diff --git a/options/AGECLASSES b/options/AGECLASSES
new file mode 100644
index 0000000000000000000000000000000000000000..8880212edf21f500c3f687c255bc05a6baf81dff
--- /dev/null
+++ b/options/AGECLASSES
@@ -0,0 +1,15 @@
+************************************************
+* *
+*Lagrangian particle dispersion model FLEXPART *
+* Please select your options *
+* *
+*This file determines the ageclasses to be used*
+* *
+*Ages are given in seconds. The first class *
+*starts at age zero and goes up to the first *
+*age specified. The last age gives the maximum *
+*time a particle is carried in the simulation. *
+* *
+************************************************
+1 Integer Number of age classes
+1728000
diff --git a/options/COMMAND b/options/COMMAND
new file mode 100644
index 0000000000000000000000000000000000000000..3a2a2928ddbb4b1ed32dc80133b5d2f4c2c96a1f
--- /dev/null
+++ b/options/COMMAND
@@ -0,0 +1,31 @@
++++++++++++++ HEADER +++++++++++++++++
++++++++++++++ HEADER +++++++++++++++++
++++++++++++++ HEADER +++++++++++++++++
++++++++++++++ HEADER +++++++++++++++++
++++++++++++++ HEADER +++++++++++++++++
++++++++++++++ HEADER +++++++++++++++++
++++++++++++++ HEADER +++++++++++++++++
+-1
+20070930 180000
+20070931 0
+ 3600
+ 3600
+ 900
+ 9999999
+900 SYNC
+-5.0 CTL
+4 IFINE
+5 IOUT
+0 IPOUT
+1 LSUBGRID
+1 LCONVECTION
+1 LAGESPECTRA
+0 IPIN
+1 IOFR
+0 IFLUX
+0 MDOMAINFILL
+1 IND_SOURCE
+2 IND_RECEPTOR
+0 MQUASILAG
+1 NESTED_OUTPUT
+2 LINIT_COND INITIAL COND. FOR BW RUNS: 0=NO,1=MASS UNIT,2=MASS MIXING RATIO UNIT
diff --git a/options/COMMAND.alternative b/options/COMMAND.alternative
new file mode 100644
index 0000000000000000000000000000000000000000..9ce5f110bf3e816be4b1a0edef6aa72d396d92b2
--- /dev/null
+++ b/options/COMMAND.alternative
@@ -0,0 +1,118 @@
+********************************************************************************
+* *
+* Input file for the Lagrangian particle dispersion model FLEXPART *
+* Please select your options *
+* *
+********************************************************************************
+
+ 1 LDIRECT 1 FOR FORWARD SIMULATION, -1 FOR BACKWARD SIMULATION
+20040720 000000 YYYYMMDD HHMISS BEGINNING DATE OF SIMULATION
+20040721 120000 YYYYMMDD HHMISS ENDING DATE OF SIMULATION
+10800 SSSSS OUTPUT EVERY SSSSS SECONDS
+10800 SSSSS TIME AVERAGE OF OUTPUT (IN SSSSS SECONDS)
+900 SSSSS SAMPLING RATE OF OUTPUT (IN SSSSS SECONDS)
+9999999 SSSSSSS TIME CONSTANT FOR PARTICLE SPLITTING (IN SECONDS)
+900 SSSSS SYNCHRONISATION INTERVAL OF FLEXPART (IN SECONDS)
+-5.0 CTL FACTOR, BY WHICH TIME STEP MUST BE SMALLER THAN TL
+4 IFINE DECREASE OF TIME STEP FOR VERTICAL MOTION BY FACTOR IFINE
+3 IOUT 1 CONC. (RESID. TIME FOR BACKWARD RUNS) OUTPUT,2 MIX. RATIO OUTPUT,3 BOTH,4 PLUME TRAJECT.,5=1+4
+0 IPOUT PARTICLE DUMP: 0 NO, 1 EVERY OUTPUT INTERVAL, 2 ONLY AT END
+1 LSUBGRID SUBGRID TERRAIN EFFECT PARAMETERIZATION: 1 YES, 0 NO
+1 LCONVECTION CONVECTION: 1 YES, 0 NO
+0 LAGESPECTRA AGE SPECTRA: 1 YES, 0 NO
+0 IPIN CONTINUE SIMULATION WITH DUMPED PARTICLE DATA: 1 YES, 0 NO
+0 IOUTPUTFOREACHREL CREATE AN OUPUT FILE FOR EACH RELEASE LOCATION: 1 YES, 0 NO
+0 IFLUX CALCULATE FLUXES: 1 YES, 0 NO
+0 MDOMAINFILL DOMAIN-FILLING TRAJECTORY OPTION: 1 YES, 0 NO
+1 IND_SOURCE 1=MASS UNIT , 2=MASS MIXING RATIO UNIT
+1 IND_RECEPTOR 1=MASS UNIT , 2=MASS MIXING RATIO UNIT
+0 MQUASILAG QUASILAGRANGIAN MODE TO TRACK INDIVIDUAL PARTICLES: 1 YES, 0 NO
+0 NESTED_OUTPUT SHALL NESTED OUTPUT BE USED? YES, 0 NO
+2 LINIT_COND INITIAL COND. FOR BW RUNS: 0=NO,1=MASS UNIT,2=MASS MIXING RATIO UNIT
+
+
+1. Simulation direction, 1 for forward, -1 for backward in time
+
+2. Beginning date and time of simulation. Must be given in format
+ YYYYMMDD HHMISS, where YYYY is YEAR, MM is MONTH, DD is DAY, HH is HOUR,
+ MI is MINUTE and SS is SECOND. Current version utilizes UTC.
+
+3. Ending date and time of simulation. Same format as 3.
+
+4. Average concentrations are calculated every SSSSS seconds.
+
+5. The average concentrations are time averages of SSSSS seconds
+ duration. If SSSSS is 0, instantaneous concentrations are outputted.
+
+6. The concentrations are sampled every SSSSS seconds to calculate the time
+ average concentration. This period must be shorter than the averaging time.
+
+7. Time constant for particle splitting. Particles are split into two
+ after SSSSS seconds, 2xSSSSS seconds, 4xSSSSS seconds, and so on.
+
+8. All processes are synchronized with this time interval (lsynctime).
+ Therefore, all other time constants must be multiples of this value.
+ Output interval and time average of output must be at least twice lsynctime.
+
+9. CTL must be >1 for time steps shorter than the Lagrangian time scale
+ If CTL<0, a purely random walk simulation is done
+
+10.IFINE=Reduction factor for time step used for vertical wind
+
+11.IOUT determines how the output shall be made: concentration
+ (ng/m3, Bq/m3), mixing ratio (pptv), or both, or plume trajectory mode,
+ or concentration + plume trajectory mode.
+ In plume trajectory mode, output is in the form of average trajectories.
+
+12.IPOUT determines whether particle positions are outputted (in addition
+ to the gridded concentrations or mixing ratios) or not.
+ 0=no output, 1 output every output interval, 2 only at end of the
+ simulation
+
+13.Switch on/off subgridscale terrain parameterization (increase of
+ mixing heights due to subgridscale orographic variations)
+
+14.Switch on/off the convection parameterization
+
+15.Switch on/off the calculation of age spectra: if yes, the file AGECLASSES
+ must be available
+
+16. If IPIN=1, a file "partposit_end" from a previous run must be available in
+ the output directory. Particle positions are read in and previous simulation
+ is continued. If IPIN=0, no particles from a previous run are used
+
+17. IF IOUTPUTFOREACHRELEASE is set to 1, one output field for each location
+ in the RLEASE file is created. For backward calculation this should be
+ set to 1. For forward calculation both possibilities are applicable.
+
+18. If IFLUX is set to 1, fluxes of each species through each of the output
+ boxes are calculated. Six fluxes, corresponding to northward, southward,
+ eastward, westward, upward and downward are calculated for each grid cell of
+ the output grid. The control surfaces are placed in the middle of each
+ output grid cell. If IFLUX is set to 0, no fluxes are determined.
+
+19. If MDOMAINFILL is set to 1, the first box specified in file RELEASES is used
+ as the domain where domain-filling trajectory calculations are to be done.
+ Particles are initialized uniformly distributed (according to the air mass
+ distribution) in that domain at the beginning of the simulation, and are
+ created at the boundaries throughout the simulation period.
+
+20. IND_SOURCE switches between different units for concentrations at the source
+ NOTE that in backward simulations the release of computational particles
+ takes place at the "receptor" and the sampling of particles at the "source".
+ 1=mass units (for bwd-runs = concentration)
+ 2=mass mixing ratio units
+21. IND_RECEPTOR switches between different units for concentrations at the receptor
+ 1=mass units (concentrations)
+ 2=mass mixing ratio units
+
+22. MQUASILAG indicates whether particles shall be numbered consecutively (1) or
+ with their release location number (0). The first option allows tracking of
+ individual particles using the partposit output files
+
+23. NESTED_OUTPUT decides whether model output shall be made also for a nested
+ output field (normally with higher resolution)
+
+24. LINIT_COND determines whether, for backward runs only, the sensitivity to initial
+ conditions shall be calculated and written to output files
+ 0=no output, 1 or 2 determines in which units the initial conditions are provided.
diff --git a/options/COMMAND.reference b/options/COMMAND.reference
new file mode 100644
index 0000000000000000000000000000000000000000..f5d5e1e8e6da7b8c7f8eaf331c355c0ef542fd3f
--- /dev/null
+++ b/options/COMMAND.reference
@@ -0,0 +1,190 @@
+********************************************************************************
+* *
+* Input file for the Lagrangian particle dispersion model FLEXPART *
+* Please select your options *
+* *
+********************************************************************************
+
+1. __ 3X, I2
+ 1
+ LDIRECT 1 FOR FORWARD SIMULATION, -1 FOR BACKWARD SIMULATION
+
+2. ________ ______ 3X, I8, 1X, I6
+ 20040720 000000
+ YYYYMMDD HHMISS BEGINNING DATE OF SIMULATION
+
+3. ________ ______ 3X, I8, 1X, I6
+ 20040721 120000
+ YYYYMMDD HHMISS ENDING DATE OF SIMULATION
+
+4. _____ 3X, I5
+ 10800
+ SSSSS OUTPUT EVERY SSSSS SECONDS
+
+5. _____ 3X, I5
+ 10800
+ SSSSS TIME AVERAGE OF OUTPUT (IN SSSSS SECONDS)
+
+6. _____ 3X, I5
+ 900
+ SSSSS SAMPLING RATE OF OUTPUT (IN SSSSS SECONDS)
+
+7. _________ 3X, I9
+ 999999999
+ SSSSSSSSS TIME CONSTANT FOR PARTICLE SPLITTING (IN SECONDS)
+
+8. _____ 3X, I5
+ 900
+ SSSSS SYNCHRONISATION INTERVAL OF FLEXPART (IN SECONDS)
+
+9. ---.-- 4X, F6.4
+ -5.0
+ CTL FACTOR, BY WHICH TIME STEP MUST BE SMALLER THAN TL
+
+10. --- 4X, I3
+ 4
+ IFINE DECREASE OF TIME STEP FOR VERTICAL MOTION BY FACTOR IFINE
+
+11. - 4X, I1
+ 3
+ IOUT 1 CONCENTRATION (RESIDENCE TIME FOR BACKWARD RUNS) OUTPUT, 2 MIXING RATIO OUTPUT, 3 BOTH,4 PLUME TRAJECT., 5=1+4
+
+12. - 4X, I1
+ 0
+ IPOUT PARTICLE DUMP: 0 NO, 1 EVERY OUTPUT INTERVAL, 2 ONLY AT END
+
+13. _ 4X, I1
+ 1
+ LSUBGRID SUBGRID TERRAIN EFFECT PARAMETERIZATION: 1 YES, 0 NO
+
+14. _ 4X, I1
+ 1
+ LCONVECTION CONVECTION: 1 YES, 0 NO
+
+15. _ 4X, I1
+ 0
+ LAGESPECTRA AGE SPECTRA: 1 YES, 0 NO
+
+16. _ 4X, I1
+ 0
+ IPIN CONTINUE SIMULATION WITH DUMPED PARTICLE DATA: 1 YES, 0 NO
+
+17. _
+ 0 4X,I1
+ IOFR IOUTPUTFOREACHREL CREATE AN OUPUT FILE FOR EACH RELEASE LOCATION: 1 YES, 0 NO
+
+18. _ 4X, I1
+ 0
+ IFLUX CALCULATE FLUXES: 1 YES, 0 NO
+
+19. _ 4X, I1
+ 0
+ MDOMAINFILL DOMAIN-FILLING TRAJECTORY OPTION: 1 YES, 0 NO, 2 STRAT. O3 TRACER
+
+20. _ 4X, I1
+ 1
+ IND_SOURCE 1=MASS UNIT , 2=MASS MIXING RATIO UNIT
+
+21. _ 4X, I1
+ 1
+ IND_RECEPTOR 1=MASS UNIT , 2=MASS MIXING RATIO UNIT
+
+22. _ 4X, I1
+ 0
+ MQUASILAG QUASILAGRANGIAN MODE TO TRACK INDIVIDUAL PARTICLES: 1 YES, 0 NO
+
+23. _ 4X, I1
+ 0
+ NESTED_OUTPUT SHALL NESTED OUTPUT BE USED? 1 YES, 0 NO
+
+24. _ 4X, I1
+ 2
+ LINIT_COND INITIAL COND. FOR BW RUNS: 0=NO,1=MASS UNIT,2=MASS MIXING RATIO UNIT
+
+
+1. Simulation direction, 1 for forward, -1 for backward in time
+ (consult Seibert and Frank, 2004 for backward runs)
+
+2. Beginning date and time of simulation. Must be given in format
+ YYYYMMDD HHMISS, where YYYY is YEAR, MM is MONTH, DD is DAY, HH is HOUR,
+ MI is MINUTE and SS is SECOND. Current version utilizes UTC.
+
+3. Ending date and time of simulation. Same format as 3.
+
+4. Average concentrations are calculated every SSSSS seconds.
+
+5. The average concentrations are time averages of SSSSS seconds
+ duration. If SSSSS is 0, instantaneous concentrations are outputted.
+
+6. The concentrations are sampled every SSSSS seconds to calculate the time
+ average concentration. This period must be shorter than the averaging time.
+
+7. Time constant for particle splitting. Particles are split into two
+ after SSSSS seconds, 2xSSSSS seconds, 4xSSSSS seconds, and so on.
+
+8. All processes are synchronized with this time interval (lsynctime).
+ Therefore, all other time constants must be multiples of this value.
+ Output interval and time average of output must be at least twice lsynctime.
+
+9. CTL must be >1 for time steps shorter than the Lagrangian time scale
+ If CTL<0, a purely random walk simulation is done
+
+10.IFINE=Reduction factor for time step used for vertical wind
+
+11.IOUT determines how the output shall be made: concentration
+ (ng/m3, Bq/m3), mixing ratio (pptv), or both, or plume trajectory mode,
+ or concentration + plume trajectory mode.
+ In plume trajectory mode, output is in the form of average trajectories.
+
+12.IPOUT determines whether particle positions are outputted (in addition
+ to the gridded concentrations or mixing ratios) or not.
+ 0=no output, 1 output every output interval, 2 only at end of the
+ simulation
+
+13.Switch on/off subgridscale terrain parameterization (increase of
+ mixing heights due to subgridscale orographic variations)
+
+14.Switch on/off the convection parameterization
+
+15.Switch on/off the calculation of age spectra: if yes, the file AGECLASSES
+ must be available
+
+16. If IPIN=1, a file "partposit_end" from a previous run must be available in
+ the output directory. Particle positions are read in and previous simulation
+ is continued. If IPIN=0, no particles from a previous run are used
+
+17. IF IOUTPUTFOREACHRELEASE is set to 1, one output field for each location
+ in the RLEASE file is created. For backward calculation this should be
+ set to 1. For forward calculation both possibilities are applicable.
+
+18. If IFLUX is set to 1, fluxes of each species through each of the output
+ boxes are calculated. Six fluxes, corresponding to northward, southward,
+ eastward, westward, upward and downward are calculated for each grid cell of
+ the output grid. The control surfaces are placed in the middle of each
+ output grid cell. If IFLUX is set to 0, no fluxes are determined.
+
+19. If MDOMAINFILL is set to 1, the first box specified in file RELEASES is used
+ as the domain where domain-filling trajectory calculations are to be done.
+ Particles are initialized uniformly distributed (according to the air mass
+ distribution) in that domain at the beginning of the simulation, and are
+ created at the boundaries throughout the simulation period.
+
+20. IND_SOURCE switches between different units for concentrations at the source
+ NOTE that in backward simulations the release of computational particles
+ takes place at the "receptor" and the sampling of particles at the "source".
+ 1=mass units (for bwd-runs = concentration)
+ 2=mass mixing ratio units
+21. IND_RECEPTOR switches between different units for concentrations at the receptor
+ 1=mass units (concentrations)
+ 2=mass mixing ratio units
+
+22. MQUASILAG indicates whether particles shall be numbered consecutively (1) or
+ with their release location number (0). The first option allows tracking of
+ individual particles using the partposit output files
+
+23. NESTED_OUTPUT decides whether model output shall be made also for a nested
+ output field (normally with higher resolution)
+
+24. LINIT_COND determines whether, for backward runs only, the sensitivity to initial
+ conditions shall be calculated and written to output files
+ 0=no output, 1 or 2 determines in which units the initial conditions are provided.
diff --git a/options/IGBP_int1.dat b/options/IGBP_int1.dat
new file mode 100644
index 0000000000000000000000000000000000000000..089a3dd57efec5ae30eddb9b2eae8c8498df0279
Binary files /dev/null and b/options/IGBP_int1.dat differ
diff --git a/options/OH_7lev_agl.dat b/options/OH_7lev_agl.dat
new file mode 100644
index 0000000000000000000000000000000000000000..d5c6e11ad191900eaa314e0fa0bfe3dfc864db25
Binary files /dev/null and b/options/OH_7lev_agl.dat differ
diff --git a/options/OUTGRID b/options/OUTGRID
new file mode 100644
index 0000000000000000000000000000000000000000..b3f68434181df9ee6c5b5ac923cc6a6f85502971
--- /dev/null
+++ b/options/OUTGRID
@@ -0,0 +1,43 @@
+********************************************************************************
+* *
+* Input file for the Lagrangian particle dispersion model FLEXPART *
+* Please specify your output grid *
+* *
+********************************************************************************
+
+1. ------.---- 4X,F11.4
+ -179.0000 GEOGRAFICAL LONGITUDE OF LOWER LEFT CORNER OF OUTPUT GRID
+ OUTLONLEFT (left boundary of the first grid cell - not its centre)
+
+2. ------.---- 4X,F11.4
+ -90.0000 GEOGRAFICAL LATITUDE OF LOWER LEFT CORNER OF OUTPUT GRID
+ OUTLATLOWER (lower boundary of the first grid cell - not its centre)
+
+3. ----- 4X,I5
+ 360 NUMBER OF GRID POINTS IN X DIRECTION (= No. of cells + 1)
+ NUMXGRID
+
+4. ----- 4X,I5
+ 180 NUMBER OF GRID POINTS IN Y DIRECTION (= No. of cells + 1)
+ NUMYGRID
+
+5. ------.--- 4X,F10.3
+ 1.000 GRID DISTANCE IN X DIRECTION
+ DXOUTLON
+
+6. ------.--- 4X,F10.3
+ 1.000 GRID DISTANCE IN Y DIRECTION
+ DYOUTLAT
+
+10. -----.- 4X, F7.1
+ 100.0
+ LEVEL 4 HEIGHT OF LEVEL (UPPER BOUNDARY)
+
+10. -----.- 4X, F7.1
+ 3000.0
+ LEVEL 4 HEIGHT OF LEVEL (UPPER BOUNDARY)
+
+10. -----.- 4X, F7.1
+ 50000.0
+ LEVEL 4 HEIGHT OF LEVEL (UPPER BOUNDARY)
+
diff --git a/options/OUTGRID_NEST b/options/OUTGRID_NEST
new file mode 100644
index 0000000000000000000000000000000000000000..ae675b5c895eb7628b85d2a5c787eac2891dd669
--- /dev/null
+++ b/options/OUTGRID_NEST
@@ -0,0 +1,30 @@
+********************************************************************************
+* *
+* Input file for the Lagrangian particle dispersion model FLEXPART *
+* Please specify your output grid *
+* *
+********************************************************************************
+
+1. ------.---- 4X,F11.4
+ -15.0000 GEOGRAFICAL LONGITUDE OF LOWER LEFT CORNER OF OUTPUT GRID
+ OUTLONLEFT (left boundary of the first grid cell - not its centre)
+
+2. ------.---- 4X,F11.4
+ 35.0000 GEOGRAFICAL LATITUDE OF LOWER LEFT CORNER OF OUTPUT GRID
+ OUTLATLOWER (lower boundary of the first grid cell - not its centre)
+
+3. ----- 4X,I5
+ 220 NUMBER OF GRID POINTS IN X DIRECTION (= No. of cells + 1)
+ NUMXGRID
+
+4. ----- 4X,I5
+ 120 NUMBER OF GRID POINTS IN Y DIRECTION (= No. of cells + 1)
+ NUMYGRID
+
+5. ------.----- 4X,F12.5
+ 0.25000 GRID DISTANCE IN X DIRECTION
+ DXOUTLON
+
+6. ------.----- 4X,F12.5
+ 0.25000 GRID DISTANCE IN Y DIRECTION
+ DYOUTLAT
diff --git a/options/RECEPTORS b/options/RECEPTORS
new file mode 100644
index 0000000000000000000000000000000000000000..3b9b5af341fbdf8a74d99b33a7d6df2a9e9a1d5b
--- /dev/null
+++ b/options/RECEPTORS
@@ -0,0 +1,79 @@
+********************************************************************************
+* *
+* Input file for the Lagrangian particle dispersion model FLEXPART *
+* Please specify your receptor points *
+* For the receptor points, ground level concentrations are calculated *
+* *
+********************************************************************************
+1. ---------------- 4X,A16
+ F15 NAME OF RECEPTOR POINT
+ RECEPTORNAME
+
+2. ------.---- 4X,F11.4
+ 6.1333 GEOGRAFICAL LONGITUDE
+ XRECEPTOR
+
+3. ------.---- 4X,F11.4
+ 49.0833 GEOGRAFICAL LATITUDE
+ YRECEPTOR
+================================================================================
+1. ---------------- 4X,A16
+ NL01 NAME OF RECEPTOR POINT
+ RECEPTORNAME
+
+2. ------.---- 4X,F11.4
+ 5.7833 GEOGRAFICAL LONGITUDE
+ XRECEPTOR
+
+3. ------.---- 4X,F11.4
+ 50.9167 GEOGRAFICAL LATITUDE
+ YRECEPTOR
+================================================================================
+1. ---------------- 4X,A16
+ B05 NAME OF RECEPTOR POINT
+ RECEPTORNAME
+
+2. ------.---- 4X,F11.4
+ 4.3500 GEOGRAFICAL LONGITUDE
+ XRECEPTOR
+
+3. ------.---- 4X,F11.4
+ 50.8000 GEOGRAFICAL LATITUDE
+ YRECEPTOR
+================================================================================
+1. ---------------- 4X,A16
+ D27 NAME OF RECEPTOR POINT
+ RECEPTORNAME
+
+2. ------.---- 4X,F11.4
+ 11.1333 GEOGRAFICAL LONGITUDE
+ XRECEPTOR
+
+3. ------.---- 4X,F11.4
+ 52.9667 GEOGRAFICAL LATITUDE
+ YRECEPTOR
+================================================================================
+1. ---------------- 4X,A16
+ D08 NAME OF RECEPTOR POINT
+ RECEPTORNAME
+
+2. ------.---- 4X,F11.4
+ 8.7000 GEOGRAFICAL LONGITUDE
+ XRECEPTOR
+
+3. ------.---- 4X,F11.4
+ 53.8667 GEOGRAFICAL LATITUDE
+ YRECEPTOR
+================================================================================
+1. ---------------- 4X,A16
+ DK05 NAME OF RECEPTOR POINT
+ RECEPTORNAME
+
+2. ------.---- 4X,F11.4
+ 8.1333 GEOGRAFICAL LONGITUDE
+ XRECEPTOR
+
+3. ------.---- 4X,F11.4
+ 56.0000 GEOGRAFICAL LATITUDE
+ YRECEPTOR
+================================================================================
diff --git a/options/RELEASES b/options/RELEASES
new file mode 100644
index 0000000000000000000000000000000000000000..1190e77a1e8dc7ab61966a820f87d3a1ac116711
--- /dev/null
+++ b/options/RELEASES
@@ -0,0 +1,868 @@
++++++++++++++++++ HEADER ++++++++++++++++++++
++++++++++++++++++ HEADER ++++++++++++++++++++
++++++++++++++++++ HEADER ++++++++++++++++++++
++++++++++++++++++ HEADER ++++++++++++++++++++
++++++++++++++++++ HEADER ++++++++++++++++++++
++++++++++++++++++ HEADER ++++++++++++++++++++
++++++++++++++++++ HEADER ++++++++++++++++++++
++++++++++++++++++ HEADER ++++++++++++++++++++
++++++++++++++++++ HEADER ++++++++++++++++++++
++++++++++++++++++ HEADER ++++++++++++++++++++
++++++++++++++++++ HEADER ++++++++++++++++++++
+5
+31
+31
+31
+31
+31
+
+20040101 080000
+20040102 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20040108 080000
+20040109 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20040115 080000
+20040116 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20040122 080000
+20040123 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20040129 080000
+20040130 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20040205 080000
+20040206 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20040212 080000
+20040213 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20040219 080000
+20040220 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20040226 080000
+20040227 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20040304 080000
+20040305 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20040311 080000
+20040312 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20040318 080000
+20040319 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20040325 080000
+20040326 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20040401 080000
+20040402 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20040408 080000
+20040409 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20040415 080000
+20040416 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20040422 080000
+20040423 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20040429 080000
+20040430 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20040609 080000
+20040610 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20040610 080000
+20040611 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20040617 080000
+20040618 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20040624 080000
+20040625 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20040701 080000
+20040702 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20040708 080000
+20040709 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20040715 080000
+20040716 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20040722 080000
+20040723 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20040729 080000
+20040730 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20040805 080000
+20040806 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20040812 080000
+20040813 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20040819 080000
+20040820 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20040826 080000
+20040827 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20040902 080000
+20040903 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20040909 080000
+20040910 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20040916 080000
+20040917 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20040923 080000
+20040924 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20040930 080000
+20041001 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20041007 080000
+20041008 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20041014 080000
+20041015 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20041021 080000
+20041022 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20041028 080000
+20041029 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20041104 080000
+20041105 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20041111 080000
+20041112 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20041118 080000
+20041119 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20041124 080000
+20041125 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20041125 080000
+20041126 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20041208 080000
+20041209 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20041209 080000
+20041210 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20041216 080000
+20041217 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20041223 080000
+20041224 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
+20041230 080000
+20041231 080000
+ 8.2500
+ 58.3833
+ 8.2500
+ 58.3833
+1
+ 0.000
+ 100.000
+4000
+1
+1
+1
+1
+1
+rel_bj
+
diff --git a/options/RELEASES.alternative b/options/RELEASES.alternative
new file mode 100644
index 0000000000000000000000000000000000000000..529888af7d8d0c49bfc01d28f9e8138c98fd69a8
--- /dev/null
+++ b/options/RELEASES.alternative
@@ -0,0 +1,40 @@
+*************************************************************************
+* *
+* *
+* *
+* Input file for the Lagrangian particle dispersion model FLEXPART *
+* Please select your options *
+* *
+* *
+* *
+*************************************************************************
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+1 Total number of species emitted
+24 Index of species in file SPECIES
+=========================================================================
+ 20011028 150007
+ 20011028 150046
+ 9.40480
+ 48.5060
+ 9.50670
+ 48.5158
+ 2
+ 6933.60
+ 6950.40
+ 20000
+ 1.00000
+FLIGHT_11242
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ 20011028 150047
+ 20011028 150107
+ 9.30380
+ 48.5158
+ 9.40480
+ 48.5906
+ 2
+ 6833.50
+ 6950.40
+ 20000
+ 1.00000
+FLIGHT_11185
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
diff --git a/options/RELEASES.reference b/options/RELEASES.reference
new file mode 100644
index 0000000000000000000000000000000000000000..912fce22b1b65b5cea4746c8b12130038fd675ec
--- /dev/null
+++ b/options/RELEASES.reference
@@ -0,0 +1,90 @@
+*************************************************************************
+* *
+* *
+* *
+* Input file for the Lagrangian particle dispersion model FLEXPART *
+* Please select your options *
+* *
+* *
+* *
+*************************************************************************
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ 1
+___ i3 Total number of species emitted
+
+ 24
+___ i3 Index of species in file SPECIES
+
+=========================================================================
+20040720 0
+________ ______ i8,1x,i6 Beginning date and time of release
+
+20040720 120000
+________ ______ i8,1x,i6 Ending date and time of release
+
+ 9.4048
+____.____ f9.4 Longitude [DEG] of lower left corner
+
+ 48.5060
+____.____ f9.4 Latitude [DEG] of lower left corner
+
+ 9.5067
+____.____ f9.4 Longitude [DEG] of upper right corner
+
+ 48.5158
+____.____ f9.4 Latitude [DEG] of upper right corner
+
+ 2
+_________ i9 1 for m above ground, 2 for m above sea level
+
+ 6933.60
+_____.___ f10.3 Lower z-level (in m agl or m asl)
+
+ 6950.40
+_____.___ f10.3 Upper z-level (in m agl or m asl)
+
+ 20000
+_________ i9 Total number of particles to be released
+
+1.0000E00
+_.____E__ e9.4 Total mass emitted
+
+RELEASE_TEST1
+________________________________________ character*40 comment
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+20040720 0
+________ ______ i8,1x,i6 Beginning date and time of release
+
+20040720 120000
+________ ______ i8,1x,i6 Ending date and time of release
+
+ 9.3038
+____.____ f9.4 Longitude [DEG] of lower left corner
+
+ 48.5158
+____.____ f9.4 Latitude [DEG] of lower left corner
+
+ 9.4048
+____.____ f9.4 Longitude [DEG] of upper right corner
+
+ 48.5906
+____.____ f9.4 Latitude [DEG] of upper right corner
+
+ 2
+_________ i9 1 for m above ground, 2 for m above sea level
+
+ 6833.50
+_____.___ f10.3 Lower z-level (in m agl or m asl)
+
+ 6950.40
+_____.___ f10.3 Upper z-level (in m agl or m asl)
+
+ 20000
+_________ i9 Total number of particles to be released
+
+1.0000E00
+_.____E__ e9.4 Total mass emitted
+
+RELEASE_TEST2
+________________________________________ character*40 comment
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
diff --git a/options/SPECIES/SPECIES.orig b/options/SPECIES/SPECIES.orig
new file mode 100644
index 0000000000000000000000000000000000000000..ab91645e8d9cce03b0c2c8405b82daa496caf867
--- /dev/null
+++ b/options/SPECIES/SPECIES.orig
@@ -0,0 +1,47 @@
+****************************************************************************
+* *
+* Input file for the Lagrangian particle dispersion model FLEXPART *
+* Definition file of chemical species/radionuclides *
+* *
+****************************************************************************
+ Radioactivity Wet depo Dry depo (gases) Dry depo (particles) Dry depo OH React
+ SPECIES HALF LIFE [s] A B D H f0 rho dquer dsig vd molweight [cm^3/s]
+ 50 TRACER1234567 1234.6 -2.4E-08 1.34 -2.4 1.3e-07 1.3 -2.4E07 1.3E-6 1.3E-6 -2.45 123.45 -2.4E-08
+ 1 TRACER -999.9 -9.9E-09 -9.9 -9.9E09 -9.99 350.00 -9.9E-09
+ 2 O3 -999.9 -9.9E-09 1.5 1.0e-02 1.0 -9.9E09 -9.99 48.00 -9.9E-09
+ 3 NO -999.9 8.0E-06 0.62 1.2 3.0e-03 0.0 -9.9E09 -9.99 30.00 -9.9E-09
+ 4 NO2 -999.9 1.0E-05 0.62 1.6 1.0e-02 0.1 -9.9E09 -9.99 46.00 -9.9E-09
+ 5 HNO3 -999.9 5.0E-05 0.62 1.9 1.0e+14 0.0 -9.9E09 -9.99 63.00 -9.9E-09
+ 6 HNO2 -999.9 -9.9E-09 1.6 1.0e+05 0.1 -9.9E09 -9.99 47.00 -9.9E-09
+ 7 H2O2 -999.9 1.0E-04 0.62 1.4 1.0e+05 1.0 -9.9E09 -9.99 34.00 -9.9E-09
+ 8 SO2 -999.9 -9.9E-09 0.62 2.0 1.0e+05 0.0 -9.9E09 -9.99 64.00 -9.9E-09
+ 9 HCHO -999.9 -9.9E-09 1.3 6.0e+03 0.0 -9.9E09 -9.99 30.00 -9.9E-09
+ 10 PAN -999.9 -9.9E-09 2.6 3.6e+00 0.1 -9.9E09 -9.99 121.00 -9.9E-09
+ 11 NH3 -999.9 9.9E-05 0.62 1.1 2.0e+14 0.0 -9.9E09 -9.99 17.00 -9.9E-09
+ 12 SO4-aero -999.9 5.0E-06 0.62 -9.9 2.0E03 4.0E-7 3.0E-1 -9.99 -9.99 -9.9E-09
+ 13 NO3-aero -999.9 5.0E-06 0.62 -9.9 2.0E03 4.0E-7 3.0E-1 -9.99 -9.99 -9.9E-09
+ 14 I2-131 691200.0 8.0E-05 0.62 2.7 1.0e+05 0.1 -9.9E09 -9.99 -9.99 -9.9E-09
+ 15 I-131 691200.0 1.0E-04 0.80 -9.9 2.5E03 6.0E-7 3.0E-1 -9.99 -9.99 -9.9E-09
+ 16 Cs-137 -999.9 1.0E-04 0.80 -9.9 2.5E03 6.0E-7 3.0E-1 -9.99 -9.99 -9.9E-09
+ 17 Y-91 5037120.0 1.0E-04 0.80 -9.9 2.5E03 6.0E-7 3.0E-1 -9.99 -9.99 -9.9E-09
+ 18 Ru-106 31536000.0 1.0E-04 0.80 -9.9 2.5E03 6.0E-7 3.0E-1 -9.99 -9.99 -9.9E-09
+ 19 Kr-85 -999.9 -9.9E-09 -9.9 -9.9E09 -9.99 -9.99 -9.9E-09
+ 20 Sr-90 -999.9 1.0E-04 0.80 -9.9 2.5E03 6.0E-7 3.0E-1 -9.99 -9.99 -9.9E-09
+ 21 Xe-133 198720.0 -9.9E-09 -9.9 -9.9E09 -9.99 -9.99 -9.9E-09
+ 22 CO -999.9 -9.9E-09 -9.9 -9.9E09 -9.99 28.00 1.5E-13
+ 23 NO2TRACER -999.9 -9.9E-09 -9.9 -9.9E09 -9.99 46.00 -9.9E-09
+ 24 AIRTRACER -999.9 -9.9E-09 -9.9 -9.9E09 -9.99 29.00 -9.9E-09
+ 25 NA-CO -999.9 -9.9E-09 -9.9 -9.9E09 -9.99 28.00 -9.9E-09
+ 26 EU-CO -999.9 -9.9E-09 -9.9 -9.9E09 -9.99 28.00 -9.9E-09
+ 27 AS-CO -999.9 -9.9E-09 -9.9 -9.9E09 -9.99 28.00 -9.9E-09
+ 28 SO2TRACER -999.9 -9.9E-09 -9.9 -9.9E09 -9.99 64.00 -9.9E-09
+ 29 WET_TRAC -999.9 1E-04 0.62 -9.9 -9.9E09 -9.99 100.00 -9.9E-09
+ 30 DRY_TRAC 3999.9 -9.9E-09 2.0 1.0e-02 1.0 -9.9E09 -9.99 100.00 -9.9E-09
+ 31 PCB28 -999.9 5E-06 0.62 3.8 3.1e-00 0.0 -9.9E09 -9.99 257.54 1.1E-12
+ 32 PCB101 -999.9 5E-06 0.62 4.3 3.2e-00 0.0 -9.9E09 -9.99 326.43 3.4E-13
+ 33 PCB180 -999.9 5E-06 0.62 4.7 1.7e+01 0.0 -9.9E09 -9.99 395.32 1.1E-13
+ 34 G-HCH -999.9 -9.9E-09 -9.9 -9.9E09 -9.99 999.99 9.9E-99
+ 35 TEST 1000.0 1E-02 0.62 2.0 1.0e-02 1.0 -9.9E09 -9.99 100.00 1.0E+02
+ 36 PCB28-TEST -999.9 -9.9E-09 0.62 -9.9 3.1e-00 0.0 -9.9E09 -9.99 257.54 1.1E-12
+ 37 HNO3 -999.9 -8.0E-04 0.62 -9.9 -9.9E09 -9.99 63.00 -9.9E-09
+
diff --git a/options/SPECIES/SPECIES_001 b/options/SPECIES/SPECIES_001
new file mode 100644
index 0000000000000000000000000000000000000000..a145a58a0952fb1059cfad05ec65d3ffc4f95b53
--- /dev/null
+++ b/options/SPECIES/SPECIES_001
@@ -0,0 +1,21 @@
+****************************************************************************
+* *
+* Input file for the Lagrangian particle dispersion model FLEXPART *
+* Definition file of chemical species/radionuclides *
+* *
+****************************************************************************
+TRACER Tracer name
+-999.9 Species half life
+-9.9E-09 Wet deposition - A
+ Wet deposition - B
+-9.9 Dry deposition (gases) - D
+ Dry deposition (gases) - Henrys const.
+ Dry deposition (gases) - f0 (reactivity)
+-9.9E09 Dry deposition (particles) - rho
+ Dry deposition (particles) - dquer
+ Dry deposition (particles) - dsig
+-9.99 Alternative: dry deposition velocity
+350.00 molweight
+-9.9E-09 OH Reaction rate at 25 deg, [cm^3/sec]
+-9 number of associated specias (neg. none)
+-99.99 KOA - organic matter air partitioning
diff --git a/options/SPECIES/SPECIES_002 b/options/SPECIES/SPECIES_002
new file mode 100644
index 0000000000000000000000000000000000000000..301ad853f4794af2e1d3d64bdca1b7f4ff5983ee
--- /dev/null
+++ b/options/SPECIES/SPECIES_002
@@ -0,0 +1,21 @@
+****************************************************************************
+* *
+* Input file for the Lagrangian particle dispersion model FLEXPART *
+* Definition file of chemical species/radionuclides *
+* *
+****************************************************************************
+O3 Tracer name
+-999.9 Species half life
+-9.9E-09 Wet deposition - A
+ Wet deposition - B
+ 1.5 Dry deposition (gases) - D
+1.0e-02 Dry deposition (gases) - Henrys const.
+1.0 Dry deposition (gases) - f0 (reactivity)
+-9.9E09 Dry deposition (particles) - rho
+ Dry deposition (particles) - dquer
+ Dry deposition (particles) - dsig
+-9.99 Alternative: dry deposition velocity
+ 48.00 molweight
+-9.9E-09 OH Reaction rate at 25 deg, [cm^3/sec]
+-9 number of associated specias (neg. none)
+-99.99 KOA - organic matter air partitioning
diff --git a/options/SPECIES/SPECIES_003 b/options/SPECIES/SPECIES_003
new file mode 100644
index 0000000000000000000000000000000000000000..76ee4c40e985d012602ca058b28db8ad38763f41
--- /dev/null
+++ b/options/SPECIES/SPECIES_003
@@ -0,0 +1,21 @@
+****************************************************************************
+* *
+* Input file for the Lagrangian particle dispersion model FLEXPART *
+* Definition file of chemical species/radionuclides *
+* *
+****************************************************************************
+NO Tracer name
+-999.9 Species half life
+ 8.0E-06 Wet deposition - A
+0.62 Wet deposition - B
+ 1.2 Dry deposition (gases) - D
+3.0e-03 Dry deposition (gases) - Henrys const.
+0.0 Dry deposition (gases) - f0 (reactivity)
+-9.9E09 Dry deposition (particles) - rho
+ Dry deposition (particles) - dquer
+ Dry deposition (particles) - dsig
+-9.99 Alternative: dry deposition velocity
+ 30.00 molweight
+-9.9E-09 OH Reaction rate at 25 deg, [cm^3/sec]
+-9 number of associated specias (neg. none)
+-99.99 KOA - organic matter air partitioning
diff --git a/options/SPECIES/SPECIES_004 b/options/SPECIES/SPECIES_004
new file mode 100644
index 0000000000000000000000000000000000000000..496275335b0d692bb13e4248824838abd52fd6ab
--- /dev/null
+++ b/options/SPECIES/SPECIES_004
@@ -0,0 +1,21 @@
+****************************************************************************
+* *
+* Input file for the Lagrangian particle dispersion model FLEXPART *
+* Definition file of chemical species/radionuclides *
+* *
+****************************************************************************
+NO2 Tracer name
+-999.9 Species half life
+ 1.0E-05 Wet deposition - A
+0.62 Wet deposition - B
+ 1.6 Dry deposition (gases) - D
+1.0e-02 Dry deposition (gases) - Henrys const.
+0.1 Dry deposition (gases) - f0 (reactivity)
+-9.9E09 Dry deposition (particles) - rho
+ Dry deposition (particles) - dquer
+ Dry deposition (particles) - dsig
+-9.99 Alternative: dry deposition velocity
+ 46.00 molweight
+-9.9E-09 OH Reaction rate at 25 deg, [cm^3/sec]
+-9 number of associated specias (neg. none)
+-99.99 KOA - organic matter air partitioning
diff --git a/options/SPECIES/SPECIES_005 b/options/SPECIES/SPECIES_005
new file mode 100644
index 0000000000000000000000000000000000000000..a945240869a6d820770353090a00c2dbd9842b9e
--- /dev/null
+++ b/options/SPECIES/SPECIES_005
@@ -0,0 +1,21 @@
+****************************************************************************
+* *
+* Input file for the Lagrangian particle dispersion model FLEXPART *
+* Definition file of chemical species/radionuclides *
+* *
+****************************************************************************
+HNO3 Tracer name
+-999.9 Species half life
+ 5.0E-05 Wet deposition - A
+0.62 Wet deposition - B
+ 1.9 Dry deposition (gases) - D
+1.0e+14 Dry deposition (gases) - Henrys const.
+0.0 Dry deposition (gases) - f0 (reactivity)
+-9.9E09 Dry deposition (particles) - rho
+ Dry deposition (particles) - dquer
+ Dry deposition (particles) - dsig
+-9.99 Alternative: dry deposition velocity
+ 63.00 molweight
+-9.9E-09 OH Reaction rate at 25 deg, [cm^3/sec]
+-9 number of associated specias (neg. none)
+-99.99 KOA - organic matter air partitioning
diff --git a/options/SPECIES/SPECIES_006 b/options/SPECIES/SPECIES_006
new file mode 100644
index 0000000000000000000000000000000000000000..d5059a1564a1ba1290cd586adc7c573a98c8a317
--- /dev/null
+++ b/options/SPECIES/SPECIES_006
@@ -0,0 +1,21 @@
+****************************************************************************
+* *
+* Input file for the Lagrangian particle dispersion model FLEXPART *
+* Definition file of chemical species/radionuclides *
+* *
+****************************************************************************
+HNO2 Tracer name
+-999.9 Species half life
+-9.9E-09 Wet deposition - A
+ Wet deposition - B
+ 1.6 Dry deposition (gases) - D
+1.0e+05 Dry deposition (gases) - Henrys const.
+0.1 Dry deposition (gases) - f0 (reactivity)
+-9.9E09 Dry deposition (particles) - rho
+ Dry deposition (particles) - dquer
+ Dry deposition (particles) - dsig
+-9.99 Alternative: dry deposition velocity
+ 47.00 molweight
+-9.9E-09 OH Reaction rate at 25 deg, [cm^3/sec]
+-9 number of associated specias (neg. none)
+-99.99 KOA - organic matter air partitioning
diff --git a/options/SPECIES/SPECIES_007 b/options/SPECIES/SPECIES_007
new file mode 100644
index 0000000000000000000000000000000000000000..5452eab59799e7e3620097527b9b38895ddce4df
--- /dev/null
+++ b/options/SPECIES/SPECIES_007
@@ -0,0 +1,21 @@
+****************************************************************************
+* *
+* Input file for the Lagrangian particle dispersion model FLEXPART *
+* Definition file of chemical species/radionuclides *
+* *
+****************************************************************************
+H2O2 Tracer name
+-999.9 Species half life
+ 1.0E-04 Wet deposition - A
+0.62 Wet deposition - B
+ 1.4 Dry deposition (gases) - D
+1.0e+05 Dry deposition (gases) - Henrys const.
+1.0 Dry deposition (gases) - f0 (reactivity)
+-9.9E09 Dry deposition (particles) - rho
+ Dry deposition (particles) - dquer
+ Dry deposition (particles) - dsig
+-9.99 Alternative: dry deposition velocity
+ 34.00 molweight
+-9.9E-09 OH Reaction rate at 25 deg, [cm^3/sec]
+-9 number of associated specias (neg. none)
+-99.99 KOA - organic matter air partitioning
diff --git a/options/SPECIES/SPECIES_008 b/options/SPECIES/SPECIES_008
new file mode 100644
index 0000000000000000000000000000000000000000..9ac00092fe37238787f4b558c1a3b1b757f17d8a
--- /dev/null
+++ b/options/SPECIES/SPECIES_008
@@ -0,0 +1,54 @@
+****************************************************************************
+* *
+* Input file for the Lagrangian particle dispersion model FLEXPART *
+* Definition file of chemical species/radionuclides *
+* *
+****************************************************************************
+SO2 Tracer name
+-999.9 Species half life
+-9.9E-09 Wet deposition - A
+0.62 Wet deposition - B
+ 2.0 Dry deposition (gases) - D
+1.0e+05 Dry deposition (gases) - Henrys const.
+0.0 Dry deposition (gases) - f0 (reactivity)
+-9.9E09 Dry deposition (particles) - rho
+ Dry deposition (particles) - dquer
+ Dry deposition (particles) - dsig
+-9.99 Alternative: dry deposition velocity
+ 64.00 molweight
+-9.9E-09 OH Reaction rate at 25 deg, [cm^3/sec]
+-9 number of associated specias (neg. none)
+-99.99 KOA - organic matter air partitioning
+hr_start so2_area so2_point
+ 0 0.636 0.814 0-1 local time
+ 1 0.571 0.767 1-2 local time
+ 2 0.523 0.743
+ 3 0.495 0.735
+ 4 0.507 0.751
+ 5 0.577 0.798
+ 6 0.732 0.873
+ 7 0.929 0.976
+ 8 1.015 1.037
+ 9 1.077 1.084
+10 1.153 1.126
+11 1.241 1.142
+12 1.315 1.157
+13 1.370 1.163
+14 1.422 1.171
+15 1.463 1.169
+16 1.463 1.162
+17 1.426 1.141
+18 1.326 1.117
+19 1.225 1.109
+20 1.082 1.095
+21 0.928 1.044
+22 0.804 0.959
+23 0.717 0.869 23-24 local time
+week_day so2_area so2_point
+1 1.060 1.000 Monday
+2 1.060 1.000 Tuesday
+3 1.060 1.000 Wednesday
+4 1.060 1.000 Thursday
+5 1.060 1.000 Friday
+6 0.900 1.000 Saturday
+7 0.800 1.000 Sunday
diff --git a/options/SPECIES/SPECIES_009 b/options/SPECIES/SPECIES_009
new file mode 100644
index 0000000000000000000000000000000000000000..22f2f5785f727f4e1b8f8eb8021e742bd7f93115
--- /dev/null
+++ b/options/SPECIES/SPECIES_009
@@ -0,0 +1,21 @@
+****************************************************************************
+* *
+* Input file for the Lagrangian particle dispersion model FLEXPART *
+* Definition file of chemical species/radionuclides *
+* *
+****************************************************************************
+HCHO Tracer name
+-999.9 Species half life
+-9.9E-09 Wet deposition - A
+ Wet deposition - B
+ 1.3 Dry deposition (gases) - D
+6.0e+03 Dry deposition (gases) - Henrys const.
+0.0 Dry deposition (gases) - f0 (reactivity)
+-9.9E09 Dry deposition (particles) - rho
+ Dry deposition (particles) - dquer
+ Dry deposition (particles) - dsig
+-9.99 Alternative: dry deposition velocity
+ 30.00 molweight
+-9.9E-09 OH Reaction rate at 25 deg, [cm^3/sec]
+-9 number of associated specias (neg. none)
+-99.99 KOA - organic matter air partitioning
diff --git a/options/SPECIES/SPECIES_010 b/options/SPECIES/SPECIES_010
new file mode 100644
index 0000000000000000000000000000000000000000..3fb692ac4aff52bc3bea0d11c3b278b36e11041c
--- /dev/null
+++ b/options/SPECIES/SPECIES_010
@@ -0,0 +1,21 @@
+****************************************************************************
+* *
+* Input file for the Lagrangian particle dispersion model FLEXPART *
+* Definition file of chemical species/radionuclides *
+* *
+****************************************************************************
+PAN Tracer name
+-999.9 Species half life
+-9.9E-09 Wet deposition - A
+ Wet deposition - B
+ 2.6 Dry deposition (gases) - D
+3.6e+00 Dry deposition (gases) - Henrys const.
+0.1 Dry deposition (gases) - f0 (reactivity)
+-9.9E09 Dry deposition (particles) - rho
+ Dry deposition (particles) - dquer
+ Dry deposition (particles) - dsig
+-9.99 Alternative: dry deposition velocity
+121.00 molweight
+-9.9E-09 OH Reaction rate at 25 deg, [cm^3/sec]
+-9 number of associated specias (neg. none)
+-99.99 KOA - organic matter air partitioning
diff --git a/options/SPECIES/SPECIES_011 b/options/SPECIES/SPECIES_011
new file mode 100644
index 0000000000000000000000000000000000000000..2080265ab5b04ff7bce3a71048a5729ab70d8f17
--- /dev/null
+++ b/options/SPECIES/SPECIES_011
@@ -0,0 +1,21 @@
+****************************************************************************
+* *
+* Input file for the Lagrangian particle dispersion model FLEXPART *
+* Definition file of chemical species/radionuclides *
+* *
+****************************************************************************
+NH3 Tracer name
+-999.9 Species half life
+ 9.9E-05 Wet deposition - A
+0.62 Wet deposition - B
+ 1.1 Dry deposition (gases) - D
+2.0e+14 Dry deposition (gases) - Henrys const.
+0.0 Dry deposition (gases) - f0 (reactivity)
+-9.9E09 Dry deposition (particles) - rho
+ Dry deposition (particles) - dquer
+ Dry deposition (particles) - dsig
+-9.99 Alternative: dry deposition velocity
+ 17.00 molweight
+-9.9E-09 OH Reaction rate at 25 deg, [cm^3/sec]
+-9 number of associated specias (neg. none)
+-99.99 KOA - organic matter air partitioning
diff --git a/options/SPECIES/SPECIES_012 b/options/SPECIES/SPECIES_012
new file mode 100644
index 0000000000000000000000000000000000000000..166a41eacf64f3a167c5131b4dba51d54abacba4
--- /dev/null
+++ b/options/SPECIES/SPECIES_012
@@ -0,0 +1,21 @@
+****************************************************************************
+* *
+* Input file for the Lagrangian particle dispersion model FLEXPART *
+* Definition file of chemical species/radionuclides *
+* *
+****************************************************************************
+SO4-aero Tracer name
+-999.9 Species half life
+ 5.0E-06 Wet deposition - A
+0.62 Wet deposition - B
+-9.9 Dry deposition (gases) - D
+ 1.0E-09 Dry deposition (gases) - Henrys const.
+ Dry deposition (gases) - f0 (reactivity)
+ 2.0E03 Dry deposition (particles) - rho
+4.0E-7 Dry deposition (particles) - dquer
+3.0E-1 Dry deposition (particles) - dsig
+-9.99 Alternative: dry deposition velocity
+ -9.99 molweight
+-9.9E-09 OH Reaction rate at 25 deg, [cm^3/sec]
+-9 number of associated specias (neg. none)
+-99.99 KOA - organic matter air partitioning
diff --git a/options/SPECIES/SPECIES_013 b/options/SPECIES/SPECIES_013
new file mode 100644
index 0000000000000000000000000000000000000000..2aadd1adf7a72f611756709e37dd4c49354e7d3b
--- /dev/null
+++ b/options/SPECIES/SPECIES_013
@@ -0,0 +1,21 @@
+****************************************************************************
+* *
+* Input file for the Lagrangian particle dispersion model FLEXPART *
+* Definition file of chemical species/radionuclides *
+* *
+****************************************************************************
+NO3-aero Tracer name
+-999.9 Species half life
+ 5.0E-06 Wet deposition - A
+0.62 Wet deposition - B
+-9.9 Dry deposition (gases) - D
+ Dry deposition (gases) - Henrys const.
+ Dry deposition (gases) - f0 (reactivity)
+ 2.0E03 Dry deposition (particles) - rho
+4.0E-7 Dry deposition (particles) - dquer
+3.0E-1 Dry deposition (particles) - dsig
+-9.99 Alternative: dry deposition velocity
+ -9.99 molweight
+-9.9E-09 OH Reaction rate at 25 deg, [cm^3/sec]
+-9 number of associated specias (neg. none)
+-99.99 KOA - organic matter air partitioning
diff --git a/options/SPECIES/SPECIES_014 b/options/SPECIES/SPECIES_014
new file mode 100644
index 0000000000000000000000000000000000000000..25251102a339cfda1c47fb77160f0aea66394e28
--- /dev/null
+++ b/options/SPECIES/SPECIES_014
@@ -0,0 +1,21 @@
+****************************************************************************
+* *
+* Input file for the Lagrangian particle dispersion model FLEXPART *
+* Definition file of chemical species/radionuclides *
+* *
+****************************************************************************
+I2-131 Tracer name
+691200.0 Species half life
+ 8.0E-05 Wet deposition - A
+0.62 Wet deposition - B
+ 2.7 Dry deposition (gases) - D
+1.0e+05 Dry deposition (gases) - Henrys const.
+0.1 Dry deposition (gases) - f0 (reactivity)
+-9.9E09 Dry deposition (particles) - rho
+ Dry deposition (particles) - dquer
+ Dry deposition (particles) - dsig
+-9.99 Alternative: dry deposition velocity
+ -9.99 molweight
+-9.9E-09 OH Reaction rate at 25 deg, [cm^3/sec]
+-9 number of associated specias (neg. none)
+-99.99 KOA - organic matter air partitioning
diff --git a/options/SPECIES/SPECIES_015 b/options/SPECIES/SPECIES_015
new file mode 100644
index 0000000000000000000000000000000000000000..e95e3988e49bc8143f68391934bad21c96d53810
--- /dev/null
+++ b/options/SPECIES/SPECIES_015
@@ -0,0 +1,21 @@
+****************************************************************************
+* *
+* Input file for the Lagrangian particle dispersion model FLEXPART *
+* Definition file of chemical species/radionuclides *
+* *
+****************************************************************************
+I-131 Tracer name
+691200.0 Species half life
+ 1.0E-04 Wet deposition - A
+0.80 Wet deposition - B
+-9.9 Dry deposition (gases) - D
+ Dry deposition (gases) - Henrys const.
+ Dry deposition (gases) - f0 (reactivity)
+ 2.5E03 Dry deposition (particles) - rho
+6.0E-7 Dry deposition (particles) - dquer
+3.0E-1 Dry deposition (particles) - dsig
+-9.99 Alternative: dry deposition velocity
+ -9.99 molweight
+-9.9E-09 OH Reaction rate at 25 deg, [cm^3/sec]
+-9 number of associated specias (neg. none)
+-99.99 KOA - organic matter air partitioning
diff --git a/options/SPECIES/SPECIES_016 b/options/SPECIES/SPECIES_016
new file mode 100644
index 0000000000000000000000000000000000000000..e054c3a13f860f23dfbfaaf7b7560964fbac6f60
--- /dev/null
+++ b/options/SPECIES/SPECIES_016
@@ -0,0 +1,21 @@
+****************************************************************************
+* *
+* Input file for the Lagrangian particle dispersion model FLEXPART *
+* Definition file of chemical species/radionuclides *
+* *
+****************************************************************************
+Cs-137 Tracer name
+-999.9 Species half life
+ 1.0E-04 Wet deposition - A
+0.80 Wet deposition - B
+-9.9 Dry deposition (gases) - D
+ Dry deposition (gases) - Henrys const.
+ Dry deposition (gases) - f0 (reactivity)
+ 2.5E03 Dry deposition (particles) - rho
+6.0E-7 Dry deposition (particles) - dquer
+3.0E-1 Dry deposition (particles) - dsig
+-9.99 Alternative: dry deposition velocity
+ -9.99 molweight
+-9.9E-09 OH Reaction rate at 25 deg, [cm^3/sec]
+-9 number of associated specias (neg. none)
+-99.99 KOA - organic matter air partitioning
diff --git a/options/SPECIES/SPECIES_017 b/options/SPECIES/SPECIES_017
new file mode 100644
index 0000000000000000000000000000000000000000..6d8cdc50b8ff00f959945bd0ba0263967c40ecae
--- /dev/null
+++ b/options/SPECIES/SPECIES_017
@@ -0,0 +1,21 @@
+****************************************************************************
+* *
+* Input file for the Lagrangian particle dispersion model FLEXPART *
+* Definition file of chemical species/radionuclides *
+* *
+****************************************************************************
+Y-91 Tracer name
+5037120.0 Species half life
+ 1.0E-04 Wet deposition - A
+0.80 Wet deposition - B
+-9.9 Dry deposition (gases) - D
+ Dry deposition (gases) - Henrys const.
+ Dry deposition (gases) - f0 (reactivity)
+ 2.5E03 Dry deposition (particles) - rho
+6.0E-7 Dry deposition (particles) - dquer
+3.0E-1 Dry deposition (particles) - dsig
+-9.99 Alternative: dry deposition velocity
+ -9.99 molweight
+-9.9E-09 OH Reaction rate at 25 deg, [cm^3/sec]
+-9 number of associated specias (neg. none)
+-99.99 KOA - organic matter air partitioning
diff --git a/options/SPECIES/SPECIES_018 b/options/SPECIES/SPECIES_018
new file mode 100644
index 0000000000000000000000000000000000000000..4aafe2ba4a5c3bd4fb5e60fe4be0bef425449372
--- /dev/null
+++ b/options/SPECIES/SPECIES_018
@@ -0,0 +1,21 @@
+****************************************************************************
+* *
+* Input file for the Lagrangian particle dispersion model FLEXPART *
+* Definition file of chemical species/radionuclides *
+* *
+****************************************************************************
+Ru-106 Tracer name
+31536000.0 Species half life
+ 1.0E-04 Wet deposition - A
+0.80 Wet deposition - B
+-9.9 Dry deposition (gases) - D
+ Dry deposition (gases) - Henrys const.
+ Dry deposition (gases) - f0 (reactivity)
+ 2.5E03 Dry deposition (particles) - rho
+6.0E-7 Dry deposition (particles) - dquer
+3.0E-1 Dry deposition (particles) - dsig
+-9.99 Alternative: dry deposition velocity
+ -9.99 molweight
+-9.9E-09 OH Reaction rate at 25 deg, [cm^3/sec]
+-9 number of associated specias (neg. none)
+-99.99 KOA - organic matter air partitioning
diff --git a/options/SPECIES/SPECIES_019 b/options/SPECIES/SPECIES_019
new file mode 100644
index 0000000000000000000000000000000000000000..c8267eee50f6457cf56bc9e7ce82a721258f52f5
--- /dev/null
+++ b/options/SPECIES/SPECIES_019
@@ -0,0 +1,21 @@
+****************************************************************************
+* *
+* Input file for the Lagrangian particle dispersion model FLEXPART *
+* Definition file of chemical species/radionuclides *
+* *
+****************************************************************************
+Kr-85 Tracer name
+-999.9 Species half life
+-9.9E-09 Wet deposition - A
+ Wet deposition - B
+-9.9 Dry deposition (gases) - D
+ Dry deposition (gases) - Henrys const.
+ Dry deposition (gases) - f0 (reactivity)
+-9.9E09 Dry deposition (particles) - rho
+ Dry deposition (particles) - dquer
+ Dry deposition (particles) - dsig
+-9.99 Alternative: dry deposition velocity
+ -9.99 molweight
+-9.9E-09 OH Reaction rate at 25 deg, [cm^3/sec]
+-9 number of associated specias (neg. none)
+-99.99 KOA - organic matter air partitioning
diff --git a/options/SPECIES/SPECIES_020 b/options/SPECIES/SPECIES_020
new file mode 100644
index 0000000000000000000000000000000000000000..d5ec655985796d207fcdb8fddc80c6926b2b3b27
--- /dev/null
+++ b/options/SPECIES/SPECIES_020
@@ -0,0 +1,21 @@
+****************************************************************************
+* *
+* Input file for the Lagrangian particle dispersion model FLEXPART *
+* Definition file of chemical species/radionuclides *
+* *
+****************************************************************************
+Sr-90 Tracer name
+-999.9 Species half life
+ 1.0E-04 Wet deposition - A
+0.80 Wet deposition - B
+-9.9 Dry deposition (gases) - D
+ Dry deposition (gases) - Henrys const.
+ Dry deposition (gases) - f0 (reactivity)
+ 2.5E03 Dry deposition (particles) - rho
+6.0E-7 Dry deposition (particles) - dquer
+3.0E-1 Dry deposition (particles) - dsig
+-9.99 Alternative: dry deposition velocity
+ -9.99 molweight
+-9.9E-09 OH Reaction rate at 25 deg, [cm^3/sec]
+-9 number of associated specias (neg. none)
+-99.99 KOA - organic matter air partitioning
diff --git a/options/SPECIES/SPECIES_021 b/options/SPECIES/SPECIES_021
new file mode 100644
index 0000000000000000000000000000000000000000..40248863503cabfab37eb1049dcae54c5f5fe846
--- /dev/null
+++ b/options/SPECIES/SPECIES_021
@@ -0,0 +1,21 @@
+****************************************************************************
+* *
+* Input file for the Lagrangian particle dispersion model FLEXPART *
+* Definition file of chemical species/radionuclides *
+* *
+****************************************************************************
+Xe-133 Tracer name
+198720.0 Species half life
+-9.9E-09 Wet deposition - A
+ Wet deposition - B
+-9.9 Dry deposition (gases) - D
+ Dry deposition (gases) - Henrys const.
+ Dry deposition (gases) - f0 (reactivity)
+-9.9E09 Dry deposition (particles) - rho
+ Dry deposition (particles) - dquer
+ Dry deposition (particles) - dsig
+-9.99 Alternative: dry deposition velocity
+ -9.99 molweight
+-9.9E-09 OH Reaction rate at 25 deg, [cm^3/sec]
+-9 number of associated specias (neg. none)
+-99.99 KOA - organic matter air partitioning
diff --git a/options/SPECIES/SPECIES_022 b/options/SPECIES/SPECIES_022
new file mode 100644
index 0000000000000000000000000000000000000000..38a229164313da399eb854220ee889253da5598e
--- /dev/null
+++ b/options/SPECIES/SPECIES_022
@@ -0,0 +1,21 @@
+****************************************************************************
+* *
+* Input file for the Lagrangian particle dispersion model FLEXPART *
+* Definition file of chemical species/radionuclides *
+* *
+****************************************************************************
+CO Tracer name
+-999.9 Species half life
+-9.9E-09 Wet deposition - A
+ Wet deposition - B
+-9.9 Dry deposition (gases) - D
+ Dry deposition (gases) - Henrys const.
+ Dry deposition (gases) - f0 (reactivity)
+-9.9E09 Dry deposition (particles) - rho
+ Dry deposition (particles) - dquer
+ Dry deposition (particles) - dsig
+-9.99 Alternative: dry deposition velocity
+ 28.00 molweight
+ 1.5E-13 OH Reaction rate at 25 deg, [cm^3/sec]
+-9 number of associated specias (neg. none)
+-99.99 KOA - organic matter air partitioning
diff --git a/options/SPECIES/SPECIES_024 b/options/SPECIES/SPECIES_024
new file mode 100644
index 0000000000000000000000000000000000000000..38a93691ed0a1edc22b98578012f6152b195b3f6
--- /dev/null
+++ b/options/SPECIES/SPECIES_024
@@ -0,0 +1,21 @@
+****************************************************************************
+* *
+* Input file for the Lagrangian particle dispersion model FLEXPART *
+* Definition file of chemical species/radionuclides *
+* *
+****************************************************************************
+AIRTRACER Tracer name
+-999.9 Species half life
+-9.9E-09 Wet deposition - A
+ Wet deposition - B
+-9.9 Dry deposition (gases) - D
+ Dry deposition (gases) - Henrys const.
+ Dry deposition (gases) - f0 (reactivity)
+-9.9E09 Dry deposition (particles) - rho
+ Dry deposition (particles) - dquer
+ Dry deposition (particles) - dsig
+-9.99 Alternative: dry deposition velocity
+29.000 molweight
+-9.9E-09 OH Reaction rate at 25 deg, [cm^3/sec]
+-9 number of associated specias (neg. none)
+-99.99 KOA - organic matter air partitioning
diff --git a/options/SPECIES/SPECIES_025 b/options/SPECIES/SPECIES_025
new file mode 100644
index 0000000000000000000000000000000000000000..f5c2a749ccabc00f98b271081516b277cfc9a70a
--- /dev/null
+++ b/options/SPECIES/SPECIES_025
@@ -0,0 +1,21 @@
+****************************************************************************
+* *
+* Input file for the Lagrangian particle dispersion model FLEXPART *
+* Definition file of chemical species/radionuclides *
+* *
+****************************************************************************
+AERO-TRACER Tracer name
+-999.9 Species half life
+2.0E-05 Wet deposition - A
+0.8 Wet deposition - B
+-9.9 Dry deposition (gases) - D
+ Dry deposition (gases) - Henrys const.
+ Dry deposition (gases) - f0 (reactivity)
+1.4E+03 Dry deposition (particles) - rho
+2.5E-07 Dry deposition (particles) - dquer
+1.25 Dry deposition (particles) - dsig
+-9.99 Alternative: dry deposition velocity
+ 29.00 molweight
+-9.9E-09 OH Reaction rate at 25 deg, [cm^3/sec]
+-9 number of associated specias (neg. none)
+-99.99 KOA - organic matter air partitioning
diff --git a/options/SPECIES/spec_overview b/options/SPECIES/spec_overview
new file mode 100644
index 0000000000000000000000000000000000000000..8b9b7dfbc19fdaa882534401e0b5abcb088f82e2
--- /dev/null
+++ b/options/SPECIES/spec_overview
@@ -0,0 +1 @@
+grep Tra SPEC*
diff --git a/options/surfdata.t b/options/surfdata.t
new file mode 100644
index 0000000000000000000000000000000000000000..95a38fb7217129dd58f4d9794c8f94704e0d28c8
--- /dev/null
+++ b/options/surfdata.t
@@ -0,0 +1,17 @@
+13 landuse categories are related roughness length
+--------------------------------------------------------
+landuse comment z0
+--------------------------------------------------------
+ 1 Urban land 0.7
+ 2 Agricultural land 0.1
+ 3 Range land 0.1
+ 4 Deciduous forest 1.
+ 5 Coniferous forest 1.
+ 6 Mixed forest including wetland 0.7
+ 7 water, both salt and fresh 0.001
+ 8 barren land mostly desert 0.01
+ 9 nonforested wetland 0.1
+10 mixed agricultural and range land 0.1
+11 rocky open areas with low grow shrubs 0.05
+12 snow and ice 0.001
+13 rainforest 1.
diff --git a/options/surfdepo.t b/options/surfdepo.t
new file mode 100644
index 0000000000000000000000000000000000000000..1171b672ea773a57c6eb90cc03091caf1a08ce92
--- /dev/null
+++ b/options/surfdepo.t
@@ -0,0 +1,57 @@
+==============================================================================
+INPUT RESISTANCES (s/m) FOR THE COMPUTATION OF SURFACE RESISTANCES TO
+DRY DEPOSITION
+==============================================================================
+AFTER WESELY, 1989
+==============================================================================
+1 to 11: Landuse types after Wesely; 12 .. snow, 13 .. rainforest
+==============================================================================
+Values are tabulated for 5 seasonal categories:
+1 Midsummer with lush vegetation
+2 Autumn with unharvested cropland
+3 Late autumn after frost, no snow
+4 Winter, snow on ground and subfreezing
+5 Transitional spring with partially green short annuals
+==============================================================================
+ 1 2 3 4 5 6 7 8 9 10 11 12 13
+________________________________________________________________________________________________________________
+ri 9999. 60. 120. 70. 130. 100. 9999. 9999. 80. 100. 150. 9999. 200. 1
+rlu 9999. 2000. 2000. 2000. 2000. 2000. 9999. 9999. 2500. 2000. 4000. 9999. 1000.
+rac 100. 200. 100. 2000. 2000. 2000. 0. 0. 300. 150. 200. 0. 2000.
+rgss 400. 150. 350. 500. 500. 100. 0. 1000. 0. 220. 400. 100. 200.
+rgso 300. 150. 200. 200. 200. 300. 2000. 400. 1000. 180. 200. 10000. 200.
+rcls 9999. 2000. 2000. 2000. 2000. 2000. 9999. 9999. 2500. 2000. 4000. 9999. 9999.
+rclo 9999. 1000. 1000. 1000. 1000. 1000. 9999. 9999. 1000. 1000. 1000. 9999. 9999.
+_________________________________________________________________________________________________________________
+ri 9999. 9999. 9999. 9999. 250. 500. 9999. 9999. 9999. 9999. 9999. 9999. 200. 2
+rlu 9999. 9000. 9000. 9000. 4000. 8000. 9999. 9999. 9000. 9000. 9000. 9999. 1000.
+rac 100. 150. 100. 1500. 2000. 1700. 0. 0. 200. 120. 140. 0. 2000.
+rgss 400. 200. 350. 500. 500. 100. 0. 1000. 0. 300. 400. 100. 200.
+rgso 300. 150. 200. 200. 200. 300. 2000. 400. 800. 180. 200. 10000. 200.
+rcls 9999. 9000. 9000. 9000. 2000. 4000. 9999. 9999. 9000. 9000. 9000. 9999. 9999.
+rclo 9999. 400. 400. 400. 1000. 600. 9999. 9999. 400. 400. 400. 9999. 9999.
+_________________________________________________________________________________________________________________
+ri 9999. 9999. 9999. 9999. 250. 500. 9999. 9999. 9999. 9999. 9999. 9999. 200. 3
+rlu 9999. 9999. 9000. 9000. 4000. 8000. 9999. 9999. 9000. 9000. 9000. 9999. 1000.
+rac 100. 10. 100. 1000. 2000. 1500. 0. 0. 100. 50. 120. 0. 2000.
+rgss 400. 150. 350. 500. 500. 200. 0. 1000. 0. 200. 400. 100. 200.
+rgso 300. 150. 200. 200. 200. 300. 2000. 400. 1000. 180. 200. 10000. 200.
+rcls 9999. 9999. 9000. 9000. 3000. 6000. 9999. 9999. 9000. 9000. 9000. 9999. 9999.
+rclo 9999. 1000. 400. 400. 1000. 600. 9999. 9999. 800. 600. 600. 9999. 9999.
+_________________________________________________________________________________________________________________
+ri 9999. 9999. 9999. 9999. 400. 800. 9999. 9999. 9999. 9999. 9999. 9999. 200. 4
+rlu 9999. 9999. 9999. 9999. 6000. 9000. 9999. 9999. 9000. 9000. 9000. 9999. 1000.
+rac 100. 10. 10. 1000. 2000. 1500. 0. 0. 50. 10. 50. 0. 2000.
+rgss 100. 100. 100. 100. 100. 100. 0. 1000. 100. 100. 50. 100. 200.
+rgso 600. 3500. 3500. 3500. 3500. 3500. 2000. 400. 3500. 3500. 3500. 10000. 200.
+rcls 9999. 9999. 9999. 9000. 200. 400. 9999. 9999. 9000. 9999. 9000. 9999. 9999.
+rclo 9999. 1000. 1000. 400. 1500. 600. 9999. 9999. 800. 1000. 800. 9999. 9999.
+_________________________________________________________________________________________________________________
+ri 9999. 120. 240. 140. 250. 190. 9999. 9999. 160. 200. 300. 9999. 200. 5
+rlu 9999. 4000. 4000. 4000. 2000. 3000. 9999. 9999. 4000. 4000. 8000. 9999. 1000.
+rac 100. 50. 80. 1200. 2000. 1500. 0. 0. 200. 60. 120. 0. 2000.
+rgss 500. 150. 350. 500 500. 200. 0. 1000. 0. 250. 400. 100. 200.
+rgso 300. 150. 200. 200. 200. 300. 2000. 400. 1000. 180. 200. 10000. 200.
+rcls 9999. 4000. 4000. 4000. 2000. 3000. 9999. 9999. 4000. 4000. 8000. 9999. 9999.
+rclo 9999. 1000. 500. 500. 1500. 700. 9999. 9999. 600. 800. 800. 9999. 9999.
+_________________________________________________________________________________________________________________
diff --git a/src/FLEXPART.f90 b/src/FLEXPART.f90
new file mode 100644
index 0000000000000000000000000000000000000000..4528d8aa598ec7a91ec6f2ee05aafe6cb4fa777a
--- /dev/null
+++ b/src/FLEXPART.f90
@@ -0,0 +1,405 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+program flexpart
+
+ !*****************************************************************************
+ ! *
+ ! This is the Lagrangian Particle Dispersion Model FLEXPART. *
+ ! The main program manages the reading of model run specifications, etc. *
+ ! All actual computing is done within subroutine timemanager. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 18 May 1996 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! Constants: *
+ ! *
+ !*****************************************************************************
+
+ use point_mod
+ use par_mod
+ use com_mod
+ use conv_mod
+
+ implicit none
+
+ integer :: i,j,ix,jy,inest
+ integer :: idummy = -320
+ character(len=256) :: inline_options !pathfile, flexversion, arg2
+
+
+ ! Generate a large number of random numbers
+ !******************************************
+
+ do i=1,maxrand-1,2
+ call gasdev1(idummy,rannumb(i),rannumb(i+1))
+ end do
+ call gasdev1(idummy,rannumb(maxrand),rannumb(maxrand-1))
+
+ !
+ flexversion='Version 9.1.8 (2013-12-08)'
+ !verbosity=0
+ ! Read the pathnames where input/output files are stored
+ !*******************************************************
+
+ inline_options='none'
+ select case (iargc())
+ case (2)
+ call getarg(1,arg1)
+ pathfile=arg1
+ call getarg(2,arg2)
+ inline_options=arg2
+ case (1)
+ call getarg(1,arg1)
+ pathfile=arg1
+ verbosity=0
+ if (arg1(1:1).eq.'-') then
+ write(pathfile,'(a11)') './pathnames'
+ inline_options=arg1
+ endif
+ case (0)
+ write(pathfile,'(a11)') './pathnames'
+ verbosity=0
+ end select
+
+ if (inline_options(1:1).eq.'-') then
+ print*, 'inline options=', inline_options
+ if (trim(inline_options).eq.'-v'.or.trim(inline_options).eq.'-v1') then
+ print*, 'verbose mode 1: additional information will be displayed'
+ verbosity=1
+ endif
+ if (trim(inline_options).eq.'-v2') then
+ print*, 'verbose mode 2: additional information will be displayed'
+ verbosity=2
+ endif
+ if (trim(inline_options).eq.'-i') then
+ print*, 'info mode: will provide run specific information and stop'
+ verbosity=1
+ info_flag=1
+ endif
+ if (trim(inline_options).eq.'-i2') then
+ print*, 'info mode: will provide run specific information and stop'
+ verbosity=2
+ info_flag=1
+ endif
+ endif
+
+
+ ! Print the GPL License statement
+ !*******************************************************
+ print*,'Welcome to FLEXPART', trim(flexversion)
+ print*,'FLEXPART is free software released under the GNU Genera'// &
+ 'l Public License.'
+
+ if (verbosity.gt.0) then
+ WRITE(*,*) 'call readpaths'
+ endif
+ call readpaths(pathfile)
+
+
+ if (verbosity.gt.1) then !show clock info
+ !print*,'length(4)',length(4)
+ !count=0,count_rate=1000
+ CALL SYSTEM_CLOCK(count_clock0, count_rate, count_max)
+ !WRITE(*,*) 'SYSTEM_CLOCK',count, count_rate, count_max
+ !WRITE(*,*) 'SYSTEM_CLOCK, count_clock0', count_clock0
+ !WRITE(*,*) 'SYSTEM_CLOCK, count_rate', count_rate
+ !WRITE(*,*) 'SYSTEM_CLOCK, count_max', count_max
+ endif
+
+
+ ! Read the user specifications for the current model run
+ !*******************************************************
+
+ if (verbosity.gt.0) then
+ WRITE(*,*) 'call readcommand'
+ endif
+ call readcommand
+ if (verbosity.gt.0) then
+ WRITE(*,*) ' ldirect=', ldirect
+ WRITE(*,*) ' ibdate,ibtime=',ibdate,ibtime
+ WRITE(*,*) ' iedate,ietime=', iedate,ietime
+ if (verbosity.gt.1) then
+ CALL SYSTEM_CLOCK(count_clock, count_rate, count_max)
+ WRITE(*,*) 'SYSTEM_CLOCK',(count_clock - count_clock0)/real(count_rate) !, count_rate, count_max
+ endif
+ endif
+
+
+ ! Read the age classes to be used
+ !********************************
+ if (verbosity.gt.0) then
+ WRITE(*,*) 'call readageclasses'
+ endif
+ call readageclasses
+
+ if (verbosity.gt.1) then
+ CALL SYSTEM_CLOCK(count_clock, count_rate, count_max)
+ WRITE(*,*) 'SYSTEM_CLOCK',(count_clock - count_clock0)/real(count_rate) !, count_rate, count_max
+ endif
+
+
+
+ ! Read, which wind fields are available within the modelling period
+ !******************************************************************
+
+ if (verbosity.gt.0) then
+ WRITE(*,*) 'call readavailable'
+ endif
+ call readavailable
+
+ ! Read the model grid specifications,
+ ! both for the mother domain and eventual nests
+ !**********************************************
+
+ if (verbosity.gt.0) then
+ WRITE(*,*) 'call gridcheck'
+ endif
+
+ call gridcheck
+
+ if (verbosity.gt.1) then
+ CALL SYSTEM_CLOCK(count_clock, count_rate, count_max)
+ WRITE(*,*) 'SYSTEM_CLOCK',(count_clock - count_clock0)/real(count_rate) !, count_rate, count_max
+ endif
+
+
+ if (verbosity.gt.0) then
+ WRITE(*,*) 'call gridcheck_nests'
+ endif
+ call gridcheck_nests
+
+
+ ! Read the output grid specifications
+ !************************************
+
+ if (verbosity.gt.0) then
+ WRITE(*,*) 'call readoutgrid'
+ endif
+
+ call readoutgrid
+
+ if (nested_output.eq.1) then
+ call readoutgrid_nest
+ if (verbosity.gt.0) then
+ WRITE(*,*) '# readoutgrid_nest'
+ endif
+ endif
+
+ ! Read the receptor points for which extra concentrations are to be calculated
+ !*****************************************************************************
+
+ if (verbosity.eq.1) then
+ print*,'call readreceptors'
+ endif
+ call readreceptors
+
+ ! Read the physico-chemical species property table
+ !*************************************************
+ !SEC: now only needed SPECIES are read in readreleases.f
+ !call readspecies
+
+
+ ! Read the landuse inventory
+ !***************************
+
+ if (verbosity.gt.0) then
+ print*,'call readlanduse'
+ endif
+ call readlanduse
+
+
+ ! Assign fractional cover of landuse classes to each ECMWF grid point
+ !********************************************************************
+
+ if (verbosity.gt.0) then
+ print*,'call assignland'
+ endif
+ call assignland
+
+
+
+ ! Read the coordinates of the release locations
+ !**********************************************
+
+ if (verbosity.gt.0) then
+ print*,'call readreleases'
+ endif
+ call readreleases
+
+
+ ! Read and compute surface resistances to dry deposition of gases
+ !****************************************************************
+
+ if (verbosity.gt.0) then
+ print*,'call readdepo'
+ endif
+ call readdepo
+
+ ! Convert the release point coordinates from geografical to grid coordinates
+ !***************************************************************************
+
+ call coordtrafo
+ if (verbosity.gt.0) then
+ print*,'call coordtrafo'
+ endif
+
+
+ ! Initialize all particles to non-existent
+ !*****************************************
+
+ if (verbosity.gt.0) then
+ print*,'Initialize all particles to non-existent'
+ endif
+ do j=1,maxpart
+ itra1(j)=-999999999
+ end do
+
+ ! For continuation of previous run, read in particle positions
+ !*************************************************************
+
+ if (ipin.eq.1) then
+ if (verbosity.gt.0) then
+ print*,'call readpartpositions'
+ endif
+ call readpartpositions
+ else
+ if (verbosity.gt.0) then
+ print*,'numpart=0, numparticlecount=0'
+ endif
+ numpart=0
+ numparticlecount=0
+ endif
+
+
+ ! Calculate volume, surface area, etc., of all output grid cells
+ ! Allocate fluxes and OHfield if necessary
+ !***************************************************************
+
+
+ if (verbosity.gt.0) then
+ print*,'call outgrid_init'
+ endif
+ call outgrid_init
+ if (nested_output.eq.1) call outgrid_init_nest
+
+
+ ! Read the OH field
+ !******************
+
+ if (OHREA.eqv..TRUE.) then
+ if (verbosity.gt.0) then
+ print*,'call readOHfield'
+ endif
+ call readOHfield
+ endif
+
+ ! Write basic information on the simulation to a file "header"
+ ! and open files that are to be kept open throughout the simulation
+ !******************************************************************
+
+
+ if (verbosity.gt.0) then
+ print*,'call writeheader'
+ endif
+
+ call writeheader
+ ! FLEXPART 9.2 ticket ?? write header in ASCII format
+ call writeheader_txt
+ !if (nested_output.eq.1) call writeheader_nest
+ if (nested_output.eq.1.and.surf_only.ne.1) call writeheader_nest
+
+ if (nested_output.eq.1.and.surf_only.eq.1) call writeheader_nest_surf
+ if (nested_output.ne.1.and.surf_only.eq.1) call writeheader_surf
+
+
+
+ !open(unitdates,file=path(2)(1:length(2))//'dates')
+
+ if (verbosity.gt.0) then
+ print*,'call openreceptors'
+ endif
+ call openreceptors
+ if ((iout.eq.4).or.(iout.eq.5)) call openouttraj
+
+
+ ! Releases can only start and end at discrete times (multiples of lsynctime)
+ !***************************************************************************
+
+ if (verbosity.gt.0) then
+ print*,'discretize release times'
+ endif
+ do i=1,numpoint
+ ireleasestart(i)=nint(real(ireleasestart(i))/ &
+ real(lsynctime))*lsynctime
+ ireleaseend(i)=nint(real(ireleaseend(i))/ &
+ real(lsynctime))*lsynctime
+ end do
+
+
+ ! Initialize cloud-base mass fluxes for the convection scheme
+ !************************************************************
+
+ if (verbosity.gt.0) then
+ print*,'Initialize cloud-base mass fluxes for the convection scheme'
+ endif
+
+ do jy=0,nymin1
+ do ix=0,nxmin1
+ cbaseflux(ix,jy)=0.
+ end do
+ end do
+ do inest=1,numbnests
+ do jy=0,nyn(inest)-1
+ do ix=0,nxn(inest)-1
+ cbasefluxn(ix,jy,inest)=0.
+ end do
+ end do
+ end do
+
+
+ ! Calculate particle trajectories
+ !********************************
+
+ if (verbosity.gt.0) then
+ if (verbosity.gt.1) then
+ CALL SYSTEM_CLOCK(count_clock, count_rate, count_max)
+ WRITE(*,*) 'SYSTEM_CLOCK',(count_clock - count_clock0)/real(count_rate) !, count_rate, count_max
+ endif
+ if (info_flag.eq.1) then
+ print*, 'info only mode (stop)'
+ stop
+ endif
+ print*,'call timemanager'
+ endif
+
+ call timemanager
+
+
+ write(*,*) 'CONGRATULATIONS: YOU HAVE SUCCESSFULLY COMPLETED A FLE&
+ &XPART MODEL RUN!'
+
+end program flexpart
diff --git a/src/advance.f90 b/src/advance.f90
new file mode 100644
index 0000000000000000000000000000000000000000..fdfdd87017da30a2b96326d9dff5eebefa4dd444
--- /dev/null
+++ b/src/advance.f90
@@ -0,0 +1,877 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine advance(itime,nrelpoint,ldt,up,vp,wp, &
+ usigold,vsigold,wsigold,nstop,xt,yt,zt,prob,icbt)
+ ! i i i/oi/oi/o
+ ! i/o i/o i/o o i/oi/oi/o i/o i/o
+ !*****************************************************************************
+ ! *
+ ! Calculation of turbulent particle trajectories utilizing a *
+ ! zero-acceleration scheme, which is corrected by a numerically more *
+ ! accurate Petterssen scheme whenever possible. *
+ ! *
+ ! Particle positions are read in, incremented, and returned to the calling *
+ ! program. *
+ ! *
+ ! In different regions of the atmosphere (PBL vs. free troposphere), *
+ ! different parameters are needed for advection, parameterizing turbulent *
+ ! velocities, etc. For efficiency, different interpolation routines have *
+ ! been written for these different cases, with the disadvantage that there *
+ ! exist several routines doing almost the same. They all share the *
+ ! included file 'interpol_mod'. The following *
+ ! interpolation routines are used: *
+ ! *
+ ! interpol_all(_nests) interpolates everything (called inside the PBL) *
+ ! interpol_misslev(_nests) if a particle moves vertically in the PBL, *
+ ! additional parameters are interpolated if it *
+ ! crosses a model level *
+ ! interpol_wind(_nests) interpolates the wind and determines the *
+ ! standard deviation of the wind (called outside *
+ ! PBL) also interpolates potential vorticity *
+ ! interpol_wind_short(_nests) only interpolates the wind (needed for the *
+ ! Petterssen scheme) *
+ ! interpol_vdep(_nests) interpolates deposition velocities *
+ ! *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 16 December 1997 *
+ ! *
+ ! Changes: *
+ ! *
+ ! 8 April 2000: Deep convection parameterization *
+ ! *
+ ! May 2002: Petterssen scheme introduced *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! icbt 1 if particle not transferred to forbidden state, *
+ ! else -1 *
+ ! dawsave accumulated displacement in along-wind direction *
+ ! dcwsave accumulated displacement in cross-wind direction *
+ ! dxsave accumulated displacement in longitude *
+ ! dysave accumulated displacement in latitude *
+ ! h [m] Mixing height *
+ ! lwindinterv [s] time interval between two wind fields *
+ ! itime [s] time at which this subroutine is entered *
+ ! itimec [s] actual time, which is incremented in this subroutine *
+ ! href [m] height for which dry deposition velocity is calculated *
+ ! ladvance [s] Total integration time period *
+ ! ldirect 1 forward, -1 backward *
+ ! ldt [s] Time step for the next integration *
+ ! lsynctime [s] Synchronisation interval of FLEXPART *
+ ! ngrid index which grid is to be used *
+ ! nrand index for a variable to be picked from rannumb *
+ ! nstop if > 1 particle has left domain and must be stopped *
+ ! prob probability of absorption due to dry deposition *
+ ! rannumb(maxrand) normally distributed random variables *
+ ! rhoa air density *
+ ! rhograd vertical gradient of the air density *
+ ! up,vp,wp random velocities due to turbulence (along wind, cross *
+ ! wind, vertical wind *
+ ! usig,vsig,wsig mesoscale wind fluctuations *
+ ! usigold,vsigold,wsigold like usig, etc., but for the last time step *
+ ! vdepo Deposition velocities for all species *
+ ! xt,yt,zt Particle position *
+ ! *
+ !*****************************************************************************
+
+ use point_mod
+ use par_mod
+ use com_mod
+ use interpol_mod
+ use hanna_mod
+ use cmapf_mod
+
+ implicit none
+
+ real(kind=dp) :: xt,yt
+ real :: zt,xts,yts,weight
+ integer :: itime,itimec,nstop,ldt,i,j,k,nrand,loop,memindnext
+ integer :: ngr,nix,njy,ks,nsp,nrelpoint
+ real :: dz,dz1,dz2,xlon,ylat,xpol,ypol,gridsize
+ real :: ru,rv,rw,dt,ux,vy,cosfact,xtn,ytn,tropop
+ real :: prob(maxspec),up,vp,wp,dxsave,dysave,dawsave
+ real :: dcwsave
+ real :: usigold,vsigold,wsigold,r,rs
+ real :: uold,vold,wold,vdepo(maxspec)
+ !real uprof(nzmax),vprof(nzmax),wprof(nzmax)
+ !real usigprof(nzmax),vsigprof(nzmax),wsigprof(nzmax)
+ !real rhoprof(nzmax),rhogradprof(nzmax)
+ real :: rhoa,rhograd,ran3,delz,dtf,rhoaux,dtftlw,uxscale,wpscale
+ integer(kind=2) :: icbt
+ real,parameter :: eps=nxmax/3.e5,eps2=1.e-9
+
+
+ !!! CHANGE: TEST OF THE WELL-MIXED CRITERION
+ ! integer,parameter :: iclass=10
+ ! real(kind=dp) :: zacc,tacc,t(iclass),th(0:iclass),hsave
+ ! logical dump
+ ! save zacc,tacc,t,th,hsave,dump
+ !!! CHANGE
+
+ integer :: idummy = -7
+ real :: settling = 0.
+
+
+ !!! CHANGE: TEST OF THE WELL-MIXED CRITERION
+ !if (idummy.eq.-7) then
+ !open(550,file='WELLMIXEDTEST')
+ !do 17 i=0,iclass
+ !7 th(i)=real(i)/real(iclass)
+ !endif
+ !!! CHANGE
+
+
+ nstop=0
+ do i=1,nmixz
+ indzindicator(i)=.true.
+ end do
+
+
+ if (DRYDEP) then ! reset probability for deposition
+ do ks=1,nspec
+ depoindicator(ks)=.true.
+ prob(ks)=0.
+ end do
+ endif
+
+ dxsave=0. ! reset position displacements
+ dysave=0. ! due to mean wind
+ dawsave=0. ! and turbulent wind
+ dcwsave=0.
+
+ itimec=itime
+
+ nrand=int(ran3(idummy)*real(maxrand-1))+1
+
+
+ ! Determine whether lat/long grid or polarstereographic projection
+ ! is to be used
+ ! Furthermore, determine which nesting level to be used
+ !*****************************************************************
+
+ if (nglobal.and.(yt.gt.switchnorthg)) then
+ ngrid=-1
+ else if (sglobal.and.(yt.lt.switchsouthg)) then
+ ngrid=-2
+ else
+ ngrid=0
+ do j=numbnests,1,-1
+ if ((xt.gt.xln(j)+eps).and.(xt.lt.xrn(j)-eps).and. &
+ (yt.gt.yln(j)+eps).and.(yt.lt.yrn(j)-eps)) then
+ ngrid=j
+ goto 23
+ endif
+ end do
+23 continue
+ endif
+
+
+ !***************************
+ ! Interpolate necessary data
+ !***************************
+
+ if (abs(itime-memtime(1)).lt.abs(itime-memtime(2))) then
+ memindnext=1
+ else
+ memindnext=2
+ endif
+
+ ! Determine nested grid coordinates
+ !**********************************
+
+ if (ngrid.gt.0) then
+ xtn=(xt-xln(ngrid))*xresoln(ngrid)
+ ytn=(yt-yln(ngrid))*yresoln(ngrid)
+ ix=int(xtn)
+ jy=int(ytn)
+ nix=nint(xtn)
+ njy=nint(ytn)
+ else
+ ix=int(xt)
+ jy=int(yt)
+ nix=nint(xt)
+ njy=nint(yt)
+ endif
+ ixp=ix+1
+ jyp=jy+1
+
+
+ ! Compute maximum mixing height around particle position
+ !*******************************************************
+
+ h=0.
+ if (ngrid.le.0) then
+ do k=1,2
+ do j=jy,jyp
+ do i=ix,ixp
+ if (hmix(i,j,1,k).gt.h) h=hmix(i,j,1,k)
+ end do
+ end do
+ end do
+ tropop=tropopause(nix,njy,1,1)
+ else
+ do k=1,2
+ do j=jy,jyp
+ do i=ix,ixp
+ if (hmixn(i,j,1,k,ngrid).gt.h) h=hmixn(i,j,1,k,ngrid)
+ end do
+ end do
+ end do
+ tropop=tropopausen(nix,njy,1,1,ngrid)
+ endif
+
+ zeta=zt/h
+
+
+
+ !*************************************************************
+ ! If particle is in the PBL, interpolate once and then make a
+ ! time loop until end of interval is reached
+ !*************************************************************
+
+ if (zeta.le.1.) then
+
+ ! BEGIN TIME LOOP
+ !================
+
+ loop=0
+100 loop=loop+1
+ if (method.eq.1) then
+ ldt=min(ldt,abs(lsynctime-itimec+itime))
+ itimec=itimec+ldt*ldirect
+ else
+ ldt=abs(lsynctime)
+ itimec=itime+lsynctime
+ endif
+ dt=real(ldt)
+
+ zeta=zt/h
+
+
+ if (loop.eq.1) then
+ if (ngrid.le.0) then
+ xts=real(xt)
+ yts=real(yt)
+ call interpol_all(itime,xts,yts,zt)
+ else
+ call interpol_all_nests(itime,xtn,ytn,zt)
+ endif
+
+ else
+
+
+ ! Determine the level below the current position for u,v,rho
+ !***********************************************************
+
+ do i=2,nz
+ if (height(i).gt.zt) then
+ indz=i-1
+ indzp=i
+ goto 6
+ endif
+ end do
+6 continue
+
+ ! If one of the levels necessary is not yet available,
+ ! calculate it
+ !*****************************************************
+
+ do i=indz,indzp
+ if (indzindicator(i)) then
+ if (ngrid.le.0) then
+ call interpol_misslev(i)
+ else
+ call interpol_misslev_nests(i)
+ endif
+ endif
+ end do
+ endif
+
+
+ ! Vertical interpolation of u,v,w,rho and drhodz
+ !***********************************************
+
+ ! Vertical distance to the level below and above current position
+ ! both in terms of (u,v) and (w) fields
+ !****************************************************************
+
+ dz=1./(height(indzp)-height(indz))
+ dz1=(zt-height(indz))*dz
+ dz2=(height(indzp)-zt)*dz
+
+ u=dz1*uprof(indzp)+dz2*uprof(indz)
+ v=dz1*vprof(indzp)+dz2*vprof(indz)
+ w=dz1*wprof(indzp)+dz2*wprof(indz)
+ rhoa=dz1*rhoprof(indzp)+dz2*rhoprof(indz)
+ rhograd=dz1*rhogradprof(indzp)+dz2*rhogradprof(indz)
+
+
+ ! Compute the turbulent disturbances
+ ! Determine the sigmas and the timescales
+ !****************************************
+
+ if (turbswitch) then
+ call hanna(zt)
+ else
+ call hanna1(zt)
+ endif
+
+
+ !*****************************************
+ ! Determine the new diffusivity velocities
+ !*****************************************
+
+ ! Horizontal components
+ !**********************
+
+ if (nrand+1.gt.maxrand) nrand=1
+ if (dt/tlu.lt..5) then
+ up=(1.-dt/tlu)*up+rannumb(nrand)*sigu*sqrt(2.*dt/tlu)
+ else
+ ru=exp(-dt/tlu)
+ up=ru*up+rannumb(nrand)*sigu*sqrt(1.-ru**2)
+ endif
+ if (dt/tlv.lt..5) then
+ vp=(1.-dt/tlv)*vp+rannumb(nrand+1)*sigv*sqrt(2.*dt/tlv)
+ else
+ rv=exp(-dt/tlv)
+ vp=rv*vp+rannumb(nrand+1)*sigv*sqrt(1.-rv**2)
+ endif
+ nrand=nrand+2
+
+
+ if (nrand+ifine.gt.maxrand) nrand=1
+ rhoaux=rhograd/rhoa
+ dtf=dt*fine
+
+ dtftlw=dtf/tlw
+
+ ! Loop over ifine short time steps for vertical component
+ !********************************************************
+
+ do i=1,ifine
+
+ ! Determine the drift velocity and density correction velocity
+ !*************************************************************
+
+ if (turbswitch) then
+ if (dtftlw.lt..5) then
+ wp=((1.-dtftlw)*wp+rannumb(nrand+i)*sqrt(2.*dtftlw) &
+ +dtf*(dsigwdz+rhoaux*sigw))*real(icbt)
+ else
+ rw=exp(-dtftlw)
+ wp=(rw*wp+rannumb(nrand+i)*sqrt(1.-rw**2) &
+ +tlw*(1.-rw)*(dsigwdz+rhoaux*sigw))*real(icbt)
+ endif
+ delz=wp*sigw*dtf
+ else
+ rw=exp(-dtftlw)
+ wp=(rw*wp+rannumb(nrand+i)*sqrt(1.-rw**2)*sigw &
+ +tlw*(1.-rw)*(dsigw2dz+rhoaux*sigw**2))*real(icbt)
+ delz=wp*dtf
+ endif
+
+ !****************************************************
+ ! Compute turbulent vertical displacement of particle
+ !****************************************************
+
+ if (abs(delz).gt.h) delz=mod(delz,h)
+
+ ! Determine if particle transfers to a "forbidden state" below the ground
+ ! or above the mixing height
+ !************************************************************************
+
+ if (delz.lt.-zt) then ! reflection at ground
+ icbt=-1
+ zt=-zt-delz
+ else if (delz.gt.(h-zt)) then ! reflection at h
+ icbt=-1
+ zt=-zt-delz+2.*h
+ else ! no reflection
+ icbt=1
+ zt=zt+delz
+ endif
+
+ if (i.ne.ifine) then
+ zeta=zt/h
+ call hanna_short(zt)
+ endif
+
+ end do
+ nrand=nrand+i
+
+ ! Determine time step for next integration
+ !*****************************************
+
+ if (turbswitch) then
+ ldt=int(min(tlw,h/max(2.*abs(wp*sigw),1.e-5), &
+ 0.5/abs(dsigwdz))*ctl)
+ else
+ ldt=int(min(tlw,h/max(2.*abs(wp),1.e-5))*ctl)
+ endif
+ ldt=max(ldt,mintime)
+
+
+ ! If particle represents only a single species, add gravitational settling
+ ! velocity. The settling velocity is zero for gases, or if particle
+ ! represents more than one species
+ !*************************************************************************
+
+ if (mdomainfill.eq.0) then
+ do nsp=1,nspec
+ if (xmass(nrelpoint,nsp).gt.eps2) goto 887
+ end do
+887 nsp=min(nsp,nspec)
+!!$ if (density(nsp).gt.0.) &
+!!$ call get_settling(itime,xts,yts,zt,nsp,settling) !old
+ if (density(nsp).gt.0.) &
+ call get_settling(itime,real(xt),real(yt),zt,nsp,settling) !bugfix
+ w=w+settling
+ endif
+
+ ! Horizontal displacements during time step dt are small real values compared
+ ! to the position; adding the two, would result in large numerical errors.
+ ! Thus, displacements are accumulated during lsynctime and are added to the
+ ! position at the end
+ !****************************************************************************
+
+ dxsave=dxsave+u*dt
+ dysave=dysave+v*dt
+ dawsave=dawsave+up*dt
+ dcwsave=dcwsave+vp*dt
+ zt=zt+w*dt*real(ldirect)
+
+ if (zt.gt.h) then
+ if (itimec.eq.itime+lsynctime) goto 99
+ goto 700 ! complete the current interval above PBL
+ endif
+
+
+ !!! CHANGE: TEST OF THE WELL-MIXED CRITERION
+ !!! These lines may be switched on to test the well-mixed criterion
+ !if (zt.le.h) then
+ ! zacc=zacc+zt/h*dt
+ ! hsave=hsave+h*dt
+ ! tacc=tacc+dt
+ ! do 67 i=1,iclass
+ ! if ((zt/h.gt.th(i-1)).and.(zt/h.le.th(i)))
+ ! + t(i)=t(i)+dt
+ !7 continue
+ !endif
+ !if ((mod(itime,10800).eq.0).and.dump) then
+ ! dump=.false.
+ ! write(550,'(i6,12f10.3)') itime,hsave/tacc,zacc/tacc,
+ ! + (t(i)/tacc*real(iclass),i=1,iclass)
+ ! zacc=0.
+ ! tacc=0.
+ ! do 68 i=1,iclass
+ !8 t(i)=0.
+ ! hsave=0.
+ !endif
+ !if (mod(itime,10800).ne.0) dump=.true.
+ !!! CHANGE
+
+
+ ! Determine probability of deposition
+ !************************************
+
+ if ((DRYDEP).and.(zt.lt.2.*href)) then
+ do ks=1,nspec
+ if (DRYDEPSPEC(ks)) then
+ if (depoindicator(ks)) then
+ if (ngrid.le.0) then
+ call interpol_vdep(ks,vdepo(ks))
+ else
+ call interpol_vdep_nests(ks,vdepo(ks))
+ endif
+ endif
+ ! correction by Petra Seibert, 10 April 2001
+ ! this formulation means that prob(n) = 1 - f(0)*...*f(n)
+ ! where f(n) is the exponential term
+ prob(ks)=1.+(prob(ks)-1.)* &
+ exp(-vdepo(ks)*abs(dt)/(2.*href))
+ endif
+ end do
+ endif
+
+ if (zt.lt.0.) zt=min(h-eps2,-1.*zt) ! if particle below ground -> reflection
+
+ if (itimec.eq.(itime+lsynctime)) then
+ usig=0.5*(usigprof(indzp)+usigprof(indz))
+ vsig=0.5*(vsigprof(indzp)+vsigprof(indz))
+ wsig=0.5*(wsigprof(indzp)+wsigprof(indz))
+ goto 99 ! finished
+ endif
+ goto 100
+
+ ! END TIME LOOP
+ !==============
+
+
+ endif
+
+
+
+ !**********************************************************
+ ! For all particles that are outside the PBL, make a single
+ ! time step. Only horizontal turbulent disturbances are
+ ! calculated. Vertical disturbances are reset.
+ !**********************************************************
+
+
+ ! Interpolate the wind
+ !*********************
+
+700 continue
+ if (ngrid.le.0) then
+ xts=real(xt)
+ yts=real(yt)
+ call interpol_wind(itime,xts,yts,zt)
+ else
+ call interpol_wind_nests(itime,xtn,ytn,zt)
+ endif
+
+
+ ! Compute everything for above the PBL
+
+ ! Assume constant, uncorrelated, turbulent perturbations
+ ! In the stratosphere, use a small vertical diffusivity d_strat,
+ ! in the troposphere, use a larger horizontal diffusivity d_trop.
+ ! Turbulent velocity scales are determined based on sqrt(d_trop/dt)
+ !******************************************************************
+
+ ldt=abs(lsynctime-itimec+itime)
+ dt=real(ldt)
+
+ if (zt.lt.tropop) then ! in the troposphere
+ uxscale=sqrt(2.*d_trop/dt)
+ if (nrand+1.gt.maxrand) nrand=1
+ ux=rannumb(nrand)*uxscale
+ vy=rannumb(nrand+1)*uxscale
+ nrand=nrand+2
+ wp=0.
+ else if (zt.lt.tropop+1000.) then ! just above the tropopause: make transition
+ weight=(zt-tropop)/1000.
+ uxscale=sqrt(2.*d_trop/dt*(1.-weight))
+ if (nrand+2.gt.maxrand) nrand=1
+ ux=rannumb(nrand)*uxscale
+ vy=rannumb(nrand+1)*uxscale
+ wpscale=sqrt(2.*d_strat/dt*weight)
+ wp=rannumb(nrand+2)*wpscale+d_strat/1000.
+ nrand=nrand+3
+ else ! in the stratosphere
+ if (nrand.gt.maxrand) nrand=1
+ ux=0.
+ vy=0.
+ wpscale=sqrt(2.*d_strat/dt)
+ wp=rannumb(nrand)*wpscale
+ nrand=nrand+1
+ endif
+
+
+ ! If particle represents only a single species, add gravitational settling
+ ! velocity. The settling velocity is zero for gases
+ !*************************************************************************
+
+
+
+ if (mdomainfill.eq.0) then
+ do nsp=1,nspec
+ if (xmass(nrelpoint,nsp).gt.eps2) goto 888
+ end do
+888 nsp=min(nsp,nspec)
+!!$ if (density(nsp).gt.0.) &
+!!$ call get_settling(itime,xts,yts,zt,nsp,settling) !old
+ if (density(nsp).gt.0.) &
+ call get_settling(itime,real(xt),real(yt),zt,nsp,settling) !bugfix
+ w=w+settling
+ endif
+
+ ! Calculate position at time step itime+lsynctime
+ !************************************************
+
+ dxsave=dxsave+(u+ux)*dt
+ dysave=dysave+(v+vy)*dt
+ zt=zt+(w+wp)*dt*real(ldirect)
+ if (zt.lt.0.) zt=min(h-eps2,-1.*zt) ! if particle below ground -> reflection
+
+99 continue
+
+
+
+ !****************************************************************
+ ! Add mesoscale random disturbances
+ ! This is done only once for the whole lsynctime interval to save
+ ! computation time
+ !****************************************************************
+
+
+ ! Mesoscale wind velocity fluctuations are obtained by scaling
+ ! with the standard deviation of the grid-scale winds surrounding
+ ! the particle location, multiplied by a factor turbmesoscale.
+ ! The autocorrelation time constant is taken as half the
+ ! time interval between wind fields
+ !****************************************************************
+
+ r=exp(-2.*real(abs(lsynctime))/real(lwindinterv))
+ rs=sqrt(1.-r**2)
+ if (nrand+2.gt.maxrand) nrand=1
+ usigold=r*usigold+rs*rannumb(nrand)*usig*turbmesoscale
+ vsigold=r*vsigold+rs*rannumb(nrand+1)*vsig*turbmesoscale
+ wsigold=r*wsigold+rs*rannumb(nrand+2)*wsig*turbmesoscale
+
+ dxsave=dxsave+usigold*real(lsynctime)
+ dysave=dysave+vsigold*real(lsynctime)
+
+ zt=zt+wsigold*real(lsynctime)
+ if (zt.lt.0.) zt=-1.*zt ! if particle below ground -> refletion
+
+ !*************************************************************
+ ! Transform along and cross wind components to xy coordinates,
+ ! add them to u and v, transform u,v to grid units/second
+ ! and calculate new position
+ !*************************************************************
+
+ call windalign(dxsave,dysave,dawsave,dcwsave,ux,vy)
+ dxsave=dxsave+ux
+ dysave=dysave+vy
+ if (ngrid.ge.0) then
+ cosfact=dxconst/cos((yt*dy+ylat0)*pi180)
+ xt=xt+real(dxsave*cosfact*real(ldirect),kind=dp)
+ yt=yt+real(dysave*dyconst*real(ldirect),kind=dp)
+ else if (ngrid.eq.-1) then ! around north pole
+ xlon=xlon0+xt*dx
+ ylat=ylat0+yt*dy
+ call cll2xy(northpolemap,ylat,xlon,xpol,ypol)
+ gridsize=1000.*cgszll(northpolemap,ylat,xlon)
+ dxsave=dxsave/gridsize
+ dysave=dysave/gridsize
+ xpol=xpol+dxsave*real(ldirect)
+ ypol=ypol+dysave*real(ldirect)
+ call cxy2ll(northpolemap,xpol,ypol,ylat,xlon)
+ xt=(xlon-xlon0)/dx
+ yt=(ylat-ylat0)/dy
+ else if (ngrid.eq.-2) then ! around south pole
+ xlon=xlon0+xt*dx
+ ylat=ylat0+yt*dy
+ call cll2xy(southpolemap,ylat,xlon,xpol,ypol)
+ gridsize=1000.*cgszll(southpolemap,ylat,xlon)
+ dxsave=dxsave/gridsize
+ dysave=dysave/gridsize
+ xpol=xpol+dxsave*real(ldirect)
+ ypol=ypol+dysave*real(ldirect)
+ call cxy2ll(southpolemap,xpol,ypol,ylat,xlon)
+ xt=(xlon-xlon0)/dx
+ yt=(ylat-ylat0)/dy
+ endif
+
+
+ ! If global data are available, use cyclic boundary condition
+ !************************************************************
+
+ if (xglobal) then
+ if (xt.ge.real(nxmin1)) xt=xt-real(nxmin1)
+ if (xt.lt.0.) xt=xt+real(nxmin1)
+ if (xt.le.eps) xt=eps
+ if (abs(xt-real(nxmin1)).le.eps) xt=real(nxmin1)-eps
+ endif
+
+
+ ! Check position: If trajectory outside model domain, terminate it
+ !*****************************************************************
+
+ if ((xt.lt.0.).or.(xt.ge.real(nxmin1)).or.(yt.lt.0.).or. &
+ (yt.ge.real(nymin1))) then
+ nstop=3
+ return
+ endif
+
+ ! If particle above highest model level, set it back into the domain
+ !*******************************************************************
+
+ if (zt.ge.height(nz)) zt=height(nz)-100.*eps
+
+
+ !************************************************************************
+ ! Now we could finish, as this was done in FLEXPART versions up to 4.0.
+ ! However, truncation errors of the advection can be significantly
+ ! reduced by doing one iteration of the Petterssen scheme, if this is
+ ! possible.
+ ! Note that this is applied only to the grid-scale winds, not to
+ ! the turbulent winds.
+ !************************************************************************
+
+ ! The Petterssen scheme can only applied with long time steps (only then u
+ ! is the "old" wind as required by the scheme); otherwise do nothing
+ !*************************************************************************
+
+ if (ldt.ne.abs(lsynctime)) return
+
+ ! The Petterssen scheme can only be applied if the ending time of the time step
+ ! (itime+ldt*ldirect) is still between the two wind fields held in memory;
+ ! otherwise do nothing
+ !******************************************************************************
+
+ if (abs(itime+ldt*ldirect).gt.abs(memtime(2))) return
+
+ ! Apply it also only if starting and ending point of current time step are on
+ ! the same grid; otherwise do nothing
+ !*****************************************************************************
+ if (nglobal.and.(yt.gt.switchnorthg)) then
+ ngr=-1
+ else if (sglobal.and.(yt.lt.switchsouthg)) then
+ ngr=-2
+ else
+ ngr=0
+ do j=numbnests,1,-1
+ if ((xt.gt.xln(j)+eps).and.(xt.lt.xrn(j)-eps).and. &
+ (yt.gt.yln(j)+eps).and.(yt.lt.yrn(j)-eps)) then
+ ngr=j
+ goto 43
+ endif
+ end do
+43 continue
+ endif
+
+ if (ngr.ne.ngrid) return
+
+ ! Determine nested grid coordinates
+ !**********************************
+
+ if (ngrid.gt.0) then
+ xtn=(xt-xln(ngrid))*xresoln(ngrid)
+ ytn=(yt-yln(ngrid))*yresoln(ngrid)
+ ix=int(xtn)
+ jy=int(ytn)
+ else
+ ix=int(xt)
+ jy=int(yt)
+ endif
+ ixp=ix+1
+ jyp=jy+1
+
+
+ ! Memorize the old wind
+ !**********************
+
+ uold=u
+ vold=v
+ wold=w
+
+ ! Interpolate wind at new position and time
+ !******************************************
+
+ if (ngrid.le.0) then
+ xts=real(xt)
+ yts=real(yt)
+ call interpol_wind_short(itime+ldt*ldirect,xts,yts,zt)
+ else
+ call interpol_wind_short_nests(itime+ldt*ldirect,xtn,ytn,zt)
+ endif
+
+ if (mdomainfill.eq.0) then
+ do nsp=1,nspec
+ if (xmass(nrelpoint,nsp).gt.eps2) goto 889
+ end do
+889 nsp=min(nsp,nspec)
+!!$ if (density(nsp).gt.0.) &
+!!$ call get_settling(itime+ldt,xts,yts,zt,nsp,settling) !old
+ if (density(nsp).gt.0.) &
+ call get_settling(itime+ldt,real(xt),real(yt),zt,nsp,settling) !bugfix
+ w=w+settling
+ endif
+
+
+ ! Determine the difference vector between new and old wind
+ ! (use half of it to correct position according to Petterssen)
+ !*************************************************************
+
+ u=(u-uold)/2.
+ v=(v-vold)/2.
+ w=(w-wold)/2.
+
+
+ ! Finally, correct the old position
+ !**********************************
+
+ zt=zt+w*real(ldt*ldirect)
+ if (zt.lt.0.) zt=min(h-eps2,-1.*zt) ! if particle below ground -> reflection
+ if (ngrid.ge.0) then
+ cosfact=dxconst/cos((yt*dy+ylat0)*pi180)
+ xt=xt+real(u*cosfact*real(ldt*ldirect),kind=dp)
+ yt=yt+real(v*dyconst*real(ldt*ldirect),kind=dp)
+ else if (ngrid.eq.-1) then ! around north pole
+ xlon=xlon0+xt*dx
+ ylat=ylat0+yt*dy
+ call cll2xy(northpolemap,ylat,xlon,xpol,ypol)
+ gridsize=1000.*cgszll(northpolemap,ylat,xlon)
+ u=u/gridsize
+ v=v/gridsize
+ xpol=xpol+u*real(ldt*ldirect)
+ ypol=ypol+v*real(ldt*ldirect)
+ call cxy2ll(northpolemap,xpol,ypol,ylat,xlon)
+ xt=(xlon-xlon0)/dx
+ yt=(ylat-ylat0)/dy
+ else if (ngrid.eq.-2) then ! around south pole
+ xlon=xlon0+xt*dx
+ ylat=ylat0+yt*dy
+ call cll2xy(southpolemap,ylat,xlon,xpol,ypol)
+ gridsize=1000.*cgszll(southpolemap,ylat,xlon)
+ u=u/gridsize
+ v=v/gridsize
+ xpol=xpol+u*real(ldt*ldirect)
+ ypol=ypol+v*real(ldt*ldirect)
+ call cxy2ll(southpolemap,xpol,ypol,ylat,xlon)
+ xt=(xlon-xlon0)/dx
+ yt=(ylat-ylat0)/dy
+ endif
+
+ ! If global data are available, use cyclic boundary condition
+ !************************************************************
+
+ if (xglobal) then
+ if (xt.ge.real(nxmin1)) xt=xt-real(nxmin1)
+ if (xt.lt.0.) xt=xt+real(nxmin1)
+ if (xt.le.eps) xt=eps
+ if (abs(xt-real(nxmin1)).le.eps) xt=real(nxmin1)-eps
+ endif
+
+ ! Check position: If trajectory outside model domain, terminate it
+ !*****************************************************************
+
+ if ((xt.lt.0.).or.(xt.ge.real(nxmin1)).or.(yt.lt.0.).or. &
+ (yt.ge.real(nymin1))) then
+ nstop=3
+ return
+ endif
+
+ ! If particle above highest model level, set it back into the domain
+ !*******************************************************************
+
+ if (zt.ge.height(nz)) zt=height(nz)-100.*eps
+
+
+end subroutine advance
+
diff --git a/src/assignland.f90 b/src/assignland.f90
new file mode 100644
index 0000000000000000000000000000000000000000..6b3ade6efaf60dbc91447bc96c8edba4803f7386
--- /dev/null
+++ b/src/assignland.f90
@@ -0,0 +1,239 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine assignland
+
+ !*****************************************************************************
+ ! *
+ ! This routine assigns fractions of the 13 landuse classes to each ECMWF *
+ ! grid point. *
+ ! The landuse inventory of *
+ ! *
+ ! Belward, A.S., Estes, J.E., and Kline, K.D., 1999, *
+ ! The IGBP-DIS 1-Km Land-Cover Data Set DISCover: *
+ ! A Project Overview: Photogrammetric Engineering and Remote Sensing , *
+ ! v. 65, no. 9, p. 1013-1020 *
+ ! *
+ ! if there are no data in the inventory *
+ ! the ECMWF land/sea mask is used to distinguish *
+ ! between sea (-> ocean) and land (-> grasslands). *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 5 December 1996 *
+ ! 8 February 1999 Additional use of nests, A. Stohl *
+ ! 29 December 2006 new landuse inventory, S. Eckhardt *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! xlanduse fractions of numclass landuses for each model grid point *
+ ! landinvent landuse inventory (0.3 deg resolution) *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: ix,jy,k,l,li,nrefine,iix,jjy
+ integer,parameter :: lumaxx=1200,lumaxy=600
+ integer,parameter :: xlon0lu=-180,ylat0lu=-90
+ real,parameter :: dxlu=0.3
+ real :: xlon,ylat,sumperc,p,xi,yj
+ real :: xlandusep(lumaxx,lumaxy,numclass)
+ ! character*2 ck
+
+ do ix=1,lumaxx
+ do jy=1,lumaxy
+ do k=1,numclass
+ xlandusep(ix,jy,k)=0.
+ end do
+ sumperc=0.
+ do li=1,3
+ sumperc=sumperc+landinvent(ix,jy,li+3)
+ end do
+ do li=1,3
+ k=landinvent(ix,jy,li)
+ if (sumperc.gt.0) then
+ p=landinvent(ix,jy,li+3)/sumperc
+ else
+ p=0
+ endif
+ ! p has values between 0 and 1
+ xlandusep(ix,jy,k)=p
+ end do
+ end do
+ end do
+
+ ! do 13 k=1,11
+ ! write (ck,'(i2.2)') k
+ ! open(4,file='xlandusetest'//ck,form='formatted')
+ ! do 11 ix=1,lumaxx
+ !11 write (4,*) (xlandusep(ix,jy,k),jy=1,lumaxy)
+ !11 write (4,*) (landinvent(ix,jy,k),jy=1,lumaxy)
+ !13 close(4)
+
+ ! write (*,*) xlon0,ylat0,xlon0n(1),ylat0n(1),nxmin1,nymin1
+ ! write (*,*) dx, dy, dxout, dyout, ylat0, xlon0
+ nrefine=10
+ do ix=0,nxmin1
+ do jy=0,nymin1
+ do k=1,numclass
+ sumperc=0.
+ xlanduse(ix,jy,k)=0.
+ end do
+ do iix=1, nrefine
+ xlon=(ix+(iix-1)/real(nrefine))*dx+xlon0 ! longitude, should be between -180 and 179
+ if (xlon.ge.(xlon0lu+lumaxx*dxlu)) then
+ xlon=xlon-lumaxx*dxlu
+ endif
+ do jjy=1, nrefine
+ ylat=(jy+(jjy-1)/real(nrefine))*dy+ylat0 ! and lat. of each gridpoint
+ xi=int((xlon-xlon0lu)/dxlu)+1
+ yj=int((ylat-ylat0lu)/dxlu)+1
+ if (xi.gt.lumaxx) xi=xi-lumaxx
+ if (yj.gt.lumaxy) yj=yj-lumaxy
+ if (xi.lt.0) then
+ write (*,*) 'problem with landuseinv sampling: ', &
+ xlon,xlon0lu,ix,iix,xlon0,dx,nxmax
+ stop
+ endif
+ do k=1,numclass
+ xlanduse(ix,jy,k)= &
+ xlanduse(ix,jy,k)+xlandusep(int(xi),int(yj),k)
+ sumperc=sumperc+xlanduse(ix,jy,k) ! just for the check if landuseinv. is available
+ end do
+ end do
+ end do
+ if (sumperc.gt.0) then ! detailed landuse available
+ sumperc=0.
+ do k=1,numclass
+ xlanduse(ix,jy,k)= &
+ xlanduse(ix,jy,k)/real(nrefine*nrefine)
+ sumperc=sumperc+xlanduse(ix,jy,k)
+ end do
+ !cc the sum of all categories should be 1 ... 100 percent ... in order to get vdep right!
+ if (sumperc.lt.1-1E-5) then
+ do k=1,numclass
+ xlanduse(ix,jy,k)= &
+ xlanduse(ix,jy,k)/sumperc
+ end do
+ endif
+ else
+ if (lsm(ix,jy).lt.0.1) then ! over sea -> ocean
+ xlanduse(ix,jy,3)=1.
+ else ! over land -> rangeland
+ xlanduse(ix,jy,7)=1.
+ endif
+ endif
+
+
+ end do
+ end do
+
+ !***********************************
+ ! for test: write out xlanduse
+
+ ! open(4,file='landusetest',form='formatted')
+ ! do 56 k=1,13
+ ! do 55 ix=0,nxmin1
+ !55 write (4,*) (xlanduse(ix,jy,k),jy=0,nymin1)
+ !56 continue
+ ! close(4)
+ ! write (*,*) 'landuse written'
+ !stop
+ ! open(4,file='landseatest'//ck,form='formatted')
+ ! do 57 ix=0,nxmin1
+ !57 write (4,*) (lsm(ix,jy),jy=0,nymin1)
+ ! write (*,*) 'landseamask written'
+
+ !****************************************
+ ! Same as above, but for the nested grids
+ !****************************************
+
+ !************** TEST ********************
+ ! dyn(1)=dyn(1)/40
+ ! dxn(1)=dxn(1)/40
+ ! xlon0n(1)=1
+ ! ylat0n(1)=50
+ !************** TEST ********************
+
+ do l=1,numbnests
+ do ix=0,nxn(l)-1
+ do jy=0,nyn(l)-1
+ do k=1,numclass
+ sumperc=0.
+ xlandusen(ix,jy,k,l)=0.
+ end do
+ do iix=1, nrefine
+ xlon=(ix+(iix-1)/real(nrefine))*dxn(l)+xlon0n(l)
+ do jjy=1, nrefine
+ ylat=(jy+(jjy-1)/real(nrefine))*dyn(l)+ylat0n(l)
+ xi=int((xlon-xlon0lu)/dxlu)+1
+ yj=int((ylat-ylat0lu)/dxlu)+1
+ if (xi.gt.lumaxx) xi=xi-lumaxx
+ if (yj.gt.lumaxy) yj=yj-lumaxy
+ do k=1,numclass
+ xlandusen(ix,jy,k,l)=xlandusen(ix,jy,k,l)+ &
+ xlandusep(int(xi),int(yj),k)
+ sumperc=sumperc+xlandusen(ix,jy,k,l)
+ end do
+ end do
+ end do
+ if (sumperc.gt.0) then ! detailed landuse available
+ sumperc=0.
+ do k=1,numclass
+ xlandusen(ix,jy,k,l)= &
+ xlandusen(ix,jy,k,l)/real(nrefine*nrefine)
+ sumperc=sumperc+xlandusen(ix,jy,k,l)
+ end do
+ !cc the sum of all categories should be 1 ... 100 percent ... in order to get vdep right!
+ if (sumperc.lt.1-1E-5) then
+ do k=1,numclass
+ xlandusen(ix,jy,k,l)=xlandusen(ix,jy,k,l)/sumperc
+ end do
+ endif
+ else ! check land/sea mask
+ if (lsmn(ix,jy,l).lt.0.1) then ! over sea -> ocean
+ xlandusen(ix,jy,3,l)=1.
+ else ! over land -> grasslands
+ xlandusen(ix,jy,7,l)=1.
+ endif
+ endif
+ end do
+ end do
+ end do
+
+ !***********************************
+ ! for test: write out xlanduse
+
+ ! do 66 k=1,11
+ ! write (ck,'(i2.2)') k
+ ! open(4,file='nlandusetest'//ck,form='formatted')
+ ! do 65 ix=0,nxn(1)-1
+ !65 write (4,*) (xlandusen(ix,jy,k,1),jy=0,nyn(1)-1)
+ !66 close(4)
+
+ ! write (*,*) 'landuse nested written'
+
+
+end subroutine assignland
diff --git a/src/boundcond_domainfill.f90 b/src/boundcond_domainfill.f90
new file mode 100644
index 0000000000000000000000000000000000000000..b1b407e1368a5e111e083ec703b8de71f6b9ab04
--- /dev/null
+++ b/src/boundcond_domainfill.f90
@@ -0,0 +1,588 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine boundcond_domainfill(itime,loutend)
+ ! i i
+ !*****************************************************************************
+ ! *
+ ! Particles are created by this subroutine continuously throughout the *
+ ! simulation at the boundaries of the domain-filling box. *
+ ! All particles carry the same amount of mass which alltogether comprises the*
+ ! mass of air within the box, which remains (more or less) constant. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 16 October 2002 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! nx_we(2) grid indices for western and eastern boundary of domain- *
+ ! filling trajectory calculations *
+ ! ny_sn(2) grid indices for southern and northern boundary of domain- *
+ ! filling trajectory calculations *
+ ! *
+ !*****************************************************************************
+
+ use point_mod
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ real :: dz,dz1,dz2,ran1,dt1,dt2,dtt,ylat,xm,cosfact,accmasst
+ integer :: itime,in,indz,indzp,i,loutend
+ integer :: j,k,ix,jy,m,indzh,indexh,minpart,ipart,mmass
+ integer :: numactiveparticles
+
+ real :: windl(2),rhol(2)
+ real :: windhl(2),rhohl(2)
+ real :: windx,rhox
+ real :: deltaz,boundarea,fluxofmass
+
+ integer :: ixm,ixp,jym,jyp,indzm,mm
+ real :: pvpart,ddx,ddy,rddx,rddy,p1,p2,p3,p4,y1(2),yh1(2)
+
+ integer :: idummy = -11
+
+
+ ! If domain-filling is global, no boundary conditions are needed
+ !***************************************************************
+
+ if (gdomainfill) return
+
+ accmasst=0.
+ numactiveparticles=0
+
+ ! Terminate trajectories that have left the domain, if domain-filling
+ ! trajectory calculation domain is not global
+ !********************************************************************
+
+ do i=1,numpart
+ if (itra1(i).eq.itime) then
+ if ((ytra1(i).gt.real(ny_sn(2))).or. &
+ (ytra1(i).lt.real(ny_sn(1)))) itra1(i)=-999999999
+ if (((.not.xglobal).or.(nx_we(2).ne.(nx-2))).and. &
+ ((xtra1(i).lt.real(nx_we(1))).or. &
+ (xtra1(i).gt.real(nx_we(2))))) itra1(i)=-999999999
+ endif
+ if (itra1(i).ne.-999999999) numactiveparticles= &
+ numactiveparticles+1
+ end do
+
+
+ ! Determine auxiliary variables for time interpolation
+ !*****************************************************
+
+ dt1=real(itime-memtime(1))
+ dt2=real(memtime(2)-itime)
+ dtt=1./(dt1+dt2)
+
+ ! Initialize auxiliary variable used to search for vacant storage space
+ !**********************************************************************
+
+ minpart=1
+
+ !***************************************
+ ! Western and eastern boundary condition
+ !***************************************
+
+ ! Loop from south to north
+ !*************************
+
+ do jy=ny_sn(1),ny_sn(2)
+
+ ! Loop over western (index 1) and eastern (index 2) boundary
+ !***********************************************************
+
+ do k=1,2
+
+ ! Loop over all release locations in a column
+ !********************************************
+
+ do j=1,numcolumn_we(k,jy)
+
+ ! Determine, for each release location, the area of the corresponding boundary
+ !*****************************************************************************
+
+ if (j.eq.1) then
+ deltaz=(zcolumn_we(k,jy,2)+zcolumn_we(k,jy,1))/2.
+ else if (j.eq.numcolumn_we(k,jy)) then
+ ! deltaz=height(nz)-(zcolumn_we(k,jy,j-1)+
+ ! + zcolumn_we(k,jy,j))/2.
+ ! In order to avoid taking a very high column for very many particles,
+ ! use the deltaz from one particle below instead
+ deltaz=(zcolumn_we(k,jy,j)-zcolumn_we(k,jy,j-2))/2.
+ else
+ deltaz=(zcolumn_we(k,jy,j+1)-zcolumn_we(k,jy,j-1))/2.
+ endif
+ if ((jy.eq.ny_sn(1)).or.(jy.eq.ny_sn(2))) then
+ boundarea=deltaz*111198.5/2.*dy
+ else
+ boundarea=deltaz*111198.5*dy
+ endif
+
+
+ ! Interpolate the wind velocity and density to the release location
+ !******************************************************************
+
+ ! Determine the model level below the release position
+ !*****************************************************
+
+ do i=2,nz
+ if (height(i).gt.zcolumn_we(k,jy,j)) then
+ indz=i-1
+ indzp=i
+ goto 6
+ endif
+ end do
+6 continue
+
+ ! Vertical distance to the level below and above current position
+ !****************************************************************
+
+ dz1=zcolumn_we(k,jy,j)-height(indz)
+ dz2=height(indzp)-zcolumn_we(k,jy,j)
+ dz=1./(dz1+dz2)
+
+ ! Vertical and temporal interpolation
+ !************************************
+
+ do m=1,2
+ indexh=memind(m)
+ do in=1,2
+ indzh=indz+in-1
+ windl(in)=uu(nx_we(k),jy,indzh,indexh)
+ rhol(in)=rho(nx_we(k),jy,indzh,indexh)
+ end do
+
+ windhl(m)=(dz2*windl(1)+dz1*windl(2))*dz
+ rhohl(m)=(dz2*rhol(1)+dz1*rhol(2))*dz
+ end do
+
+ windx=(windhl(1)*dt2+windhl(2)*dt1)*dtt
+ rhox=(rhohl(1)*dt2+rhohl(2)*dt1)*dtt
+
+ ! Calculate mass flux
+ !********************
+
+ fluxofmass=windx*rhox*boundarea*real(lsynctime)
+
+
+ ! If the mass flux is directed into the domain, add it to previous mass fluxes;
+ ! if it is out of the domain, set accumulated mass flux to zero
+ !******************************************************************************
+
+ if (k.eq.1) then
+ if (fluxofmass.ge.0.) then
+ acc_mass_we(k,jy,j)=acc_mass_we(k,jy,j)+fluxofmass
+ else
+ acc_mass_we(k,jy,j)=0.
+ endif
+ else
+ if (fluxofmass.le.0.) then
+ acc_mass_we(k,jy,j)=acc_mass_we(k,jy,j)+abs(fluxofmass)
+ else
+ acc_mass_we(k,jy,j)=0.
+ endif
+ endif
+ accmasst=accmasst+acc_mass_we(k,jy,j)
+
+ ! If the accumulated mass exceeds half the mass that each particle shall carry,
+ ! one (or more) particle(s) is (are) released and the accumulated mass is
+ ! reduced by the mass of this (these) particle(s)
+ !******************************************************************************
+
+ if (acc_mass_we(k,jy,j).ge.xmassperparticle/2.) then
+ mmass=int((acc_mass_we(k,jy,j)+xmassperparticle/2.)/ &
+ xmassperparticle)
+ acc_mass_we(k,jy,j)=acc_mass_we(k,jy,j)- &
+ real(mmass)*xmassperparticle
+ else
+ mmass=0
+ endif
+
+ do m=1,mmass
+ do ipart=minpart,maxpart
+
+ ! If a vacant storage space is found, attribute everything to this array element
+ !*****************************************************************************
+
+ if (itra1(ipart).ne.itime) then
+
+ ! Assign particle positions
+ !**************************
+
+ xtra1(ipart)=real(nx_we(k))
+ if (jy.eq.ny_sn(1)) then
+ ytra1(ipart)=real(jy)+0.5*ran1(idummy)
+ else if (jy.eq.ny_sn(2)) then
+ ytra1(ipart)=real(jy)-0.5*ran1(idummy)
+ else
+ ytra1(ipart)=real(jy)+(ran1(idummy)-.5)
+ endif
+ if (j.eq.1) then
+ ztra1(ipart)=zcolumn_we(k,jy,1)+(zcolumn_we(k,jy,2)- &
+ zcolumn_we(k,jy,1))/4.
+ else if (j.eq.numcolumn_we(k,jy)) then
+ ztra1(ipart)=(2.*zcolumn_we(k,jy,j)+ &
+ zcolumn_we(k,jy,j-1)+height(nz))/4.
+ else
+ ztra1(ipart)=zcolumn_we(k,jy,j-1)+ran1(idummy)* &
+ (zcolumn_we(k,jy,j+1)-zcolumn_we(k,jy,j-1))
+ endif
+
+ ! Interpolate PV to the particle position
+ !****************************************
+ ixm=int(xtra1(ipart))
+ jym=int(ytra1(ipart))
+ ixp=ixm+1
+ jyp=jym+1
+ ddx=xtra1(ipart)-real(ixm)
+ ddy=ytra1(ipart)-real(jym)
+ rddx=1.-ddx
+ rddy=1.-ddy
+ p1=rddx*rddy
+ p2=ddx*rddy
+ p3=rddx*ddy
+ p4=ddx*ddy
+ do i=2,nz
+ if (height(i).gt.ztra1(ipart)) then
+ indzm=i-1
+ indzp=i
+ goto 26
+ endif
+ end do
+26 continue
+ dz1=ztra1(ipart)-height(indzm)
+ dz2=height(indzp)-ztra1(ipart)
+ dz=1./(dz1+dz2)
+ do mm=1,2
+ indexh=memind(mm)
+ do in=1,2
+ indzh=indzm+in-1
+ y1(in)=p1*pv(ixm,jym,indzh,indexh) &
+ +p2*pv(ixp,jym,indzh,indexh) &
+ +p3*pv(ixm,jyp,indzh,indexh) &
+ +p4*pv(ixp,jyp,indzh,indexh)
+ end do
+ yh1(mm)=(dz2*y1(1)+dz1*y1(2))*dz
+ end do
+ pvpart=(yh1(1)*dt2+yh1(2)*dt1)*dtt
+ ylat=ylat0+ytra1(ipart)*dy
+ if (ylat.lt.0.) pvpart=-1.*pvpart
+
+
+ ! For domain-filling option 2 (stratospheric O3), do the rest only in the stratosphere
+ !*****************************************************************************
+
+ if (((ztra1(ipart).gt.3000.).and. &
+ (pvpart.gt.pvcrit)).or.(mdomainfill.eq.1)) then
+ nclass(ipart)=min(int(ran1(idummy)* &
+ real(nclassunc))+1,nclassunc)
+ numactiveparticles=numactiveparticles+1
+ numparticlecount=numparticlecount+1
+ npoint(ipart)=numparticlecount
+ idt(ipart)=mintime
+ itra1(ipart)=itime
+ itramem(ipart)=itra1(ipart)
+ itrasplit(ipart)=itra1(ipart)+ldirect*itsplit
+ xmass1(ipart,1)=xmassperparticle
+ if (mdomainfill.eq.2) xmass1(ipart,1)= &
+ xmass1(ipart,1)*pvpart*48./29.*ozonescale/10.**9
+ else
+ goto 71
+ endif
+
+
+ ! Increase numpart, if necessary
+ !*******************************
+
+ numpart=max(numpart,ipart)
+ goto 73 ! Storage space has been found, stop searching
+ endif
+ end do
+ if (ipart.gt.maxpart) &
+ stop 'boundcond_domainfill.f: too many particles required'
+73 minpart=ipart+1
+71 continue
+ end do
+
+
+ end do
+ end do
+ end do
+
+
+ !*****************************************
+ ! Southern and northern boundary condition
+ !*****************************************
+
+ ! Loop from west to east
+ !***********************
+
+ do ix=nx_we(1),nx_we(2)
+
+ ! Loop over southern (index 1) and northern (index 2) boundary
+ !*************************************************************
+
+ do k=1,2
+ ylat=ylat0+real(ny_sn(k))*dy
+ cosfact=cos(ylat*pi180)
+
+ ! Loop over all release locations in a column
+ !********************************************
+
+ do j=1,numcolumn_sn(k,ix)
+
+ ! Determine, for each release location, the area of the corresponding boundary
+ !*****************************************************************************
+
+ if (j.eq.1) then
+ deltaz=(zcolumn_sn(k,ix,2)+zcolumn_sn(k,ix,1))/2.
+ else if (j.eq.numcolumn_sn(k,ix)) then
+ ! deltaz=height(nz)-(zcolumn_sn(k,ix,j-1)+
+ ! + zcolumn_sn(k,ix,j))/2.
+ ! In order to avoid taking a very high column for very many particles,
+ ! use the deltaz from one particle below instead
+ deltaz=(zcolumn_sn(k,ix,j)-zcolumn_sn(k,ix,j-2))/2.
+ else
+ deltaz=(zcolumn_sn(k,ix,j+1)-zcolumn_sn(k,ix,j-1))/2.
+ endif
+ if ((ix.eq.nx_we(1)).or.(ix.eq.nx_we(2))) then
+ boundarea=deltaz*111198.5/2.*cosfact*dx
+ else
+ boundarea=deltaz*111198.5*cosfact*dx
+ endif
+
+
+ ! Interpolate the wind velocity and density to the release location
+ !******************************************************************
+
+ ! Determine the model level below the release position
+ !*****************************************************
+
+ do i=2,nz
+ if (height(i).gt.zcolumn_sn(k,ix,j)) then
+ indz=i-1
+ indzp=i
+ goto 16
+ endif
+ end do
+16 continue
+
+ ! Vertical distance to the level below and above current position
+ !****************************************************************
+
+ dz1=zcolumn_sn(k,ix,j)-height(indz)
+ dz2=height(indzp)-zcolumn_sn(k,ix,j)
+ dz=1./(dz1+dz2)
+
+ ! Vertical and temporal interpolation
+ !************************************
+
+ do m=1,2
+ indexh=memind(m)
+ do in=1,2
+ indzh=indz+in-1
+ windl(in)=vv(ix,ny_sn(k),indzh,indexh)
+ rhol(in)=rho(ix,ny_sn(k),indzh,indexh)
+ end do
+
+ windhl(m)=(dz2*windl(1)+dz1*windl(2))*dz
+ rhohl(m)=(dz2*rhol(1)+dz1*rhol(2))*dz
+ end do
+
+ windx=(windhl(1)*dt2+windhl(2)*dt1)*dtt
+ rhox=(rhohl(1)*dt2+rhohl(2)*dt1)*dtt
+
+ ! Calculate mass flux
+ !********************
+
+ fluxofmass=windx*rhox*boundarea*real(lsynctime)
+
+ ! If the mass flux is directed into the domain, add it to previous mass fluxes;
+ ! if it is out of the domain, set accumulated mass flux to zero
+ !******************************************************************************
+
+ if (k.eq.1) then
+ if (fluxofmass.ge.0.) then
+ acc_mass_sn(k,ix,j)=acc_mass_sn(k,ix,j)+fluxofmass
+ else
+ acc_mass_sn(k,ix,j)=0.
+ endif
+ else
+ if (fluxofmass.le.0.) then
+ acc_mass_sn(k,ix,j)=acc_mass_sn(k,ix,j)+abs(fluxofmass)
+ else
+ acc_mass_sn(k,ix,j)=0.
+ endif
+ endif
+ accmasst=accmasst+acc_mass_sn(k,ix,j)
+
+ ! If the accumulated mass exceeds half the mass that each particle shall carry,
+ ! one (or more) particle(s) is (are) released and the accumulated mass is
+ ! reduced by the mass of this (these) particle(s)
+ !******************************************************************************
+
+ if (acc_mass_sn(k,ix,j).ge.xmassperparticle/2.) then
+ mmass=int((acc_mass_sn(k,ix,j)+xmassperparticle/2.)/ &
+ xmassperparticle)
+ acc_mass_sn(k,ix,j)=acc_mass_sn(k,ix,j)- &
+ real(mmass)*xmassperparticle
+ else
+ mmass=0
+ endif
+
+ do m=1,mmass
+ do ipart=minpart,maxpart
+
+ ! If a vacant storage space is found, attribute everything to this array element
+ !*****************************************************************************
+
+ if (itra1(ipart).ne.itime) then
+
+ ! Assign particle positions
+ !**************************
+
+ ytra1(ipart)=real(ny_sn(k))
+ if (ix.eq.nx_we(1)) then
+ xtra1(ipart)=real(ix)+0.5*ran1(idummy)
+ else if (ix.eq.nx_we(2)) then
+ xtra1(ipart)=real(ix)-0.5*ran1(idummy)
+ else
+ xtra1(ipart)=real(ix)+(ran1(idummy)-.5)
+ endif
+ if (j.eq.1) then
+ ztra1(ipart)=zcolumn_sn(k,ix,1)+(zcolumn_sn(k,ix,2)- &
+ zcolumn_sn(k,ix,1))/4.
+ else if (j.eq.numcolumn_sn(k,ix)) then
+ ztra1(ipart)=(2.*zcolumn_sn(k,ix,j)+ &
+ zcolumn_sn(k,ix,j-1)+height(nz))/4.
+ else
+ ztra1(ipart)=zcolumn_sn(k,ix,j-1)+ran1(idummy)* &
+ (zcolumn_sn(k,ix,j+1)-zcolumn_sn(k,ix,j-1))
+ endif
+
+
+ ! Interpolate PV to the particle position
+ !****************************************
+ ixm=int(xtra1(ipart))
+ jym=int(ytra1(ipart))
+ ixp=ixm+1
+ jyp=jym+1
+ ddx=xtra1(ipart)-real(ixm)
+ ddy=ytra1(ipart)-real(jym)
+ rddx=1.-ddx
+ rddy=1.-ddy
+ p1=rddx*rddy
+ p2=ddx*rddy
+ p3=rddx*ddy
+ p4=ddx*ddy
+ do i=2,nz
+ if (height(i).gt.ztra1(ipart)) then
+ indzm=i-1
+ indzp=i
+ goto 126
+ endif
+ end do
+126 continue
+ dz1=ztra1(ipart)-height(indzm)
+ dz2=height(indzp)-ztra1(ipart)
+ dz=1./(dz1+dz2)
+ do mm=1,2
+ indexh=memind(mm)
+ do in=1,2
+ indzh=indzm+in-1
+ y1(in)=p1*pv(ixm,jym,indzh,indexh) &
+ +p2*pv(ixp,jym,indzh,indexh) &
+ +p3*pv(ixm,jyp,indzh,indexh) &
+ +p4*pv(ixp,jyp,indzh,indexh)
+ end do
+ yh1(mm)=(dz2*y1(1)+dz1*y1(2))*dz
+ end do
+ pvpart=(yh1(1)*dt2+yh1(2)*dt1)*dtt
+ if (ylat.lt.0.) pvpart=-1.*pvpart
+
+
+ ! For domain-filling option 2 (stratospheric O3), do the rest only in the stratosphere
+ !*****************************************************************************
+
+ if (((ztra1(ipart).gt.3000.).and. &
+ (pvpart.gt.pvcrit)).or.(mdomainfill.eq.1)) then
+ nclass(ipart)=min(int(ran1(idummy)* &
+ real(nclassunc))+1,nclassunc)
+ numactiveparticles=numactiveparticles+1
+ numparticlecount=numparticlecount+1
+ npoint(ipart)=numparticlecount
+ idt(ipart)=mintime
+ itra1(ipart)=itime
+ itramem(ipart)=itra1(ipart)
+ itrasplit(ipart)=itra1(ipart)+ldirect*itsplit
+ xmass1(ipart,1)=xmassperparticle
+ if (mdomainfill.eq.2) xmass1(ipart,1)= &
+ xmass1(ipart,1)*pvpart*48./29.*ozonescale/10.**9
+ else
+ goto 171
+ endif
+
+
+ ! Increase numpart, if necessary
+ !*******************************
+ numpart=max(numpart,ipart)
+ goto 173 ! Storage space has been found, stop searching
+ endif
+ end do
+ if (ipart.gt.maxpart) &
+ stop 'boundcond_domainfill.f: too many particles required'
+173 minpart=ipart+1
+171 continue
+ end do
+
+
+ end do
+ end do
+ end do
+
+
+ xm=0.
+ do i=1,numpart
+ if (itra1(i).eq.itime) xm=xm+xmass1(i,1)
+ end do
+
+ !write(*,*) itime,numactiveparticles,numparticlecount,numpart,
+ ! +xm,accmasst,xm+accmasst
+
+
+ ! If particles shall be dumped, then accumulated masses at the domain boundaries
+ ! must be dumped, too, to be used for later runs
+ !*****************************************************************************
+
+ if ((ipout.gt.0).and.(itime.eq.loutend)) then
+ open(unitboundcond,file=path(2)(1:length(2))//'boundcond.bin', &
+ form='unformatted')
+ write(unitboundcond) numcolumn_we,numcolumn_sn, &
+ zcolumn_we,zcolumn_sn,acc_mass_we,acc_mass_sn
+ close(unitboundcond)
+ endif
+
+end subroutine boundcond_domainfill
diff --git a/src/calcfluxes.f90 b/src/calcfluxes.f90
new file mode 100644
index 0000000000000000000000000000000000000000..6713da4b7f8a3c0947bd2428d552a012f10e7108
--- /dev/null
+++ b/src/calcfluxes.f90
@@ -0,0 +1,187 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine calcfluxes(nage,jpart,xold,yold,zold)
+ ! i i i i i
+ !*****************************************************************************
+ ! *
+ ! Calculation of the gross fluxes across horizontal, eastward and *
+ ! northward facing surfaces. The routine calculates the mass flux *
+ ! due to the motion of only one particle. The fluxes of subsequent calls *
+ ! to this subroutine are accumulated until the next output is due. *
+ ! Upon output, flux fields are re-set to zero in subroutine fluxoutput.f.*
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 04 April 2000 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! nage Age class of the particle considered *
+ ! jpart Index of the particle considered *
+ ! xold,yold,zold "Memorized" old positions of the particle *
+ ! *
+ !*****************************************************************************
+
+ use flux_mod
+ use outg_mod
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: jpart,nage,ixave,jyave,kz,kzave,kp
+ integer :: k,k1,k2,ix,ix1,ix2,ixs,jy,jy1,jy2
+ real :: xold,yold,zold,xmean,ymean
+
+
+ ! Determine average positions
+ !****************************
+
+ if ((ioutputforeachrelease.eq.1).and.(mdomainfill.eq.0)) then
+ kp=npoint(jpart)
+ else
+ kp=1
+ endif
+
+ xmean=(xold+xtra1(jpart))/2.
+ ymean=(yold+ytra1(jpart))/2.
+
+ ixave=int((xmean*dx+xoutshift)/dxout)
+ jyave=int((ymean*dy+youtshift)/dyout)
+ do kz=1,numzgrid ! determine height of cell
+ if (outheight(kz).gt.ztra1(jpart)) goto 16
+ end do
+16 kzave=kz
+
+
+ ! Determine vertical fluxes
+ !**************************
+
+ if ((ixave.ge.0).and.(jyave.ge.0).and.(ixave.le.numxgrid-1).and. &
+ (jyave.le.numygrid-1)) then
+ do kz=1,numzgrid ! determine height of cell
+ if (outheighthalf(kz).gt.zold) goto 11
+ end do
+11 k1=min(numzgrid,kz)
+ do kz=1,numzgrid ! determine height of cell
+ if (outheighthalf(kz).gt.ztra1(jpart)) goto 21
+ end do
+21 k2=min(numzgrid,kz)
+
+ do k=1,nspec
+ do kz=k1,k2-1
+ flux(5,ixave,jyave,kz,k,kp,nage)= &
+ flux(5,ixave,jyave,kz,k,kp,nage)+ &
+ xmass1(jpart,k)
+ end do
+ do kz=k2,k1-1
+ flux(6,ixave,jyave,kz,k,kp,nage)= &
+ flux(6,ixave,jyave,kz,k,kp,nage)+ &
+ xmass1(jpart,k)
+ end do
+ end do
+ endif
+
+
+ ! Determine west-east fluxes (fluxw) and east-west fluxes (fluxe)
+ !****************************************************************
+
+ if ((kzave.le.numzgrid).and.(jyave.ge.0).and. &
+ (jyave.le.numygrid-1)) then
+
+ ! 1) Particle does not cross domain boundary
+
+ if (abs(xold-xtra1(jpart)).lt.real(nx)/2.) then
+ ix1=int((xold*dx+xoutshift)/dxout+0.5)
+ ix2=int((xtra1(jpart)*dx+xoutshift)/dxout+0.5)
+ do k=1,nspec
+ do ix=ix1,ix2-1
+ if ((ix.ge.0).and.(ix.le.numxgrid-1)) then
+ flux(1,ix,jyave,kzave,k,kp,nage)= &
+ flux(1,ix,jyave,kzave,k,kp,nage) &
+ +xmass1(jpart,k)
+ endif
+ end do
+ do ix=ix2,ix1-1
+ if ((ix.ge.0).and.(ix.le.numxgrid-1)) then
+ flux(2,ix,jyave,kzave,k,kp,nage)= &
+ flux(2,ix,jyave,kzave,k,kp,nage) &
+ +xmass1(jpart,k)
+ endif
+ end do
+ end do
+
+ ! 2) Particle crosses domain boundary: use cyclic boundary condition
+ ! and attribute flux to easternmost grid row only (approximation valid
+ ! for relatively slow motions compared to output grid cell size)
+
+ else
+ ixs=int(((real(nxmin1)-1.e5)*dx+xoutshift)/dxout)
+ if ((ixs.ge.0).and.(ixs.le.numxgrid-1)) then
+ if (xold.gt.xtra1(jpart)) then ! west-east flux
+ do k=1,nspec
+ flux(1,ixs,jyave,kzave,k,kp,nage)= &
+ flux(1,ixs,jyave,kzave,k,kp,nage) &
+ +xmass1(jpart,k)
+ end do
+ else ! east-west flux
+ do k=1,nspec
+ flux(2,ixs,jyave,kzave,k,kp,nage)= &
+ flux(2,ixs,jyave,kzave,k,kp,nage) &
+ +xmass1(jpart,k)
+ end do
+ endif
+ endif
+ endif
+ endif
+
+
+ ! Determine south-north fluxes (fluxs) and north-south fluxes (fluxn)
+ !********************************************************************
+
+ if ((kzave.le.numzgrid).and.(ixave.ge.0).and. &
+ (ixave.le.numxgrid-1)) then
+ jy1=int((yold*dy+youtshift)/dyout+0.5)
+ jy2=int((ytra1(jpart)*dy+youtshift)/dyout+0.5)
+
+ do k=1,nspec
+ do jy=jy1,jy2-1
+ if ((jy.ge.0).and.(jy.le.numygrid-1)) then
+ flux(3,ixave,jy,kzave,k,kp,nage)= &
+ flux(3,ixave,jy,kzave,k,kp,nage) &
+ +xmass1(jpart,k)
+ endif
+ end do
+ do jy=jy2,jy1-1
+ if ((jy.ge.0).and.(jy.le.numygrid-1)) then
+ flux(4,ixave,jy,kzave,k,kp,nage)= &
+ flux(4,ixave,jy,kzave,k,kp,nage) &
+ +xmass1(jpart,k)
+ endif
+ end do
+ end do
+ endif
+
+end subroutine calcfluxes
+
diff --git a/src/calcmatrix.f90 b/src/calcmatrix.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d17d9ad508f5a68db4147c6a48bdeb5818bc4c54
--- /dev/null
+++ b/src/calcmatrix.f90
@@ -0,0 +1,142 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine calcmatrix(lconv,delt,cbmf)
+ ! o i o
+ !*****************************************************************************
+ ! *
+ ! This subroutine calculates the matrix describing convective *
+ ! redistribution of mass in a grid column, using the subroutine *
+ ! convect43c.f provided by Kerry Emanuel. *
+ ! *
+ ! Petra Seibert, Bernd C. Krueger, 2000-2001 *
+ ! *
+ ! changed by C. Forster, November 2003 - February 2004 *
+ ! array fmassfrac(nconvlevmax,nconvlevmax) represents *
+ ! the convective redistribution matrix for the particles *
+ ! *
+ ! lconv indicates whether there is convection in this cell, or not *
+ ! delt time step for convection [s] *
+ ! cbmf cloud base mass flux *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+ use conv_mod
+
+ implicit none
+
+ real :: rlevmass,summe
+
+ integer :: iflag, k, kk, kuvz
+
+ !1-d variables for convection
+ !variables for redistribution matrix
+ real :: cbmfold, precip, qprime
+ real :: tprime, wd, f_qvsat
+ real :: delt,cbmf
+ logical :: lconv
+
+ lconv = .false.
+
+
+ ! calculate pressure at eta levels for use in convect
+ ! and assign temp & spec. hum. to 1D workspace
+ ! -------------------------------------------------------
+
+ ! pconv(1) is the pressure at the first level above ground
+ ! phconv(k) is the pressure between levels k-1 and k
+ ! dpr(k) is the pressure difference "around" tconv(k)
+ ! phconv(kmax) must also be defined 1/2 level above pconv(kmax)
+ ! Therefore, we define k = kuvz-1 and let kuvz start from 2
+ ! top layer cannot be used for convection because p at top of this layer is
+ ! not given
+
+
+ phconv(1) = psconv
+ ! Emanuel subroutine needs pressure in hPa, therefore convert all pressures
+ do kuvz = 2,nuvz
+ k = kuvz-1
+ pconv(k) = (akz(kuvz) + bkz(kuvz)*psconv)
+ phconv(kuvz) = (akm(kuvz) + bkm(kuvz)*psconv)
+ dpr(k) = phconv(k) - phconv(kuvz)
+ qsconv(k) = f_qvsat( pconv(k), tconv(k) )
+
+ ! initialize mass fractions
+ do kk=1,nconvlev
+ fmassfrac(k,kk)=0.
+ enddo
+ enddo
+
+
+ !note that Emanuel says it is important
+ !a. to set this =0. every grid point
+ !b. to keep this value in the calling programme in the iteration
+
+ ! CALL CONVECTION
+ !******************
+
+ cbmfold = cbmf
+ ! Convert pressures to hPa, as required by Emanuel scheme
+ !********************************************************
+!!$ do k=1,nconvlev !old
+ do k=1,nconvlev+1 !bugfix
+ pconv_hpa(k)=pconv(k)/100.
+ phconv_hpa(k)=phconv(k)/100.
+ end do
+ phconv_hpa(nconvlev+1)=phconv(nconvlev+1)/100.
+ call convect(nconvlevmax, nconvlev, delt, iflag, &
+ precip, wd, tprime, qprime, cbmf)
+
+ ! do not update fmassfrac and cloudbase massflux
+ ! if no convection takes place or
+ ! if a CFL criterion is violated in convect43c.f
+ if (iflag .ne. 1 .and. iflag .ne. 4) then
+ cbmf=cbmfold
+ goto 200
+ endif
+
+ ! do not update fmassfrac and cloudbase massflux
+ ! if the old and the new cloud base mass
+ ! fluxes are zero
+ if (cbmf.le.0..and.cbmfold.le.0.) then
+ cbmf=cbmfold
+ goto 200
+ endif
+
+ ! Update fmassfrac
+ ! account for mass displaced from level k to level k
+
+ lconv = .true.
+ do k=1,nconvtop
+ rlevmass = dpr(k)/ga
+ summe = 0.
+ do kk=1,nconvtop
+ fmassfrac(k,kk) = delt*fmass(k,kk)
+ summe = summe + fmassfrac(k,kk)
+ end do
+ fmassfrac(k,k)=fmassfrac(k,k) + rlevmass - summe
+ end do
+
+200 continue
+
+end subroutine calcmatrix
diff --git a/src/calcmatrix_gfs.f90 b/src/calcmatrix_gfs.f90
new file mode 100644
index 0000000000000000000000000000000000000000..31eeb1fe22a2d4a1fda0e3096e0cc19e083ee6c6
--- /dev/null
+++ b/src/calcmatrix_gfs.f90
@@ -0,0 +1,139 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine calcmatrix(lconv,delt,cbmf)
+ ! o i o
+ !*****************************************************************************
+ ! *
+ ! This subroutine calculates the matrix describing convective *
+ ! redistribution of mass in a grid column, using the subroutine *
+ ! convect43c.f provided by Kerry Emanuel. *
+ ! *
+ ! Petra Seibert, Bernd C. Krueger, 2000-2001 *
+ ! *
+ ! changed by C. Forster, November 2003 - February 2004 *
+ ! array fmassfrac(nconvlevmax,nconvlevmax) represents *
+ ! the convective redistribution matrix for the particles *
+ ! *
+ ! Changes by C. Forster, November 2005, NCEP GFS version *
+ ! *
+ ! lconv indicates whether there is convection in this cell, or not *
+ ! delt time step for convection [s] *
+ ! cbmf cloud base mass flux *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+ use conv_mod
+
+ implicit none
+
+ real :: rlevmass,summe
+
+ integer :: iflag, k, kk, kuvz
+
+ !1-d variables for convection
+ !variables for redistribution matrix
+ real :: cbmfold, precip, qprime
+ real :: tprime, wd, f_qvsat
+ real :: delt,cbmf
+ logical :: lconv
+
+ lconv = .false.
+
+
+ ! calculate pressure at eta levels for use in convect
+ ! and assign temp & spec. hum. to 1D workspace
+ ! -------------------------------------------------------
+
+ ! pconv(1) is the pressure at the first level above ground
+ ! phconv(k) is the pressure between levels k-1 and k
+ ! dpr(k) is the pressure difference "around" tconv(k)
+ ! phconv(kmax) must also be defined 1/2 level above pconv(kmax)
+ ! Therefore, we define k = kuvz-1 and let kuvz start from 2
+ ! top layer cannot be used for convection because p at top of this layer is
+ ! not given
+
+ phconv(1) = psconv
+ do kuvz = 2,nuvz
+ k = kuvz-1
+ phconv(kuvz) = 0.5*(pconv(kuvz)+pconv(k))
+ dpr(k) = phconv(k) - phconv(kuvz)
+ qsconv(k) = f_qvsat( pconv(k), tconv(k) )
+ ! initialize mass fractions
+ do kk=1,nconvlev
+ fmassfrac(k,kk)=0.
+ enddo
+ end do
+
+ !note that Emanuel says it is important
+ !a. to set this =0. every grid point
+ !b. to keep this value in the calling programme in the iteration
+
+ ! CALL CONVECTION
+ !******************
+
+ cbmfold = cbmf
+ ! Convert pressures to hPa, as required by Emanuel scheme
+ !********************************************************
+!!$ do k=1,nconvlev !old
+ do k=1,nconvlev+1 !bugfix
+ pconv_hpa(k)=pconv(k)/100.
+ phconv_hpa(k)=phconv(k)/100.
+ end do
+ phconv_hpa(nconvlev+1)=phconv(nconvlev+1)/100.
+ call convect(nconvlevmax, nconvlev, delt, iflag, &
+ precip, wd, tprime, qprime, cbmf)
+
+ ! do not update fmassfrac and cloudbase massflux
+ ! if no convection takes place or
+ ! if a CFL criterion is violated in convect43c.f
+ if (iflag .ne. 1 .and. iflag .ne. 4) then
+ cbmf=cbmfold
+ goto 200
+ endif
+
+ ! do not update fmassfrac and cloudbase massflux
+ ! if the old and the new cloud base mass
+ ! fluxes are zero
+ if (cbmf.le.0..and.cbmfold.le.0.) then
+ cbmf=cbmfold
+ goto 200
+ endif
+
+ ! Update fmassfrac
+ ! account for mass displaced from level k to level k
+
+ lconv = .true.
+ do k=1,nconvtop
+ rlevmass = dpr(k)/ga
+ summe = 0.
+ do kk=1,nconvtop
+ fmassfrac(k,kk) = delt*fmass(k,kk)
+ summe = summe + fmassfrac(k,kk)
+ end do
+ fmassfrac(k,k)=fmassfrac(k,k) + rlevmass - summe
+ end do
+
+200 continue
+
+end subroutine calcmatrix
diff --git a/src/calcpar.f90 b/src/calcpar.f90
new file mode 100644
index 0000000000000000000000000000000000000000..c88f886e867218163105c1ab7e636c7e9727a69f
--- /dev/null
+++ b/src/calcpar.f90
@@ -0,0 +1,238 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine calcpar(n,uuh,vvh,pvh)
+ ! i i i o
+ !*****************************************************************************
+ ! *
+ ! Computation of several boundary layer parameters needed for the *
+ ! dispersion calculation and calculation of dry deposition velocities. *
+ ! All parameters are calculated over the entire grid. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 21 May 1995 *
+ ! *
+ ! ------------------------------------------------------------------ *
+ ! Petra Seibert, Feb 2000: *
+ ! convection scheme: *
+ ! new variables in call to richardson *
+ ! *
+ !*****************************************************************************
+ ! Changes, Bernd C. Krueger, Feb. 2001:
+ ! Variables tth and qvh (on eta coordinates) in common block
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! n temporal index for meteorological fields (1 to 3) *
+ ! *
+ ! Constants: *
+ ! *
+ ! *
+ ! Functions: *
+ ! scalev computation of ustar *
+ ! obukhov computatio of Obukhov length *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: n,ix,jy,i,kz,lz,kzmin
+ real :: ttlev(nuvzmax),qvlev(nuvzmax),obukhov,scalev,ol,hmixplus
+ real :: ulev(nuvzmax),vlev(nuvzmax),ew,rh,vd(maxspec),subsceff,ylat
+ real :: altmin,tvold,pold,zold,pint,tv,zlev(nuvzmax)
+ real :: uuh(0:nxmax-1,0:nymax-1,nuvzmax)
+ real :: vvh(0:nxmax-1,0:nymax-1,nuvzmax)
+ real :: pvh(0:nxmax-1,0:nymax-1,nuvzmax)
+ real,parameter :: const=r_air/ga
+
+ !write(*,*) 'in calcpar writting snowheight'
+ !***********************************
+ ! for test: write out snow depths
+
+ ! open(4,file='slandusetest',form='formatted')
+ ! do 5 ix=0,nxmin1
+ !5 write (4,*) (sd(ix,jy,1,n),jy=0,nymin1)
+ ! close(4)
+
+
+ ! Loop over entire grid
+ !**********************
+
+ do jy=0,nymin1
+
+ ! Set minimum height for tropopause
+ !**********************************
+
+ ylat=ylat0+real(jy)*dy
+ if ((ylat.ge.-20.).and.(ylat.le.20.)) then
+ altmin = 5000.
+ else
+ if ((ylat.gt.20.).and.(ylat.lt.40.)) then
+ altmin=2500.+(40.-ylat)*125.
+ else if ((ylat.gt.-40.).and.(ylat.lt.-20.)) then
+ altmin=2500.+(40.+ylat)*125.
+ else
+ altmin=2500.
+ endif
+ endif
+
+ do ix=0,nxmin1
+
+ ! 1) Calculation of friction velocity
+ !************************************
+
+ ustar(ix,jy,1,n)=scalev(ps(ix,jy,1,n),tt2(ix,jy,1,n), &
+ td2(ix,jy,1,n),surfstr(ix,jy,1,n))
+ if (ustar(ix,jy,1,n).le.1.e-8) ustar(ix,jy,1,n)=1.e-8
+
+ ! 2) Calculation of inverse Obukhov length scale
+ !***********************************************
+
+ ol=obukhov(ps(ix,jy,1,n),tt2(ix,jy,1,n),td2(ix,jy,1,n), &
+ tth(ix,jy,2,n),ustar(ix,jy,1,n),sshf(ix,jy,1,n),akm,bkm)
+ if (ol.ne.0.) then
+ oli(ix,jy,1,n)=1./ol
+ else
+ oli(ix,jy,1,n)=99999.
+ endif
+
+
+ ! 3) Calculation of convective velocity scale and mixing height
+ !**************************************************************
+
+ do i=1,nuvz
+ ulev(i)=uuh(ix,jy,i)
+ vlev(i)=vvh(ix,jy,i)
+ ttlev(i)=tth(ix,jy,i,n)
+ qvlev(i)=qvh(ix,jy,i,n)
+ end do
+
+ call richardson(ps(ix,jy,1,n),ustar(ix,jy,1,n),ttlev,qvlev, &
+ ulev,vlev,nuvz,akz,bkz,sshf(ix,jy,1,n),tt2(ix,jy,1,n), &
+ td2(ix,jy,1,n),hmix(ix,jy,1,n),wstar(ix,jy,1,n),hmixplus)
+
+ if(lsubgrid.eq.1) then
+ subsceff=min(excessoro(ix,jy),hmixplus)
+ else
+ subsceff=0.0
+ endif
+ !
+ ! CALCULATE HMIX EXCESS ACCORDING TO SUBGRIDSCALE VARIABILITY AND STABILITY
+ !
+ hmix(ix,jy,1,n)=hmix(ix,jy,1,n)+subsceff
+ hmix(ix,jy,1,n)=max(hmixmin,hmix(ix,jy,1,n)) ! set minimum PBL height
+ hmix(ix,jy,1,n)=min(hmixmax,hmix(ix,jy,1,n)) ! set maximum PBL height
+
+ ! 4) Calculation of dry deposition velocities
+ !********************************************
+
+ if (DRYDEP) then
+ ! Sabine Eckhardt, Dec 06: use new index for z0 for water depending on
+ ! windspeed
+ z0(7)=0.016*ustar(ix,jy,1,n)*ustar(ix,jy,1,n)/ga
+
+ ! Calculate relative humidity at surface
+ !***************************************
+ rh=ew(td2(ix,jy,1,n))/ew(tt2(ix,jy,1,n))
+
+ call getvdep(n,ix,jy,ustar(ix,jy,1,n), &
+ tt2(ix,jy,1,n),ps(ix,jy,1,n),1./oli(ix,jy,1,n), &
+ ssr(ix,jy,1,n),rh,lsprec(ix,jy,1,n)+convprec(ix,jy,1,n), &
+ sd(ix,jy,1,n),vd)
+
+ do i=1,nspec
+ vdep(ix,jy,i,n)=vd(i)
+ end do
+
+ endif
+
+ !******************************************************
+ ! Calculate height of thermal tropopause (Hoinka, 1997)
+ !******************************************************
+
+ ! 1) Calculate altitudes of ECMWF model levels
+ !*********************************************
+
+ tvold=tt2(ix,jy,1,n)*(1.+0.378*ew(td2(ix,jy,1,n))/ &
+ ps(ix,jy,1,n))
+ pold=ps(ix,jy,1,n)
+ zold=0.
+ do kz=2,nuvz
+ pint=akz(kz)+bkz(kz)*ps(ix,jy,1,n) ! pressure on model layers
+ tv=tth(ix,jy,kz,n)*(1.+0.608*qvh(ix,jy,kz,n))
+
+ if (abs(tv-tvold).gt.0.2) then
+ zlev(kz)=zold+const*log(pold/pint)*(tv-tvold)/log(tv/tvold)
+ else
+ zlev(kz)=zold+const*log(pold/pint)*tv
+ endif
+ tvold=tv
+ pold=pint
+ zold=zlev(kz)
+ end do
+
+ ! 2) Define a minimum level kzmin, from which upward the tropopause is
+ ! searched for. This is to avoid inversions in the lower troposphere
+ ! to be identified as the tropopause
+ !************************************************************************
+
+ do kz=1,nuvz
+ if (zlev(kz).ge.altmin) then
+ kzmin=kz
+ goto 45
+ endif
+ end do
+45 continue
+
+ ! 3) Search for first stable layer above minimum height that fulfills the
+ ! thermal tropopause criterion
+ !************************************************************************
+
+ do kz=kzmin,nuvz
+ do lz=kz+1,nuvz
+ if ((zlev(lz)-zlev(kz)).gt.2000.) then
+ if (((tth(ix,jy,kz,n)-tth(ix,jy,lz,n))/ &
+ (zlev(lz)-zlev(kz))).lt.0.002) then
+ tropopause(ix,jy,1,n)=zlev(kz)
+ goto 51
+ endif
+ goto 50
+ endif
+ end do
+50 continue
+ end do
+51 continue
+
+
+ end do
+ end do
+
+ ! Calculation of potential vorticity on 3-d grid
+ !***********************************************
+
+ call calcpv(n,uuh,vvh,pvh)
+
+
+end subroutine calcpar
diff --git a/src/calcpar_gfs.f90 b/src/calcpar_gfs.f90
new file mode 100644
index 0000000000000000000000000000000000000000..41202611d4c99d2422e75f35196eda21ce488bc0
--- /dev/null
+++ b/src/calcpar_gfs.f90
@@ -0,0 +1,243 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine calcpar(n,uuh,vvh,pvh)
+ ! i i i o
+ !*****************************************************************************
+ ! *
+ ! Computation of several boundary layer parameters needed for the *
+ ! dispersion calculation and calculation of dry deposition velocities. *
+ ! All parameters are calculated over the entire grid. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 21 May 1995 *
+ ! *
+ ! ------------------------------------------------------------------ *
+ ! Petra Seibert, Feb 2000: *
+ ! convection scheme: *
+ ! new variables in call to richardson *
+ ! *
+ !*****************************************************************************
+ ! Changes, Bernd C. Krueger, Feb. 2001:
+ ! Variables tth and qvh (on eta coordinates) in common block
+ !*****************************************************************************
+ ! *
+ ! CHANGE 17/11/2005 Caroline Forster NCEP GFS version *
+ ! *
+ ! Variables: *
+ ! n temporal index for meteorological fields (1 to 3) *
+ ! *
+ ! Constants: *
+ ! *
+ ! *
+ ! Functions: *
+ ! scalev computation of ustar *
+ ! obukhov computatio of Obukhov length *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: n,ix,jy,i,kz,lz,kzmin,llev
+ real :: ttlev(nuvzmax),qvlev(nuvzmax),obukhov,scalev,ol,hmixplus
+ real :: ulev(nuvzmax),vlev(nuvzmax),ew,rh,vd(maxspec),subsceff,ylat
+ real :: altmin,tvold,pold,zold,pint,tv,zlev(nuvzmax),hmixdummy
+ real :: uuh(0:nxmax-1,0:nymax-1,nuvzmax)
+ real :: vvh(0:nxmax-1,0:nymax-1,nuvzmax)
+ real :: pvh(0:nxmax-1,0:nymax-1,nuvzmax)
+ real,parameter :: const=r_air/ga
+
+
+ ! Loop over entire grid
+ !**********************
+
+ do jy=0,nymin1
+
+ ! Set minimum height for tropopause
+ !**********************************
+
+ ylat=ylat0+real(jy)*dy
+ if ((ylat.ge.-20.).and.(ylat.le.20.)) then
+ altmin = 5000.
+ else
+ if ((ylat.gt.20.).and.(ylat.lt.40.)) then
+ altmin=2500.+(40.-ylat)*125.
+ else if ((ylat.gt.-40.).and.(ylat.lt.-20.)) then
+ altmin=2500.+(40.+ylat)*125.
+ else
+ altmin=2500.
+ endif
+ endif
+
+ do ix=0,nxmin1
+
+ ! 1) Calculation of friction velocity
+ !************************************
+
+ ustar(ix,jy,1,n)=scalev(ps(ix,jy,1,n),tt2(ix,jy,1,n), &
+ td2(ix,jy,1,n),surfstr(ix,jy,1,n))
+ if (ustar(ix,jy,1,n).le.1.e-8) ustar(ix,jy,1,n)=1.e-8
+
+ ! 2) Calculation of inverse Obukhov length scale
+ !***********************************************
+
+ ! NCEP version: find first level above ground
+ llev = 0
+ do i=1,nuvz
+ if (ps(ix,jy,1,n).lt.akz(i)) llev=i
+ end do
+ llev = llev+1
+ if (llev.gt.nuvz) llev = nuvz-1
+ ! NCEP version
+
+ ! calculate inverse Obukhov length scale with tth(llev)
+ ol=obukhov(ps(ix,jy,1,n),tt2(ix,jy,1,n),td2(ix,jy,1,n), &
+ tth(ix,jy,llev,n),ustar(ix,jy,1,n),sshf(ix,jy,1,n),akz(llev))
+ if (ol.ne.0.) then
+ oli(ix,jy,1,n)=1./ol
+ else
+ oli(ix,jy,1,n)=99999.
+ endif
+
+
+ ! 3) Calculation of convective velocity scale and mixing height
+ !**************************************************************
+
+ do i=1,nuvz
+ ulev(i)=uuh(ix,jy,i)
+ vlev(i)=vvh(ix,jy,i)
+ ttlev(i)=tth(ix,jy,i,n)
+ qvlev(i)=qvh(ix,jy,i,n)
+ end do
+
+ ! NCEP version hmix has been read in in readwind.f, is therefore not calculated here
+ call richardson(ps(ix,jy,1,n),ustar(ix,jy,1,n),ttlev,qvlev, &
+ ulev,vlev,nuvz,akz,bkz,sshf(ix,jy,1,n),tt2(ix,jy,1,n), &
+ td2(ix,jy,1,n),hmixdummy,wstar(ix,jy,1,n),hmixplus)
+
+ if(lsubgrid.eq.1) then
+ subsceff=min(excessoro(ix,jy),hmixplus)
+ else
+ subsceff=0
+ endif
+ !
+ ! CALCULATE HMIX EXCESS ACCORDING TO SUBGRIDSCALE VARIABILITY AND STABILITY
+ !
+ hmix(ix,jy,1,n)=hmix(ix,jy,1,n)+subsceff
+ hmix(ix,jy,1,n)=max(hmixmin,hmix(ix,jy,1,n)) ! set minimum PBL height
+ hmix(ix,jy,1,n)=min(hmixmax,hmix(ix,jy,1,n)) ! set maximum PBL height
+
+ ! 4) Calculation of dry deposition velocities
+ !********************************************
+
+ if (DRYDEP) then
+ ! Sabine Eckhardt, Dec 06: use new index for z0 for water depending on
+ ! windspeed
+ z0(7)=0.016*ustar(ix,jy,1,n)*ustar(ix,jy,1,n)/ga
+
+ ! Calculate relative humidity at surface
+ !***************************************
+ rh=ew(td2(ix,jy,1,n))/ew(tt2(ix,jy,1,n))
+
+ call getvdep(n,ix,jy,ustar(ix,jy,1,n), &
+ tt2(ix,jy,1,n),ps(ix,jy,1,n),1./oli(ix,jy,1,n), &
+ ssr(ix,jy,1,n),rh,lsprec(ix,jy,1,n)+convprec(ix,jy,1,n), &
+ sd(ix,jy,1,n),vd)
+
+ do i=1,nspec
+ vdep(ix,jy,i,n)=vd(i)
+ end do
+
+ endif
+
+ !******************************************************
+ ! Calculate height of thermal tropopause (Hoinka, 1997)
+ !******************************************************
+
+ ! 1) Calculate altitudes of NCEP model levels
+ !*********************************************
+
+ tvold=tt2(ix,jy,1,n)*(1.+0.378*ew(td2(ix,jy,1,n))/ &
+ ps(ix,jy,1,n))
+ pold=ps(ix,jy,1,n)
+ zold=0.
+ do kz=llev,nuvz
+ pint=akz(kz)+bkz(kz)*ps(ix,jy,1,n) ! pressure on model layers
+ tv=tth(ix,jy,kz,n)*(1.+0.608*qvh(ix,jy,kz,n))
+
+ if (abs(tv-tvold).gt.0.2) then
+ zlev(kz)=zold+const*log(pold/pint)*(tv-tvold)/log(tv/tvold)
+ else
+ zlev(kz)=zold+const*log(pold/pint)*tv
+ endif
+ tvold=tv
+ pold=pint
+ zold=zlev(kz)
+ end do
+
+ ! 2) Define a minimum level kzmin, from which upward the tropopause is
+ ! searched for. This is to avoid inversions in the lower troposphere
+ ! to be identified as the tropopause
+ !************************************************************************
+
+ do kz=llev,nuvz
+ if (zlev(kz).ge.altmin) then
+ kzmin=kz
+ goto 45
+ endif
+ end do
+45 continue
+
+ ! 3) Search for first stable layer above minimum height that fulfills the
+ ! thermal tropopause criterion
+ !************************************************************************
+
+ do kz=kzmin,nuvz
+ do lz=kz+1,nuvz
+ if ((zlev(lz)-zlev(kz)).gt.2000.) then
+ if (((tth(ix,jy,kz,n)-tth(ix,jy,lz,n))/ &
+ (zlev(lz)-zlev(kz))).lt.0.002) then
+ tropopause(ix,jy,1,n)=zlev(kz)
+ goto 51
+ endif
+ goto 50
+ endif
+ end do
+50 continue
+ end do
+51 continue
+
+
+ end do
+ end do
+
+
+ ! Calculation of potential vorticity on 3-d grid
+ !***********************************************
+
+ call calcpv(n,uuh,vvh,pvh)
+
+
+end subroutine calcpar
diff --git a/src/calcpar_nests.f90 b/src/calcpar_nests.f90
new file mode 100644
index 0000000000000000000000000000000000000000..b1d17df9a8e5c9eca8348c745993741cce0fb2db
--- /dev/null
+++ b/src/calcpar_nests.f90
@@ -0,0 +1,236 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine calcpar_nests(n,uuhn,vvhn,pvhn)
+ ! i i i o
+ !*****************************************************************************
+ ! *
+ ! Computation of several boundary layer parameters needed for the *
+ ! dispersion calculation and calculation of dry deposition velocities. *
+ ! All parameters are calculated over the entire grid. *
+ ! This routine is similar to calcpar, but is used for the nested grids. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 8 February 1999 *
+ ! *
+ ! ------------------------------------------------------------------ *
+ ! Petra Seibert, Feb 2000: *
+ ! convection scheme: *
+ ! new variables in call to richardson *
+ ! *
+ !*****************************************************************************
+ ! Changes, Bernd C. Krueger, Feb. 2001:
+ ! Variables tth and qvh (on eta coordinates) in common block
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! n temporal index for meteorological fields (1 to 3) *
+ ! *
+ ! Constants: *
+ ! *
+ ! *
+ ! Functions: *
+ ! scalev computation of ustar *
+ ! obukhov computatio of Obukhov length *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: n,ix,jy,i,l,kz,lz,kzmin
+ real :: ttlev(nuvzmax),qvlev(nuvzmax),obukhov,scalev,ol,hmixplus
+ real :: ulev(nuvzmax),vlev(nuvzmax),ew,rh,vd(maxspec),subsceff,ylat
+ real :: altmin,tvold,pold,zold,pint,tv,zlev(nuvzmax)
+ real :: uuhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
+ real :: vvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
+ real :: pvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
+ real,parameter :: const=r_air/ga
+
+
+ ! Loop over all nests
+ !********************
+
+ do l=1,numbnests
+
+ ! Loop over entire grid
+ !**********************
+
+ do jy=0,nyn(l)-1
+
+ ! Set minimum height for tropopause
+ !**********************************
+
+ ylat=ylat0n(l)+real(jy)*dyn(l)
+ if ((ylat.ge.-20.).and.(ylat.le.20.)) then
+ altmin = 5000.
+ else
+ if ((ylat.gt.20.).and.(ylat.lt.40.)) then
+ altmin=2500.+(40.-ylat)*125.
+ else if ((ylat.gt.-40.).and.(ylat.lt.-20.)) then
+ altmin=2500.+(40.+ylat)*125.
+ else
+ altmin=2500.
+ endif
+ endif
+
+ do ix=0,nxn(l)-1
+
+ ! 1) Calculation of friction velocity
+ !************************************
+
+ ustarn(ix,jy,1,n,l)=scalev(psn(ix,jy,1,n,l),tt2n(ix,jy,1,n,l), &
+ td2n(ix,jy,1,n,l),surfstrn(ix,jy,1,n,l))
+
+ ! 2) Calculation of inverse Obukhov length scale
+ !***********************************************
+
+ ol=obukhov(psn(ix,jy,1,n,l),tt2n(ix,jy,1,n,l), &
+ td2n(ix,jy,1,n,l),tthn(ix,jy,2,n,l),ustarn(ix,jy,1,n,l), &
+ sshfn(ix,jy,1,n,l),akm,bkm)
+ if (ol.ne.0.) then
+ olin(ix,jy,1,n,l)=1./ol
+ else
+ olin(ix,jy,1,n,l)=99999.
+ endif
+
+
+ ! 3) Calculation of convective velocity scale and mixing height
+ !**************************************************************
+
+ do i=1,nuvz
+ ulev(i)=uuhn(ix,jy,i,l)
+ vlev(i)=vvhn(ix,jy,i,l)
+ ttlev(i)=tthn(ix,jy,i,n,l)
+ qvlev(i)=qvhn(ix,jy,i,n,l)
+ end do
+
+ call richardson(psn(ix,jy,1,n,l),ustarn(ix,jy,1,n,l),ttlev, &
+ qvlev,ulev,vlev,nuvz,akz,bkz,sshfn(ix,jy,1,n,l), &
+ tt2n(ix,jy,1,n,l),td2n(ix,jy,1,n,l),hmixn(ix,jy,1,n,l), &
+ wstarn(ix,jy,1,n,l),hmixplus)
+
+ if(lsubgrid.eq.1) then
+ subsceff=min(excessoron(ix,jy,l),hmixplus)
+ else
+ subsceff=0
+ endif
+ !
+ ! CALCULATE HMIX EXCESS ACCORDING TO SUBGRIDSCALE VARIABILITY AND STABILITY
+ !
+ hmixn(ix,jy,1,n,l)=hmixn(ix,jy,1,n,l)+subsceff
+ hmixn(ix,jy,1,n,l)=max(hmixmin,hmixn(ix,jy,1,n,l)) ! minim PBL height
+ hmixn(ix,jy,1,n,l)=min(hmixmax,hmixn(ix,jy,1,n,l)) ! maxim PBL height
+
+
+ ! 4) Calculation of dry deposition velocities
+ !********************************************
+
+ if (DRYDEP) then
+ z0(4)=0.016*ustarn(ix,jy,1,n,l)*ustarn(ix,jy,1,n,l)/ga
+ z0(9)=0.016*ustarn(ix,jy,1,n,l)*ustarn(ix,jy,1,n,l)/ga
+
+ ! Calculate relative humidity at surface
+ !***************************************
+ rh=ew(td2n(ix,jy,1,n,l))/ew(tt2n(ix,jy,1,n,l))
+
+ call getvdep_nests(n,ix,jy,ustarn(ix,jy,1,n,l), &
+ tt2n(ix,jy,1,n,l),psn(ix,jy,1,n,l),1./olin(ix,jy,1,n,l), &
+ ssrn(ix,jy,1,n,l),rh,lsprecn(ix,jy,1,n,l)+ &
+ convprecn(ix,jy,1,n,l),sdn(ix,jy,1,n,l),vd,l)
+
+ do i=1,nspec
+ vdepn(ix,jy,i,n,l)=vd(i)
+ end do
+
+ endif
+
+ !******************************************************
+ ! Calculate height of thermal tropopause (Hoinka, 1997)
+ !******************************************************
+
+ ! 1) Calculate altitudes of ECMWF model levels
+ !*********************************************
+
+ tvold=tt2n(ix,jy,1,n,l)*(1.+0.378*ew(td2n(ix,jy,1,n,l))/ &
+ psn(ix,jy,1,n,l))
+ pold=psn(ix,jy,1,n,l)
+ zold=0.
+ do kz=2,nuvz
+ pint=akz(kz)+bkz(kz)*psn(ix,jy,1,n,l) ! pressure on model layers
+ tv=tthn(ix,jy,kz,n,l)*(1.+0.608*qvhn(ix,jy,kz,n,l))
+
+ if (abs(tv-tvold).gt.0.2) then
+ zlev(kz)=zold+const*log(pold/pint)*(tv-tvold)/log(tv/tvold)
+ else
+ zlev(kz)=zold+const*log(pold/pint)*tv
+ endif
+ tvold=tv
+ pold=pint
+ zold=zlev(kz)
+ end do
+
+ ! 2) Define a minimum level kzmin, from which upward the tropopause is
+ ! searched for. This is to avoid inversions in the lower troposphere
+ ! to be identified as the tropopause
+ !************************************************************************
+
+ do kz=1,nuvz
+ if (zlev(kz).ge.altmin) then
+ kzmin=kz
+ goto 45
+ endif
+ end do
+45 continue
+
+ ! 3) Search for first stable layer above minimum height that fulfills the
+ ! thermal tropopause criterion
+ !************************************************************************
+
+ do kz=kzmin,nuvz
+ do lz=kz+1,nuvz
+ if ((zlev(lz)-zlev(kz)).gt.2000.) then
+ if (((tthn(ix,jy,kz,n,l)-tthn(ix,jy,lz,n,l))/ &
+ (zlev(lz)-zlev(kz))).lt.0.002) then
+ tropopausen(ix,jy,1,n,l)=zlev(kz)
+ goto 51
+ endif
+ goto 50
+ endif
+ end do
+50 continue
+ end do
+51 continue
+
+
+ end do
+ end do
+
+
+ call calcpv_nests(l,n,uuhn,vvhn,pvhn)
+
+ end do
+
+
+end subroutine calcpar_nests
diff --git a/src/calcpv.f90 b/src/calcpv.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d3f57a0be803ca2acc8eb7dca7663232bc499549
--- /dev/null
+++ b/src/calcpv.f90
@@ -0,0 +1,337 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine calcpv(n,uuh,vvh,pvh)
+ ! i i i o
+ !*****************************************************************************
+ ! *
+ ! Calculation of potential vorticity on 3-d grid. *
+ ! *
+ ! Author: P. James *
+ ! 3 February 2000 *
+ ! *
+ ! Adaptation to FLEXPART, A. Stohl, 1 May 2000 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! n temporal index for meteorological fields (1 to 2) *
+ ! *
+ ! Constants: *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: n,ix,jy,i,j,k,kl,ii,jj,klvrp,klvrm,klpt,kup,kdn,kch
+ integer :: jyvp,jyvm,ixvp,ixvm,jumpx,jumpy,jux,juy,ivrm,ivrp,ivr
+ integer :: nlck
+ real :: vx(2),uy(2),phi,tanphi,cosphi,dvdx,dudy,f
+ real :: theta,thetap,thetam,dthetadp,dt1,dt2,dt,ppmk
+ real :: pvavr,ppml(nuvzmax)
+ real :: thup,thdn
+ real,parameter :: eps=1.e-5, p0=101325
+ real :: uuh(0:nxmax-1,0:nymax-1,nuvzmax)
+ real :: vvh(0:nxmax-1,0:nymax-1,nuvzmax)
+ real :: pvh(0:nxmax-1,0:nymax-1,nuvzmax)
+
+ ! Set number of levels to check for adjacent theta
+ nlck=nuvz/3
+ !
+ ! Loop over entire grid
+ !**********************
+ do jy=0,nymin1
+ if (sglobal.and.jy.eq.0) goto 10
+ if (nglobal.and.jy.eq.nymin1) goto 10
+ phi = (ylat0 + jy * dy) * pi / 180.
+ f = 0.00014585 * sin(phi)
+ tanphi = tan(phi)
+ cosphi = cos(phi)
+ ! Provide a virtual jy+1 and jy-1 in case we are on domain edge (Lat)
+ jyvp=jy+1
+ jyvm=jy-1
+ if (jy.eq.0) jyvm=0
+ if (jy.eq.nymin1) jyvp=nymin1
+ ! Define absolute gap length
+ jumpy=2
+ if (jy.eq.0.or.jy.eq.nymin1) jumpy=1
+ if (sglobal.and.jy.eq.1) then
+ jyvm=1
+ jumpy=1
+ end if
+ if (nglobal.and.jy.eq.ny-2) then
+ jyvp=ny-2
+ jumpy=1
+ end if
+ juy=jumpy
+ !
+ do ix=0,nxmin1
+ ! Provide a virtual ix+1 and ix-1 in case we are on domain edge (Long)
+ ixvp=ix+1
+ ixvm=ix-1
+ jumpx=2
+ if (xglobal) then
+ ivrp=ixvp
+ ivrm=ixvm
+ if (ixvm.lt.0) ivrm=ixvm+nxmin1
+ if (ixvp.ge.nx) ivrp=ixvp-nx+1
+ else
+ if (ix.eq.0) ixvm=0
+ if (ix.eq.nxmin1) ixvp=nxmin1
+ ivrp=ixvp
+ ivrm=ixvm
+ ! Define absolute gap length
+ if (ix.eq.0.or.ix.eq.nxmin1) jumpx=1
+ end if
+ jux=jumpx
+ ! Precalculate pressure values for efficiency
+ do kl=1,nuvz
+ ppml(kl)=akz(kl)+bkz(kl)*ps(ix,jy,1,n)
+ end do
+ !
+ ! Loop over the vertical
+ !***********************
+
+ do kl=1,nuvz
+ ppmk=akz(kl)+bkz(kl)*ps(ix,jy,1,n)
+ theta=tth(ix,jy,kl,n)*(100000./ppmk)**kappa
+ klvrp=kl+1
+ klvrm=kl-1
+ klpt=kl
+ ! If top or bottom level, dthetadp is evaluated between the current
+ ! level and the level inside, otherwise between level+1 and level-1
+ !
+ if (klvrp.gt.nuvz) klvrp=nuvz
+ if (klvrm.lt.1) klvrm=1
+ ppmk=akz(klvrp)+bkz(klvrp)*ps(ix,jy,1,n)
+ thetap=tth(ix,jy,klvrp,n)*(100000./ppmk)**kappa
+ ppmk=akz(klvrm)+bkz(klvrm)*ps(ix,jy,1,n)
+ thetam=tth(ix,jy,klvrm,n)*(100000./ppmk)**kappa
+ dthetadp=(thetap-thetam)/(ppml(klvrp)-ppml(klvrm))
+
+ ! Compute vertical position at pot. temperature surface on subgrid
+ ! and the wind at that position
+ !*****************************************************************
+ ! a) in x direction
+ ii=0
+ do i=ixvm,ixvp,jumpx
+ ivr=i
+ if (xglobal) then
+ if (i.lt.0) ivr=ivr+nxmin1
+ if (i.ge.nx) ivr=ivr-nx+1
+ end if
+ ii=ii+1
+ ! Search adjacent levels for current theta value
+ ! Spiral out from current level for efficiency
+ kup=klpt-1
+ kdn=klpt
+ kch=0
+40 continue
+ ! Upward branch
+ kup=kup+1
+ if (kch.ge.nlck) goto 21 ! No more levels to check,
+ ! ! and no values found
+ if (kup.ge.nuvz) goto 41
+ kch=kch+1
+ k=kup
+ ppmk=akz(k)+bkz(k)*ps(ivr,jy,1,n)
+ thdn=tth(ivr,jy,k,n)*(100000./ppmk)**kappa
+ ppmk=akz(k+1)+bkz(k+1)*ps(ivr,jy,1,n)
+ thup=tth(ivr,jy,k+1,n)*(100000./ppmk)**kappa
+
+
+ if (((thdn.ge.theta).and.(thup.le.theta)).or. &
+ ((thdn.le.theta).and.(thup.ge.theta))) then
+ dt1=abs(theta-thdn)
+ dt2=abs(theta-thup)
+ dt=dt1+dt2
+ if (dt.lt.eps) then ! Avoid division by zero error
+ dt1=0.5 ! G.W., 10.4.1996
+ dt2=0.5
+ dt=1.0
+ endif
+ vx(ii)=(vvh(ivr,jy,k)*dt2+vvh(ivr,jy,k+1)*dt1)/dt
+ goto 20
+ endif
+41 continue
+ ! Downward branch
+ kdn=kdn-1
+ if (kdn.lt.1) goto 40
+ kch=kch+1
+ k=kdn
+ ppmk=akz(k)+bkz(k)*ps(ivr,jy,1,n)
+ thdn=tth(ivr,jy,k,n)*(100000./ppmk)**kappa
+ ppmk=akz(k+1)+bkz(k+1)*ps(ivr,jy,1,n)
+ thup=tth(ivr,jy,k+1,n)*(100000./ppmk)**kappa
+
+ if (((thdn.ge.theta).and.(thup.le.theta)).or. &
+ ((thdn.le.theta).and.(thup.ge.theta))) then
+ dt1=abs(theta-thdn)
+ dt2=abs(theta-thup)
+ dt=dt1+dt2
+ if (dt.lt.eps) then ! Avoid division by zero error
+ dt1=0.5 ! G.W., 10.4.1996
+ dt2=0.5
+ dt=1.0
+ endif
+ vx(ii)=(vvh(ivr,jy,k)*dt2+vvh(ivr,jy,k+1)*dt1)/dt
+ goto 20
+ endif
+ goto 40
+ ! This section used when no values were found
+21 continue
+ ! Must use vv at current level and long. jux becomes smaller by 1
+ vx(ii)=vvh(ix,jy,kl)
+ jux=jux-1
+ ! Otherwise OK
+20 continue
+ end do
+ if (jux.gt.0) then
+ dvdx=(vx(2)-vx(1))/real(jux)/(dx*pi/180.)
+ else
+ dvdx=vvh(ivrp,jy,kl)-vvh(ivrm,jy,kl)
+ dvdx=dvdx/real(jumpx)/(dx*pi/180.)
+ ! Only happens if no equivalent theta value
+ ! can be found on either side, hence must use values
+ ! from either side, same pressure level.
+ end if
+
+ ! b) in y direction
+
+ jj=0
+ do j=jyvm,jyvp,jumpy
+ jj=jj+1
+ ! Search adjacent levels for current theta value
+ ! Spiral out from current level for efficiency
+ kup=klpt-1
+ kdn=klpt
+ kch=0
+70 continue
+ ! Upward branch
+ kup=kup+1
+ if (kch.ge.nlck) goto 51 ! No more levels to check,
+ ! ! and no values found
+ if (kup.ge.nuvz) goto 71
+ kch=kch+1
+ k=kup
+ ppmk=akz(k)+bkz(k)*ps(ix,j,1,n)
+ thdn=tth(ix,j,k,n)*(100000./ppmk)**kappa
+ ppmk=akz(k+1)+bkz(k+1)*ps(ix,j,1,n)
+ thup=tth(ix,j,k+1,n)*(100000./ppmk)**kappa
+ if (((thdn.ge.theta).and.(thup.le.theta)).or. &
+ ((thdn.le.theta).and.(thup.ge.theta))) then
+ dt1=abs(theta-thdn)
+ dt2=abs(theta-thup)
+ dt=dt1+dt2
+ if (dt.lt.eps) then ! Avoid division by zero error
+ dt1=0.5 ! G.W., 10.4.1996
+ dt2=0.5
+ dt=1.0
+ endif
+ uy(jj)=(uuh(ix,j,k)*dt2+uuh(ix,j,k+1)*dt1)/dt
+ goto 50
+ endif
+71 continue
+ ! Downward branch
+ kdn=kdn-1
+ if (kdn.lt.1) goto 70
+ kch=kch+1
+ k=kdn
+ ppmk=akz(k)+bkz(k)*ps(ix,j,1,n)
+ thdn=tth(ix,j,k,n)*(100000./ppmk)**kappa
+ ppmk=akz(k+1)+bkz(k+1)*ps(ix,j,1,n)
+ thup=tth(ix,j,k+1,n)*(100000./ppmk)**kappa
+ if (((thdn.ge.theta).and.(thup.le.theta)).or. &
+ ((thdn.le.theta).and.(thup.ge.theta))) then
+ dt1=abs(theta-thdn)
+ dt2=abs(theta-thup)
+ dt=dt1+dt2
+ if (dt.lt.eps) then ! Avoid division by zero error
+ dt1=0.5 ! G.W., 10.4.1996
+ dt2=0.5
+ dt=1.0
+ endif
+ uy(jj)=(uuh(ix,j,k)*dt2+uuh(ix,j,k+1)*dt1)/dt
+ goto 50
+ endif
+ goto 70
+ ! This section used when no values were found
+51 continue
+ ! Must use uu at current level and lat. juy becomes smaller by 1
+ uy(jj)=uuh(ix,jy,kl)
+ juy=juy-1
+ ! Otherwise OK
+50 continue
+ end do
+ if (juy.gt.0) then
+ dudy=(uy(2)-uy(1))/real(juy)/(dy*pi/180.)
+ else
+ dudy=uuh(ix,jyvp,kl)-uuh(ix,jyvm,kl)
+ dudy=dudy/real(jumpy)/(dy*pi/180.)
+ end if
+ !
+ pvh(ix,jy,kl)=dthetadp*(f+(dvdx/cosphi-dudy &
+ +uuh(ix,jy,kl)*tanphi)/r_earth)*(-1.e6)*9.81
+
+
+ !
+ ! Resest jux and juy
+ jux=jumpx
+ juy=jumpy
+ end do
+ end do
+10 continue
+ end do
+ !
+ ! Fill in missing PV values on poles, if present
+ ! Use mean PV of surrounding latitude ring
+ !
+ if (sglobal) then
+ do kl=1,nuvz
+ pvavr=0.
+ do ix=0,nxmin1
+ pvavr=pvavr+pvh(ix,1,kl)
+ end do
+ pvavr=pvavr/real(nx)
+ jy=0
+ do ix=0,nxmin1
+ pvh(ix,jy,kl)=pvavr
+ end do
+ end do
+ end if
+ if (nglobal) then
+ do kl=1,nuvz
+ pvavr=0.
+ do ix=0,nxmin1
+ pvavr=pvavr+pvh(ix,ny-2,kl)
+ end do
+ pvavr=pvavr/real(nx)
+ jy=nymin1
+ do ix=0,nxmin1
+ pvh(ix,jy,kl)=pvavr
+ end do
+ end do
+ end if
+
+end subroutine calcpv
diff --git a/src/calcpv_nests.f90 b/src/calcpv_nests.f90
new file mode 100644
index 0000000000000000000000000000000000000000..9c1847f5c03eb75490ffc2519705823366c9195b
--- /dev/null
+++ b/src/calcpv_nests.f90
@@ -0,0 +1,281 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine calcpv_nests(l,n,uuhn,vvhn,pvhn)
+ ! i i i i o
+ !*****************************************************************************
+ ! *
+ ! Calculation of potential vorticity on 3-d nested grid *
+ ! *
+ ! Author: P. James *
+ ! 22 February 2000 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! n temporal index for meteorological fields (1 to 2) *
+ ! l index of current nest *
+ ! *
+ ! Constants: *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: n,ix,jy,i,j,k,kl,ii,jj,klvrp,klvrm,klpt,kup,kdn,kch
+ integer :: jyvp,jyvm,ixvp,ixvm,jumpx,jumpy,jux,juy,ivrm,ivrp,ivr
+ integer :: nlck,l
+ real :: vx(2),uy(2),phi,tanphi,cosphi,dvdx,dudy,f
+ real :: theta,thetap,thetam,dthetadp,dt1,dt2,dt,ppmk
+ real :: ppml(nuvzmax)
+ real :: thup,thdn
+ real,parameter :: eps=1.e-5,p0=101325
+ real :: uuhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
+ real :: vvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
+ real :: pvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
+
+ ! Set number of levels to check for adjacent theta
+ nlck=nuvz/3
+ !
+ ! Loop over entire grid
+ !**********************
+ do jy=0,nyn(l)-1
+ phi = (ylat0n(l) + jy * dyn(l)) * pi / 180.
+ f = 0.00014585 * sin(phi)
+ tanphi = tan(phi)
+ cosphi = cos(phi)
+ ! Provide a virtual jy+1 and jy-1 in case we are on domain edge (Lat)
+ jyvp=jy+1
+ jyvm=jy-1
+ if (jy.eq.0) jyvm=0
+ if (jy.eq.nyn(l)-1) jyvp=nyn(l)-1
+ ! Define absolute gap length
+ jumpy=2
+ if (jy.eq.0.or.jy.eq.nyn(l)-1) jumpy=1
+ juy=jumpy
+ !
+ do ix=0,nxn(l)-1
+ ! Provide a virtual ix+1 and ix-1 in case we are on domain edge (Long)
+ ixvp=ix+1
+ ixvm=ix-1
+ jumpx=2
+ if (ix.eq.0) ixvm=0
+ if (ix.eq.nxn(l)-1) ixvp=nxn(l)-1
+ ivrp=ixvp
+ ivrm=ixvm
+ ! Define absolute gap length
+ if (ix.eq.0.or.ix.eq.nxn(l)-1) jumpx=1
+ jux=jumpx
+ ! Precalculate pressure values for efficiency
+ do kl=1,nuvz
+ ppml(kl)=akz(kl)+bkz(kl)*psn(ix,jy,1,n,l)
+ end do
+ !
+ ! Loop over the vertical
+ !***********************
+
+ do kl=1,nuvz
+ ppmk=akz(kl)+bkz(kl)*psn(ix,jy,1,n,l)
+ theta=tthn(ix,jy,kl,n,l)*(100000./ppmk)**kappa
+ klvrp=kl+1
+ klvrm=kl-1
+ klpt=kl
+ ! If top or bottom level, dthetadp is evaluated between the current
+ ! level and the level inside, otherwise between level+1 and level-1
+ !
+ if (klvrp.gt.nuvz) klvrp=nuvz
+ if (klvrm.lt.1) klvrm=1
+ ppmk=akz(klvrp)+bkz(klvrp)*psn(ix,jy,1,n,l)
+ thetap=tthn(ix,jy,klvrp,n,l)*(100000./ppmk)**kappa
+ ppmk=akz(klvrm)+bkz(klvrm)*psn(ix,jy,1,n,l)
+ thetam=tthn(ix,jy,klvrm,n,l)*(100000./ppmk)**kappa
+ dthetadp=(thetap-thetam)/(ppml(klvrp)-ppml(klvrm))
+
+ ! Compute vertical position at pot. temperature surface on subgrid
+ ! and the wind at that position
+ !*****************************************************************
+ ! a) in x direction
+ ii=0
+ do i=ixvm,ixvp,jumpx
+ ivr=i
+ ii=ii+1
+ ! Search adjacent levels for current theta value
+ ! Spiral out from current level for efficiency
+ kup=klpt-1
+ kdn=klpt
+ kch=0
+40 continue
+ ! Upward branch
+ kup=kup+1
+ if (kch.ge.nlck) goto 21 ! No more levels to check,
+ ! ! and no values found
+ if (kup.ge.nuvz) goto 41
+ kch=kch+1
+ k=kup
+ ppmk=akz(k)+bkz(k)*psn(ivr,jy,1,n,l)
+ thdn=tthn(ivr,jy,k,n,l)*(100000./ppmk)**kappa
+ ppmk=akz(k+1)+bkz(k+1)*psn(ivr,jy,1,n,l)
+ thup=tthn(ivr,jy,k+1,n,l)*(100000./ppmk)**kappa
+
+ if (((thdn.ge.theta).and.(thup.le.theta)).or. &
+ ((thdn.le.theta).and.(thup.ge.theta))) then
+ dt1=abs(theta-thdn)
+ dt2=abs(theta-thup)
+ dt=dt1+dt2
+ if (dt.lt.eps) then ! Avoid division by zero error
+ dt1=0.5 ! G.W., 10.4.1996
+ dt2=0.5
+ dt=1.0
+ endif
+ vx(ii)=(vvhn(ivr,jy,k,l)*dt2+vvhn(ivr,jy,k+1,l)*dt1)/dt
+ goto 20
+ endif
+41 continue
+ ! Downward branch
+ kdn=kdn-1
+ if (kdn.lt.1) goto 40
+ kch=kch+1
+ k=kdn
+ ppmk=akz(k)+bkz(k)*psn(ivr,jy,1,n,l)
+ thdn=tthn(ivr,jy,k,n,l)*(100000./ppmk)**kappa
+ ppmk=akz(k+1)+bkz(k+1)*psn(ivr,jy,1,n,l)
+ thup=tthn(ivr,jy,k+1,n,l)*(100000./ppmk)**kappa
+ if (((thdn.ge.theta).and.(thup.le.theta)).or. &
+ ((thdn.le.theta).and.(thup.ge.theta))) then
+ dt1=abs(theta-thdn)
+ dt2=abs(theta-thup)
+ dt=dt1+dt2
+ if (dt.lt.eps) then ! Avoid division by zero error
+ dt1=0.5 ! G.W., 10.4.1996
+ dt2=0.5
+ dt=1.0
+ endif
+ vx(ii)=(vvhn(ivr,jy,k,l)*dt2+vvhn(ivr,jy,k+1,l)*dt1)/dt
+ goto 20
+ endif
+ goto 40
+ ! This section used when no values were found
+21 continue
+ ! Must use vv at current level and long. jux becomes smaller by 1
+ vx(ii)=vvhn(ix,jy,kl,l)
+ jux=jux-1
+ ! Otherwise OK
+20 continue
+ end do
+ if (jux.gt.0) then
+ dvdx=(vx(2)-vx(1))/real(jux)/(dxn(l)*pi/180.)
+ else
+ dvdx=vvhn(ivrp,jy,kl,l)-vvhn(ivrm,jy,kl,l)
+ dvdx=dvdx/real(jumpx)/(dxn(l)*pi/180.)
+ ! Only happens if no equivalent theta value
+ ! can be found on either side, hence must use values
+ ! from either side, same pressure level.
+ end if
+
+ ! b) in y direction
+
+ jj=0
+ do j=jyvm,jyvp,jumpy
+ jj=jj+1
+ ! Search adjacent levels for current theta value
+ ! Spiral out from current level for efficiency
+ kup=klpt-1
+ kdn=klpt
+ kch=0
+70 continue
+ ! Upward branch
+ kup=kup+1
+ if (kch.ge.nlck) goto 51 ! No more levels to check,
+ ! ! and no values found
+ if (kup.ge.nuvz) goto 71
+ kch=kch+1
+ k=kup
+ ppmk=akz(k)+bkz(k)*psn(ix,j,1,n,l)
+ thdn=tthn(ix,j,k,n,l)*(100000./ppmk)**kappa
+ ppmk=akz(k+1)+bkz(k+1)*psn(ix,j,1,n,l)
+ thup=tthn(ix,j,k+1,n,l)*(100000./ppmk)**kappa
+ if (((thdn.ge.theta).and.(thup.le.theta)).or. &
+ ((thdn.le.theta).and.(thup.ge.theta))) then
+ dt1=abs(theta-thdn)
+ dt2=abs(theta-thup)
+ dt=dt1+dt2
+ if (dt.lt.eps) then ! Avoid division by zero error
+ dt1=0.5 ! G.W., 10.4.1996
+ dt2=0.5
+ dt=1.0
+ endif
+ uy(jj)=(uuhn(ix,j,k,l)*dt2+uuhn(ix,j,k+1,l)*dt1)/dt
+ goto 50
+ endif
+71 continue
+ ! Downward branch
+ kdn=kdn-1
+ if (kdn.lt.1) goto 70
+ kch=kch+1
+ k=kdn
+ ppmk=akz(k)+bkz(k)*psn(ix,j,1,n,l)
+ thdn=tthn(ix,j,k,n,l)*(100000./ppmk)**kappa
+ ppmk=akz(k+1)+bkz(k+1)*psn(ix,j,1,n,l)
+ thup=tthn(ix,j,k+1,n,l)*(100000./ppmk)**kappa
+ if (((thdn.ge.theta).and.(thup.le.theta)).or. &
+ ((thdn.le.theta).and.(thup.ge.theta))) then
+ dt1=abs(theta-thdn)
+ dt2=abs(theta-thup)
+ dt=dt1+dt2
+ if (dt.lt.eps) then ! Avoid division by zero error
+ dt1=0.5 ! G.W., 10.4.1996
+ dt2=0.5
+ dt=1.0
+ endif
+ uy(jj)=(uuhn(ix,j,k,l)*dt2+uuhn(ix,j,k+1,l)*dt1)/dt
+ goto 50
+ endif
+ goto 70
+ ! This section used when no values were found
+51 continue
+ ! Must use uu at current level and lat. juy becomes smaller by 1
+ uy(jj)=uuhn(ix,jy,kl,l)
+ juy=juy-1
+ ! Otherwise OK
+50 continue
+ end do
+ if (juy.gt.0) then
+ dudy=(uy(2)-uy(1))/real(juy)/(dyn(l)*pi/180.)
+ else
+ dudy=uuhn(ix,jyvp,kl,l)-uuhn(ix,jyvm,kl,l)
+ dudy=dudy/real(jumpy)/(dyn(l)*pi/180.)
+ end if
+ !
+ pvhn(ix,jy,kl,l)=dthetadp*(f+(dvdx/cosphi-dudy &
+ +uuhn(ix,jy,kl,l)*tanphi)/r_earth)*(-1.e6)*9.81
+
+ !
+ ! Resest jux and juy
+ jux=jumpx
+ juy=jumpy
+ end do
+ end do
+ end do
+ !
+end subroutine calcpv_nests
diff --git a/src/caldate.f90 b/src/caldate.f90
new file mode 100644
index 0000000000000000000000000000000000000000..99d1fee3ec8975b45e83fecd05ae6ba45cfb8194
--- /dev/null
+++ b/src/caldate.f90
@@ -0,0 +1,91 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine caldate(juldate,yyyymmdd,hhmiss)
+ ! i o o
+ !*****************************************************************************
+ ! *
+ ! Calculates the Gregorian date from the Julian date *
+ ! *
+ ! AUTHOR: Andreas Stohl (21 January 1994), adapted from Numerical Recipes*
+ ! *
+ ! Variables: *
+ ! dd Day *
+ ! hh Hour *
+ ! hhmiss Hour, Minute, Second *
+ ! ja,jb,jc,jd,je help variables *
+ ! jalpha help variable *
+ ! juldate Julian Date *
+ ! julday help variable *
+ ! mi Minute *
+ ! mm Month *
+ ! ss Seconds *
+ ! yyyy Year *
+ ! yyyymmdd Year, Month, Day *
+ ! *
+ ! Constants: *
+ ! igreg help constant *
+ ! *
+ !*****************************************************************************
+
+ use par_mod, only: dp
+
+ implicit none
+
+ integer :: yyyymmdd,yyyy,mm,dd,hhmiss,hh,mi,ss
+ integer :: julday,ja,jb,jc,jd,je,jalpha
+ real(kind=dp) :: juldate
+ integer,parameter :: igreg=2299161
+
+ julday=int(juldate)
+ if(julday.ge.igreg)then
+ jalpha=int(((julday-1867216)-0.25)/36524.25)
+ ja=julday+1+jalpha-int(0.25*jalpha)
+ else
+ ja=julday
+ endif
+ jb=ja+1524
+ jc=int(6680.+((jb-2439870)-122.1)/365.25)
+ jd=365*jc+int(0.25*jc)
+ je=int((jb-jd)/30.6001)
+ dd=jb-jd-int(30.6001*je)
+ mm=je-1
+ if (mm.gt.12) mm=mm-12
+ yyyy=jc-4715
+ if (mm.gt.2) yyyy=yyyy-1
+ if (yyyy.le.0) yyyy=yyyy-1
+
+ yyyymmdd=10000*yyyy+100*mm+dd
+ hh=int(24._dp*(juldate-real(julday,kind=dp)))
+ mi=int(1440._dp*(juldate-real(julday,kind=dp))-60._dp*real(hh,kind=dp))
+ ss=nint(86400._dp*(juldate-real(julday,kind=dp))-3600._dp*real(hh,kind=dp)- &
+ 60._dp*real(mi,kind=dp))
+ if (ss.eq.60) then ! 60 seconds = 1 minute
+ ss=0
+ mi=mi+1
+ endif
+ if (mi.eq.60) then
+ mi=0
+ hh=hh+1
+ endif
+ hhmiss=10000*hh+100*mi+ss
+
+end subroutine caldate
diff --git a/src/centerofmass.f90 b/src/centerofmass.f90
new file mode 100644
index 0000000000000000000000000000000000000000..faf7b1e2b402db81fdd0d3fb5674083ae1352d28
--- /dev/null
+++ b/src/centerofmass.f90
@@ -0,0 +1,89 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine centerofmass(xl,yl,n,xcenter,ycenter)
+ ! i i i o o
+ !*****************************************************************************
+ ! *
+ ! This routine calculates the center of mass of n points on the Earth. *
+ ! Input are the longitudes (xl) and latitudes (yl) of the individual *
+ ! points, output is the longitude and latitude of the centre of mass. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 24 January 2002 *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+
+ implicit none
+
+ integer :: n,l
+ real :: xl(n),yl(n),xll,yll,xav,yav,zav,x,y,z,xcenter,ycenter
+
+
+ xav=0.
+ yav=0.
+ zav=0.
+
+ do l=1,n
+
+ ! Convert longitude and latitude from degrees to radians
+ !*******************************************************
+
+ xll=xl(l)*pi180
+ yll=yl(l)*pi180
+
+ ! Calculate 3D coordinates from longitude and latitude
+ !*****************************************************
+
+ x = cos(yll)*sin(xll)
+ y = -1.*cos(yll)*cos(xll)
+ z = sin(yll)
+
+
+ ! Find the mean location in Cartesian coordinates
+ !************************************************
+
+ xav=xav+x
+ yav=yav+y
+ zav=zav+z
+ end do
+
+ xav=xav/real(n)
+ yav=yav/real(n)
+ zav=zav/real(n)
+
+
+ ! Project the point back onto Earth's surface
+ !********************************************
+
+ xcenter=atan2(xav,-1.*yav)
+ ycenter=atan2(zav,sqrt(xav*xav+yav*yav))
+
+ ! Convert back to degrees
+ !************************
+
+ xcenter=xcenter/pi180
+ ycenter=ycenter/pi180
+
+end subroutine centerofmass
diff --git a/src/clustering.f90 b/src/clustering.f90
new file mode 100644
index 0000000000000000000000000000000000000000..f7dfd5c61b5ae05bedf71edae4b7028bc95afd2c
--- /dev/null
+++ b/src/clustering.f90
@@ -0,0 +1,210 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine clustering(xl,yl,zl,n,xclust,yclust,zclust,fclust,rms, &
+ rmsclust,zrms)
+ ! i i i i o o o o o
+ ! o o
+ !*****************************************************************************
+ ! *
+ ! This routine clusters the particle position into ncluster custers. *
+ ! Input are the longitudes (xl) and latitudes (yl) of the individual *
+ ! points, output are the cluster mean positions (xclust,yclust). *
+ ! Vertical positions are not directly used for the clustering. *
+ ! *
+ ! For clustering, the procedure described in Dorling et al. (1992) is used.*
+ ! *
+ ! Dorling, S.R., Davies, T.D. and Pierce, C.E. (1992): *
+ ! Cluster analysis: a technique for estimating the synoptic meteorological *
+ ! controls on air and precipitation chemistry - method and applications. *
+ ! Atmospheric Environment 26A, 2575-2581. *
+ ! *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 1 February 2002 *
+ ! *
+ ! Variables: *
+ ! fclust fraction of particles belonging to each cluster *
+ ! ncluster number of clusters to be used *
+ ! rms total horizontal rms distance after clustering *
+ ! rmsclust horizontal rms distance for each individual cluster *
+ ! zrms total vertical rms distance after clustering *
+ ! xclust,yclust, Cluster centroid positions *
+ ! zclust *
+ ! xl,yl,zl particle positions *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+
+ implicit none
+
+ integer :: n,i,j,l,nclust(maxpart),numb(ncluster),ncl
+ real :: xl(n),yl(n),zl(n),xclust(ncluster),yclust(ncluster),x,y,z
+ real :: zclust(ncluster),distance2,distances,distancemin,rms,rmsold
+ real :: xav(ncluster),yav(ncluster),zav(ncluster),fclust(ncluster)
+ real :: rmsclust(ncluster)
+ real :: zdist,zrms
+
+
+
+ if (n.lt.ncluster) return
+ rmsold=-5.
+
+ ! Convert longitude and latitude from degrees to radians
+ !*******************************************************
+
+ do i=1,n
+ nclust(i)=i
+ xl(i)=xl(i)*pi180
+ yl(i)=yl(i)*pi180
+ end do
+
+
+ ! Generate a seed for each cluster
+ !*********************************
+
+ do j=1,ncluster
+ zclust(j)=0.
+ xclust(j)=xl(j*n/ncluster)
+ yclust(j)=yl(j*n/ncluster)
+ end do
+
+
+ ! Iterative loop to compute the cluster means
+ !********************************************
+
+ do l=1,100
+
+ ! Assign each particle to a cluster: criterion minimum distance to the
+ ! cluster mean position
+ !*********************************************************************
+
+
+ do i=1,n
+ distancemin=10.**10.
+ do j=1,ncluster
+ distances=distance2(yl(i),xl(i),yclust(j),xclust(j))
+ if (distances.lt.distancemin) then
+ distancemin=distances
+ ncl=j
+ endif
+ end do
+ nclust(i)=ncl
+ end do
+
+
+ ! Recalculate the cluster centroid position: convert to 3D Cartesian coordinates,
+ ! calculate mean position, and re-project this point onto the Earth's surface
+ !*****************************************************************************
+
+ do j=1,ncluster
+ xav(j)=0.
+ yav(j)=0.
+ zav(j)=0.
+ rmsclust(j)=0.
+ numb(j)=0
+ end do
+ rms=0.
+
+ do i=1,n
+ numb(nclust(i))=numb(nclust(i))+1
+ distances=distance2(yl(i),xl(i), &
+ yclust(nclust(i)),xclust(nclust(i)))
+
+ ! rms is the total rms of all particles
+ ! rmsclust is the rms for a particular cluster
+ !*********************************************
+
+ rms=rms+distances*distances
+ rmsclust(nclust(i))=rmsclust(nclust(i))+distances*distances
+
+ ! Calculate Cartesian 3D coordinates from longitude and latitude
+ !***************************************************************
+
+ x = cos(yl(i))*sin(xl(i))
+ y = -1.*cos(yl(i))*cos(xl(i))
+ z = sin(yl(i))
+ xav(nclust(i))=xav(nclust(i))+x
+ yav(nclust(i))=yav(nclust(i))+y
+ zav(nclust(i))=zav(nclust(i))+z
+ end do
+
+ rms=sqrt(rms/real(n))
+
+
+ ! Find the mean location in Cartesian coordinates
+ !************************************************
+
+ do j=1,ncluster
+ if (numb(j).gt.0) then
+ rmsclust(j)=sqrt(rmsclust(j)/real(numb(j)))
+ xav(j)=xav(j)/real(numb(j))
+ yav(j)=yav(j)/real(numb(j))
+ zav(j)=zav(j)/real(numb(j))
+
+ ! Project the point back onto Earth's surface
+ !********************************************
+
+ xclust(j)=atan2(xav(j),-1.*yav(j))
+ yclust(j)=atan2(zav(j),sqrt(xav(j)*xav(j)+yav(j)*yav(j)))
+ endif
+ end do
+
+
+ ! Leave the loop if the RMS distance decreases only slightly between 2 iterations
+ !*****************************************************************************
+
+ if ((l.gt.1).and.(abs(rms-rmsold)/rmsold.lt.0.005)) goto 99
+ rmsold=rms
+
+ end do
+
+99 continue
+
+ ! Convert longitude and latitude from radians to degrees
+ !*******************************************************
+
+ do i=1,n
+ xl(i)=xl(i)/pi180
+ yl(i)=yl(i)/pi180
+ zclust(nclust(i))=zclust(nclust(i))+zl(i)
+ end do
+
+ do j=1,ncluster
+ xclust(j)=xclust(j)/pi180
+ yclust(j)=yclust(j)/pi180
+ if (numb(j).gt.0) zclust(j)=zclust(j)/real(numb(j))
+ fclust(j)=100.*real(numb(j))/real(n)
+ end do
+
+ ! Determine total vertical RMS deviation
+ !***************************************
+
+ zrms=0.
+ do i=1,n
+ zdist=zl(i)-zclust(nclust(i))
+ zrms=zrms+zdist*zdist
+ end do
+ if (zrms.gt.0.) zrms=sqrt(zrms/real(n))
+
+end subroutine clustering
diff --git a/src/cmapf_mod.f90 b/src/cmapf_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..576b291af4085386a95c6c02fadbf29835577ab0
--- /dev/null
+++ b/src/cmapf_mod.f90
@@ -0,0 +1,834 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+! Changes to the routines by A. Stohl
+! xi,xi0,eta,eta0 are double precision variables to avoid problems
+! at poles
+
+module cmapf_mod
+
+ use par_mod, only: dp
+
+ implicit none
+ private
+
+ public :: cc2gll, cll2xy, cgszll, cxy2ll, stlmbr, stcm2p
+
+ real,parameter :: rearth=6371.2, almst1=.9999999
+
+ real,parameter :: pi=3.14159265358979
+ real,parameter :: radpdg=pi/180., dgprad=180./pi
+
+contains
+
+subroutine cc2gll (strcmp, xlat,xlong, ue,vn, ug,vg)
+ !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
+
+ use par_mod, only: dp
+
+ implicit none
+
+ real :: strcmp(9), xlat, xlong, ue, vn, ug, vg
+
+ real(kind=dp) :: xpolg,ypolg,along,slong,clong,rot
+
+ along = cspanf( xlong - strcmp(2), -180., 180.)
+ if (xlat.gt.89.985) then
+ !* North polar meteorological orientation: "north" along prime meridian
+ rot = - strcmp(1) * along + xlong - 180.
+ elseif (xlat.lt.-89.985) then
+ !* South polar meteorological orientation: "north" along prime meridian
+ rot = - strcmp(1) * along - xlong
+ else
+ rot = - strcmp(1) * along
+ endif
+ slong = sin( radpdg * rot )
+ clong = cos( radpdg * rot )
+ xpolg = slong * strcmp(5) + clong * strcmp(6)
+ ypolg = clong * strcmp(5) - slong * strcmp(6)
+ ug = ypolg * ue + xpolg * vn
+ vg = ypolg * vn - xpolg * ue
+ return
+end subroutine cc2gll
+
+subroutine ccrvll (strcmp, xlat,xlong, gx,gy)
+ !* Written on 9/20/94 by Dr. Albion Taylor NOAA / OAR / ARL
+
+ use par_mod, only: dp
+
+ implicit none
+
+ real(kind=dp) :: xpolg,ypolg,temp,along,slong,clong,ctemp, curv
+ real :: strcmp(9), xlat, xlong, gx, gy
+
+ along = cspanf( xlong - strcmp(2), -180., 180.)
+ slong = sin( radpdg * strcmp(1) * along)
+ clong = cos( radpdg * strcmp(1) * along)
+ xpolg = - slong * strcmp(5) + clong * strcmp(6)
+ ypolg = clong * strcmp(5) + slong * strcmp(6)
+ temp = sin(radpdg * xlat)
+ ctemp = cos(radpdg * xlat)
+ curv = (strcmp(1) - temp) / ctemp / rearth
+ gx = curv * xpolg
+ gy = curv * ypolg
+ return
+end subroutine ccrvll
+
+subroutine ccrvxy (strcmp, x,y, gx,gy)
+ !* Written on 9/20/94 by Dr. Albion Taylor NOAA / OAR / ARL
+
+ use par_mod, only: dp
+
+ implicit none
+
+ real :: strcmp(9), x, y, gx, gy
+ real(kind=dp) :: xpolg,ypolg,temp,ymerc,efact,curv
+
+ temp = strcmp(1) * strcmp(7) /rearth
+ xpolg = strcmp(6) + temp * (strcmp(3) - x)
+ ypolg = strcmp(5) + temp * (strcmp(4) - y)
+ temp = sqrt ( xpolg ** 2 + ypolg ** 2 )
+ if (temp.gt.0.) then
+ ymerc = - log( temp) /strcmp(1)
+ efact = exp(ymerc)
+ curv = ( (strcmp(1) - 1.d0) * efact + &
+ (strcmp(1) + 1.d0) / efact ) &
+ * .5d0 / rearth
+ gx = xpolg * curv / temp
+ gy = ypolg * curv / temp
+ else
+ if (abs(strcmp(1)) .eq. 1.) then
+ gx = 0.
+ gy = 0.
+ else
+ gx = 1./rearth
+ gy = 1./rearth
+ endif
+ endif
+ return
+end subroutine ccrvxy
+
+subroutine cg2cll (strcmp, xlat,xlong, ug,vg, ue,vn)
+ !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
+
+ use par_mod, only: dp
+
+ implicit none
+
+ real(kind=dp) :: xpolg,ypolg,along,slong,clong,rot
+ real :: strcmp(9), xlat, xlong, ug, vg, ue, vn
+
+ along = cspanf( xlong - strcmp(2), -180., 180.)
+ if (xlat.gt.89.985) then
+ !* North polar meteorological orientation: "north" along prime meridian
+ rot = - strcmp(1) * along + xlong - 180.
+ elseif (xlat.lt.-89.985) then
+ !* South polar meteorological orientation: "north" along prime meridian
+ rot = - strcmp(1) * along - xlong
+ else
+ rot = - strcmp(1) * along
+ endif
+ slong = sin( radpdg * rot )
+ clong = cos( radpdg * rot )
+ xpolg = slong * strcmp(5) + clong * strcmp(6)
+ ypolg = clong * strcmp(5) - slong * strcmp(6)
+ ue = ypolg * ug - xpolg * vg
+ vn = ypolg * vg + xpolg * ug
+ return
+end subroutine cg2cll
+
+subroutine cg2cxy (strcmp, x,y, ug,vg, ue,vn)
+ !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
+
+ use par_mod, only: dp
+
+ implicit none
+
+ real :: strcmp(9) , x, y, ug, vg, ue, vn
+
+ real :: clong, radial, rot, slong, xlat, xlong
+ real(kind=dp) :: xpolg,ypolg,temp,xi0,eta0,xi,eta
+
+ xi0 = ( x - strcmp(3) ) * strcmp(7) / rearth
+ eta0 = ( y - strcmp(4) ) * strcmp(7) /rearth
+ xi = xi0 * strcmp(5) - eta0 * strcmp(6)
+ eta = eta0 * strcmp(5) + xi0 * strcmp(6)
+ radial = 2. * eta - strcmp(1) * (xi*xi + eta*eta)
+ if (radial.gt.strcmp(8)) then
+ !* Case north of 89 degrees. Meteorological wind direction definition
+ !* changes.
+ call cnxyll(strcmp, xi,eta, xlat,xlong)
+ !* North polar meteorological orientation: "north" along prime meridian
+ rot = strcmp(1) * (xlong - strcmp(2)) - xlong - 180.
+ slong = - sin( radpdg * rot )
+ clong = cos( radpdg * rot )
+ xpolg = slong * strcmp(5) + clong * strcmp(6)
+ ypolg = clong * strcmp(5) - slong * strcmp(6)
+ else if (radial.lt.strcmp(9)) then
+ !* Case south of -89 degrees. Meteorological wind direction definition
+ !* changes.
+ call cnxyll(strcmp, xi,eta, xlat,xlong)
+ !* South polar meteorological orientation: "north" along prime meridian
+ rot = strcmp(1) * (xlong - strcmp(2)) + xlong
+ slong = - sin( radpdg * rot )
+ clong = cos( radpdg * rot )
+ xpolg = slong * strcmp(5) + clong * strcmp(6)
+ ypolg = clong * strcmp(5) - slong * strcmp(6)
+ else
+ !* Normal case. Meteorological direction of wind related to true north.
+ xpolg = strcmp(6) - strcmp(1) * xi0
+ ypolg = strcmp(5) - strcmp(1) * eta0
+ temp = sqrt ( xpolg ** 2 + ypolg ** 2 )
+ xpolg = xpolg / temp
+ ypolg = ypolg / temp
+ end if
+ ue = ( ypolg * ug - xpolg * vg )
+ vn = ( ypolg * vg + xpolg * ug )
+ return
+end subroutine cg2cxy
+
+real function cgszll (strcmp, xlat,xlong)
+ !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
+
+ use par_mod, only: dp
+
+ implicit none
+
+ real :: strcmp(9), xlat, xlong
+
+ real(kind=dp) :: slat,ymerc,efact
+
+ if (xlat .gt. 89.985) then
+ !* Close to north pole
+ if (strcmp(1) .gt. 0.9999) then
+ !* and to gamma == 1.
+ cgszll = 2. * strcmp(7)
+ return
+ endif
+ efact = cos(radpdg * xlat)
+ if (efact .le. 0.) then
+ cgszll = 0.
+ return
+ else
+ ymerc = - log( efact /(1. + sin(radpdg * xlat)))
+ endif
+ else if (xlat .lt. -89.985) then
+ !* Close to south pole
+ if (strcmp(1) .lt. -0.9999) then
+ !* and to gamma == -1.0
+ cgszll = 2. * strcmp(7)
+ return
+ endif
+ efact = cos(radpdg * xlat)
+ if (efact .le. 0.) then
+ cgszll = 0.
+ return
+ else
+ ymerc = log( efact /(1. - sin(radpdg * xlat)))
+ endif
+ else
+ slat = sin(radpdg * xlat)
+ ymerc = log((1. + slat) / (1. - slat))/2.
+ !efact = exp(ymerc)
+ !cgszll = 2. * strcmp(7) * exp (strcmp(1) * ymerc)
+ !c / (efact + 1./efact)
+ endif
+ cgszll = strcmp(7) * cos(radpdg * xlat) * exp(strcmp(1) *ymerc)
+ return
+end function cgszll
+
+real function cgszxy (strcmp, x,y)
+ !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
+
+ use par_mod, only: dp
+
+ implicit none
+
+ real :: strcmp(9) , x, y
+ real(kind=dp) :: ymerc,efact, radial, temp
+ real(kind=dp) :: xi0,eta0,xi,eta
+
+
+ xi0 = ( x - strcmp(3) ) * strcmp(7) / rearth
+ eta0 = ( y - strcmp(4) ) * strcmp(7) /rearth
+ xi = xi0 * strcmp(5) - eta0 * strcmp(6)
+ eta = eta0 * strcmp(5) + xi0 * strcmp(6)
+ radial = 2. * eta - strcmp(1) * (xi*xi + eta*eta)
+ efact = strcmp(1) * radial
+ if (efact .gt. almst1) then
+ if (strcmp(1).gt.almst1) then
+ cgszxy = 2. * strcmp(7)
+ else
+ cgszxy = 0.
+ endif
+ return
+ endif
+ if (abs(efact) .lt. 1.e-2) then
+ temp = (efact / (2. - efact) )**2
+ ymerc = radial / (2. - efact) * (1. + temp * &
+ (1./3. + temp * &
+ (1./5. + temp * &
+ (1./7. ))))
+ else
+ ymerc = - log( 1. - efact ) /2. /strcmp(1)
+ endif
+ if (ymerc .gt. 6.) then
+ if (strcmp(1) .gt. almst1) then
+ cgszxy = 2. * strcmp(7)
+ else
+ cgszxy = 0.
+ endif
+ else if (ymerc .lt. -6.) then
+ if (strcmp(1) .lt. -almst1) then
+ cgszxy = 2. * strcmp(7)
+ else
+ cgszxy = 0.
+ endif
+ else
+ efact = exp(ymerc)
+ cgszxy = 2. * strcmp(7) * exp (strcmp(1) * ymerc) &
+ / (efact + 1./efact)
+ endif
+ return
+end function cgszxy
+
+subroutine cll2xy (strcmp, xlat,xlong, x,y)
+ !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
+
+ implicit none
+
+ real :: strcmp(9) , xlat, xlong, x, y, xi, eta
+
+ call cnllxy(strcmp, xlat,xlong, xi,eta)
+ x = strcmp(3) + rearth/strcmp(7) * &
+ (xi * strcmp(5) + eta * strcmp(6) )
+ y = strcmp(4) + rearth/strcmp(7) * &
+ (eta * strcmp(5) - xi * strcmp(6) )
+ return
+end subroutine cll2xy
+
+subroutine cnllxy (strcmp, xlat,xlong, xi,eta)
+ !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
+ ! main transformation routine from latitude-longitude to
+ ! canonical (equator-centered, radian unit) coordinates
+
+ use par_mod, only: dp
+
+ implicit none
+
+ real :: strcmp(9), xlat, xlong, xi, eta, &
+ gdlong, sndgam, csdgam, rhog1
+ real(kind=dp) :: gamma
+ real(kind=dp) :: dlong,dlat,slat,mercy,gmercy
+
+ gamma = strcmp(1)
+ dlat = xlat
+ dlong = cspanf(xlong - strcmp(2), -180., 180.)
+ dlong = dlong * radpdg
+ gdlong = gamma * dlong
+ if (abs(gdlong) .lt. .01) then
+ ! Code for gamma small or zero. This avoids round-off error or divide-
+ ! by zero in the case of mercator or near-mercator projections.
+ gdlong = gdlong * gdlong
+ sndgam = dlong * (1. - 1./6. * gdlong * &
+ (1. - 1./20. * gdlong * &
+ (1. - 1./42. * gdlong )))
+ csdgam = dlong * dlong * .5 * &
+ (1. - 1./12. * gdlong * &
+ (1. - 1./30. * gdlong * &
+ (1. - 1./56. * gdlong )))
+ else
+ ! Code for moderate values of gamma
+ sndgam = sin (gdlong) /gamma
+ csdgam = (1. - cos(gdlong) )/gamma /gamma
+ endif
+ slat = sin(radpdg * dlat)
+ if ((slat .ge. almst1) .or. (slat .le. -almst1)) then
+ eta = 1./strcmp(1)
+ xi = 0.
+ return
+ endif
+ mercy = .5 * log( (1. + slat) / (1. - slat) )
+ gmercy = gamma * mercy
+ if (abs(gmercy) .lt. .001) then
+ ! Code for gamma small or zero. This avoids round-off error or divide-
+ ! by zero in the case of mercator or near-mercator projections.
+ rhog1 = mercy * (1. - .5 * gmercy * &
+ (1. - 1./3. * gmercy * &
+ (1. - 1./4. * gmercy ) ) )
+ else
+ ! Code for moderate values of gamma
+ rhog1 = (1. - exp(-gmercy)) / gamma
+ endif
+ eta = rhog1 + (1. - gamma * rhog1) * gamma * csdgam
+ xi = (1. - gamma * rhog1 ) * sndgam
+end subroutine cnllxy
+
+subroutine cnxyll (strcmp, xi,eta, xlat,xlong)
+ !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
+ ! main transformation routine from canonical (equator-centered,
+ ! radian unit) coordinates
+
+ use par_mod, only: dp
+
+ implicit none
+
+ real :: strcmp(9), xlat, xlong, odist
+ real(kind=dp) :: gamma,temp,arg1,arg2,ymerc,along,gxi,cgeta
+ real(kind=dp) :: xi,eta
+
+ gamma = strcmp(1)
+ ! Calculate equivalent mercator coordinate
+ odist = xi*xi + eta*eta
+ arg2 = 2. * eta - gamma * (xi*xi + eta*eta)
+ arg1 = gamma * arg2
+ ! Change by A. Stohl to avoid problems close to the poles
+ ! if (arg1 .ge. almst1) then
+ ! distance to north (or south) pole is zero (or imaginary ;) )
+ ! xlat = sign(90.,strcmp(1))
+ ! xlong = strcmp(2)
+ ! return
+ ! endif
+ if (abs(arg1) .lt. .01) then
+ ! Code for gamma small or zero. This avoids round-off error or divide-
+ ! by zero in the case of mercator or near-mercator projections.
+ temp = (arg1 / (2. - arg1) )**2
+ ymerc = arg2 / (2. - arg1) * (1. + temp * &
+ (1./3. + temp * &
+ (1./5. + temp * &
+ (1./7. ))))
+ else
+ ! Code for moderate values of gamma
+ ymerc = - log ( 1. - arg1 ) /2. / gamma
+ endif
+ ! Convert ymerc to latitude
+ temp = exp( - abs(ymerc) )
+ xlat = sign(atan2((1. - temp) * (1. + temp), 2. * temp), ymerc)
+ ! Find longitudes
+ gxi = gamma*xi
+ cgeta = 1. - gamma * eta
+ if ( abs(gxi) .lt. .01*cgeta ) then
+ ! Code for gamma small or zero. This avoids round-off error or divide-
+ ! by zero in the case of mercator or near-mercator projections.
+ temp = ( gxi /cgeta )**2
+ along = xi / cgeta * (1. - temp * &
+ (1./3. - temp * &
+ (1./5. - temp * &
+ (1./7. ))))
+ else
+ ! Code for moderate values of gamma
+ along = atan2( gxi, cgeta) / gamma
+ endif
+ xlong = sngl(strcmp(2) + dgprad * along)
+ xlat = xlat * dgprad
+ return
+end subroutine cnxyll
+
+subroutine cpolll (strcmp, xlat,xlong, enx,eny,enz)
+ !* Written on 11/23/94 by Dr. Albion Taylor NOAA / OAR / ARL
+
+ use par_mod, only: dp
+
+ implicit none
+
+ real(kind=dp) :: xpolg,ypolg,along,slong,clong,rot
+ real :: strcmp(9), xlat, xlong, enx, eny, enz, clat
+
+ along = cspanf( xlong - strcmp(2), -180., 180.)
+ rot = - strcmp(1) * along
+ slong = sin( radpdg * rot )
+ clong = cos( radpdg * rot )
+ xpolg = slong * strcmp(5) + clong * strcmp(6)
+ ypolg = clong * strcmp(5) - slong * strcmp(6)
+ clat = cos(radpdg * xlat)
+ enx = clat * xpolg
+ eny = clat * ypolg
+ enz = sin(radpdg * xlat)
+ return
+end subroutine cpolll
+
+subroutine cpolxy (strcmp, x,y, enx,eny,enz)
+ !* Written on 11/26/94 by Dr. Albion Taylor NOAA / OAR / ARL
+
+ use par_mod, only: dp
+
+ implicit none
+
+ real :: strcmp(9) , x, y, enx, eny, enz
+ real(kind=dp) :: xpol,ypol,temp,xi0,eta0,xi,eta,radial
+ real(kind=dp) :: temp2,ymerc,arg,oarg,clat
+
+ xi0 = ( x - strcmp(3) ) * strcmp(7) / rearth
+ eta0 = ( y - strcmp(4) ) * strcmp(7) /rearth
+ xi = xi0 * strcmp(5) - eta0 * strcmp(6)
+ eta = eta0 * strcmp(5) + xi0 * strcmp(6)
+ radial = 2. * eta - strcmp(1) * (xi*xi + eta*eta)
+ temp = strcmp(1) * radial
+ if (temp .ge. 1.) then
+ enx = 0.
+ eny = 0.
+ enz = sign(1.,strcmp(1))
+ return
+ endif
+ if (abs(temp).lt.1.e-2) then
+ temp2 = (temp / (2. - temp))**2
+ ymerc = radial / (2. - temp) * (1. + temp2 * &
+ (1./3. + temp2 * &
+ (1./5. + temp2 * &
+ (1./7.))))
+ else
+ ymerc = -.5 * log(1. - temp) / strcmp(1)
+ endif
+ arg = exp( ymerc )
+ oarg = 1./arg
+ clat = 2./(arg + oarg)
+ enz = (arg - oarg) * clat /2.
+ temp = clat / sqrt(1. - temp)
+ xpol = - xi * strcmp(1) * temp
+ ypol = (1. - eta * strcmp(1) ) * temp
+ enx = xpol * strcmp(5) + ypol * strcmp(6)
+ eny = ypol * strcmp(5) - xpol * strcmp(6)
+ return
+end subroutine cpolxy
+
+real function cspanf (value, begin, end)
+ !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
+ !* real function cspanf returns a value in the interval (begin,end]
+ !* which is equivalent to value, mod (end - begin). It is used to
+ !* reduce periodic variables to a standard range. It adjusts for the
+ !* behavior of the mod function which provides positive results for
+ !* positive input, and negative results for negative input
+ !* input:
+ !* value - real number to be reduced to the span
+ !* begin - first value of the span
+ !* end - last value of the span
+ !* returns:
+ !* the reduced value
+ !* examples:
+ !* along = cspanf(xlong, -180., +180.)
+ !* dir = cspanf(angle, 0., 360.)
+
+ implicit none
+
+ real :: first,last, value, begin, end, val
+
+ first = min(begin,end)
+ last = max(begin,end)
+ val = mod( value - first , last - first)
+ if ( val .le. 0.) then
+ cspanf = val + last
+ else
+ cspanf = val + first
+ endif
+ return
+end function cspanf
+
+subroutine cxy2ll (strcmp, x,y, xlat,xlong)
+ !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
+
+ use par_mod, only: dp
+
+ implicit none
+
+ real(kind=dp) :: xi0,eta0,xi,eta
+ real :: strcmp(9), x, y, xlat, xlong
+
+ xi0 = ( x - strcmp(3) ) * strcmp(7) / rearth
+ eta0 = ( y - strcmp(4) ) * strcmp(7) /rearth
+ xi = xi0 * strcmp(5) - eta0 * strcmp(6)
+ eta = eta0 * strcmp(5) + xi0 * strcmp(6)
+ call cnxyll(strcmp, xi,eta, xlat,xlong)
+ xlong = cspanf(xlong, -180., 180.)
+ return
+end subroutine cxy2ll
+
+real function eqvlat (xlat1,xlat2)
+ !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
+
+ implicit none
+
+ real :: xlat1, xlat2, x, ssind, sinl1, sinl2, al1, al2, tau
+
+ ssind(x) = sin (radpdg*x)
+ sinl1 = ssind (xlat1)
+ sinl2 = ssind (xlat2)
+ if (abs(sinl1 - sinl2) .gt. .001) then
+ al1 = log((1. - sinl1)/(1. - sinl2))
+ al2 = log((1. + sinl1)/(1. + sinl2))
+ else
+ ! Case lat1 near or equal to lat2
+ tau = - (sinl1 - sinl2)/(2. - sinl1 - sinl2)
+ tau = tau*tau
+ al1 = 2. / (2. - sinl1 - sinl2) * (1. + tau * &
+ (1./3. + tau * &
+ (1./5. + tau * &
+ (1./7.))))
+ tau = (sinl1 - sinl2)/(2. + sinl1 + sinl2)
+ tau = tau*tau
+ al2 = -2. / (2. + sinl1 + sinl2) * (1. + tau * &
+ (1./3. + tau * &
+ (1./5. + tau * &
+ (1./7.))))
+ endif
+ eqvlat = asin((al1 + al2) / (al1 - al2))/radpdg
+ return
+end function eqvlat
+
+subroutine stcm1p(strcmp, x1,y1, xlat1,xlong1, &
+ xlatg,xlongg, gridsz, orient)
+ !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
+
+ implicit none
+
+ integer :: k
+ real :: strcmp(9), x1, y1, xlat1, xlong1, turn, orient, &
+ xlatg, xlongg, gridsz, x1a, y1a
+
+ do k=3,4
+ strcmp (k) = 0.
+ enddo
+ turn = radpdg * (orient - strcmp(1) * &
+ cspanf(xlongg - strcmp(2), -180., 180.) )
+ strcmp (5) = cos (turn)
+ strcmp (6) = - sin (turn)
+ strcmp (7) = 1.
+ strcmp (7) = gridsz * strcmp(7) &
+ / cgszll(strcmp, xlatg, strcmp(2))
+ call cll2xy (strcmp, xlat1,xlong1, x1a,y1a)
+ strcmp(3) = strcmp(3) + x1 - x1a
+ strcmp(4) = strcmp(4) + y1 - y1a
+ return
+end subroutine stcm1p
+
+subroutine stcm2p(strcmp, x1,y1, xlat1,xlong1, &
+ x2,y2, xlat2,xlong2)
+ !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
+
+ implicit none
+
+ real :: strcmp(9), x1, y1, xlat1, xlong1, &
+ x2, y2, xlat2, xlong2
+
+ integer :: k
+ real :: x1a, y1a, x2a, y2a, den, dena
+
+ do k=3,6
+ strcmp (k) = 0.
+ enddo
+ strcmp (5) = 1.
+ strcmp (7) = 1.
+ call cll2xy (strcmp, xlat1,xlong1, x1a,y1a)
+ call cll2xy (strcmp, xlat2,xlong2, x2a,y2a)
+ den = sqrt( (x1 - x2)**2 + (y1 - y2)**2 )
+ dena = sqrt( (x1a - x2a)**2 + (y1a - y2a)**2 )
+ strcmp(5) = ((x1a - x2a)*(x1 - x2) + (y1a - y2a) * (y1 - y2)) &
+ /den /dena
+ strcmp(6) = ((y1a - y2a)*(x1 - x2) - (x1a - x2a) * (y1 - y2)) &
+ /den /dena
+ strcmp (7) = strcmp(7) * dena / den
+ call cll2xy (strcmp, xlat1,xlong1, x1a,y1a)
+ strcmp(3) = strcmp(3) + x1 - x1a
+ strcmp(4) = strcmp(4) + y1 - y1a
+ return
+end subroutine stcm2p
+
+!* General conformal map routines for meteorological modelers
+!* written on 3/31/94 by
+
+!* Dr. Albion Taylor
+!* NOAA / OAR / ARL phone: (301) 713-0295 x 132
+!* rm. 3151, 1315 east-west highway fax: (301) 713-0119
+!* silver spring, md 20910 e-mail: adtaylor@arlrisc.ssmc.noaa.gov
+
+!* subroutine stlmbr (strcmp, tnglat, clong)
+!* This routine initializes the map structure array strcmp to
+!* the form of a specific map projection
+!* inputs:
+!* tnglat - the latitude at which the projection will be tangent
+!* to the earth. +90. For north polar stereographic,
+!* -90. for south polar stereographic, 0. For mercator,
+!* and other values for lambert conformal.
+!* -90 <= tnglat <= 90.
+!* clong - a longitude in the region under consideration. Longitudes
+!* between clong-180. and clong+180. Will be mapped in one
+!* connected region
+!* outputs:
+!* strcmp - a 9-value map structure array for use with subsequent
+!* calls to the coordinate transform routines.
+!*
+!* real function eqvlat (xlat1,xlat2)
+!* This function is provided to assist in finding the tangent latitude
+!* equivalent to the 2-reference latitude specification in the legend
+!* of most lambert conformal maps. If the map specifies "scale
+!* 1:xxxxx true at 40n and 60n", then eqvlat(40.,60.) will return the
+!* equivalent tangent latitude.
+!* inputs:
+!* xlat1,xlat2: the two latitudes specified in the map legend
+!* returns:
+!* the equivalent tangent latitude
+!* example: call stlmbr(strcmp, eqvlat(40.,60.), 90.)
+
+!* subroutine stcm2p (strcmp, x1,y1, xlat1,xlong1,
+!* x2,y2, xlat2,xlong2)
+!* subroutine stcm1p (strcmp, x1,y1, xlat1,xlong1,
+!* xlatg,xlongg, gridsz, orient)
+!* These routines complete the specification of the map structure
+!* array by conforming the map coordinates to the specifications
+!* of a particular grid. Either stcm1p or stcm2p must be called,
+!* but not both
+!* inputs:
+!* strcmp - a 9-value map structure array, set to a particular map
+!* form by a previous call to stlmbr
+!* for stcm2p:
+!* x1,y1, x2,y2 - the map coordinates of two points on the grid
+!* xlat1,xlong1, xlat2,xlong2 - the geographic coordinates of the
+!* same two points
+!* for stcm1p:
+!* x1,y1 - the map coordinates of one point on the grid
+!* xlat1,xlong1 - the geographic coordinates of the same point
+!* xlatg,xlongg - latitude and longitude of reference point for
+!* gridsz and orientation specification.
+!* gridsz - the desired grid size in kilometers, at xlatg,xlongg
+!* orient - the angle, with respect to north, of a y-grid line, at
+!* the point xlatg,xlongg
+!* outputs:
+!* strcmp - a 9-value map structure array, fully set for use by
+!* other subroutines in this system
+
+!* subroutine cll2xy (strcmp, xlat,xlong, x,y)
+!* subroutine cxy2ll (strcmp, x,y, xlat,xlong)
+!* these routines convert between map coordinates x,y
+!* and geographic coordinates xlat,xlong
+!* inputs:
+!* strcmp(9) - 9-value map structure array
+!* for cll2xy: xlat,xlong - geographic coordinates
+!* for cxy2ll: x,y - map coordinates
+!* outputs:
+!* for cll2xy: x,y - map coordinates
+!* for cxy2ll: xlat,xlong - geographic coordinates
+
+!* subroutine cc2gxy (strcmp, x,y, ue,vn, ug,vg)
+!* subroutine cg2cxy (strcmp, x,y, ug,vg, ue,vn)
+!* subroutine cc2gll (strcmp, xlat,xlong, ue,vn, ug,vg)
+!* subroutine cg2cll (strcmp, xlat,xlong, ug,vg, ue,vn)
+!* These subroutines convert vector wind components from
+!* geographic, or compass, coordinates, to map or
+!* grid coordinates. The site of the wind to be
+!* converted may be given either in geographic or
+!* map coordinates. Wind components are all in kilometers
+!* per hour, whether geographic or map coordinates.
+!* inputs:
+!* strcmp(9) - 9-value map structure array
+!* for cc2gxy and cg2cxy: x,y - map coordinates of site
+!* for cc2gll and cg2cll: xlat,xlong - geographic coordinates of site
+!* for cc2gxy and cc2gll: ue,vn - east and north wind components
+!* for cg2cxy and cg2cll: ug,vg - x- and y- direction wind components
+!* outputs:
+!* for cc2gxy and cc2gll: ug,vg - x- and y- direction wind components
+!* for cg2cxy and cg2cll: ue,vn - east and north wind components
+
+!* subroutine ccrvxy (strcmp, x, y, gx,gy)
+!* subroutine ccrvll (strcmp, xlat,xlong, gx,gy)
+!* These subroutines return the curvature vector (gx,gy), as referenced
+!* to map coordinates, induced by the map transformation. When
+!* non-linear terms in wind speed are important, a "geodesic" force
+!* should be included in the vector form [ (u,u) g - (u,g) u ] where the
+!* inner product (u,g) is defined as ux*gx + uy*gy.
+!* inputs:
+!* strcmp(9) - 9-value map structure array
+!* for ccrvxy: x,y - map coordinates of site
+!* for ccrvll: xlat,xlong - geographic coordinates of site
+!* outputs:
+!* gx,gy - vector coefficients of curvature, in units radians
+!* per kilometer
+
+!* real function cgszll (strcmp, xlat,xlong)
+!* real function cgszxy (strcmp, x,y)
+!* These functions return the size, in kilometers, of each unit of
+!* motion in map coordinates (grid size). The grid size at any
+!* location depends on that location; the position may be given in
+!* either map or geographic coordinates.
+!* inputs:
+!* strcmp(9) - 9-value map structure array
+!* for cgszxy: x,y - map coordinates of site
+!* for cgszll: xlat,xlong - geographic coordinates of site
+!* returns:
+!* gridsize in kilometers at given site.
+
+!* subroutine cpolxy (strcmp, x,y, enx,eny,enz)
+!* subroutine cpolll (strcmp, xlat,xlong, enx,eny,enz)
+!* These subroutines provide 3-d vector components of a unit vector
+!* in the direction of the north polar axis. When multiplied
+!* by twice the rotation rate of the earth (2 * pi/24 hr), the
+!* vertical component yields the coriolis factor.
+!* inputs:
+!* strcmp(9) - 9-value map structure array
+!* for cpolxy: x,y - map coordinates of site
+!* for cpolll: xlat,xlong - geographic coordinates of site
+!* returns:
+!* enx,eny,enz the direction cosines of a unit vector in the
+!* direction of the rotation axis of the earth
+
+!* subroutine cnllxy (strcmp, xlat,xlong, xi,eta)
+!* subroutine cnxyll (strcmp, xi,eta, xlat,xlong)
+!* These subroutines perform the underlying transformations from
+!* geographic coordinates to and from canonical (equator centered)
+!* coordinates. They are called by cxy2ll and cll2xy, but are not
+!* intended to be called directly
+
+!* real function cspanf (value, begin, end)
+!* This function assists other routines in providing a longitude in
+!* the proper range. It adds to value whatever multiple of
+!* (end - begin) is needed to return a number begin < cspanf <= end
+
+subroutine stlmbr(strcmp, tnglat, xlong)
+ !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
+
+ implicit none
+
+ real :: strcmp(9), tnglat, xlong
+
+ real :: eta, xi
+
+ strcmp(1) = sin(radpdg * tnglat)
+ !* gamma = sine of the tangent latitude
+ strcmp(2) = cspanf( xlong, -180., +180.)
+ !* lambda_0 = reference longitude
+ strcmp(3) = 0.
+ !* x_0 = x- grid coordinate of origin (xi,eta) = (0.,0.)
+ strcmp(4) = 0.
+ !* y_0 = y-grid coordinate of origin (xi,eta) = (0.,0.)
+ strcmp(5) = 1.
+ !* Cosine of rotation angle from xi,eta to x,y
+ strcmp(6) = 0.
+ !* Sine of rotation angle from xi,eta to x,y
+ strcmp(7) = rearth
+ !* Gridsize in kilometers at the equator
+ call cnllxy(strcmp, 89.,xlong, xi,eta)
+ strcmp(8) = 2. * eta - strcmp(1) * eta * eta
+ !* Radial coordinate for 1 degree from north pole
+ call cnllxy(strcmp, -89.,xlong, xi,eta)
+ strcmp(9) = 2. * eta - strcmp(1) * eta * eta
+ !* Radial coordinate for 1 degree from south pole
+ return
+end subroutine stlmbr
+
+end module cmapf_mod
diff --git a/src/com_mod.f90 b/src/com_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..90e890faca223e3d6fc5dea11a6b274698af247b
--- /dev/null
+++ b/src/com_mod.f90
@@ -0,0 +1,697 @@
+!*******************************************************************************
+! Include file for particle diffusion model FLEXPART *
+! This file contains a global common block used by FLEXPART *
+! *
+! Author: A. Stohl *
+! *
+! June 1996 *
+! *
+! Last update:15 August 2013 IP *
+! *
+!*******************************************************************************
+
+module com_mod
+
+ use par_mod, only: dp, numpath, maxnests, maxageclass, maxspec, ni, &
+ numclass, nymax, nxmax, maxcolumn, maxwf, nzmax, nxmaxn, nymaxn, &
+ maxreceptor, maxpart, maxrand, nwzmax, nuvzmax
+
+ implicit none
+
+ !****************************************************************
+ ! Variables defining where FLEXPART input/output files are stored
+ !****************************************************************
+
+ character :: path(numpath+2*maxnests)*120
+ integer :: length(numpath+2*maxnests)
+ character(len=256) :: pathfile, flexversion, arg1, arg2
+
+ ! path path names needed for trajectory model
+ ! length length of path names needed for trajectory model
+ ! pathfile file where pathnames are stored
+ ! flexversion version of flexpart
+ ! arg input arguments from launch at command line
+
+ !********************************************************
+ ! Variables defining the general model run specifications
+ !********************************************************
+
+ integer :: ibdate,ibtime,iedate,ietime
+ real(kind=dp) :: bdate,edate
+
+
+ ! ibdate beginning date (YYYYMMDD)
+ ! ibtime beginning time (HHMISS)
+ ! iedate ending date (YYYYMMDD)
+ ! ietime ending time (HHMISS)
+ ! bdate beginning date of simulation (julian date)
+ ! edate ending date of simulation (julian date)
+
+
+ integer :: ldirect,ideltas
+
+ ! ldirect 1 for forward, -1 for backward simulation
+ ! ideltas length of trajectory loop from beginning to
+ ! ending date (s)
+
+ integer :: loutstep,loutaver,loutsample,method,lsynctime
+ real :: outstep
+
+ ! loutstep [s] gridded concentration output every loutstep seconds
+ ! loutaver [s] concentration output is an average over [s] seconds
+ ! loutsample [s] sampling interval of gridded concentration output
+ ! lsynctime [s] synchronisation time of all particles
+ ! method indicator which dispersion method is to be used
+ ! outstep = real(abs(loutstep))
+
+ real :: ctl,fine
+ integer :: ifine,iout,ipout,ipin,iflux,mdomainfill
+ integer :: mquasilag,nested_output,ind_source,ind_receptor
+ integer :: ind_rel,ind_samp,ioutputforeachrelease,linit_cond,surf_only
+ logical :: turbswitch
+
+ ! ctl factor, by which time step must be smaller than Lagrangian time scale
+ ! ifine reduction factor for time step used for vertical wind
+ ! Langevin equation for the vertical wind component
+ ! ioutputforeachrelease Should each release be a seperate output field?
+ ! iflux flux calculation options: 1 calculation of fluxes, 2 no fluxes
+ ! iout output options: 1 conc. output (ng/m3), 2 mixing ratio (pptv), 3 both
+ ! ipout particle dump options: 0 no, 1 every output interval, 2 only at end
+ ! ipin read in particle positions from dumped file from a previous run
+ ! fine real(ifine)
+ ! mdomainfill 0: normal run
+ ! 1: particles are initialized according to atmospheric mass distribution
+ ! ind_source switches between different units for concentrations at the source
+ ! NOTE that in backward simulations the release of computational particles
+ ! takes place at the "receptor" and the sampling of particles at the "source".
+ ! 1= mass units
+ ! 2= mass mixing ratio units
+ ! ind_receptor switches between different units for FLEXPART concentration at the receptor
+ ! 1= mass units
+ ! 2= mass mixing ratio units
+ ! linit_cond switch on the output of sensitivity to initial conditions for backward runs
+ ! 0=no, 1=mass unit, 2=mass mixing ratio unit
+ ! mquasilag 0: normal run
+ ! 1: Particle position output is produced in a condensed format and particles are numbered
+ ! surf_only switch output in grid_time files for surface only or full vertical resolution
+ ! 0=no (full vertical resolution), 1=yes (surface only)
+ ! nested_output: 0 no, 1 yes
+ ! turbswitch determines how the Markov chain is formulated
+
+ ! ind_rel and ind_samp are used within the code to change between mass and mass-mix (see readcommand.f)
+
+
+ integer :: mintime,itsplit
+
+ ! mintime minimum time step to be used by FLEXPART
+ ! itsplit time constant for splitting particles
+
+ integer :: lsubgrid,lconvection,lagespectra
+
+ ! lsubgrid 1 if subgrid topography parameterization switched on, 2 if not
+ ! lconvection 1 if convection parameterization switched on, 0 if not
+ ! lagespectra 1 if age spectra calculation switched on, 2 if not
+
+
+ integer :: nageclass,lage(maxageclass)
+
+ ! nageclass number of ageclasses for the age spectra calculation
+ ! lage [s] ageclasses for the age spectra calculation
+
+
+ logical :: gdomainfill
+
+ ! gdomainfill .T., if domain-filling is global, .F. if not
+
+
+
+ !*********************************************************************
+ ! Variables defining the release locations, released species and their
+ ! properties, etc.
+ !*********************************************************************
+
+ !change Sabine Eckhardt, only save the first 1000 identifier for releasepoints
+ character :: compoint(1001)*45
+ integer :: numpoint
+ !sec, now dynamically allocated:
+ ! ireleasestart(maxpoint),ireleaseend(maxpoint)
+ ! real xpoint1(maxpoint),ypoint1(maxpoint)
+ !real xpoint2(maxpoint),ypoint2(maxpoint)
+ !real zpoint1(maxpoint),zpoint2(maxpoint)
+ !integer*2 kindz(maxpoint)
+ integer :: specnum(maxspec)
+ !real xmass(maxpoint,maxspec)
+ real :: decay(maxspec)
+ real :: weta(maxspec),wetb(maxspec)
+! NIK: 31.01.2013- parameters for in-cloud scavening
+ real :: weta_in(maxspec), wetb_in(maxspec), wetc_in(maxspec), wetd_in(maxspec)
+ real :: reldiff(maxspec),henry(maxspec),f0(maxspec)
+ real :: density(maxspec),dquer(maxspec),dsigma(maxspec)
+ real :: vsetaver(maxspec),cunningham(maxspec),weightmolar(maxspec)
+ real :: vset(maxspec,ni),schmi(maxspec,ni),fract(maxspec,ni)
+ real :: ri(5,numclass),rac(5,numclass),rcl(maxspec,5,numclass)
+ real :: rgs(maxspec,5,numclass),rlu(maxspec,5,numclass)
+ real :: rm(maxspec),dryvel(maxspec),kao(maxspec),ohreact(maxspec)
+ ! se it is possible to associate a species with a second one to make transfer from gas to aerosol
+ integer :: spec_ass(maxspec)
+
+ real :: area_hour(maxspec,24),point_hour(maxspec,24)
+ real :: area_dow(maxspec,7),point_dow(maxspec,7)
+
+ !integer npart(maxpoint)
+ integer :: nspec,maxpointspec_act
+ character(len=10) :: species(maxspec)
+
+
+ ! compoint comment, also "name" of each starting point
+ ! numpoint actual number of trajectory starting/ending points
+ ! ireleasestart,ireleaseend [s] starting and ending time of each release
+ ! xmass total mass emitted
+ ! xpoint1,ypoint1 lower left coordinates of release area
+ ! xpoint2,ypoint2 upper right coordinates of release area
+ ! zpoint1,zpoint2 min./max. z-coordinates of release points
+ ! kindz 1: zpoint is in m agl, 2: zpoint is in m asl
+ ! npart number of particles per release point
+ ! nspec number of different species allowed for one release
+ ! maxpointspec_act number of releaspoints for which a different output shall be created
+ ! species name of species
+ ! decay decay constant of radionuclide
+
+ ! WET DEPOSITION
+ ! weta, wetb parameters for determining below-cloud wet scavenging coefficients
+ ! weta_in, wetb_in parameters for determining in-cloud wet scavenging coefficients
+ ! wetc_in, wetd_in parameters for determining in-cloud wet scavenging coefficients
+
+ ! GAS DEPOSITION
+ ! reldiff diffusivitiy of species relative to diff. of H2O
+ ! henry [M/atm] Henry constant
+ ! f0 reactivity relative to that of O3
+ ! ri [s/m] stomatal resistance
+ ! rcl [s/m] lower canopy resistance
+ ! rgs [s/m] ground resistance
+ ! rlu [s/m] leaf cuticular resistance
+ ! rm [s/m] mesophyll resistance
+ ! dryvel [m/s] constant dry deposition velocity
+
+ ! PARTICLE DEPOSITION
+ ! density [kg/m3] density of particles
+ ! dquer [m] mean diameter of particles
+ ! dsigma dsigma=10 or dsigma=0.1 means that 68% of the
+ ! mass are between 0.1*dquer and 10*dquer
+
+ ! fract mass fraction of each diameter interval
+ ! vset [m/s] gravitational settling velocity in ni intervals
+ ! cunningham Cunningham slip correction (strictly valid only near surface)
+ ! vsetaver [m/s] average gravitational settling velocity
+ ! schmi Schmidt number**2/3 of each diameter interval
+ ! weightmolar [g/mol] molecular weight
+
+ ! TIME VARIATION OF EMISSION
+ ! area_hour, point_hour daily variation of emission strengths for area and point sources
+ ! area_dow, point_dow day-of-week variation of emission strengths for area and point sources
+
+
+
+ !**********************************************************
+ ! Variables used for domain-filling trajectory calculations
+ !**********************************************************
+
+ integer :: nx_we(2),ny_sn(2)
+ integer :: numcolumn
+ integer :: numcolumn_we(2,0:nymax-1),numcolumn_sn(2,0:nxmax-1)
+ real :: zcolumn_we(2,0:nymax-1,maxcolumn)
+ real :: zcolumn_sn(2,0:nxmax-1,maxcolumn)
+ real :: xmassperparticle
+ real :: acc_mass_we(2,0:nymax-1,maxcolumn)
+ real :: acc_mass_sn(2,0:nxmax-1,maxcolumn)
+
+ ! nx_we(2) x indices of western and eastern boundary of domain-filling
+ ! ny_sn(2) y indices of southern and northern boundary of domain-filling
+ ! numcolumn_we number of particles to be released within one column
+ ! at the western and eastern boundary surfaces
+ ! numcolumn_sn same as numcolumn_we, but for southern and northern domain boundary
+ ! numcolumn maximum number of particles to be released within a single
+ ! column
+ ! zcolumn_we altitudes where particles are to be released
+ ! at the western and eastern boundary surfaces
+ ! zcolumn_sn same as zcolumn_we, but for southern and northern domain boundary
+ ! xmassperparticle air mass per particle in the domain-filling traj. option
+ ! acc_mass_we mass that has accumulated at the western and eastern boundary;
+ ! if it exceeds xmassperparticle, a particle is released and
+ ! acc_mass_we is reduced accordingly
+ ! acc_mass_sn same as acc_mass_we, but for southern and northern domain boundary
+
+
+
+ !******************************************************************************
+ ! Variables associated with the ECMWF meteorological input data ("wind fields")
+ !******************************************************************************
+
+ integer :: numbwf,wftime(maxwf),lwindinterv
+ character(len=255) :: wfname(maxwf),wfspec(maxwf)
+
+ ! lwindinterv [s] Interval between wind fields currently in memory
+ ! numbwf actual number of wind fields
+ ! wftime(maxwf) [s] times relative to beginning time of wind fields
+ ! wfname(maxwf) file names of wind fields
+ ! wfspec(maxwf) specifications of wind field file, e.g. if on hard
+ ! disc or on tape
+
+ integer :: memtime(2),memind(2)
+
+ ! memtime [s] validation times of wind fields in memory
+ ! memind pointer to wind field, in order to avoid shuffling
+ ! of wind fields
+
+
+
+ !****************************************************************************
+ ! Variables defining actual size and geographical location of the wind fields
+ !****************************************************************************
+
+ integer :: nx,ny,nxmin1,nymin1,nxfield,nuvz,nwz,nz,nmixz,nlev_ec
+ real :: dx,dy,xlon0,ylat0,dxconst,dyconst,height(nzmax)
+
+ ! nx,ny,nz actual dimensions of wind fields in x,y and z
+ ! direction, respectively
+ ! nxmin1,nymin1 nx-1, ny-1, respectively
+ ! nuvz,nwz vertical dimension of original ECMWF data
+ ! nxfield same as nx for limited area fields,
+ ! but for global fields nx=nxfield+1
+ ! nmixz number of levels up to maximum PBL height (3500 m)
+
+ ! nuvz is used for u,v components
+ ! nwz is used for w components (staggered grid)
+ ! nz is used for the levels in transformed coordinates (terrain-following Cartesian
+ ! coordinates)
+
+ ! nlev_ec number of levels ECMWF model
+ ! dx grid distance in x direction
+ ! dy grid distance in y direction
+ ! dxconst,dyconst auxiliary variables for utransform,vtransform
+ ! height heights of all levels
+ ! xlon0 geographical longitude and
+ ! ylat0 geographical latitude of lower left grid point
+
+
+
+ !*************************************************
+ ! Variables used for vertical model discretization
+ !*************************************************
+
+ real :: akm(nwzmax),bkm(nwzmax)
+ real :: akz(nuvzmax),bkz(nuvzmax)
+ real :: aknew(nzmax),bknew(nzmax)
+
+ ! akm,bkm: coeffizients which regulate vertical discretization of ecmwf model
+ ! (at the border of model layers)
+ ! akz,bkz: model discretization coeffizients at the centre of the layers
+ ! aknew,bknew model discretization coeffizients at the interpolated levels
+
+
+
+ ! Fixed fields, unchangeable with time
+ !*************************************
+
+ real :: oro(0:nxmax-1,0:nymax-1)
+ real :: excessoro(0:nxmax-1,0:nymax-1)
+ real :: lsm(0:nxmax-1,0:nymax-1)
+ real :: xlanduse(0:nxmax-1,0:nymax-1,numclass)
+
+ ! oro [m] orography of the ECMWF model
+ ! excessoro excess orography mother domain
+ ! lsm land sea mask of the ECMWF model
+ ! xlanduse [0-1] area fractions in percent
+
+ ! 3d fields
+ !**********
+
+ real :: uu(0:nxmax-1,0:nymax-1,nzmax,2)
+ real :: vv(0:nxmax-1,0:nymax-1,nzmax,2)
+ real :: uupol(0:nxmax-1,0:nymax-1,nzmax,2)
+ real :: vvpol(0:nxmax-1,0:nymax-1,nzmax,2)
+ real :: ww(0:nxmax-1,0:nymax-1,nzmax,2)
+ real :: tt(0:nxmax-1,0:nymax-1,nzmax,2)
+ real :: qv(0:nxmax-1,0:nymax-1,nzmax,2)
+ real :: pv(0:nxmax-1,0:nymax-1,nzmax,2)
+ real :: rho(0:nxmax-1,0:nymax-1,nzmax,2)
+ real :: drhodz(0:nxmax-1,0:nymax-1,nzmax,2)
+ real :: tth(0:nxmax-1,0:nymax-1,nuvzmax,2)
+ real :: qvh(0:nxmax-1,0:nymax-1,nuvzmax,2)
+ real :: pplev(0:nxmax-1,0:nymax-1,nuvzmax,2)
+ !scavenging NIK, PS
+ integer(kind=1) :: clouds(0:nxmax-1,0:nymax-1,nzmax,2)
+ integer :: cloudsh(0:nxmax-1,0:nymax-1,2)
+ integer icloudbot(0:nxmax-1,0:nymax-1,2)
+ integer icloudthck(0:nxmax-1,0:nymax-1,2)
+
+
+ ! uu,vv,ww [m/2] wind components in x,y and z direction
+ ! uupol,vvpol [m/s] wind components in polar stereographic projection
+ ! tt [K] temperature data
+ ! qv specific humidity data
+ ! pv (pvu) potential vorticity
+ ! rho [kg/m3] air density
+ ! drhodz [kg/m2] vertical air density gradient
+ ! tth,qvh tth,qvh on original eta levels
+ ! clouds: no cloud, no precipitation 0
+ ! cloud, no precipitation 1
+ ! rainout conv/lsp dominated 2/3
+ ! washout conv/lsp dominated 4/5
+! PS 2013
+!c icloudbot (m) cloud bottom height
+!c icloudthck (m) cloud thickness
+
+ ! pplev for the GFS version
+
+ ! 2d fields
+ !**********
+
+ real :: ps(0:nxmax-1,0:nymax-1,1,2)
+ real :: sd(0:nxmax-1,0:nymax-1,1,2)
+ real :: msl(0:nxmax-1,0:nymax-1,1,2)
+ real :: tcc(0:nxmax-1,0:nymax-1,1,2)
+ real :: u10(0:nxmax-1,0:nymax-1,1,2)
+ real :: v10(0:nxmax-1,0:nymax-1,1,2)
+ real :: tt2(0:nxmax-1,0:nymax-1,1,2)
+ real :: td2(0:nxmax-1,0:nymax-1,1,2)
+ real :: lsprec(0:nxmax-1,0:nymax-1,1,2)
+ real :: convprec(0:nxmax-1,0:nymax-1,1,2)
+ real :: sshf(0:nxmax-1,0:nymax-1,1,2)
+ real :: ssr(0:nxmax-1,0:nymax-1,1,2)
+ real :: surfstr(0:nxmax-1,0:nymax-1,1,2)
+ real :: ustar(0:nxmax-1,0:nymax-1,1,2)
+ real :: wstar(0:nxmax-1,0:nymax-1,1,2)
+ real :: hmix(0:nxmax-1,0:nymax-1,1,2)
+ real :: tropopause(0:nxmax-1,0:nymax-1,1,2)
+ real :: oli(0:nxmax-1,0:nymax-1,1,2)
+ real :: diffk(0:nxmax-1,0:nymax-1,1,2)
+
+ ! ps surface pressure
+ ! sd snow depth
+ ! msl mean sea level pressure
+ ! tcc total cloud cover
+ ! u10 10 meter u
+ ! v10 10 meter v
+ ! tt2 2 meter temperature
+ ! td2 2 meter dew point
+ ! lsprec [mm/h] large scale total precipitation
+ ! convprec [mm/h] convective precipitation
+ ! sshf surface sensible heat flux
+ ! ssr surface solar radiation
+ ! surfstr surface stress
+ ! ustar [m/s] friction velocity
+ ! wstar [m/s] convective velocity scale
+ ! hmix [m] mixing height
+ ! tropopause [m] altitude of thermal tropopause
+ ! oli [m] inverse Obukhov length (1/L)
+ ! diffk [m2/s] diffusion coefficient at reference height
+
+
+ real :: vdep(0:nxmax-1,0:nymax-1,maxspec,2)
+
+ ! vdep [m/s] deposition velocities
+
+
+ !********************************************************************
+ ! Variables associated with the ECMWF input data (nested wind fields)
+ !********************************************************************
+
+ ! NOTE: all nested variables have the same name as the variables used
+ ! for the mother domain, except with a 'n' appended at the end
+ !********************************************************************
+
+ integer :: numbnests
+
+ ! numbnests number of nested grids
+
+ character(len=255) :: wfnamen(maxnests,maxwf)
+ character(len=18) :: wfspecn(maxnests,maxwf)
+
+ ! wfnamen nested wind field names
+ ! wfspecn specifications of wind field file, e.g. if on hard
+ ! disc or on tape
+
+
+ !*********************************************************************
+ ! Variables characterizing size and location of the nested wind fields
+ !*********************************************************************
+
+ integer :: nxn(maxnests),nyn(maxnests)
+ real :: dxn(maxnests),dyn(maxnests),xlon0n(maxnests),ylat0n(maxnests)
+
+ ! nxn,nyn actual dimensions of nested wind fields in x and y direction
+ ! dxn,dyn grid distances in x,y direction for the nested grids
+ ! xlon0n geographical longitude of lower left grid point of nested wind fields
+ ! ylat0n geographical latitude of lower left grid point of nested wind fields
+
+
+ ! Nested fields, unchangeable with time
+ !**************************************
+
+ real :: oron(0:nxmaxn-1,0:nymaxn-1,maxnests)
+ real :: excessoron(0:nxmaxn-1,0:nymaxn-1,maxnests)
+ real :: lsmn(0:nxmaxn-1,0:nymaxn-1,maxnests)
+ real :: xlandusen(0:nxmaxn-1,0:nymaxn-1,numclass,maxnests)
+
+
+ ! 3d nested fields
+ !*****************
+
+ real :: uun(0:nxmaxn-1,0:nymaxn-1,nzmax,2,maxnests)
+ real :: vvn(0:nxmaxn-1,0:nymaxn-1,nzmax,2,maxnests)
+ real :: wwn(0:nxmaxn-1,0:nymaxn-1,nzmax,2,maxnests)
+ real :: ttn(0:nxmaxn-1,0:nymaxn-1,nzmax,2,maxnests)
+ real :: qvn(0:nxmaxn-1,0:nymaxn-1,nzmax,2,maxnests)
+ real :: pvn(0:nxmaxn-1,0:nymaxn-1,nzmax,2,maxnests)
+ integer(kind=1) :: cloudsn(0:nxmaxn-1,0:nymaxn-1,0:nzmax,2,maxnests)
+ integer :: cloudsnh(0:nxmaxn-1,0:nymaxn-1,2,maxnests)
+ real :: rhon(0:nxmaxn-1,0:nymaxn-1,nzmax,2,maxnests)
+ real :: drhodzn(0:nxmaxn-1,0:nymaxn-1,nzmax,2,maxnests)
+ real :: tthn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,2,maxnests)
+ real :: qvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,2,maxnests)
+
+ ! 2d nested fields
+ !*****************
+
+ real :: psn(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
+ real :: sdn(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
+ real :: msln(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
+ real :: tccn(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
+ real :: u10n(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
+ real :: v10n(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
+ real :: tt2n(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
+ real :: td2n(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
+ real :: lsprecn(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
+ real :: convprecn(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
+ real :: sshfn(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
+ real :: ssrn(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
+ real :: surfstrn(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
+ real :: ustarn(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
+ real :: wstarn(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
+ real :: hmixn(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
+ real :: tropopausen(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
+ real :: olin(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
+ real :: diffkn(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
+ real :: vdepn(0:nxmaxn-1,0:nymaxn-1,maxspec,2,maxnests)
+
+
+ !*************************************************
+ ! Certain auxiliary variables needed for the nests
+ !*************************************************
+
+ real :: xresoln(0:maxnests),yresoln(0:maxnests)
+
+ ! xresoln, yresoln Factors by which the resolutions in the nests
+ ! are enhanced compared to mother grid
+
+ real :: xln(maxnests),yln(maxnests),xrn(maxnests),yrn(maxnests)
+
+ ! xln,yln,xrn,yrn Corner points of nested grids in grid coordinates
+ ! of mother grid
+
+
+ !******************************************************
+ ! Variables defining the polar stereographic projection
+ !******************************************************
+
+ logical :: xglobal,sglobal,nglobal
+ real :: switchnorthg,switchsouthg
+
+ !xglobal T for global fields, F for limited area fields
+ !sglobal T if domain extends towards south pole
+ !nglobal T if domain extends towards north pole
+ !switchnorthg,switchsouthg same as parameters switchnorth,
+ ! switchsouth, but in grid units
+
+ real :: southpolemap(9),northpolemap(9)
+
+ !southpolemap,northpolemap define stereographic projections
+ ! at the two poles
+
+
+ !******************
+ ! Landuse inventory
+ ! Sabine Eckhardt Dec 06: change to new landuse inventary - 11 classes, 1200 x 600 global
+ !******************
+
+ integer(kind=1) :: landinvent(1200,600,6)
+ real :: z0(numclass)
+
+ ! landinvent landuse inventory (numclass=11 classes)
+ ! z0 roughness length for the landuse classes
+
+
+
+ !**************************************************************************
+ ! Variables characterizing the output grid and containing the model results
+ !**************************************************************************
+
+ integer :: numxgrid,numygrid,numzgrid
+ real :: dxout,dyout,outlon0,outlat0,xoutshift,youtshift
+ integer :: numxgridn,numygridn
+ real :: dxoutn,dyoutn,outlon0n,outlat0n,xoutshiftn,youtshiftn
+ !real outheight(maxzgrid),outheighthalf(maxzgrid)
+ logical :: DEP,DRYDEP,DRYDEPSPEC(maxspec),WETDEP,OHREA,ASSSPEC
+
+ ! numxgrid,numygrid number of grid points in x,y-direction
+ ! numxgridn,numygridn number of grid points in x,y-direction for nested output grid
+ ! numzgrid number of vertical levels of output grid
+ ! dxout,dyout grid distance of output grid
+ ! dxoutn,dyoutn grid distance of nested output grid
+ ! outlon0,outlat0 lower left corner of output grid
+ ! outlon0n,outlat0n lower left corner of nested output grid
+ ! xoutshift,youtshift xlon0-outlon0, ylat0-outlat0
+ ! xoutshiftn,youtshiftn xlon0-outlon0n, ylat0-outlat0n
+ ! outheight [m] upper levels of the output grid
+ ! outheighthalf [m] half (middle) levels of the output grid cells
+ ! DEP .true., if either dry or wet depos. is switched on
+ ! DRYDEP .true., if dry deposition is switched on
+ ! DRYDEPSPEC .true., if dry deposition is switched on for that species
+ ! WETDEP .true., if wet deposition is switched on
+ ! OHREA .true., if OH reaction is switched on
+ ! ASSSPEC .true., if there are two species asscoiated
+ ! (i.e. transfer of mass between these two occurs
+
+
+
+ ! if output for each releasepoint shall be created maxpointspec=number of releasepoints
+ ! else maxpointspec is 1 -> moved to unc_mod
+ ! the OUTGRID is moved to the module outg_mod
+ !******************************************************************************
+
+ !real gridunc(0:maxxgrid-1,0:maxygrid-1,maxzgrid,maxspec,
+ ! + maxpointspec_act,nclassunc,maxageclass)
+ !real griduncn(0:maxxgridn-1,0:maxygridn-1,maxzgrid,maxspec,
+ ! + maxpointspec_act,nclassunc,maxageclass)
+ !real wetgridunc(0:maxxgrid-1,0:maxygrid-1,maxspec,
+ ! + maxpointspec_act,nclassunc,maxageclass)
+ !real wetgriduncn(0:maxxgridn-1,0:maxygridn-1,maxspec,
+ ! +ct maxpointspec,nclassunc,maxageclass)
+ !real drygridunc(0:maxxgrid-1,0:maxygrid-1,maxspec,maxpointspec,
+ ! + nclassunc,maxageclass)
+ !real drygriduncn(0:maxxgridn-1,0:maxygridn-1,maxspec,
+ ! + maxpointspec,nclassunc,maxageclass)
+
+ !real oroout(0:maxxgrid-1,0:maxygrid-1)
+ !real orooutn(0:maxxgridn-1,0:maxygridn-1)
+ ! real area(0:maxxgrid-1,0:maxygrid-1)
+ !real arean(0:maxxgridn-1,0:maxygridn-1)
+ !real volume(0:maxxgrid-1,0:maxygrid-1,maxzgrid)
+ !real volumen(0:maxxgridn-1,0:maxygridn-1,maxzgrid)
+
+ !real areaeast(0:maxxgrid-1,0:maxygrid-1,maxzgrid)
+ !real areanorth(0:maxxgrid-1,0:maxygrid-1,maxzgrid)
+
+
+ ! gridunc,griduncn uncertainty of outputted concentrations
+ ! wetgridunc,wetgriduncn uncertainty of accumulated wet deposited mass on output grid
+ ! drygridunc,drygriduncn uncertainty of accumulated dry deposited mass on output grid
+ ! oroout,orooutn [m] height of model topography at output grid
+ ! area,arean [m2] area of each grid cell
+ ! volume,volumen [m3] volume of each grid cell
+ ! ... field names with n at the end indicate a nested output grid
+
+
+ !***********************************
+ ! Variables defining receptor points
+ !***********************************
+
+ real :: xreceptor(maxreceptor),yreceptor(maxreceptor)
+ real :: receptorarea(maxreceptor)
+ real :: creceptor(maxreceptor,maxspec)
+ character(len=16) :: receptorname(maxreceptor)
+ integer :: numreceptor
+
+ ! xreceptor,yreceptor receptor position
+ ! creceptor concentrations at receptor points
+ ! receptorarea area of 1*1 grid cell at receptor point
+
+
+
+ !***************************************
+ ! Variables characterizing each particle
+ !***************************************
+
+ integer :: numpart,itra1(maxpart)
+ integer :: npoint(maxpart),nclass(maxpart)
+ integer :: idt(maxpart),itramem(maxpart),itrasplit(maxpart)
+ integer :: numparticlecount
+
+ real(kind=dp) :: xtra1(maxpart),ytra1(maxpart)
+ real :: ztra1(maxpart),xmass1(maxpart,maxspec)
+
+ ! numpart actual number of particles in memory
+ ! itra1 (maxpart) [s] temporal positions of the particles
+ ! npoint(maxpart) indicates the release point of each particle
+ ! nclass (maxpart) one of nclassunc classes to which the particle is attributed
+ ! itramem (maxpart) [s] memorized release times of the particles
+ ! itrasplit (maxpart) [s] next time when particle is to be split into two
+ ! idt(maxpart) [s] time step to be used for next integration
+ ! numparticlecount counts the total number of particles that have been released
+ ! xtra1,ytra1,ztra1 spatial positions of the particles
+ ! xmass1 [kg] particle masses
+
+
+
+ !*******************************************************
+ ! Info table on available chemical species/radionuclides
+ !*******************************************************
+
+ !character*10 specname(maxtable)
+ !real decaytime(maxtable),wetscava(maxtable),wetscavb(maxtable)
+ !real drydiff(maxtable),dryhenry(maxtable),dryactiv(maxtable)
+ !real partrho(maxtable),partmean(maxtable),partsig(maxtable)
+ !real dryvelo(maxtable),weightmol(maxtable),ohreact(maxtable)
+
+ ! specname Name of chemical species/radionuclide
+ ! decaytime Half time of radionuclides
+ ! wetscava, wetscavb Parameters for calculating scavenging coefficients
+ ! drydiff diffusivitiy of species relative to diff. of H2O
+ ! dryhenry [M/atm] Henry constant
+ ! dryactiv reactivity relative to that of O3
+ ! partrho [kg/m3] density of particles
+ ! partmean [m] mean diameter of particles
+ ! partsig [m] mean stand. deviation of particle diameter
+ ! dryvelo [cm/s] constant dry deposition velocity
+ ! weightmol [g/mol] molecular weight
+ ! ohreact OH reaction rate
+
+
+ !********************
+ ! Random number field
+ !********************
+
+ real :: rannumb(maxrand)
+
+ ! rannumb field of normally distributed random numbers
+
+ !********************
+ ! Verbosity, testing flags
+ !********************
+ integer :: verbosity=0
+ integer :: info_flag=0
+ INTEGER :: count_clock, count_clock0, count_rate, count_max
+
+
+end module com_mod
diff --git a/src/conccalc.f90 b/src/conccalc.f90
new file mode 100644
index 0000000000000000000000000000000000000000..9e7767c4757170a98065eba7f1319924e9cbfb4c
--- /dev/null
+++ b/src/conccalc.f90
@@ -0,0 +1,419 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine conccalc(itime,weight)
+ ! i i
+ !*****************************************************************************
+ ! *
+ ! Calculation of the concentrations on a regular grid using volume *
+ ! sampling *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 24 May 1996 *
+ ! *
+ ! April 2000: Update to calculate age spectra *
+ ! Bug fix to avoid negative conc. at the domain boundaries, *
+ ! as suggested by Petra Seibert *
+ ! *
+ ! 2 July 2002: re-order if-statements in order to optimize CPU time *
+ ! *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! nspeciesdim = nspec for forward runs, 1 for backward runs *
+ ! *
+ !*****************************************************************************
+
+ use unc_mod
+ use outg_mod
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: itime,itage,i,ix,jy,ixp,jyp,kz,ks,n,nage
+ integer :: il,ind,indz,indzp,nrelpointer
+ real :: rddx,rddy,p1,p2,p3,p4,dz1,dz2,dz
+ real :: weight,hx,hy,hz,h,xd,yd,zd,xkern,r2,c(maxspec),ddx,ddy
+ real :: rhoprof(2),rhoi
+ real :: xl,yl,wx,wy,w
+ real,parameter :: factor=.596831, hxmax=6.0, hymax=4.0, hzmax=150.
+
+
+ ! For forward simulations, make a loop over the number of species;
+ ! for backward simulations, make an additional loop over the
+ ! releasepoints
+ !***************************************************************************
+
+
+ do i=1,numpart
+ if (itra1(i).ne.itime) goto 20
+
+ ! Determine age class of the particle
+ itage=abs(itra1(i)-itramem(i))
+ do nage=1,nageclass
+ if (itage.lt.lage(nage)) goto 33
+ end do
+33 continue
+
+
+ ! For special runs, interpolate the air density to the particle position
+ !************************************************************************
+ !***********************************************************************
+ !AF IND_SOURCE switches between different units for concentrations at the source
+ !Af NOTE that in backward simulations the release of particles takes place
+ !Af at the receptor and the sampling at the source.
+ !Af 1="mass"
+ !Af 2="mass mixing ratio"
+ !Af IND_RECEPTOR switches between different units for concentrations at the receptor
+ !Af 1="mass"
+ !Af 2="mass mixing ratio"
+
+ !Af switches for the conccalcfile:
+ !AF IND_SAMP = 0 : xmass * 1
+ !Af IND_SAMP = -1 : xmass / rho
+
+ !Af ind_samp is defined in readcommand.f
+
+ if ( ind_samp .eq. -1 ) then
+
+ ix=int(xtra1(i))
+ jy=int(ytra1(i))
+ ixp=ix+1
+ jyp=jy+1
+ ddx=xtra1(i)-real(ix)
+ ddy=ytra1(i)-real(jy)
+ rddx=1.-ddx
+ rddy=1.-ddy
+ p1=rddx*rddy
+ p2=ddx*rddy
+ p3=rddx*ddy
+ p4=ddx*ddy
+
+ do il=2,nz
+ if (height(il).gt.ztra1(i)) then
+ indz=il-1
+ indzp=il
+ goto 6
+ endif
+ end do
+6 continue
+
+ dz1=ztra1(i)-height(indz)
+ dz2=height(indzp)-ztra1(i)
+ dz=1./(dz1+dz2)
+
+ ! Take density from 2nd wind field in memory (accurate enough, no time interpolation needed)
+ !*****************************************************************************
+ do ind=indz,indzp
+ rhoprof(ind-indz+1)=p1*rho(ix ,jy ,ind,2) &
+ +p2*rho(ixp,jy ,ind,2) &
+ +p3*rho(ix ,jyp,ind,2) &
+ +p4*rho(ixp,jyp,ind,2)
+ end do
+ rhoi=(dz1*rhoprof(2)+dz2*rhoprof(1))*dz
+ elseif (ind_samp.eq.0) then
+ rhoi = 1.
+ endif
+
+
+ !****************************************************************************
+ ! 1. Evaluate grid concentrations using a uniform kernel of bandwidths dx, dy
+ !****************************************************************************
+
+
+ ! For backward simulations, look from which release point the particle comes from
+ ! For domain-filling trajectory option, npoint contains a consecutive particle
+ ! number, not the release point information. Therefore, nrelpointer is set to 1
+ ! for the domain-filling option.
+ !*****************************************************************************
+
+ if ((ioutputforeachrelease.eq.0).or.(mdomainfill.eq.1)) then
+ nrelpointer=1
+ else
+ nrelpointer=npoint(i)
+ endif
+
+ do kz=1,numzgrid ! determine height of cell
+ if (outheight(kz).gt.ztra1(i)) goto 21
+ end do
+21 continue
+ if (kz.le.numzgrid) then ! inside output domain
+
+
+ !********************************
+ ! Do everything for mother domain
+ !********************************
+
+ xl=(xtra1(i)*dx+xoutshift)/dxout
+ yl=(ytra1(i)*dy+youtshift)/dyout
+ ix=int(xl)
+ if (xl.lt.0.) ix=ix-1
+ jy=int(yl)
+ if (yl.lt.0.) jy=jy-1
+
+ ! if (i.eq.10000) write(*,*) itime,xtra1(i),ytra1(i),ztra1(i),xl,yl
+
+
+ ! For particles aged less than 3 hours, attribute particle mass to grid cell
+ ! it resides in rather than use the kernel, in order to avoid its smoothing effect.
+ ! For older particles, use the uniform kernel.
+ ! If a particle is close to the domain boundary, do not use the kernel either.
+ !*****************************************************************************
+
+ if ((itage.lt.10800).or.(xl.lt.0.5).or.(yl.lt.0.5).or. &
+ (xl.gt.real(numxgrid-1)-0.5).or. &
+ (yl.gt.real(numygrid-1)-0.5)) then ! no kernel, direct attribution to grid cell
+ if ((ix.ge.0).and.(jy.ge.0).and.(ix.le.numxgrid-1).and. &
+ (jy.le.numygrid-1)) then
+ do ks=1,nspec
+ gridunc(ix,jy,kz,ks,nrelpointer,nclass(i),nage)= &
+ gridunc(ix,jy,kz,ks,nrelpointer,nclass(i),nage)+ &
+ xmass1(i,ks)/rhoi*weight
+ end do
+ endif
+
+ else ! attribution via uniform kernel
+
+ ddx=xl-real(ix) ! distance to left cell border
+ ddy=yl-real(jy) ! distance to lower cell border
+ if (ddx.gt.0.5) then
+ ixp=ix+1
+ wx=1.5-ddx
+ else
+ ixp=ix-1
+ wx=0.5+ddx
+ endif
+
+ if (ddy.gt.0.5) then
+ jyp=jy+1
+ wy=1.5-ddy
+ else
+ jyp=jy-1
+ wy=0.5+ddy
+ endif
+
+
+ ! Determine mass fractions for four grid points
+ !**********************************************
+
+ if ((ix.ge.0).and.(ix.le.numxgrid-1)) then
+ if ((jy.ge.0).and.(jy.le.numygrid-1)) then
+ w=wx*wy
+ do ks=1,nspec
+ gridunc(ix,jy,kz,ks,nrelpointer,nclass(i),nage)= &
+ gridunc(ix,jy,kz,ks,nrelpointer,nclass(i),nage)+ &
+ xmass1(i,ks)/rhoi*weight*w
+ end do
+ endif
+
+ if ((jyp.ge.0).and.(jyp.le.numygrid-1)) then
+ w=wx*(1.-wy)
+ do ks=1,nspec
+ gridunc(ix,jyp,kz,ks,nrelpointer,nclass(i),nage)= &
+ gridunc(ix,jyp,kz,ks,nrelpointer,nclass(i),nage)+ &
+ xmass1(i,ks)/rhoi*weight*w
+ end do
+ endif
+ endif
+
+
+ if ((ixp.ge.0).and.(ixp.le.numxgrid-1)) then
+ if ((jyp.ge.0).and.(jyp.le.numygrid-1)) then
+ w=(1.-wx)*(1.-wy)
+ do ks=1,nspec
+ gridunc(ixp,jyp,kz,ks,nrelpointer,nclass(i),nage)= &
+ gridunc(ixp,jyp,kz,ks,nrelpointer,nclass(i),nage)+ &
+ xmass1(i,ks)/rhoi*weight*w
+ end do
+ endif
+
+ if ((jy.ge.0).and.(jy.le.numygrid-1)) then
+ w=(1.-wx)*wy
+ do ks=1,nspec
+ gridunc(ixp,jy,kz,ks,nrelpointer,nclass(i),nage)= &
+ gridunc(ixp,jy,kz,ks,nrelpointer,nclass(i),nage)+ &
+ xmass1(i,ks)/rhoi*weight*w
+ end do
+ endif
+ endif
+ endif
+
+
+
+ !************************************
+ ! Do everything for the nested domain
+ !************************************
+
+ if (nested_output.eq.1) then
+ xl=(xtra1(i)*dx+xoutshiftn)/dxoutn
+ yl=(ytra1(i)*dy+youtshiftn)/dyoutn
+ ix=int(xl)
+ if (xl.lt.0.) ix=ix-1
+ jy=int(yl)
+ if (yl.lt.0.) jy=jy-1
+
+
+ ! For particles aged less than 3 hours, attribute particle mass to grid cell
+ ! it resides in rather than use the kernel, in order to avoid its smoothing effect.
+ ! For older particles, use the uniform kernel.
+ ! If a particle is close to the domain boundary, do not use the kernel either.
+ !*****************************************************************************
+
+ if ((itage.lt.10800).or.(xl.lt.0.5).or.(yl.lt.0.5).or. &
+ (xl.gt.real(numxgridn-1)-0.5).or. &
+ (yl.gt.real(numygridn-1)-0.5)) then ! no kernel, direct attribution to grid cell
+ if ((ix.ge.0).and.(jy.ge.0).and.(ix.le.numxgridn-1).and. &
+ (jy.le.numygridn-1)) then
+ do ks=1,nspec
+ griduncn(ix,jy,kz,ks,nrelpointer,nclass(i),nage)= &
+ griduncn(ix,jy,kz,ks,nrelpointer,nclass(i),nage)+ &
+ xmass1(i,ks)/rhoi*weight
+ end do
+ endif
+
+ else ! attribution via uniform kernel
+
+ ddx=xl-real(ix) ! distance to left cell border
+ ddy=yl-real(jy) ! distance to lower cell border
+ if (ddx.gt.0.5) then
+ ixp=ix+1
+ wx=1.5-ddx
+ else
+ ixp=ix-1
+ wx=0.5+ddx
+ endif
+
+ if (ddy.gt.0.5) then
+ jyp=jy+1
+ wy=1.5-ddy
+ else
+ jyp=jy-1
+ wy=0.5+ddy
+ endif
+
+
+ ! Determine mass fractions for four grid points
+ !**********************************************
+
+ if ((ix.ge.0).and.(ix.le.numxgridn-1)) then
+ if ((jy.ge.0).and.(jy.le.numygridn-1)) then
+ w=wx*wy
+ do ks=1,nspec
+ griduncn(ix,jy,kz,ks,nrelpointer,nclass(i),nage)= &
+ griduncn(ix,jy,kz,ks,nrelpointer,nclass(i),nage)+ &
+ xmass1(i,ks)/rhoi*weight*w
+ end do
+ endif
+
+ if ((jyp.ge.0).and.(jyp.le.numygridn-1)) then
+ w=wx*(1.-wy)
+ do ks=1,nspec
+ griduncn(ix,jyp,kz,ks,nrelpointer,nclass(i),nage)= &
+ griduncn(ix,jyp,kz,ks,nrelpointer,nclass(i),nage)+ &
+ xmass1(i,ks)/rhoi*weight*w
+ end do
+ endif
+ endif
+
+
+ if ((ixp.ge.0).and.(ixp.le.numxgridn-1)) then
+ if ((jyp.ge.0).and.(jyp.le.numygridn-1)) then
+ w=(1.-wx)*(1.-wy)
+ do ks=1,nspec
+ griduncn(ixp,jyp,kz,ks,nrelpointer,nclass(i),nage)= &
+ griduncn(ixp,jyp,kz,ks,nrelpointer,nclass(i),nage)+ &
+ xmass1(i,ks)/rhoi*weight*w
+ end do
+ endif
+
+ if ((jy.ge.0).and.(jy.le.numygridn-1)) then
+ w=(1.-wx)*wy
+ do ks=1,nspec
+ griduncn(ixp,jy,kz,ks,nrelpointer,nclass(i),nage)= &
+ griduncn(ixp,jy,kz,ks,nrelpointer,nclass(i),nage)+ &
+ xmass1(i,ks)/rhoi*weight*w
+ end do
+ endif
+ endif
+ endif
+
+ endif
+ endif
+20 continue
+ end do
+
+ !***********************************************************************
+ ! 2. Evaluate concentrations at receptor points, using the kernel method
+ !***********************************************************************
+
+ do n=1,numreceptor
+
+
+ ! Reset concentrations
+ !*********************
+
+ do ks=1,nspec
+ c(ks)=0.
+ end do
+
+
+ ! Estimate concentration at receptor
+ !***********************************
+
+ do i=1,numpart
+
+ if (itra1(i).ne.itime) goto 40
+ itage=abs(itra1(i)-itramem(i))
+
+ hz=min(50.+0.3*sqrt(real(itage)),hzmax)
+ zd=ztra1(i)/hz
+ if (zd.gt.1.) goto 40 ! save computing time, leave loop
+
+ hx=min((0.29+2.222e-3*sqrt(real(itage)))*dx+ &
+ real(itage)*1.2e-5,hxmax) ! 80 km/day
+ xd=(xtra1(i)-xreceptor(n))/hx
+ if (xd*xd.gt.1.) goto 40 ! save computing time, leave loop
+
+ hy=min((0.18+1.389e-3*sqrt(real(itage)))*dy+ &
+ real(itage)*7.5e-6,hymax) ! 80 km/day
+ yd=(ytra1(i)-yreceptor(n))/hy
+ if (yd*yd.gt.1.) goto 40 ! save computing time, leave loop
+ h=hx*hy*hz
+
+ r2=xd*xd+yd*yd+zd*zd
+ if (r2.lt.1.) then
+ xkern=factor*(1.-r2)
+ do ks=1,nspec
+ c(ks)=c(ks)+xmass1(i,ks)*xkern/h
+ end do
+ endif
+40 continue
+ end do
+
+ do ks=1,nspec
+ creceptor(n,ks)=creceptor(n,ks)+2.*weight*c(ks)/receptorarea(n)
+ end do
+ end do
+
+end subroutine conccalc
diff --git a/src/concoutput.f90 b/src/concoutput.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d8ac114d8f2eba4a98334aedebf4abb5d4de24f4
--- /dev/null
+++ b/src/concoutput.f90
@@ -0,0 +1,610 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine concoutput(itime,outnum,gridtotalunc,wetgridtotalunc, &
+ drygridtotalunc)
+ ! i i o o
+ ! o
+ !*****************************************************************************
+ ! *
+ ! Output of the concentration grid and the receptor concentrations. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 24 May 1995 *
+ ! *
+ ! 13 April 1999, Major update: if output size is smaller, dump output *
+ ! in sparse matrix format; additional output of *
+ ! uncertainty *
+ ! *
+ ! 05 April 2000, Major update: output of age classes; output for backward*
+ ! runs is time spent in grid cell times total mass of *
+ ! species. *
+ ! *
+ ! 17 February 2002, Appropriate dimensions for backward and forward runs *
+ ! are now specified in file par_mod *
+ ! *
+ ! June 2006, write grid in sparse matrix with a single write command *
+ ! in order to save disk space *
+ ! *
+ ! 2008 new sparse matrix format *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! outnum number of samples *
+ ! ncells number of cells with non-zero concentrations *
+ ! sparse .true. if in sparse matrix format, else .false. *
+ ! tot_mu 1 for forward, initial mass mixing ration for backw. runs *
+ ! *
+ !*****************************************************************************
+
+ use unc_mod
+ use point_mod
+ use outg_mod
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ real(kind=dp) :: jul
+ integer :: itime,i,ix,jy,kz,ks,kp,l,iix,jjy,kzz,nage,jjjjmmdd,ihmmss
+ integer :: sp_count_i,sp_count_r
+ real :: sp_fact
+ real :: outnum,densityoutrecept(maxreceptor),xl,yl
+
+ !real densityoutgrid(0:numxgrid-1,0:numygrid-1,numzgrid),
+ ! +grid(0:numxgrid-1,0:numygrid-1,numzgrid,maxspec,maxpointspec_act,
+ ! + maxageclass)
+ !real wetgrid(0:numxgrid-1,0:numygrid-1,maxspec,maxpointspec_act,
+ ! + maxageclass)
+ !real drygrid(0:numxgrid-1,0:numygrid-1,maxspec,
+ ! + maxpointspec_act,maxageclass)
+ !real gridsigma(0:numxgrid-1,0:numygrid-1,numzgrid,maxspec,
+ ! + maxpointspec_act,maxageclass),
+ ! + drygridsigma(0:numxgrid-1,0:numygrid-1,maxspec,
+ ! + maxpointspec_act,maxageclass),
+ ! + wetgridsigma(0:numxgrid-1,0:numygrid-1,maxspec,
+ ! + maxpointspec_act,maxageclass)
+ !real factor(0:numxgrid-1,0:numygrid-1,numzgrid)
+ !real sparse_dump_r(numxgrid*numygrid*numzgrid)
+ !integer sparse_dump_i(numxgrid*numygrid*numzgrid)
+
+ !real sparse_dump_u(numxgrid*numygrid*numzgrid)
+ real :: auxgrid(nclassunc),gridtotal,gridsigmatotal,gridtotalunc
+ real :: wetgridtotal,wetgridsigmatotal,wetgridtotalunc
+ real :: drygridtotal,drygridsigmatotal,drygridtotalunc
+ real :: halfheight,dz,dz1,dz2,tot_mu(maxspec,maxpointspec_act)
+ real,parameter :: smallnum = tiny(0.0) ! smallest number that can be handled
+ real,parameter :: weightair=28.97
+ logical :: sp_zer
+ character :: adate*8,atime*6
+ character(len=3) :: anspec
+
+
+ ! Determine current calendar date, needed for the file name
+ !**********************************************************
+
+ jul=bdate+real(itime,kind=dp)/86400._dp
+ call caldate(jul,jjjjmmdd,ihmmss)
+ write(adate,'(i8.8)') jjjjmmdd
+ write(atime,'(i6.6)') ihmmss
+ open(unitdates,file=path(2)(1:length(2))//'dates', ACCESS='APPEND')
+ write(unitdates,'(a)') adate//atime
+ close(unitdates)
+
+ ! For forward simulations, output fields have dimension MAXSPEC,
+ ! for backward simulations, output fields have dimension MAXPOINT.
+ ! Thus, make loops either about nspec, or about numpoint
+ !*****************************************************************
+
+
+ if (ldirect.eq.1) then
+ do ks=1,nspec
+ do kp=1,maxpointspec_act
+ tot_mu(ks,kp)=1
+ end do
+ end do
+ else
+ do ks=1,nspec
+ do kp=1,maxpointspec_act
+ tot_mu(ks,kp)=xmass(kp,ks)
+ end do
+ end do
+ endif
+
+
+ !*******************************************************************
+ ! Compute air density: sufficiently accurate to take it
+ ! from coarse grid at some time
+ ! Determine center altitude of output layer, and interpolate density
+ ! data to that altitude
+ !*******************************************************************
+
+ do kz=1,numzgrid
+ if (kz.eq.1) then
+ halfheight=outheight(1)/2.
+ else
+ halfheight=(outheight(kz)+outheight(kz-1))/2.
+ endif
+ do kzz=2,nz
+ if ((height(kzz-1).lt.halfheight).and. &
+ (height(kzz).gt.halfheight)) goto 46
+ end do
+46 kzz=max(min(kzz,nz),2)
+ dz1=halfheight-height(kzz-1)
+ dz2=height(kzz)-halfheight
+ dz=dz1+dz2
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ xl=outlon0+real(ix)*dxout
+ yl=outlat0+real(jy)*dyout
+ xl=(xl-xlon0)/dx
+ yl=(yl-ylat0)/dy !v9.1.1
+ iix=max(min(nint(xl),nxmin1),0)
+ jjy=max(min(nint(yl),nymin1),0)
+ densityoutgrid(ix,jy,kz)=(rho(iix,jjy,kzz,2)*dz1+ &
+ rho(iix,jjy,kzz-1,2)*dz2)/dz
+ end do
+ end do
+ end do
+
+ do i=1,numreceptor
+ xl=xreceptor(i)
+ yl=yreceptor(i)
+ iix=max(min(nint(xl),nxmin1),0)
+ jjy=max(min(nint(yl),nymin1),0)
+ densityoutrecept(i)=rho(iix,jjy,1,2)
+ end do
+
+
+ ! Output is different for forward and backward simulations
+ do kz=1,numzgrid
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (ldirect.eq.1) then
+ factor3d(ix,jy,kz)=1.e12/volume(ix,jy,kz)/outnum
+ else
+ factor3d(ix,jy,kz)=real(abs(loutaver))/outnum
+ endif
+ end do
+ end do
+ end do
+
+ !*********************************************************************
+ ! Determine the standard deviation of the mean concentration or mixing
+ ! ratio (uncertainty of the output) and the dry and wet deposition
+ !*********************************************************************
+
+ gridtotal=0.
+ gridsigmatotal=0.
+ gridtotalunc=0.
+ wetgridtotal=0.
+ wetgridsigmatotal=0.
+ wetgridtotalunc=0.
+ drygridtotal=0.
+ drygridsigmatotal=0.
+ drygridtotalunc=0.
+
+ do ks=1,nspec
+
+ write(anspec,'(i3.3)') ks
+ if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then
+ if (ldirect.eq.1) then
+ open(unitoutgrid,file=path(2)(1:length(2))//'grid_conc_'//adate// &
+ atime//'_'//anspec,form='unformatted')
+ else
+ open(unitoutgrid,file=path(2)(1:length(2))//'grid_time_'//adate// &
+ atime//'_'//anspec,form='unformatted')
+ endif
+ write(unitoutgrid) itime
+ endif
+
+ if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio
+ open(unitoutgridppt,file=path(2)(1:length(2))//'grid_pptv_'//adate// &
+ atime//'_'//anspec,form='unformatted')
+
+ write(unitoutgridppt) itime
+ endif
+
+ do kp=1,maxpointspec_act
+ do nage=1,nageclass
+
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+
+ ! WET DEPOSITION
+ if ((WETDEP).and.(ldirect.gt.0)) then
+ do l=1,nclassunc
+ auxgrid(l)=wetgridunc(ix,jy,ks,kp,l,nage)
+ end do
+ call mean(auxgrid,wetgrid(ix,jy), &
+ wetgridsigma(ix,jy),nclassunc)
+ ! Multiply by number of classes to get total concentration
+ wetgrid(ix,jy)=wetgrid(ix,jy) &
+ *nclassunc
+ wetgridtotal=wetgridtotal+wetgrid(ix,jy)
+ ! Calculate standard deviation of the mean
+ wetgridsigma(ix,jy)= &
+ wetgridsigma(ix,jy)* &
+ sqrt(real(nclassunc))
+ wetgridsigmatotal=wetgridsigmatotal+ &
+ wetgridsigma(ix,jy)
+ endif
+
+ ! DRY DEPOSITION
+ if ((DRYDEP).and.(ldirect.gt.0)) then
+ do l=1,nclassunc
+ auxgrid(l)=drygridunc(ix,jy,ks,kp,l,nage)
+ end do
+ call mean(auxgrid,drygrid(ix,jy), &
+ drygridsigma(ix,jy),nclassunc)
+ ! Multiply by number of classes to get total concentration
+ drygrid(ix,jy)=drygrid(ix,jy)* &
+ nclassunc
+ drygridtotal=drygridtotal+drygrid(ix,jy)
+ ! Calculate standard deviation of the mean
+ drygridsigma(ix,jy)= &
+ drygridsigma(ix,jy)* &
+ sqrt(real(nclassunc))
+125 drygridsigmatotal=drygridsigmatotal+ &
+ drygridsigma(ix,jy)
+ endif
+
+ ! CONCENTRATION OR MIXING RATIO
+ do kz=1,numzgrid
+ do l=1,nclassunc
+ auxgrid(l)=gridunc(ix,jy,kz,ks,kp,l,nage)
+ end do
+ call mean(auxgrid,grid(ix,jy,kz), &
+ gridsigma(ix,jy,kz),nclassunc)
+ ! Multiply by number of classes to get total concentration
+ grid(ix,jy,kz)= &
+ grid(ix,jy,kz)*nclassunc
+ gridtotal=gridtotal+grid(ix,jy,kz)
+ ! Calculate standard deviation of the mean
+ gridsigma(ix,jy,kz)= &
+ gridsigma(ix,jy,kz)* &
+ sqrt(real(nclassunc))
+ gridsigmatotal=gridsigmatotal+ &
+ gridsigma(ix,jy,kz)
+ end do
+ end do
+ end do
+
+
+
+
+ !*******************************************************************
+ ! Generate output: may be in concentration (ng/m3) or in mixing
+ ! ratio (ppt) or both
+ ! Output the position and the values alternated multiplied by
+ ! 1 or -1, first line is number of values, number of positions
+ ! For backward simulations, the unit is seconds, stored in grid_time
+ !*******************************************************************
+
+ ! Concentration output
+ !*********************
+ if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then
+
+ ! Wet deposition
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ if ((ldirect.eq.1).and.(WETDEP)) then
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ !oncentraion greater zero
+ if (wetgrid(ix,jy).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)=ix+jy*numxgrid
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact*1.e12*wetgrid(ix,jy)/area(ix,jy)
+ ! sparse_dump_u(sp_count_r)=
+ !+ 1.e12*wetgridsigma(ix,jy,ks,kp,nage)/area(ix,jy)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ else
+ sp_count_i=0
+ sp_count_r=0
+ endif
+ write(unitoutgrid) sp_count_i
+ write(unitoutgrid) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgrid) sp_count_r
+ write(unitoutgrid) (sparse_dump_r(i),i=1,sp_count_r)
+ ! write(unitoutgrid) sp_count_u
+ ! write(unitoutgrid) (sparse_dump_u(i),i=1,sp_count_r)
+
+ ! Dry deposition
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ if ((ldirect.eq.1).and.(DRYDEP)) then
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (drygrid(ix,jy).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)=ix+jy*numxgrid
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ 1.e12*drygrid(ix,jy)/area(ix,jy)
+ ! sparse_dump_u(sp_count_r)=
+ !+ 1.e12*drygridsigma(ix,jy,ks,kp,nage)/area(ix,jy)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ else
+ sp_count_i=0
+ sp_count_r=0
+ endif
+ write(unitoutgrid) sp_count_i
+ write(unitoutgrid) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgrid) sp_count_r
+ write(unitoutgrid) (sparse_dump_r(i),i=1,sp_count_r)
+ ! write(*,*) sp_count_u
+ ! write(unitoutgrid) (sparse_dump_u(i),i=1,sp_count_r)
+
+
+
+ ! Concentrations
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ do kz=1,numzgrid
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (grid(ix,jy,kz).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgrid+kz*numxgrid*numygrid
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ grid(ix,jy,kz)* &
+ factor3d(ix,jy,kz)/tot_mu(ks,kp)
+ ! if ((factor(ix,jy,kz)/tot_mu(ks,kp)).eq.0)
+ ! + write (*,*) factor(ix,jy,kz),tot_mu(ks,kp),ks,kp
+ ! sparse_dump_u(sp_count_r)=
+ !+ ,gridsigma(ix,jy,kz,ks,kp,nage)*
+ !+ factor(ix,jy,kz)/tot_mu(ks,kp)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ end do
+ write(unitoutgrid) sp_count_i
+ write(unitoutgrid) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgrid) sp_count_r
+ write(unitoutgrid) (sparse_dump_r(i),i=1,sp_count_r)
+ ! write(unitoutgrid) sp_count_u
+ ! write(unitoutgrid) (sparse_dump_u(i),i=1,sp_count_r)
+
+
+
+ endif ! concentration output
+
+ ! Mixing ratio output
+ !********************
+
+ if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio
+
+ ! Wet deposition
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ if ((ldirect.eq.1).and.(WETDEP)) then
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (wetgrid(ix,jy).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgrid
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ 1.e12*wetgrid(ix,jy)/area(ix,jy)
+ ! sparse_dump_u(sp_count_r)=
+ ! + ,1.e12*wetgridsigma(ix,jy,ks,kp,nage)/area(ix,jy)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ else
+ sp_count_i=0
+ sp_count_r=0
+ endif
+ write(unitoutgridppt) sp_count_i
+ write(unitoutgridppt) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgridppt) sp_count_r
+ write(unitoutgridppt) (sparse_dump_r(i),i=1,sp_count_r)
+ ! write(unitoutgridppt) sp_count_u
+ ! write(unitoutgridppt) (sparse_dump_u(i),i=1,sp_count_r)
+
+
+ ! Dry deposition
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ if ((ldirect.eq.1).and.(DRYDEP)) then
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (drygrid(ix,jy).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgrid
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ 1.e12*drygrid(ix,jy)/area(ix,jy)
+ ! sparse_dump_u(sp_count_r)=
+ ! + ,1.e12*drygridsigma(ix,jy,ks,kp,nage)/area(ix,jy)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ else
+ sp_count_i=0
+ sp_count_r=0
+ endif
+ write(unitoutgridppt) sp_count_i
+ write(unitoutgridppt) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgridppt) sp_count_r
+ write(unitoutgridppt) (sparse_dump_r(i),i=1,sp_count_r)
+ ! write(unitoutgridppt) sp_count_u
+ ! write(unitoutgridppt) (sparse_dump_u(i),i=1,sp_count_r)
+
+
+ ! Mixing ratios
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ do kz=1,numzgrid
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (grid(ix,jy,kz).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgrid+kz*numxgrid*numygrid
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ 1.e12*grid(ix,jy,kz) &
+ /volume(ix,jy,kz)/outnum* &
+ weightair/weightmolar(ks)/densityoutgrid(ix,jy,kz)
+ ! sparse_dump_u(sp_count_r)=
+ !+ ,1.e12*gridsigma(ix,jy,kz,ks,kp,nage)/volume(ix,jy,kz)/
+ !+ outnum*weightair/weightmolar(ks)/
+ !+ densityoutgrid(ix,jy,kz)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ end do
+ write(unitoutgridppt) sp_count_i
+ write(unitoutgridppt) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgridppt) sp_count_r
+ write(unitoutgridppt) (sparse_dump_r(i),i=1,sp_count_r)
+ ! write(unitoutgridppt) sp_count_u
+ ! write(unitoutgridppt) (sparse_dump_u(i),i=1,sp_count_r)
+
+ endif ! output for ppt
+
+ end do
+ end do
+
+ close(unitoutgridppt)
+ close(unitoutgrid)
+
+ end do
+
+ if (gridtotal.gt.0.) gridtotalunc=gridsigmatotal/gridtotal
+ if (wetgridtotal.gt.0.) wetgridtotalunc=wetgridsigmatotal/ &
+ wetgridtotal
+ if (drygridtotal.gt.0.) drygridtotalunc=drygridsigmatotal/ &
+ drygridtotal
+
+ ! Dump of receptor concentrations
+
+ if (numreceptor.gt.0 .and. (iout.eq.2 .or. iout.eq.3) ) then
+ write(unitoutreceptppt) itime
+ do ks=1,nspec
+ write(unitoutreceptppt) (1.e12*creceptor(i,ks)/outnum* &
+ weightair/weightmolar(ks)/densityoutrecept(i),i=1,numreceptor)
+ end do
+ endif
+
+ ! Dump of receptor concentrations
+
+ if (numreceptor.gt.0) then
+ write(unitoutrecept) itime
+ do ks=1,nspec
+ write(unitoutrecept) (1.e12*creceptor(i,ks)/outnum, &
+ i=1,numreceptor)
+ end do
+ endif
+
+
+
+ ! Reinitialization of grid
+ !*************************
+
+ do ks=1,nspec
+ do kp=1,maxpointspec_act
+ do i=1,numreceptor
+ creceptor(i,ks)=0.
+ end do
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ do l=1,nclassunc
+ do nage=1,nageclass
+ do kz=1,numzgrid
+ gridunc(ix,jy,kz,ks,kp,l,nage)=0.
+ end do
+ end do
+ end do
+ end do
+ end do
+ end do
+ end do
+
+
+end subroutine concoutput
diff --git a/src/concoutput_nest.f90 b/src/concoutput_nest.f90
new file mode 100644
index 0000000000000000000000000000000000000000..f5e0a555b31d247f2fe4904c0a71d60a3f70cd05
--- /dev/null
+++ b/src/concoutput_nest.f90
@@ -0,0 +1,561 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine concoutput_nest(itime,outnum)
+ ! i i
+ !*****************************************************************************
+ ! *
+ ! Output of the concentration grid and the receptor concentrations. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 24 May 1995 *
+ ! *
+ ! 13 April 1999, Major update: if output size is smaller, dump output *
+ ! in sparse matrix format; additional output of *
+ ! uncertainty *
+ ! *
+ ! 05 April 2000, Major update: output of age classes; output for backward*
+ ! runs is time spent in grid cell times total mass of *
+ ! species. *
+ ! *
+ ! 17 February 2002, Appropriate dimensions for backward and forward runs *
+ ! are now specified in file par_mod *
+ ! *
+ ! June 2006, write grid in sparse matrix with a single write command *
+ ! in order to save disk space *
+ ! *
+ ! 2008 new sparse matrix format *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! outnum number of samples *
+ ! ncells number of cells with non-zero concentrations *
+ ! sparse .true. if in sparse matrix format, else .false. *
+ ! tot_mu 1 for forward, initial mass mixing ration for backw. runs *
+ ! *
+ !*****************************************************************************
+
+ use unc_mod
+ use point_mod
+ use outg_mod
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ real(kind=dp) :: jul
+ integer :: itime,i,ix,jy,kz,ks,kp,l,iix,jjy,kzz,nage,jjjjmmdd,ihmmss
+ integer :: sp_count_i,sp_count_r
+ real :: sp_fact
+ real :: outnum,densityoutrecept(maxreceptor),xl,yl
+
+ !real densityoutgrid(0:numxgrid-1,0:numygrid-1,numzgrid),
+ ! +grid(0:numxgrid-1,0:numygrid-1,numzgrid,maxspec,maxpointspec_act,
+ ! + maxageclass)
+ !real wetgrid(0:numxgrid-1,0:numygrid-1,maxspec,maxpointspec_act,
+ ! + maxageclass)
+ !real drygrid(0:numxgrid-1,0:numygrid-1,maxspec,
+ ! + maxpointspec_act,maxageclass)
+ !real gridsigma(0:numxgrid-1,0:numygrid-1,numzgrid,maxspec,
+ ! + maxpointspec_act,maxageclass),
+ ! + drygridsigma(0:numxgrid-1,0:numygrid-1,maxspec,
+ ! + maxpointspec_act,maxageclass),
+ ! + wetgridsigma(0:numxgrid-1,0:numygrid-1,maxspec,
+ ! + maxpointspec_act,maxageclass)
+ !real factor(0:numxgrid-1,0:numygrid-1,numzgrid)
+ !real sparse_dump_r(numxgrid*numygrid*numzgrid)
+ !integer sparse_dump_i(numxgrid*numygrid*numzgrid)
+
+ !real sparse_dump_u(numxgrid*numygrid*numzgrid)
+ real :: auxgrid(nclassunc)
+ real :: halfheight,dz,dz1,dz2,tot_mu(maxspec,maxpointspec_act)
+ real,parameter :: smallnum = tiny(0.0) ! smallest number that can be handled
+ real,parameter :: weightair=28.97
+ logical :: sp_zer
+ character :: adate*8,atime*6
+ character(len=3) :: anspec
+
+
+ ! Determine current calendar date, needed for the file name
+ !**********************************************************
+
+ jul=bdate+real(itime,kind=dp)/86400._dp
+ call caldate(jul,jjjjmmdd,ihmmss)
+ write(adate,'(i8.8)') jjjjmmdd
+ write(atime,'(i6.6)') ihmmss
+
+
+ ! For forward simulations, output fields have dimension MAXSPEC,
+ ! for backward simulations, output fields have dimension MAXPOINT.
+ ! Thus, make loops either about nspec, or about numpoint
+ !*****************************************************************
+
+
+ if (ldirect.eq.1) then
+ do ks=1,nspec
+ do kp=1,maxpointspec_act
+ tot_mu(ks,kp)=1
+ end do
+ end do
+ else
+ do ks=1,nspec
+ do kp=1,maxpointspec_act
+ tot_mu(ks,kp)=xmass(kp,ks)
+ end do
+ end do
+ endif
+
+
+ !*******************************************************************
+ ! Compute air density: sufficiently accurate to take it
+ ! from coarse grid at some time
+ ! Determine center altitude of output layer, and interpolate density
+ ! data to that altitude
+ !*******************************************************************
+
+ do kz=1,numzgrid
+ if (kz.eq.1) then
+ halfheight=outheight(1)/2.
+ else
+ halfheight=(outheight(kz)+outheight(kz-1))/2.
+ endif
+ do kzz=2,nz
+ if ((height(kzz-1).lt.halfheight).and. &
+ (height(kzz).gt.halfheight)) goto 46
+ end do
+46 kzz=max(min(kzz,nz),2)
+ dz1=halfheight-height(kzz-1)
+ dz2=height(kzz)-halfheight
+ dz=dz1+dz2
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ xl=outlon0n+real(ix)*dxoutn
+ yl=outlat0n+real(jy)*dyoutn
+ xl=(xl-xlon0)/dx
+ yl=(yl-ylat0)/dy
+ iix=max(min(nint(xl),nxmin1),0)
+ jjy=max(min(nint(yl),nymin1),0)
+ densityoutgrid(ix,jy,kz)=(rho(iix,jjy,kzz,2)*dz1+ &
+ rho(iix,jjy,kzz-1,2)*dz2)/dz
+ end do
+ end do
+ end do
+
+ do i=1,numreceptor
+ xl=xreceptor(i)
+ yl=yreceptor(i)
+ iix=max(min(nint(xl),nxmin1),0)
+ jjy=max(min(nint(yl),nymin1),0)
+ densityoutrecept(i)=rho(iix,jjy,1,2)
+ end do
+
+
+ ! Output is different for forward and backward simulations
+ do kz=1,numzgrid
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ if (ldirect.eq.1) then
+ factor3d(ix,jy,kz)=1.e12/volumen(ix,jy,kz)/outnum
+ else
+ factor3d(ix,jy,kz)=real(abs(loutaver))/outnum
+ endif
+ end do
+ end do
+ end do
+
+ !*********************************************************************
+ ! Determine the standard deviation of the mean concentration or mixing
+ ! ratio (uncertainty of the output) and the dry and wet deposition
+ !*********************************************************************
+
+ do ks=1,nspec
+
+ write(anspec,'(i3.3)') ks
+ if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then
+ if (ldirect.eq.1) then
+ open(unitoutgrid,file=path(2)(1:length(2))//'grid_conc_nest_' &
+ //adate// &
+ atime//'_'//anspec,form='unformatted')
+ else
+ open(unitoutgrid,file=path(2)(1:length(2))//'grid_time_nest_' &
+ //adate// &
+ atime//'_'//anspec,form='unformatted')
+ endif
+ write(unitoutgrid) itime
+ endif
+
+ if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio
+ open(unitoutgridppt,file=path(2)(1:length(2))//'grid_pptv_nest_' &
+ //adate// &
+ atime//'_'//anspec,form='unformatted')
+
+ write(unitoutgridppt) itime
+ endif
+
+ do kp=1,maxpointspec_act
+ do nage=1,nageclass
+
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+
+ ! WET DEPOSITION
+ if ((WETDEP).and.(ldirect.gt.0)) then
+ do l=1,nclassunc
+ auxgrid(l)=wetgriduncn(ix,jy,ks,kp,l,nage)
+ end do
+ call mean(auxgrid,wetgrid(ix,jy), &
+ wetgridsigma(ix,jy),nclassunc)
+ ! Multiply by number of classes to get total concentration
+ wetgrid(ix,jy)=wetgrid(ix,jy) &
+ *nclassunc
+ ! Calculate standard deviation of the mean
+ wetgridsigma(ix,jy)= &
+ wetgridsigma(ix,jy)* &
+ sqrt(real(nclassunc))
+ endif
+
+ ! DRY DEPOSITION
+ if ((DRYDEP).and.(ldirect.gt.0)) then
+ do l=1,nclassunc
+ auxgrid(l)=drygriduncn(ix,jy,ks,kp,l,nage)
+ end do
+ call mean(auxgrid,drygrid(ix,jy), &
+ drygridsigma(ix,jy),nclassunc)
+ ! Multiply by number of classes to get total concentration
+ drygrid(ix,jy)=drygrid(ix,jy)* &
+ nclassunc
+ ! Calculate standard deviation of the mean
+ drygridsigma(ix,jy)= &
+ drygridsigma(ix,jy)* &
+ sqrt(real(nclassunc))
+ endif
+
+ ! CONCENTRATION OR MIXING RATIO
+ do kz=1,numzgrid
+ do l=1,nclassunc
+ auxgrid(l)=griduncn(ix,jy,kz,ks,kp,l,nage)
+ end do
+ call mean(auxgrid,grid(ix,jy,kz), &
+ gridsigma(ix,jy,kz),nclassunc)
+ ! Multiply by number of classes to get total concentration
+ grid(ix,jy,kz)= &
+ grid(ix,jy,kz)*nclassunc
+ ! Calculate standard deviation of the mean
+ gridsigma(ix,jy,kz)= &
+ gridsigma(ix,jy,kz)* &
+ sqrt(real(nclassunc))
+ end do
+ end do
+ end do
+
+
+ !*******************************************************************
+ ! Generate output: may be in concentration (ng/m3) or in mixing
+ ! ratio (ppt) or both
+ ! Output the position and the values alternated multiplied by
+ ! 1 or -1, first line is number of values, number of positions
+ ! For backward simulations, the unit is seconds, stored in grid_time
+ !*******************************************************************
+
+ ! Concentration output
+ !*********************
+ if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then
+
+ ! Wet deposition
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ if ((ldirect.eq.1).and.(WETDEP)) then
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ !oncentraion greater zero
+ if (wetgrid(ix,jy).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)=ix+jy*numxgridn
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact*1.e12*wetgrid(ix,jy)/arean(ix,jy)
+ ! sparse_dump_u(sp_count_r)=
+ !+ 1.e12*wetgridsigma(ix,jy,ks,kp,nage)/area(ix,jy)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ else
+ sp_count_i=0
+ sp_count_r=0
+ endif
+ write(unitoutgrid) sp_count_i
+ write(unitoutgrid) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgrid) sp_count_r
+ write(unitoutgrid) (sparse_dump_r(i),i=1,sp_count_r)
+ ! write(unitoutgrid) sp_count_u
+ ! write(unitoutgrid) (sparse_dump_u(i),i=1,sp_count_r)
+
+ ! Dry deposition
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ if ((ldirect.eq.1).and.(DRYDEP)) then
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ if (drygrid(ix,jy).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)=ix+jy*numxgridn
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ 1.e12*drygrid(ix,jy)/arean(ix,jy)
+ ! sparse_dump_u(sp_count_r)=
+ !+ 1.e12*drygridsigma(ix,jy,ks,kp,nage)/area(ix,jy)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ else
+ sp_count_i=0
+ sp_count_r=0
+ endif
+ write(unitoutgrid) sp_count_i
+ write(unitoutgrid) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgrid) sp_count_r
+ write(unitoutgrid) (sparse_dump_r(i),i=1,sp_count_r)
+ ! write(*,*) sp_count_u
+ ! write(unitoutgrid) (sparse_dump_u(i),i=1,sp_count_r)
+
+
+
+ ! Concentrations
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ do kz=1,numzgrid
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ if (grid(ix,jy,kz).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgridn+kz*numxgridn*numygridn
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ grid(ix,jy,kz)* &
+ factor3d(ix,jy,kz)/tot_mu(ks,kp)
+ ! if ((factor(ix,jy,kz)/tot_mu(ks,kp)).eq.0)
+ ! + write (*,*) factor(ix,jy,kz),tot_mu(ks,kp),ks,kp
+ ! sparse_dump_u(sp_count_r)=
+ !+ ,gridsigma(ix,jy,kz,ks,kp,nage)*
+ !+ factor(ix,jy,kz)/tot_mu(ks,kp)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ end do
+ write(unitoutgrid) sp_count_i
+ write(unitoutgrid) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgrid) sp_count_r
+ write(unitoutgrid) (sparse_dump_r(i),i=1,sp_count_r)
+ ! write(unitoutgrid) sp_count_u
+ ! write(unitoutgrid) (sparse_dump_u(i),i=1,sp_count_r)
+
+
+
+ endif ! concentration output
+
+ ! Mixing ratio output
+ !********************
+
+ if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio
+
+ ! Wet deposition
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ if ((ldirect.eq.1).and.(WETDEP)) then
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ if (wetgrid(ix,jy).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgridn
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ 1.e12*wetgrid(ix,jy)/arean(ix,jy)
+ ! sparse_dump_u(sp_count_r)=
+ ! + ,1.e12*wetgridsigma(ix,jy,ks,kp,nage)/area(ix,jy)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ else
+ sp_count_i=0
+ sp_count_r=0
+ endif
+ write(unitoutgridppt) sp_count_i
+ write(unitoutgridppt) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgridppt) sp_count_r
+ write(unitoutgridppt) (sparse_dump_r(i),i=1,sp_count_r)
+ ! write(unitoutgridppt) sp_count_u
+ ! write(unitoutgridppt) (sparse_dump_u(i),i=1,sp_count_r)
+
+
+ ! Dry deposition
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ if ((ldirect.eq.1).and.(DRYDEP)) then
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ if (drygrid(ix,jy).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgridn
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ 1.e12*drygrid(ix,jy)/arean(ix,jy)
+ ! sparse_dump_u(sp_count_r)=
+ ! + ,1.e12*drygridsigma(ix,jy,ks,kp,nage)/area(ix,jy)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ else
+ sp_count_i=0
+ sp_count_r=0
+ endif
+ write(unitoutgridppt) sp_count_i
+ write(unitoutgridppt) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgridppt) sp_count_r
+ write(unitoutgridppt) (sparse_dump_r(i),i=1,sp_count_r)
+ ! write(unitoutgridppt) sp_count_u
+ ! write(unitoutgridppt) (sparse_dump_u(i),i=1,sp_count_r)
+
+
+ ! Mixing ratios
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ do kz=1,numzgrid
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ if (grid(ix,jy,kz).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgridn+kz*numxgridn*numygridn
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ 1.e12*grid(ix,jy,kz) &
+ /volumen(ix,jy,kz)/outnum* &
+ weightair/weightmolar(ks)/densityoutgrid(ix,jy,kz)
+ ! sparse_dump_u(sp_count_r)=
+ !+ ,1.e12*gridsigma(ix,jy,kz,ks,kp,nage)/volume(ix,jy,kz)/
+ !+ outnum*weightair/weightmolar(ks)/
+ !+ densityoutgrid(ix,jy,kz)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ end do
+ write(unitoutgridppt) sp_count_i
+ write(unitoutgridppt) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgridppt) sp_count_r
+ write(unitoutgridppt) (sparse_dump_r(i),i=1,sp_count_r)
+ ! write(unitoutgridppt) sp_count_u
+ ! write(unitoutgridppt) (sparse_dump_u(i),i=1,sp_count_r)
+
+ endif ! output for ppt
+
+ end do
+ end do
+
+ close(unitoutgridppt)
+ close(unitoutgrid)
+
+ end do
+
+
+
+ ! Reinitialization of grid
+ !*************************
+
+ do ks=1,nspec
+ do kp=1,maxpointspec_act
+ do i=1,numreceptor
+ creceptor(i,ks)=0.
+ end do
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ do l=1,nclassunc
+ do nage=1,nageclass
+ do kz=1,numzgrid
+ griduncn(ix,jy,kz,ks,kp,l,nage)=0.
+ end do
+ end do
+ end do
+ end do
+ end do
+ end do
+ end do
+
+
+end subroutine concoutput_nest
+
diff --git a/src/concoutput_surf.f90 b/src/concoutput_surf.f90
new file mode 100644
index 0000000000000000000000000000000000000000..f390e9a686093d785329c758371010c415aabf30
--- /dev/null
+++ b/src/concoutput_surf.f90
@@ -0,0 +1,744 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine concoutput_surf(itime,outnum,gridtotalunc,wetgridtotalunc, &
+ drygridtotalunc)
+ ! i i o o
+ ! o
+ !*****************************************************************************
+ ! *
+ ! Output of the concentration grid and the receptor concentrations. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 24 May 1995 *
+ ! *
+ ! 13 April 1999, Major update: if output size is smaller, dump output *
+ ! in sparse matrix format; additional output of *
+ ! uncertainty *
+ ! *
+ ! 05 April 2000, Major update: output of age classes; output for backward*
+ ! runs is time spent in grid cell times total mass of *
+ ! species. *
+ ! *
+ ! 17 February 2002, Appropriate dimensions for backward and forward runs *
+ ! are now specified in file par_mod *
+ ! *
+ ! June 2006, write grid in sparse matrix with a single write command *
+ ! in order to save disk space *
+ ! *
+ ! 2008 new sparse matrix format *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! outnum number of samples *
+ ! ncells number of cells with non-zero concentrations *
+ ! sparse .true. if in sparse matrix format, else .false. *
+ ! tot_mu 1 for forward, initial mass mixing ration for backw. runs *
+ ! *
+ !*****************************************************************************
+
+ use unc_mod
+ use point_mod
+ use outg_mod
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ real(kind=dp) :: jul
+ integer :: itime,i,ix,jy,kz,ks,kp,l,iix,jjy,kzz,nage,jjjjmmdd,ihmmss
+ integer :: sp_count_i,sp_count_r
+ real :: sp_fact
+ real :: outnum,densityoutrecept(maxreceptor),xl,yl
+
+ !real densityoutgrid(0:numxgrid-1,0:numygrid-1,numzgrid),
+ ! +grid(0:numxgrid-1,0:numygrid-1,numzgrid,maxspec,maxpointspec_act,
+ ! + maxageclass)
+ !real wetgrid(0:numxgrid-1,0:numygrid-1,maxspec,maxpointspec_act,
+ ! + maxageclass)
+ !real drygrid(0:numxgrid-1,0:numygrid-1,maxspec,
+ ! + maxpointspec_act,maxageclass)
+ !real gridsigma(0:numxgrid-1,0:numygrid-1,numzgrid,maxspec,
+ ! + maxpointspec_act,maxageclass),
+ ! + drygridsigma(0:numxgrid-1,0:numygrid-1,maxspec,
+ ! + maxpointspec_act,maxageclass),
+ ! + wetgridsigma(0:numxgrid-1,0:numygrid-1,maxspec,
+ ! + maxpointspec_act,maxageclass)
+ !real factor(0:numxgrid-1,0:numygrid-1,numzgrid)
+ !real sparse_dump_r(numxgrid*numygrid*numzgrid)
+ !integer sparse_dump_i(numxgrid*numygrid*numzgrid)
+
+ !real sparse_dump_u(numxgrid*numygrid*numzgrid)
+ real :: auxgrid(nclassunc),gridtotal,gridsigmatotal,gridtotalunc
+ real :: wetgridtotal,wetgridsigmatotal,wetgridtotalunc
+ real :: drygridtotal,drygridsigmatotal,drygridtotalunc
+ real :: halfheight,dz,dz1,dz2,tot_mu(maxspec,maxpointspec_act)
+ real,parameter :: smallnum = tiny(0.0) ! smallest number that can be handled
+ real,parameter :: weightair=28.97
+ logical :: sp_zer
+ character :: adate*8,atime*6
+ character(len=3) :: anspec
+
+
+ if (verbosity.eq.1) then
+ print*,'inside concoutput_surf '
+ CALL SYSTEM_CLOCK(count_clock)
+ WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0
+ endif
+
+ ! Determine current calendar date, needed for the file name
+ !**********************************************************
+
+ jul=bdate+real(itime,kind=dp)/86400._dp
+ call caldate(jul,jjjjmmdd,ihmmss)
+ write(adate,'(i8.8)') jjjjmmdd
+ write(atime,'(i6.6)') ihmmss
+ !write(unitdates,'(a)') adate//atime
+
+ open(unitdates,file=path(2)(1:length(2))//'dates', ACCESS='APPEND')
+ write(unitdates,'(a)') adate//atime
+ close(unitdates)
+
+ ! For forward simulations, output fields have dimension MAXSPEC,
+ ! for backward simulations, output fields have dimension MAXPOINT.
+ ! Thus, make loops either about nspec, or about numpoint
+ !*****************************************************************
+
+
+ if (ldirect.eq.1) then
+ do ks=1,nspec
+ do kp=1,maxpointspec_act
+ tot_mu(ks,kp)=1
+ end do
+ end do
+ else
+ do ks=1,nspec
+ do kp=1,maxpointspec_act
+ tot_mu(ks,kp)=xmass(kp,ks)
+ end do
+ end do
+ endif
+
+
+ if (verbosity.eq.1) then
+ print*,'concoutput_surf 2'
+ CALL SYSTEM_CLOCK(count_clock)
+ WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0
+ endif
+
+ !*******************************************************************
+ ! Compute air density: sufficiently accurate to take it
+ ! from coarse grid at some time
+ ! Determine center altitude of output layer, and interpolate density
+ ! data to that altitude
+ !*******************************************************************
+
+ do kz=1,numzgrid
+ if (kz.eq.1) then
+ halfheight=outheight(1)/2.
+ else
+ halfheight=(outheight(kz)+outheight(kz-1))/2.
+ endif
+ do kzz=2,nz
+ if ((height(kzz-1).lt.halfheight).and. &
+ (height(kzz).gt.halfheight)) goto 46
+ end do
+46 kzz=max(min(kzz,nz),2)
+ dz1=halfheight-height(kzz-1)
+ dz2=height(kzz)-halfheight
+ dz=dz1+dz2
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ xl=outlon0+real(ix)*dxout
+ yl=outlat0+real(jy)*dyout
+ xl=(xl-xlon0)/dx
+ yl=(yl-ylat0)/dx
+ iix=max(min(nint(xl),nxmin1),0)
+ jjy=max(min(nint(yl),nymin1),0)
+ densityoutgrid(ix,jy,kz)=(rho(iix,jjy,kzz,2)*dz1+ &
+ rho(iix,jjy,kzz-1,2)*dz2)/dz
+ end do
+ end do
+ end do
+
+ do i=1,numreceptor
+ xl=xreceptor(i)
+ yl=yreceptor(i)
+ iix=max(min(nint(xl),nxmin1),0)
+ jjy=max(min(nint(yl),nymin1),0)
+ densityoutrecept(i)=rho(iix,jjy,1,2)
+ end do
+
+
+ ! Output is different for forward and backward simulations
+ do kz=1,numzgrid
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (ldirect.eq.1) then
+ factor3d(ix,jy,kz)=1.e12/volume(ix,jy,kz)/outnum
+ else
+ factor3d(ix,jy,kz)=real(abs(loutaver))/outnum
+ endif
+ end do
+ end do
+ end do
+
+ !*********************************************************************
+ ! Determine the standard deviation of the mean concentration or mixing
+ ! ratio (uncertainty of the output) and the dry and wet deposition
+ !*********************************************************************
+
+ if (verbosity.eq.1) then
+ print*,'concoutput_surf 3 (sd)'
+ CALL SYSTEM_CLOCK(count_clock)
+ WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0
+ endif
+ gridtotal=0.
+ gridsigmatotal=0.
+ gridtotalunc=0.
+ wetgridtotal=0.
+ wetgridsigmatotal=0.
+ wetgridtotalunc=0.
+ drygridtotal=0.
+ drygridsigmatotal=0.
+ drygridtotalunc=0.
+
+ do ks=1,nspec
+
+ write(anspec,'(i3.3)') ks
+ if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then
+ if (ldirect.eq.1) then
+ open(unitoutgrid,file=path(2)(1:length(2))//'grid_conc_'//adate// &
+ atime//'_'//anspec,form='unformatted')
+ else
+ open(unitoutgrid,file=path(2)(1:length(2))//'grid_time_'//adate// &
+ atime//'_'//anspec,form='unformatted')
+ endif
+ write(unitoutgrid) itime
+ endif
+
+ if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio
+ open(unitoutgridppt,file=path(2)(1:length(2))//'grid_pptv_'//adate// &
+ atime//'_'//anspec,form='unformatted')
+
+ write(unitoutgridppt) itime
+ endif
+
+ do kp=1,maxpointspec_act
+ do nage=1,nageclass
+
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+
+ ! WET DEPOSITION
+ if ((WETDEP).and.(ldirect.gt.0)) then
+ do l=1,nclassunc
+ auxgrid(l)=wetgridunc(ix,jy,ks,kp,l,nage)
+ end do
+ call mean(auxgrid,wetgrid(ix,jy), &
+ wetgridsigma(ix,jy),nclassunc)
+ ! Multiply by number of classes to get total concentration
+ wetgrid(ix,jy)=wetgrid(ix,jy) &
+ *nclassunc
+ wetgridtotal=wetgridtotal+wetgrid(ix,jy)
+ ! Calculate standard deviation of the mean
+ wetgridsigma(ix,jy)= &
+ wetgridsigma(ix,jy)* &
+ sqrt(real(nclassunc))
+ wetgridsigmatotal=wetgridsigmatotal+ &
+ wetgridsigma(ix,jy)
+ endif
+
+ ! DRY DEPOSITION
+ if ((DRYDEP).and.(ldirect.gt.0)) then
+ do l=1,nclassunc
+ auxgrid(l)=drygridunc(ix,jy,ks,kp,l,nage)
+ end do
+ call mean(auxgrid,drygrid(ix,jy), &
+ drygridsigma(ix,jy),nclassunc)
+ ! Multiply by number of classes to get total concentration
+ drygrid(ix,jy)=drygrid(ix,jy)* &
+ nclassunc
+ drygridtotal=drygridtotal+drygrid(ix,jy)
+ ! Calculate standard deviation of the mean
+ drygridsigma(ix,jy)= &
+ drygridsigma(ix,jy)* &
+ sqrt(real(nclassunc))
+125 drygridsigmatotal=drygridsigmatotal+ &
+ drygridsigma(ix,jy)
+ endif
+
+ ! CONCENTRATION OR MIXING RATIO
+ do kz=1,numzgrid
+ do l=1,nclassunc
+ auxgrid(l)=gridunc(ix,jy,kz,ks,kp,l,nage)
+ end do
+ call mean(auxgrid,grid(ix,jy,kz), &
+ gridsigma(ix,jy,kz),nclassunc)
+ ! Multiply by number of classes to get total concentration
+ grid(ix,jy,kz)= &
+ grid(ix,jy,kz)*nclassunc
+ gridtotal=gridtotal+grid(ix,jy,kz)
+ ! Calculate standard deviation of the mean
+ gridsigma(ix,jy,kz)= &
+ gridsigma(ix,jy,kz)* &
+ sqrt(real(nclassunc))
+ gridsigmatotal=gridsigmatotal+ &
+ gridsigma(ix,jy,kz)
+ end do
+ end do
+ end do
+
+
+
+
+ !*******************************************************************
+ ! Generate output: may be in concentration (ng/m3) or in mixing
+ ! ratio (ppt) or both
+ ! Output the position and the values alternated multiplied by
+ ! 1 or -1, first line is number of values, number of positions
+ ! For backward simulations, the unit is seconds, stored in grid_time
+ !*******************************************************************
+ if (verbosity.eq.1) then
+ print*,'concoutput_surf 4 (output)'
+ CALL SYSTEM_CLOCK(count_clock)
+ WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0
+ endif
+
+ ! Concentration output
+ !*********************
+ if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then
+ if (verbosity.eq.1) then
+ print*,'concoutput_surf (Wet deposition)'
+ CALL SYSTEM_CLOCK(count_clock)
+ WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0
+ endif
+
+ ! Wet deposition
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ if ((ldirect.eq.1).and.(WETDEP)) then
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ !oncentraion greater zero
+ if (wetgrid(ix,jy).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)=ix+jy*numxgrid
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact*1.e12*wetgrid(ix,jy)/area(ix,jy)
+ sparse_dump_u(sp_count_r)= &
+ 1.e12*wetgridsigma(ix,jy)/area(ix,jy)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ else
+ sp_count_i=0
+ sp_count_r=0
+ endif
+ write(unitoutgrid) sp_count_i
+ write(unitoutgrid) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgrid) sp_count_r
+ write(unitoutgrid) (sparse_dump_r(i),i=1,sp_count_r)
+! write(unitoutgrid) sp_count_r
+ write(unitoutgrid) (sparse_dump_u(i),i=1,sp_count_r)
+
+ if (verbosity.eq.1) then
+ print*,'concoutput_surf (Dry deposition)'
+ CALL SYSTEM_CLOCK(count_clock)
+ WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0
+ endif
+ ! Dry deposition
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ if ((ldirect.eq.1).and.(DRYDEP)) then
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (drygrid(ix,jy).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)=ix+jy*numxgrid
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ 1.e12*drygrid(ix,jy)/area(ix,jy)
+ sparse_dump_u(sp_count_r)= &
+ 1.e12*drygridsigma(ix,jy)/area(ix,jy)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ else
+ sp_count_i=0
+ sp_count_r=0
+ endif
+ write(unitoutgrid) sp_count_i
+ write(unitoutgrid) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgrid) sp_count_r
+ write(unitoutgrid) (sparse_dump_r(i),i=1,sp_count_r)
+! write(unitoutgrid) sp_count_r
+ write(unitoutgrid) (sparse_dump_u(i),i=1,sp_count_r)
+
+
+
+ if (verbosity.eq.1) then
+ print*,'concoutput_surf (Concentrations)'
+ CALL SYSTEM_CLOCK(count_clock)
+ WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0
+ endif
+ ! Concentrations
+
+ ! if surf_only write only 1st layer
+
+ if(surf_only.eq.1) then
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ do kz=1,1
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (grid(ix,jy,kz).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgrid+kz*numxgrid*numygrid
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ grid(ix,jy,kz)* &
+ factor3d(ix,jy,kz)/tot_mu(ks,kp)
+ ! if ((factor(ix,jy,kz)/tot_mu(ks,kp)).eq.0)
+ ! + write (*,*) factor(ix,jy,kz),tot_mu(ks,kp),ks,kp
+ sparse_dump_u(sp_count_r)= &
+ gridsigma(ix,jy,kz)* &
+ factor3d(ix,jy,kz)/tot_mu(ks,kp)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ end do
+ write(unitoutgrid) sp_count_i
+ write(unitoutgrid) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgrid) sp_count_r
+ write(unitoutgrid) (sparse_dump_r(i),i=1,sp_count_r)
+! write(unitoutgrid) sp_count_r
+ write(unitoutgrid) (sparse_dump_u(i),i=1,sp_count_r)
+ else
+
+ ! write full vertical resolution
+ if (verbosity.eq.1) then
+ print*,'concoutput_surf (write full vertical resolution)'
+ CALL SYSTEM_CLOCK(count_clock)
+ WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0
+ endif
+
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ do kz=1,numzgrid
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (grid(ix,jy,kz).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgrid+kz*numxgrid*numygrid
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ grid(ix,jy,kz)* &
+ factor3d(ix,jy,kz)/tot_mu(ks,kp)
+ ! if ((factor(ix,jy,kz)/tot_mu(ks,kp)).eq.0)
+ ! + write (*,*) factor(ix,jy,kz),tot_mu(ks,kp),ks,kp
+ sparse_dump_u(sp_count_r)= &
+ gridsigma(ix,jy,kz)* &
+ factor3d(ix,jy,kz)/tot_mu(ks,kp)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ end do
+ write(unitoutgrid) sp_count_i
+ write(unitoutgrid) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgrid) sp_count_r
+ write(unitoutgrid) (sparse_dump_r(i),i=1,sp_count_r)
+! write(unitoutgrid) sp_count_r
+ write(unitoutgrid) (sparse_dump_u(i),i=1,sp_count_r)
+ endif ! surf_only
+
+ endif ! concentration output
+
+ ! Mixing ratio output
+ !********************
+
+ if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio
+
+ ! Wet deposition
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ if ((ldirect.eq.1).and.(WETDEP)) then
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (wetgrid(ix,jy).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgrid
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ 1.e12*wetgrid(ix,jy)/area(ix,jy)
+ sparse_dump_u(sp_count_r)= &
+ 1.e12*wetgridsigma(ix,jy)/area(ix,jy)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ else
+ sp_count_i=0
+ sp_count_r=0
+ endif
+ write(unitoutgridppt) sp_count_i
+ write(unitoutgridppt) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgridppt) sp_count_r
+ write(unitoutgridppt) (sparse_dump_r(i),i=1,sp_count_r)
+! write(unitoutgridppt) sp_count_r
+ write(unitoutgridppt) (sparse_dump_u(i),i=1,sp_count_r)
+
+
+ ! Dry deposition
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ if ((ldirect.eq.1).and.(DRYDEP)) then
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (drygrid(ix,jy).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgrid
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ 1.e12*drygrid(ix,jy)/area(ix,jy)
+ sparse_dump_u(sp_count_r)= &
+ 1.e12*drygridsigma(ix,jy)/area(ix,jy)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ else
+ sp_count_i=0
+ sp_count_r=0
+ endif
+ write(unitoutgridppt) sp_count_i
+ write(unitoutgridppt) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgridppt) sp_count_r
+ write(unitoutgridppt) (sparse_dump_r(i),i=1,sp_count_r)
+! write(unitoutgridppt) sp_count_r
+ write(unitoutgridppt) (sparse_dump_u(i),i=1,sp_count_r)
+
+
+ ! Mixing ratios
+
+ ! if surf_only write only 1st layer
+
+ if(surf_only.eq.1) then
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ do kz=1,1
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (grid(ix,jy,kz).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgrid+kz*numxgrid*numygrid
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ 1.e12*grid(ix,jy,kz) &
+ /volume(ix,jy,kz)/outnum* &
+ weightair/weightmolar(ks)/densityoutgrid(ix,jy,kz)
+ sparse_dump_u(sp_count_r)= &
+ 1.e12*gridsigma(ix,jy,kz)/volume(ix,jy,kz)/ &
+ outnum*weightair/weightmolar(ks)/ &
+ densityoutgrid(ix,jy,kz)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ end do
+ write(unitoutgridppt) sp_count_i
+ write(unitoutgridppt) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgridppt) sp_count_r
+ write(unitoutgridppt) (sparse_dump_r(i),i=1,sp_count_r)
+! write(unitoutgridppt) sp_count_r
+ write(unitoutgridppt) (sparse_dump_u(i),i=1,sp_count_r)
+ else
+
+ ! write full vertical resolution
+
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ do kz=1,numzgrid
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (grid(ix,jy,kz).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgrid+kz*numxgrid*numygrid
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ 1.e12*grid(ix,jy,kz) &
+ /volume(ix,jy,kz)/outnum* &
+ weightair/weightmolar(ks)/densityoutgrid(ix,jy,kz)
+ sparse_dump_u(sp_count_r)= &
+ 1.e12*gridsigma(ix,jy,kz)/volume(ix,jy,kz)/ &
+ outnum*weightair/weightmolar(ks)/ &
+ densityoutgrid(ix,jy,kz)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ end do
+ write(unitoutgridppt) sp_count_i
+ write(unitoutgridppt) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgridppt) sp_count_r
+ write(unitoutgridppt) (sparse_dump_r(i),i=1,sp_count_r)
+! write(unitoutgridppt) sp_count_r
+ write(unitoutgridppt) (sparse_dump_u(i),i=1,sp_count_r)
+ endif ! surf_only
+
+ endif ! output for ppt
+
+ end do
+ end do
+
+ close(unitoutgridppt)
+ close(unitoutgrid)
+
+ end do
+
+ if (gridtotal.gt.0.) gridtotalunc=gridsigmatotal/gridtotal
+ if (wetgridtotal.gt.0.) wetgridtotalunc=wetgridsigmatotal/ &
+ wetgridtotal
+ if (drygridtotal.gt.0.) drygridtotalunc=drygridsigmatotal/ &
+ drygridtotal
+
+ ! Dump of receptor concentrations
+
+ if (numreceptor.gt.0 .and. (iout.eq.2 .or. iout.eq.3) ) then
+ write(unitoutreceptppt) itime
+ do ks=1,nspec
+ write(unitoutreceptppt) (1.e12*creceptor(i,ks)/outnum* &
+ weightair/weightmolar(ks)/densityoutrecept(i),i=1,numreceptor)
+ end do
+ endif
+
+ ! Dump of receptor concentrations
+
+ if (numreceptor.gt.0) then
+ write(unitoutrecept) itime
+ do ks=1,nspec
+ write(unitoutrecept) (1.e12*creceptor(i,ks)/outnum, &
+ i=1,numreceptor)
+ end do
+ endif
+
+
+
+ ! Reinitialization of grid
+ !*************************
+
+ do ks=1,nspec
+ do kp=1,maxpointspec_act
+ do i=1,numreceptor
+ creceptor(i,ks)=0.
+ end do
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ do l=1,nclassunc
+ do nage=1,nageclass
+ do kz=1,numzgrid
+ gridunc(ix,jy,kz,ks,kp,l,nage)=0.
+ end do
+ end do
+ end do
+ end do
+ end do
+ end do
+ end do
+
+
+end subroutine concoutput_surf
diff --git a/src/concoutput_surf_nest.f90 b/src/concoutput_surf_nest.f90
new file mode 100644
index 0000000000000000000000000000000000000000..ee1b50bda221f78d50ba64d328c0e19d08e0c851
--- /dev/null
+++ b/src/concoutput_surf_nest.f90
@@ -0,0 +1,652 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine concoutput_surf_nest(itime,outnum)
+ ! i i
+ !*****************************************************************************
+ ! *
+ ! Output of the concentration grid and the receptor concentrations. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 24 May 1995 *
+ ! *
+ ! 13 April 1999, Major update: if output size is smaller, dump output *
+ ! in sparse matrix format; additional output of *
+ ! uncertainty *
+ ! *
+ ! 05 April 2000, Major update: output of age classes; output for backward*
+ ! runs is time spent in grid cell times total mass of *
+ ! species. *
+ ! *
+ ! 17 February 2002, Appropriate dimensions for backward and forward runs *
+ ! are now specified in file par_mod *
+ ! *
+ ! June 2006, write grid in sparse matrix with a single write command *
+ ! in order to save disk space *
+ ! *
+ ! 2008 new sparse matrix format *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! outnum number of samples *
+ ! ncells number of cells with non-zero concentrations *
+ ! sparse .true. if in sparse matrix format, else .false. *
+ ! tot_mu 1 for forward, initial mass mixing ration for backw. runs *
+ ! *
+ !*****************************************************************************
+
+ use unc_mod
+ use point_mod
+ use outg_mod
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ real(kind=dp) :: jul
+ integer :: itime,i,ix,jy,kz,ks,kp,l,iix,jjy,kzz,nage,jjjjmmdd,ihmmss
+ integer :: sp_count_i,sp_count_r
+ real :: sp_fact
+ real :: outnum,densityoutrecept(maxreceptor),xl,yl
+
+ !real densityoutgrid(0:numxgrid-1,0:numygrid-1,numzgrid),
+ ! +grid(0:numxgrid-1,0:numygrid-1,numzgrid,maxspec,maxpointspec_act,
+ ! + maxageclass)
+ !real wetgrid(0:numxgrid-1,0:numygrid-1,maxspec,maxpointspec_act,
+ ! + maxageclass)
+ !real drygrid(0:numxgrid-1,0:numygrid-1,maxspec,
+ ! + maxpointspec_act,maxageclass)
+ !real gridsigma(0:numxgrid-1,0:numygrid-1,numzgrid,maxspec,
+ ! + maxpointspec_act,maxageclass),
+ ! + drygridsigma(0:numxgrid-1,0:numygrid-1,maxspec,
+ ! + maxpointspec_act,maxageclass),
+ ! + wetgridsigma(0:numxgrid-1,0:numygrid-1,maxspec,
+ ! + maxpointspec_act,maxageclass)
+ !real factor(0:numxgrid-1,0:numygrid-1,numzgrid)
+ !real sparse_dump_r(numxgrid*numygrid*numzgrid)
+ !integer sparse_dump_i(numxgrid*numygrid*numzgrid)
+
+ !real sparse_dump_u(numxgrid*numygrid*numzgrid)
+ real :: auxgrid(nclassunc)
+ real :: halfheight,dz,dz1,dz2,tot_mu(maxspec,maxpointspec_act)
+ real,parameter :: smallnum = tiny(0.0) ! smallest number that can be handled
+ real,parameter :: weightair=28.97
+ logical :: sp_zer
+ character :: adate*8,atime*6
+ character(len=3) :: anspec
+
+
+ ! Determine current calendar date, needed for the file name
+ !**********************************************************
+
+ jul=bdate+real(itime,kind=dp)/86400._dp
+ call caldate(jul,jjjjmmdd,ihmmss)
+ write(adate,'(i8.8)') jjjjmmdd
+ write(atime,'(i6.6)') ihmmss
+
+
+ ! For forward simulations, output fields have dimension MAXSPEC,
+ ! for backward simulations, output fields have dimension MAXPOINT.
+ ! Thus, make loops either about nspec, or about numpoint
+ !*****************************************************************
+
+
+ if (ldirect.eq.1) then
+ do ks=1,nspec
+ do kp=1,maxpointspec_act
+ tot_mu(ks,kp)=1
+ end do
+ end do
+ else
+ do ks=1,nspec
+ do kp=1,maxpointspec_act
+ tot_mu(ks,kp)=xmass(kp,ks)
+ end do
+ end do
+ endif
+
+
+ !*******************************************************************
+ ! Compute air density: sufficiently accurate to take it
+ ! from coarse grid at some time
+ ! Determine center altitude of output layer, and interpolate density
+ ! data to that altitude
+ !*******************************************************************
+
+ do kz=1,numzgrid
+ if (kz.eq.1) then
+ halfheight=outheight(1)/2.
+ else
+ halfheight=(outheight(kz)+outheight(kz-1))/2.
+ endif
+ do kzz=2,nz
+ if ((height(kzz-1).lt.halfheight).and. &
+ (height(kzz).gt.halfheight)) goto 46
+ end do
+46 kzz=max(min(kzz,nz),2)
+ dz1=halfheight-height(kzz-1)
+ dz2=height(kzz)-halfheight
+ dz=dz1+dz2
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ xl=outlon0n+real(ix)*dxoutn
+ yl=outlat0n+real(jy)*dyoutn
+ xl=(xl-xlon0)/dx
+ yl=(yl-ylat0)/dy
+ iix=max(min(nint(xl),nxmin1),0)
+ jjy=max(min(nint(yl),nymin1),0)
+ densityoutgrid(ix,jy,kz)=(rho(iix,jjy,kzz,2)*dz1+ &
+ rho(iix,jjy,kzz-1,2)*dz2)/dz
+ end do
+ end do
+ end do
+
+ do i=1,numreceptor
+ xl=xreceptor(i)
+ yl=yreceptor(i)
+ iix=max(min(nint(xl),nxmin1),0)
+ jjy=max(min(nint(yl),nymin1),0)
+ densityoutrecept(i)=rho(iix,jjy,1,2)
+ end do
+
+
+ ! Output is different for forward and backward simulations
+ do kz=1,numzgrid
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ if (ldirect.eq.1) then
+ factor3d(ix,jy,kz)=1.e12/volumen(ix,jy,kz)/outnum
+ else
+ factor3d(ix,jy,kz)=real(abs(loutaver))/outnum
+ endif
+ end do
+ end do
+ end do
+
+ !*********************************************************************
+ ! Determine the standard deviation of the mean concentration or mixing
+ ! ratio (uncertainty of the output) and the dry and wet deposition
+ !*********************************************************************
+
+ do ks=1,nspec
+
+ write(anspec,'(i3.3)') ks
+ if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then
+ if (ldirect.eq.1) then
+ open(unitoutgrid,file=path(2)(1:length(2))//'grid_conc_nest_' &
+ //adate// &
+ atime//'_'//anspec,form='unformatted')
+ else
+ open(unitoutgrid,file=path(2)(1:length(2))//'grid_time_nest_' &
+ //adate// &
+ atime//'_'//anspec,form='unformatted')
+ endif
+ write(unitoutgrid) itime
+ endif
+
+ if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio
+ open(unitoutgridppt,file=path(2)(1:length(2))//'grid_pptv_nest_' &
+ //adate// &
+ atime//'_'//anspec,form='unformatted')
+
+ write(unitoutgridppt) itime
+ endif
+
+ do kp=1,maxpointspec_act
+ do nage=1,nageclass
+
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+
+ ! WET DEPOSITION
+ if ((WETDEP).and.(ldirect.gt.0)) then
+ do l=1,nclassunc
+ auxgrid(l)=wetgriduncn(ix,jy,ks,kp,l,nage)
+ end do
+ call mean(auxgrid,wetgrid(ix,jy), &
+ wetgridsigma(ix,jy),nclassunc)
+ ! Multiply by number of classes to get total concentration
+ wetgrid(ix,jy)=wetgrid(ix,jy) &
+ *nclassunc
+ ! Calculate standard deviation of the mean
+ wetgridsigma(ix,jy)= &
+ wetgridsigma(ix,jy)* &
+ sqrt(real(nclassunc))
+ endif
+
+ ! DRY DEPOSITION
+ if ((DRYDEP).and.(ldirect.gt.0)) then
+ do l=1,nclassunc
+ auxgrid(l)=drygriduncn(ix,jy,ks,kp,l,nage)
+ end do
+ call mean(auxgrid,drygrid(ix,jy), &
+ drygridsigma(ix,jy),nclassunc)
+ ! Multiply by number of classes to get total concentration
+ drygrid(ix,jy)=drygrid(ix,jy)* &
+ nclassunc
+ ! Calculate standard deviation of the mean
+ drygridsigma(ix,jy)= &
+ drygridsigma(ix,jy)* &
+ sqrt(real(nclassunc))
+ endif
+
+ ! CONCENTRATION OR MIXING RATIO
+ do kz=1,numzgrid
+ do l=1,nclassunc
+ auxgrid(l)=griduncn(ix,jy,kz,ks,kp,l,nage)
+ end do
+ call mean(auxgrid,grid(ix,jy,kz), &
+ gridsigma(ix,jy,kz),nclassunc)
+ ! Multiply by number of classes to get total concentration
+ grid(ix,jy,kz)= &
+ grid(ix,jy,kz)*nclassunc
+ ! Calculate standard deviation of the mean
+ gridsigma(ix,jy,kz)= &
+ gridsigma(ix,jy,kz)* &
+ sqrt(real(nclassunc))
+ end do
+ end do
+ end do
+
+
+ !*******************************************************************
+ ! Generate output: may be in concentration (ng/m3) or in mixing
+ ! ratio (ppt) or both
+ ! Output the position and the values alternated multiplied by
+ ! 1 or -1, first line is number of values, number of positions
+ ! For backward simulations, the unit is seconds, stored in grid_time
+ !*******************************************************************
+
+ ! Concentration output
+ !*********************
+ if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then
+
+ ! Wet deposition
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ if ((ldirect.eq.1).and.(WETDEP)) then
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ !oncentraion greater zero
+ if (wetgrid(ix,jy).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)=ix+jy*numxgridn
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact*1.e12*wetgrid(ix,jy)/arean(ix,jy)
+ sparse_dump_u(sp_count_r)= &
+ 1.e12*wetgridsigma(ix,jy)/area(ix,jy)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ else
+ sp_count_i=0
+ sp_count_r=0
+ endif
+ write(unitoutgrid) sp_count_i
+ write(unitoutgrid) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgrid) sp_count_r
+ write(unitoutgrid) (sparse_dump_r(i),i=1,sp_count_r)
+ write(unitoutgrid) sp_count_r
+ write(unitoutgrid) (sparse_dump_u(i),i=1,sp_count_r)
+
+ ! Dry deposition
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ if ((ldirect.eq.1).and.(DRYDEP)) then
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ if (drygrid(ix,jy).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)=ix+jy*numxgridn
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ 1.e12*drygrid(ix,jy)/arean(ix,jy)
+ sparse_dump_u(sp_count_r)= &
+ 1.e12*drygridsigma(ix,jy)/area(ix,jy)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ else
+ sp_count_i=0
+ sp_count_r=0
+ endif
+ write(unitoutgrid) sp_count_i
+ write(unitoutgrid) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgrid) sp_count_r
+ write(unitoutgrid) (sparse_dump_r(i),i=1,sp_count_r)
+ write(unitoutgrid) sp_count_r
+ write(unitoutgrid) (sparse_dump_u(i),i=1,sp_count_r)
+
+
+
+ ! Concentrations
+
+ ! if surf_only write only 1st layer
+
+ if(surf_only.eq.1) then
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ do kz=1,1
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ if (grid(ix,jy,kz).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgridn+kz*numxgridn*numygridn
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ grid(ix,jy,kz)* &
+ factor3d(ix,jy,kz)/tot_mu(ks,kp)
+ ! if ((factor(ix,jy,kz)/tot_mu(ks,kp)).eq.0)
+ ! + write (*,*) factor(ix,jy,kz),tot_mu(ks,kp),ks,kp
+ sparse_dump_u(sp_count_r)= &
+ gridsigma(ix,jy,kz)* &
+ factor3d(ix,jy,kz)/tot_mu(ks,kp)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ end do
+ write(unitoutgrid) sp_count_i
+ write(unitoutgrid) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgrid) sp_count_r
+ write(unitoutgrid) (sparse_dump_r(i),i=1,sp_count_r)
+ write(unitoutgrid) sp_count_r
+ write(unitoutgrid) (sparse_dump_u(i),i=1,sp_count_r)
+ else
+
+ ! write full vertical resolution
+
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ do kz=1,numzgrid
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ if (grid(ix,jy,kz).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgridn+kz*numxgridn*numygridn
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ grid(ix,jy,kz)* &
+ factor3d(ix,jy,kz)/tot_mu(ks,kp)
+ ! if ((factor(ix,jy,kz)/tot_mu(ks,kp)).eq.0)
+ ! + write (*,*) factor(ix,jy,kz),tot_mu(ks,kp),ks,kp
+ sparse_dump_u(sp_count_r)= &
+ gridsigma(ix,jy,kz)* &
+ factor3d(ix,jy,kz)/tot_mu(ks,kp)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ end do
+ write(unitoutgrid) sp_count_i
+ write(unitoutgrid) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgrid) sp_count_r
+ write(unitoutgrid) (sparse_dump_r(i),i=1,sp_count_r)
+ write(unitoutgrid) sp_count_r
+ write(unitoutgrid) (sparse_dump_u(i),i=1,sp_count_r)
+ endif ! surf_only
+
+
+ endif ! concentration output
+
+ ! Mixing ratio output
+ !********************
+
+ if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio
+
+ ! Wet deposition
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ if ((ldirect.eq.1).and.(WETDEP)) then
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ if (wetgrid(ix,jy).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgridn
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ 1.e12*wetgrid(ix,jy)/arean(ix,jy)
+ sparse_dump_u(sp_count_r)= &
+ 1.e12*wetgridsigma(ix,jy)/area(ix,jy)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ else
+ sp_count_i=0
+ sp_count_r=0
+ endif
+ write(unitoutgridppt) sp_count_i
+ write(unitoutgridppt) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgridppt) sp_count_r
+ write(unitoutgridppt) (sparse_dump_r(i),i=1,sp_count_r)
+ write(unitoutgridppt) sp_count_r
+ write(unitoutgridppt) (sparse_dump_u(i),i=1,sp_count_r)
+
+
+ ! Dry deposition
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ if ((ldirect.eq.1).and.(DRYDEP)) then
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ if (drygrid(ix,jy).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgridn
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ 1.e12*drygrid(ix,jy)/arean(ix,jy)
+ sparse_dump_u(sp_count_r)= &
+ 1.e12*drygridsigma(ix,jy)/area(ix,jy)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ else
+ sp_count_i=0
+ sp_count_r=0
+ endif
+ write(unitoutgridppt) sp_count_i
+ write(unitoutgridppt) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgridppt) sp_count_r
+ write(unitoutgridppt) (sparse_dump_r(i),i=1,sp_count_r)
+ write(unitoutgridppt) sp_count_r
+ write(unitoutgridppt) (sparse_dump_u(i),i=1,sp_count_r)
+
+
+ ! Mixing ratios
+
+ ! if surf_only write only 1st layer
+
+ if(surf_only.eq.1) then
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ do kz=1,1
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ if (grid(ix,jy,kz).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgridn+kz*numxgridn*numygridn
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ 1.e12*grid(ix,jy,kz) &
+ /volumen(ix,jy,kz)/outnum* &
+ weightair/weightmolar(ks)/densityoutgrid(ix,jy,kz)
+ sparse_dump_u(sp_count_r)= &
+ 1.e12*gridsigma(ix,jy,kz)/volumen(ix,jy,kz)/ &
+ outnum*weightair/weightmolar(ks)/ &
+ densityoutgrid(ix,jy,kz)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ end do
+ write(unitoutgridppt) sp_count_i
+ write(unitoutgridppt) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgridppt) sp_count_r
+ write(unitoutgridppt) (sparse_dump_r(i),i=1,sp_count_r)
+ write(unitoutgridppt) sp_count_r
+ write(unitoutgridppt) (sparse_dump_u(i),i=1,sp_count_r)
+ else
+
+ ! write full vertical resolution
+
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ do kz=1,numzgrid
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ if (grid(ix,jy,kz).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgridn+kz*numxgridn*numygridn
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ 1.e12*grid(ix,jy,kz) &
+ /volumen(ix,jy,kz)/outnum* &
+ weightair/weightmolar(ks)/densityoutgrid(ix,jy,kz)
+ sparse_dump_u(sp_count_r)= &
+ 1.e12*gridsigma(ix,jy,kz)/volumen(ix,jy,kz)/ &
+ outnum*weightair/weightmolar(ks)/ &
+ densityoutgrid(ix,jy,kz)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ end do
+ write(unitoutgridppt) sp_count_i
+ write(unitoutgridppt) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgridppt) sp_count_r
+ write(unitoutgridppt) (sparse_dump_r(i),i=1,sp_count_r)
+ write(unitoutgridppt) sp_count_r
+ write(unitoutgridppt) (sparse_dump_u(i),i=1,sp_count_r)
+ endif ! surf_only
+
+ endif ! output for ppt
+
+ end do
+ end do
+
+ close(unitoutgridppt)
+ close(unitoutgrid)
+
+ end do
+
+
+
+ ! Reinitialization of grid
+ !*************************
+
+ do ks=1,nspec
+ do kp=1,maxpointspec_act
+ do i=1,numreceptor
+ creceptor(i,ks)=0.
+ end do
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ do l=1,nclassunc
+ do nage=1,nageclass
+ do kz=1,numzgrid
+ griduncn(ix,jy,kz,ks,kp,l,nage)=0.
+ end do
+ end do
+ end do
+ end do
+ end do
+ end do
+ end do
+
+
+end subroutine concoutput_surf_nest
+
diff --git a/src/conv_mod.f90 b/src/conv_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..7b1bbc89aa8cddf7f5a10d8ef843129236ac204e
--- /dev/null
+++ b/src/conv_mod.f90
@@ -0,0 +1,34 @@
+!*******************************************************************************
+! Include file for convection
+! This file contains a global common block used by convect
+! and other subroutines
+! Author: P. Ferstl
+!
+! Feb 2001
+!
+!*******************************************************************************
+
+module conv_mod
+
+ use par_mod, only: nconvlevmax, na, nxmax, nymax, nxmaxn, nymaxn, maxnests
+
+ implicit none
+
+ !integer,parameter :: nconvlevmax = nuvzmax-1, &
+ ! na = nconvlevmax+1
+ !these parameters are defined in par_mod now!
+
+ real :: pconv(nconvlevmax),phconv(na),dpr(nconvlevmax)
+ real :: pconv_hpa(nconvlevmax),phconv_hpa(na)
+
+ real :: ft(nconvlevmax), fq(nconvlevmax)
+ real :: fmass(nconvlevmax,nconvlevmax),sub(nconvlevmax)
+ real :: fmassfrac(nconvlevmax,nconvlevmax)
+ real :: cbaseflux(0:nxmax-1,0:nymax-1)
+ real :: cbasefluxn(0:nxmaxn-1,0:nymaxn-1,maxnests)
+ real :: tconv(na),qconv(na),qsconv(na)
+ real :: psconv,tt2conv,td2conv
+
+ integer :: nconvlev,nconvtop
+
+end module conv_mod
diff --git a/src/convect43c.f90 b/src/convect43c.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d51388fc9efc3a8f8d2e68e3c62ac27299f088f0
--- /dev/null
+++ b/src/convect43c.f90
@@ -0,0 +1,1110 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+!**************************************************************************
+!**** SUBROUTINE CONVECT *****
+!**** VERSION 4.3c *****
+!**** 20 May, 2002 *****
+!**** Kerry Emanuel *****
+!**************************************************************************
+!
+ SUBROUTINE CONVECT &
+ (ND, NL, DELT, IFLAG, &
+ PRECIP, WD, TPRIME, QPRIME, CBMF )
+ !
+ !-cv *************************************************************************
+ !-cv C. Forster, November 2003 - May 2004:
+ !-cv
+ !-cv The subroutine has been downloaded from Kerry Emanuel's homepage,
+ !-cv where further infos on the convection scheme can be found
+ !-cv http://www-paoc.mit.edu/~emanuel/home.html
+ !-cv
+ !-cv The following changes have been made to integrate this subroutine
+ !-cv into FLEXPART
+ !-cv
+ !-cv Putting most of the variables in a new common block
+ !-cv renaming eps to eps0 because there is some eps already in includepar
+ !-cv
+ !-cv removing the arrays U,V,TRA and related arrays
+ !-cv
+ !-cv renaming the original arrays T,Q,QS,P,PH to
+ !-cv TCONV,QCONV,QSCONV,PCONV_HPA,PHCONV_HPA
+ !-cv
+ !-cv Initialization of variables has been put into parameter statements
+ !-cv instead of assignment of values at each call, in order to save
+ !-cv computation time.
+ !***************************************************************************
+ !
+ !-----------------------------------------------------------------------------
+ ! *** On input: ***
+ !
+ !T: Array of absolute temperature (K) of dimension ND, with first
+ ! index corresponding to lowest model level. Note that this array
+ ! will be altered by the subroutine if dry convective adjustment
+ ! occurs and if IPBL is not equal to 0.
+ !
+ !Q: Array of specific humidity (gm/gm) of dimension ND, with first
+ ! index corresponding to lowest model level. Must be defined
+ ! at same grid levels as T. Note that this array will be altered
+ ! if dry convective adjustment occurs and if IPBL is not equal to 0.
+ !
+ !QS: Array of saturation specific humidity of dimension ND, with first
+ ! index corresponding to lowest model level. Must be defined
+ ! at same grid levels as T. Note that this array will be altered
+ ! if dry convective adjustment occurs and if IPBL is not equal to 0.
+ !
+ !U: Array of zonal wind velocity (m/s) of dimension ND, witth first
+ ! index corresponding with the lowest model level. Defined at
+ ! same levels as T. Note that this array will be altered if
+ ! dry convective adjustment occurs and if IPBL is not equal to 0.
+ !
+ !V: Same as U but for meridional velocity.
+ !
+ !TRA: Array of passive tracer mixing ratio, of dimensions (ND,NTRA),
+ ! where NTRA is the number of different tracers. If no
+ ! convective tracer transport is needed, define a dummy
+ ! input array of dimension (ND,1). Tracers are defined at
+ ! same vertical levels as T. Note that this array will be altered
+ ! if dry convective adjustment occurs and if IPBL is not equal to 0.
+ !
+ !P: Array of pressure (mb) of dimension ND, with first
+ ! index corresponding to lowest model level. Must be defined
+ ! at same grid levels as T.
+ !
+ !PH: Array of pressure (mb) of dimension ND+1, with first index
+ ! corresponding to lowest level. These pressures are defined at
+ ! levels intermediate between those of P, T, Q and QS. The first
+ ! value of PH should be greater than (i.e. at a lower level than)
+ ! the first value of the array P.
+ !
+ !ND: The dimension of the arrays T,Q,QS,P,PH,FT and FQ
+ !
+ !NL: The maximum number of levels to which convection can
+ ! penetrate, plus 1.
+ ! NL MUST be less than or equal to ND-1.
+ !
+ !NTRA:The number of different tracers. If no tracer transport
+ ! is needed, set this equal to 1. (On most compilers, setting
+ ! NTRA to 0 will bypass tracer calculation, saving some CPU.)
+ !
+ !DELT: The model time step (sec) between calls to CONVECT
+ !
+ !----------------------------------------------------------------------------
+ ! *** On Output: ***
+ !
+ !IFLAG: An output integer whose value denotes the following:
+ !
+ ! VALUE INTERPRETATION
+ ! ----- --------------
+ ! 0 No moist convection; atmosphere is not
+ ! unstable, or surface temperature is less
+ ! than 250 K or surface specific humidity
+ ! is non-positive.
+ !
+ ! 1 Moist convection occurs.
+ !
+ ! 2 No moist convection: lifted condensation
+ ! level is above the 200 mb level.
+ !
+ ! 3 No moist convection: cloud base is higher
+ ! then the level NL-1.
+ !
+ ! 4 Moist convection occurs, but a CFL condition
+ ! on the subsidence warming is violated. This
+ ! does not cause the scheme to terminate.
+ !
+ !FT: Array of temperature tendency (K/s) of dimension ND, defined at same
+ ! grid levels as T, Q, QS and P.
+ !
+ !FQ: Array of specific humidity tendencies ((gm/gm)/s) of dimension ND,
+ ! defined at same grid levels as T, Q, QS and P.
+ !
+ !FU: Array of forcing of zonal velocity (m/s^2) of dimension ND,
+ ! defined at same grid levels as T.
+ !
+ !FV: Same as FU, but for forcing of meridional velocity.
+ !
+ !FTRA: Array of forcing of tracer content, in tracer mixing ratio per
+ ! second, defined at same levels as T. Dimensioned (ND,NTRA).
+ !
+ !PRECIP: Scalar convective precipitation rate (mm/day).
+ !
+ !WD: A convective downdraft velocity scale. For use in surface
+ ! flux parameterizations. See convect.ps file for details.
+ !
+ !TPRIME: A convective downdraft temperature perturbation scale (K).
+ ! For use in surface flux parameterizations. See convect.ps
+ ! file for details.
+ !
+ !QPRIME: A convective downdraft specific humidity
+ ! perturbation scale (gm/gm).
+ ! For use in surface flux parameterizations. See convect.ps
+ ! file for details.
+ !
+ !CBMF: The cloud base mass flux ((kg/m**2)/s). THIS SCALAR VALUE MUST
+ ! BE STORED BY THE CALLING PROGRAM AND RETURNED TO CONVECT AT
+ ! ITS NEXT CALL. That is, the value of CBMF must be "remembered"
+ ! by the calling program between calls to CONVECT.
+ !
+ !-----------------------------------------------------------------------------
+ !
+ ! *** THE PARAMETER NA SHOULD IN GENERAL BE GREATER THAN ***
+ ! *** OR EQUAL TO ND + 1 ***
+ !
+ !
+ use par_mod
+ use conv_mod
+
+ implicit none
+ !
+ !-cv====>Begin Module CONVECT File convect.f Undeclared variables
+ !
+ !Argument variables
+ !
+ integer :: iflag, nd, nl
+ !
+ real :: cbmf, delt, precip, qprime, tprime, wd
+ !
+ !Local variables
+ !
+ integer :: i, icb, ihmin, inb, inb1, j, jtt, k
+ integer :: nk
+ !
+ real :: ad, afac, ahmax, ahmin, alt, altem
+ real :: am, amp1, anum, asij, awat, b6, bf2, bsum, by
+ real :: byp, c6, cape, capem, cbmfold, chi, coeff
+ real :: cpinv, cwat, damps, dbo, dbosum
+ real :: defrac, dei, delm, delp, delt0, delti, denom, dhdp
+ real :: dpinv, dtma, dtmin, dtpbl, elacrit, ents
+ real :: epmax, fac, fqold, frac, ftold
+ real :: plcl, qp1, qsm, qstm, qti, rat
+ real :: rdcp, revap, rh, scrit, sigt, sjmax
+ real :: sjmin, smid, smin, stemp, tca
+ real :: tvaplcl, tvpplcl, tvx, tvy, wdtrain
+
+ !integer jc,jn
+ !real alvnew,a2,ahm,alv,rm,sum,qnew,dphinv,tc,thbar,tnew,x
+
+ real :: FUP(NA),FDOWN(NA)
+ !
+ !-cv====>End Module CONVECT File convect.f
+
+ INTEGER :: NENT(NA)
+ REAL :: M(NA),MP(NA),MENT(NA,NA),QENT(NA,NA),ELIJ(NA,NA)
+ REAL :: SIJ(NA,NA),TVP(NA),TV(NA),WATER(NA)
+ REAL :: QP(NA),EP(NA),TH(NA),WT(NA),EVAP(NA),CLW(NA)
+ REAL :: SIGP(NA),TP(NA),CPN(NA)
+ REAL :: LV(NA),LVCP(NA),H(NA),HP(NA),GZ(NA),HM(NA)
+ !REAL TOLD(NA)
+ !
+ ! -----------------------------------------------------------------------
+ !
+ ! *** Specify Switches ***
+ !
+ ! *** IPBL: Set to zero to bypass dry adiabatic adjustment ***
+ ! *** Any other value results in dry adiabatic adjustment ***
+ ! *** (Zero value recommended for use in models with ***
+ ! *** boundary layer schemes) ***
+ !
+ ! *** MINORIG: Lowest level from which convection may originate ***
+ ! *** (Should be first model level at which T is defined ***
+ ! *** for models using bulk PBL schemes; otherwise, it should ***
+ ! *** be the first model level at which T is defined above ***
+ ! *** the surface layer) ***
+ !
+ INTEGER,PARAMETER :: IPBL=0
+ INTEGER,PARAMETER :: MINORIG=1
+ !
+ !------------------------------------------------------------------------------
+ !
+ ! *** SPECIFY PARAMETERS ***
+ !
+ ! *** ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm) ***
+ ! *** TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO- ***
+ ! *** CONVERSION THRESHOLD IS ASSUMED TO BE ZERO ***
+ ! *** (THE AUTOCONVERSION THRESHOLD VARIES LINEARLY ***
+ ! *** BETWEEN 0 C AND TLCRIT) ***
+ ! *** ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT ***
+ ! *** FORMULATION ***
+ ! *** SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT ***
+ ! *** SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE ***
+ ! *** OF CLOUD ***
+ ! *** OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN ***
+ ! *** OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW ***
+ ! *** COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION ***
+ ! *** OF RAIN ***
+ ! *** COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION ***
+ ! *** OF SNOW ***
+ ! *** CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM ***
+ ! *** TRANSPORT ***
+ ! *** DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION ***
+ ! *** A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC ***
+ ! *** ALPHA AND DAMP ARE PARAMETERS THAT CONTROL THE RATE OF ***
+ ! *** APPROACH TO QUASI-EQUILIBRIUM ***
+ ! *** (THEIR STANDARD VALUES ARE 0.20 AND 0.1, RESPECTIVELY) ***
+ ! *** (DAMP MUST BE LESS THAN 1) ***
+ !
+ REAL,PARAMETER :: ELCRIT=.0011
+ REAL,PARAMETER :: TLCRIT=-55.0
+ REAL,PARAMETER :: ENTP=1.5
+ REAL,PARAMETER :: SIGD=0.05
+ REAL,PARAMETER :: SIGS=0.12
+ REAL,PARAMETER :: OMTRAIN=50.0
+ REAL,PARAMETER :: OMTSNOW=5.5
+ REAL,PARAMETER :: COEFFR=1.0
+ REAL,PARAMETER :: COEFFS=0.8
+ REAL,PARAMETER :: CU=0.7
+ REAL,PARAMETER :: BETA=10.0
+ REAL,PARAMETER :: DTMAX=0.9
+ REAL,PARAMETER :: ALPHA=0.025 !original 0.2
+ REAL,PARAMETER :: DAMP=0.1
+ !
+ ! *** ASSIGN VALUES OF THERMODYNAMIC CONSTANTS, ***
+ ! *** GRAVITY, AND LIQUID WATER DENSITY. ***
+ ! *** THESE SHOULD BE CONSISTENT WITH ***
+ ! *** THOSE USED IN CALLING PROGRAM ***
+ ! *** NOTE: THESE ARE ALSO SPECIFIED IN SUBROUTINE TLIFT ***
+ !
+ REAL,PARAMETER :: CPD=1005.7
+ REAL,PARAMETER :: CPV=1870.0
+ REAL,PARAMETER :: CL=2500.0
+ REAL,PARAMETER :: RV=461.5
+ REAL,PARAMETER :: RD=287.04
+ REAL,PARAMETER :: LV0=2.501E6
+ REAL,PARAMETER :: G=9.81
+ REAL,PARAMETER :: ROWL=1000.0
+ !
+ REAL,PARAMETER :: CPVMCL=CL-CPV
+ REAL,PARAMETER :: EPS0=RD/RV
+ REAL,PARAMETER :: EPSI=1./EPS0
+ REAL,PARAMETER :: GINV=1.0/G
+ REAL,PARAMETER :: EPSILON=1.e-20
+
+ ! EPSILON IS A SMALL NUMBER USED TO EXCLUDE MASS FLUXES OF ZERO
+ !
+ DELTI=1.0/DELT
+ !
+ ! *** INITIALIZE OUTPUT ARRAYS AND PARAMETERS ***
+ !
+
+ DO I=1,NL+1
+ FT(I)=0.0
+ FQ(I)=0.0
+ FDOWN(I)=0.0
+ SUB(I)=0.0
+ FUP(I)=0.0
+ M(I)=0.0
+ MP(I)=0.0
+ DO J=1,NL+1
+ FMASS(I,J)=0.0
+ MENT(I,J)=0.0
+ END DO
+ END DO
+ DO I=1,NL+1
+ RDCP=(RD*(1.-QCONV(I))+QCONV(I)*RV)/ &
+ (CPD*(1.-QCONV(I))+QCONV(I)*CPV)
+ TH(I)=TCONV(I)*(1000.0/PCONV_HPA(I))**RDCP
+ END DO
+ PRECIP=0.0
+ WD=0.0
+ TPRIME=0.0
+ QPRIME=0.0
+ IFLAG=0
+ !
+ ! IF(IPBL.NE.0)THEN
+ !
+ !*** PERFORM DRY ADIABATIC ADJUSTMENT ***
+ !
+ ! JC=0
+ ! DO 30 I=NL-1,1,-1
+ ! JN=0
+ ! SUM=TH(I)*(1.+QCONV(I)*EPSI-QCONV(I))
+ ! DO 10 J=I+1,NL
+ ! SUM=SUM+TH(J)*(1.+QCONV(J)*EPSI-QCONV(J))
+ ! THBAR=SUM/REAL(J+1-I)
+ ! IF((TH(J)*(1.+QCONV(J)*EPSI-QCONV(J))).LT.THBAR)JN=J
+ ! 10 CONTINUE
+ ! IF(I.EQ.1)JN=MAX(JN,2)
+ ! IF(JN.EQ.0)GOTO 30
+ ! 12 CONTINUE
+ ! AHM=0.0
+ ! RM=0.0
+ ! DO 15 J=I,JN
+ ! AHM=AHM+(CPD*(1.-QCONV(J))+QCONV(J)*CPV)*TCONV(J)*
+ ! + (PHCONV_HPA(J)-PHCONV_HPA(J+1))
+ ! RM=RM+QCONV(J)*(PHCONV_HPA(J)-PHCONV_HPA(J+1))
+ ! 15 CONTINUE
+ ! DPHINV=1./(PHCONV_HPA(I)-PHCONV_HPA(JN+1))
+ ! RM=RM*DPHINV
+ ! A2=0.0
+ ! DO 20 J=I,JN
+ ! QCONV(J)=RM
+ ! RDCP=(RD*(1.-QCONV(J))+QCONV(J)*RV)/
+ ! 1 (CPD*(1.-QCONV(J))+QCONV(J)*CPV)
+ ! X=(0.001*PCONV_HPA(J))**RDCP
+ ! TOLD(J)=TCONV(J)
+ ! TCONV(J)=X
+ ! A2=A2+(CPD*(1.-QCONV(J))+QCONV(J)*CPV)*X*
+ ! 1 (PHCONV_HPA(J)-PHCONV_HPA(J+1))
+ ! 20 CONTINUE
+ ! DO 25 J=I,JN
+ ! TH(J)=AHM/A2
+ ! TCONV(J)=TCONV(J)*TH(J)
+ ! TC=TOLD(J)-273.15
+ ! ALV=LV0-CPVMCL*TC
+ ! QSCONV(J)=QSCONV(J)+QSCONV(J)*(1.+QSCONV(J)*(EPSI-1.))*ALV*
+ ! 1 (TCONV(J)- TOLD(J))/(RV*TOLD(J)*TOLD(J))
+ ! if (qslev(j) .lt. 0.) then
+ ! write(*,*) 'qslev.lt.0 ',j,qslev
+ ! endif
+ ! 25 CONTINUE
+ ! IF((TH(JN+1)*(1.+QCONV(JN+1)*EPSI-QCONV(JN+1))).LT.
+ ! 1 (TH(JN)*(1.+QCONV(JN)*EPSI-QCONV(JN))))THEN
+ ! JN=JN+1
+ ! GOTO 12
+ ! END IF
+ ! IF(I.EQ.1)JC=JN
+ ! 30 CONTINUE
+ !
+ ! *** Remove any supersaturation that results from adjustment ***
+ !
+ !IF(JC.GT.1)THEN
+ ! DO 38 J=1,JC
+ ! IF(QSCONV(J).LT.QCONV(J))THEN
+ ! ALV=LV0-CPVMCL*(TCONV(J)-273.15)
+ ! TNEW=TCONV(J)+ALV*(QCONV(J)-QSCONV(J))/(CPD*(1.-QCONV(J))+
+ ! 1 CL*QCONV(J)+QSCONV(J)*(CPV-CL+ALV*ALV/(RV*TCONV(J)*TCONV(J))))
+ ! ALVNEW=LV0-CPVMCL*(TNEW-273.15)
+ ! QNEW=(ALV*QCONV(J)-(TNEW-TCONV(J))*(CPD*(1.-QCONV(J))
+ ! 1 +CL*QCONV(J)))/ALVNEW
+ ! PRECIP=PRECIP+24.*3600.*1.0E5*(PHCONV_HPA(J)-PHCONV_HPA(J+1))*
+ ! 1 (QCONV(J)-QNEW)/(G*DELT*ROWL)
+ ! TCONV(J)=TNEW
+ ! QCONV(J)=QNEW
+ ! QSCONV(J)=QNEW
+ ! END IF
+ ! 38 CONTINUE
+ !END IF
+ !
+ !END IF
+ !
+ ! *** CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY AND STATIC ENERGY
+ !
+ GZ(1)=0.0
+ CPN(1)=CPD*(1.-QCONV(1))+QCONV(1)*CPV
+ H(1)=TCONV(1)*CPN(1)
+ LV(1)=LV0-CPVMCL*(TCONV(1)-273.15)
+ HM(1)=LV(1)*QCONV(1)
+ TV(1)=TCONV(1)*(1.+QCONV(1)*EPSI-QCONV(1))
+ AHMIN=1.0E12
+ IHMIN=NL
+ DO I=2,NL+1
+ TVX=TCONV(I)*(1.+QCONV(I)*EPSI-QCONV(I))
+ TVY=TCONV(I-1)*(1.+QCONV(I-1)*EPSI-QCONV(I-1))
+ GZ(I)=GZ(I-1)+0.5*RD*(TVX+TVY)*(PCONV_HPA(I-1)-PCONV_HPA(I))/ &
+ PHCONV_HPA(I)
+ CPN(I)=CPD*(1.-QCONV(I))+CPV*QCONV(I)
+ H(I)=TCONV(I)*CPN(I)+GZ(I)
+ LV(I)=LV0-CPVMCL*(TCONV(I)-273.15)
+ HM(I)=(CPD*(1.-QCONV(I))+CL*QCONV(I))*(TCONV(I)-TCONV(1))+ &
+ LV(I)*QCONV(I)+GZ(I)
+ TV(I)=TCONV(I)*(1.+QCONV(I)*EPSI-QCONV(I))
+ !
+ ! *** Find level of minimum moist static energy ***
+ !
+ IF(I.GE.MINORIG.AND.HM(I).LT.AHMIN.AND.HM(I).LT.HM(I-1))THEN
+ AHMIN=HM(I)
+ IHMIN=I
+ END IF
+ END DO
+ IHMIN=MIN(IHMIN, NL-1)
+ !
+ ! *** Find that model level below the level of minimum moist ***
+ ! *** static energy that has the maximum value of moist static energy ***
+ !
+ AHMAX=0.0
+ ! *** bug fixed: need to assign an initial value to NK
+ ! HSO, 05.08.2009
+ NK=MINORIG
+ DO I=MINORIG,IHMIN
+ IF(HM(I).GT.AHMAX)THEN
+ NK=I
+ AHMAX=HM(I)
+ END IF
+ END DO
+ !
+ ! *** CHECK WHETHER PARCEL LEVEL TEMPERATURE AND SPECIFIC HUMIDITY ***
+ ! *** ARE REASONABLE ***
+ ! *** Skip convection if HM increases monotonically upward ***
+ !
+ IF(TCONV(NK).LT.250.0.OR.QCONV(NK).LE.0.0.OR.IHMIN.EQ.(NL-1)) &
+ THEN
+ IFLAG=0
+ CBMF=0.0
+ RETURN
+ END IF
+ !
+ ! *** CALCULATE LIFTED CONDENSATION LEVEL OF AIR AT PARCEL ORIGIN LEVEL ***
+ ! *** (WITHIN 0.2% OF FORMULA OF BOLTON, MON. WEA. REV.,1980) ***
+ !
+ RH=QCONV(NK)/QSCONV(NK)
+ CHI=TCONV(NK)/(1669.0-122.0*RH-TCONV(NK))
+ PLCL=PCONV_HPA(NK)*(RH**CHI)
+ IF(PLCL.LT.200.0.OR.PLCL.GE.2000.0)THEN
+ IFLAG=2
+ CBMF=0.0
+ RETURN
+ END IF
+ !
+ ! *** CALCULATE FIRST LEVEL ABOVE LCL (=ICB) ***
+ !
+ ICB=NL-1
+ DO I=NK+1,NL
+ IF(PCONV_HPA(I).LT.PLCL)THEN
+ ICB=MIN(ICB,I)
+ END IF
+ END DO
+ IF(ICB.GE.(NL-1))THEN
+ IFLAG=3
+ CBMF=0.0
+ RETURN
+ END IF
+ !
+ ! *** FIND TEMPERATURE UP THROUGH ICB AND TEST FOR INSTABILITY ***
+ !
+ ! *** SUBROUTINE TLIFT CALCULATES PART OF THE LIFTED PARCEL VIRTUAL ***
+ ! *** TEMPERATURE, THE ACTUAL TEMPERATURE AND THE ADIABATIC ***
+ ! *** LIQUID WATER CONTENT ***
+ !
+ CALL TLIFT(GZ,ICB,NK,TVP,TP,CLW,ND,NL,1)
+ DO I=NK,ICB
+ TVP(I)=TVP(I)-TP(I)*QCONV(NK)
+ END DO
+ !
+ ! *** If there was no convection at last time step and parcel ***
+ ! *** is stable at ICB then skip rest of calculation ***
+ !
+ IF(CBMF.EQ.0.0.AND.TVP(ICB).LE.(TV(ICB)-DTMAX))THEN
+ IFLAG=0
+ RETURN
+ END IF
+ !
+ ! *** IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY ***
+ !
+ IF(IFLAG.NE.4)IFLAG=1
+ !
+ ! *** FIND THE REST OF THE LIFTED PARCEL TEMPERATURES ***
+ !
+ CALL TLIFT(GZ,ICB,NK,TVP,TP,CLW,ND,NL,2)
+ !
+ ! *** SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF ***
+ ! *** PRECIPITATION FALLING OUTSIDE OF CLOUD ***
+ ! *** THESE MAY BE FUNCTIONS OF TP(I), PCONV_HPA(I) AND CLW(I) ***
+ !
+ DO I=1,NK
+ EP(I)=0.0
+ SIGP(I)=SIGS
+ END DO
+ DO I=NK+1,NL
+ TCA=TP(I)-273.15
+ IF(TCA.GE.0.0)THEN
+ ELACRIT=ELCRIT
+ ELSE
+ ELACRIT=ELCRIT*(1.0-TCA/TLCRIT)
+ END IF
+ ELACRIT=MAX(ELACRIT,0.0)
+ EPMAX=0.999
+ EP(I)=EPMAX*(1.0-ELACRIT/MAX(CLW(I),1.0E-8))
+ EP(I)=MAX(EP(I),0.0)
+ EP(I)=MIN(EP(I),EPMAX)
+ SIGP(I)=SIGS
+ END DO
+ !
+ ! *** CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL ***
+ ! *** VIRTUAL TEMPERATURE ***
+ !
+ DO I=ICB+1,NL
+ TVP(I)=TVP(I)-TP(I)*QCONV(NK)
+ END DO
+ TVP(NL+1)=TVP(NL)-(GZ(NL+1)-GZ(NL))/CPD
+ !
+ ! *** NOW INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS ***
+ !
+ DO I=1,NL+1
+ HP(I)=H(I)
+ NENT(I)=0
+ WATER(I)=0.0
+ EVAP(I)=0.0
+ WT(I)=OMTSNOW
+ LVCP(I)=LV(I)/CPN(I)
+ DO J=1,NL+1
+ QENT(I,J)=QCONV(J)
+ ELIJ(I,J)=0.0
+ SIJ(I,J)=0.0
+ END DO
+ END DO
+ QP(1)=QCONV(1)
+ DO I=2,NL+1
+ QP(I)=QCONV(I-1)
+ END DO
+ !
+ ! *** FIND THE FIRST MODEL LEVEL (INB1) ABOVE THE PARCEL'S ***
+ ! *** HIGHEST LEVEL OF NEUTRAL BUOYANCY ***
+ ! *** AND THE HIGHEST LEVEL OF POSITIVE CAPE (INB) ***
+ !
+ CAPE=0.0
+ CAPEM=0.0
+ INB=ICB+1
+ INB1=INB
+ BYP=0.0
+ DO I=ICB+1,NL-1
+ BY=(TVP(I)-TV(I))*(PHCONV_HPA(I)-PHCONV_HPA(I+1))/PCONV_HPA(I)
+ CAPE=CAPE+BY
+ IF(BY.GE.0.0)INB1=I+1
+ IF(CAPE.GT.0.0)THEN
+ INB=I+1
+ BYP=(TVP(I+1)-TV(I+1))*(PHCONV_HPA(I+1)-PHCONV_HPA(I+2))/ &
+ PCONV_HPA(I+1)
+ CAPEM=CAPE
+ END IF
+ END DO
+ INB=MAX(INB,INB1)
+ CAPE=CAPEM+BYP
+ DEFRAC=CAPEM-CAPE
+ DEFRAC=MAX(DEFRAC,0.001)
+ FRAC=-CAPE/DEFRAC
+ FRAC=MIN(FRAC,1.0)
+ FRAC=MAX(FRAC,0.0)
+ !
+ ! *** CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL ***
+ !
+ DO I=ICB,INB
+ HP(I)=H(NK)+(LV(I)+(CPD-CPV)*TCONV(I))*EP(I)*CLW(I)
+ END DO
+ !
+ ! *** CALCULATE CLOUD BASE MASS FLUX AND RATES OF MIXING, M(I), ***
+ ! *** AT EACH MODEL LEVEL ***
+ !
+ DBOSUM=0.0
+ !
+ ! *** INTERPOLATE DIFFERENCE BETWEEN LIFTED PARCEL AND ***
+ ! *** ENVIRONMENTAL TEMPERATURES TO LIFTED CONDENSATION LEVEL ***
+ !
+ TVPPLCL=TVP(ICB-1)-RD*TVP(ICB-1)*(PCONV_HPA(ICB-1)-PLCL)/ &
+ (CPN(ICB-1)*PCONV_HPA(ICB-1))
+ TVAPLCL=TV(ICB)+(TVP(ICB)-TVP(ICB+1))*(PLCL-PCONV_HPA(ICB))/ &
+ (PCONV_HPA(ICB)-PCONV_HPA(ICB+1))
+ DTPBL=0.0
+ DO I=NK,ICB-1
+ DTPBL=DTPBL+(TVP(I)-TV(I))*(PHCONV_HPA(I)-PHCONV_HPA(I+1))
+ END DO
+ DTPBL=DTPBL/(PHCONV_HPA(NK)-PHCONV_HPA(ICB))
+ DTMIN=TVPPLCL-TVAPLCL+DTMAX+DTPBL
+ DTMA=DTMIN
+ !
+ ! *** ADJUST CLOUD BASE MASS FLUX ***
+ !
+ CBMFOLD=CBMF
+ ! *** C. Forster: adjustment of CBMF is not allowed to depend on FLEXPART timestep
+ DELT0=DELT/3.
+ DAMPS=DAMP*DELT/DELT0
+ CBMF=(1.-DAMPS)*CBMF+0.1*ALPHA*DTMA
+ CBMF=MAX(CBMF,0.0)
+ !
+ ! *** If cloud base mass flux is zero, skip rest of calculation ***
+ !
+ IF(CBMF.EQ.0.0.AND.CBMFOLD.EQ.0.0)THEN
+ RETURN
+ END IF
+
+ !
+ ! *** CALCULATE RATES OF MIXING, M(I) ***
+ !
+ M(ICB)=0.0
+ DO I=ICB+1,INB
+ K=MIN(I,INB1)
+ DBO=ABS(TV(K)-TVP(K))+ &
+ ENTP*0.02*(PHCONV_HPA(K)-PHCONV_HPA(K+1))
+ DBOSUM=DBOSUM+DBO
+ M(I)=CBMF*DBO
+ END DO
+ DO I=ICB+1,INB
+ M(I)=M(I)/DBOSUM
+ END DO
+ !
+ ! *** CALCULATE ENTRAINED AIR MASS FLUX (MENT), TOTAL WATER MIXING ***
+ ! *** RATIO (QENT), TOTAL CONDENSED WATER (ELIJ), AND MIXING ***
+ ! *** FRACTION (SIJ) ***
+ !
+ DO I=ICB+1,INB
+ QTI=QCONV(NK)-EP(I)*CLW(I)
+ DO J=ICB,INB
+ BF2=1.+LV(J)*LV(J)*QSCONV(J)/(RV*TCONV(J)*TCONV(J)*CPD)
+ ANUM=H(J)-HP(I)+(CPV-CPD)*TCONV(J)*(QTI-QCONV(J))
+ DENOM=H(I)-HP(I)+(CPD-CPV)*(QCONV(I)-QTI)*TCONV(J)
+ DEI=DENOM
+ IF(ABS(DEI).LT.0.01)DEI=0.01
+ SIJ(I,J)=ANUM/DEI
+ SIJ(I,I)=1.0
+ ALTEM=SIJ(I,J)*QCONV(I)+(1.-SIJ(I,J))*QTI-QSCONV(J)
+ ALTEM=ALTEM/BF2
+ CWAT=CLW(J)*(1.-EP(J))
+ STEMP=SIJ(I,J)
+ IF((STEMP.LT.0.0.OR.STEMP.GT.1.0.OR. &
+ ALTEM.GT.CWAT).AND.J.GT.I)THEN
+ ANUM=ANUM-LV(J)*(QTI-QSCONV(J)-CWAT*BF2)
+ DENOM=DENOM+LV(J)*(QCONV(I)-QTI)
+ IF(ABS(DENOM).LT.0.01)DENOM=0.01
+ SIJ(I,J)=ANUM/DENOM
+ ALTEM=SIJ(I,J)*QCONV(I)+(1.-SIJ(I,J))*QTI-QSCONV(J)
+ ALTEM=ALTEM-(BF2-1.)*CWAT
+ END IF
+ IF(SIJ(I,J).GT.0.0.AND.SIJ(I,J).LT.0.9)THEN
+ QENT(I,J)=SIJ(I,J)*QCONV(I)+(1.-SIJ(I,J))*QTI
+ ELIJ(I,J)=ALTEM
+ ELIJ(I,J)=MAX(0.0,ELIJ(I,J))
+ MENT(I,J)=M(I)/(1.-SIJ(I,J))
+ NENT(I)=NENT(I)+1
+ END IF
+ SIJ(I,J)=MAX(0.0,SIJ(I,J))
+ SIJ(I,J)=MIN(1.0,SIJ(I,J))
+ END DO
+ !
+ ! *** IF NO AIR CAN ENTRAIN AT LEVEL I ASSUME THAT UPDRAFT DETRAINS ***
+ ! *** AT THAT LEVEL AND CALCULATE DETRAINED AIR FLUX AND PROPERTIES ***
+ !
+ IF(NENT(I).EQ.0)THEN
+ MENT(I,I)=M(I)
+ QENT(I,I)=QCONV(NK)-EP(I)*CLW(I)
+ ELIJ(I,I)=CLW(I)
+ SIJ(I,I)=1.0
+ END IF
+ END DO
+ SIJ(INB,INB)=1.0
+ !
+ ! *** NORMALIZE ENTRAINED AIR MASS FLUXES TO REPRESENT EQUAL ***
+ ! *** PROBABILITIES OF MIXING ***
+ !
+ DO I=ICB+1,INB
+ IF(NENT(I).NE.0)THEN
+ QP1=QCONV(NK)-EP(I)*CLW(I)
+ ANUM=H(I)-HP(I)-LV(I)*(QP1-QSCONV(I))
+ DENOM=H(I)-HP(I)+LV(I)*(QCONV(I)-QP1)
+ IF(ABS(DENOM).LT.0.01)DENOM=0.01
+ SCRIT=ANUM/DENOM
+ ALT=QP1-QSCONV(I)+SCRIT*(QCONV(I)-QP1)
+ IF(ALT.LT.0.0)SCRIT=1.0
+ SCRIT=MAX(SCRIT,0.0)
+ ASIJ=0.0
+ SMIN=1.0
+ DO J=ICB,INB
+ IF(SIJ(I,J).GT.0.0.AND.SIJ(I,J).LT.0.9)THEN
+ IF(J.GT.I)THEN
+ SMID=MIN(SIJ(I,J),SCRIT)
+ SJMAX=SMID
+ SJMIN=SMID
+ IF(SMID.LT.SMIN.AND.SIJ(I,J+1).LT.SMID)THEN
+ SMIN=SMID
+ SJMAX=MIN(SIJ(I,J+1),SIJ(I,J),SCRIT)
+ SJMIN=MAX(SIJ(I,J-1),SIJ(I,J))
+ SJMIN=MIN(SJMIN,SCRIT)
+ END IF
+ ELSE
+ SJMAX=MAX(SIJ(I,J+1),SCRIT)
+ SMID=MAX(SIJ(I,J),SCRIT)
+ SJMIN=0.0
+ IF(J.GT.1)SJMIN=SIJ(I,J-1)
+ SJMIN=MAX(SJMIN,SCRIT)
+ END IF
+ DELP=ABS(SJMAX-SMID)
+ DELM=ABS(SJMIN-SMID)
+ ASIJ=ASIJ+(DELP+DELM)*(PHCONV_HPA(J)-PHCONV_HPA(J+1))
+ MENT(I,J)=MENT(I,J)*(DELP+DELM)* &
+ (PHCONV_HPA(J)-PHCONV_HPA(J+1))
+ END IF
+ END DO
+ ASIJ=MAX(1.0E-21,ASIJ)
+ ASIJ=1.0/ASIJ
+ DO J=ICB,INB
+ MENT(I,J)=MENT(I,J)*ASIJ
+ END DO
+ BSUM=0.0
+ DO J=ICB,INB
+ BSUM=BSUM+MENT(I,J)
+ END DO
+ IF(BSUM.LT.1.0E-18)THEN
+ NENT(I)=0
+ MENT(I,I)=M(I)
+ QENT(I,I)=QCONV(NK)-EP(I)*CLW(I)
+ ELIJ(I,I)=CLW(I)
+ SIJ(I,I)=1.0
+ END IF
+ END IF
+ END DO
+ !
+ ! *** CHECK WHETHER EP(INB)=0, IF SO, SKIP PRECIPITATING ***
+ ! *** DOWNDRAFT CALCULATION ***
+ !
+ IF(EP(INB).LT.0.0001)GOTO 405
+ !
+ ! *** INTEGRATE LIQUID WATER EQUATION TO FIND CONDENSED WATER ***
+ ! *** AND CONDENSED WATER FLUX ***
+ !
+ JTT=2
+ !
+ ! *** BEGIN DOWNDRAFT LOOP ***
+ !
+ DO I=INB,1,-1
+ !
+ ! *** CALCULATE DETRAINED PRECIPITATION ***
+ !
+ WDTRAIN=G*EP(I)*M(I)*CLW(I)
+ IF(I.GT.1)THEN
+ DO J=1,I-1
+ AWAT=ELIJ(J,I)-(1.-EP(I))*CLW(I)
+ AWAT=MAX(0.0,AWAT)
+ WDTRAIN=WDTRAIN+G*AWAT*MENT(J,I)
+ END DO
+ END IF
+ !
+ ! *** FIND RAIN WATER AND EVAPORATION USING PROVISIONAL ***
+ ! *** ESTIMATES OF QP(I)AND QP(I-1) ***
+ !
+ !
+ ! *** Value of terminal velocity and coefficient of evaporation for snow ***
+ !
+ COEFF=COEFFS
+ WT(I)=OMTSNOW
+ !
+ ! *** Value of terminal velocity and coefficient of evaporation for rain ***
+ !
+ IF(TCONV(I).GT.273.0)THEN
+ COEFF=COEFFR
+ WT(I)=OMTRAIN
+ END IF
+ QSM=0.5*(QCONV(I)+QP(I+1))
+ AFAC=COEFF*PHCONV_HPA(I)*(QSCONV(I)-QSM)/ &
+ (1.0E4+2.0E3*PHCONV_HPA(I)*QSCONV(I))
+ AFAC=MAX(AFAC,0.0)
+ SIGT=SIGP(I)
+ SIGT=MAX(0.0,SIGT)
+ SIGT=MIN(1.0,SIGT)
+ B6=100.*(PHCONV_HPA(I)-PHCONV_HPA(I+1))*SIGT*AFAC/WT(I)
+ C6=(WATER(I+1)*WT(I+1)+WDTRAIN/SIGD)/WT(I)
+ REVAP=0.5*(-B6+SQRT(B6*B6+4.*C6))
+ EVAP(I)=SIGT*AFAC*REVAP
+ WATER(I)=REVAP*REVAP
+ !
+ ! *** CALCULATE PRECIPITATING DOWNDRAFT MASS FLUX UNDER ***
+ ! *** HYDROSTATIC APPROXIMATION ***
+ !
+ IF(I.EQ.1)GOTO 360
+ DHDP=(H(I)-H(I-1))/(PCONV_HPA(I-1)-PCONV_HPA(I))
+ DHDP=MAX(DHDP,10.0)
+ MP(I)=100.*GINV*LV(I)*SIGD*EVAP(I)/DHDP
+ MP(I)=MAX(MP(I),0.0)
+ !
+ ! *** ADD SMALL AMOUNT OF INERTIA TO DOWNDRAFT ***
+ !
+ FAC=20.0/(PHCONV_HPA(I-1)-PHCONV_HPA(I))
+ MP(I)=(FAC*MP(I+1)+MP(I))/(1.+FAC)
+ !
+ ! *** FORCE MP TO DECREASE LINEARLY TO ZERO ***
+ ! *** BETWEEN ABOUT 950 MB AND THE SURFACE ***
+ !
+ IF(PCONV_HPA(I).GT.(0.949*PCONV_HPA(1)))THEN
+ JTT=MAX(JTT,I)
+ MP(I)=MP(JTT)*(PCONV_HPA(1)-PCONV_HPA(I))/(PCONV_HPA(1)- &
+ PCONV_HPA(JTT))
+ END IF
+ 360 CONTINUE
+ !
+ ! *** FIND MIXING RATIO OF PRECIPITATING DOWNDRAFT ***
+ !
+ IF(I.EQ.INB)GOTO 400
+ IF(I.EQ.1)THEN
+ QSTM=QSCONV(1)
+ ELSE
+ QSTM=QSCONV(I-1)
+ END IF
+ IF(MP(I).GT.MP(I+1))THEN
+ RAT=MP(I+1)/MP(I)
+ QP(I)=QP(I+1)*RAT+QCONV(I)*(1.0-RAT)+100.*GINV* &
+ SIGD*(PHCONV_HPA(I)-PHCONV_HPA(I+1))*(EVAP(I)/MP(I))
+ ELSE
+ IF(MP(I+1).GT.0.0)THEN
+ QP(I)=(GZ(I+1)-GZ(I)+QP(I+1)*(LV(I+1)+TCONV(I+1)*(CL-CPD))+ &
+ CPD*(TCONV(I+1)-TCONV(I)))/(LV(I)+TCONV(I)*(CL-CPD))
+ END IF
+ END IF
+ QP(I)=MIN(QP(I),QSTM)
+ QP(I)=MAX(QP(I),0.0)
+400 CONTINUE
+ END DO
+ !
+ ! *** CALCULATE SURFACE PRECIPITATION IN MM/DAY ***
+ !
+ PRECIP=PRECIP+WT(1)*SIGD*WATER(1)*3600.*24000./(ROWL*G)
+ !
+ 405 CONTINUE
+ !
+ ! *** CALCULATE DOWNDRAFT VELOCITY SCALE AND SURFACE TEMPERATURE AND ***
+ ! *** WATER VAPOR FLUCTUATIONS ***
+ !
+ WD=BETA*ABS(MP(ICB))*0.01*RD*TCONV(ICB)/(SIGD*PCONV_HPA(ICB))
+ QPRIME=0.5*(QP(1)-QCONV(1))
+ TPRIME=LV0*QPRIME/CPD
+ !
+ ! *** CALCULATE TENDENCIES OF LOWEST LEVEL POTENTIAL TEMPERATURE ***
+ ! *** AND MIXING RATIO ***
+ !
+ DPINV=0.01/(PHCONV_HPA(1)-PHCONV_HPA(2))
+ AM=0.0
+ IF(NK.EQ.1)THEN
+ DO K=2,INB
+ AM=AM+M(K)
+ END DO
+ END IF
+ ! save saturated upward mass flux for first level
+ FUP(1)=AM
+ IF((2.*G*DPINV*AM).GE.DELTI)IFLAG=4
+ FT(1)=FT(1)+G*DPINV*AM*(TCONV(2)-TCONV(1)+(GZ(2)-GZ(1))/CPN(1))
+ FT(1)=FT(1)-LVCP(1)*SIGD*EVAP(1)
+ FT(1)=FT(1)+SIGD*WT(2)*(CL-CPD)*WATER(2)*(TCONV(2)- &
+ TCONV(1))*DPINV/CPN(1)
+ FQ(1)=FQ(1)+G*MP(2)*(QP(2)-QCONV(1))* &
+ DPINV+SIGD*EVAP(1)
+ FQ(1)=FQ(1)+G*AM*(QCONV(2)-QCONV(1))*DPINV
+ DO J=2,INB
+ FQ(1)=FQ(1)+G*DPINV*MENT(J,1)*(QENT(J,1)-QCONV(1))
+ END DO
+ !
+ ! *** CALCULATE TENDENCIES OF POTENTIAL TEMPERATURE AND MIXING RATIO ***
+ ! *** AT LEVELS ABOVE THE LOWEST LEVEL ***
+ !
+ ! *** FIRST FIND THE NET SATURATED UPDRAFT AND DOWNDRAFT MASS FLUXES ***
+ ! *** THROUGH EACH LEVEL ***
+ !
+ DO I=2,INB
+ DPINV=0.01/(PHCONV_HPA(I)-PHCONV_HPA(I+1))
+ CPINV=1.0/CPN(I)
+ AMP1=0.0
+ AD=0.0
+ IF(I.GE.NK)THEN
+ DO K=I+1,INB+1
+ AMP1=AMP1+M(K)
+ END DO
+ END IF
+ DO K=1,I
+ DO J=I+1,INB+1
+ AMP1=AMP1+MENT(K,J)
+ END DO
+ END DO
+ ! save saturated upward mass flux
+ FUP(I)=AMP1
+ IF((2.*G*DPINV*AMP1).GE.DELTI)IFLAG=4
+ DO K=1,I-1
+ DO J=I,INB
+ AD=AD+MENT(J,K)
+ END DO
+ END DO
+ ! save saturated downward mass flux
+ FDOWN(I)=AD
+ FT(I)=FT(I)+G*DPINV*(AMP1*(TCONV(I+1)-TCONV(I)+(GZ(I+1)-GZ(I))* &
+ CPINV)-AD*(TCONV(I)-TCONV(I-1)+(GZ(I)-GZ(I-1))*CPINV)) &
+ -SIGD*LVCP(I)*EVAP(I)
+ FT(I)=FT(I)+G*DPINV*MENT(I,I)*(HP(I)-H(I)+ &
+ TCONV(I)*(CPV-CPD)*(QCONV(I)-QENT(I,I)))*CPINV
+ FT(I)=FT(I)+SIGD*WT(I+1)*(CL-CPD)*WATER(I+1)* &
+ (TCONV(I+1)-TCONV(I))*DPINV*CPINV
+ FQ(I)=FQ(I)+G*DPINV*(AMP1*(QCONV(I+1)-QCONV(I))- &
+ AD*(QCONV(I)-QCONV(I-1)))
+ DO K=1,I-1
+ AWAT=ELIJ(K,I)-(1.-EP(I))*CLW(I)
+ AWAT=MAX(AWAT,0.0)
+ FQ(I)=FQ(I)+G*DPINV*MENT(K,I)*(QENT(K,I)-AWAT-QCONV(I))
+ END DO
+ DO K=I,INB
+ FQ(I)=FQ(I)+G*DPINV*MENT(K,I)*(QENT(K,I)-QCONV(I))
+ END DO
+ FQ(I)=FQ(I)+SIGD*EVAP(I)+G*(MP(I+1)* &
+ (QP(I+1)-QCONV(I))-MP(I)*(QP(I)-QCONV(I-1)))*DPINV
+ END DO
+ !
+ ! *** Adjust tendencies at top of convection layer to reflect ***
+ ! *** actual position of the level zero CAPE ***
+ !
+ FQOLD=FQ(INB)
+ FQ(INB)=FQ(INB)*(1.-FRAC)
+ FQ(INB-1)=FQ(INB-1)+FRAC*FQOLD*((PHCONV_HPA(INB)- &
+ PHCONV_HPA(INB+1))/ &
+ (PHCONV_HPA(INB-1)-PHCONV_HPA(INB)))*LV(INB)/LV(INB-1)
+ FTOLD=FT(INB)
+ FT(INB)=FT(INB)*(1.-FRAC)
+ FT(INB-1)=FT(INB-1)+FRAC*FTOLD*((PHCONV_HPA(INB)- &
+ PHCONV_HPA(INB+1))/ &
+ (PHCONV_HPA(INB-1)-PHCONV_HPA(INB)))*CPN(INB)/CPN(INB-1)
+ !
+ ! *** Very slightly adjust tendencies to force exact ***
+ ! *** enthalpy, momentum and tracer conservation ***
+ !
+ ENTS=0.0
+ DO I=1,INB
+ ENTS=ENTS+(CPN(I)*FT(I)+LV(I)*FQ(I))* &
+ (PHCONV_HPA(I)-PHCONV_HPA(I+1))
+ END DO
+ ENTS=ENTS/(PHCONV_HPA(1)-PHCONV_HPA(INB+1))
+ DO I=1,INB
+ FT(I)=FT(I)-ENTS/CPN(I)
+ END DO
+
+ ! ************************************************
+ ! **** DETERMINE MASS DISPLACEMENT MATRIX
+ ! ***** AND COMPENSATING SUBSIDENCE
+ ! ************************************************
+
+ ! mass displacement matrix due to saturated up-and downdrafts
+ ! inside the cloud and determine compensating subsidence
+ ! FUP(I) (saturated updrafts), FDOWN(I) (saturated downdrafts) are assumed to be
+ ! balanced by compensating subsidence (SUB(I))
+ ! FDOWN(I) and SUB(I) defined positive downwards
+
+ ! NCONVTOP IS THE TOP LEVEL AT WHICH CONVECTIVE MASS FLUXES ARE DIAGNOSED
+ ! EPSILON IS A SMALL NUMBER
+
+ SUB(1)=0.
+ NCONVTOP=1
+ do i=1,INB+1
+ do j=1,INB+1
+ if (j.eq.NK) then
+ FMASS(j,i)=FMASS(j,i)+M(i)
+ endif
+ FMASS(j,i)=FMASS(j,i)+MENT(j,i)
+ IF (FMASS(J,I).GT.EPSILON) NCONVTOP=MAX(NCONVTOP,I,J)
+ end do
+ if (i.gt.1) then
+ SUB(i)=FUP(i-1)-FDOWN(i)
+ endif
+ end do
+ NCONVTOP=NCONVTOP+1
+
+ RETURN
+ !
+END SUBROUTINE CONVECT
+!
+! ---------------------------------------------------------------------------
+!
+SUBROUTINE TLIFT(GZ,ICB,NK,TVP,TPK,CLW,ND,NL,KK)
+ !
+ !-cv
+ use par_mod
+ use conv_mod
+
+ implicit none
+ !-cv
+ !====>Begin Module TLIFT File convect.f Undeclared variables
+ !
+ !Argument variables
+ !
+ integer :: icb, kk, nd, nk, nl
+ !
+ !Local variables
+ !
+ integer :: i, j, nsb, nst
+ !
+ real :: ah0, ahg, alv, cpinv, cpp, denom
+ real :: es, qg, rg, s, tc, tg
+ !
+ !====>End Module TLIFT File convect.f
+
+ REAL :: GZ(ND),TPK(ND),CLW(ND)
+ REAL :: TVP(ND)
+ !
+ ! *** ASSIGN VALUES OF THERMODYNAMIC CONSTANTS ***
+ !
+ REAL,PARAMETER :: CPD=1005.7
+ REAL,PARAMETER :: CPV=1870.0
+ REAL,PARAMETER :: CL=2500.0
+ REAL,PARAMETER :: RV=461.5
+ REAL,PARAMETER :: RD=287.04
+ REAL,PARAMETER :: LV0=2.501E6
+ !
+ REAL,PARAMETER :: CPVMCL=CL-CPV
+ REAL,PARAMETER :: EPS0=RD/RV
+ REAL,PARAMETER :: EPSI=1./EPS0
+ !
+ ! *** CALCULATE CERTAIN PARCEL QUANTITIES, INCLUDING STATIC ENERGY ***
+ !
+ AH0=(CPD*(1.-QCONV(NK))+CL*QCONV(NK))*TCONV(NK)+QCONV(NK)* &
+ (LV0-CPVMCL*( &
+ TCONV(NK)-273.15))+GZ(NK)
+ CPP=CPD*(1.-QCONV(NK))+QCONV(NK)*CPV
+ CPINV=1./CPP
+ !
+ IF(KK.EQ.1)THEN
+ !
+ ! *** CALCULATE LIFTED PARCEL QUANTITIES BELOW CLOUD BASE ***
+ !
+ DO I=1,ICB-1
+ CLW(I)=0.0
+ END DO
+ DO I=NK,ICB-1
+ TPK(I)=TCONV(NK)-(GZ(I)-GZ(NK))*CPINV
+ TVP(I)=TPK(I)*(1.+QCONV(NK)*EPSI)
+ END DO
+ END IF
+ !
+ ! *** FIND LIFTED PARCEL QUANTITIES ABOVE CLOUD BASE ***
+ !
+ NST=ICB
+ NSB=ICB
+ IF(KK.EQ.2)THEN
+ NST=NL
+ NSB=ICB+1
+ END IF
+ DO I=NSB,NST
+ TG=TCONV(I)
+ QG=QSCONV(I)
+ ALV=LV0-CPVMCL*(TCONV(I)-273.15)
+ DO J=1,2
+ S=CPD+ALV*ALV*QG/(RV*TCONV(I)*TCONV(I))
+ S=1./S
+ AHG=CPD*TG+(CL-CPD)*QCONV(NK)*TCONV(I)+ALV*QG+GZ(I)
+ TG=TG+S*(AH0-AHG)
+ TG=MAX(TG,35.0)
+ TC=TG-273.15
+ DENOM=243.5+TC
+ IF(TC.GE.0.0)THEN
+ ES=6.112*EXP(17.67*TC/DENOM)
+ ELSE
+ ES=EXP(23.33086-6111.72784/TG+0.15215*LOG(TG))
+ END IF
+ QG=EPS0*ES/(PCONV_HPA(I)-ES*(1.-EPS0))
+ END DO
+ ALV=LV0-CPVMCL*(TCONV(I)-273.15)
+ TPK(I)=(AH0-(CL-CPD)*QCONV(NK)*TCONV(I)-GZ(I)-ALV*QG)/CPD
+ CLW(I)=QCONV(NK)-QG
+ CLW(I)=MAX(0.0,CLW(I))
+ RG=QG/(1.-QCONV(NK))
+ TVP(I)=TPK(I)*(1.+RG*EPSI)
+ END DO
+ RETURN
+END SUBROUTINE TLIFT
diff --git a/src/convmix.f90 b/src/convmix.f90
new file mode 100644
index 0000000000000000000000000000000000000000..94af20f649a120d2215ae66a99bb45dc6059cecf
--- /dev/null
+++ b/src/convmix.f90
@@ -0,0 +1,299 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine convmix(itime)
+ ! i
+ !**************************************************************
+ !handles all the calculations related to convective mixing
+ !Petra Seibert, Bernd C. Krueger, Feb 2001
+ !nested grids included, Bernd C. Krueger, May 2001
+ !
+ !Changes by Caroline Forster, April 2004 - February 2005:
+ ! convmix called every lsynctime seconds
+ !CHANGES by A. Stohl:
+ ! various run-time optimizations - February 2005
+ !**************************************************************
+
+ use flux_mod
+ use par_mod
+ use com_mod
+ use conv_mod
+
+ implicit none
+
+ integer :: igr,igrold, ipart, itime, ix, j, inest
+ integer :: ipconv
+ integer :: jy, kpart, ktop, ngrid,kz
+ integer :: igrid(maxpart), ipoint(maxpart), igridn(maxpart,maxnests)
+ ! itime [s] current time
+ ! igrid(maxpart) horizontal grid position of each particle
+ ! igridn(maxpart,maxnests) dto. for nested grids
+ ! ipoint(maxpart) pointer to access particles according to grid position
+
+ logical :: lconv
+ real :: x, y, xtn,ytn, ztold, delt
+ real :: dt1,dt2,dtt
+ integer :: mind1,mind2
+ ! dt1,dt2,dtt,mind1,mind2 variables used for time interpolation
+ integer :: itage,nage
+ real,parameter :: eps=nxmax/3.e5
+
+
+ !monitoring variables
+ !real sumconv,sumall
+
+
+ ! Calculate auxiliary variables for time interpolation
+ !*****************************************************
+
+ dt1=real(itime-memtime(1))
+ dt2=real(memtime(2)-itime)
+ dtt=1./(dt1+dt2)
+ mind1=memind(1)
+ mind2=memind(2)
+ delt=real(abs(lsynctime))
+
+
+ lconv = .false.
+
+ ! if no particles are present return after initialization
+ !********************************************************
+
+ if (numpart.le.0) return
+
+ ! Assign igrid and igridn, which are pseudo grid numbers indicating particles
+ ! that are outside the part of the grid under consideration
+ ! (e.g. particles near the poles or particles in other nests).
+ ! Do this for all nests but use only the innermost nest; for all others
+ ! igrid shall be -1
+ ! Also, initialize index vector ipoint
+ !************************************************************************
+
+ do ipart=1,numpart
+ igrid(ipart)=-1
+ do j=numbnests,1,-1
+ igridn(ipart,j)=-1
+ end do
+ ipoint(ipart)=ipart
+ ! do not consider particles that are (yet) not part of simulation
+ if (itra1(ipart).ne.itime) goto 20
+ x = xtra1(ipart)
+ y = ytra1(ipart)
+
+ ! Determine which nesting level to be used
+ !**********************************************************
+
+ ngrid=0
+ do j=numbnests,1,-1
+ if ( x.gt.xln(j)+eps .and. x.lt.xrn(j)-eps .and. &
+ y.gt.yln(j)+eps .and. y.lt.yrn(j)-eps ) then
+ ngrid=j
+ goto 23
+ endif
+ end do
+ 23 continue
+
+ ! Determine nested grid coordinates
+ !**********************************
+
+ if (ngrid.gt.0) then
+ ! nested grids
+ xtn=(x-xln(ngrid))*xresoln(ngrid)
+ ytn=(y-yln(ngrid))*yresoln(ngrid)
+ ix=nint(xtn)
+ jy=nint(ytn)
+ igridn(ipart,ngrid) = 1 + jy*nxn(ngrid) + ix
+ else if(ngrid.eq.0) then
+ ! mother grid
+ ix=nint(x)
+ jy=nint(y)
+ igrid(ipart) = 1 + jy*nx + ix
+ endif
+
+ 20 continue
+ end do
+
+ !sumall = 0.
+ !sumconv = 0.
+
+ !*****************************************************************************
+ ! 1. Now, do everything for the mother domain and, later, for all of the nested domains
+ ! While all particles have to be considered for redistribution, the Emanuel convection
+ ! scheme only needs to be called once for every grid column where particles are present.
+ ! Therefore, particles are sorted according to their grid position. Whenever a new grid
+ ! cell is encountered by looping through the sorted particles, the convection scheme is called.
+ !*****************************************************************************
+
+ ! sort particles according to horizontal position and calculate index vector IPOINT
+
+ call sort2(numpart,igrid,ipoint)
+
+ ! Now visit all grid columns where particles are present
+ ! by going through the sorted particles
+
+ igrold = -1
+ do kpart=1,numpart
+ igr = igrid(kpart)
+ if (igr .eq. -1) goto 50
+ ipart = ipoint(kpart)
+ ! sumall = sumall + 1
+ if (igr .ne. igrold) then
+ ! we are in a new grid column
+ jy = (igr-1)/nx
+ ix = igr - jy*nx - 1
+
+ ! Interpolate all meteorological data needed for the convection scheme
+ psconv=(ps(ix,jy,1,mind1)*dt2+ps(ix,jy,1,mind2)*dt1)*dtt
+ tt2conv=(tt2(ix,jy,1,mind1)*dt2+tt2(ix,jy,1,mind2)*dt1)*dtt
+ td2conv=(td2(ix,jy,1,mind1)*dt2+td2(ix,jy,1,mind2)*dt1)*dtt
+!!$ do kz=1,nconvlev+1 !old
+ do kz=1,nuvz-1 !bugfix
+ tconv(kz)=(tth(ix,jy,kz+1,mind1)*dt2+ &
+ tth(ix,jy,kz+1,mind2)*dt1)*dtt
+ qconv(kz)=(qvh(ix,jy,kz+1,mind1)*dt2+ &
+ qvh(ix,jy,kz+1,mind2)*dt1)*dtt
+ end do
+
+ ! Calculate translocation matrix
+ call calcmatrix(lconv,delt,cbaseflux(ix,jy))
+ igrold = igr
+ ktop = 0
+ endif
+
+ ! treat particle only if column has convection
+ if (lconv .eqv. .true.) then
+ ! assign new vertical position to particle
+
+ ztold=ztra1(ipart)
+ call redist(ipart,ktop,ipconv)
+ ! if (ipconv.le.0) sumconv = sumconv+1
+
+ ! Calculate the gross fluxes across layer interfaces
+ !***************************************************
+
+ if (iflux.eq.1) then
+ itage=abs(itra1(ipart)-itramem(ipart))
+ do nage=1,nageclass
+ if (itage.lt.lage(nage)) goto 37
+ end do
+ 37 continue
+
+ if (nage.le.nageclass) &
+ call calcfluxes(nage,ipart,real(xtra1(ipart)), &
+ real(ytra1(ipart)),ztold)
+ endif
+
+ endif !(lconv .eqv. .true)
+ 50 continue
+ end do
+
+
+ !*****************************************************************************
+ ! 2. Nested domains
+ !*****************************************************************************
+
+ ! sort particles according to horizontal position and calculate index vector IPOINT
+
+ do inest=1,numbnests
+ do ipart=1,numpart
+ ipoint(ipart)=ipart
+ igrid(ipart) = igridn(ipart,inest)
+ enddo
+ call sort2(numpart,igrid,ipoint)
+
+ ! Now visit all grid columns where particles are present
+ ! by going through the sorted particles
+
+ igrold = -1
+ do kpart=1,numpart
+ igr = igrid(kpart)
+ if (igr .eq. -1) goto 60
+ ipart = ipoint(kpart)
+ ! sumall = sumall + 1
+ if (igr .ne. igrold) then
+ ! we are in a new grid column
+ jy = (igr-1)/nxn(inest)
+ ix = igr - jy*nxn(inest) - 1
+
+ ! Interpolate all meteorological data needed for the convection scheme
+ psconv=(psn(ix,jy,1,mind1,inest)*dt2+ &
+ psn(ix,jy,1,mind2,inest)*dt1)*dtt
+ tt2conv=(tt2n(ix,jy,1,mind1,inest)*dt2+ &
+ tt2n(ix,jy,1,mind2,inest)*dt1)*dtt
+ td2conv=(td2n(ix,jy,1,mind1,inest)*dt2+ &
+ td2n(ix,jy,1,mind2,inest)*dt1)*dtt
+!!$ do kz=1,nconvlev+1 !old
+ do kz=1,nuvz-1 !bugfix
+ tconv(kz)=(tthn(ix,jy,kz+1,mind1,inest)*dt2+ &
+ tthn(ix,jy,kz+1,mind2,inest)*dt1)*dtt
+ qconv(kz)=(qvhn(ix,jy,kz+1,mind1,inest)*dt2+ &
+ qvhn(ix,jy,kz+1,mind2,inest)*dt1)*dtt
+ end do
+
+ ! calculate translocation matrix
+ !*******************************
+ call calcmatrix(lconv,delt,cbasefluxn(ix,jy,inest))
+ igrold = igr
+ ktop = 0
+ endif
+
+ ! treat particle only if column has convection
+ if (lconv .eqv. .true.) then
+ ! assign new vertical position to particle
+ ztold=ztra1(ipart)
+ call redist(ipart,ktop,ipconv)
+ ! if (ipconv.le.0) sumconv = sumconv+1
+
+ ! Calculate the gross fluxes across layer interfaces
+ !***************************************************
+
+ if (iflux.eq.1) then
+ itage=abs(itra1(ipart)-itramem(ipart))
+ do nage=1,nageclass
+ if (itage.lt.lage(nage)) goto 47
+ end do
+ 47 continue
+
+ if (nage.le.nageclass) &
+ call calcfluxes(nage,ipart,real(xtra1(ipart)), &
+ real(ytra1(ipart)),ztold)
+ endif
+
+ endif !(lconv .eqv. .true.)
+
+
+60 continue
+ end do
+ end do
+ !--------------------------------------------------------------------------
+ !write(*,*)'############################################'
+ !write(*,*)'TIME=',
+ ! & itime
+ !write(*,*)'fraction of particles under convection',
+ ! & sumconv/(sumall+0.001)
+ !write(*,*)'total number of particles',
+ ! & sumall
+ !write(*,*)'number of particles under convection',
+ ! & sumconv
+ !write(*,*)'############################################'
+
+ return
+end subroutine convmix
diff --git a/src/convmix_gfs.f90 b/src/convmix_gfs.f90
new file mode 100644
index 0000000000000000000000000000000000000000..3059b5ed6b05cb1cdcf7192cd08f4c35b0b3f577
--- /dev/null
+++ b/src/convmix_gfs.f90
@@ -0,0 +1,303 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine convmix(itime)
+ ! i
+ !**************************************************************
+ !handles all the calculations related to convective mixing
+ !Petra Seibert, Bernd C. Krueger, Feb 2001
+ !nested grids included, Bernd C. Krueger, May 2001
+ !
+ !Changes by Caroline Forster, April 2004 - February 2005:
+ ! convmix called every lsynctime seconds
+ !CHANGES by A. Stohl:
+ ! various run-time optimizations - February 2005
+ !CHANGES by C. Forster, November 2005, NCEP GFS version
+ ! in the ECMWF version convection is calculated on the
+ ! original eta-levels
+ ! in the GFS version convection is calculated on the
+ ! FLEXPART levels
+ !**************************************************************
+
+ use par_mod
+ use com_mod
+ use conv_mod
+
+ implicit none
+
+ integer :: igr,igrold, ipart, itime, ix, j, inest
+ integer :: ipconv
+ integer :: jy, kpart, ktop, ngrid,kz
+ integer :: igrid(maxpart), ipoint(maxpart), igridn(maxpart,maxnests)
+ ! itime [s] current time
+ ! igrid(maxpart) horizontal grid position of each particle
+ ! igridn(maxpart,maxnests) dto. for nested grids
+ ! ipoint(maxpart) pointer to access particles according to grid position
+
+ logical :: lconv
+ real :: x, y, xtn,ytn, ztold, delt
+ real :: dt1,dt2,dtt
+ integer :: mind1,mind2
+ ! dt1,dt2,dtt,mind1,mind2 variables used for time interpolation
+ integer :: itage,nage
+
+ !monitoring variables
+ !real sumconv,sumall
+
+
+ ! Calculate auxiliary variables for time interpolation
+ !*****************************************************
+
+ dt1=real(itime-memtime(1))
+ dt2=real(memtime(2)-itime)
+ dtt=1./(dt1+dt2)
+ mind1=memind(1)
+ mind2=memind(2)
+ delt=real(abs(lsynctime))
+
+
+ lconv = .false.
+
+ ! if no particles are present return after initialization
+ !********************************************************
+
+ if (numpart.le.0) return
+
+ ! Assign igrid and igridn, which are pseudo grid numbers indicating particles
+ ! that are outside the part of the grid under consideration
+ ! (e.g. particles near the poles or particles in other nests).
+ ! Do this for all nests but use only the innermost nest; for all others
+ ! igrid shall be -1
+ ! Also, initialize index vector ipoint
+ !************************************************************************
+
+ do ipart=1,numpart
+ igrid(ipart)=-1
+ do j=numbnests,1,-1
+ igridn(ipart,j)=-1
+ end do
+ ipoint(ipart)=ipart
+ ! do not consider particles that are (yet) not part of simulation
+ if (itra1(ipart).ne.itime) goto 20
+ x = xtra1(ipart)
+ y = ytra1(ipart)
+
+ ! Determine which nesting level to be used
+ !**********************************************************
+
+ ngrid=0
+ do j=numbnests,1,-1
+ if ( x.gt.xln(j) .and. x.lt.xrn(j) .and. &
+ y.gt.yln(j) .and. y.lt.yrn(j) ) then
+ ngrid=j
+ goto 23
+ endif
+ end do
+ 23 continue
+
+ ! Determine nested grid coordinates
+ !**********************************
+
+ if (ngrid.gt.0) then
+ ! nested grids
+ xtn=(x-xln(ngrid))*xresoln(ngrid)
+ ytn=(y-yln(ngrid))*yresoln(ngrid)
+ ix=nint(xtn)
+ jy=nint(ytn)
+ igridn(ipart,ngrid) = 1 + jy*nxn(ngrid) + ix
+ else if(ngrid.eq.0) then
+ ! mother grid
+ ix=nint(x)
+ jy=nint(y)
+ igrid(ipart) = 1 + jy*nx + ix
+ endif
+
+ 20 continue
+ end do
+
+ !sumall = 0.
+ !sumconv = 0.
+
+ !*****************************************************************************
+ ! 1. Now, do everything for the mother domain and, later, for all of the nested domains
+ ! While all particles have to be considered for redistribution, the Emanuel convection
+ ! scheme only needs to be called once for every grid column where particles are present.
+ ! Therefore, particles are sorted according to their grid position. Whenever a new grid
+ ! cell is encountered by looping through the sorted particles, the convection scheme is called.
+ !*****************************************************************************
+
+ ! sort particles according to horizontal position and calculate index vector IPOINT
+
+ call sort2(numpart,igrid,ipoint)
+
+ ! Now visit all grid columns where particles are present
+ ! by going through the sorted particles
+
+ igrold = -1
+ do kpart=1,numpart
+ igr = igrid(kpart)
+ if (igr .eq. -1) goto 50
+ ipart = ipoint(kpart)
+ ! sumall = sumall + 1
+ if (igr .ne. igrold) then
+ ! we are in a new grid column
+ jy = (igr-1)/nx
+ ix = igr - jy*nx - 1
+
+ ! Interpolate all meteorological data needed for the convection scheme
+ psconv=(ps(ix,jy,1,mind1)*dt2+ps(ix,jy,1,mind2)*dt1)*dtt
+ tt2conv=(tt2(ix,jy,1,mind1)*dt2+tt2(ix,jy,1,mind2)*dt1)*dtt
+ td2conv=(td2(ix,jy,1,mind1)*dt2+td2(ix,jy,1,mind2)*dt1)*dtt
+!!$ do kz=1,nconvlev+1 !old
+ do kz=1,nuvz-1 !bugfix
+ pconv(kz)=(pplev(ix,jy,kz,mind1)*dt2+ &
+ pplev(ix,jy,kz,mind2)*dt1)*dtt
+ tconv(kz)=(tt(ix,jy,kz,mind1)*dt2+ &
+ tt(ix,jy,kz,mind2)*dt1)*dtt
+ qconv(kz)=(qv(ix,jy,kz,mind1)*dt2+ &
+ qv(ix,jy,kz,mind2)*dt1)*dtt
+ end do
+
+ ! Calculate translocation matrix
+ call calcmatrix(lconv,delt,cbaseflux(ix,jy))
+ igrold = igr
+ ktop = 0
+ endif
+
+ ! treat particle only if column has convection
+ if (lconv .eqv. .true.) then
+ ! assign new vertical position to particle
+
+ ztold=ztra1(ipart)
+ call redist(ipart,ktop,ipconv)
+ ! if (ipconv.le.0) sumconv = sumconv+1
+
+ ! Calculate the gross fluxes across layer interfaces
+ !***************************************************
+
+ if (iflux.eq.1) then
+ itage=abs(itra1(ipart)-itramem(ipart))
+ do nage=1,nageclass
+ if (itage.lt.lage(nage)) goto 37
+ end do
+ 37 continue
+
+ if (nage.le.nageclass) &
+ call calcfluxes(nage,ipart,real(xtra1(ipart)), &
+ real(ytra1(ipart)),ztold)
+ endif
+
+ endif !(lconv .eqv. .true)
+50 continue
+ end do
+
+
+ !*****************************************************************************
+ ! 2. Nested domains
+ !*****************************************************************************
+
+ ! sort particles according to horizontal position and calculate index vector IPOINT
+
+ do inest=1,numbnests
+ do ipart=1,numpart
+ ipoint(ipart)=ipart
+ igrid(ipart) = igridn(ipart,inest)
+ enddo
+ call sort2(numpart,igrid,ipoint)
+
+ ! Now visit all grid columns where particles are present
+ ! by going through the sorted particles
+
+ igrold = -1
+ do kpart=1,numpart
+ igr = igrid(kpart)
+ if (igr .eq. -1) goto 60
+ ipart = ipoint(kpart)
+ ! sumall = sumall + 1
+ if (igr .ne. igrold) then
+ ! we are in a new grid column
+ jy = (igr-1)/nxn(inest)
+ ix = igr - jy*nxn(inest) - 1
+
+ ! Interpolate all meteorological data needed for the convection scheme
+ psconv=(psn(ix,jy,1,mind1,inest)*dt2+ &
+ psn(ix,jy,1,mind2,inest)*dt1)*dtt
+ tt2conv=(tt2n(ix,jy,1,mind1,inest)*dt2+ &
+ tt2n(ix,jy,1,mind2,inest)*dt1)*dtt
+ td2conv=(td2n(ix,jy,1,mind1,inest)*dt2+ &
+ td2n(ix,jy,1,mind2,inest)*dt1)*dtt
+!!$ do kz=1,nconvlev+1 !old
+ do kz=1,nuvz-1 !bugfix
+ tconv(kz)=(tthn(ix,jy,kz+1,mind1,inest)*dt2+ &
+ tthn(ix,jy,kz+1,mind2,inest)*dt1)*dtt
+ qconv(kz)=(qvhn(ix,jy,kz+1,mind1,inest)*dt2+ &
+ qvhn(ix,jy,kz+1,mind2,inest)*dt1)*dtt
+ end do
+
+ ! calculate translocation matrix
+ !*******************************
+ call calcmatrix(lconv,delt,cbasefluxn(ix,jy,inest))
+ igrold = igr
+ ktop = 0
+ endif
+
+ ! treat particle only if column has convection
+ if (lconv .eqv. .true.) then
+ ! assign new vertical position to particle
+ ztold=ztra1(ipart)
+ call redist(ipart,ktop,ipconv)
+ ! if (ipconv.le.0) sumconv = sumconv+1
+
+ ! Calculate the gross fluxes across layer interfaces
+ !***************************************************
+
+ if (iflux.eq.1) then
+ itage=abs(itra1(ipart)-itramem(ipart))
+ do nage=1,nageclass
+ if (itage.lt.lage(nage)) goto 47
+ end do
+ 47 continue
+
+ if (nage.le.nageclass) &
+ call calcfluxes(nage,ipart,real(xtra1(ipart)), &
+ real(ytra1(ipart)),ztold)
+ endif
+
+ endif !(lconv .eqv. .true.)
+
+
+60 continue
+ end do
+ end do
+ !--------------------------------------------------------------------------
+ !write(*,*)'############################################'
+ !write(*,*)'TIME=',
+ ! & itime
+ !write(*,*)'fraction of particles under convection',
+ ! & sumconv/(sumall+0.001)
+ !write(*,*)'total number of particles',
+ ! & sumall
+ !write(*,*)'number of particles under convection',
+ ! & sumconv
+ !write(*,*)'############################################'
+
+ return
+end subroutine convmix
diff --git a/src/coordtrafo.f90 b/src/coordtrafo.f90
new file mode 100644
index 0000000000000000000000000000000000000000..647236b5f66670af44b40d0ee33ac11cb8527ad3
--- /dev/null
+++ b/src/coordtrafo.f90
@@ -0,0 +1,114 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine coordtrafo
+
+ !**********************************************************************
+ ! *
+ ! FLEXPART MODEL SUBROUTINE COORDTRAFO *
+ ! *
+ !**********************************************************************
+ ! *
+ ! AUTHOR: G. WOTAWA *
+ ! DATE: 1994-02-07 *
+ ! LAST UPDATE: 1996-05-18 A. STOHL *
+ ! *
+ !**********************************************************************
+ ! *
+ ! DESCRIPTION: This subroutine transforms x and y coordinates of *
+ ! particle release points to grid coordinates. *
+ ! *
+ !**********************************************************************
+
+ use point_mod
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: i,j,k
+
+ if (numpoint.eq.0) goto 30
+
+ ! TRANSFORM X- AND Y- COORDINATES OF STARTING POINTS TO GRID COORDINATES
+ !***********************************************************************
+
+ do i=1,numpoint
+ xpoint1(i)=(xpoint1(i)-xlon0)/dx
+ xpoint2(i)=(xpoint2(i)-xlon0)/dx
+ ypoint1(i)=(ypoint1(i)-ylat0)/dy
+ ypoint2(i)=(ypoint2(i)-ylat0)/dy
+ end do
+
+15 continue
+
+
+ ! CHECK IF RELEASE POINTS ARE WITHIN DOMAIN
+ !******************************************
+
+ do i=1,numpoint
+ if (sglobal.and.(ypoint1(i).lt.1.e-6)) ypoint1(i)=1.e-6
+ if (nglobal.and.(ypoint2(i).gt.real(nymin1)-1.e-5)) &
+ ypoint2(i)=real(nymin1)-1.e-5
+ if ((ypoint1(i).lt.1.e-6).or.(ypoint1(i).ge.real(nymin1)-1.e-6) &
+ .or.(ypoint2(i).lt.1.e-6).or.(ypoint2(i).ge.real(nymin1)-1.e-6) &
+ .or.((.not.xglobal).and.((xpoint1(i).lt.1.e-6).or. &
+ (xpoint1(i).ge.real(nxmin1)-1.e-6).or.(xpoint2(i).lt.1.e-6).or. &
+ (xpoint2(i).ge.real(nxmin1)-1.e-6)))) then
+ write(*,*) ' NOTICE: RELEASE POINT OUT OF DOMAIN DETECTED.'
+ write(*,*) ' IT IS REMOVED NOW ... '
+ if (i.ge.1000) then
+ write(*,*) ' COMMENT: ',compoint(i)
+ else
+ write(*,*) ' COMMENT: ',compoint(1001)
+ endif
+ if (i.lt.numpoint) then
+ do j=i+1,numpoint
+ xpoint1(j-1)=xpoint1(j)
+ ypoint1(j-1)=ypoint1(j)
+ xpoint2(j-1)=xpoint2(j)
+ ypoint2(j-1)=ypoint2(j)
+ zpoint1(j-1)=zpoint1(j)
+ zpoint2(j-1)=zpoint2(j)
+ npart(j-1)=npart(j)
+ kindz(j-1)=kindz(j)
+ ireleasestart(j-1)=ireleasestart(j)
+ ireleaseend(j-1)=ireleaseend(j)
+ if (j.le.1000) compoint(j-1)=compoint(j)
+ do k=1,nspec
+ xmass(j-1,k)=xmass(j,k)
+ end do
+ end do
+ endif
+
+ numpoint=numpoint-1
+ if (numpoint.gt.0) goto 15
+ endif
+ end do
+
+30 if(numpoint.eq.0) then
+ write(*,*) ' FLEXPART MODEL SUBROUTINE COORDTRAFO: ERROR ! '
+ write(*,*) ' NO PARTICLE RELEASES ARE DEFINED!'
+ write(*,*) ' CHECK FILE RELEASES...'
+ stop
+ endif
+
+end subroutine coordtrafo
diff --git a/src/distance.f90 b/src/distance.f90
new file mode 100644
index 0000000000000000000000000000000000000000..091d83127bba34ec43512b88db3a03537c5e8928
--- /dev/null
+++ b/src/distance.f90
@@ -0,0 +1,74 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+!-----------------------------------------------------------------------
+function distance(rlat1,rlon1,rlat2,rlon2)
+
+ !$$$ SUBPROGRAM DOCUMENTATION BLOCK
+ !
+ ! SUBPROGRAM: GCDIST COMPUTE GREAT CIRCLE DISTANCE
+ ! PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-04-10
+ !
+ ! ABSTRACT: THIS SUBPROGRAM COMPUTES GREAT CIRCLE DISTANCE
+ ! BETWEEN TWO POINTS ON THE EARTH.
+ !
+ ! PROGRAM HISTORY LOG:
+ ! 96-04-10 IREDELL
+ !
+ ! USAGE: ...GCDIST(RLAT1,RLON1,RLAT2,RLON2)
+ !
+ ! INPUT ARGUMENT LIST:
+ !rlat1 - REAL LATITUDE OF POINT 1 IN DEGREES
+ !rlon1 - REAL LONGITUDE OF POINT 1 IN DEGREES
+ !rlat2 - REAL LATITUDE OF POINT 2 IN DEGREES
+ !rlon2 - REAL LONGITUDE OF POINT 2 IN DEGREES
+ !
+ ! OUTPUT ARGUMENT LIST:
+ !distance - REAL GREAT CIRCLE DISTANCE IN KILOMETERS
+ !
+ ! ATTRIBUTES:
+ ! LANGUAGE: Fortran 90
+ !
+ !$$$
+
+ use par_mod, only: dp
+
+ implicit none
+
+ real :: rlat1,rlon1,rlat2,rlon2,distance
+ real(kind=dp) :: clat1,clat2,slat1,slat2,cdlon,crd
+ real(kind=dp),parameter :: rerth=6.3712e6_dp
+ real(kind=dp),parameter :: pi=3.14159265358979_dp, dpr=180.0_dp/pi
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if ((abs(rlat1-rlat2).lt.0.03).and. &
+ (abs(rlon1-rlon2).lt.0.03)) then
+ distance=0.
+ else
+ clat1=cos(real(rlat1,kind=dp)/dpr)
+ slat1=sin(real(rlat1,kind=dp)/dpr)
+ clat2=cos(real(rlat2,kind=dp)/dpr)
+ slat2=sin(real(rlat2,kind=dp)/dpr)
+ cdlon=cos(real((rlon1-rlon2),kind=dp)/dpr)
+ crd=slat1*slat2+clat1*clat2*cdlon
+ distance=real(rerth*acos(crd)/1000.0_dp)
+ endif
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+end function distance
diff --git a/src/distance2.f90 b/src/distance2.f90
new file mode 100644
index 0000000000000000000000000000000000000000..af0a9af7bb7ca0de5399bd656104d5acdac9a998
--- /dev/null
+++ b/src/distance2.f90
@@ -0,0 +1,76 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+!-----------------------------------------------------------------------
+function distance2(rlat1,rlon1,rlat2,rlon2)
+
+ !$$$ SUBPROGRAM DOCUMENTATION BLOCK
+ !
+ ! SUBPROGRAM: GCDIST COMPUTE GREAT CIRCLE DISTANCE
+ ! PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-04-10
+ !
+ ! ABSTRACT: THIS SUBPROGRAM COMPUTES GREAT CIRCLE DISTANCE
+ ! BETWEEN TWO POINTS ON THE EARTH. COORDINATES ARE GIVEN IN RADIANS!
+ !
+ ! PROGRAM HISTORY LOG:
+ ! 96-04-10 IREDELL
+ !
+ ! USAGE: ...GCDIST(RLAT1,RLON1,RLAT2,RLON2)
+ !
+ ! INPUT ARGUMENT LIST:
+ !rlat1 - REAL LATITUDE OF POINT 1 IN RADIANS
+ !rlon1 - REAL LONGITUDE OF POINT 1 IN RADIANS
+ !rlat2 - REAL LATITUDE OF POINT 2 IN RADIANS
+ !rlon2 - REAL LONGITUDE OF POINT 2 IN RADIANS
+ !
+ ! OUTPUT ARGUMENT LIST:
+ !distance2 - REAL GREAT CIRCLE DISTANCE IN KM
+ !
+ ! ATTRIBUTES:
+ ! LANGUAGE: Fortran 90
+ !
+ !$$$
+
+ use par_mod, only: dp
+
+ implicit none
+
+ real :: rlat1,rlon1,rlat2,rlon2,distance2
+ real(kind=dp) :: clat1,clat2,slat1,slat2,cdlon,crd
+ real(kind=dp),parameter :: rerth=6.3712e6_dp
+ real(kind=dp),parameter :: pi=3.14159265358979_dp
+
+ if ((abs(rlat1-rlat2).lt.0.0003).and. &
+ (abs(rlon1-rlon2).lt.0.0003)) then
+ distance2=0.0_dp
+ else
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ clat1=cos(real(rlat1,kind=dp))
+ slat1=sin(real(rlat1,kind=dp))
+ clat2=cos(real(rlat2,kind=dp))
+ slat2=sin(real(rlat2,kind=dp))
+ cdlon=cos(real(rlon1-rlon2,kind=dp))
+ crd=slat1*slat2+clat1*clat2*cdlon
+ distance2=real(rerth*acos(crd)/1000.0_dp)
+ endif
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+end function distance2
diff --git a/src/drydepokernel.f90 b/src/drydepokernel.f90
new file mode 100644
index 0000000000000000000000000000000000000000..6bca81e1ec881eb7adc819d3fa1b1cf9edb55900
--- /dev/null
+++ b/src/drydepokernel.f90
@@ -0,0 +1,116 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine drydepokernel(nunc,deposit,x,y,nage,kp)
+ ! i i i i i
+ !*****************************************************************************
+ ! *
+ ! Attribution of the deposition to the grid using a uniform kernel with *
+ ! bandwidths dx and dy. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 26 December 1996 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! nunc uncertainty class of the respective particle *
+ ! nage age class of the respective particle *
+ ! deposit amount (kg) to be deposited *
+ ! *
+ !*****************************************************************************
+
+ use unc_mod
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ real :: x,y,deposit(maxspec),ddx,ddy,xl,yl,wx,wy,w
+ integer :: ix,jy,ixp,jyp,ks,nunc,nage,kp
+
+
+ xl=(x*dx+xoutshift)/dxout
+ yl=(y*dy+youtshift)/dyout
+ ix=int(xl)
+ jy=int(yl)
+ ddx=xl-real(ix) ! distance to left cell border
+ ddy=yl-real(jy) ! distance to lower cell border
+
+ if (ddx.gt.0.5) then
+ ixp=ix+1
+ wx=1.5-ddx
+ else
+ ixp=ix-1
+ wx=0.5+ddx
+ endif
+
+ if (ddy.gt.0.5) then
+ jyp=jy+1
+ wy=1.5-ddy
+ else
+ jyp=jy-1
+ wy=0.5+ddy
+ endif
+
+
+ ! Determine mass fractions for four grid points
+ !**********************************************
+ do ks=1,nspec
+
+ if ((abs(deposit(ks)).gt.0).and.DRYDEPSPEC(ks)) then
+
+ if ((ix.ge.0).and.(jy.ge.0).and.(ix.le.numxgrid-1).and. &
+ (jy.le.numygrid-1)) then
+ w=wx*wy
+ drygridunc(ix,jy,ks,kp,nunc,nage)= &
+ drygridunc(ix,jy,ks,kp,nunc,nage)+deposit(ks)*w
+ continue
+ endif
+
+ if ((ixp.ge.0).and.(jyp.ge.0).and.(ixp.le.numxgrid-1).and. &
+ (jyp.le.numygrid-1)) then
+ w=(1.-wx)*(1.-wy)
+ drygridunc(ixp,jyp,ks,kp,nunc,nage)= &
+ drygridunc(ixp,jyp,ks,kp,nunc,nage)+deposit(ks)*w
+ endif
+
+ if ((ixp.ge.0).and.(jy.ge.0).and.(ixp.le.numxgrid-1).and. &
+ (jy.le.numygrid-1)) then
+ w=(1.-wx)*wy
+ drygridunc(ixp,jy,ks,kp,nunc,nage)= &
+ drygridunc(ixp,jy,ks,kp,nunc,nage)+deposit(ks)*w
+ endif
+
+ if ((ix.ge.0).and.(jyp.ge.0).and.(ix.le.numxgrid-1).and. &
+ (jyp.le.numygrid-1)) then
+ w=wx*(1.-wy)
+ drygridunc(ix,jyp,ks,kp,nunc,nage)= &
+ drygridunc(ix,jyp,ks,kp,nunc,nage)+deposit(ks)*w
+ endif
+
+ endif
+
+ end do
+
+end subroutine drydepokernel
diff --git a/src/drydepokernel_nest.f90 b/src/drydepokernel_nest.f90
new file mode 100644
index 0000000000000000000000000000000000000000..5c715d7ba8a809643e27677fc63e8b7ff8dfd3cc
--- /dev/null
+++ b/src/drydepokernel_nest.f90
@@ -0,0 +1,118 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine drydepokernel_nest(nunc,deposit,x,y,nage,kp)
+ ! i i i i i
+ !*****************************************************************************
+ ! *
+ ! Attribution of the deposition from an individual particle to the *
+ ! nested deposition fields using a uniform kernel with bandwidths *
+ ! dxoutn and dyoutn. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 26 December 1996 *
+ ! *
+ ! 2 September 2004: Adaptation from drydepokernel. *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! nunc uncertainty class of the respective particle *
+ ! nage age class of the respective particle *
+ ! deposit amount (kg) to be deposited *
+ ! *
+ !*****************************************************************************
+
+ use unc_mod
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ real :: x,y,deposit(maxspec),ddx,ddy,xl,yl,wx,wy,w
+ integer :: ix,jy,ixp,jyp,ks,kp,nunc,nage
+
+
+
+ xl=(x*dx+xoutshiftn)/dxoutn
+ yl=(y*dy+youtshiftn)/dyoutn
+ ix=int(xl)
+ jy=int(yl)
+ ddx=xl-real(ix) ! distance to left cell border
+ ddy=yl-real(jy) ! distance to lower cell border
+
+ if (ddx.gt.0.5) then
+ ixp=ix+1
+ wx=1.5-ddx
+ else
+ ixp=ix-1
+ wx=0.5+ddx
+ endif
+
+ if (ddy.gt.0.5) then
+ jyp=jy+1
+ wy=1.5-ddy
+ else
+ jyp=jy-1
+ wy=0.5+ddy
+ endif
+
+
+ ! Determine mass fractions for four grid points
+ !**********************************************
+ do ks=1,nspec
+
+ if (DRYDEPSPEC(ks).and.(abs(deposit(ks)).gt.0)) then
+
+ if ((ix.ge.0).and.(jy.ge.0).and.(ix.le.numxgridn-1).and. &
+ (jy.le.numygridn-1)) then
+ w=wx*wy
+ drygriduncn(ix,jy,ks,kp,nunc,nage)= &
+ drygriduncn(ix,jy,ks,kp,nunc,nage)+deposit(ks)*w
+ endif
+
+ if ((ixp.ge.0).and.(jyp.ge.0).and.(ixp.le.numxgridn-1).and. &
+ (jyp.le.numygridn-1)) then
+ w=(1.-wx)*(1.-wy)
+ drygriduncn(ixp,jyp,ks,kp,nunc,nage)= &
+ drygriduncn(ixp,jyp,ks,kp,nunc,nage)+deposit(ks)*w
+ endif
+
+ if ((ixp.ge.0).and.(jy.ge.0).and.(ixp.le.numxgridn-1).and. &
+ (jy.le.numygridn-1)) then
+ w=(1.-wx)*wy
+ drygriduncn(ixp,jy,ks,kp,nunc,nage)= &
+ drygriduncn(ixp,jy,ks,kp,nunc,nage)+deposit(ks)*w
+ endif
+
+ if ((ix.ge.0).and.(jyp.ge.0).and.(ix.le.numxgridn-1).and. &
+ (jyp.le.numygridn-1)) then
+ w=wx*(1.-wy)
+ drygriduncn(ix,jyp,ks,kp,nunc,nage)= &
+ drygriduncn(ix,jyp,ks,kp,nunc,nage)+deposit(ks)*w
+ endif
+
+ endif
+
+ end do
+end subroutine drydepokernel_nest
diff --git a/src/dynamic_viscosity.f90 b/src/dynamic_viscosity.f90
new file mode 100644
index 0000000000000000000000000000000000000000..0ef1bcb92f05c145cfbdbff55a9fbaa686618843
--- /dev/null
+++ b/src/dynamic_viscosity.f90
@@ -0,0 +1,36 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+! Function calculates dynamic viscosity of air (kg/m/s) as function of
+! temperature (K) using Sutherland's formula
+
+real function viscosity(t)
+
+ implicit none
+
+ real :: t
+ real,parameter :: c=120.,t_0=291.15,eta_0=1.827e-5
+
+ viscosity=eta_0*(t_0+c)/(t+c)*(t/t_0)**1.5
+
+ return
+
+end function viscosity
diff --git a/src/erf.f90 b/src/erf.f90
new file mode 100644
index 0000000000000000000000000000000000000000..1150f76ec539520202ccb545949c8ca1b43d550c
--- /dev/null
+++ b/src/erf.f90
@@ -0,0 +1,212 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+! To be used, if the non-standard Fortran function erf does not exist on
+! your machine
+!
+!aus: Numerical Recipes (FORTRAN) / Chapter 6.
+!
+!6.1 FUNCTION GAMMLN
+!6.2 FUNCTION GAMMP <6.2:GSER/6.2:GCF/6.1:GAMMLN>
+!6.2 FUNCTION GAMMQ <6.2:GSER/6.2:GCF/6.1:GAMMLN>
+!6.2 SUBROUTINE GSER <6.1:GAMMLN>
+!6.2 SUBROUTINE GCF <6.1:GAMMLN>
+!6.2 FUNCTION ERF <6.2:GAMMP/6.2:GSER/6.2:GCF/6.1:GAMMLN>
+!6.2 FUNCTION ERFC <6.2.:GAMMP/6.2:GAMMQ/6.2:GSER/
+! 6.2:GCF/6.1:GAMMLN>
+!6.2 FUNCTION ERFCC
+
+function gammln(xx)
+
+ use par_mod, only: dp
+
+ implicit none
+
+ integer :: j
+ real :: x,tmp,ser,xx,gammln
+ real :: cof(6) = (/ &
+ 76.18009173_dp, -86.50532033_dp, 24.01409822_dp, &
+ -1.231739516_dp, .120858003e-2_dp, -.536382e-5_dp /)
+ real :: stp = 2.50662827465_dp
+ real :: half = 0.5_dp, one = 1.0_dp, fpf = 5.5_dp
+
+ x=xx-one
+ tmp=x+fpf
+ tmp=(x+half)*log(tmp)-tmp
+ ser=one
+ do j=1,6
+ x=x+one
+ ser=ser+cof(j)/x
+ end do
+ gammln=tmp+log(stp*ser)
+end function gammln
+
+function gammp(a,x)
+
+ implicit none
+
+ real :: a, x, gln, gamser, gammp, gammcf
+
+ if(x .lt. 0. .or. a .le. 0.) then
+ print*, 'gammp'
+ stop
+ end if
+ if(x.lt.a+1.)then
+ call gser(gamser,a,x,gln)
+ gammp=gamser
+ else
+ call gcf(gammcf,a,x,gln)
+ gammp=1.-gammcf
+ endif
+end function gammp
+
+function gammq(a,x)
+
+ implicit none
+
+ real :: a, x, gln, gamser, gammq, gammcf
+
+ if(x.lt.0..or.a.le.0.) then
+ print*, 'gammq'
+ stop
+ end if
+ if(x.lt.a+1.)then
+ call gser(gamser,a,x,gln)
+ gammq=1.-gamser
+ else
+ call gcf(gammcf,a,x,gln)
+ gammq=gammcf
+ endif
+end function gammq
+
+subroutine gser(gamser,a,x,gln)
+
+ implicit none
+
+ integer :: n
+ real :: gamser, a, x, gln, ap, summ, del
+ real, external :: gammln
+
+ integer,parameter :: itmax=100
+ real,parameter :: eps=3.e-7
+
+ gln=gammln(a)
+ if(x.le.0.)then
+ if(x.lt.0.) then
+ print*, 'gser'
+ stop
+ end if
+ gamser=0.
+ return
+ endif
+ ap=a
+ summ=1./a
+ del=summ
+ do n=1,itmax
+ ap=ap+1.
+ del=del*x/ap
+ summ=summ+del
+ if(abs(del).lt.abs(summ)*eps)go to 1
+ end do
+ print*, 'gser: a too large, itmax too small'
+ stop
+1 gamser=summ*exp(-x+a*log(x)-gln)
+end subroutine gser
+
+subroutine gcf(gammcf,a,x,gln)
+
+ implicit none
+
+ integer :: n
+ real :: gammcf, a, x, gln, gold, a0, a1, b0, b1, fac, an, anf, ana, g
+ real, external :: gammln
+
+ integer,parameter :: itmax=100
+ real,parameter :: eps=3.e-7
+
+ gln=gammln(a)
+ gold=0.
+ a0=1.
+ a1=x
+ b0=0.
+ b1=1.
+ fac=1.
+ do n=1,itmax
+ an=real(n)
+ ana=an-a
+ a0=(a1+a0*ana)*fac
+ b0=(b1+b0*ana)*fac
+ anf=an*fac
+ a1=x*a0+anf*a1
+ b1=x*b0+anf*b1
+ if(a1.ne.0.)then
+ fac=1./a1
+ g=b1*fac
+ if(abs((g-gold)/g).lt.eps)go to 1
+ gold=g
+ endif
+ end do
+ print*, 'gcf: a too large, itmax too small'
+ stop
+1 gammcf=exp(-x+a*alog(x)-gln)*g
+end subroutine gcf
+
+function erf(x)
+
+ implicit none
+
+ real :: x, erf
+ real, external :: gammp
+
+ if(x.lt.0.)then
+ erf=-gammp(.5,x**2)
+ else
+ erf=gammp(.5,x**2)
+ endif
+end function erf
+
+function erfc(x)
+
+ implicit none
+
+ real :: x, erfc
+ real, external :: gammp, gammq
+
+ if(x.lt.0.)then
+ erfc=1.+gammp(.5,x**2)
+ else
+ erfc=gammq(.5,x**2)
+ endif
+end function erfc
+
+function erfcc(x)
+
+ implicit none
+
+ real :: x, z, t, erfcc
+
+ z=abs(x)
+ t=1./(1.+0.5*z)
+ erfcc=t*exp(-z*z-1.26551223+t*(1.00002368+t*(.37409196+ &
+ t*(.09678418+t*(-.18628806+t*(.27886807+t*(-1.13520398+ &
+ t*(1.48851587+t*(-.82215223+t*.17087277)))))))))
+ if (x.lt.0.) erfcc=2.-erfcc
+end function erfcc
diff --git a/src/ew.f90 b/src/ew.f90
new file mode 100644
index 0000000000000000000000000000000000000000..0d44e82cf9f345b4955f373ba4f4fcd3f95cd4c3
--- /dev/null
+++ b/src/ew.f90
@@ -0,0 +1,47 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+real function ew(x)
+
+ !****************************************************************
+ !SAETTIGUNGSDAMPFDRUCK UEBER WASSER IN PA. X IN KELVIN.
+ !NACH DER GOFF-GRATCH-FORMEL.
+ !****************************************************************
+
+ implicit none
+
+ real :: x, y, a, c, d
+
+ ew=0.
+ if(x.le.0.) stop 'sorry: t not in [k]'
+ y=373.16/x
+ a=-7.90298*(y-1.)
+ a=a+(5.02808*0.43429*alog(y))
+ c=(1.-(1./y))*11.344
+ c=-1.+(10.**c)
+ c=-1.3816*c/(10.**7)
+ d=(1.-y)*3.49149
+ d=-1.+(10.**d)
+ d=8.1328*d/(10.**3)
+ y=a+c+d
+ ew=101324.6*(10.**y) ! Saettigungsdampfdruck in Pa
+
+end function ew
diff --git a/src/flux_mod.f90 b/src/flux_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..220dd4f57d94fac2f3cdb8e165f35f098506afa7
--- /dev/null
+++ b/src/flux_mod.f90
@@ -0,0 +1,41 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+module flux_mod
+
+ ! flux eastward, westward, northward, southward, upward and downward
+ ! fluxes of all species and all ageclasses
+ ! areaeast,areanorth [m2] side areas of each grid cell
+
+ implicit none
+
+ real,allocatable, dimension (:,:,:,:,:,:,:) :: flux
+
+ !1 fluxw west - east
+ !2 fluxe east - west
+ !3 fluxs south - north
+ !4 fluxn north - south
+ !5 fluxu upward
+ !6 fluxd downward
+ !real,allocatable, dimension (:,:,:) :: areanorth
+ !real,allocatable, dimension (:,:,:) :: areaeast
+
+end module flux_mod
diff --git a/src/fluxoutput.f90 b/src/fluxoutput.f90
new file mode 100644
index 0000000000000000000000000000000000000000..5bc03eb3d1aae45af1adb9c7fea5112c942b23e8
--- /dev/null
+++ b/src/fluxoutput.f90
@@ -0,0 +1,324 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine fluxoutput(itime)
+ ! i
+ !*****************************************************************************
+ ! *
+ ! Output of the gridded fluxes. *
+ ! Eastward, westward, northward, southward, upward and downward gross *
+ ! fluxes are written to output file in either sparse matrix or grid dump *
+ ! format, whichever is more efficient. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 04 April 2000 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! ncellse number of cells with non-zero values for eastward fluxes *
+ ! sparsee .true. if in sparse matrix format, else .false. *
+ ! *
+ !*****************************************************************************
+
+ use flux_mod
+ use outg_mod
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ real(kind=dp) :: jul
+ integer :: itime,ix,jy,kz,k,nage,jjjjmmdd,ihmmss,kp,i
+ integer :: ncellse(maxspec,maxageclass),ncellsw(maxspec,maxageclass)
+ integer :: ncellss(maxspec,maxageclass),ncellsn(maxspec,maxageclass)
+ integer :: ncellsu(maxspec,maxageclass),ncellsd(maxspec,maxageclass)
+ logical :: sparsee(maxspec,maxageclass),sparsew(maxspec,maxageclass)
+ logical :: sparses(maxspec,maxageclass),sparsen(maxspec,maxageclass)
+ logical :: sparseu(maxspec,maxageclass),sparsed(maxspec,maxageclass)
+ character :: adate*8,atime*6
+
+
+ ! Determine current calendar date, needed for the file name
+ !**********************************************************
+
+ jul=bdate+real(itime,kind=dp)/86400._dp
+ call caldate(jul,jjjjmmdd,ihmmss)
+ write(adate,'(i8.8)') jjjjmmdd
+ write(atime,'(i6.6)') ihmmss
+
+
+ open(unitflux,file=path(2)(1:length(2))//'grid_flux_'//adate// &
+ atime,form='unformatted')
+
+ !**************************************************************
+ ! Check, whether output of full grid or sparse matrix format is
+ ! more efficient in terms of storage space. This is checked for
+ ! every species and for every age class
+ !**************************************************************
+
+ do k=1,nspec
+ do nage=1,nageclass
+ ncellse(k,nage)=0
+ ncellsw(k,nage)=0
+ ncellsn(k,nage)=0
+ ncellss(k,nage)=0
+ ncellsu(k,nage)=0
+ ncellsd(k,nage)=0
+ end do
+ end do
+
+ do k=1,nspec
+ do kp=1,maxpointspec_act
+ do nage=1,nageclass
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ do kz=1,numzgrid
+ if (flux(2,ix,jy,kz,k,kp,nage).gt.0) ncellse(k,nage)= &
+ ncellse(k,nage)+1
+ if (flux(1,ix,jy,kz,k,kp,nage).gt.0) ncellsw(k,nage)= &
+ ncellsw(k,nage)+1
+ if (flux(4,ix,jy,kz,k,kp,nage).gt.0) ncellsn(k,nage)= &
+ ncellsn(k,nage)+1
+ if (flux(3,ix,jy,kz,k,kp,nage).gt.0) ncellss(k,nage)= &
+ ncellss(k,nage)+1
+ if (flux(5,ix,jy,kz,k,kp,nage).gt.0) ncellsu(k,nage)= &
+ ncellsu(k,nage)+1
+ if (flux(6,ix,jy,kz,k,kp,nage).gt.0) ncellsd(k,nage)= &
+ ncellsd(k,nage)+1
+ end do
+ end do
+ end do
+ end do
+ end do
+ end do
+
+ ! Output in sparse matrix format more efficient, if less than
+ ! 2/5 of all cells contains concentrations>0
+ !************************************************************
+
+ do k=1,nspec
+ do nage=1,nageclass
+ if (4*ncellse(k,nage).lt.numxgrid*numygrid*numzgrid) then
+ sparsee(k,nage)=.true.
+ else
+ sparsee(k,nage)=.false.
+ endif
+ if (4*ncellsw(k,nage).lt.numxgrid*numygrid*numzgrid) then
+ sparsew(k,nage)=.true.
+ else
+ sparsew(k,nage)=.false.
+ endif
+ if (4*ncellsn(k,nage).lt.numxgrid*numygrid*numzgrid) then
+ sparsen(k,nage)=.true.
+ else
+ sparsen(k,nage)=.false.
+ endif
+ if (4*ncellss(k,nage).lt.numxgrid*numygrid*numzgrid) then
+ sparses(k,nage)=.true.
+ else
+ sparses(k,nage)=.false.
+ endif
+ if (4*ncellsu(k,nage).lt.numxgrid*numygrid*numzgrid) then
+ sparseu(k,nage)=.true.
+ else
+ sparseu(k,nage)=.false.
+ endif
+ if (4*ncellsd(k,nage).lt.numxgrid*numygrid*numzgrid) then
+ sparsed(k,nage)=.true.
+ else
+ sparsed(k,nage)=.false.
+ endif
+ end do
+ end do
+
+
+
+ ! Flux output: divide by area and time to get flux in ng/m2/s
+ !************************************************************
+
+ write(unitflux) itime
+ do k=1,nspec
+ do kp=1,maxpointspec_act
+ do nage=1,nageclass
+
+ if (sparsee(k,nage)) then
+ write(unitflux) 1
+ do kz=1,numzgrid
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (flux(2,ix,jy,kz,k,kp,nage).gt.0.) write(unitflux) &
+ ix+jy*numxgrid+kz*numxgrid*numygrid,1.e12* &
+ flux(2,ix,jy,kz,k,kp,nage)/areaeast(ix,jy,kz)/outstep
+ end do
+ end do
+ end do
+ write(unitflux) -999,999.
+ else
+ write(unitflux) 2
+ do kz=1,numzgrid
+ do ix=0,numxgrid-1
+ write(unitflux) (1.e12*flux(2,ix,jy,kz,k,kp,nage)/ &
+ areaeast(ix,jy,kz)/outstep,jy=0,numygrid-1)
+ end do
+ end do
+ endif
+
+ if (sparsew(k,nage)) then
+ write(unitflux) 1
+ do kz=1,numzgrid
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (flux(1,ix,jy,kz,k,kp,nage).gt.0.) write(unitflux) &
+ ix+jy*numxgrid+kz*numxgrid*numygrid,1.e12* &
+ flux(1,ix,jy,kz,k,kp,nage)/areaeast(ix,jy,kz)/outstep
+ end do
+ end do
+ end do
+ write(unitflux) -999,999.
+ else
+ write(unitflux) 2
+ do kz=1,numzgrid
+ do ix=0,numxgrid-1
+ write(unitflux) (1.e12*flux(1,ix,jy,kz,k,kp,nage)/ &
+ areaeast(ix,jy,kz)/outstep,jy=0,numygrid-1)
+ end do
+ end do
+ endif
+
+ if (sparses(k,nage)) then
+ write(unitflux) 1
+ do kz=1,numzgrid
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (flux(3,ix,jy,kz,k,kp,nage).gt.0.) write(unitflux) &
+ ix+jy*numxgrid+kz*numxgrid*numygrid,1.e12* &
+ flux(3,ix,jy,kz,k,kp,nage)/areanorth(ix,jy,kz)/outstep
+ end do
+ end do
+ end do
+ write(unitflux) -999,999.
+ else
+ write(unitflux) 2
+ do kz=1,numzgrid
+ do ix=0,numxgrid-1
+ write(unitflux) (1.e12*flux(3,ix,jy,kz,k,kp,nage)/ &
+ areanorth(ix,jy,kz)/outstep,jy=0,numygrid-1)
+ end do
+ end do
+ endif
+
+ if (sparsen(k,nage)) then
+ write(unitflux) 1
+ do kz=1,numzgrid
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1 ! north
+ if (flux(4,ix,jy,kz,k,kp,nage).gt.0.) write(unitflux) &
+ ix+jy*numxgrid+kz*numxgrid*numygrid,1.e12* &
+ flux(4,ix,jy,kz,k,kp,nage)/areanorth(ix,jy,kz)/outstep
+ end do
+ end do
+ end do
+ write(unitflux) -999,999.
+ else
+ write(unitflux) 2
+ do kz=1,numzgrid
+ do ix=0,numxgrid-1
+ write(unitflux) (1.e12*flux(4,ix,jy,kz,k,kp,nage)/ &
+ areanorth(ix,jy,kz)/outstep,jy=0,numygrid-1)
+ end do
+ end do
+ endif
+
+ if (sparseu(k,nage)) then
+ write(unitflux) 1
+ do kz=1,numzgrid
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (flux(5,ix,jy,kz,k,kp,nage).gt.0.) write(unitflux) &
+ ix+jy*numxgrid+kz*numxgrid*numygrid,1.e12* &
+ flux(5,ix,jy,kz,k,kp,nage)/area(ix,jy)/outstep
+ end do
+ end do
+ end do
+ write(unitflux) -999,999.
+ else
+ write(unitflux) 2
+ do kz=1,numzgrid
+ do ix=0,numxgrid-1
+ write(unitflux) (1.e12*flux(5,ix,jy,kz,k,kp,nage)/ &
+ area(ix,jy)/outstep,jy=0,numygrid-1)
+ end do
+ end do
+ endif
+
+ if (sparsed(k,nage)) then
+ write(unitflux) 1
+ do kz=1,numzgrid
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (flux(6,ix,jy,kz,k,kp,nage).gt.0.) write(unitflux) &
+ ix+jy*numxgrid+kz*numxgrid*numygrid,1.e12* &
+ flux(6,ix,jy,kz,k,kp,nage)/area(ix,jy)/outstep
+ end do
+ end do
+ end do
+ write(unitflux) -999,999.
+ else
+ write(unitflux) 2
+ do kz=1,numzgrid
+ do ix=0,numxgrid-1
+ write(unitflux) (1.e12*flux(6,ix,jy,kz,k,kp,nage)/ &
+ area(ix,jy)/outstep,jy=0,numygrid-1)
+ end do
+ end do
+ endif
+
+ end do
+ end do
+ end do
+
+
+ close(unitflux)
+
+
+ ! Reinitialization of grid
+ !*************************
+
+ do k=1,nspec
+ do kp=1,maxpointspec_act
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ do kz=1,numzgrid
+ do nage=1,nageclass
+ do i=1,6
+ flux(i,ix,jy,kz,k,kp,nage)=0.
+ end do
+ end do
+ end do
+ end do
+ end do
+ end do
+ end do
+
+
+end subroutine fluxoutput
diff --git a/src/get_settling.f90 b/src/get_settling.f90
new file mode 100644
index 0000000000000000000000000000000000000000..59c5eebeec944ff504cdb821efa373409b1f9190
--- /dev/null
+++ b/src/get_settling.f90
@@ -0,0 +1,147 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine get_settling(itime,xt,yt,zt,nsp,settling)
+ ! i i i i i o
+ !*****************************************************************************
+ ! *
+ ! This subroutine calculates particle settling velocity. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! May 2010 *
+ ! *
+ ! Improvement over traditional settling calculation in FLEXPART: *
+ ! generalize to higher Reynolds numbers and also take into account the *
+ ! temperature dependence of dynamic viscosity. *
+ ! *
+ ! Based on: *
+ ! Naeslund E., and Thaning, L. (1991): On the settling velocity in a *
+ ! nonstationary atmosphere, Aerosol Science and Technology 14, 247-256. *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! itime [s] current temporal position *
+ ! xt,yt,zt coordinates position for which wind data shall be cal- *
+ ! culated *
+ ! *
+ ! Constants: *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: itime,indz
+ real :: xt,yt,zt
+
+ ! Auxiliary variables needed for interpolation
+ real :: dz1,dz2,dz
+ real :: rho1(2),tt1(2),temperature,airdens,vis_dyn,vis_kin,viscosity
+ real :: settling,settling_old,reynolds,c_d
+ integer :: i,n,nix,njy,indzh,nsp
+
+
+ !*****************************************************************************
+ ! 1. Interpolate temperature and density: nearest neighbor interpolation sufficient
+ !*****************************************************************************
+
+ nix=int(xt)
+ njy=int(yt)
+
+ ! Determine the level below the current position for u,v
+ !*******************************************************
+
+ do i=2,nz
+ if (height(i).gt.zt) then
+ indz=i-1
+ goto 6
+ endif
+ end do
+6 continue
+
+
+ ! Vertical distance to the level below and above current position
+ !****************************************************************
+
+ dz=1./(height(indz+1)-height(indz))
+ dz1=(zt-height(indz))*dz
+ dz2=(height(indz+1)-zt)*dz
+
+
+ ! Bilinear horizontal interpolation
+ !**********************************
+
+ ! Loop over 2 levels
+ !*******************
+
+ do n=1,2
+ indzh=indz+n-1
+ rho1(n)=rho(nix,njy,indzh,1)
+ tt1(n)=tt(nix,njy,indzh,1)
+ end do
+
+
+ ! Linear vertical interpolation
+ !******************************
+
+ temperature=dz2*tt1(1)+dz1*tt1(2)
+ airdens=dz2*rho1(1)+dz1*rho1(2)
+
+
+ vis_dyn=viscosity(temperature)
+ vis_kin=vis_dyn/airdens
+
+ reynolds=dquer(nsp)/1.e6*abs(vsetaver(nsp))/vis_kin
+
+
+
+ ! Iteration to determine both Reynolds number and settling velocity
+ !******************************************************************
+
+ settling_old=vsetaver(nsp) ! initialize iteration with Stokes' law, constant viscosity estimate
+
+ do i=1,20 ! do a few iterations
+
+ if (reynolds.lt.1.917) then
+ c_d=24./reynolds
+ else if (reynolds.lt.500.) then
+ c_d=18.5/(reynolds**0.6)
+ else
+ c_d=0.44
+ endif
+
+ settling=-1.* &
+ sqrt(4*ga*dquer(nsp)/1.e6*density(nsp)*cunningham(nsp)/ &
+ (3.*c_d*airdens))
+
+ if (abs((settling-settling_old)/settling).lt.0.01) goto 11 ! stop iteration
+
+ reynolds=dquer(nsp)/1.e6*abs(settling)/vis_kin
+ settling_old=settling
+ end do
+
+11 continue
+
+end subroutine get_settling
diff --git a/src/getfields.f90 b/src/getfields.f90
new file mode 100644
index 0000000000000000000000000000000000000000..fad4e969ce491d88f12f332df4370df5a3ce4ace
--- /dev/null
+++ b/src/getfields.f90
@@ -0,0 +1,177 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine getfields(itime,nstop)
+ ! i o
+ !*****************************************************************************
+ ! *
+ ! This subroutine manages the 3 data fields to be kept in memory. *
+ ! During the first time step of petterssen it has to be fulfilled that the *
+ ! first data field must have |wftime|<itime, i.e. the absolute value of *
+ ! wftime must be smaller than the absolute value of the current time in [s].*
+ ! The other 2 fields are the next in time after the first one. *
+ ! Pointers (memind) are used, because otherwise one would have to resort the*
+ ! wind fields, which costs a lot of computing time. Here only the pointers *
+ ! are resorted. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 29 April 1994 *
+ ! *
+ !*****************************************************************************
+ ! Changes, Bernd C. Krueger, Feb. 2001:
+ ! Variables tth,qvh,tthn,qvhn (on eta coordinates) in common block.
+ ! Function of nstop extended.
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! lwindinterval [s] time difference between the two wind fields read in *
+ ! indj indicates the number of the wind field to be read in *
+ ! indmin remembers the number of wind fields already treated *
+ ! memind(2) pointer, on which place the wind fields are stored *
+ ! memtime(2) [s] times of the wind fields, which are kept in memory *
+ ! itime [s] current time since start date of trajectory calcu- *
+ ! lation *
+ ! nstop > 0, if trajectory has to be terminated *
+ ! nx,ny,nuvz,nwz field dimensions in x,y and z direction *
+ ! uu(0:nxmax,0:nymax,nuvzmax,2) wind components in x-direction [m/s] *
+ ! vv(0:nxmax,0:nymax,nuvzmax,2) wind components in y-direction [m/s] *
+ ! ww(0:nxmax,0:nymax,nwzmax,2) wind components in z-direction [deltaeta/s]*
+ ! tt(0:nxmax,0:nymax,nuvzmax,2) temperature [K] *
+ ! ps(0:nxmax,0:nymax,2) surface pressure [Pa] *
+ ! *
+ ! Constants: *
+ ! idiffmax maximum allowable time difference between 2 wind *
+ ! fields *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: indj,itime,nstop,memaux
+
+ real :: uuh(0:nxmax-1,0:nymax-1,nuvzmax)
+ real :: vvh(0:nxmax-1,0:nymax-1,nuvzmax)
+ real :: pvh(0:nxmax-1,0:nymax-1,nuvzmax)
+ real :: wwh(0:nxmax-1,0:nymax-1,nwzmax)
+ real :: uuhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
+ real :: vvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
+ real :: pvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
+ real :: wwhn(0:nxmaxn-1,0:nymaxn-1,nwzmax,maxnests)
+
+ integer :: indmin = 1
+
+
+ ! Check, if wind fields are available for the current time step
+ !**************************************************************
+
+ nstop=0
+
+ if ((ldirect*wftime(1).gt.ldirect*itime).or. &
+ (ldirect*wftime(numbwf).lt.ldirect*itime)) then
+ write(*,*) 'FLEXPART WARNING: NO WIND FIELDS ARE AVAILABLE.'
+ write(*,*) 'A TRAJECTORY HAS TO BE TERMINATED.'
+ nstop=4
+ return
+ endif
+
+
+ if ((ldirect*memtime(1).le.ldirect*itime).and. &
+ (ldirect*memtime(2).gt.ldirect*itime)) then
+
+ ! The right wind fields are already in memory -> don't do anything
+ !*****************************************************************
+
+ continue
+
+ else if ((ldirect*memtime(2).le.ldirect*itime).and. &
+ (memtime(2).ne.999999999)) then
+
+
+ ! Current time is after 2nd wind field
+ ! -> Resort wind field pointers, so that current time is between 1st and 2nd
+ !***************************************************************************
+
+ memaux=memind(1)
+ memind(1)=memind(2)
+ memind(2)=memaux
+ memtime(1)=memtime(2)
+
+
+ ! Read a new wind field and store it on place memind(2)
+ !******************************************************
+
+ do indj=indmin,numbwf-1
+ if (ldirect*wftime(indj+1).gt.ldirect*itime) then
+ call readwind(indj+1,memind(2),uuh,vvh,wwh)
+ call readwind_nests(indj+1,memind(2),uuhn,vvhn,wwhn)
+ call calcpar(memind(2),uuh,vvh,pvh)
+ call calcpar_nests(memind(2),uuhn,vvhn,pvhn)
+ call verttransform(memind(2),uuh,vvh,wwh,pvh)
+ call verttransform_nests(memind(2),uuhn,vvhn,wwhn,pvhn)
+ memtime(2)=wftime(indj+1)
+ nstop = 1
+ goto 40
+ endif
+ end do
+ 40 indmin=indj
+
+ else
+
+ ! No wind fields, which can be used, are currently in memory
+ ! -> read both wind fields
+ !***********************************************************
+
+ do indj=indmin,numbwf-1
+ if ((ldirect*wftime(indj).le.ldirect*itime).and. &
+ (ldirect*wftime(indj+1).gt.ldirect*itime)) then
+ memind(1)=1
+ call readwind(indj,memind(1),uuh,vvh,wwh)
+ call readwind_nests(indj,memind(1),uuhn,vvhn,wwhn)
+ call calcpar(memind(1),uuh,vvh,pvh)
+ call calcpar_nests(memind(1),uuhn,vvhn,pvhn)
+ call verttransform(memind(1),uuh,vvh,wwh,pvh)
+ call verttransform_nests(memind(1),uuhn,vvhn,wwhn,pvhn)
+ memtime(1)=wftime(indj)
+ memind(2)=2
+ call readwind(indj+1,memind(2),uuh,vvh,wwh)
+ call readwind_nests(indj+1,memind(2),uuhn,vvhn,wwhn)
+ call calcpar(memind(2),uuh,vvh,pvh)
+ call calcpar_nests(memind(2),uuhn,vvhn,pvhn)
+ call verttransform(memind(2),uuh,vvh,wwh,pvh)
+ call verttransform_nests(memind(2),uuhn,vvhn,wwhn,pvhn)
+ memtime(2)=wftime(indj+1)
+ nstop = 1
+ goto 60
+ endif
+ end do
+ 60 indmin=indj
+
+ endif
+
+ lwindinterv=abs(memtime(2)-memtime(1))
+
+ if (lwindinterv.gt.idiffmax) nstop=3
+
+end subroutine getfields
diff --git a/src/getrb.f90 b/src/getrb.f90
new file mode 100644
index 0000000000000000000000000000000000000000..82e58d623296404529dcf27999c00ac8b4fbcd7c
--- /dev/null
+++ b/src/getrb.f90
@@ -0,0 +1,61 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine getrb(nc,ustar,nyl,diffh2o,reldiff,rb)
+ ! i i i i i o
+ !*****************************************************************************
+ ! *
+ ! Calculation of the quasilaminar sublayer resistance to dry deposition. *
+ ! *
+ ! AUTHOR: Andreas Stohl, 20 May 1995 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! rb(ncmax) sublayer resistance *
+ ! schmidt Schmidt number *
+ ! ustar [m/s] friction velocity *
+ ! diffh20 [m2/s] diffusivity of water vapor in air *
+ ! reldiff diffusivity relative to H2O *
+ ! *
+ ! Constants: *
+ ! karman von Karman constant *
+ ! pr Prandtl number *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+
+ implicit none
+
+ real :: ustar,diffh2o,rb(maxspec),schmidt,nyl
+ real :: reldiff(maxspec)
+ integer :: ic,nc
+ real,parameter :: pr=0.72
+
+ do ic=1,nc
+ if (reldiff(ic).gt.0.) then
+ schmidt=nyl/diffh2o*reldiff(ic)
+ rb(ic)=2.0*(schmidt/pr)**0.67/(karman*ustar)
+ endif
+ end do
+
+end subroutine getrb
diff --git a/src/getrc.f90 b/src/getrc.f90
new file mode 100644
index 0000000000000000000000000000000000000000..05bbbe2d4d6ac1f83949d51596f97c30eb143709
--- /dev/null
+++ b/src/getrc.f90
@@ -0,0 +1,122 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine getrc(nc,i,j,t,gr,rh,rr,rc)
+ ! i i i i i i i o
+ !*****************************************************************************
+ ! *
+ ! Calculation of the surface resistance according to the procedure given *
+ ! in: *
+ ! Wesely (1989): Parameterization of surface resistances to gaseous *
+ ! dry deposition in regional-scale numerical models. *
+ ! Atmos. Environ. 23, 1293-1304. *
+ ! *
+ ! *
+ ! AUTHOR: Andreas Stohl, 19 May 1995 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! reldiff(maxspec) diffusivity of H2O/diffusivity of component i *
+ ! gr [W/m2] global radiation *
+ ! i index of seasonal category *
+ ! j index of landuse class *
+ ! ldep(maxspec) 1, if deposition shall be calculated for species i *
+ ! nc actual number of chemical components *
+ ! rcl(maxspec,5,8) [s/m] Lower canopy resistance *
+ ! rgs(maxspec,5,8) [s/m] Ground resistance *
+ ! rlu(maxspec,5,8) [s/m] Leaf cuticular resistance *
+ ! rm(maxspec) [s/m] Mesophyll resistance *
+ ! t [C] temperature *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: i,j,ic,nc
+ real :: gr,rh,rr,t,rs,rsm,corr,rluc,rclc,rgsc,rdc,rluo
+ real :: rc(maxspec)
+
+
+ ! Compute stomatal resistance
+ !****************************
+ ! Sabine Eckhardt, Dec 06: use 1E25 instead of 99999. for infinite res.
+
+ if ((t.gt.0.).and.(t.lt.40.)) then
+ rs=ri(i,j)*(1.+(200./(gr+0.1))**2)*(400./(t*(40.-t)))
+ else
+ rs=1.E25
+ ! rs=99999.
+ endif
+
+
+ ! Correct stomatal resistance for effect of dew and rain
+ !*******************************************************
+
+ if ((rh.gt.0.9).or.(rr.gt.0.)) rs=rs*3.
+
+ ! Compute the lower canopy resistance
+ !************************************
+
+ rdc=100.*(1.+1000./(gr+10.))
+
+
+ corr=1000.*exp(-1.*t-4.)
+ do ic=1,nc
+ if (reldiff(ic).gt.0.) then
+
+ ! Compute combined stomatal and mesophyll resistance
+ !***************************************************
+
+ rsm=rs*reldiff(ic)+rm(ic)
+
+ ! Correct leaf cuticular, lower canopy and ground resistance
+ !***********************************************************
+
+ rluc=rlu(ic,i,j)+corr
+ rclc=rcl(ic,i,j)+corr
+ rgsc=rgs(ic,i,j)+corr
+
+ ! Correct leaf cuticular resistance for effect of dew and rain
+ !*************************************************************
+
+ if (rr.gt.0.) then
+ rluo=1./(1./1000.+1./(3.*rluc))
+ rluc=1./(1./(3.*rluc)+1.e-7*henry(ic)+f0(ic)/rluo)
+ else if (rh.gt.0.9) then
+ rluo=1./(1./3000.+1./(3.*rluc))
+ rluc=1./(1./(3.*rluc)+1.e-7*henry(ic)+f0(ic)/rluo)
+ endif
+
+ ! Combine resistances to give total resistance
+ !*********************************************
+
+ rc(ic)=1./(1./rsm+1./rluc+1./(rdc+rclc)+1./(rac(i,j)+rgsc))
+ ! Sabine Eckhardt, Dec 06: avoid possible excessively high vdep
+ if (rc(ic).lt.10.) rc(ic)=10.
+ endif
+ end do
+
+end subroutine getrc
diff --git a/src/getvdep.f90 b/src/getvdep.f90
new file mode 100644
index 0000000000000000000000000000000000000000..140f627b7f82c366fafcee20156b295a9a55722b
--- /dev/null
+++ b/src/getvdep.f90
@@ -0,0 +1,203 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine getvdep(n,ix,jy,ust,temp,pa,L,gr,rh,rr,snow,vdepo)
+ ! i i i i i i i i i i i o
+ !*****************************************************************************
+ ! *
+ ! This routine calculates the dry deposition velocities. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 20 December 1996 *
+ ! Sabine Eckhardt, Jan 07 *
+ ! if the latitude is negative: add half a year to the julian day *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! gr [W/m2] global radiation *
+ ! L [m] Obukhov length *
+ ! nyl kinematic viscosity *
+ ! pa [Pa] surface air pressure *
+ ! ra [s/m] aerodynamic resistance *
+ ! raquer [s/m] average aerodynamic resistance *
+ ! rh [0-1] relative humidity *
+ ! rhoa density of the air *
+ ! rr [mm/h] precipitation rate *
+ ! temp [K] 2m temperature *
+ ! tc [C] 2m temperature *
+ ! ust [m/s] friction velocity *
+ ! snow [m of water equivalent] snow depth *
+ ! xlanduse fractions of numclasS landuses for each model grid point *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: yyyymmdd,hhmmss,yyyy,mmdd,n,lseason,i,j,ix,jy
+ real :: vdepo(maxspec),vd,rb(maxspec),rc(maxspec),raquer,ylat
+ real :: raerod,ra,ust,temp,tc,pa,L,gr,rh,rr,myl,nyl,rhoa,diffh2o,snow
+ real :: slanduse(numclass)
+ real,parameter :: eps=1.e-5
+ real(kind=dp) :: jul
+
+ ! Calculate month and determine the seasonal category
+ !****************************************************
+
+ jul=bdate+real(wftime(n),kind=dp)/86400._dp
+
+ ylat=jy*dy+ylat0
+ if (ylat.lt.0) then
+ jul=jul+365/2
+ endif
+
+
+ call caldate(jul,yyyymmdd,hhmmss)
+ yyyy=yyyymmdd/10000
+ mmdd=yyyymmdd-10000*yyyy
+
+ if ((ylat.gt.-20).and.(ylat.lt.20)) then
+ mmdd=600 ! summer
+ endif
+
+ if ((mmdd.ge.1201).or.(mmdd.le.301)) then
+ lseason=4
+ else if ((mmdd.ge.1101).or.(mmdd.le.331)) then
+ lseason=3
+ else if ((mmdd.ge.401).and.(mmdd.le.515)) then
+ lseason=5
+ else if ((mmdd.ge.516).and.(mmdd.le.915)) then
+ lseason=1
+ else
+ lseason=2
+ endif
+
+ ! Calculate diffusivity of water vapor
+ !************************************
+ diffh2o=2.11e-5*(temp/273.15)**1.94*(101325/pa)
+
+ ! Conversion of temperature from K to C
+ !**************************************
+
+ tc=temp-273.15
+
+ ! Calculate dynamic viscosity
+ !****************************
+
+ if (tc.lt.0) then
+ myl=(1.718+0.0049*tc-1.2e-05*tc**2)*1.e-05
+ else
+ myl=(1.718+0.0049*tc)*1.e-05
+ endif
+
+ ! Calculate kinematic viscosity
+ !******************************
+
+ rhoa=pa/(287.*temp)
+ nyl=myl/rhoa
+
+
+ ! 0. Set all deposition velocities zero
+ !**************************************
+
+ do i=1,nspec
+ vdepo(i)=0.
+ end do
+
+
+ ! 1. Compute surface layer resistances rb
+ !****************************************
+
+ call getrb(nspec,ust,nyl,diffh2o,reldiff,rb)
+
+ ! change for snow
+ do j=1,numclass
+ if (snow.gt.0.001) then ! 10 mm
+ if (j.eq.12) then
+ slanduse(j)=1.
+ else
+ slanduse(j)=0.
+ endif
+ else
+ slanduse(j)=xlanduse(ix,jy,j)
+ endif
+ end do
+
+ raquer=0.
+ do j=1,numclass ! loop over all landuse classes
+
+ if (slanduse(j).gt.eps) then
+
+ ! 2. Calculate aerodynamic resistance ra
+ !***************************************
+
+ ra=raerod(L,ust,z0(j))
+ raquer=raquer+ra*slanduse(j)
+
+ ! 3. Calculate surface resistance for gases
+ !******************************************
+
+ call getrc(nspec,lseason,j,tc,gr,rh,rr,rc)
+
+ ! 4. Calculate deposition velocities for gases and ...
+ ! 5. ... sum deposition velocities for all landuse classes
+ !*********************************************************
+
+ do i=1,nspec
+ if (reldiff(i).gt.0.) then
+ if ((ra+rb(i)+rc(i)).gt.0.) then
+ vd=1./(ra+rb(i)+rc(i))
+ ! XXXXXXXXXXXXXXXXXXXXXXXXXX TEST
+ ! vd=1./rc(i)
+ ! XXXXXXXXXXXXXXXXXXXXXXXXXX TEST
+ else
+ vd=9.999
+ endif
+ vdepo(i)=vdepo(i)+vd*slanduse(j)
+ endif
+ end do
+ endif
+ end do
+
+
+ ! 6. Calculate deposition velocities for particles
+ !*************************************************
+
+ call partdep(nspec,density,fract,schmi,vset,raquer,ust,nyl,vdepo)
+
+
+ ! 7. If no detailed parameterization available, take constant deposition
+ ! velocity if that is available
+ !***********************************************************************
+
+ do i=1,nspec
+ if ((reldiff(i).lt.0.).and.(density(i).lt.0.).and. &
+ (dryvel(i).gt.0.)) then
+ vdepo(i)=dryvel(i)
+ endif
+ end do
+
+
+end subroutine getvdep
diff --git a/src/getvdep_nests.f90 b/src/getvdep_nests.f90
new file mode 100644
index 0000000000000000000000000000000000000000..fd24fc9bffa654da215d5c277559e71a45f6691f
--- /dev/null
+++ b/src/getvdep_nests.f90
@@ -0,0 +1,204 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine getvdep_nests(n,ix,jy,ust,temp,pa, &
+ L,gr,rh,rr,snow,vdepo,lnest)
+ ! i i i i i i i i i i i o i
+ !*****************************************************************************
+ ! *
+ ! This routine calculates the dry deposition velocities. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 20 December 1996 *
+ ! Sabine Eckhardt, Jan 07 *
+ ! if the latitude is negative: add half a year to the julian day *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! gr [W/m2] global radiation *
+ ! L [m] Obukhov length *
+ ! nyl kinematic viscosity *
+ ! pa [Pa] surface air pressure *
+ ! ra [s/m] aerodynamic resistance *
+ ! raquer [s/m] average aerodynamic resistance *
+ ! rh [0-1] relative humidity *
+ ! rhoa density of the air *
+ ! rr [mm/h] precipitation rate *
+ ! temp [K] 2m temperature *
+ ! tc [C] 2m temperature *
+ ! ust [m/s] friction velocity *
+ ! snow [m of water equivalent] snow depth *
+ ! xlanduse fractions of numclasS landuses for each model grid point *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: yyyymmdd,hhmmss,yyyy,mmdd,n,lseason,i,j,ix,jy,lnest
+ real :: vdepo(maxspec),vd,rb(maxspec),rc(maxspec),raquer,ylat
+ real :: raerod,ra,ust,temp,tc,pa,L,gr,rh,rr,myl,nyl,rhoa,diffh2o,snow
+ real :: slanduse(numclass)
+ real,parameter :: eps=1.e-5
+ real(kind=dp) :: jul
+
+ ! Calculate month and determine the seasonal category
+ !****************************************************
+
+ jul=bdate+real(wftime(n),kind=dp)/86400._dp
+
+ ylat=jy*dy+ylat0
+ if (ylat.lt.0) then
+ jul=jul+365/2
+ endif
+
+
+ call caldate(jul,yyyymmdd,hhmmss)
+ yyyy=yyyymmdd/10000
+ mmdd=yyyymmdd-10000*yyyy
+
+ if ((ylat.gt.-20).and.(ylat.lt.20)) then
+ mmdd=600 ! summer
+ endif
+
+ if ((mmdd.ge.1201).or.(mmdd.le.301)) then
+ lseason=4
+ else if ((mmdd.ge.1101).or.(mmdd.le.331)) then
+ lseason=3
+ else if ((mmdd.ge.401).and.(mmdd.le.515)) then
+ lseason=5
+ else if ((mmdd.ge.516).and.(mmdd.le.915)) then
+ lseason=1
+ else
+ lseason=2
+ endif
+
+ ! Calculate diffusivity of water vapor
+ !************************************
+ diffh2o=2.11e-5*(temp/273.15)**1.94*(101325/pa)
+
+ ! Conversion of temperature from K to C
+ !**************************************
+
+ tc=temp-273.15
+
+ ! Calculate dynamic viscosity
+ !****************************
+
+ if (tc.lt.0) then
+ myl=(1.718+0.0049*tc-1.2e-05*tc**2)*1.e-05
+ else
+ myl=(1.718+0.0049*tc)*1.e-05
+ endif
+
+ ! Calculate kinematic viscosity
+ !******************************
+
+ rhoa=pa/(287.*temp)
+ nyl=myl/rhoa
+
+
+ ! 0. Set all deposition velocities zero
+ !**************************************
+
+ do i=1,nspec
+ vdepo(i)=0.
+ end do
+
+
+ ! 1. Compute surface layer resistances rb
+ !****************************************
+
+ call getrb(nspec,ust,nyl,diffh2o,reldiff,rb)
+
+ ! change for snow
+ do j=1,numclass
+ if (snow.gt.0.001) then ! 10 mm
+ if (j.eq.12) then
+ slanduse(j)=1.
+ else
+ slanduse(j)=0.
+ endif
+ else
+ slanduse(j)=xlandusen(ix,jy,j,lnest)
+ endif
+ end do
+
+ raquer=0.
+ do j=1,numclass ! loop over all landuse classes
+
+ if (slanduse(j).gt.eps) then
+
+ ! 2. Calculate aerodynamic resistance ra
+ !***************************************
+
+ ra=raerod(L,ust,z0(j))
+ raquer=raquer+ra*slanduse(j)
+
+ ! 3. Calculate surface resistance for gases
+ !******************************************
+
+ call getrc(nspec,lseason,j,tc,gr,rh,rr,rc)
+
+ ! 4. Calculate deposition velocities for gases and ...
+ ! 5. ... sum deposition velocities for all landuse classes
+ !*********************************************************
+
+ do i=1,nspec
+ if (reldiff(i).gt.0.) then
+ if ((ra+rb(i)+rc(i)).gt.0.) then
+ vd=1./(ra+rb(i)+rc(i))
+ ! XXXXXXXXXXXXXXXXXXXXXXXXXX TEST
+ ! vd=1./rc(i)
+ ! XXXXXXXXXXXXXXXXXXXXXXXXXX TEST
+ else
+ vd=9.999
+ endif
+ vdepo(i)=vdepo(i)+vd*slanduse(j)
+ endif
+ end do
+ endif
+ end do
+
+
+ ! 6. Calculate deposition velocities for particles
+ !*************************************************
+
+ call partdep(nspec,density,fract,schmi,vset,raquer,ust,nyl,vdepo)
+
+
+ ! 7. If no detailed parameterization available, take constant deposition
+ ! velocity if that is available
+ !***********************************************************************
+
+ do i=1,nspec
+ if ((reldiff(i).lt.0.).and.(density(i).lt.0.).and. &
+ (dryvel(i).gt.0.)) then
+ vdepo(i)=dryvel(i)
+ endif
+ end do
+
+
+end subroutine getvdep_nests
diff --git a/src/gridcheck.f90 b/src/gridcheck.f90
new file mode 100644
index 0000000000000000000000000000000000000000..3da581abc793a547081f8dff8ca8409951c7000a
--- /dev/null
+++ b/src/gridcheck.f90
@@ -0,0 +1,554 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine gridcheck
+
+ !**********************************************************************
+ ! *
+ ! FLEXPART MODEL SUBROUTINE GRIDCHECK *
+ ! *
+ !**********************************************************************
+ ! *
+ ! AUTHOR: G. WOTAWA *
+ ! DATE: 1997-08-06 *
+ ! LAST UPDATE: 1997-10-10 *
+ ! *
+ ! Update: 1999-02-08, global fields allowed, A. Stohl*
+ ! CHANGE: 11/01/2008, Harald Sodemann, GRIB1/2 input with *
+ ! ECMWF grib_api *
+ ! CHANGE: 03/12/2008, Harald Sodemann, update to f90 with *
+ ! ECMWF grib_api *
+ ! *
+ !**********************************************************************
+ ! *
+ ! DESCRIPTION: *
+ ! *
+ ! THIS SUBROUTINE DETERMINES THE GRID SPECIFICATIONS (LOWER LEFT *
+ ! LONGITUDE, LOWER LEFT LATITUDE, NUMBER OF GRID POINTS, GRID DIST- *
+ ! ANCE AND VERTICAL DISCRETIZATION OF THE ECMWF MODEL) FROM THE *
+ ! GRIB HEADER OF THE FIRST INPUT FILE. THE CONSISTANCY (NO CHANGES *
+ ! WITHIN ONE FLEXPART RUN) IS CHECKED IN THE ROUTINE "READWIND" AT *
+ ! ANY CALL. *
+ ! *
+ ! XLON0 geographical longitude of lower left gridpoint *
+ ! YLAT0 geographical latitude of lower left gridpoint *
+ ! NX number of grid points x-direction *
+ ! NY number of grid points y-direction *
+ ! DX grid distance x-direction *
+ ! DY grid distance y-direction *
+ ! NUVZ number of grid points for horizontal wind *
+ ! components in z direction *
+ ! NWZ number of grid points for vertical wind *
+ ! component in z direction *
+ ! sizesouth, sizenorth give the map scale (i.e. number of virtual grid*
+ ! points of the polar stereographic grid): *
+ ! used to check the CFL criterion *
+ ! UVHEIGHT(1)- heights of gridpoints where u and v are *
+ ! UVHEIGHT(NUVZ) given *
+ ! WHEIGHT(1)- heights of gridpoints where w is given *
+ ! WHEIGHT(NWZ) *
+ ! *
+ !**********************************************************************
+
+ use grib_api
+ use par_mod
+ use com_mod
+ use conv_mod
+ use cmapf_mod, only: stlmbr,stcm2p
+
+ implicit none
+
+ !HSO parameters for grib_api
+ integer :: ifile
+ integer :: iret
+ integer :: igrib
+ integer :: gotGrid
+ real(kind=4) :: xaux1,xaux2,yaux1,yaux2
+ real(kind=8) :: xaux1in,xaux2in,yaux1in,yaux2in
+ integer :: gribVer,parCat,parNum,typSurf,valSurf,discipl
+ !HSO end
+ integer :: ix,jy,i,ifn,ifield,j,k,iumax,iwmax,numskip
+ real :: sizesouth,sizenorth,xauxa,pint
+
+ ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING
+
+ ! dimension of isec2 at least (22+n), where n is the number of parallels or
+ ! meridians in a quasi-regular (reduced) Gaussian or lat/long grid
+
+ ! dimension of zsec2 at least (10+nn), where nn is the number of vertical
+ ! coordinate parameters
+
+ integer :: isec1(56),isec2(22+nxmax+nymax)
+ !real(kind=4) :: zsec2(60+2*nuvzmax),zsec4(jpunp)
+ real(kind=4) :: zsec2(184),zsec4(jpunp)
+ character(len=1) :: opt
+
+ !HSO grib api error messages
+ character(len=24) :: gribErrorMsg = 'Error reading grib file'
+ character(len=20) :: gribFunction = 'gridcheck'
+
+ iumax=0
+ iwmax=0
+
+ if(ideltas.gt.0) then
+ ifn=1
+ else
+ ifn=numbwf
+ endif
+ !
+ ! OPENING OF DATA FILE (GRIB CODE)
+ !
+5 call grib_open_file(ifile,path(3)(1:length(3)) &
+ //trim(wfname(ifn)),'r',iret)
+ if (iret.ne.GRIB_SUCCESS) then
+ goto 999 ! ERROR DETECTED
+ endif
+ !turn on support for multi fields messages
+ !call grib_multi_support_on
+
+ gotGrid=0
+ ifield=0
+10 ifield=ifield+1
+
+ !
+ ! GET NEXT FIELDS
+ !
+ call grib_new_from_file(ifile,igrib,iret)
+ if (iret.eq.GRIB_END_OF_FILE ) then
+ goto 30 ! EOF DETECTED
+ elseif (iret.ne.GRIB_SUCCESS) then
+ goto 999 ! ERROR DETECTED
+ endif
+
+ !first see if we read GRIB1 or GRIB2
+ call grib_get_int(igrib,'editionNumber',gribVer,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ if (gribVer.eq.1) then ! GRIB Edition 1
+
+ !print*,'GRiB Edition 1'
+ !read the grib2 identifiers
+ call grib_get_int(igrib,'indicatorOfParameter',isec1(6),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'level',isec1(8),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ !change code for etadot to code for omega
+ if (isec1(6).eq.77) then
+ isec1(6)=135
+ endif
+
+ !print*,isec1(6),isec1(8)
+
+ else
+
+ !print*,'GRiB Edition 2'
+ !read the grib2 identifiers
+ call grib_get_int(igrib,'discipline',discipl,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'parameterCategory',parCat,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'parameterNumber',parNum,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'typeOfFirstFixedSurface',typSurf,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'level',valSurf,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ !print*,discipl,parCat,parNum,typSurf,valSurf
+
+ !convert to grib1 identifiers
+ isec1(6)=-1
+ isec1(7)=-1
+ isec1(8)=-1
+ isec1(8)=valSurf ! level
+ if ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.105)) then ! T
+ isec1(6)=130 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.105)) then ! U
+ isec1(6)=131 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.105)) then ! V
+ isec1(6)=132 ! indicatorOfParameter
+ elseif ((parCat.eq.1).and.(parNum.eq.0).and.(typSurf.eq.105)) then ! Q
+ isec1(6)=133 ! indicatorOfParameter
+ elseif ((parCat.eq.3).and.(parNum.eq.0).and.(typSurf.eq.1)) then !SP
+ isec1(6)=134 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.32)) then ! W, actually eta dot
+ isec1(6)=135 ! indicatorOfParameter
+ elseif ((parCat.eq.3).and.(parNum.eq.0).and.(typSurf.eq.101)) then !SLP
+ isec1(6)=151 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.103)) then ! 10U
+ isec1(6)=165 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.103)) then ! 10V
+ isec1(6)=166 ! indicatorOfParameter
+ elseif ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.103)) then ! 2T
+ isec1(6)=167 ! indicatorOfParameter
+ elseif ((parCat.eq.0).and.(parNum.eq.6).and.(typSurf.eq.103)) then ! 2D
+ isec1(6)=168 ! indicatorOfParameter
+ elseif ((parCat.eq.1).and.(parNum.eq.11).and.(typSurf.eq.1)) then ! SD
+ isec1(6)=141 ! indicatorOfParameter
+ elseif ((parCat.eq.6).and.(parNum.eq.1)) then ! CC
+ isec1(6)=164 ! indicatorOfParameter
+ elseif ((parCat.eq.1).and.(parNum.eq.9)) then ! LSP
+ isec1(6)=142 ! indicatorOfParameter
+ elseif ((parCat.eq.1).and.(parNum.eq.10)) then ! CP
+ isec1(6)=143 ! indicatorOfParameter
+ elseif ((parCat.eq.0).and.(parNum.eq.11).and.(typSurf.eq.1)) then ! SHF
+ isec1(6)=146 ! indicatorOfParameter
+ elseif ((parCat.eq.4).and.(parNum.eq.9).and.(typSurf.eq.1)) then ! SR
+ isec1(6)=176 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.17)) then ! EWSS
+ isec1(6)=180 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.18)) then ! NSSS
+ isec1(6)=181 ! indicatorOfParameter
+ elseif ((parCat.eq.3).and.(parNum.eq.4)) then ! ORO
+ isec1(6)=129 ! indicatorOfParameter
+ elseif ((parCat.eq.3).and.(parNum.eq.7)) then ! SDO
+ isec1(6)=160 ! indicatorOfParameter
+ elseif ((discipl.eq.2).and.(parCat.eq.0).and.(parNum.eq.0).and. &
+ (typSurf.eq.1)) then ! LSM
+ isec1(6)=172 ! indicatorOfParameter
+ else
+ print*,'***ERROR: undefined GRiB2 message found!',discipl, &
+ parCat,parNum,typSurf
+ endif
+
+ endif
+
+ !get the size and data of the values array
+ if (isec1(6).ne.-1) then
+ call grib_get_real4_array(igrib,'values',zsec4,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ endif
+
+ if (ifield.eq.1) then
+
+ !HSO get the required fields from section 2 in a gribex compatible manner
+ call grib_get_int(igrib,'numberOfPointsAlongAParallel', &
+ isec2(2),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'numberOfPointsAlongAMeridian', &
+ isec2(3),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_real8(igrib,'longitudeOfFirstGridPointInDegrees', &
+ xaux1in,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'numberOfVerticalCoordinateValues', &
+ isec2(12),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ ! get the size and data of the vertical coordinate array
+ call grib_get_real4_array(igrib,'pv',zsec2,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ nxfield=isec2(2)
+ ny=isec2(3)
+ nlev_ec=isec2(12)/2-1
+ endif
+
+ !HSO get the second part of the grid dimensions only from GRiB1 messages
+ if ((gribVer.eq.1).and.(gotGrid.eq.0)) then
+ call grib_get_real8(igrib,'longitudeOfLastGridPointInDegrees', &
+ xaux2in,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_real8(igrib,'latitudeOfLastGridPointInDegrees', &
+ yaux1in,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_real8(igrib,'latitudeOfFirstGridPointInDegrees', &
+ yaux2in,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ xaux1=xaux1in
+ xaux2=xaux2in
+ yaux1=yaux1in
+ yaux2=yaux2in
+ if (xaux1.gt.180.) xaux1=xaux1-360.0
+ if (xaux2.gt.180.) xaux2=xaux2-360.0
+ if (xaux1.lt.-180.) xaux1=xaux1+360.0
+ if (xaux2.lt.-180.) xaux2=xaux2+360.0
+ if (xaux2.lt.xaux1) xaux2=xaux2+360.0
+ xlon0=xaux1
+ ylat0=yaux1
+ dx=(xaux2-xaux1)/real(nxfield-1)
+ dy=(yaux2-yaux1)/real(ny-1)
+ dxconst=180./(dx*r_earth*pi)
+ dyconst=180./(dy*r_earth*pi)
+ gotGrid=1
+
+ ! Check whether fields are global
+ ! If they contain the poles, specify polar stereographic map
+ ! projections using the stlmbr- and stcm2p-calls
+ !***********************************************************
+
+ xauxa=abs(xaux2+dx-360.-xaux1)
+ if (xauxa.lt.0.001) then
+ nx=nxfield+1 ! field is cyclic
+ xglobal=.true.
+ if (abs(nxshift).ge.nx) &
+ stop 'nxshift in file par_mod is too large'
+ xlon0=xlon0+real(nxshift)*dx
+ else
+ nx=nxfield
+ xglobal=.false.
+ if (nxshift.ne.0) &
+ stop 'nxshift (par_mod) must be zero for non-global domain'
+ endif
+ nxmin1=nx-1
+ nymin1=ny-1
+ if (xlon0.gt.180.) xlon0=xlon0-360.
+ xauxa=abs(yaux1+90.)
+ if (xglobal.and.xauxa.lt.0.001) then
+ sglobal=.true. ! field contains south pole
+ ! Enhance the map scale by factor 3 (*2=6) compared to north-south
+ ! map scale
+ sizesouth=6.*(switchsouth+90.)/dy
+ call stlmbr(southpolemap,-90.,0.)
+ call stcm2p(southpolemap,0.,0.,switchsouth,0.,sizesouth, &
+ sizesouth,switchsouth,180.)
+ switchsouthg=(switchsouth-ylat0)/dy
+ else
+ sglobal=.false.
+ switchsouthg=999999.
+ endif
+ xauxa=abs(yaux2-90.)
+ if (xglobal.and.xauxa.lt.0.001) then
+ nglobal=.true. ! field contains north pole
+ ! Enhance the map scale by factor 3 (*2=6) compared to north-south
+ ! map scale
+ sizenorth=6.*(90.-switchnorth)/dy
+ call stlmbr(northpolemap,90.,0.)
+ call stcm2p(northpolemap,0.,0.,switchnorth,0.,sizenorth, &
+ sizenorth,switchnorth,180.)
+ switchnorthg=(switchnorth-ylat0)/dy
+ else
+ nglobal=.false.
+ switchnorthg=999999.
+ endif
+ if (nxshift.lt.0) &
+ stop 'nxshift (par_mod) must not be negative'
+ if (nxshift.ge.nxfield) stop 'nxshift (par_mod) too large'
+ endif ! gotGrid
+
+ k=isec1(8)
+ if(isec1(6).eq.131) iumax=max(iumax,nlev_ec-k+1)
+ if(isec1(6).eq.135) iwmax=max(iwmax,nlev_ec-k+1)
+
+ if(isec1(6).eq.129) then
+ do jy=0,ny-1
+ do ix=0,nxfield-1
+ oro(ix,jy)=zsec4(nxfield*(ny-jy-1)+ix+1)/ga
+ end do
+ end do
+ endif
+ if(isec1(6).eq.172) then
+ do jy=0,ny-1
+ do ix=0,nxfield-1
+ lsm(ix,jy)=zsec4(nxfield*(ny-jy-1)+ix+1)
+ end do
+ end do
+ endif
+ if(isec1(6).eq.160) then
+ do jy=0,ny-1
+ do ix=0,nxfield-1
+ excessoro(ix,jy)=zsec4(nxfield*(ny-jy-1)+ix+1)
+ end do
+ end do
+ endif
+
+ call grib_release(igrib)
+ goto 10 !! READ NEXT LEVEL OR PARAMETER
+ !
+ ! CLOSING OF INPUT DATA FILE
+ !
+
+30 call grib_close_file(ifile)
+
+ !error message if no fields found with correct first longitude in it
+ if (gotGrid.eq.0) then
+ print*,'***ERROR: input file needs to contain GRiB1 formatted'// &
+ 'messages'
+ stop
+ endif
+
+ nuvz=iumax
+ nwz =iwmax
+ if(nuvz.eq.nlev_ec) nwz=nlev_ec+1
+
+ if (nx.gt.nxmax) then
+ write(*,*) 'FLEXPART error: Too many grid points in x direction.'
+ write(*,*) 'Reduce resolution of wind fields.'
+ write(*,*) 'Or change parameter settings in file par_mod.'
+ write(*,*) nx,nxmax
+ stop
+ endif
+
+ if (ny.gt.nymax) then
+ write(*,*) 'FLEXPART error: Too many grid points in y direction.'
+ write(*,*) 'Reduce resolution of wind fields.'
+ write(*,*) 'Or change parameter settings in file par_mod.'
+ write(*,*) ny,nymax
+ stop
+ endif
+
+ if (nuvz+1.gt.nuvzmax) then
+ write(*,*) 'FLEXPART error: Too many u,v grid points in z '// &
+ 'direction.'
+ write(*,*) 'Reduce resolution of wind fields.'
+ write(*,*) 'Or change parameter settings in file par_mod.'
+ write(*,*) nuvz+1,nuvzmax
+ stop
+ endif
+
+ if (nwz.gt.nwzmax) then
+ write(*,*) 'FLEXPART error: Too many w grid points in z '// &
+ 'direction.'
+ write(*,*) 'Reduce resolution of wind fields.'
+ write(*,*) 'Or change parameter settings in file par_mod.'
+ write(*,*) nwz,nwzmax
+ stop
+ endif
+
+ ! If desired, shift all grids by nxshift grid cells
+ !**************************************************
+
+ if (xglobal) then
+ call shift_field_0(oro,nxfield,ny)
+ call shift_field_0(lsm,nxfield,ny)
+ call shift_field_0(excessoro,nxfield,ny)
+ endif
+
+ ! Output of grid info
+ !********************
+
+ write(*,*)
+ write(*,*)
+ write(*,'(a,2i7)') '# of vertical levels in ECMWF data: ', &
+ nuvz+1,nwz
+ write(*,*)
+ write(*,'(a)') 'Mother domain:'
+ write(*,'(a,f10.2,a1,f10.2,a,f10.2)') ' Longitude range: ', &
+ xlon0,' to ',xlon0+(nx-1)*dx,' Grid distance: ',dx
+ write(*,'(a,f10.2,a1,f10.2,a,f10.2)') ' Latitude range: ', &
+ ylat0,' to ',ylat0+(ny-1)*dy,' Grid distance: ',dy
+ write(*,*)
+
+
+ ! CALCULATE VERTICAL DISCRETIZATION OF ECMWF MODEL
+ ! PARAMETER akm,bkm DESCRIBE THE HYBRID "ETA" COORDINATE SYSTEM
+
+ numskip=nlev_ec-nuvz ! number of ecmwf model layers not used
+ ! by trajectory model
+ !do 8940 i=1,244
+ ! write (*,*) 'zsec2:',i,ifield,zsec2(i),numskip
+ !940 continue
+ ! stop
+ ! SEC SEC SEC
+ ! for unknown reason zsec 1 to 10 is filled in this version
+ ! compared to the old one
+ ! SEC SEC SE
+ do i=1,nwz
+ j=numskip+i
+ k=nlev_ec+1+numskip+i
+ akm(nwz-i+1)=zsec2(j)
+ bkm(nwz-i+1)=zsec2(k)
+ end do
+
+ !
+ ! CALCULATION OF AKZ, BKZ
+ ! AKZ,BKZ: model discretization parameters at the center of each model
+ ! layer
+ !
+ ! Assign the 10 m winds to an artificial model level with akz=0 and bkz=1.0,
+ ! i.e. ground level
+ !*****************************************************************************
+
+ akz(1)=0.
+ bkz(1)=1.0
+ do i=1,nuvz
+ akz(i+1)=0.5*(akm(i+1)+akm(i))
+ bkz(i+1)=0.5*(bkm(i+1)+bkm(i))
+ end do
+ nuvz=nuvz+1
+
+ ! NOTE: In FLEXPART versions up to 4.0, the number of model levels was doubled
+ ! upon the transformation to z levels. In order to save computer memory, this is
+ ! not done anymore in the standard version. However, this option can still be
+ ! switched on by replacing the following lines with those below, that are
+ ! currently commented out. For this, similar changes are necessary in
+ ! verttransform.f and verttranform_nests.f
+ !*****************************************************************************
+
+ nz=nuvz
+ if (nz.gt.nzmax) stop 'nzmax too small'
+ do i=1,nuvz
+ aknew(i)=akz(i)
+ bknew(i)=bkz(i)
+ end do
+
+ ! Switch on following lines to use doubled vertical resolution
+ !*************************************************************
+ !nz=nuvz+nwz-1
+ !if (nz.gt.nzmax) stop 'nzmax too small'
+ !do 100 i=1,nwz
+ ! aknew(2*(i-1)+1)=akm(i)
+ !00 bknew(2*(i-1)+1)=bkm(i)
+ !do 110 i=2,nuvz
+ ! aknew(2*(i-1))=akz(i)
+ !10 bknew(2*(i-1))=bkz(i)
+ ! End doubled vertical resolution
+
+
+ ! Determine the uppermost level for which the convection scheme shall be applied
+ ! by assuming that there is no convection above 50 hPa (for standard SLP)
+ !*****************************************************************************
+
+ do i=1,nuvz-2
+ pint=akz(i)+bkz(i)*101325.
+ if (pint.lt.5000.) goto 96
+ end do
+96 nconvlev=i
+ if (nconvlev.gt.nconvlevmax-1) then
+ nconvlev=nconvlevmax-1
+ write(*,*) 'Attention, convection only calculated up to ', &
+ akz(nconvlev)+bkz(nconvlev)*1013.25,' hPa'
+ endif
+
+ return
+
+999 write(*,*)
+ write(*,*) ' ###########################################'// &
+ '###### '
+ write(*,*) ' TRAJECTORY MODEL SUBROUTINE GRIDCHECK:'
+ write(*,*) ' CAN NOT OPEN INPUT DATA FILE '//wfname(ifn)
+ write(*,*) ' ###########################################'// &
+ '###### '
+ write(*,*)
+ write(*,'(a)') '!!! PLEASE INSERT A NEW CD-ROM AND !!!'
+ write(*,'(a)') '!!! PRESS ANY KEY TO CONTINUE... !!!'
+ write(*,'(a)') '!!! ...OR TERMINATE FLEXPART PRESSING!!!'
+ write(*,'(a)') '!!! THE "X" KEY... !!!'
+ write(*,*)
+ read(*,'(a)') opt
+ if(opt.eq.'X') then
+ stop
+ else
+ goto 5
+ endif
+
+end subroutine gridcheck
diff --git a/src/gridcheck_emos.f90 b/src/gridcheck_emos.f90
new file mode 100644
index 0000000000000000000000000000000000000000..474de4a74464cebbb95656aa66fc7427afbe844b
--- /dev/null
+++ b/src/gridcheck_emos.f90
@@ -0,0 +1,396 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine gridcheck
+
+ !**********************************************************************
+ ! *
+ ! FLEXPART MODEL SUBROUTINE GRIDCHECK *
+ ! *
+ !**********************************************************************
+ ! *
+ ! AUTHOR: G. WOTAWA *
+ ! DATE: 1997-08-06 *
+ ! LAST UPDATE: 1997-10-10 *
+ ! *
+ ! Update: 1999-02-08, global fields allowed, A. Stohl*
+ ! *
+ !**********************************************************************
+ ! *
+ ! DESCRIPTION: *
+ ! *
+ ! THIS SUBROUTINE DETERMINES THE GRID SPECIFICATIONS (LOWER LEFT *
+ ! LONGITUDE, LOWER LEFT LATITUDE, NUMBER OF GRID POINTS, GRID DIST- *
+ ! ANCE AND VERTICAL DISCRETIZATION OF THE ECMWF MODEL) FROM THE *
+ ! GRIB HEADER OF THE FIRST INPUT FILE. THE CONSISTANCY (NO CHANGES *
+ ! WITHIN ONE FLEXPART RUN) IS CHECKED IN THE ROUTINE "READWIND" AT *
+ ! ANY CALL. *
+ ! *
+ ! XLON0 geographical longitude of lower left gridpoint *
+ ! YLAT0 geographical latitude of lower left gridpoint *
+ ! NX number of grid points x-direction *
+ ! NY number of grid points y-direction *
+ ! DX grid distance x-direction *
+ ! DY grid distance y-direction *
+ ! NUVZ number of grid points for horizontal wind *
+ ! components in z direction *
+ ! NWZ number of grid points for vertical wind *
+ ! component in z direction *
+ ! sizesouth, sizenorth give the map scale (i.e. number of virtual grid*
+ ! points of the polar stereographic grid): *
+ ! used to check the CFL criterion *
+ ! UVHEIGHT(1)- heights of gridpoints where u and v are *
+ ! UVHEIGHT(NUVZ) given *
+ ! WHEIGHT(1)- heights of gridpoints where w is given *
+ ! WHEIGHT(NWZ) *
+ ! *
+ !**********************************************************************
+
+ use par_mod
+ use com_mod
+ use conv_mod
+
+ implicit none
+
+ integer :: ix,jy,i,ifn,ifield,j,k,iumax,iwmax,numskip
+ real :: xaux1,xaux2,yaux1,yaux2,sizesouth,sizenorth,xauxa,pint
+
+ ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING
+
+ ! dimension of isec2 at least (22+n), where n is the number of parallels or
+ ! meridians in a quasi-regular (reduced) Gaussian or lat/long grid
+
+ ! dimension of zsec2 at least (10+nn), where nn is the number of vertical
+ ! coordinate parameters
+
+ integer :: isec0(2),isec1(56),isec2(22+nxmax+nymax),isec3(2)
+ integer :: isec4(64),inbuff(jpack),ilen,ierr,iword,lunit
+ !integer iswap
+ real :: zsec2(60+2*nuvzmax),zsec3(2),zsec4(jpunp)
+ character(len=1) :: opt, yoper = 'D'
+
+
+ iumax=0
+ iwmax=0
+
+ if(ideltas.gt.0) then
+ ifn=1
+ else
+ ifn=numbwf
+ endif
+ !
+ ! OPENING OF DATA FILE (GRIB CODE)
+ !
+5 call pbopen(lunit,path(3)(1:length(3))//wfname(ifn),'r',ierr)
+ if(ierr.lt.0) goto 999
+
+ ifield=0
+10 ifield=ifield+1
+ !
+ ! GET NEXT FIELDS
+ !
+ call pbgrib(lunit,inbuff,jpack,ilen,ierr)
+ if(ierr.eq.-1) goto 30 ! EOF DETECTED
+ if(ierr.lt.-1) goto 999 ! ERROR DETECTED
+
+ ierr=1
+
+ ! Check whether we are on a little endian or on a big endian computer
+ !********************************************************************
+
+ !if (inbuff(1).eq.1112101447) then ! little endian, swap bytes
+ ! iswap=1+ilen/4
+ ! call swap32(inbuff,iswap)
+ !else if (inbuff(1).ne.1196575042) then ! big endian
+ ! stop 'subroutine gridcheck: corrupt GRIB data'
+ !endif
+
+ call gribex(isec0,isec1,isec2,zsec2,isec3,zsec3,isec4, &
+ zsec4,jpunp,inbuff,jpack,iword,yoper,ierr)
+ if (ierr.ne.0) goto 999 ! ERROR DETECTED
+
+ if(ifield.eq.1) then
+ nxfield=isec2(2)
+ ny=isec2(3)
+ xaux1=real(isec2(5))/1000.
+ xaux2=real(isec2(8))/1000.
+ if (xaux1.gt.180) xaux1=xaux1-360.0
+ if (xaux2.gt.180) xaux2=xaux2-360.0
+ if (xaux1.lt.-180) xaux1=xaux1+360.0
+ if (xaux2.lt.-180) xaux2=xaux2+360.0
+ if (xaux2.lt.xaux1) xaux2=xaux2+360.
+ yaux1=real(isec2(7))/1000.
+ yaux2=real(isec2(4))/1000.
+ xlon0=xaux1
+ ylat0=yaux1
+ dx=(xaux2-xaux1)/real(nxfield-1)
+ dy=(yaux2-yaux1)/real(ny-1)
+ dxconst=180./(dx*r_earth*pi)
+ dyconst=180./(dy*r_earth*pi)
+ nlev_ec=isec2(12)/2-1
+
+
+ ! Check whether fields are global
+ ! If they contain the poles, specify polar stereographic map
+ ! projections using the stlmbr- and stcm2p-calls
+ !***********************************************************
+
+ xauxa=abs(xaux2+dx-360.-xaux1)
+ if (xauxa.lt.0.001) then
+ nx=nxfield+1 ! field is cyclic
+ xglobal=.true.
+ if (abs(nxshift).ge.nx) &
+ stop 'nxshift in file par_mod is too large'
+ xlon0=xlon0+real(nxshift)*dx
+ else
+ nx=nxfield
+ xglobal=.false.
+ if (nxshift.ne.0) &
+ stop 'nxshift (par_mod) must be zero for non-global domain'
+ endif
+ nxmin1=nx-1
+ nymin1=ny-1
+ if (xlon0.gt.180.) xlon0=xlon0-360.
+ xauxa=abs(yaux1+90.)
+ if (xglobal.and.xauxa.lt.0.001) then
+ sglobal=.true. ! field contains south pole
+ ! Enhance the map scale by factor 3 (*2=6) compared to north-south
+ ! map scale
+ sizesouth=6.*(switchsouth+90.)/dy
+ call stlmbr(southpolemap,-90.,0.)
+ call stcm2p(southpolemap,0.,0.,switchsouth,0.,sizesouth, &
+ sizesouth,switchsouth,180.)
+ switchsouthg=(switchsouth-ylat0)/dy
+ else
+ sglobal=.false.
+ switchsouthg=999999.
+ endif
+ xauxa=abs(yaux2-90.)
+ if (xglobal.and.xauxa.lt.0.001) then
+ nglobal=.true. ! field contains north pole
+ ! Enhance the map scale by factor 3 (*2=6) compared to north-south
+ ! map scale
+ sizenorth=6.*(90.-switchnorth)/dy
+ call stlmbr(northpolemap,90.,0.)
+ call stcm2p(northpolemap,0.,0.,switchnorth,0.,sizenorth, &
+ sizenorth,switchnorth,180.)
+ switchnorthg=(switchnorth-ylat0)/dy
+ else
+ nglobal=.false.
+ switchnorthg=999999.
+ endif
+ endif
+
+ if (nxshift.lt.0) stop 'nxshift (par_mod) must not be negative'
+ if (nxshift.ge.nxfield) stop 'nxshift (par_mod) too large'
+
+ k=isec1(8)
+ if(isec1(6).eq.131) iumax=max(iumax,nlev_ec-k+1)
+ if(isec1(6).eq.135) iwmax=max(iwmax,nlev_ec-k+1)
+
+ if(isec1(6).eq.129) then
+ do jy=0,ny-1
+ do ix=0,nxfield-1
+ ! write (*,*) 'ich stop!',nxfield,ny,jy,ix,ga
+ ! stop
+ oro(ix,jy)=zsec4(nxfield*(ny-jy-1)+ix+1)/ga
+ end do
+ end do
+ endif
+ if(isec1(6).eq.172) then
+ do jy=0,ny-1
+ do ix=0,nxfield-1
+ lsm(ix,jy)=zsec4(nxfield*(ny-jy-1)+ix+1)
+ end do
+ end do
+ endif
+ if(isec1(6).eq.160) then
+ do jy=0,ny-1
+ do ix=0,nxfield-1
+ excessoro(ix,jy)=zsec4(nxfield*(ny-jy-1)+ix+1)
+ end do
+ end do
+ endif
+
+ goto 10 !! READ NEXT LEVEL OR PARAMETER
+ !
+ ! CLOSING OF INPUT DATA FILE
+ !
+30 call pbclose(lunit,ierr) !! FINISHED READING / CLOSING GRIB FILE
+
+ nuvz=iumax
+ nwz =iwmax
+ if(nuvz.eq.nlev_ec) nwz=nlev_ec+1
+
+ if (nx.gt.nxmax) then
+ write(*,*) 'FLEXPART error: Too many grid points in x direction.'
+ write(*,*) 'Reduce resolution of wind fields.'
+ write(*,*) 'Or change parameter settings in file par_mod.'
+ write(*,*) nx,nxmax
+ stop
+ endif
+
+ if (ny.gt.nymax) then
+ write(*,*) 'FLEXPART error: Too many grid points in y direction.'
+ write(*,*) 'Reduce resolution of wind fields.'
+ write(*,*) 'Or change parameter settings in file par_mod.'
+ write(*,*) ny,nymax
+ stop
+ endif
+
+ if (nuvz+1.gt.nuvzmax) then
+ write(*,*) 'FLEXPART error: Too many u,v grid points in z '// &
+ 'direction.'
+ write(*,*) 'Reduce resolution of wind fields.'
+ write(*,*) 'Or change parameter settings in file par_mod.'
+ write(*,*) nuvz+1,nuvzmax
+ stop
+ endif
+
+ if (nwz.gt.nwzmax) then
+ write(*,*) 'FLEXPART error: Too many w grid points in z '// &
+ 'direction.'
+ write(*,*) 'Reduce resolution of wind fields.'
+ write(*,*) 'Or change parameter settings in file par_mod.'
+ write(*,*) nwz,nwzmax
+ stop
+ endif
+
+ ! If desired, shift all grids by nxshift grid cells
+ !**************************************************
+
+ if (xglobal) then
+ call shift_field_0(oro,nxfield,ny)
+ call shift_field_0(lsm,nxfield,ny)
+ call shift_field_0(excessoro,nxfield,ny)
+ endif
+
+ ! Output of grid info
+ !********************
+
+ write(*,*)
+ write(*,*)
+ write(*,'(a,2i7)') '# of vertical levels in ECMWF data: ', &
+ nuvz+1,nwz
+ write(*,*)
+ write(*,'(a)') 'Mother domain:'
+ write(*,'(a,f10.2,a1,f10.2,a,f10.2)') ' Longitude range: ', &
+ xlon0,' to ',xlon0+(nx-1)*dx,' Grid distance: ',dx
+ write(*,'(a,f10.2,a1,f10.2,a,f10.2)') ' Latitude range: ', &
+ ylat0,' to ',ylat0+(ny-1)*dy,' Grid distance: ',dy
+ write(*,*)
+
+
+ ! CALCULATE VERTICAL DISCRETIZATION OF ECMWF MODEL
+ ! PARAMETER akm,bkm DESCRIBE THE HYBRID "ETA" COORDINATE SYSTEM
+
+ numskip=nlev_ec-nuvz ! number of ecmwf model layers not used
+ ! by trajectory model
+ do i=1,nwz
+ j=numskip+i
+ k=nlev_ec+1+numskip+i
+ akm(nwz-i+1)=zsec2(10+j)
+ bkm(nwz-i+1)=zsec2(10+k)
+ end do
+
+ !
+ ! CALCULATION OF AKZ, BKZ
+ ! AKZ,BKZ: model discretization parameters at the center of each model
+ ! layer
+ !
+ ! Assign the 10 m winds to an artificial model level with akz=0 and bkz=1.0,
+ ! i.e. ground level
+ !*****************************************************************************
+
+ akz(1)=0.
+ bkz(1)=1.0
+ do i=1,nuvz
+ akz(i+1)=0.5*(akm(i+1)+akm(i))
+ bkz(i+1)=0.5*(bkm(i+1)+bkm(i))
+ end do
+ nuvz=nuvz+1
+
+ ! NOTE: In FLEXPART versions up to 4.0, the number of model levels was doubled
+ ! upon the transformation to z levels. In order to save computer memory, this is
+ ! not done anymore in the standard version. However, this option can still be
+ ! switched on by replacing the following lines with those below, that are
+ ! currently commented out. For this, similar changes are necessary in
+ ! verttransform.f and verttranform_nests.f
+ !*****************************************************************************
+
+ nz=nuvz
+ if (nz.gt.nzmax) stop 'nzmax too small'
+ do i=1,nuvz
+ aknew(i)=akz(i)
+ bknew(i)=bkz(i)
+ end do
+
+ ! Switch on following lines to use doubled vertical resolution
+ !*************************************************************
+ !nz=nuvz+nwz-1
+ !if (nz.gt.nzmax) stop 'nzmax too small'
+ !do 100 i=1,nwz
+ ! aknew(2*(i-1)+1)=akm(i)
+ !00 bknew(2*(i-1)+1)=bkm(i)
+ !do 110 i=2,nuvz
+ ! aknew(2*(i-1))=akz(i)
+ !10 bknew(2*(i-1))=bkz(i)
+ ! End doubled vertical resolution
+
+
+ ! Determine the uppermost level for which the convection scheme shall be applied
+ ! by assuming that there is no convection above 50 hPa (for standard SLP)
+ !*****************************************************************************
+
+ do i=1,nuvz-2
+ pint=akz(i)+bkz(i)*101325.
+ if (pint.lt.5000.) goto 96
+ end do
+96 nconvlev=i
+ if (nconvlev.gt.nconvlevmax-1) then
+ nconvlev=nconvlevmax-1
+ write(*,*) 'Attention, convection only calculated up to ', &
+ akz(nconvlev)+bkz(nconvlev)*1013.25,' hPa'
+ endif
+
+ return
+
+999 write(*,*)
+ write(*,*) ' ###########################################'// &
+ '###### '
+ write(*,*) ' TRAJECTORY MODEL SUBROUTINE GRIDCHECK:'
+ write(*,*) ' CAN NOT OPEN INPUT DATA FILE '//wfname(ifn)
+ write(*,*) ' ###########################################'// &
+ '###### '
+ write(*,*)
+ write(*,'(a)') '!!! PLEASE INSERT A NEW CD-ROM AND !!!'
+ write(*,'(a)') '!!! PRESS ANY KEY TO CONTINUE... !!!'
+ write(*,'(a)') '!!! ...OR TERMINATE FLEXPART PRESSING!!!'
+ write(*,'(a)') '!!! THE "X" KEY... !!!'
+ write(*,*)
+ read(*,'(a)') opt
+ if(opt.eq.'X') then
+ stop
+ else
+ goto 5
+ endif
+
+end subroutine gridcheck
diff --git a/src/gridcheck_fnl.f90 b/src/gridcheck_fnl.f90
new file mode 100644
index 0000000000000000000000000000000000000000..dde7651ce892283b863f8f1a43df10a354326df2
--- /dev/null
+++ b/src/gridcheck_fnl.f90
@@ -0,0 +1,545 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine gridcheck
+
+ !**********************************************************************
+ ! *
+ ! FLEXPART MODEL SUBROUTINE GRIDCHECK *
+ ! *
+ !**********************************************************************
+ ! *
+ ! AUTHOR: G. WOTAWA *
+ ! DATE: 1997-08-06 *
+ ! LAST UPDATE: 1997-10-10 *
+ ! *
+ ! Update: 1999-02-08, global fields allowed, A. Stohl*
+ ! CHANGE: 17/11/2005, Caroline Forster, GFS data *
+ ! CHANGE: 11/01/2008, Harald Sodemann, GRIB1/2 input with *
+ ! ECMWF grib_api *
+ ! CHANGE: 03/12/2008, Harald Sodemann, update to f90 with *
+ ! ECMWF grib_api *
+ ! *
+ !**********************************************************************
+ ! *
+ ! DESCRIPTION: *
+ ! *
+ ! THIS SUBROUTINE DETERMINES THE GRID SPECIFICATIONS (LOWER LEFT *
+ ! LONGITUDE, LOWER LEFT LATITUDE, NUMBER OF GRID POINTS, GRID DIST- *
+ ! ANCE AND VERTICAL DISCRETIZATION OF THE ECMWF MODEL) FROM THE *
+ ! GRIB HEADER OF THE FIRST INPUT FILE. THE CONSISTANCY (NO CHANGES *
+ ! WITHIN ONE FLEXPART RUN) IS CHECKED IN THE ROUTINE "READWIND" AT *
+ ! ANY CALL. *
+ ! *
+ ! XLON0 geographical longitude of lower left gridpoint *
+ ! YLAT0 geographical latitude of lower left gridpoint *
+ ! NX number of grid points x-direction *
+ ! NY number of grid points y-direction *
+ ! DX grid distance x-direction *
+ ! DY grid distance y-direction *
+ ! NUVZ number of grid points for horizontal wind *
+ ! components in z direction *
+ ! NWZ number of grid points for vertical wind *
+ ! component in z direction *
+ ! sizesouth, sizenorth give the map scale (i.e. number of virtual grid*
+ ! points of the polar stereographic grid): *
+ ! used to check the CFL criterion *
+ ! VHEIGHT(1)- heights of gridpoints where u and v are *
+ ! UVHEIGHT(NUVZ) given *
+ ! WHEIGHT(1)- heights of gridpoints where w is given *
+ ! WHEIGHT(NWZ) *
+ ! *
+ !**********************************************************************
+
+ use grib_api
+ use par_mod
+ use com_mod
+ use conv_mod
+ use cmapf_mod, only: stlmbr,stcm2p
+
+ implicit none
+
+ !HSO parameters for grib_api
+ integer :: ifile
+ integer :: iret
+ integer :: igrib
+ real(kind=4) :: xaux1,xaux2,yaux1,yaux2
+ real(kind=8) :: xaux1in,xaux2in,yaux1in,yaux2in
+ integer :: gribVer,parCat,parNum,typSurf,valSurf,discipl
+ !HSO end
+ integer :: ix,jy,i,ifn,ifield,j,k,iumax,iwmax,numskip
+ real :: sizesouth,sizenorth,xauxa,pint
+ real :: akm_usort(nwzmax)
+ real,parameter :: eps=0.0001
+
+ ! NCEP GFS
+ real :: pres(nwzmax), help
+
+ integer :: i179,i180,i181
+
+ ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING
+
+ integer :: isec1(8),isec2(3)
+ real(kind=4) :: zsec4(jpunp)
+ character(len=1) :: opt
+
+ !HSO grib api error messages
+ character(len=24) :: gribErrorMsg = 'Error reading grib file'
+ character(len=20) :: gribFunction = 'gridcheckwind_gfs'
+ !
+ if (numbnests.ge.1) then
+ write(*,*) ' ###########################################'
+ write(*,*) ' FLEXPART ERROR SUBROUTINE GRIDCHECK:'
+ write(*,*) ' NO NESTED WINDFIELDAS ALLOWED FOR GFS! '
+ write(*,*) ' ###########################################'
+ stop
+ endif
+
+ iumax=0
+ iwmax=0
+
+ if(ideltas.gt.0) then
+ ifn=1
+ else
+ ifn=numbwf
+ endif
+ !
+ ! OPENING OF DATA FILE (GRIB CODE)
+ !
+5 call grib_open_file(ifile,path(3)(1:length(3)) &
+ //trim(wfname(ifn)),'r',iret)
+ if (iret.ne.GRIB_SUCCESS) then
+ goto 999 ! ERROR DETECTED
+ endif
+ !turn on support for multi fields messages
+ call grib_multi_support_on
+
+ ifield=0
+10 ifield=ifield+1
+ !
+ ! GET NEXT FIELDS
+ !
+ call grib_new_from_file(ifile,igrib,iret)
+ if (iret.eq.GRIB_END_OF_FILE ) then
+ goto 30 ! EOF DETECTED
+ elseif (iret.ne.GRIB_SUCCESS) then
+ goto 999 ! ERROR DETECTED
+ endif
+
+ !first see if we read GRIB1 or GRIB2
+ call grib_get_int(igrib,'editionNumber',gribVer,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ if (gribVer.eq.1) then ! GRIB Edition 1
+
+ !read the grib1 identifiers
+ call grib_get_int(igrib,'indicatorOfParameter',isec1(6),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'indicatorOfTypeOfLevel',isec1(7),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'level',isec1(8),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ !get the size and data of the values array
+ call grib_get_real4_array(igrib,'values',zsec4,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ else ! GRIB Edition 2
+
+ !read the grib2 identifiers
+ call grib_get_int(igrib,'discipline',discipl,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'parameterCategory',parCat,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'parameterNumber',parNum,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'typeOfFirstFixedSurface',typSurf,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'scaledValueOfFirstFixedSurface', &
+ valSurf,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ !convert to grib1 identifiers
+ isec1(6)=-1
+ isec1(7)=-1
+ isec1(8)=-1
+ if ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.100)) then ! U
+ isec1(6)=33 ! indicatorOfParameter
+ isec1(7)=100 ! indicatorOfTypeOfLevel
+ isec1(8)=valSurf/100 ! level, convert to hPa
+ elseif ((parCat.eq.3).and.(parNum.eq.5).and.(typSurf.eq.1)) then ! TOPO
+ isec1(6)=7 ! indicatorOfParameter
+ isec1(7)=1 ! indicatorOfTypeOfLevel
+ isec1(8)=0
+ elseif ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.1) &
+ .and.(discipl.eq.2)) then ! LSM
+ isec1(6)=81 ! indicatorOfParameter
+ isec1(7)=1 ! indicatorOfTypeOfLevel
+ isec1(8)=0
+ endif
+
+ if (isec1(6).ne.-1) then
+ ! get the size and data of the values array
+ call grib_get_real4_array(igrib,'values',zsec4,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ endif
+
+ endif ! gribVer
+
+ if(ifield.eq.1) then
+
+ !get the required fields from section 2
+ !store compatible to gribex input
+ call grib_get_int(igrib,'numberOfPointsAlongAParallel', &
+ isec2(2),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'numberOfPointsAlongAMeridian', &
+ isec2(3),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_real8(igrib,'longitudeOfFirstGridPointInDegrees', &
+ xaux1in,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_real8(igrib,'longitudeOfLastGridPointInDegrees', &
+ xaux2in,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_real8(igrib,'latitudeOfLastGridPointInDegrees', &
+ yaux1in,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_real8(igrib,'latitudeOfFirstGridPointInDegrees', &
+ yaux2in,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ xaux1=xaux1in
+! xaux2=xaux2in
+ xaux2=xaux2in+360. !!! Transform FNL xauu2in from -1 to 359 (Xuekue Fang, 31 Jan 2013)
+ yaux1=yaux1in
+ yaux2=yaux2in
+ write(*,*) 'xaux1,xaux2,yaux1,yaux2',xaux1,xaux2,yaux1,yaux2
+ nxfield=isec2(2)
+ ny=isec2(3)
+
+
+
+ if((abs(xaux1).lt.eps).and.(xaux2.ge.359)) then ! NCEP DATA FROM 0 TO
+ xaux1=-179.0 ! 359 DEG EAST ->
+ xaux2=-179.0+360.-360./real(nxfield) ! TRANSFORMED TO -179
+ endif ! TO 180 DEG EAST
+ if (xaux1.gt.180) xaux1=xaux1-360.0
+ if (xaux2.gt.180) xaux2=xaux2-360.0
+ if (xaux1.lt.-180) xaux1=xaux1+360.0
+ if (xaux2.lt.-180) xaux2=xaux2+360.0
+ if (xaux2.lt.xaux1) xaux2=xaux2+360.
+ xlon0=xaux1
+ ylat0=yaux1
+ write(*,*) 'xlon0,ylat0',xlon0,ylat0
+
+ dx=(xaux2-xaux1)/real(nxfield-1)
+ dy=(yaux2-yaux1)/real(ny-1)
+ dxconst=180./(dx*r_earth*pi)
+ dyconst=180./(dy*r_earth*pi)
+ write(*,*) 'dx,dy,dxconst,dyconst',dx,dy,dxconst,dyconst
+ !HSO end edits
+
+
+ ! Check whether fields are global
+ ! If they contain the poles, specify polar stereographic map
+ ! projections using the stlmbr- and stcm2p-calls
+ !***********************************************************
+
+ xauxa=abs(xaux2+dx-360.-xaux1)
+ if (xauxa.lt.0.001) then
+ nx=nxfield+1 ! field is cyclic
+ xglobal=.true.
+ if (abs(nxshift).ge.nx) &
+ stop 'nxshift in file par_mod is too large'
+ xlon0=xlon0+real(nxshift)*dx
+ else
+ nx=nxfield
+ xglobal=.false.
+ if (nxshift.ne.0) &
+ stop 'nxshift (par_mod) must be zero for non-global domain'
+ endif
+ nxmin1=nx-1
+ nymin1=ny-1
+ if (xlon0.gt.180.) xlon0=xlon0-360.
+ xauxa=abs(yaux1+90.)
+ if (xglobal.and.xauxa.lt.0.001) then
+ sglobal=.true. ! field contains south pole
+ ! Enhance the map scale by factor 3 (*2=6) compared to north-south
+ ! map scale
+ sizesouth=6.*(switchsouth+90.)/dy
+ call stlmbr(southpolemap,-90.,0.)
+ call stcm2p(southpolemap,0.,0.,switchsouth,0.,sizesouth, &
+ sizesouth,switchsouth,180.)
+ switchsouthg=(switchsouth-ylat0)/dy
+ else
+ sglobal=.false.
+ switchsouthg=999999.
+ endif
+ xauxa=abs(yaux2-90.)
+ if (xglobal.and.xauxa.lt.0.001) then
+ nglobal=.true. ! field contains north pole
+ ! Enhance the map scale by factor 3 (*2=6) compared to north-south
+ ! map scale
+ sizenorth=6.*(90.-switchnorth)/dy
+ call stlmbr(northpolemap,90.,0.)
+ call stcm2p(northpolemap,0.,0.,switchnorth,0.,sizenorth, &
+ sizenorth,switchnorth,180.)
+ switchnorthg=(switchnorth-ylat0)/dy
+ else
+ nglobal=.false.
+ switchnorthg=999999.
+ endif
+ endif ! ifield.eq.1
+
+ if (nxshift.lt.0) stop 'nxshift (par_mod) must not be negative'
+ if (nxshift.ge.nxfield) stop 'nxshift (par_mod) too large'
+
+ ! NCEP ISOBARIC LEVELS
+ !*********************
+
+ if((isec1(6).eq.33).and.(isec1(7).eq.100)) then ! check for U wind
+ iumax=iumax+1
+ pres(iumax)=real(isec1(8))*100.0
+ endif
+
+
+ i179=nint(179./dx)
+ if (dx.lt.0.7) then
+ i180=nint(180./dx)+1 ! 0.5 deg data
+ else
+ i180=nint(179./dx)+1 ! 1 deg data
+ endif
+ i181=i180+1
+
+
+ ! NCEP TERRAIN
+ !*************
+
+ if((isec1(6).eq.007).and.(isec1(7).eq.001)) then
+ do jy=0,ny-1
+ do ix=0,nxfield-1
+ help=zsec4(nxfield*(ny-jy-1)+ix+1)
+ if(ix.le.i180) then
+ oro(i179+ix,jy)=help
+ excessoro(i179+ix,jy)=0.0 ! ISOBARIC SURFACES: SUBGRID TERRAIN DISREGARDED
+ else
+ oro(ix-i181,jy)=help
+ excessoro(ix-i181,jy)=0.0 ! ISOBARIC SURFACES: SUBGRID TERRAIN DISREGARDED
+ endif
+ end do
+ end do
+ endif
+
+ ! NCEP LAND SEA MASK
+ !*******************
+
+ if((isec1(6).eq.081).and.(isec1(7).eq.001)) then
+ do jy=0,ny-1
+ do ix=0,nxfield-1
+ help=zsec4(nxfield*(ny-jy-1)+ix+1)
+ if(ix.le.i180) then
+ lsm(i179+ix,jy)=help
+ else
+ lsm(ix-i181,jy)=help
+ endif
+ end do
+ end do
+ endif
+
+ call grib_release(igrib)
+
+ goto 10 !! READ NEXT LEVEL OR PARAMETER
+ !
+ ! CLOSING OF INPUT DATA FILE
+ !
+
+ ! HSO
+30 continue
+ call grib_close_file(ifile)
+ ! HSO end edits
+
+ nuvz=iumax
+ nwz =iumax
+ nlev_ec=iumax
+
+ if (nx.gt.nxmax) then
+ write(*,*) 'FLEXPART error: Too many grid points in x direction.'
+ write(*,*) 'Reduce resolution of wind fields.'
+ write(*,*) 'Or change parameter settings in file par_mod.'
+ write(*,*) nx,nxmax
+ stop
+ endif
+
+ if (ny.gt.nymax) then
+ write(*,*) 'FLEXPART error: Too many grid points in y direction.'
+ write(*,*) 'Reduce resolution of wind fields.'
+ write(*,*) 'Or change parameter settings in file par_mod.'
+ write(*,*) ny,nymax
+ stop
+ endif
+
+ if (nuvz.gt.nuvzmax) then
+ write(*,*) 'FLEXPART error: Too many u,v grid points in z '// &
+ 'direction.'
+ write(*,*) 'Reduce resolution of wind fields.'
+ write(*,*) 'Or change parameter settings in file par_mod.'
+ write(*,*) nuvz,nuvzmax
+ stop
+ endif
+
+ if (nwz.gt.nwzmax) then
+ write(*,*) 'FLEXPART error: Too many w grid points in z '// &
+ 'direction.'
+ write(*,*) 'Reduce resolution of wind fields.'
+ write(*,*) 'Or change parameter settings in file par_mod.'
+ write(*,*) nwz,nwzmax
+ stop
+ endif
+
+ ! If desired, shift all grids by nxshift grid cells
+ !**************************************************
+
+ if (xglobal) then
+ call shift_field_0(oro,nxfield,ny)
+ call shift_field_0(lsm,nxfield,ny)
+ call shift_field_0(excessoro,nxfield,ny)
+ endif
+
+ ! Output of grid info
+ !********************
+
+ write(*,*)
+ write(*,*)
+ write(*,'(a,2i7)') '# of vertical levels in NCEP data: ', &
+ nuvz,nwz
+ write(*,*)
+ write(*,'(a)') 'other domain:'
+ write(*,'(a,f10.2,a1,f10.2,a,f10.2)') ' Longitude range: ', &
+ xlon0,' to ',xlon0+(nx-1)*dx,' Grid distance: ',dx
+ write(*,'(a,f10.2,a1,f10.2,a,f10.2)') ' Latitude range: ', &
+ ylat0,' to ',ylat0+(ny-1)*dy,' Grid distance: ',dy
+ write(*,*)
+
+
+ ! CALCULATE VERTICAL DISCRETIZATION OF ECMWF MODEL
+ ! PARAMETER akm,bkm DESCRIBE THE HYBRID "ETA" COORDINATE SYSTEM
+
+ numskip=nlev_ec-nuvz ! number of ecmwf model layers not used
+ ! by trajectory model
+ do i=1,nwz
+ j=numskip+i
+ k=nlev_ec+1+numskip+i
+ akm_usort(nwz-i+1)=pres(nwz-i+1)
+ bkm(nwz-i+1)=0.0
+ end do
+
+ !******************************
+ ! change Sabine Eckhardt: akm should always be in descending order ... readwind adapted!
+ !******************************
+ do i=1,nwz
+ if (akm_usort(1).gt.akm_usort(2)) then
+ akm(i)=akm_usort(i)
+ else
+ akm(i)=akm_usort(nwz-i+1)
+ endif
+ end do
+
+ !
+ ! CALCULATION OF AKZ, BKZ
+ ! AKZ,BKZ: model discretization parameters at the center of each model
+ ! layer
+ !
+ ! Assign the 10 m winds to an artificial model level with akz=0 and bkz=1.0,
+ ! i.e. ground level
+ !*****************************************************************************
+
+ do i=1,nuvz
+ akz(i)=akm(i)
+ bkz(i)=bkm(i)
+ end do
+
+ ! NOTE: In FLEXPART versions up to 4.0, the number of model levels was doubled
+ ! upon the transformation to z levels. In order to save computer memory, this is
+ ! not done anymore in the standard version. However, this option can still be
+ ! switched on by replacing the following lines with those below, that are
+ ! currently commented out. For this, similar changes are necessary in
+ ! verttransform.f and verttranform_nests.f
+ !*****************************************************************************
+
+ nz=nuvz
+ if (nz.gt.nzmax) stop 'nzmax too small'
+ do i=1,nuvz
+ aknew(i)=akz(i)
+ bknew(i)=bkz(i)
+ end do
+
+ ! Switch on following lines to use doubled vertical resolution
+ !*************************************************************
+ !nz=nuvz+nwz-1
+ !if (nz.gt.nzmax) stop 'nzmax too small'
+ !do 100 i=1,nwz
+ ! aknew(2*(i-1)+1)=akm(i)
+ !00 bknew(2*(i-1)+1)=bkm(i)
+ !do 110 i=2,nuvz
+ ! aknew(2*(i-1))=akz(i)
+ !10 bknew(2*(i-1))=bkz(i)
+ ! End doubled vertical resolution
+
+
+ ! Determine the uppermost level for which the convection scheme shall be applied
+ ! by assuming that there is no convection above 50 hPa (for standard SLP)
+ !*****************************************************************************
+
+ do i=1,nuvz-2
+ pint=akz(i)+bkz(i)*101325.
+ if (pint.lt.5000.) goto 96
+ end do
+96 nconvlev=i
+ if (nconvlev.gt.nconvlevmax-1) then
+ nconvlev=nconvlevmax-1
+ write(*,*) 'Attention, convection only calculated up to ', &
+ akz(nconvlev)+bkz(nconvlev)*1013.25,' hPa'
+ endif
+
+ return
+
+999 write(*,*)
+ write(*,*) ' ###########################################'// &
+ '###### '
+ write(*,*) ' TRAJECTORY MODEL SUBROUTINE GRIDCHECK:'
+ write(*,*) ' CAN NOT OPEN INPUT DATA FILE '//wfname(ifn)
+ write(*,*) ' ###########################################'// &
+ '###### '
+ write(*,*)
+ write(*,'(a)') '!!! PLEASE INSERT A NEW CD-ROM AND !!!'
+ write(*,'(a)') '!!! PRESS ANY KEY TO CONTINUE... !!!'
+ write(*,'(a)') '!!! ...OR TERMINATE FLEXPART PRESSING!!!'
+ write(*,'(a)') '!!! THE "X" KEY... !!!'
+ write(*,*)
+ read(*,'(a)') opt
+ if(opt.eq.'X') then
+ stop
+ else
+ goto 5
+ endif
+
+end subroutine gridcheck
diff --git a/src/gridcheck_gfs.f90 b/src/gridcheck_gfs.f90
new file mode 100644
index 0000000000000000000000000000000000000000..f1fce80762b3d164710ee9a5941efa41723cc427
--- /dev/null
+++ b/src/gridcheck_gfs.f90
@@ -0,0 +1,538 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine gridcheck
+
+ !**********************************************************************
+ ! *
+ ! FLEXPART MODEL SUBROUTINE GRIDCHECK *
+ ! *
+ !**********************************************************************
+ ! *
+ ! AUTHOR: G. WOTAWA *
+ ! DATE: 1997-08-06 *
+ ! LAST UPDATE: 1997-10-10 *
+ ! *
+ ! Update: 1999-02-08, global fields allowed, A. Stohl*
+ ! CHANGE: 17/11/2005, Caroline Forster, GFS data *
+ ! CHANGE: 11/01/2008, Harald Sodemann, GRIB1/2 input with *
+ ! ECMWF grib_api *
+ ! CHANGE: 03/12/2008, Harald Sodemann, update to f90 with *
+ ! ECMWF grib_api *
+ ! *
+ !**********************************************************************
+ ! *
+ ! DESCRIPTION: *
+ ! *
+ ! THIS SUBROUTINE DETERMINES THE GRID SPECIFICATIONS (LOWER LEFT *
+ ! LONGITUDE, LOWER LEFT LATITUDE, NUMBER OF GRID POINTS, GRID DIST- *
+ ! ANCE AND VERTICAL DISCRETIZATION OF THE ECMWF MODEL) FROM THE *
+ ! GRIB HEADER OF THE FIRST INPUT FILE. THE CONSISTANCY (NO CHANGES *
+ ! WITHIN ONE FLEXPART RUN) IS CHECKED IN THE ROUTINE "READWIND" AT *
+ ! ANY CALL. *
+ ! *
+ ! XLON0 geographical longitude of lower left gridpoint *
+ ! YLAT0 geographical latitude of lower left gridpoint *
+ ! NX number of grid points x-direction *
+ ! NY number of grid points y-direction *
+ ! DX grid distance x-direction *
+ ! DY grid distance y-direction *
+ ! NUVZ number of grid points for horizontal wind *
+ ! components in z direction *
+ ! NWZ number of grid points for vertical wind *
+ ! component in z direction *
+ ! sizesouth, sizenorth give the map scale (i.e. number of virtual grid*
+ ! points of the polar stereographic grid): *
+ ! used to check the CFL criterion *
+ ! UVHEIGHT(1)- heights of gridpoints where u and v are *
+ ! UVHEIGHT(NUVZ) given *
+ ! WHEIGHT(1)- heights of gridpoints where w is given *
+ ! WHEIGHT(NWZ) *
+ ! *
+ !**********************************************************************
+
+ use grib_api
+ use par_mod
+ use com_mod
+ use conv_mod
+ use cmapf_mod, only: stlmbr,stcm2p
+
+ implicit none
+
+ !HSO parameters for grib_api
+ integer :: ifile
+ integer :: iret
+ integer :: igrib
+ real(kind=4) :: xaux1,xaux2,yaux1,yaux2
+ real(kind=8) :: xaux1in,xaux2in,yaux1in,yaux2in
+ integer :: gribVer,parCat,parNum,typSurf,valSurf,discipl
+ !HSO end
+ integer :: ix,jy,i,ifn,ifield,j,k,iumax,iwmax,numskip
+ real :: sizesouth,sizenorth,xauxa,pint
+ real :: akm_usort(nwzmax)
+ real,parameter :: eps=0.0001
+
+ ! NCEP GFS
+ real :: pres(nwzmax), help
+
+ integer :: i179,i180,i181
+
+ ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING
+
+ integer :: isec1(8),isec2(3)
+ real(kind=4) :: zsec4(jpunp)
+ character(len=1) :: opt
+
+ !HSO grib api error messages
+ character(len=24) :: gribErrorMsg = 'Error reading grib file'
+ character(len=20) :: gribFunction = 'gridcheckwind_gfs'
+ !
+ if (numbnests.ge.1) then
+ write(*,*) ' ###########################################'
+ write(*,*) ' FLEXPART ERROR SUBROUTINE GRIDCHECK:'
+ write(*,*) ' NO NESTED WINDFIELDAS ALLOWED FOR GFS! '
+ write(*,*) ' ###########################################'
+ stop
+ endif
+
+ iumax=0
+ iwmax=0
+
+ if(ideltas.gt.0) then
+ ifn=1
+ else
+ ifn=numbwf
+ endif
+ !
+ ! OPENING OF DATA FILE (GRIB CODE)
+ !
+5 call grib_open_file(ifile,path(3)(1:length(3)) &
+ //trim(wfname(ifn)),'r',iret)
+ if (iret.ne.GRIB_SUCCESS) then
+ goto 999 ! ERROR DETECTED
+ endif
+ !turn on support for multi fields messages
+ call grib_multi_support_on
+
+ ifield=0
+10 ifield=ifield+1
+ !
+ ! GET NEXT FIELDS
+ !
+ call grib_new_from_file(ifile,igrib,iret)
+ if (iret.eq.GRIB_END_OF_FILE ) then
+ goto 30 ! EOF DETECTED
+ elseif (iret.ne.GRIB_SUCCESS) then
+ goto 999 ! ERROR DETECTED
+ endif
+
+ !first see if we read GRIB1 or GRIB2
+ call grib_get_int(igrib,'editionNumber',gribVer,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ if (gribVer.eq.1) then ! GRIB Edition 1
+
+ !read the grib1 identifiers
+ call grib_get_int(igrib,'indicatorOfParameter',isec1(6),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'indicatorOfTypeOfLevel',isec1(7),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'level',isec1(8),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ !get the size and data of the values array
+ call grib_get_real4_array(igrib,'values',zsec4,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ else ! GRIB Edition 2
+
+ !read the grib2 identifiers
+ call grib_get_int(igrib,'discipline',discipl,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'parameterCategory',parCat,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'parameterNumber',parNum,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'typeOfFirstFixedSurface',typSurf,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'scaledValueOfFirstFixedSurface', &
+ valSurf,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ !convert to grib1 identifiers
+ isec1(6)=-1
+ isec1(7)=-1
+ isec1(8)=-1
+ if ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.100)) then ! U
+ isec1(6)=33 ! indicatorOfParameter
+ isec1(7)=100 ! indicatorOfTypeOfLevel
+ isec1(8)=valSurf/100 ! level, convert to hPa
+ elseif ((parCat.eq.3).and.(parNum.eq.5).and.(typSurf.eq.1)) then ! TOPO
+ isec1(6)=7 ! indicatorOfParameter
+ isec1(7)=1 ! indicatorOfTypeOfLevel
+ isec1(8)=0
+ elseif ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.1) &
+ .and.(discipl.eq.2)) then ! LSM
+ isec1(6)=81 ! indicatorOfParameter
+ isec1(7)=1 ! indicatorOfTypeOfLevel
+ isec1(8)=0
+ endif
+
+ if (isec1(6).ne.-1) then
+ ! get the size and data of the values array
+ call grib_get_real4_array(igrib,'values',zsec4,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ endif
+
+ endif ! gribVer
+
+ if(ifield.eq.1) then
+
+ !get the required fields from section 2
+ !store compatible to gribex input
+ call grib_get_int(igrib,'numberOfPointsAlongAParallel', &
+ isec2(2),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'numberOfPointsAlongAMeridian', &
+ isec2(3),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_real8(igrib,'longitudeOfFirstGridPointInDegrees', &
+ xaux1in,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_real8(igrib,'longitudeOfLastGridPointInDegrees', &
+ xaux2in,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_real8(igrib,'latitudeOfLastGridPointInDegrees', &
+ yaux1in,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_real8(igrib,'latitudeOfFirstGridPointInDegrees', &
+ yaux2in,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ xaux1=xaux1in
+ xaux2=xaux2in
+ yaux1=yaux1in
+ yaux2=yaux2in
+
+ nxfield=isec2(2)
+ ny=isec2(3)
+ if((abs(xaux1).lt.eps).and.(xaux2.ge.359)) then ! NCEP DATA FROM 0 TO
+ xaux1=-179.0 ! 359 DEG EAST ->
+ xaux2=-179.0+360.-360./real(nxfield) ! TRANSFORMED TO -179
+ endif ! TO 180 DEG EAST
+ if (xaux1.gt.180) xaux1=xaux1-360.0
+ if (xaux2.gt.180) xaux2=xaux2-360.0
+ if (xaux1.lt.-180) xaux1=xaux1+360.0
+ if (xaux2.lt.-180) xaux2=xaux2+360.0
+ if (xaux2.lt.xaux1) xaux2=xaux2+360.
+ xlon0=xaux1
+ ylat0=yaux1
+ dx=(xaux2-xaux1)/real(nxfield-1)
+ dy=(yaux2-yaux1)/real(ny-1)
+ dxconst=180./(dx*r_earth*pi)
+ dyconst=180./(dy*r_earth*pi)
+ !HSO end edits
+
+
+ ! Check whether fields are global
+ ! If they contain the poles, specify polar stereographic map
+ ! projections using the stlmbr- and stcm2p-calls
+ !***********************************************************
+
+ xauxa=abs(xaux2+dx-360.-xaux1)
+ if (xauxa.lt.0.001) then
+ nx=nxfield+1 ! field is cyclic
+ xglobal=.true.
+ if (abs(nxshift).ge.nx) &
+ stop 'nxshift in file par_mod is too large'
+ xlon0=xlon0+real(nxshift)*dx
+ else
+ nx=nxfield
+ xglobal=.false.
+ if (nxshift.ne.0) &
+ stop 'nxshift (par_mod) must be zero for non-global domain'
+ endif
+ nxmin1=nx-1
+ nymin1=ny-1
+ if (xlon0.gt.180.) xlon0=xlon0-360.
+ xauxa=abs(yaux1+90.)
+ if (xglobal.and.xauxa.lt.0.001) then
+ sglobal=.true. ! field contains south pole
+ ! Enhance the map scale by factor 3 (*2=6) compared to north-south
+ ! map scale
+ sizesouth=6.*(switchsouth+90.)/dy
+ call stlmbr(southpolemap,-90.,0.)
+ call stcm2p(southpolemap,0.,0.,switchsouth,0.,sizesouth, &
+ sizesouth,switchsouth,180.)
+ switchsouthg=(switchsouth-ylat0)/dy
+ else
+ sglobal=.false.
+ switchsouthg=999999.
+ endif
+ xauxa=abs(yaux2-90.)
+ if (xglobal.and.xauxa.lt.0.001) then
+ nglobal=.true. ! field contains north pole
+ ! Enhance the map scale by factor 3 (*2=6) compared to north-south
+ ! map scale
+ sizenorth=6.*(90.-switchnorth)/dy
+ call stlmbr(northpolemap,90.,0.)
+ call stcm2p(northpolemap,0.,0.,switchnorth,0.,sizenorth, &
+ sizenorth,switchnorth,180.)
+ switchnorthg=(switchnorth-ylat0)/dy
+ else
+ nglobal=.false.
+ switchnorthg=999999.
+ endif
+ endif ! ifield.eq.1
+
+ if (nxshift.lt.0) stop 'nxshift (par_mod) must not be negative'
+ if (nxshift.ge.nxfield) stop 'nxshift (par_mod) too large'
+
+ ! NCEP ISOBARIC LEVELS
+ !*********************
+
+ if((isec1(6).eq.33).and.(isec1(7).eq.100)) then ! check for U wind
+ iumax=iumax+1
+ pres(iumax)=real(isec1(8))*100.0
+ endif
+
+
+ i179=nint(179./dx)
+ if (dx.lt.0.7) then
+ i180=nint(180./dx)+1 ! 0.5 deg data
+ else
+ i180=nint(179./dx)+1 ! 1 deg data
+ endif
+ i181=i180+1
+
+
+ ! NCEP TERRAIN
+ !*************
+
+ if((isec1(6).eq.007).and.(isec1(7).eq.001)) then
+ do jy=0,ny-1
+ do ix=0,nxfield-1
+ help=zsec4(nxfield*(ny-jy-1)+ix+1)
+ if(ix.le.i180) then
+ oro(i179+ix,jy)=help
+ excessoro(i179+ix,jy)=0.0 ! ISOBARIC SURFACES: SUBGRID TERRAIN DISREGARDED
+ else
+ oro(ix-i181,jy)=help
+ excessoro(ix-i181,jy)=0.0 ! ISOBARIC SURFACES: SUBGRID TERRAIN DISREGARDED
+ endif
+ end do
+ end do
+ endif
+
+ ! NCEP LAND SEA MASK
+ !*******************
+
+ if((isec1(6).eq.081).and.(isec1(7).eq.001)) then
+ do jy=0,ny-1
+ do ix=0,nxfield-1
+ help=zsec4(nxfield*(ny-jy-1)+ix+1)
+ if(ix.le.i180) then
+ lsm(i179+ix,jy)=help
+ else
+ lsm(ix-i181,jy)=help
+ endif
+ end do
+ end do
+ endif
+
+ call grib_release(igrib)
+
+ goto 10 !! READ NEXT LEVEL OR PARAMETER
+ !
+ ! CLOSING OF INPUT DATA FILE
+ !
+
+ ! HSO
+30 continue
+ call grib_close_file(ifile)
+ ! HSO end edits
+
+ nuvz=iumax
+ nwz =iumax
+ nlev_ec=iumax
+
+ if (nx.gt.nxmax) then
+ write(*,*) 'FLEXPART error: Too many grid points in x direction.'
+ write(*,*) 'Reduce resolution of wind fields.'
+ write(*,*) 'Or change parameter settings in file par_mod.'
+ write(*,*) nx,nxmax
+ stop
+ endif
+
+ if (ny.gt.nymax) then
+ write(*,*) 'FLEXPART error: Too many grid points in y direction.'
+ write(*,*) 'Reduce resolution of wind fields.'
+ write(*,*) 'Or change parameter settings in file par_mod.'
+ write(*,*) ny,nymax
+ stop
+ endif
+
+ if (nuvz.gt.nuvzmax) then
+ write(*,*) 'FLEXPART error: Too many u,v grid points in z '// &
+ 'direction.'
+ write(*,*) 'Reduce resolution of wind fields.'
+ write(*,*) 'Or change parameter settings in file par_mod.'
+ write(*,*) nuvz,nuvzmax
+ stop
+ endif
+
+ if (nwz.gt.nwzmax) then
+ write(*,*) 'FLEXPART error: Too many w grid points in z '// &
+ 'direction.'
+ write(*,*) 'Reduce resolution of wind fields.'
+ write(*,*) 'Or change parameter settings in file par_mod.'
+ write(*,*) nwz,nwzmax
+ stop
+ endif
+
+ ! If desired, shift all grids by nxshift grid cells
+ !**************************************************
+
+ if (xglobal) then
+ call shift_field_0(oro,nxfield,ny)
+ call shift_field_0(lsm,nxfield,ny)
+ call shift_field_0(excessoro,nxfield,ny)
+ endif
+
+ ! Output of grid info
+ !********************
+
+ write(*,*)
+ write(*,*)
+ write(*,'(a,2i7)') '# of vertical levels in NCEP data: ', &
+ nuvz,nwz
+ write(*,*)
+ write(*,'(a)') 'Mother domain:'
+ write(*,'(a,f10.2,a1,f10.2,a,f10.2)') ' Longitude range: ', &
+ xlon0,' to ',xlon0+(nx-1)*dx,' Grid distance: ',dx
+ write(*,'(a,f10.2,a1,f10.2,a,f10.2)') ' Latitude range: ', &
+ ylat0,' to ',ylat0+(ny-1)*dy,' Grid distance: ',dy
+ write(*,*)
+
+
+ ! CALCULATE VERTICAL DISCRETIZATION OF ECMWF MODEL
+ ! PARAMETER akm,bkm DESCRIBE THE HYBRID "ETA" COORDINATE SYSTEM
+
+ numskip=nlev_ec-nuvz ! number of ecmwf model layers not used
+ ! by trajectory model
+ do i=1,nwz
+ j=numskip+i
+ k=nlev_ec+1+numskip+i
+ akm_usort(nwz-i+1)=pres(nwz-i+1)
+ bkm(nwz-i+1)=0.0
+ end do
+
+ !******************************
+ ! change Sabine Eckhardt: akm should always be in descending order ... readwind adapted!
+ !******************************
+ do i=1,nwz
+ if (akm_usort(1).gt.akm_usort(2)) then
+ akm(i)=akm_usort(i)
+ else
+ akm(i)=akm_usort(nwz-i+1)
+ endif
+ end do
+
+ !
+ ! CALCULATION OF AKZ, BKZ
+ ! AKZ,BKZ: model discretization parameters at the center of each model
+ ! layer
+ !
+ ! Assign the 10 m winds to an artificial model level with akz=0 and bkz=1.0,
+ ! i.e. ground level
+ !*****************************************************************************
+
+ do i=1,nuvz
+ akz(i)=akm(i)
+ bkz(i)=bkm(i)
+ end do
+
+ ! NOTE: In FLEXPART versions up to 4.0, the number of model levels was doubled
+ ! upon the transformation to z levels. In order to save computer memory, this is
+ ! not done anymore in the standard version. However, this option can still be
+ ! switched on by replacing the following lines with those below, that are
+ ! currently commented out. For this, similar changes are necessary in
+ ! verttransform.f and verttranform_nests.f
+ !*****************************************************************************
+
+ nz=nuvz
+ if (nz.gt.nzmax) stop 'nzmax too small'
+ do i=1,nuvz
+ aknew(i)=akz(i)
+ bknew(i)=bkz(i)
+ end do
+
+ ! Switch on following lines to use doubled vertical resolution
+ !*************************************************************
+ !nz=nuvz+nwz-1
+ !if (nz.gt.nzmax) stop 'nzmax too small'
+ !do 100 i=1,nwz
+ ! aknew(2*(i-1)+1)=akm(i)
+ !00 bknew(2*(i-1)+1)=bkm(i)
+ !do 110 i=2,nuvz
+ ! aknew(2*(i-1))=akz(i)
+ !10 bknew(2*(i-1))=bkz(i)
+ ! End doubled vertical resolution
+
+
+ ! Determine the uppermost level for which the convection scheme shall be applied
+ ! by assuming that there is no convection above 50 hPa (for standard SLP)
+ !*****************************************************************************
+
+ do i=1,nuvz-2
+ pint=akz(i)+bkz(i)*101325.
+ if (pint.lt.5000.) goto 96
+ end do
+96 nconvlev=i
+ if (nconvlev.gt.nconvlevmax-1) then
+ nconvlev=nconvlevmax-1
+ write(*,*) 'Attention, convection only calculated up to ', &
+ akz(nconvlev)+bkz(nconvlev)*1013.25,' hPa'
+ endif
+
+ return
+
+999 write(*,*)
+ write(*,*) ' ###########################################'// &
+ '###### '
+ write(*,*) ' TRAJECTORY MODEL SUBROUTINE GRIDCHECK:'
+ write(*,*) ' CAN NOT OPEN INPUT DATA FILE '//wfname(ifn)
+ write(*,*) ' ###########################################'// &
+ '###### '
+ write(*,*)
+ write(*,'(a)') '!!! PLEASE INSERT A NEW CD-ROM AND !!!'
+ write(*,'(a)') '!!! PRESS ANY KEY TO CONTINUE... !!!'
+ write(*,'(a)') '!!! ...OR TERMINATE FLEXPART PRESSING!!!'
+ write(*,'(a)') '!!! THE "X" KEY... !!!'
+ write(*,*)
+ read(*,'(a)') opt
+ if(opt.eq.'X') then
+ stop
+ else
+ goto 5
+ endif
+
+end subroutine gridcheck
diff --git a/src/gridcheck_gfs_emos.f90 b/src/gridcheck_gfs_emos.f90
new file mode 100644
index 0000000000000000000000000000000000000000..8becd18fc4e462c1b25b7a324f440171d8519e1f
--- /dev/null
+++ b/src/gridcheck_gfs_emos.f90
@@ -0,0 +1,425 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine gridcheck
+
+ !**********************************************************************
+ ! *
+ ! FLEXPART MODEL SUBROUTINE GRIDCHECK *
+ ! *
+ !**********************************************************************
+ ! *
+ ! AUTHOR: G. WOTAWA *
+ ! DATE: 1997-08-06 *
+ ! LAST UPDATE: 1997-10-10 *
+ ! *
+ ! Update: 1999-02-08, global fields allowed, A. Stohl*
+ ! CHANGE: 17/11/2005, Caroline Forster, GFS data *
+ ! *
+ !**********************************************************************
+ ! *
+ ! DESCRIPTION: *
+ ! *
+ ! THIS SUBROUTINE DETERMINES THE GRID SPECIFICATIONS (LOWER LEFT *
+ ! LONGITUDE, LOWER LEFT LATITUDE, NUMBER OF GRID POINTS, GRID DIST- *
+ ! ANCE AND VERTICAL DISCRETIZATION OF THE ECMWF MODEL) FROM THE *
+ ! GRIB HEADER OF THE FIRST INPUT FILE. THE CONSISTANCY (NO CHANGES *
+ ! WITHIN ONE FLEXPART RUN) IS CHECKED IN THE ROUTINE "READWIND" AT *
+ ! ANY CALL. *
+ ! *
+ ! XLON0 geographical longitude of lower left gridpoint *
+ ! YLAT0 geographical latitude of lower left gridpoint *
+ ! NX number of grid points x-direction *
+ ! NY number of grid points y-direction *
+ ! DX grid distance x-direction *
+ ! DY grid distance y-direction *
+ ! NUVZ number of grid points for horizontal wind *
+ ! components in z direction *
+ ! NWZ number of grid points for vertical wind *
+ ! component in z direction *
+ ! sizesouth, sizenorth give the map scale (i.e. number of virtual grid*
+ ! points of the polar stereographic grid): *
+ ! used to check the CFL criterion *
+ ! UVHEIGHT(1)- heights of gridpoints where u and v are *
+ ! UVHEIGHT(NUVZ) given *
+ ! WHEIGHT(1)- heights of gridpoints where w is given *
+ ! WHEIGHT(NWZ) *
+ ! *
+ !**********************************************************************
+
+ use par_mod
+ use com_mod
+ use conv_mod
+
+ implicit none
+
+ integer :: ix,jy,i,ifn,ifield,j,k,iumax,iwmax,numskip
+ real :: xaux1,xaux2,yaux1,yaux2,sizesouth,sizenorth,xauxa,pint
+ real :: akm_usort(nwzmax)
+
+ ! NCEP GFS
+ real :: pres(nwzmax), help
+
+ ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING
+
+ ! dimension of isec2 at least (22+n), where n is the number of parallels or
+ ! meridians in a quasi-regular (reduced) Gaussian or lat/long grid
+
+ ! dimension of zsec2 at least (10+nn), where nn is the number of vertical
+ ! coordinate parameters
+
+ integer :: isec0(2),isec1(56),isec2(22+nxmax+nymax),isec3(2)
+ integer :: isec4(64),inbuff(jpack),ilen,iswap,ierr,iword,lunit
+ real :: zsec2(60+2*nuvzmax),zsec3(2),zsec4(jpunp)
+ character(len=1) :: opt, yoper = 'D'
+
+
+ iumax=0
+ iwmax=0
+
+ if(ideltas.gt.0) then
+ ifn=1
+ else
+ ifn=numbwf
+ endif
+ !
+ ! OPENING OF DATA FILE (GRIB CODE)
+ !
+5 call pbopen(lunit,path(3)(1:length(3))//wfname(ifn),'r',ierr)
+ if(ierr.lt.0) goto 999
+
+ ifield=0
+10 ifield=ifield+1
+ !
+ ! GET NEXT FIELDS
+ !
+ call pbgrib(lunit,inbuff,jpack,ilen,ierr)
+ if(ierr.eq.-1) goto 30 ! EOF DETECTED
+ if(ierr.lt.-1) goto 999 ! ERROR DETECTED
+
+ ierr=1
+
+ ! Check whether we are on a little endian or on a big endian computer
+ !********************************************************************
+
+ !if (inbuff(1).eq.1112101447) then ! little endian, swap bytes
+ ! iswap=1+ilen/4
+ ! call swap32(inbuff,iswap)
+ !else if (inbuff(1).ne.1196575042) then ! big endian
+ ! stop 'subroutine gridcheck: corrupt GRIB data'
+ !endif
+
+ call gribex(isec0,isec1,isec2,zsec2,isec3,zsec3,isec4, &
+ zsec4,jpunp,inbuff,jpack,iword,yoper,ierr)
+ if (ierr.ne.0) goto 10 ! ERROR DETECTED
+
+ if(ifield.eq.1) then
+ nxfield=isec2(2)
+ ny=isec2(3)
+ xaux1=real(isec2(5))/1000.
+ xaux2=real(isec2(8))/1000.
+ if((xaux1.eq.0.).and.(xaux2.eq.-1.0)) then ! NCEP DATA FROM 0 TO
+ xaux1=-179.0 ! 359 DEG EAST ->
+ xaux2=180.0 ! TRANSFORMED TO -179
+ endif ! TO 180 DEG EAST
+ if (xaux1.gt.180) xaux1=xaux1-360.0
+ if (xaux2.gt.180) xaux2=xaux2-360.0
+ if (xaux1.lt.-180) xaux1=xaux1+360.0
+ if (xaux2.lt.-180) xaux2=xaux2+360.0
+ if (xaux2.lt.xaux1) xaux2=xaux2+360.
+ yaux1=real(isec2(7))/1000.
+ yaux2=real(isec2(4))/1000.
+ xlon0=xaux1
+ ylat0=yaux1
+ dx=(xaux2-xaux1)/real(nxfield-1)
+ dy=(yaux2-yaux1)/real(ny-1)
+ dxconst=180./(dx*r_earth*pi)
+ dyconst=180./(dy*r_earth*pi)
+
+
+ ! Check whether fields are global
+ ! If they contain the poles, specify polar stereographic map
+ ! projections using the stlmbr- and stcm2p-calls
+ !***********************************************************
+
+ xauxa=abs(xaux2+dx-360.-xaux1)
+ if (xauxa.lt.0.001) then
+ nx=nxfield+1 ! field is cyclic
+ xglobal=.true.
+ if (abs(nxshift).ge.nx) &
+ stop 'nxshift in file par_mod is too large'
+ xlon0=xlon0+real(nxshift)*dx
+ else
+ nx=nxfield
+ xglobal=.false.
+ if (nxshift.ne.0) &
+ stop 'nxshift (par_mod) must be zero for non-global domain'
+ endif
+ nxmin1=nx-1
+ nymin1=ny-1
+ if (xlon0.gt.180.) xlon0=xlon0-360.
+ xauxa=abs(yaux1+90.)
+ if (xglobal.and.xauxa.lt.0.001) then
+ sglobal=.true. ! field contains south pole
+ ! Enhance the map scale by factor 3 (*2=6) compared to north-south
+ ! map scale
+ sizesouth=6.*(switchsouth+90.)/dy
+ call stlmbr(southpolemap,-90.,0.)
+ call stcm2p(southpolemap,0.,0.,switchsouth,0.,sizesouth, &
+ sizesouth,switchsouth,180.)
+ switchsouthg=(switchsouth-ylat0)/dy
+ else
+ sglobal=.false.
+ switchsouthg=999999.
+ endif
+ xauxa=abs(yaux2-90.)
+ if (xglobal.and.xauxa.lt.0.001) then
+ nglobal=.true. ! field contains north pole
+ ! Enhance the map scale by factor 3 (*2=6) compared to north-south
+ ! map scale
+ sizenorth=6.*(90.-switchnorth)/dy
+ call stlmbr(northpolemap,90.,0.)
+ call stcm2p(northpolemap,0.,0.,switchnorth,0.,sizenorth, &
+ sizenorth,switchnorth,180.)
+ switchnorthg=(switchnorth-ylat0)/dy
+ else
+ nglobal=.false.
+ switchnorthg=999999.
+ endif
+ endif
+
+ if (nxshift.lt.0) stop 'nxshift (par_mod) must not be negative'
+ if (nxshift.ge.nxfield) stop 'nxshift (par_mod) too large'
+
+ ! NCEP ISOBARIC LEVELS
+ !*********************
+
+ if((isec1(6).eq.33).and.(isec1(7).eq.100)) then
+ iumax=iumax+1
+ pres(iumax)=real(isec1(8))*100.0
+ endif
+
+ ! NCEP TERRAIN
+ !*************
+
+ if((isec1(6).eq.007).and.(isec1(7).eq.001)) then
+ do jy=0,ny-1
+ do ix=0,nxfield-1
+ help=zsec4(nxfield*(ny-jy-1)+ix+1)
+ if(ix.le.180) then
+ oro(179+ix,jy)=help
+ excessoro(179+ix,jy)=0.0 ! ISOBARIC SURFACES: SUBGRID TERRAIN DISREGARDED
+ else
+ oro(ix-181,jy)=help
+ excessoro(ix-181,jy)=0.0 ! ISOBARIC SURFACES: SUBGRID TERRAIN DISREGARDED
+ endif
+ end do
+ end do
+ endif
+
+ ! NCEP LAND SEA MASK
+ !*******************
+
+ if((isec1(6).eq.081).and.(isec1(7).eq.001)) then
+ do jy=0,ny-1
+ do ix=0,nxfield-1
+ help=zsec4(nxfield*(ny-jy-1)+ix+1)
+ if(ix.le.180) then
+ lsm(179+ix,jy)=help
+ else
+ lsm(ix-181,jy)=help
+ endif
+ end do
+ end do
+ endif
+
+ goto 10 !! READ NEXT LEVEL OR PARAMETER
+ !
+ ! CLOSING OF INPUT DATA FILE
+ !
+30 call pbclose(lunit,ierr) !! FINISHED READING / CLOSING GRIB FILE
+
+ nuvz=iumax
+ nwz =iumax
+ nlev_ec=iumax
+
+ if (nx.gt.nxmax) then
+ write(*,*) 'FLEXPART error: Too many grid points in x direction.'
+ write(*,*) 'Reduce resolution of wind fields.'
+ write(*,*) 'Or change parameter settings in file par_mod.'
+ write(*,*) nx,nxmax
+ stop
+ endif
+
+ if (ny.gt.nymax) then
+ write(*,*) 'FLEXPART error: Too many grid points in y direction.'
+ write(*,*) 'Reduce resolution of wind fields.'
+ write(*,*) 'Or change parameter settings in file par_mod.'
+ write(*,*) ny,nymax
+ stop
+ endif
+
+ if (nuvz.gt.nuvzmax) then
+ write(*,*) 'FLEXPART error: Too many u,v grid points in z '// &
+ 'direction.'
+ write(*,*) 'Reduce resolution of wind fields.'
+ write(*,*) 'Or change parameter settings in file par_mod.'
+ write(*,*) nuvz,nuvzmax
+ stop
+ endif
+
+ if (nwz.gt.nwzmax) then
+ write(*,*) 'FLEXPART error: Too many w grid points in z '// &
+ 'direction.'
+ write(*,*) 'Reduce resolution of wind fields.'
+ write(*,*) 'Or change parameter settings in file par_mod.'
+ write(*,*) nwz,nwzmax
+ stop
+ endif
+
+ ! If desired, shift all grids by nxshift grid cells
+ !**************************************************
+
+ if (xglobal) then
+ call shift_field_0(oro,nxfield,ny)
+ call shift_field_0(lsm,nxfield,ny)
+ call shift_field_0(excessoro,nxfield,ny)
+ endif
+
+ ! Output of grid info
+ !********************
+
+ write(*,*)
+ write(*,*)
+ write(*,'(a,2i7)') '# of vertical levels in ECMWF data: ', &
+ nuvz,nwz
+ write(*,*)
+ write(*,'(a)') 'Mother domain:'
+ write(*,'(a,f10.1,a1,f10.1,a,f10.1)') ' Longitude range: ', &
+ xlon0,' to ',xlon0+(nx-1)*dx,' Grid distance: ',dx
+ write(*,'(a,f10.1,a1,f10.1,a,f10.1)') ' Latitude range: ', &
+ ylat0,' to ',ylat0+(ny-1)*dy,' Grid distance: ',dy
+ write(*,*)
+
+
+ ! CALCULATE VERTICAL DISCRETIZATION OF ECMWF MODEL
+ ! PARAMETER akm,bkm DESCRIBE THE HYBRID "ETA" COORDINATE SYSTEM
+
+ numskip=nlev_ec-nuvz ! number of ecmwf model layers not used
+ ! by trajectory model
+ do i=1,nwz
+ j=numskip+i
+ k=nlev_ec+1+numskip+i
+ akm_usort(nwz-i+1)=pres(nwz-i+1)
+ bkm(nwz-i+1)=0.0
+ end do
+
+ !******************************
+ ! change Sabine Eckhardt: akm should always be in descending order ... readwind adapted!
+ !******************************
+ do i=1,nwz
+ if (akm_usort(1).gt.akm_usort(2)) then
+ akm(i)=akm_usort(i)
+ else
+ akm(i)=akm_usort(nwz-i+1)
+ endif
+ end do
+
+ !
+ ! CALCULATION OF AKZ, BKZ
+ ! AKZ,BKZ: model discretization parameters at the center of each model
+ ! layer
+ !
+ ! Assign the 10 m winds to an artificial model level with akz=0 and bkz=1.0,
+ ! i.e. ground level
+ !*****************************************************************************
+
+ do i=1,nuvz
+ akz(i)=akm(i)
+ bkz(i)=bkm(i)
+ end do
+
+ ! NOTE: In FLEXPART versions up to 4.0, the number of model levels was doubled
+ ! upon the transformation to z levels. In order to save computer memory, this is
+ ! not done anymore in the standard version. However, this option can still be
+ ! switched on by replacing the following lines with those below, that are
+ ! currently commented out. For this, similar changes are necessary in
+ ! verttransform.f and verttranform_nests.f
+ !*****************************************************************************
+
+ nz=nuvz
+ if (nz.gt.nzmax) stop 'nzmax too small'
+ do i=1,nuvz
+ aknew(i)=akz(i)
+ bknew(i)=bkz(i)
+ end do
+
+ ! Switch on following lines to use doubled vertical resolution
+ !*************************************************************
+ !nz=nuvz+nwz-1
+ !if (nz.gt.nzmax) stop 'nzmax too small'
+ !do 100 i=1,nwz
+ ! aknew(2*(i-1)+1)=akm(i)
+ !00 bknew(2*(i-1)+1)=bkm(i)
+ !do 110 i=2,nuvz
+ ! aknew(2*(i-1))=akz(i)
+ !10 bknew(2*(i-1))=bkz(i)
+ ! End doubled vertical resolution
+
+
+ ! Determine the uppermost level for which the convection scheme shall be applied
+ ! by assuming that there is no convection above 50 hPa (for standard SLP)
+ !*****************************************************************************
+
+ do i=1,nuvz-2
+ pint=akz(i)+bkz(i)*101325.
+ if (pint.lt.5000.) goto 96
+ end do
+96 nconvlev=i
+ if (nconvlev.gt.nconvlevmax-1) then
+ nconvlev=nconvlevmax-1
+ write(*,*) 'Attention, convection only calculated up to ', &
+ akz(nconvlev)+bkz(nconvlev)*1013.25,' hPa'
+ endif
+
+ return
+
+999 write(*,*)
+ write(*,*) ' ###########################################'// &
+ '###### '
+ write(*,*) ' TRAJECTORY MODEL SUBROUTINE GRIDCHECK:'
+ write(*,*) ' CAN NOT OPEN INPUT DATA FILE '//wfname(ifn)
+ write(*,*) ' ###########################################'// &
+ '###### '
+ write(*,*)
+ write(*,'(a)') '!!! PLEASE INSERT A NEW CD-ROM AND !!!'
+ write(*,'(a)') '!!! PRESS ANY KEY TO CONTINUE... !!!'
+ write(*,'(a)') '!!! ...OR TERMINATE FLEXPART PRESSING!!!'
+ write(*,'(a)') '!!! THE "X" KEY... !!!'
+ write(*,*)
+ read(*,'(a)') opt
+ if(opt.eq.'X') then
+ stop
+ else
+ goto 5
+ endif
+
+end subroutine gridcheck
diff --git a/src/gridcheck_nests.f90 b/src/gridcheck_nests.f90
new file mode 100644
index 0000000000000000000000000000000000000000..9c3ff5a73830b89b7e2924957d957473933a3580
--- /dev/null
+++ b/src/gridcheck_nests.f90
@@ -0,0 +1,450 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine gridcheck_nests
+
+ !*****************************************************************************
+ ! *
+ ! This routine checks the grid specification for the nested model *
+ ! domains. It is similar to subroutine gridcheck, which checks the *
+ ! mother domain. *
+ ! *
+ ! Authors: A. Stohl, G. Wotawa *
+ ! *
+ ! 8 February 1999 *
+ ! *
+ !*****************************************************************************
+ ! CHANGE: 11/01/2008, Harald Sodemann, GRIB1/2 input with ECMWF grib_api *
+ ! CHANGE: 03/12/2008, Harald Sodemann, change to f90 grib_api *
+ !*****************************************************************************
+
+ use grib_api
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ !HSO parameters for grib_api
+ integer :: ifile
+ integer :: iret
+ integer :: igrib
+ integer :: gribVer,parCat,parNum,typSurf,valSurf,discipl
+ integer :: gotGrib
+ !HSO end
+ integer :: i,j,k,l,ifn,ifield,iumax,iwmax,numskip,nlev_ecn
+ integer :: nuvzn,nwzn
+ real :: akmn(nwzmax),bkmn(nwzmax),akzn(nuvzmax),bkzn(nuvzmax)
+ real(kind=4) :: xaux1,xaux2,yaux1,yaux2
+ real(kind=8) :: xaux1in,xaux2in,yaux1in,yaux2in
+
+ ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING
+
+ ! dimension of isec2 at least (22+n), where n is the number of parallels or
+ ! meridians in a quasi-regular (reduced) Gaussian or lat/long grid
+
+ ! dimension of zsec2 at least (10+nn), where nn is the number of vertical
+ ! coordinate parameters
+
+ integer :: isec1(56),isec2(22+nxmaxn+nymaxn)
+ real(kind=4) :: zsec2(60+2*nuvzmax),zsec4(jpunp)
+
+ !HSO grib api error messages
+ character(len=24) :: gribErrorMsg = 'Error reading grib file'
+ character(len=20) :: gribFunction = 'gridcheck_nests'
+
+ xresoln(0)=1. ! resolution enhancement for mother grid
+ yresoln(0)=1. ! resolution enhancement for mother grid
+
+ ! Loop about all nesting levels
+ !******************************
+
+ do l=1,numbnests
+
+ iumax=0
+ iwmax=0
+
+ if(ideltas.gt.0) then
+ ifn=1
+ else
+ ifn=numbwf
+ endif
+ !
+ ! OPENING OF DATA FILE (GRIB CODE)
+ !
+ ifile=0
+ igrib=0
+ iret=0
+
+5 call grib_open_file(ifile,path(numpath+2*(l-1)+1) &
+ (1:length(numpath+2*(l-1)+1))//trim(wfnamen(l,ifn)),'r',iret)
+ if (iret.ne.GRIB_SUCCESS) then
+ goto 999 ! ERROR DETECTED
+ endif
+ !turn on support for multi fields messages
+ !call grib_multi_support_on
+
+ gotGrib=0
+ ifield=0
+10 ifield=ifield+1
+
+ !
+ ! GET NEXT FIELDS
+ !
+ call grib_new_from_file(ifile,igrib,iret)
+ if (iret.eq.GRIB_END_OF_FILE) then
+ goto 30 ! EOF DETECTED
+ elseif (iret.ne.GRIB_SUCCESS) then
+ goto 999 ! ERROR DETECTED
+ endif
+
+ !first see if we read GRIB1 or GRIB2
+ call grib_get_int(igrib,'editionNumber',gribVer,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ if (gribVer.eq.1) then ! GRIB Edition 1
+
+ !print*,'GRiB Edition 1'
+ !read the grib2 identifiers
+ call grib_get_int(igrib,'indicatorOfParameter',isec1(6),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'level',isec1(8),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ !change code for etadot to code for omega
+ if (isec1(6).eq.77) then
+ isec1(6)=135
+ endif
+
+ !print*,isec1(6),isec1(8)
+
+ else
+
+ !print*,'GRiB Edition 2'
+ !read the grib2 identifiers
+ call grib_get_int(igrib,'discipline',discipl,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'parameterCategory',parCat,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'parameterNumber',parNum,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'typeOfFirstFixedSurface',typSurf,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'level',valSurf,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ !print*,discipl,parCat,parNum,typSurf,valSurf
+
+ !convert to grib1 identifiers
+ isec1(6)=-1
+ isec1(7)=-1
+ isec1(8)=-1
+ isec1(8)=valSurf ! level
+ if ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.105)) then ! T
+ isec1(6)=130 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.105)) then ! U
+ isec1(6)=131 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.105)) then ! V
+ isec1(6)=132 ! indicatorOfParameter
+ elseif ((parCat.eq.1).and.(parNum.eq.0).and.(typSurf.eq.105)) then ! Q
+ isec1(6)=133 ! indicatorOfParameter
+ elseif ((parCat.eq.3).and.(parNum.eq.0).and.(typSurf.eq.1)) then !SP
+ isec1(6)=134 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.32)) then ! W, actually eta dot
+ isec1(6)=135 ! indicatorOfParameter
+ elseif ((parCat.eq.3).and.(parNum.eq.0).and.(typSurf.eq.101)) then !SLP
+ isec1(6)=151 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.103)) then ! 10U
+ isec1(6)=165 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.103)) then ! 10V
+ isec1(6)=166 ! indicatorOfParameter
+ elseif ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.103)) then ! 2T
+ isec1(6)=167 ! indicatorOfParameter
+ elseif ((parCat.eq.0).and.(parNum.eq.6).and.(typSurf.eq.103)) then ! 2D
+ isec1(6)=168 ! indicatorOfParameter
+ elseif ((parCat.eq.1).and.(parNum.eq.11).and.(typSurf.eq.1)) then ! SD
+ isec1(6)=141 ! indicatorOfParameter
+ elseif ((parCat.eq.6).and.(parNum.eq.1)) then ! CC
+ isec1(6)=164 ! indicatorOfParameter
+ elseif ((parCat.eq.1).and.(parNum.eq.9)) then ! LSP
+ isec1(6)=142 ! indicatorOfParameter
+ elseif ((parCat.eq.1).and.(parNum.eq.10)) then ! CP
+ isec1(6)=143 ! indicatorOfParameter
+ elseif ((parCat.eq.0).and.(parNum.eq.11).and.(typSurf.eq.1)) then ! SHF
+ isec1(6)=146 ! indicatorOfParameter
+ elseif ((parCat.eq.4).and.(parNum.eq.9).and.(typSurf.eq.1)) then ! SR
+ isec1(6)=176 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.17)) then ! EWSS
+ isec1(6)=180 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.18)) then ! NSSS
+ isec1(6)=181 ! indicatorOfParameter
+ elseif ((parCat.eq.3).and.(parNum.eq.4)) then ! ORO
+ isec1(6)=129 ! indicatorOfParameter
+ elseif ((parCat.eq.3).and.(parNum.eq.7)) then ! SDO
+ isec1(6)=160 ! indicatorOfParameter
+ elseif ((discipl.eq.2).and.(parCat.eq.0).and.(parNum.eq.0).and. &
+ (typSurf.eq.1)) then ! LSM
+ isec1(6)=172 ! indicatorOfParameter
+ else
+ print*,'***ERROR: undefined GRiB2 message found!',discipl, &
+ parCat,parNum,typSurf
+ endif
+
+ endif
+
+ !get the size and data of the values array
+ if (isec1(6).ne.-1) then
+ call grib_get_real4_array(igrib,'values',zsec4,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ endif
+
+ !HSO get the required fields from section 2 in a gribex compatible manner
+ if (ifield.eq.1) then
+ call grib_get_int(igrib,'numberOfPointsAlongAParallel', &
+ isec2(2),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'numberOfPointsAlongAMeridian', &
+ isec2(3),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'numberOfVerticalCoordinateValues', &
+ isec2(12),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ !HSO get the size and data of the vertical coordinate array
+ call grib_get_real4_array(igrib,'pv',zsec2,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ nxn(l)=isec2(2)
+ nyn(l)=isec2(3)
+ nlev_ecn=isec2(12)/2-1
+ endif ! ifield
+
+ !HSO get the second part of the grid dimensions only from GRiB1 messages
+ if ((gribVer.eq.1).and.(gotGrib.eq.0)) then
+ call grib_get_real8(igrib,'longitudeOfFirstGridPointInDegrees', &
+ xaux1in,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_real8(igrib,'longitudeOfLastGridPointInDegrees', &
+ xaux2in,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_real8(igrib,'latitudeOfLastGridPointInDegrees', &
+ yaux1in,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_real8(igrib,'latitudeOfFirstGridPointInDegrees', &
+ yaux2in,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ xaux1=xaux1in
+ xaux2=xaux2in
+ yaux1=yaux1in
+ yaux2=yaux2in
+ if(xaux1.gt.180) xaux1=xaux1-360.0
+ if(xaux2.gt.180) xaux2=xaux2-360.0
+ if(xaux1.lt.-180) xaux1=xaux1+360.0
+ if(xaux2.lt.-180) xaux2=xaux2+360.0
+ if (xaux2.lt.xaux1) xaux2=xaux2+360.
+ xlon0n(l)=xaux1
+ ylat0n(l)=yaux1
+ dxn(l)=(xaux2-xaux1)/real(nxn(l)-1)
+ dyn(l)=(yaux2-yaux1)/real(nyn(l)-1)
+ gotGrib=1
+ endif ! ifield.eq.1
+
+ k=isec1(8)
+ if(isec1(6).eq.131) iumax=max(iumax,nlev_ec-k+1)
+ if(isec1(6).eq.135) iwmax=max(iwmax,nlev_ec-k+1)
+
+ if(isec1(6).eq.129) then
+ do j=0,nyn(l)-1
+ do i=0,nxn(l)-1
+ oron(i,j,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)/ga
+ end do
+ end do
+ endif
+ if(isec1(6).eq.172) then
+ do j=0,nyn(l)-1
+ do i=0,nxn(l)-1
+ lsmn(i,j,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)/ga
+ end do
+ end do
+ endif
+ if(isec1(6).eq.160) then
+ do j=0,nyn(l)-1
+ do i=0,nxn(l)-1
+ excessoron(i,j,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)/ga
+ end do
+ end do
+ endif
+
+ call grib_release(igrib)
+ goto 10 !! READ NEXT LEVEL OR PARAMETER
+ !
+ ! CLOSING OF INPUT DATA FILE
+ !
+
+30 call grib_close_file(ifile)
+
+ !error message if no fields found with correct first longitude in it
+ if (gotGrib.eq.0) then
+ print*,'***ERROR: input file needs to contain GRiB1 formatted'// &
+ 'messages'
+ stop
+ endif
+
+ nuvzn=iumax
+ nwzn=iwmax
+ if(nuvzn.eq.nlev_ec) nwzn=nlev_ecn+1
+
+ if (nxn(l).gt.nxmaxn) then
+ write(*,*) 'FLEXPART error: Too many grid points in x direction.'
+ write(*,*) 'Reduce resolution of wind fields (file GRIDSPEC)'
+ write(*,*) 'for nesting level ',l
+ write(*,*) 'Or change parameter settings in file par_mod.'
+ write(*,*) nxn(l),nxmaxn
+ stop
+ endif
+
+ if (nyn(l).gt.nymaxn) then
+ write(*,*) 'FLEXPART error: Too many grid points in y direction.'
+ write(*,*) 'Reduce resolution of wind fields (file GRIDSPEC)'
+ write(*,*) 'for nesting level ',l
+ write(*,*) 'Or change parameter settings in file par_mod.'
+ write(*,*) nyn(l),nymaxn
+ stop
+ endif
+
+ if ((nuvzn.gt.nuvzmax).or.(nwzn.gt.nwzmax)) then
+ write(*,*) 'FLEXPART error: Nested wind fields have too many'// &
+ 'vertical levels.'
+ write(*,*) 'Problem was encountered for nesting level ',l
+ stop
+ endif
+
+
+ ! Output of grid info
+ !********************
+
+ write(*,'(a,i2)') 'Nested domain #: ',l
+ write(*,'(a,f10.2,a1,f10.2,a,f10.2)') ' Longitude range: ', &
+ xlon0n(l),' to ',xlon0n(l)+(nxn(l)-1)*dxn(l), &
+ ' Grid distance: ',dxn(l)
+ write(*,'(a,f10.2,a1,f10.2,a,f10.2)') ' Latitude range: ', &
+ ylat0n(l),' to ',ylat0n(l)+(nyn(l)-1)*dyn(l), &
+ ' Grid distance: ',dyn(l)
+ write(*,*)
+
+ ! Determine, how much the resolutions in the nests are enhanced as
+ ! compared to the mother grid
+ !*****************************************************************
+
+ xresoln(l)=dx/dxn(l)
+ yresoln(l)=dy/dyn(l)
+
+ ! Determine the mother grid coordinates of the corner points of the
+ ! nested grids
+ ! Convert first to geographical coordinates, then to grid coordinates
+ !********************************************************************
+
+ xaux1=xlon0n(l)
+ xaux2=xlon0n(l)+real(nxn(l)-1)*dxn(l)
+ yaux1=ylat0n(l)
+ yaux2=ylat0n(l)+real(nyn(l)-1)*dyn(l)
+
+ xln(l)=(xaux1-xlon0)/dx
+ xrn(l)=(xaux2-xlon0)/dx
+ yln(l)=(yaux1-ylat0)/dy
+ yrn(l)=(yaux2-ylat0)/dy
+
+
+ if ((xln(l).lt.0.).or.(yln(l).lt.0.).or. &
+ (xrn(l).gt.real(nxmin1)).or.(yrn(l).gt.real(nymin1))) then
+ write(*,*) 'Nested domain does not fit into mother domain'
+ write(*,*) 'For global mother domain fields, you can shift'
+ write(*,*) 'shift the mother domain into x-direction'
+ write(*,*) 'by setting nxshift (file par_mod) to a'
+ write(*,*) 'positive value. Execution is terminated.'
+ stop
+ endif
+
+
+ ! CALCULATE VERTICAL DISCRETIZATION OF ECMWF MODEL
+ ! PARAMETER akm,bkm DESCRIBE THE HYBRID "ETA" COORDINATE SYSTEM
+
+ numskip=nlev_ecn-nuvzn ! number of ecmwf model layers not used by FLEXPART
+ do i=1,nwzn
+ j=numskip+i
+ k=nlev_ecn+1+numskip+i
+ akmn(nwzn-i+1)=zsec2(j)
+ bkmn(nwzn-i+1)=zsec2(k)
+ end do
+
+ !
+ ! CALCULATION OF AKZ, BKZ
+ ! AKZ,BKZ: model discretization parameters at the center of each model
+ ! layer
+ !
+ ! Assign the 10 m winds to an artificial model level with akz=0 and bkz=1.0,
+ ! i.e. ground level
+ !*****************************************************************************
+
+ akzn(1)=0.
+ bkzn(1)=1.0
+ do i=1,nuvzn
+ akzn(i+1)=0.5*(akmn(i+1)+akmn(i))
+ bkzn(i+1)=0.5*(bkmn(i+1)+bkmn(i))
+ end do
+ nuvzn=nuvzn+1
+
+ ! Check, whether the heights of the model levels of the nested
+ ! wind fields are consistent with those of the mother domain.
+ ! If not, terminate model run.
+ !*************************************************************
+
+ do i=1,nuvz
+ if ((akzn(i).ne.akz(i)).or.(bkzn(i).ne.bkz(i))) then
+ write(*,*) 'FLEXPART error: The wind fields of nesting level',l
+ write(*,*) 'are not consistent with the mother domain:'
+ write(*,*) 'Differences in vertical levels detected.'
+ stop
+ endif
+ end do
+
+ do i=1,nwz
+ if ((akmn(i).ne.akm(i)).or.(bkmn(i).ne.bkm(i))) then
+ write(*,*) 'FLEXPART error: The wind fields of nesting level',l
+ write(*,*) 'are not consistent with the mother domain:'
+ write(*,*) 'Differences in vertical levels detected.'
+ stop
+ endif
+ end do
+
+ end do
+
+ return
+
+999 write(*,*)
+ write(*,*) ' ###########################################'// &
+ '###### '
+ write(*,*) ' FLEXPART SUBROUTINE GRIDCHECK:'
+ write(*,*) ' CAN NOT OPEN INPUT DATA FILE '//wfnamen(l,ifn)
+ write(*,*) ' FOR NESTING LEVEL ',k
+ write(*,*) ' ###########################################'// &
+ '###### '
+ stop
+
+end subroutine gridcheck_nests
diff --git a/src/gridcheck_nests_emos.f90 b/src/gridcheck_nests_emos.f90
new file mode 100644
index 0000000000000000000000000000000000000000..f0139ddde8014c63bf7b2640144599ce1717befe
--- /dev/null
+++ b/src/gridcheck_nests_emos.f90
@@ -0,0 +1,301 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine gridcheck_nests
+
+ !*****************************************************************************
+ ! *
+ ! This routine checks the grid specification for the nested model *
+ ! domains. It is similar to subroutine gridcheck, which checks the *
+ ! mother domain. *
+ ! *
+ ! Authors: A. Stohl, G. Wotawa *
+ ! *
+ ! 8 February 1999 *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: i,j,k,l,ifn,ifield,iumax,iwmax,numskip,nlev_ecn
+ integer :: nuvzn,nwzn
+ real :: akmn(nwzmax),bkmn(nwzmax),akzn(nuvzmax),bkzn(nuvzmax)
+ real :: xaux1,xaux2,yaux1,yaux2
+
+ ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING
+
+ ! dimension of isec2 at least (22+n), where n is the number of parallels or
+ ! meridians in a quasi-regular (reduced) Gaussian or lat/long grid
+
+ ! dimension of zsec2 at least (10+nn), where nn is the number of vertical
+ ! coordinate parameters
+
+ integer :: isec0(2),isec1(56),isec2(22+nxmaxn+nymaxn),isec3(2)
+ integer :: isec4(64),inbuff(jpack),ilen,ierr,iword,lunit
+ !integer iswap
+ real :: zsec2(60+2*nuvzmax),zsec3(2),zsec4(jpunp)
+ character(len=1) :: yoper = 'D'
+
+ xresoln(0)=1. ! resolution enhancement for mother grid
+ yresoln(0)=1. ! resolution enhancement for mother grid
+
+ ! Loop about all nesting levels
+ !******************************
+
+ do l=1,numbnests
+
+ iumax=0
+ iwmax=0
+
+ if(ideltas.gt.0) then
+ ifn=1
+ else
+ ifn=numbwf
+ endif
+ !
+ ! OPENING OF DATA FILE (GRIB CODE)
+ !
+5 call pbopen(lunit,path(numpath+2*(l-1)+1) &
+ (1:length(numpath+2*(l-1)+1))//wfnamen(l,ifn),'r',ierr)
+ if(ierr.lt.0) goto 999
+
+ ifield=0
+10 ifield=ifield+1
+ !
+ ! GET NEXT FIELDS
+ !
+ call pbgrib(lunit,inbuff,jpack,ilen,ierr)
+ if(ierr.eq.-1) goto 30 ! EOF DETECTED
+ if(ierr.lt.-1) goto 999 ! ERROR DETECTED
+
+ ierr=1
+
+ ! Check whether we are on a little endian or on a big endian computer
+ !********************************************************************
+
+ ! if (inbuff(1).eq.1112101447) then ! little endian, swap bytes
+ ! iswap=1+ilen/4
+ ! call swap32(inbuff,iswap)
+ ! else if (inbuff(1).ne.1196575042) then ! big endian
+ ! stop 'subroutine gridcheck: corrupt GRIB data'
+ ! endif
+
+ call gribex(isec0,isec1,isec2,zsec2,isec3,zsec3,isec4, &
+ zsec4,jpunp,inbuff,jpack,iword,yoper,ierr)
+ if (ierr.ne.0) goto 999 ! ERROR DETECTED
+
+ if(ifield.eq.1) then
+ nxn(l)=isec2(2)
+ nyn(l)=isec2(3)
+ xaux1=real(isec2(5))/1000.
+ xaux2=real(isec2(8))/1000.
+ if(xaux1.gt.180) xaux1=xaux1-360.0
+ if(xaux2.gt.180) xaux2=xaux2-360.0
+ if(xaux1.lt.-180) xaux1=xaux1+360.0
+ if(xaux2.lt.-180) xaux2=xaux2+360.0
+ if (xaux2.lt.xaux1) xaux2=xaux2+360.
+ yaux1=real(isec2(7))/1000.
+ yaux2=real(isec2(4))/1000.
+ xlon0n(l)=xaux1
+ ylat0n(l)=yaux1
+ dxn(l)=(xaux2-xaux1)/real(nxn(l)-1)
+ dyn(l)=(yaux2-yaux1)/real(nyn(l)-1)
+ nlev_ecn=isec2(12)/2-1
+ endif
+
+
+ k=isec1(8)
+ if(isec1(6).eq.131) iumax=max(iumax,nlev_ec-k+1)
+ if(isec1(6).eq.135) iwmax=max(iwmax,nlev_ec-k+1)
+
+ if(isec1(6).eq.129) then
+ do j=0,nyn(l)-1
+ do i=0,nxn(l)-1
+ oron(i,j,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)/ga
+ end do
+ end do
+ endif
+ if(isec1(6).eq.172) then
+ do j=0,nyn(l)-1
+ do i=0,nxn(l)-1
+ lsmn(i,j,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)/ga
+ end do
+ end do
+ endif
+ if(isec1(6).eq.160) then
+ do j=0,nyn(l)-1
+ do i=0,nxn(l)-1
+ excessoron(i,j,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)/ga
+ end do
+ end do
+ endif
+
+ goto 10 !! READ NEXT LEVEL OR PARAMETER
+ !
+ ! CLOSING OF INPUT DATA FILE
+ !
+30 call pbclose(lunit,ierr) !! FINISHED READING / CLOSING GRIB FILE
+
+ nuvzn=iumax
+ nwzn=iwmax
+ if(nuvzn.eq.nlev_ec) nwzn=nlev_ecn+1
+
+ if (nxn(l).gt.nxmaxn) then
+ write(*,*) 'FLEXPART error: Too many grid points in x direction.'
+ write(*,*) 'Reduce resolution of wind fields (file GRIDSPEC)'
+ write(*,*) 'for nesting level ',l
+ write(*,*) 'Or change parameter settings in file par_mod.'
+ write(*,*) nxn(l),nxmaxn
+ stop
+ endif
+
+ if (nyn(l).gt.nymaxn) then
+ write(*,*) 'FLEXPART error: Too many grid points in y direction.'
+ write(*,*) 'Reduce resolution of wind fields (file GRIDSPEC)'
+ write(*,*) 'for nesting level ',l
+ write(*,*) 'Or change parameter settings in file par_mod.'
+ write(*,*) nyn(l),nymaxn
+ stop
+ endif
+
+ if ((nuvzn.gt.nuvzmax).or.(nwzn.gt.nwzmax)) then
+ write(*,*) 'FLEXPART error: Nested wind fields have too many'// &
+ 'vertical levels.'
+ write(*,*) 'Problem was encountered for nesting level ',l
+ stop
+ endif
+
+
+ ! Output of grid info
+ !********************
+
+ write(*,'(a,i2)') 'Nested domain #: ',l
+ write(*,'(a,f10.2,a1,f10.2,a,f10.2)') ' Longitude range: ', &
+ xlon0n(l),' to ',xlon0n(l)+(nxn(l)-1)*dxn(l), &
+ ' Grid distance: ',dxn(l)
+ write(*,'(a,f10.2,a1,f10.2,a,f10.2)') ' Latitude range: ', &
+ ylat0n(l),' to ',ylat0n(l)+(nyn(l)-1)*dyn(l), &
+ ' Grid distance: ',dyn(l)
+ write(*,*)
+
+ ! Determine, how much the resolutions in the nests are enhanced as
+ ! compared to the mother grid
+ !*****************************************************************
+
+ xresoln(l)=dx/dxn(l)
+ yresoln(l)=dy/dyn(l)
+
+ ! Determine the mother grid coordinates of the corner points of the
+ ! nested grids
+ ! Convert first to geographical coordinates, then to grid coordinates
+ !********************************************************************
+
+ xaux1=xlon0n(l)
+ xaux2=xlon0n(l)+real(nxn(l)-1)*dxn(l)
+ yaux1=ylat0n(l)
+ yaux2=ylat0n(l)+real(nyn(l)-1)*dyn(l)
+
+ xln(l)=(xaux1-xlon0)/dx
+ xrn(l)=(xaux2-xlon0)/dx
+ yln(l)=(yaux1-ylat0)/dy
+ yrn(l)=(yaux2-ylat0)/dy
+
+
+ if ((xln(l).lt.0.).or.(yln(l).lt.0.).or. &
+ (xrn(l).gt.real(nxmin1)).or.(yrn(l).gt.real(nymin1))) then
+ write(*,*) 'Nested domain does not fit into mother domain'
+ write(*,*) 'For global mother domain fields, you can shift'
+ write(*,*) 'shift the mother domain into x-direction'
+ write(*,*) 'by setting nxshift (file par_mod) to a'
+ write(*,*) 'positive value. Execution is terminated.'
+ stop
+ endif
+
+
+ ! CALCULATE VERTICAL DISCRETIZATION OF ECMWF MODEL
+ ! PARAMETER akm,bkm DESCRIBE THE HYBRID "ETA" COORDINATE SYSTEM
+
+ numskip=nlev_ecn-nuvzn ! number of ecmwf model layers not used by FLEXPART
+ do i=1,nwzn
+ j=numskip+i
+ k=nlev_ecn+1+numskip+i
+ akmn(nwzn-i+1)=zsec2(10+j)
+ bkmn(nwzn-i+1)=zsec2(10+k)
+ end do
+
+ !
+ ! CALCULATION OF AKZ, BKZ
+ ! AKZ,BKZ: model discretization parameters at the center of each model
+ ! layer
+ !
+ ! Assign the 10 m winds to an artificial model level with akz=0 and bkz=1.0,
+ ! i.e. ground level
+ !*****************************************************************************
+
+ akzn(1)=0.
+ bkzn(1)=1.0
+ do i=1,nuvzn
+ akzn(i+1)=0.5*(akmn(i+1)+akmn(i))
+ bkzn(i+1)=0.5*(bkmn(i+1)+bkmn(i))
+ end do
+ nuvzn=nuvzn+1
+
+ ! Check, whether the heights of the model levels of the nested
+ ! wind fields are consistent with those of the mother domain.
+ ! If not, terminate model run.
+ !*************************************************************
+
+ do i=1,nuvz
+ if ((akzn(i).ne.akz(i)).or.(bkzn(i).ne.bkz(i))) then
+ write(*,*) 'FLEXPART error: The wind fields of nesting level',l
+ write(*,*) 'are not consistent with the mother domain:'
+ write(*,*) 'Differences in vertical levels detected.'
+ stop
+ endif
+ end do
+
+ do i=1,nwz
+ if ((akmn(i).ne.akm(i)).or.(bkmn(i).ne.bkm(i))) then
+ write(*,*) 'FLEXPART error: The wind fields of nesting level',l
+ write(*,*) 'are not consistent with the mother domain:'
+ write(*,*) 'Differences in vertical levels detected.'
+ stop
+ endif
+ end do
+
+ end do
+
+ return
+
+999 write(*,*)
+ write(*,*) ' ###########################################'// &
+ '###### '
+ write(*,*) ' FLEXPART SUBROUTINE GRIDCHECK:'
+ write(*,*) ' CAN NOT OPEN INPUT DATA FILE '//wfnamen(l,ifn)
+ write(*,*) ' FOR NESTING LEVEL ',k
+ write(*,*) ' ###########################################'// &
+ '###### '
+ stop
+
+end subroutine gridcheck_nests
diff --git a/src/hanna.f90 b/src/hanna.f90
new file mode 100644
index 0000000000000000000000000000000000000000..e315541dc4dfcd9ced5e9b6c0d1b31ca5143eee2
--- /dev/null
+++ b/src/hanna.f90
@@ -0,0 +1,126 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine hanna(z)
+ ! i
+ !*****************************************************************************
+ ! *
+ ! Computation of \sigma_i and \tau_L based on the scheme of Hanna (1982) *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 4 December 1997 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! dsigwdz [1/s] vertical gradient of sigw *
+ ! ol [m] Obukhov length *
+ ! sigu, sigv, sigw standard deviations of turbulent velocity fluctuations *
+ ! tlu [s] Lagrangian time scale for the along wind component. *
+ ! tlv [s] Lagrangian time scale for the cross wind component. *
+ ! tlw [s] Lagrangian time scale for the vertical wind component. *
+ ! ust, ustar [m/s] friction velocity *
+ ! wst, wstar [m/s] convective velocity scale *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+ use hanna_mod
+
+ implicit none
+
+ real :: corr,z
+
+
+
+ !**********************
+ ! 1. Neutral conditions
+ !**********************
+
+ if (h/abs(ol).lt.1.) then
+ ust=max(1.e-4,ust)
+ corr=z/ust
+ sigu=1.e-2+2.0*ust*exp(-3.e-4*corr)
+ sigw=1.3*ust*exp(-2.e-4*corr)
+ dsigwdz=-2.e-4*sigw
+ sigw=sigw+1.e-2
+ sigv=sigw
+ tlu=0.5*z/sigw/(1.+1.5e-3*corr)
+ tlv=tlu
+ tlw=tlu
+
+
+ !***********************
+ ! 2. Unstable conditions
+ !***********************
+
+ else if (ol.lt.0.) then
+
+
+ ! Determine sigmas
+ !*****************
+
+ sigu=1.e-2+ust*(12-0.5*h/ol)**0.33333
+ sigv=sigu
+ sigw=sqrt(1.2*wst**2*(1.-.9*zeta)*zeta**0.66666+ &
+ (1.8-1.4*zeta)*ust**2)+1.e-2
+ dsigwdz=0.5/sigw/h*(-1.4*ust**2+wst**2* &
+ (0.8*max(zeta,1.e-3)**(-.33333)-1.8*zeta**0.66666))
+
+
+ ! Determine average Lagrangian time scale
+ !****************************************
+
+ tlu=0.15*h/sigu
+ tlv=tlu
+ if (z.lt.abs(ol)) then
+ tlw=0.1*z/(sigw*(0.55-0.38*abs(z/ol)))
+ else if (zeta.lt.0.1) then
+ tlw=0.59*z/sigw
+ else
+ tlw=0.15*h/sigw*(1.-exp(-5*zeta))
+ endif
+
+
+ !*********************
+ ! 3. Stable conditions
+ !*********************
+
+ else
+ sigu=1.e-2+2.*ust*(1.-zeta)
+ sigv=1.e-2+1.3*ust*(1.-zeta)
+ sigw=sigv
+ dsigwdz=-1.3*ust/h
+ tlu=0.15*h/sigu*(sqrt(zeta))
+ tlv=0.467*tlu
+ tlw=0.1*h/sigw*zeta**0.8
+ endif
+
+
+ tlu=max(10.,tlu)
+ tlv=max(10.,tlv)
+ tlw=max(30.,tlw)
+
+ if (dsigwdz.eq.0.) dsigwdz=1.e-10
+
+end subroutine hanna
diff --git a/src/hanna1.f90 b/src/hanna1.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d630851f2b20a723ae20d68122f24bdfe3cc41d8
--- /dev/null
+++ b/src/hanna1.f90
@@ -0,0 +1,149 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine hanna1(z)
+ ! i
+ !*****************************************************************************
+ ! *
+ ! Computation of \sigma_i and \tau_L based on the scheme of Hanna (1982) *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 4 December 1997 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! dsigwdz [1/s] vertical gradient of sigw *
+ ! ol [m] Obukhov length *
+ ! sigu, sigv, sigw standard deviations of turbulent velocity fluctuations *
+ ! tlu [s] Lagrangian time scale for the along wind component. *
+ ! tlv [s] Lagrangian time scale for the cross wind component. *
+ ! tlw [s] Lagrangian time scale for the vertical wind component. *
+ ! ust, ustar [m/s] friction velocity *
+ ! wst, wstar [m/s] convective velocity scale *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+ use hanna_mod
+
+ implicit none
+
+ real :: z,s1,s2
+
+
+
+ !**********************
+ ! 1. Neutral conditions
+ !**********************
+
+ if (h/abs(ol).lt.1.) then
+
+ ust=max(1.e-4,ust)
+ sigu=2.0*ust*exp(-3.e-4*z/ust)
+ sigu=max(sigu,1.e-5)
+ sigv=1.3*ust*exp(-2.e-4*z/ust)
+ sigv=max(sigv,1.e-5)
+ sigw=sigv
+ dsigw2dz=-6.76e-4*ust*exp(-4.e-4*z/ust)
+ tlu=0.5*z/sigw/(1.+1.5e-3*z/ust)
+ tlv=tlu
+ tlw=tlu
+
+
+ !***********************
+ ! 2. Unstable conditions
+ !***********************
+
+ else if (ol.lt.0.) then
+
+
+ ! Determine sigmas
+ !*****************
+
+ sigu=ust*(12-0.5*h/ol)**0.33333
+ sigu=max(sigu,1.e-6)
+ sigv=sigu
+
+ if (zeta.lt.0.03) then
+ sigw=0.96*wst*(3*zeta-ol/h)**0.33333
+ dsigw2dz=1.8432*wst*wst/h*(3*zeta-ol/h)**(-0.33333)
+ else if (zeta.lt.0.4) then
+ s1=0.96*(3*zeta-ol/h)**0.33333
+ s2=0.763*zeta**0.175
+ if (s1.lt.s2) then
+ sigw=wst*s1
+ dsigw2dz=1.8432*wst*wst/h*(3*zeta-ol/h)**(-0.33333)
+ else
+ sigw=wst*s2
+ dsigw2dz=0.203759*wst*wst/h*zeta**(-0.65)
+ endif
+ else if (zeta.lt.0.96) then
+ sigw=0.722*wst*(1-zeta)**0.207
+ dsigw2dz=-.215812*wst*wst/h*(1-zeta)**(-0.586)
+ else if (zeta.lt.1.00) then
+ sigw=0.37*wst
+ dsigw2dz=0.
+ endif
+ sigw=max(sigw,1.e-6)
+
+
+ ! Determine average Lagrangian time scale
+ !****************************************
+
+ tlu=0.15*h/sigu
+ tlv=tlu
+ if (z.lt.abs(ol)) then
+ tlw=0.1*z/(sigw*(0.55-0.38*abs(z/ol)))
+ else if (zeta.lt.0.1) then
+ tlw=0.59*z/sigw
+ else
+ tlw=0.15*h/sigw*(1.-exp(-5*zeta))
+ endif
+
+
+ !*********************
+ ! 3. Stable conditions
+ !*********************
+
+ else
+ sigu=2.*ust*(1.-zeta)
+ sigv=1.3*ust*(1.-zeta)
+ sigu=max(sigu,1.e-6)
+ sigv=max(sigv,1.e-6)
+ sigw=sigv
+ dsigw2dz=3.38*ust*ust*(zeta-1.)/h
+ tlu=0.15*h/sigu*(sqrt(zeta))
+ tlv=0.467*tlu
+ tlw=0.1*h/sigw*zeta**0.8
+ endif
+
+
+
+
+ tlu=max(10.,tlu)
+ tlv=max(10.,tlv)
+ tlw=max(30.,tlw)
+
+
+end subroutine hanna1
diff --git a/src/hanna_mod.f90 b/src/hanna_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..91717ec4c8bfd4897d2fe54110078b160c0a78be
--- /dev/null
+++ b/src/hanna_mod.f90
@@ -0,0 +1,8 @@
+module hanna_mod
+
+ implicit none
+
+ real :: ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw
+ real :: sigw,dsigwdz,dsigw2dz
+
+end module hanna_mod
diff --git a/src/hanna_short.f90 b/src/hanna_short.f90
new file mode 100644
index 0000000000000000000000000000000000000000..6b0a6a65bf366d2ff44f6f993c5d7ac761458642
--- /dev/null
+++ b/src/hanna_short.f90
@@ -0,0 +1,112 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine hanna_short(z)
+ ! i
+ !*****************************************************************************
+ ! *
+ ! Computation of \sigma_i and \tau_L based on the scheme of Hanna (1982) *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 4 December 1997 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! dsigwdz [1/s] vertical gradient of sigw *
+ ! ol [m] Obukhov length *
+ ! sigu, sigv, sigw standard deviations of turbulent velocity fluctuations *
+ ! tlu [s] Lagrangian time scale for the along wind component. *
+ ! tlv [s] Lagrangian time scale for the cross wind component. *
+ ! tlw [s] Lagrangian time scale for the vertical wind component. *
+ ! ust, ustar [m/s] friction velocity *
+ ! wst, wstar [m/s] convective velocity scale *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+ use hanna_mod
+
+ implicit none
+
+ real :: z
+
+
+
+ !**********************
+ ! 1. Neutral conditions
+ !**********************
+
+ if (h/abs(ol).lt.1.) then
+ ust=max(1.e-4,ust)
+ sigw=1.3*exp(-2.e-4*z/ust)
+ dsigwdz=-2.e-4*sigw
+ sigw=sigw*ust+1.e-2
+ tlw=0.5*z/sigw/(1.+1.5e-3*z/ust)
+
+
+ !***********************
+ ! 2. Unstable conditions
+ !***********************
+
+ else if (ol.lt.0.) then
+
+
+ ! Determine sigmas
+ !*****************
+
+ sigw=sqrt(1.2*wst**2*(1.-.9*zeta)*zeta**0.66666+ &
+ (1.8-1.4*zeta)*ust**2)+1.e-2
+ dsigwdz=0.5/sigw/h*(-1.4*ust**2+wst**2* &
+ (0.8*max(zeta,1.e-3)**(-.33333)-1.8*zeta**0.66666))
+
+
+ ! Determine average Lagrangian time scale
+ !****************************************
+
+ if (z.lt.abs(ol)) then
+ tlw=0.1*z/(sigw*(0.55-0.38*abs(z/ol)))
+ else if (zeta.lt.0.1) then
+ tlw=0.59*z/sigw
+ else
+ tlw=0.15*h/sigw*(1.-exp(-5*zeta))
+ endif
+
+
+ !*********************
+ ! 3. Stable conditions
+ !*********************
+
+ else
+ sigw=1.e-2+1.3*ust*(1.-zeta)
+ dsigwdz=-1.3*ust/h
+ tlw=0.1*h/sigw*zeta**0.8
+ endif
+
+
+ tlu=max(10.,tlu)
+ tlv=max(10.,tlv)
+ tlw=max(30.,tlw)
+ if (dsigwdz.eq.0.) dsigwdz=1.e-10
+
+end subroutine hanna_short
diff --git a/src/init_domainfill.f90 b/src/init_domainfill.f90
new file mode 100644
index 0000000000000000000000000000000000000000..c5454cf4443104c22dca11ab37f8c38197b4843a
--- /dev/null
+++ b/src/init_domainfill.f90
@@ -0,0 +1,416 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine init_domainfill
+ !
+ !*****************************************************************************
+ ! *
+ ! Initializes particles equally distributed over the first release location *
+ ! specified in file RELEASES. This box is assumed to be the domain for doing *
+ ! domain-filling trajectory calculations. *
+ ! All particles carry the same amount of mass which alltogether comprises the*
+ ! mass of air within the box. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 15 October 2002 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! numparticlecount consecutively counts the number of particles released *
+ ! nx_we(2) grid indices for western and eastern boundary of domain- *
+ ! filling trajectory calculations *
+ ! ny_sn(2) grid indices for southern and northern boundary of domain- *
+ ! filling trajectory calculations *
+ ! *
+ !*****************************************************************************
+
+ use point_mod
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: j,ix,jy,kz,ncolumn,numparttot
+ real :: gridarea(0:nymax-1),pp(nzmax),ylat,ylatp,ylatm,hzone,ran1
+ real :: cosfactm,cosfactp,deltacol,dz1,dz2,dz,pnew,fractus
+ real,parameter :: pih=pi/180.
+ real :: colmass(0:nxmax-1,0:nymax-1),colmasstotal,zposition
+
+ integer :: ixm,ixp,jym,jyp,indzm,indzp,in,indzh,i,jj
+ real :: pvpart,ddx,ddy,rddx,rddy,p1,p2,p3,p4,y1(2)
+
+ integer :: idummy = -11
+
+
+ ! Determine the release region (only full grid cells), over which particles
+ ! shall be initialized
+ ! Use 2 fields for west/east and south/north boundary
+ !**************************************************************************
+
+ nx_we(1)=max(int(xpoint1(1)),0)
+ nx_we(2)=min((int(xpoint2(1))+1),nxmin1)
+ ny_sn(1)=max(int(ypoint1(1)),0)
+ ny_sn(2)=min((int(ypoint2(1))+1),nymin1)
+
+ ! For global simulations (both global wind data and global domain-filling),
+ ! set a switch, such that no boundary conditions are used
+ !**************************************************************************
+ if (xglobal.and.sglobal.and.nglobal) then
+ if ((nx_we(1).eq.0).and.(nx_we(2).eq.nxmin1).and. &
+ (ny_sn(1).eq.0).and.(ny_sn(2).eq.nymin1)) then
+ gdomainfill=.true.
+ else
+ gdomainfill=.false.
+ endif
+ endif
+
+ ! Do not release particles twice (i.e., not at both in the leftmost and rightmost
+ ! grid cell) for a global domain
+ !*****************************************************************************
+ if (xglobal) nx_we(2)=min(nx_we(2),nx-2)
+
+
+ ! Calculate area of grid cell with formula M=2*pi*R*h*dx/360,
+ ! see Netz, Formeln der Mathematik, 5. Auflage (1983), p.90
+ !************************************************************
+
+ do jy=ny_sn(1),ny_sn(2) ! loop about latitudes
+ ylat=ylat0+real(jy)*dy
+ ylatp=ylat+0.5*dy
+ ylatm=ylat-0.5*dy
+ if ((ylatm.lt.0).and.(ylatp.gt.0.)) then
+ hzone=1./dyconst
+ else
+ cosfactp=cos(ylatp*pih)*r_earth
+ cosfactm=cos(ylatm*pih)*r_earth
+ if (cosfactp.lt.cosfactm) then
+ hzone=sqrt(r_earth**2-cosfactp**2)- &
+ sqrt(r_earth**2-cosfactm**2)
+ else
+ hzone=sqrt(r_earth**2-cosfactm**2)- &
+ sqrt(r_earth**2-cosfactp**2)
+ endif
+ endif
+ gridarea(jy)=2.*pi*r_earth*hzone*dx/360.
+ end do
+
+ ! Do the same for the south pole
+
+ if (sglobal) then
+ ylat=ylat0
+ ylatp=ylat+0.5*dy
+ ylatm=ylat
+ cosfactm=0.
+ cosfactp=cos(ylatp*pih)*r_earth
+ hzone=sqrt(r_earth**2-cosfactm**2)- &
+ sqrt(r_earth**2-cosfactp**2)
+ gridarea(0)=2.*pi*r_earth*hzone*dx/360.
+ endif
+
+ ! Do the same for the north pole
+
+ if (nglobal) then
+ ylat=ylat0+real(nymin1)*dy
+ ylatp=ylat
+ ylatm=ylat-0.5*dy
+ cosfactp=0.
+ cosfactm=cos(ylatm*pih)*r_earth
+ hzone=sqrt(r_earth**2-cosfactp**2)- &
+ sqrt(r_earth**2-cosfactm**2)
+ gridarea(nymin1)=2.*pi*r_earth*hzone*dx/360.
+ endif
+
+
+ ! Calculate total mass of each grid column and of the whole atmosphere
+ !*********************************************************************
+
+ colmasstotal=0.
+ do jy=ny_sn(1),ny_sn(2) ! loop about latitudes
+ do ix=nx_we(1),nx_we(2) ! loop about longitudes
+ pp(1)=rho(ix,jy,1,1)*r_air*tt(ix,jy,1,1)
+ pp(nz)=rho(ix,jy,nz,1)*r_air*tt(ix,jy,nz,1)
+ colmass(ix,jy)=(pp(1)-pp(nz))/ga*gridarea(jy)
+ colmasstotal=colmasstotal+colmass(ix,jy)
+ end do
+ end do
+
+ write(*,*) 'Atm. mass: ',colmasstotal
+
+
+ if (ipin.eq.0) numpart=0
+
+ ! Determine the particle positions
+ !*********************************
+
+ numparttot=0
+ numcolumn=0
+ do jy=ny_sn(1),ny_sn(2) ! loop about latitudes
+ ylat=ylat0+real(jy)*dy
+ do ix=nx_we(1),nx_we(2) ! loop about longitudes
+ ncolumn=nint(0.999*real(npart(1))*colmass(ix,jy)/ &
+ colmasstotal)
+ if (ncolumn.eq.0) goto 30
+ if (ncolumn.gt.numcolumn) numcolumn=ncolumn
+
+ ! Calculate pressure at the altitudes of model surfaces, using the air density
+ ! information, which is stored as a 3-d field
+ !*****************************************************************************
+
+ do kz=1,nz
+ pp(kz)=rho(ix,jy,kz,1)*r_air*tt(ix,jy,kz,1)
+ end do
+
+
+ deltacol=(pp(1)-pp(nz))/real(ncolumn)
+ pnew=pp(1)+deltacol/2.
+ jj=0
+ do j=1,ncolumn
+ jj=jj+1
+
+
+ ! For columns with many particles (i.e. around the equator), distribute
+ ! the particles equally, for columns with few particles (i.e. around the
+ ! poles), distribute the particles randomly
+ !***********************************************************************
+
+
+ if (ncolumn.gt.20) then
+ pnew=pnew-deltacol
+ else
+ pnew=pp(1)-ran1(idummy)*(pp(1)-pp(nz))
+ endif
+
+ do kz=1,nz-1
+ if ((pp(kz).ge.pnew).and.(pp(kz+1).lt.pnew)) then
+ dz1=pp(kz)-pnew
+ dz2=pnew-pp(kz+1)
+ dz=1./(dz1+dz2)
+
+ ! Assign particle position
+ !*************************
+ ! Do the following steps only if particles are not read in from previous model run
+ !*****************************************************************************
+ if (ipin.eq.0) then
+ xtra1(numpart+jj)=real(ix)-0.5+ran1(idummy)
+ if (ix.eq.0) xtra1(numpart+jj)=ran1(idummy)
+ if (ix.eq.nxmin1) xtra1(numpart+jj)= &
+ real(nxmin1)-ran1(idummy)
+ ytra1(numpart+jj)=real(jy)-0.5+ran1(idummy)
+ ztra1(numpart+jj)=(height(kz)*dz2+height(kz+1)*dz1)*dz
+ if (ztra1(numpart+jj).gt.height(nz)-0.5) &
+ ztra1(numpart+jj)=height(nz)-0.5
+
+
+ ! Interpolate PV to the particle position
+ !****************************************
+ ixm=int(xtra1(numpart+jj))
+ jym=int(ytra1(numpart+jj))
+ ixp=ixm+1
+ jyp=jym+1
+ ddx=xtra1(numpart+jj)-real(ixm)
+ ddy=ytra1(numpart+jj)-real(jym)
+ rddx=1.-ddx
+ rddy=1.-ddy
+ p1=rddx*rddy
+ p2=ddx*rddy
+ p3=rddx*ddy
+ p4=ddx*ddy
+ do i=2,nz
+ if (height(i).gt.ztra1(numpart+jj)) then
+ indzm=i-1
+ indzp=i
+ goto 6
+ endif
+ end do
+6 continue
+ dz1=ztra1(numpart+jj)-height(indzm)
+ dz2=height(indzp)-ztra1(numpart+jj)
+ dz=1./(dz1+dz2)
+ do in=1,2
+ indzh=indzm+in-1
+ y1(in)=p1*pv(ixm,jym,indzh,1) &
+ +p2*pv(ixp,jym,indzh,1) &
+ +p3*pv(ixm,jyp,indzh,1) &
+ +p4*pv(ixp,jyp,indzh,1)
+ end do
+ pvpart=(dz2*y1(1)+dz1*y1(2))*dz
+ if (ylat.lt.0.) pvpart=-1.*pvpart
+
+
+ ! For domain-filling option 2 (stratospheric O3), do the rest only in the stratosphere
+ !*****************************************************************************
+
+ if (((ztra1(numpart+jj).gt.3000.).and. &
+ (pvpart.gt.pvcrit)).or.(mdomainfill.eq.1)) then
+
+ ! Assign certain properties to the particle
+ !******************************************
+ nclass(numpart+jj)=min(int(ran1(idummy)* &
+ real(nclassunc))+1,nclassunc)
+ numparticlecount=numparticlecount+1
+ npoint(numpart+jj)=numparticlecount
+ idt(numpart+jj)=mintime
+ itra1(numpart+jj)=0
+ itramem(numpart+jj)=0
+ itrasplit(numpart+jj)=itra1(numpart+jj)+ldirect* &
+ itsplit
+ xmass1(numpart+jj,1)=colmass(ix,jy)/real(ncolumn)
+ if (mdomainfill.eq.2) xmass1(numpart+jj,1)= &
+ xmass1(numpart+jj,1)*pvpart*48./29.*ozonescale/10.**9
+ else
+ jj=jj-1
+ endif
+ endif
+ endif
+ end do
+ end do
+ numparttot=numparttot+ncolumn
+ if (ipin.eq.0) numpart=numpart+jj
+30 continue
+ end do
+ end do
+
+
+ ! Check whether numpart is really smaller than maxpart
+ !*****************************************************
+
+ if (numpart.gt.maxpart) then
+ write(*,*) 'numpart too large: change source in init_atm_mass.f'
+ write(*,*) 'numpart: ',numpart,' maxpart: ',maxpart
+ endif
+
+
+ xmassperparticle=colmasstotal/real(numparttot)
+
+
+ ! Make sure that all particles are within domain
+ !***********************************************
+
+ do j=1,numpart
+ if ((xtra1(j).lt.0.).or.(xtra1(j).ge.real(nxmin1)).or. &
+ (ytra1(j).lt.0.).or.(ytra1(j).ge.real(nymin1))) then
+ itra1(j)=-999999999
+ endif
+ end do
+
+
+
+
+ ! For boundary conditions, we need fewer particle release heights per column,
+ ! because otherwise it takes too long until enough mass has accumulated to
+ ! release a particle at the boundary (would take dx/u seconds), leading to
+ ! relatively large position errors of the order of one grid distance.
+ ! It's better to release fewer particles per column, but to do so more often.
+ ! Thus, use on the order of nz starting heights per column.
+ ! We thus repeat the above to determine fewer starting heights, that are
+ ! used furtheron in subroutine boundcond_domainfill.f.
+ !****************************************************************************
+
+ fractus=real(numcolumn)/real(nz)
+ write(*,*) 'Total number of particles at model start: ',numpart
+ write(*,*) 'Maximum number of particles per column: ',numcolumn
+ write(*,*) 'If ',fractus,' <1, better use more particles'
+ fractus=sqrt(max(fractus,1.))/2.
+
+ do jy=ny_sn(1),ny_sn(2) ! loop about latitudes
+ do ix=nx_we(1),nx_we(2) ! loop about longitudes
+ ncolumn=nint(0.999/fractus*real(npart(1))*colmass(ix,jy) &
+ /colmasstotal)
+ if (ncolumn.gt.maxcolumn) stop 'maxcolumn too small'
+ if (ncolumn.eq.0) goto 80
+
+
+ ! Memorize how many particles per column shall be used for all boundaries
+ ! This is further used in subroutine boundcond_domainfill.f
+ ! Use 2 fields for west/east and south/north boundary
+ !************************************************************************
+
+ if (ix.eq.nx_we(1)) numcolumn_we(1,jy)=ncolumn
+ if (ix.eq.nx_we(2)) numcolumn_we(2,jy)=ncolumn
+ if (jy.eq.ny_sn(1)) numcolumn_sn(1,ix)=ncolumn
+ if (jy.eq.ny_sn(2)) numcolumn_sn(2,ix)=ncolumn
+
+ ! Calculate pressure at the altitudes of model surfaces, using the air density
+ ! information, which is stored as a 3-d field
+ !*****************************************************************************
+
+ do kz=1,nz
+ pp(kz)=rho(ix,jy,kz,1)*r_air*tt(ix,jy,kz,1)
+ end do
+
+ ! Determine the reference starting altitudes
+ !*******************************************
+
+ deltacol=(pp(1)-pp(nz))/real(ncolumn)
+ pnew=pp(1)+deltacol/2.
+ do j=1,ncolumn
+ pnew=pnew-deltacol
+ do kz=1,nz-1
+ if ((pp(kz).ge.pnew).and.(pp(kz+1).lt.pnew)) then
+ dz1=pp(kz)-pnew
+ dz2=pnew-pp(kz+1)
+ dz=1./(dz1+dz2)
+ zposition=(height(kz)*dz2+height(kz+1)*dz1)*dz
+ if (zposition.gt.height(nz)-0.5) zposition=height(nz)-0.5
+
+ ! Memorize vertical positions where particles are introduced
+ ! This is further used in subroutine boundcond_domainfill.f
+ !***********************************************************
+
+ if (ix.eq.nx_we(1)) zcolumn_we(1,jy,j)=zposition
+ if (ix.eq.nx_we(2)) zcolumn_we(2,jy,j)=zposition
+ if (jy.eq.ny_sn(1)) zcolumn_sn(1,ix,j)=zposition
+ if (jy.eq.ny_sn(2)) zcolumn_sn(2,ix,j)=zposition
+
+ ! Initialize mass that has accumulated at boundary to zero
+ !*********************************************************
+
+ acc_mass_we(1,jy,j)=0.
+ acc_mass_we(2,jy,j)=0.
+ acc_mass_sn(1,jy,j)=0.
+ acc_mass_sn(2,jy,j)=0.
+ endif
+ end do
+ end do
+80 continue
+ end do
+ end do
+
+ ! If particles shall be read in to continue an existing run,
+ ! then the accumulated masses at the domain boundaries must be read in, too.
+ ! This overrides any previous calculations.
+ !***************************************************************************
+
+ if (ipin.eq.1) then
+ open(unitboundcond,file=path(2)(1:length(2))//'boundcond.bin', &
+ form='unformatted')
+ read(unitboundcond) numcolumn_we,numcolumn_sn, &
+ zcolumn_we,zcolumn_sn,acc_mass_we,acc_mass_sn
+ close(unitboundcond)
+ endif
+
+
+
+
+end subroutine init_domainfill
diff --git a/src/initial_cond_calc.f90 b/src/initial_cond_calc.f90
new file mode 100644
index 0000000000000000000000000000000000000000..b14a85fb0f8fd6f28f3dee1515485a7e4735bdf1
--- /dev/null
+++ b/src/initial_cond_calc.f90
@@ -0,0 +1,213 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine initial_cond_calc(itime,i)
+ ! i i
+ !*****************************************************************************
+ ! *
+ ! Calculation of the sensitivity to initial conditions for BW runs *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 15 January 2010 *
+ ! *
+ !*****************************************************************************
+
+ use unc_mod
+ use outg_mod
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: itime,i,ix,jy,ixp,jyp,kz,ks
+ integer :: il,ind,indz,indzp,nrelpointer
+ real :: rddx,rddy,p1,p2,p3,p4,dz1,dz2,dz
+ real :: ddx,ddy
+ real :: rhoprof(2),rhoi,xl,yl,wx,wy,w
+
+
+ ! For forward simulations, make a loop over the number of species;
+ ! for backward simulations, make an additional loop over the release points
+ !**************************************************************************
+
+
+ if (itra1(i).ne.itime) return
+
+ ! Depending on output option, calculate air density or set it to 1
+ ! linit_cond: 1=mass unit, 2=mass mixing ratio unit
+ !*****************************************************************
+
+
+ if (linit_cond.eq.1) then ! mass unit
+
+ ix=int(xtra1(i))
+ jy=int(ytra1(i))
+ ixp=ix+1
+ jyp=jy+1
+ ddx=xtra1(i)-real(ix)
+ ddy=ytra1(i)-real(jy)
+ rddx=1.-ddx
+ rddy=1.-ddy
+ p1=rddx*rddy
+ p2=ddx*rddy
+ p3=rddx*ddy
+ p4=ddx*ddy
+
+ do il=2,nz
+ if (height(il).gt.ztra1(i)) then
+ indz=il-1
+ indzp=il
+ goto 6
+ endif
+ end do
+6 continue
+
+ dz1=ztra1(i)-height(indz)
+ dz2=height(indzp)-ztra1(i)
+ dz=1./(dz1+dz2)
+
+ ! Take density from 2nd wind field in memory (accurate enough, no time interpolation needed)
+ !*****************************************************************************
+ do ind=indz,indzp
+ rhoprof(ind-indz+1)=p1*rho(ix ,jy ,ind,2) &
+ +p2*rho(ixp,jy ,ind,2) &
+ +p3*rho(ix ,jyp,ind,2) &
+ +p4*rho(ixp,jyp,ind,2)
+ end do
+ rhoi=(dz1*rhoprof(2)+dz2*rhoprof(1))*dz
+ elseif (linit_cond.eq.2) then ! mass mixing ratio unit
+ rhoi=1.
+ endif
+
+
+ !****************************************************************************
+ ! 1. Evaluate grid concentrations using a uniform kernel of bandwidths dx, dy
+ !****************************************************************************
+
+
+ ! For backward simulations, look from which release point the particle comes from
+ ! For domain-filling trajectory option, npoint contains a consecutive particle
+ ! number, not the release point information. Therefore, nrelpointer is set to 1
+ ! for the domain-filling option.
+ !*****************************************************************************
+
+ if ((ioutputforeachrelease.eq.0).or.(mdomainfill.eq.1)) then
+ nrelpointer=1
+ else
+ nrelpointer=npoint(i)
+ endif
+
+ do kz=1,numzgrid ! determine height of cell
+ if (outheight(kz).gt.ztra1(i)) goto 21
+ end do
+21 continue
+ if (kz.le.numzgrid) then ! inside output domain
+
+
+ xl=(xtra1(i)*dx+xoutshift)/dxout
+ yl=(ytra1(i)*dy+youtshift)/dyout
+ ix=int(xl)
+ if (xl.lt.0.) ix=ix-1
+ jy=int(yl)
+ if (yl.lt.0.) jy=jy-1
+
+
+ ! If a particle is close to the domain boundary, do not use the kernel either
+ !****************************************************************************
+
+ if ((xl.lt.0.5).or.(yl.lt.0.5).or. &
+ (xl.gt.real(numxgrid-1)-0.5).or. &
+ (yl.gt.real(numygrid-1)-0.5)) then ! no kernel, direct attribution to grid cell
+ if ((ix.ge.0).and.(jy.ge.0).and.(ix.le.numxgrid-1).and. &
+ (jy.le.numygrid-1)) then
+ do ks=1,nspec
+ init_cond(ix,jy,kz,ks,nrelpointer)= &
+ init_cond(ix,jy,kz,ks,nrelpointer)+ &
+ xmass1(i,ks)/rhoi
+ end do
+ endif
+
+ else ! attribution via uniform kernel
+
+ ddx=xl-real(ix) ! distance to left cell border
+ ddy=yl-real(jy) ! distance to lower cell border
+ if (ddx.gt.0.5) then
+ ixp=ix+1
+ wx=1.5-ddx
+ else
+ ixp=ix-1
+ wx=0.5+ddx
+ endif
+
+ if (ddy.gt.0.5) then
+ jyp=jy+1
+ wy=1.5-ddy
+ else
+ jyp=jy-1
+ wy=0.5+ddy
+ endif
+
+
+ ! Determine mass fractions for four grid points
+ !**********************************************
+
+ if ((ix.ge.0).and.(ix.le.numxgrid-1)) then
+ if ((jy.ge.0).and.(jy.le.numygrid-1)) then
+ w=wx*wy
+ do ks=1,nspec
+ init_cond(ix,jy,kz,ks,nrelpointer)= &
+ init_cond(ix,jy,kz,ks,nrelpointer)+xmass1(i,ks)/rhoi*w
+ end do
+ endif
+
+ if ((jyp.ge.0).and.(jyp.le.numygrid-1)) then
+ w=wx*(1.-wy)
+ do ks=1,nspec
+ init_cond(ix,jyp,kz,ks,nrelpointer)= &
+ init_cond(ix,jyp,kz,ks,nrelpointer)+xmass1(i,ks)/rhoi*w
+ end do
+ endif
+ endif
+
+
+ if ((ixp.ge.0).and.(ixp.le.numxgrid-1)) then
+ if ((jyp.ge.0).and.(jyp.le.numygrid-1)) then
+ w=(1.-wx)*(1.-wy)
+ do ks=1,nspec
+ init_cond(ixp,jyp,kz,ks,nrelpointer)= &
+ init_cond(ixp,jyp,kz,ks,nrelpointer)+xmass1(i,ks)/rhoi*w
+ end do
+ endif
+
+ if ((jy.ge.0).and.(jy.le.numygrid-1)) then
+ w=(1.-wx)*wy
+ do ks=1,nspec
+ init_cond(ixp,jy,kz,ks,nrelpointer)= &
+ init_cond(ixp,jy,kz,ks,nrelpointer)+xmass1(i,ks)/rhoi*w
+ end do
+ endif
+ endif
+ endif
+
+ endif
+
+end subroutine initial_cond_calc
diff --git a/src/initial_cond_output.f90 b/src/initial_cond_output.f90
new file mode 100644
index 0000000000000000000000000000000000000000..2dc9a2ca86fb7a3281c94ecdb93d265db290d911
--- /dev/null
+++ b/src/initial_cond_output.f90
@@ -0,0 +1,151 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine initial_cond_output(itime)
+ ! i
+ !*****************************************************************************
+ ! *
+ ! Output of the initial condition sensitivity field. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 24 May 1995 *
+ ! *
+ ! 13 April 1999, Major update: if output size is smaller, dump output *
+ ! in sparse matrix format; additional output of *
+ ! uncertainty *
+ ! *
+ ! 05 April 2000, Major update: output of age classes; output for backward*
+ ! runs is time spent in grid cell times total mass of *
+ ! species. *
+ ! *
+ ! 17 February 2002, Appropriate dimensions for backward and forward runs *
+ ! are now specified in file par_mod *
+ ! *
+ ! June 2006, write grid in sparse matrix with a single write command *
+ ! in order to save disk space *
+ ! *
+ ! 2008 new sparse matrix format *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! ncells number of cells with non-zero concentrations *
+ ! sparse .true. if in sparse matrix format, else .false. *
+ ! *
+ !*****************************************************************************
+
+ use unc_mod
+ use point_mod
+ use outg_mod
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: itime,i,ix,jy,kz,ks,kp,sp_count_i,sp_count_r
+ real :: sp_fact,fact_recept
+ real,parameter :: smallnum = tiny(0.0) ! smallest number that can be handled
+ logical :: sp_zer
+ character(len=3) :: anspec
+
+
+ !*********************************************************************
+ ! Determine the standard deviation of the mean concentration or mixing
+ ! ratio (uncertainty of the output) and the dry and wet deposition
+ !*********************************************************************
+
+ do ks=1,nspec
+
+ write(anspec,'(i3.3)') ks
+ open(97,file=path(2)(1:length(2))//'grid_initial'// &
+ '_'//anspec,form='unformatted')
+ write(97) itime
+
+ do kp=1,maxpointspec_act
+
+ if (ind_rel.eq.1) then
+ fact_recept=rho_rel(kp)
+ else
+ fact_recept=1.
+ endif
+
+ !*******************************************************************
+ ! Generate output: may be in concentration (ng/m3) or in mixing
+ ! ratio (ppt) or both
+ ! Output the position and the values alternated multiplied by
+ ! 1 or -1, first line is number of values, number of positions
+ ! For backward simulations, the unit is seconds, stored in grid_time
+ !*******************************************************************
+
+ ! Write out dummy "wet and dry deposition" fields, to keep same format
+ ! as for concentration output
+ sp_count_i=0
+ sp_count_r=0
+ write(97) sp_count_i
+ write(97) (sparse_dump_i(i),i=1,sp_count_i)
+ write(97) sp_count_r
+ write(97) (sparse_dump_r(i),i=1,sp_count_r)
+ write(97) sp_count_i
+ write(97) (sparse_dump_i(i),i=1,sp_count_i)
+ write(97) sp_count_r
+ write(97) (sparse_dump_r(i),i=1,sp_count_r)
+
+
+ ! Write out sensitivity to initial conditions
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ do kz=1,numzgrid
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (init_cond(ix,jy,kz,ks,kp).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgrid+kz*numxgrid*numygrid
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)=sp_fact* &
+ init_cond(ix,jy,kz,ks,kp)/xmass(kp,ks)*fact_recept
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ end do
+ write(97) sp_count_i
+ write(97) (sparse_dump_i(i),i=1,sp_count_i)
+ write(97) sp_count_r
+ write(97) (sparse_dump_r(i),i=1,sp_count_r)
+
+
+ end do
+
+ close(97)
+
+ end do
+
+
+end subroutine initial_cond_output
diff --git a/src/initialize.f90 b/src/initialize.f90
new file mode 100644
index 0000000000000000000000000000000000000000..dbb30625d6f4a7fbdc5bbfe705a5bb087d83ec80
--- /dev/null
+++ b/src/initialize.f90
@@ -0,0 +1,226 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine initialize(itime,ldt,up,vp,wp, &
+ usigold,vsigold,wsigold,xt,yt,zt,icbt)
+ ! i i o o o
+ ! o o o i i i o
+ !*****************************************************************************
+ ! *
+ ! Calculation of trajectories utilizing a zero-acceleration scheme. The time*
+ ! step is determined by the Courant-Friedrichs-Lewy (CFL) criterion. This *
+ ! means that the time step must be so small that the displacement within *
+ ! this time step is smaller than 1 grid distance. Additionally, a temporal *
+ ! CFL criterion is introduced: the time step must be smaller than the time *
+ ! interval of the wind fields used for interpolation. *
+ ! For random walk simulations, these are the only time step criteria. *
+ ! For the other options, the time step is also limited by the Lagrangian *
+ ! time scale. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 16 December 1997 *
+ ! *
+ ! Literature: *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! h [m] Mixing height *
+ ! lwindinterv [s] time interval between two wind fields *
+ ! itime [s] current temporal position *
+ ! ldt [s] Suggested time step for next integration *
+ ! ladvance [s] Total integration time period *
+ ! rannumb(maxrand) normally distributed random variables *
+ ! up,vp,wp random velocities due to turbulence *
+ ! usig,vsig,wsig uncertainties of wind velocities due to interpolation *
+ ! usigold,vsigold,wsigold like usig, etc., but for the last time step *
+ ! xt,yt,zt Next time step's spatial position of trajectory *
+ ! *
+ ! *
+ ! Constants: *
+ ! cfl factor, by which the time step has to be smaller than *
+ ! the spatial CFL-criterion *
+ ! cflt factor, by which the time step has to be smaller than *
+ ! the temporal CFL-criterion *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+ use interpol_mod
+ use hanna_mod
+
+ implicit none
+
+ integer :: itime
+ integer :: ldt,nrand
+ integer(kind=2) :: icbt
+ real :: zt,dz,dz1,dz2,up,vp,wp,usigold,vsigold,wsigold,ran3
+ real(kind=dp) :: xt,yt
+ save idummy
+
+ integer :: idummy = -7
+
+ icbt=1 ! initialize particle to "no reflection"
+
+ nrand=int(ran3(idummy)*real(maxrand-1))+1
+
+
+ !******************************
+ ! 2. Interpolate necessary data
+ !******************************
+
+ ! Compute maximum mixing height around particle position
+ !*******************************************************
+
+ ix=int(xt)
+ jy=int(yt)
+ ixp=ix+1
+ jyp=jy+1
+
+ h=max(hmix(ix ,jy ,1,memind(1)), &
+ hmix(ixp,jy ,1,memind(1)), &
+ hmix(ix ,jyp,1,memind(1)), &
+ hmix(ixp,jyp,1,memind(1)), &
+ hmix(ix ,jy ,1,memind(2)), &
+ hmix(ixp,jy ,1,memind(2)), &
+ hmix(ix ,jyp,1,memind(2)), &
+ hmix(ixp,jyp,1,memind(2)))
+
+ zeta=zt/h
+
+
+ !*************************************************************
+ ! If particle is in the PBL, interpolate once and then make a
+ ! time loop until end of interval is reached
+ !*************************************************************
+
+ if (zeta.le.1.) then
+
+ call interpol_all(itime,real(xt),real(yt),zt)
+
+
+ ! Vertical interpolation of u,v,w,rho and drhodz
+ !***********************************************
+
+ ! Vertical distance to the level below and above current position
+ ! both in terms of (u,v) and (w) fields
+ !****************************************************************
+
+ dz1=zt-height(indz)
+ dz2=height(indzp)-zt
+ dz=1./(dz1+dz2)
+
+ u=(dz1*uprof(indzp)+dz2*uprof(indz))*dz
+ v=(dz1*vprof(indzp)+dz2*vprof(indz))*dz
+ w=(dz1*wprof(indzp)+dz2*wprof(indz))*dz
+
+
+ ! Compute the turbulent disturbances
+
+ ! Determine the sigmas and the timescales
+ !****************************************
+
+ if (turbswitch) then
+ call hanna(zt)
+ else
+ call hanna1(zt)
+ endif
+
+
+ ! Determine the new diffusivity velocities
+ !*****************************************
+
+ if (nrand+2.gt.maxrand) nrand=1
+ up=rannumb(nrand)*sigu
+ vp=rannumb(nrand+1)*sigv
+ wp=rannumb(nrand+2)
+ if (.not.turbswitch) wp=wp*sigw
+
+
+ ! Determine time step for next integration
+ !*****************************************
+
+ if (turbswitch) then
+ ldt=int(min(tlw,h/max(2.*abs(wp*sigw),1.e-5), &
+ 0.5/abs(dsigwdz),600.)*ctl)
+ else
+ ldt=int(min(tlw,h/max(2.*abs(wp),1.e-5),600.)*ctl)
+ endif
+ ldt=max(ldt,mintime)
+
+
+ usig=(usigprof(indzp)+usigprof(indz))/2.
+ vsig=(vsigprof(indzp)+vsigprof(indz))/2.
+ wsig=(wsigprof(indzp)+wsigprof(indz))/2.
+
+ else
+
+
+
+ !**********************************************************
+ ! For all particles that are outside the PBL, make a single
+ ! time step. Only horizontal turbulent disturbances are
+ ! calculated. Vertical disturbances are reset.
+ !**********************************************************
+
+
+ ! Interpolate the wind
+ !*********************
+
+ call interpol_wind(itime,real(xt),real(yt),zt)
+
+
+ ! Compute everything for above the PBL
+
+ ! Assume constant turbulent perturbations
+ !****************************************
+
+ ldt=abs(lsynctime)
+
+ if (nrand+1.gt.maxrand) nrand=1
+ up=rannumb(nrand)*0.3
+ vp=rannumb(nrand+1)*0.3
+ nrand=nrand+2
+ wp=0.
+ sigw=0.
+
+ endif
+
+ !****************************************************************
+ ! Add mesoscale random disturbances
+ ! This is done only once for the whole lsynctime interval to save
+ ! computation time
+ !****************************************************************
+
+
+ ! It is assumed that the average interpolation error is 1/2 sigma
+ ! of the surrounding points, autocorrelation time constant is
+ ! 1/2 of time interval between wind fields
+ !****************************************************************
+
+ if (nrand+2.gt.maxrand) nrand=1
+ usigold=rannumb(nrand)*usig
+ vsigold=rannumb(nrand+1)*vsig
+ wsigold=rannumb(nrand+2)*wsig
+
+end subroutine initialize
diff --git a/src/interpol_all.f90 b/src/interpol_all.f90
new file mode 100644
index 0000000000000000000000000000000000000000..ffcc0216a1aa213f7d007b16d725d8939143c068
--- /dev/null
+++ b/src/interpol_all.f90
@@ -0,0 +1,261 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine interpol_all(itime,xt,yt,zt)
+ ! i i i i
+ !*****************************************************************************
+ ! *
+ ! This subroutine interpolates everything that is needed for calculating the*
+ ! dispersion. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 16 December 1997 *
+ ! *
+ ! Revision March 2005 by AST : all output variables in common block cal- *
+ ! culation of standard deviation done in this *
+ ! routine rather than subroutine call in order *
+ ! to save computation time *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! itime [s] current temporal position *
+ ! memtime(3) [s] times of the wind fields in memory *
+ ! xt,yt,zt coordinates position for which wind data shall be *
+ ! culated *
+ ! *
+ ! Constants: *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+ use interpol_mod
+ use hanna_mod
+
+ implicit none
+
+ integer :: itime
+ real :: xt,yt,zt
+
+ ! Auxiliary variables needed for interpolation
+ real :: ust1(2),wst1(2),oli1(2),oliaux
+ real :: y1(2),y2(2),y3(2),rho1(2),rhograd1(2)
+ real :: usl,vsl,wsl,usq,vsq,wsq,xaux
+ integer :: i,m,n,indexh
+ real,parameter :: eps=1.0e-30
+
+
+ !********************************************
+ ! Multilinear interpolation in time and space
+ !********************************************
+
+ ! Determine the lower left corner and its distance to the current position
+ !*************************************************************************
+
+ ddx=xt-real(ix)
+ ddy=yt-real(jy)
+ rddx=1.-ddx
+ rddy=1.-ddy
+ p1=rddx*rddy
+ p2=ddx*rddy
+ p3=rddx*ddy
+ p4=ddx*ddy
+
+ ! Calculate variables for time interpolation
+ !*******************************************
+
+ dt1=real(itime-memtime(1))
+ dt2=real(memtime(2)-itime)
+ dtt=1./(dt1+dt2)
+
+
+ !*****************************************
+ ! 1. Interpolate u*, w* and Obukhov length
+ !*****************************************
+
+ ! a) Bilinear horizontal interpolation
+
+ do m=1,2
+ indexh=memind(m)
+
+ ust1(m)=p1*ustar(ix ,jy ,1,indexh) &
+ + p2*ustar(ixp,jy ,1,indexh) &
+ + p3*ustar(ix ,jyp,1,indexh) &
+ + p4*ustar(ixp,jyp,1,indexh)
+ wst1(m)=p1*wstar(ix ,jy ,1,indexh) &
+ + p2*wstar(ixp,jy ,1,indexh) &
+ + p3*wstar(ix ,jyp,1,indexh) &
+ + p4*wstar(ixp,jyp,1,indexh)
+ oli1(m)=p1*oli(ix ,jy ,1,indexh) &
+ + p2*oli(ixp,jy ,1,indexh) &
+ + p3*oli(ix ,jyp,1,indexh) &
+ + p4*oli(ixp,jyp,1,indexh)
+ end do
+
+ ! b) Temporal interpolation
+
+ ust=(ust1(1)*dt2+ust1(2)*dt1)*dtt
+ wst=(wst1(1)*dt2+wst1(2)*dt1)*dtt
+ oliaux=(oli1(1)*dt2+oli1(2)*dt1)*dtt
+
+ if (oliaux.ne.0.) then
+ ol=1./oliaux
+ else
+ ol=99999.
+ endif
+
+
+ !*****************************************************
+ ! 2. Interpolate vertical profiles of u,v,w,rho,drhodz
+ !*****************************************************
+
+
+ ! Determine the level below the current position
+ !***********************************************
+
+ do i=2,nz
+ if (height(i).gt.zt) then
+ indz=i-1
+ indzp=i
+ goto 6
+ endif
+ end do
+6 continue
+
+ !**************************************
+ ! 1.) Bilinear horizontal interpolation
+ ! 2.) Temporal interpolation (linear)
+ !**************************************
+
+ ! Loop over 2 time steps and indz levels
+ !***************************************
+
+ do n=indz,indzp
+ usl=0.
+ vsl=0.
+ wsl=0.
+ usq=0.
+ vsq=0.
+ wsq=0.
+ do m=1,2
+ indexh=memind(m)
+ if (ngrid.lt.0) then
+ y1(m)=p1*uupol(ix ,jy ,n,indexh) &
+ +p2*uupol(ixp,jy ,n,indexh) &
+ +p3*uupol(ix ,jyp,n,indexh) &
+ +p4*uupol(ixp,jyp,n,indexh)
+ y2(m)=p1*vvpol(ix ,jy ,n,indexh) &
+ +p2*vvpol(ixp,jy ,n,indexh) &
+ +p3*vvpol(ix ,jyp,n,indexh) &
+ +p4*vvpol(ixp,jyp,n,indexh)
+ usl=usl+uupol(ix ,jy ,n,indexh)+uupol(ixp,jy ,n,indexh) &
+ +uupol(ix ,jyp,n,indexh)+uupol(ixp,jyp,n,indexh)
+ vsl=vsl+vvpol(ix ,jy ,n,indexh)+vvpol(ixp,jy ,n,indexh) &
+ +vvpol(ix ,jyp,n,indexh)+vvpol(ixp,jyp,n,indexh)
+
+ usq=usq+uupol(ix ,jy ,n,indexh)*uupol(ix ,jy ,n,indexh)+ &
+ uupol(ixp,jy ,n,indexh)*uupol(ixp,jy ,n,indexh)+ &
+ uupol(ix ,jyp,n,indexh)*uupol(ix ,jyp,n,indexh)+ &
+ uupol(ixp,jyp,n,indexh)*uupol(ixp,jyp,n,indexh)
+ vsq=vsq+vvpol(ix ,jy ,n,indexh)*vvpol(ix ,jy ,n,indexh)+ &
+ vvpol(ixp,jy ,n,indexh)*vvpol(ixp,jy ,n,indexh)+ &
+ vvpol(ix ,jyp,n,indexh)*vvpol(ix ,jyp,n,indexh)+ &
+ vvpol(ixp,jyp,n,indexh)*vvpol(ixp,jyp,n,indexh)
+ else
+ y1(m)=p1*uu(ix ,jy ,n,indexh) &
+ +p2*uu(ixp,jy ,n,indexh) &
+ +p3*uu(ix ,jyp,n,indexh) &
+ +p4*uu(ixp,jyp,n,indexh)
+ y2(m)=p1*vv(ix ,jy ,n,indexh) &
+ +p2*vv(ixp,jy ,n,indexh) &
+ +p3*vv(ix ,jyp,n,indexh) &
+ +p4*vv(ixp,jyp,n,indexh)
+ usl=usl+uu(ix ,jy ,n,indexh)+uu(ixp,jy ,n,indexh) &
+ +uu(ix ,jyp,n,indexh)+uu(ixp,jyp,n,indexh)
+ vsl=vsl+vv(ix ,jy ,n,indexh)+vv(ixp,jy ,n,indexh) &
+ +vv(ix ,jyp,n,indexh)+vv(ixp,jyp,n,indexh)
+
+ usq=usq+uu(ix ,jy ,n,indexh)*uu(ix ,jy ,n,indexh)+ &
+ uu(ixp,jy ,n,indexh)*uu(ixp,jy ,n,indexh)+ &
+ uu(ix ,jyp,n,indexh)*uu(ix ,jyp,n,indexh)+ &
+ uu(ixp,jyp,n,indexh)*uu(ixp,jyp,n,indexh)
+ vsq=vsq+vv(ix ,jy ,n,indexh)*vv(ix ,jy ,n,indexh)+ &
+ vv(ixp,jy ,n,indexh)*vv(ixp,jy ,n,indexh)+ &
+ vv(ix ,jyp,n,indexh)*vv(ix ,jyp,n,indexh)+ &
+ vv(ixp,jyp,n,indexh)*vv(ixp,jyp,n,indexh)
+ endif
+ y3(m)=p1*ww(ix ,jy ,n,indexh) &
+ +p2*ww(ixp,jy ,n,indexh) &
+ +p3*ww(ix ,jyp,n,indexh) &
+ +p4*ww(ixp,jyp,n,indexh)
+ rhograd1(m)=p1*drhodz(ix ,jy ,n,indexh) &
+ +p2*drhodz(ixp,jy ,n,indexh) &
+ +p3*drhodz(ix ,jyp,n,indexh) &
+ +p4*drhodz(ixp,jyp,n,indexh)
+ rho1(m)=p1*rho(ix ,jy ,n,indexh) &
+ +p2*rho(ixp,jy ,n,indexh) &
+ +p3*rho(ix ,jyp,n,indexh) &
+ +p4*rho(ixp,jyp,n,indexh)
+ wsl=wsl+ww(ix ,jy ,n,indexh)+ww(ixp,jy ,n,indexh) &
+ +ww(ix ,jyp,n,indexh)+ww(ixp,jyp,n,indexh)
+ wsq=wsq+ww(ix ,jy ,n,indexh)*ww(ix ,jy ,n,indexh)+ &
+ ww(ixp,jy ,n,indexh)*ww(ixp,jy ,n,indexh)+ &
+ ww(ix ,jyp,n,indexh)*ww(ix ,jyp,n,indexh)+ &
+ ww(ixp,jyp,n,indexh)*ww(ixp,jyp,n,indexh)
+ end do
+ uprof(n)=(y1(1)*dt2+y1(2)*dt1)*dtt
+ vprof(n)=(y2(1)*dt2+y2(2)*dt1)*dtt
+ wprof(n)=(y3(1)*dt2+y3(2)*dt1)*dtt
+ rhoprof(n)=(rho1(1)*dt2+rho1(2)*dt1)*dtt
+ rhogradprof(n)=(rhograd1(1)*dt2+rhograd1(2)*dt1)*dtt
+ indzindicator(n)=.false.
+
+ ! Compute standard deviations
+ !****************************
+
+ xaux=usq-usl*usl/8.
+ if (xaux.lt.eps) then
+ usigprof(n)=0.
+ else
+ usigprof(n)=sqrt(xaux/7.)
+ endif
+
+ xaux=vsq-vsl*vsl/8.
+ if (xaux.lt.eps) then
+ vsigprof(n)=0.
+ else
+ vsigprof(n)=sqrt(xaux/7.)
+ endif
+
+
+ xaux=wsq-wsl*wsl/8.
+ if (xaux.lt.eps) then
+ wsigprof(n)=0.
+ else
+ wsigprof(n)=sqrt(xaux/7.)
+ endif
+
+ end do
+
+
+end subroutine interpol_all
diff --git a/src/interpol_all_nests.f90 b/src/interpol_all_nests.f90
new file mode 100644
index 0000000000000000000000000000000000000000..b5852abc9e102b5f332c8f5d503a23c6268a41b5
--- /dev/null
+++ b/src/interpol_all_nests.f90
@@ -0,0 +1,239 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine interpol_all_nests(itime,xt,yt,zt)
+ ! i i i i
+ !*****************************************************************************
+ ! *
+ ! This subroutine interpolates everything that is needed for calculating the*
+ ! dispersion. *
+ ! Version for interpolating nested grids. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 9 February 1999 *
+ ! 16 December 1997 *
+ ! *
+ ! Revision March 2005 by AST : all output variables in common block cal- *
+ ! culation of standard deviation done in this *
+ ! routine rather than subroutine call in order *
+ ! to save computation time *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! itime [s] current temporal position *
+ ! memtime(3) [s] times of the wind fields in memory *
+ ! xt,yt,zt coordinates position for which wind data shall be *
+ ! calculated *
+ ! *
+ ! Constants: *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+ use interpol_mod
+ use hanna_mod
+
+ implicit none
+
+ integer :: itime
+ real :: xt,yt,zt
+
+ ! Auxiliary variables needed for interpolation
+ real :: ust1(2),wst1(2),oli1(2),oliaux
+ real :: y1(2),y2(2),y3(2),rho1(2),rhograd1(2)
+ real :: usl,vsl,wsl,usq,vsq,wsq,xaux
+ integer :: i,m,n,indexh
+ real,parameter :: eps=1.0e-30
+
+
+ !********************************************
+ ! Multilinear interpolation in time and space
+ !********************************************
+
+ ! Determine the lower left corner and its distance to the current position
+ !*************************************************************************
+
+ ddx=xt-real(ix)
+ ddy=yt-real(jy)
+ rddx=1.-ddx
+ rddy=1.-ddy
+ p1=rddx*rddy
+ p2=ddx*rddy
+ p3=rddx*ddy
+ p4=ddx*ddy
+
+ ! Calculate variables for time interpolation
+ !*******************************************
+
+ dt1=real(itime-memtime(1))
+ dt2=real(memtime(2)-itime)
+ dtt=1./(dt1+dt2)
+
+
+ !*****************************************
+ ! 1. Interpolate u*, w* and Obukhov length
+ !*****************************************
+
+ ! a) Bilinear horizontal interpolation
+
+ do m=1,2
+ indexh=memind(m)
+
+ ust1(m)=p1*ustarn(ix ,jy ,1,indexh,ngrid) &
+ + p2*ustarn(ixp,jy ,1,indexh,ngrid) &
+ + p3*ustarn(ix ,jyp,1,indexh,ngrid) &
+ + p4*ustarn(ixp,jyp,1,indexh,ngrid)
+ wst1(m)=p1*wstarn(ix ,jy ,1,indexh,ngrid) &
+ + p2*wstarn(ixp,jy ,1,indexh,ngrid) &
+ + p3*wstarn(ix ,jyp,1,indexh,ngrid) &
+ + p4*wstarn(ixp,jyp,1,indexh,ngrid)
+ oli1(m)=p1*olin(ix ,jy ,1,indexh,ngrid) &
+ + p2*olin(ixp,jy ,1,indexh,ngrid) &
+ + p3*olin(ix ,jyp,1,indexh,ngrid) &
+ + p4*olin(ixp,jyp,1,indexh,ngrid)
+ end do
+
+ ! b) Temporal interpolation
+
+ ust=(ust1(1)*dt2+ust1(2)*dt1)*dtt
+ wst=(wst1(1)*dt2+wst1(2)*dt1)*dtt
+ oliaux=(oli1(1)*dt2+oli1(2)*dt1)*dtt
+
+ if (oliaux.ne.0.) then
+ ol=1./oliaux
+ else
+ ol=99999.
+ endif
+
+
+ !*****************************************************
+ ! 2. Interpolate vertical profiles of u,v,w,rho,drhodz
+ !*****************************************************
+
+
+ ! Determine the level below the current position
+ !***********************************************
+
+ do i=2,nz
+ if (height(i).gt.zt) then
+ indz=i-1
+ indzp=i
+ goto 6
+ endif
+ end do
+6 continue
+
+ !**************************************
+ ! 1.) Bilinear horizontal interpolation
+ ! 2.) Temporal interpolation (linear)
+ !**************************************
+
+ ! Loop over 2 time steps and indz levels
+ !***************************************
+
+ do n=indz,indz+1
+ usl=0.
+ vsl=0.
+ wsl=0.
+ usq=0.
+ vsq=0.
+ wsq=0.
+ do m=1,2
+ indexh=memind(m)
+ y1(m)=p1*uun(ix ,jy ,n,indexh,ngrid) &
+ +p2*uun(ixp,jy ,n,indexh,ngrid) &
+ +p3*uun(ix ,jyp,n,indexh,ngrid) &
+ +p4*uun(ixp,jyp,n,indexh,ngrid)
+ y2(m)=p1*vvn(ix ,jy ,n,indexh,ngrid) &
+ +p2*vvn(ixp,jy ,n,indexh,ngrid) &
+ +p3*vvn(ix ,jyp,n,indexh,ngrid) &
+ +p4*vvn(ixp,jyp,n,indexh,ngrid)
+ y3(m)=p1*wwn(ix ,jy ,n,indexh,ngrid) &
+ +p2*wwn(ixp,jy ,n,indexh,ngrid) &
+ +p3*wwn(ix ,jyp,n,indexh,ngrid) &
+ +p4*wwn(ixp,jyp,n,indexh,ngrid)
+ rhograd1(m)=p1*drhodzn(ix ,jy ,n,indexh,ngrid) &
+ +p2*drhodzn(ixp,jy ,n,indexh,ngrid) &
+ +p3*drhodzn(ix ,jyp,n,indexh,ngrid) &
+ +p4*drhodzn(ixp,jyp,n,indexh,ngrid)
+ rho1(m)=p1*rhon(ix ,jy ,n,indexh,ngrid) &
+ +p2*rhon(ixp,jy ,n,indexh,ngrid) &
+ +p3*rhon(ix ,jyp,n,indexh,ngrid) &
+ +p4*rhon(ixp,jyp,n,indexh,ngrid)
+
+ usl=usl+uun(ix ,jy ,n,indexh,ngrid)+uun(ixp,jy ,n,indexh,ngrid) &
+ +uun(ix ,jyp,n,indexh,ngrid)+uun(ixp,jyp,n,indexh,ngrid)
+ vsl=vsl+vvn(ix ,jy ,n,indexh,ngrid)+vvn(ixp,jy ,n,indexh,ngrid) &
+ +vvn(ix ,jyp,n,indexh,ngrid)+vvn(ixp,jyp,n,indexh,ngrid)
+ wsl=wsl+wwn(ix ,jy ,n,indexh,ngrid)+wwn(ixp,jy ,n,indexh,ngrid) &
+ +wwn(ix ,jyp,n,indexh,ngrid)+wwn(ixp,jyp,n,indexh,ngrid)
+
+ usq=usq+uun(ix ,jy ,n,indexh,ngrid)*uun(ix ,jy ,n,indexh,ngrid)+ &
+ uun(ixp,jy ,n,indexh,ngrid)*uun(ixp,jy ,n,indexh,ngrid)+ &
+ uun(ix ,jyp,n,indexh,ngrid)*uun(ix ,jyp,n,indexh,ngrid)+ &
+ uun(ixp,jyp,n,indexh,ngrid)*uun(ixp,jyp,n,indexh,ngrid)
+ vsq=vsq+vvn(ix ,jy ,n,indexh,ngrid)*vvn(ix ,jy ,n,indexh,ngrid)+ &
+ vvn(ixp,jy ,n,indexh,ngrid)*vvn(ixp,jy ,n,indexh,ngrid)+ &
+ vvn(ix ,jyp,n,indexh,ngrid)*vvn(ix ,jyp,n,indexh,ngrid)+ &
+ vvn(ixp,jyp,n,indexh,ngrid)*vvn(ixp,jyp,n,indexh,ngrid)
+ wsq=wsq+wwn(ix ,jy ,n,indexh,ngrid)*wwn(ix ,jy ,n,indexh,ngrid)+ &
+ wwn(ixp,jy ,n,indexh,ngrid)*wwn(ixp,jy ,n,indexh,ngrid)+ &
+ wwn(ix ,jyp,n,indexh,ngrid)*wwn(ix ,jyp,n,indexh,ngrid)+ &
+ wwn(ixp,jyp,n,indexh,ngrid)*wwn(ixp,jyp,n,indexh,ngrid)
+ end do
+ uprof(n)=(y1(1)*dt2+y1(2)*dt1)*dtt
+ vprof(n)=(y2(1)*dt2+y2(2)*dt1)*dtt
+ wprof(n)=(y3(1)*dt2+y3(2)*dt1)*dtt
+ rhoprof(n)=(rho1(1)*dt2+rho1(2)*dt1)*dtt
+ rhogradprof(n)=(rhograd1(1)*dt2+rhograd1(2)*dt1)*dtt
+ indzindicator(n)=.false.
+
+ ! Compute standard deviations
+ !****************************
+
+ xaux=usq-usl*usl/8.
+ if (xaux.lt.eps) then
+ usigprof(n)=0.
+ else
+ usigprof(n)=sqrt(xaux/7.)
+ endif
+
+ xaux=vsq-vsl*vsl/8.
+ if (xaux.lt.eps) then
+ vsigprof(n)=0.
+ else
+ vsigprof(n)=sqrt(xaux/7.)
+ endif
+
+
+ xaux=wsq-wsl*wsl/8.
+ if (xaux.lt.eps) then
+ wsigprof(n)=0.
+ else
+ wsigprof(n)=sqrt(xaux/7.)
+ endif
+
+ end do
+
+end subroutine interpol_all_nests
diff --git a/src/interpol_misslev.f90 b/src/interpol_misslev.f90
new file mode 100644
index 0000000000000000000000000000000000000000..c079ea4fa3389b730a01a4bde1a00a898190ac17
--- /dev/null
+++ b/src/interpol_misslev.f90
@@ -0,0 +1,180 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine interpol_misslev(n)
+ ! i
+ !*****************************************************************************
+ ! *
+ ! This subroutine interpolates u,v,w, density and density gradients. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 16 December 1997 *
+ ! Update: 2 March 1999 *
+ ! *
+ ! Revision March 2005 by AST : all output variables in common block cal- *
+ ! culation of standard deviation done in this *
+ ! routine rather than subroutine call in order *
+ ! to save computation time *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! n level *
+ ! *
+ ! Constants: *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+ use interpol_mod
+ use hanna_mod
+
+ implicit none
+
+ ! Auxiliary variables needed for interpolation
+ real :: y1(2),y2(2),y3(2),rho1(2),rhograd1(2)
+ real :: usl,vsl,wsl,usq,vsq,wsq,xaux
+ integer :: m,n,indexh
+ real,parameter :: eps=1.0e-30
+
+
+ !********************************************
+ ! Multilinear interpolation in time and space
+ !********************************************
+
+
+ !**************************************
+ ! 1.) Bilinear horizontal interpolation
+ ! 2.) Temporal interpolation (linear)
+ !**************************************
+
+ ! Loop over 2 time steps
+ !***********************
+
+ usl=0.
+ vsl=0.
+ wsl=0.
+ usq=0.
+ vsq=0.
+ wsq=0.
+ do m=1,2
+ indexh=memind(m)
+ if (ngrid.lt.0) then
+ y1(m)=p1*uupol(ix ,jy ,n,indexh) &
+ +p2*uupol(ixp,jy ,n,indexh) &
+ +p3*uupol(ix ,jyp,n,indexh) &
+ +p4*uupol(ixp,jyp,n,indexh)
+ y2(m)=p1*vvpol(ix ,jy ,n,indexh) &
+ +p2*vvpol(ixp,jy ,n,indexh) &
+ +p3*vvpol(ix ,jyp,n,indexh) &
+ +p4*vvpol(ixp,jyp,n,indexh)
+ usl=usl+uupol(ix ,jy ,n,indexh)+uupol(ixp,jy ,n,indexh) &
+ +uupol(ix ,jyp,n,indexh)+uupol(ixp,jyp,n,indexh)
+ vsl=vsl+vvpol(ix ,jy ,n,indexh)+vvpol(ixp,jy ,n,indexh) &
+ +vvpol(ix ,jyp,n,indexh)+vvpol(ixp,jyp,n,indexh)
+
+ usq=usq+uupol(ix ,jy ,n,indexh)*uupol(ix ,jy ,n,indexh)+ &
+ uupol(ixp,jy ,n,indexh)*uupol(ixp,jy ,n,indexh)+ &
+ uupol(ix ,jyp,n,indexh)*uupol(ix ,jyp,n,indexh)+ &
+ uupol(ixp,jyp,n,indexh)*uupol(ixp,jyp,n,indexh)
+ vsq=vsq+vvpol(ix ,jy ,n,indexh)*vvpol(ix ,jy ,n,indexh)+ &
+ vvpol(ixp,jy ,n,indexh)*vvpol(ixp,jy ,n,indexh)+ &
+ vvpol(ix ,jyp,n,indexh)*vvpol(ix ,jyp,n,indexh)+ &
+ vvpol(ixp,jyp,n,indexh)*vvpol(ixp,jyp,n,indexh)
+ else
+ y1(m)=p1*uu(ix ,jy ,n,indexh) &
+ +p2*uu(ixp,jy ,n,indexh) &
+ +p3*uu(ix ,jyp,n,indexh) &
+ +p4*uu(ixp,jyp,n,indexh)
+ y2(m)=p1*vv(ix ,jy ,n,indexh) &
+ +p2*vv(ixp,jy ,n,indexh) &
+ +p3*vv(ix ,jyp,n,indexh) &
+ +p4*vv(ixp,jyp,n,indexh)
+ usl=usl+uu(ix ,jy ,n,indexh)+uu(ixp,jy ,n,indexh) &
+ +uu(ix ,jyp,n,indexh)+uu(ixp,jyp,n,indexh)
+ vsl=vsl+vv(ix ,jy ,n,indexh)+vv(ixp,jy ,n,indexh) &
+ +vv(ix ,jyp,n,indexh)+vv(ixp,jyp,n,indexh)
+
+ usq=usq+uu(ix ,jy ,n,indexh)*uu(ix ,jy ,n,indexh)+ &
+ uu(ixp,jy ,n,indexh)*uu(ixp,jy ,n,indexh)+ &
+ uu(ix ,jyp,n,indexh)*uu(ix ,jyp,n,indexh)+ &
+ uu(ixp,jyp,n,indexh)*uu(ixp,jyp,n,indexh)
+ vsq=vsq+vv(ix ,jy ,n,indexh)*vv(ix ,jy ,n,indexh)+ &
+ vv(ixp,jy ,n,indexh)*vv(ixp,jy ,n,indexh)+ &
+ vv(ix ,jyp,n,indexh)*vv(ix ,jyp,n,indexh)+ &
+ vv(ixp,jyp,n,indexh)*vv(ixp,jyp,n,indexh)
+ endif
+ y3(m)=p1*ww(ix ,jy ,n,indexh) &
+ +p2*ww(ixp,jy ,n,indexh) &
+ +p3*ww(ix ,jyp,n,indexh) &
+ +p4*ww(ixp,jyp,n,indexh)
+ rhograd1(m)=p1*drhodz(ix ,jy ,n,indexh) &
+ +p2*drhodz(ixp,jy ,n,indexh) &
+ +p3*drhodz(ix ,jyp,n,indexh) &
+ +p4*drhodz(ixp,jyp,n,indexh)
+ rho1(m)=p1*rho(ix ,jy ,n,indexh) &
+ +p2*rho(ixp,jy ,n,indexh) &
+ +p3*rho(ix ,jyp,n,indexh) &
+ +p4*rho(ixp,jyp,n,indexh)
+ wsl=wsl+ww(ix ,jy ,n,indexh)+ww(ixp,jy ,n,indexh) &
+ +ww(ix ,jyp,n,indexh)+ww(ixp,jyp,n,indexh)
+ wsq=wsq+ww(ix ,jy ,n,indexh)*ww(ix ,jy ,n,indexh)+ &
+ ww(ixp,jy ,n,indexh)*ww(ixp,jy ,n,indexh)+ &
+ ww(ix ,jyp,n,indexh)*ww(ix ,jyp,n,indexh)+ &
+ ww(ixp,jyp,n,indexh)*ww(ixp,jyp,n,indexh)
+ end do
+ uprof(n)=(y1(1)*dt2+y1(2)*dt1)*dtt
+ vprof(n)=(y2(1)*dt2+y2(2)*dt1)*dtt
+ wprof(n)=(y3(1)*dt2+y3(2)*dt1)*dtt
+ rhoprof(n)=(rho1(1)*dt2+rho1(2)*dt1)*dtt
+ rhogradprof(n)=(rhograd1(1)*dt2+rhograd1(2)*dt1)*dtt
+ indzindicator(n)=.false.
+
+
+ ! Compute standard deviations
+ !****************************
+
+ xaux=usq-usl*usl/8.
+ if (xaux.lt.eps) then
+ usigprof(n)=0.
+ else
+ usigprof(n)=sqrt(xaux/7.)
+ endif
+
+ xaux=vsq-vsl*vsl/8.
+ if (xaux.lt.eps) then
+ vsigprof(n)=0.
+ else
+ vsigprof(n)=sqrt(xaux/7.)
+ endif
+
+
+ xaux=wsq-wsl*wsl/8.
+ if (xaux.lt.eps) then
+ wsigprof(n)=0.
+ else
+ wsigprof(n)=sqrt(xaux/7.)
+ endif
+
+
+end subroutine interpol_misslev
diff --git a/src/interpol_misslev_nests.f90 b/src/interpol_misslev_nests.f90
new file mode 100644
index 0000000000000000000000000000000000000000..1cb3489ee01f9d00628c8ff24a3fda87a569ac7d
--- /dev/null
+++ b/src/interpol_misslev_nests.f90
@@ -0,0 +1,149 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine interpol_misslev_nests(n)
+ ! i
+ !*****************************************************************************
+ ! *
+ ! This subroutine interpolates u,v,w, density and density gradients. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 16 December 1997 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! n level *
+ ! *
+ ! Constants: *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+ use interpol_mod
+ use hanna_mod
+
+ implicit none
+
+ ! Auxiliary variables needed for interpolation
+ real :: y1(2),y2(2),y3(2),rho1(2),rhograd1(2)
+ real :: usl,vsl,wsl,usq,vsq,wsq,xaux
+ integer :: m,n,indexh
+ real,parameter :: eps=1.0e-30
+
+
+ !********************************************
+ ! Multilinear interpolation in time and space
+ !********************************************
+
+
+ !**************************************
+ ! 1.) Bilinear horizontal interpolation
+ ! 2.) Temporal interpolation (linear)
+ !**************************************
+
+ ! Loop over 2 time steps
+ !***********************
+
+ usl=0.
+ vsl=0.
+ wsl=0.
+ usq=0.
+ vsq=0.
+ wsq=0.
+ do m=1,2
+ indexh=memind(m)
+ y1(m)=p1*uun(ix ,jy ,n,indexh,ngrid) &
+ +p2*uun(ixp,jy ,n,indexh,ngrid) &
+ +p3*uun(ix ,jyp,n,indexh,ngrid) &
+ +p4*uun(ixp,jyp,n,indexh,ngrid)
+ y2(m)=p1*vvn(ix ,jy ,n,indexh,ngrid) &
+ +p2*vvn(ixp,jy ,n,indexh,ngrid) &
+ +p3*vvn(ix ,jyp,n,indexh,ngrid) &
+ +p4*vvn(ixp,jyp,n,indexh,ngrid)
+ y3(m)=p1*wwn(ix ,jy ,n,indexh,ngrid) &
+ +p2*wwn(ixp,jy ,n,indexh,ngrid) &
+ +p3*wwn(ix ,jyp,n,indexh,ngrid) &
+ +p4*wwn(ixp,jyp,n,indexh,ngrid)
+ rho1(m)=p1*rhon(ix ,jy ,n,indexh,ngrid) &
+ +p2*rhon(ixp,jy ,n,indexh,ngrid) &
+ +p3*rhon(ix ,jyp,n,indexh,ngrid) &
+ +p4*rhon(ixp,jyp,n,indexh,ngrid)
+ rhograd1(m)=p1*drhodzn(ix ,jy ,n,indexh,ngrid) &
+ +p2*drhodzn(ixp,jy ,n,indexh,ngrid) &
+ +p3*drhodzn(ix ,jyp,n,indexh,ngrid) &
+ +p4*drhodzn(ixp,jyp,n,indexh,ngrid)
+
+ usl=usl+uun(ix ,jy ,n,indexh,ngrid)+uun(ixp,jy ,n,indexh,ngrid) &
+ +uun(ix ,jyp,n,indexh,ngrid)+uun(ixp,jyp,n,indexh,ngrid)
+ vsl=vsl+vvn(ix ,jy ,n,indexh,ngrid)+vvn(ixp,jy ,n,indexh,ngrid) &
+ +vvn(ix ,jyp,n,indexh,ngrid)+vvn(ixp,jyp,n,indexh,ngrid)
+ wsl=wsl+wwn(ix ,jy ,n,indexh,ngrid)+wwn(ixp,jy ,n,indexh,ngrid) &
+ +wwn(ix ,jyp,n,indexh,ngrid)+wwn(ixp,jyp,n,indexh,ngrid)
+
+ usq=usq+uun(ix ,jy ,n,indexh,ngrid)*uun(ix ,jy ,n,indexh,ngrid)+ &
+ uun(ixp,jy ,n,indexh,ngrid)*uun(ixp,jy ,n,indexh,ngrid)+ &
+ uun(ix ,jyp,n,indexh,ngrid)*uun(ix ,jyp,n,indexh,ngrid)+ &
+ uun(ixp,jyp,n,indexh,ngrid)*uun(ixp,jyp,n,indexh,ngrid)
+ vsq=vsq+vvn(ix ,jy ,n,indexh,ngrid)*vvn(ix ,jy ,n,indexh,ngrid)+ &
+ vvn(ixp,jy ,n,indexh,ngrid)*vvn(ixp,jy ,n,indexh,ngrid)+ &
+ vvn(ix ,jyp,n,indexh,ngrid)*vvn(ix ,jyp,n,indexh,ngrid)+ &
+ vvn(ixp,jyp,n,indexh,ngrid)*vvn(ixp,jyp,n,indexh,ngrid)
+ wsq=wsq+wwn(ix ,jy ,n,indexh,ngrid)*wwn(ix ,jy ,n,indexh,ngrid)+ &
+ wwn(ixp,jy ,n,indexh,ngrid)*wwn(ixp,jy ,n,indexh,ngrid)+ &
+ wwn(ix ,jyp,n,indexh,ngrid)*wwn(ix ,jyp,n,indexh,ngrid)+ &
+ wwn(ixp,jyp,n,indexh,ngrid)*wwn(ixp,jyp,n,indexh,ngrid)
+ end do
+ uprof(n)=(y1(1)*dt2+y1(2)*dt1)*dtt
+ vprof(n)=(y2(1)*dt2+y2(2)*dt1)*dtt
+ wprof(n)=(y3(1)*dt2+y3(2)*dt1)*dtt
+ rhoprof(n)=(rho1(1)*dt2+rho1(2)*dt1)*dtt
+ rhogradprof(n)=(rhograd1(1)*dt2+rhograd1(2)*dt1)*dtt
+ indzindicator(n)=.false.
+
+ ! Compute standard deviations
+ !****************************
+
+ xaux=usq-usl*usl/8.
+ if (xaux.lt.eps) then
+ usigprof(n)=0.
+ else
+ usigprof(n)=sqrt(xaux/7.)
+ endif
+
+ xaux=vsq-vsl*vsl/8.
+ if (xaux.lt.eps) then
+ vsigprof(n)=0.
+ else
+ vsigprof(n)=sqrt(xaux/7.)
+ endif
+
+
+ xaux=wsq-wsl*wsl/8.
+ if (xaux.lt.eps) then
+ wsigprof(n)=0.
+ else
+ wsigprof(n)=sqrt(xaux/7.)
+ endif
+
+end subroutine interpol_misslev_nests
diff --git a/src/interpol_mod.f90 b/src/interpol_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..0a9c329191d48eb57cc475209d7e773bf9246407
--- /dev/null
+++ b/src/interpol_mod.f90
@@ -0,0 +1,20 @@
+module interpol_mod
+
+ use par_mod, only: nzmax, maxspec
+
+ implicit none
+
+ real :: uprof(nzmax),vprof(nzmax),wprof(nzmax)
+ real :: usigprof(nzmax),vsigprof(nzmax),wsigprof(nzmax)
+ real :: rhoprof(nzmax),rhogradprof(nzmax)
+
+ real :: u,v,w,usig,vsig,wsig,pvi
+
+ real :: p1,p2,p3,p4,ddx,ddy,rddx,rddy,dtt,dt1,dt2
+ integer :: ix,jy,ixp,jyp,ngrid,indz,indzp
+ logical :: depoindicator(maxspec)
+ logical :: indzindicator(nzmax)
+
+end module interpol_mod
+
+
diff --git a/src/interpol_rain.f90 b/src/interpol_rain.f90
new file mode 100644
index 0000000000000000000000000000000000000000..56d7e73e33e47d619fd981b916718539c22ccf6d
--- /dev/null
+++ b/src/interpol_rain.f90
@@ -0,0 +1,223 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+!subroutine interpol_rain(yy1,yy2,yy3,nxmax,nymax,nzmax,nx, &
+! ny,memind,xt,yt,level,itime1,itime2,itime,yint1,yint2,yint3)
+! ! i i i i i i i
+! !i i i i i i i i o o o
+
+ subroutine interpol_rain(yy1,yy2,yy3,iy1,iy2,nxmax,nymax,nzmax,nx, &
+ ny,memind,xt,yt,level,itime1,itime2,itime,yint1,yint2,yint3, &
+ intiy1,intiy2,icmv)
+! i i i i i i i
+! i i i i i i i i o o o
+
+ !****************************************************************************
+ ! *
+ ! Interpolation of meteorological fields on 2-d model layers. *
+ ! In horizontal direction bilinear interpolation interpolation is used. *
+ ! Temporally a linear interpolation is used. *
+ ! Three fields are interpolated at the same time. *
+ ! *
+ ! This is a special version of levlininterpol to save CPU time. *
+ ! *
+ ! 1 first time *
+ ! 2 second time *
+ ! *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 30 August 1996 *
+ !
+ !* Petra Seibert, 2011/2012:
+ !* Add interpolation of cloud bottom and cloud thickness
+ !* for fix to SE's new wet scavenging scheme *
+ !****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! dt1,dt2 time differences between fields and current position *
+ ! dz1,dz2 z distance between levels and current position *
+ ! height(nzmax) heights of the model levels *
+ ! indexh help variable *
+ ! indz the level closest to the current trajectory position *
+ ! indzh help variable *
+ ! itime current time *
+ ! itime1 time of the first wind field *
+ ! itime2 time of the second wind field *
+ ! ix,jy x,y coordinates of lower left subgrid point *
+ ! level level at which interpolation shall be done *
+ ! memind(3) points to the places of the wind fields *
+ ! nx,ny actual field dimensions in x,y and z direction *
+ ! nxmax,nymax,nzmax maximum field dimensions in x,y and z direction *
+ ! xt current x coordinate *
+ ! yint the final interpolated value *
+ ! yt current y coordinate *
+ ! yy(0:nxmax,0:nymax,nzmax,3) meteorological field used for interpolation *
+ ! zt current z coordinate *
+ ! *
+ !****************************************************************************
+
+ implicit none
+
+ integer :: nx,ny,nxmax,nymax,nzmax,memind(2),m,ix,jy,ixp,jyp
+ !integer :: itime,itime1,itime2,level,indexh
+ integer :: itime,itime1,itime2,level,indexh,ip1,ip2,ip3,ip4
+ integer :: intiy1,intiy2,ipsum,icmv
+ real :: yy1(0:nxmax-1,0:nymax-1,nzmax,2)
+ real :: yy2(0:nxmax-1,0:nymax-1,nzmax,2)
+ real :: yy3(0:nxmax-1,0:nymax-1,nzmax,2)
+ integer iy1(0:nxmax-1,0:nymax-1,2),iy2(0:nxmax-1,0:nymax-1,2)
+ real :: ddx,ddy,rddx,rddy,dt1,dt2,dt,y1(2),y2(2),y3(2),yi1(2),yi2(2)
+ !real :: ddx,ddy,rddx,rddy,dt1,dt2,dt,y1(2),y2(2),y3(2)
+ real :: xt,yt,yint1,yint2,yint3,yint4,p1,p2,p3,p4
+ !real :: xt,yt,yint1,yint2,yint3,p1,p2,p3,p4
+
+
+
+ ! If point at border of grid -> small displacement into grid
+ !***********************************************************
+
+ if (xt.ge.real(nx-1)) xt=real(nx-1)-0.00001
+ if (yt.ge.real(ny-1)) yt=real(ny-1)-0.00001
+
+
+
+ !**********************************************************************
+ ! 1.) Bilinear horizontal interpolation
+ ! This has to be done separately for 2 fields (Temporal)
+ !*******************************************************
+
+ ! Determine the lower left corner and its distance to the current position
+ !*************************************************************************
+
+ ix=int(xt)
+ jy=int(yt)
+ ixp=ix+1
+ jyp=jy+1
+ ddx=xt-real(ix)
+ ddy=yt-real(jy)
+ rddx=1.-ddx
+ rddy=1.-ddy
+ p1=rddx*rddy
+ p2=ddx*rddy
+ p3=rddx*ddy
+ p4=ddx*ddy
+
+
+ ! Loop over 2 time steps
+ !***********************
+
+ do m=1,2
+ indexh=memind(m)
+
+ y1(m)=p1*yy1(ix ,jy ,level,indexh) &
+ + p2*yy1(ixp,jy ,level,indexh) &
+ + p3*yy1(ix ,jyp,level,indexh) &
+ + p4*yy1(ixp,jyp,level,indexh)
+ y2(m)=p1*yy2(ix ,jy ,level,indexh) &
+ + p2*yy2(ixp,jy ,level,indexh) &
+ + p3*yy2(ix ,jyp,level,indexh) &
+ + p4*yy2(ixp,jyp,level,indexh)
+ y3(m)=p1*yy3(ix ,jy ,level,indexh) &
+ + p2*yy3(ixp,jy ,level,indexh) &
+ + p3*yy3(ix ,jyp,level,indexh) &
+ + p4*yy3(ixp,jyp,level,indexh)
+
+!CPS clouds:
+ ip1=1
+ ip2=1
+ ip3=1
+ ip4=1
+ if (iy1(ix ,jy ,indexh) .eq. icmv) ip1=0
+ if (iy1(ixp,jy ,indexh) .eq. icmv) ip2=0
+ if (iy1(ix ,jyp,indexh) .eq. icmv) ip3=0
+ if (iy1(ixp,jyp,indexh) .eq. icmv) ip4=0
+ ipsum= ip1+ip2+ip3+ip4
+ if (ipsum .eq. 0) then
+ yi1(m)=icmv
+ else
+ yi1(m)=(ip1*p1*iy1(ix ,jy ,indexh) &
+ + ip2*p2*iy1(ixp,jy ,indexh) &
+ + ip3*p3*iy1(ix ,jyp,indexh) &
+ + ip4*p4*iy1(ixp,jyp,indexh))/ipsum
+ endif
+
+ ip1=1
+ ip2=1
+ ip3=1
+ ip4=1
+ if (iy2(ix ,jy ,indexh) .eq. icmv) ip1=0
+ if (iy2(ixp,jy ,indexh) .eq. icmv) ip2=0
+ if (iy2(ix ,jyp,indexh) .eq. icmv) ip3=0
+ if (iy2(ixp,jyp,indexh) .eq. icmv) ip4=0
+ ipsum= ip1+ip2+ip3+ip4
+ if (ipsum .eq. 0) then
+ yi2(m)=icmv
+ else
+ yi2(m)=(ip1*p1*iy2(ix ,jy ,indexh) &
+ + ip2*p2*iy2(ixp,jy ,indexh) &
+ + ip3*p3*iy2(ix ,jyp,indexh) &
+ + ip4*p4*iy2(ixp,jyp,indexh))/ipsum
+ endif
+!CPS end clouds
+
+ end do
+
+
+ !************************************
+ ! 2.) Temporal interpolation (linear)
+ !************************************
+
+ if (abs(itime) .lt. abs(itime1)) then
+ print*,'interpol_rain.f90'
+ print*,itime,itime1,itime2
+ stop 'ITIME PROBLEM'
+ endif
+
+
+ dt1=real(itime-itime1)
+ dt2=real(itime2-itime)
+ dt=dt1+dt2
+
+ yint1=(y1(1)*dt2+y1(2)*dt1)/dt
+ yint2=(y2(1)*dt2+y2(2)*dt1)/dt
+ yint3=(y3(1)*dt2+y3(2)*dt1)/dt
+
+
+!PS clouds:
+ intiy1=(yi1(1)*dt2 + yi1(2)*dt1)/dt
+ if (yi1(1) .eq. float(icmv)) intiy1=yi1(2)
+ if (yi1(2) .eq. float(icmv)) intiy1=yi1(1)
+
+ intiy2=(yi2(1)*dt2 + yi2(2)*dt1)/dt
+ if (yi2(1) .eq. float(icmv)) intiy2=yi2(2)
+ if (yi2(2) .eq. float(icmv)) intiy2=yi2(1)
+
+ if (intiy1 .ne. icmv .and. intiy2 .ne. icmv) then
+ intiy2 = intiy1 + intiy2 ! convert cloud thickness to cloud top
+ else
+ intiy1=icmv
+ intiy2=icmv
+ endif
+!PS end clouds
+
+end subroutine interpol_rain
diff --git a/src/interpol_rain_nests.f90 b/src/interpol_rain_nests.f90
new file mode 100644
index 0000000000000000000000000000000000000000..53e64b880b71f89b713a960f73dfd459b3958ad3
--- /dev/null
+++ b/src/interpol_rain_nests.f90
@@ -0,0 +1,152 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine interpol_rain_nests(yy1,yy2,yy3,nxmaxn,nymaxn,nzmax, &
+ maxnests,ngrid,nxn,nyn,memind,xt,yt,level,itime1,itime2,itime, &
+ yint1,yint2,yint3)
+ ! i i i i i i
+ ! i i i i i i i i i i i
+ ! o o o
+ !****************************************************************************
+ ! *
+ ! Interpolation of meteorological fields on 2-d model layers for nested *
+ ! grids. This routine is related to levlin3interpol.f for the mother domain*
+ ! *
+ ! In horizontal direction bilinear interpolation interpolation is used. *
+ ! Temporally a linear interpolation is used. *
+ ! Three fields are interpolated at the same time. *
+ ! *
+ ! This is a special version of levlininterpol to save CPU time. *
+ ! *
+ ! 1 first time *
+ ! 2 second time *
+ ! *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 15 March 2000 *
+ ! *
+ !****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! dt1,dt2 time differences between fields and current position *
+ ! dz1,dz2 z distance between levels and current position *
+ ! height(nzmax) heights of the model levels *
+ ! indexh help variable *
+ ! indz the level closest to the current trajectory position *
+ ! indzh help variable *
+ ! itime current time *
+ ! itime1 time of the first wind field *
+ ! itime2 time of the second wind field *
+ ! ix,jy x,y coordinates of lower left subgrid point *
+ ! level level at which interpolation shall be done *
+ ! memind(3) points to the places of the wind fields *
+ ! nx,ny actual field dimensions in x,y and z direction *
+ ! nxmax,nymax,nzmax maximum field dimensions in x,y and z direction *
+ ! xt current x coordinate *
+ ! yint the final interpolated value *
+ ! yt current y coordinate *
+ ! yy(0:nxmax,0:nymax,nzmax,3) meteorological field used for interpolation *
+ ! zt current z coordinate *
+ ! *
+ !****************************************************************************
+
+ implicit none
+
+ integer :: maxnests,ngrid
+ integer :: nxn(maxnests),nyn(maxnests),nxmaxn,nymaxn,nzmax,memind(2)
+ integer :: m,ix,jy,ixp,jyp,itime,itime1,itime2,level,indexh
+ real :: yy1(0:nxmaxn-1,0:nymaxn-1,nzmax,2,maxnests)
+ real :: yy2(0:nxmaxn-1,0:nymaxn-1,nzmax,2,maxnests)
+ real :: yy3(0:nxmaxn-1,0:nymaxn-1,nzmax,2,maxnests)
+ real :: ddx,ddy,rddx,rddy,dt1,dt2,dt,y1(2),y2(2),y3(2)
+ real :: xt,yt,yint1,yint2,yint3,p1,p2,p3,p4
+
+
+
+ ! If point at border of grid -> small displacement into grid
+ !***********************************************************
+
+ if (xt.ge.(real(nxn(ngrid)-1)-0.0001)) &
+ xt=real(nxn(ngrid)-1)-0.0001
+ if (yt.ge.(real(nyn(ngrid)-1)-0.0001)) &
+ yt=real(nyn(ngrid)-1)-0.0001
+
+
+
+ !**********************************************************************
+ ! 1.) Bilinear horizontal interpolation
+ ! This has to be done separately for 2 fields (Temporal)
+ !*******************************************************
+
+ ! Determine the lower left corner and its distance to the current position
+ !*************************************************************************
+
+ ix=int(xt)
+ jy=int(yt)
+ ixp=ix+1
+ jyp=jy+1
+ ddx=xt-real(ix)
+ ddy=yt-real(jy)
+ rddx=1.-ddx
+ rddy=1.-ddy
+ p1=rddx*rddy
+ p2=ddx*rddy
+ p3=rddx*ddy
+ p4=ddx*ddy
+
+
+ ! Loop over 2 time steps
+ !***********************
+
+ do m=1,2
+ indexh=memind(m)
+
+ y1(m)=p1*yy1(ix ,jy ,level,indexh,ngrid) &
+ + p2*yy1(ixp,jy ,level,indexh,ngrid) &
+ + p3*yy1(ix ,jyp,level,indexh,ngrid) &
+ + p4*yy1(ixp,jyp,level,indexh,ngrid)
+ y2(m)=p1*yy2(ix ,jy ,level,indexh,ngrid) &
+ + p2*yy2(ixp,jy ,level,indexh,ngrid) &
+ + p3*yy2(ix ,jyp,level,indexh,ngrid) &
+ + p4*yy2(ixp,jyp,level,indexh,ngrid)
+ y3(m)=p1*yy3(ix ,jy ,level,indexh,ngrid) &
+ + p2*yy3(ixp,jy ,level,indexh,ngrid) &
+ + p3*yy3(ix ,jyp,level,indexh,ngrid) &
+ + p4*yy3(ixp,jyp,level,indexh,ngrid)
+ end do
+
+
+ !************************************
+ ! 2.) Temporal interpolation (linear)
+ !************************************
+
+ dt1=real(itime-itime1)
+ dt2=real(itime2-itime)
+ dt=dt1+dt2
+
+ yint1=(y1(1)*dt2+y1(2)*dt1)/dt
+ yint2=(y2(1)*dt2+y2(2)*dt1)/dt
+ yint3=(y3(1)*dt2+y3(2)*dt1)/dt
+
+
+end subroutine interpol_rain_nests
diff --git a/src/interpol_vdep.f90 b/src/interpol_vdep.f90
new file mode 100644
index 0000000000000000000000000000000000000000..8f5caa3248e609155367fabc44b2c8e3361e58ed
--- /dev/null
+++ b/src/interpol_vdep.f90
@@ -0,0 +1,75 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine interpol_vdep(level,vdepo)
+ ! i o
+ !****************************************************************************
+ ! *
+ ! Interpolation of the deposition velocity on 2-d model layer. *
+ ! In horizontal direction bilinear interpolation interpolation is used. *
+ ! Temporally a linear interpolation is used. *
+ ! *
+ ! 1 first time *
+ ! 2 second time *
+ ! *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 30 May 1994 *
+ ! *
+ !****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! level number of species for which interpolation is done *
+ ! *
+ !****************************************************************************
+
+ use par_mod
+ use com_mod
+ use interpol_mod
+
+ implicit none
+
+ integer :: level,indexh,m
+ real :: y(2),vdepo
+
+ ! a) Bilinear horizontal interpolation
+
+ do m=1,2
+ indexh=memind(m)
+
+ y(m)=p1*vdep(ix ,jy ,level,indexh) &
+ +p2*vdep(ixp,jy ,level,indexh) &
+ +p3*vdep(ix ,jyp,level,indexh) &
+ +p4*vdep(ixp,jyp,level,indexh)
+ end do
+
+
+
+ ! b) Temporal interpolation
+
+ vdepo=(y(1)*dt2+y(2)*dt1)*dtt
+
+ depoindicator(level)=.false.
+
+
+end subroutine interpol_vdep
diff --git a/src/interpol_vdep_nests.f90 b/src/interpol_vdep_nests.f90
new file mode 100644
index 0000000000000000000000000000000000000000..b8db5132bb8d947706aabe15d0aedba08e782da4
--- /dev/null
+++ b/src/interpol_vdep_nests.f90
@@ -0,0 +1,74 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine interpol_vdep_nests(level,vdepo)
+ ! i o
+ !****************************************************************************
+ ! *
+ ! Interpolation of the deposition velocity on 2-d model layer. *
+ ! In horizontal direction bilinear interpolation interpolation is used. *
+ ! Temporally a linear interpolation is used. *
+ ! *
+ ! 1 first time *
+ ! 2 second time *
+ ! *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 30 May 1994 *
+ ! *
+ !****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! level number of species for which interpolation is done *
+ ! *
+ !****************************************************************************
+
+ use par_mod
+ use com_mod
+ use interpol_mod
+
+ implicit none
+
+ integer :: level,indexh,m
+ real :: y(2),vdepo
+
+ ! a) Bilinear horizontal interpolation
+
+ do m=1,2
+ indexh=memind(m)
+
+ y(m)=p1*vdepn(ix ,jy ,level,indexh,ngrid) &
+ +p2*vdepn(ixp,jy ,level,indexh,ngrid) &
+ +p3*vdepn(ix ,jyp,level,indexh,ngrid) &
+ +p4*vdepn(ixp,jyp,level,indexh,ngrid)
+ end do
+
+
+ ! b) Temporal interpolation
+
+ vdepo=(y(1)*dt2+y(2)*dt1)*dtt
+
+ depoindicator(level)=.false.
+
+
+end subroutine interpol_vdep_nests
diff --git a/src/interpol_wind.f90 b/src/interpol_wind.f90
new file mode 100644
index 0000000000000000000000000000000000000000..18a90ca707b69b4e8d9bcea97b60ca7a380f1d12
--- /dev/null
+++ b/src/interpol_wind.f90
@@ -0,0 +1,234 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine interpol_wind(itime,xt,yt,zt)
+ ! i i i i
+ !*****************************************************************************
+ ! *
+ ! This subroutine interpolates the wind data to current trajectory position.*
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 16 December 1997 *
+ ! *
+ ! Revision March 2005 by AST : all output variables in common block cal- *
+ ! culation of standard deviation done in this *
+ ! routine rather than subroutine call in order *
+ ! to save computation time *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! u,v,w wind components *
+ ! itime [s] current temporal position *
+ ! memtime(3) [s] times of the wind fields in memory *
+ ! xt,yt,zt coordinates position for which wind data shall be *
+ ! calculated *
+ ! *
+ ! Constants: *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+ use interpol_mod
+
+ implicit none
+
+ integer :: itime
+ real :: xt,yt,zt
+
+ ! Auxiliary variables needed for interpolation
+ real :: dz1,dz2,dz
+ real :: u1(2),v1(2),w1(2),uh(2),vh(2),wh(2)
+ real :: usl,vsl,wsl,usq,vsq,wsq,xaux
+ integer :: i,m,n,indexh,indzh
+ real,parameter :: eps=1.0e-30
+
+
+ !********************************************
+ ! Multilinear interpolation in time and space
+ !********************************************
+
+ ! Determine the lower left corner and its distance to the current position
+ !*************************************************************************
+
+ ddx=xt-real(ix)
+ ddy=yt-real(jy)
+ rddx=1.-ddx
+ rddy=1.-ddy
+ p1=rddx*rddy
+ p2=ddx*rddy
+ p3=rddx*ddy
+ p4=ddx*ddy
+
+ ! Calculate variables for time interpolation
+ !*******************************************
+
+ dt1=real(itime-memtime(1))
+ dt2=real(memtime(2)-itime)
+ dtt=1./(dt1+dt2)
+
+ ! Determine the level below the current position for u,v
+ !*******************************************************
+
+ do i=2,nz
+ if (height(i).gt.zt) then
+ indz=i-1
+ goto 6
+ endif
+ end do
+6 continue
+
+
+ ! Vertical distance to the level below and above current position
+ !****************************************************************
+
+ dz=1./(height(indz+1)-height(indz))
+ dz1=(zt-height(indz))*dz
+ dz2=(height(indz+1)-zt)*dz
+
+ !**********************************************************************
+ ! 1.) Bilinear horizontal interpolation
+ ! This has to be done separately for 6 fields (Temporal(2)*Vertical(3))
+ !**********************************************************************
+
+ ! Loop over 2 time steps and 2 levels
+ !************************************
+
+ usl=0.
+ vsl=0.
+ wsl=0.
+ usq=0.
+ vsq=0.
+ wsq=0.
+ do m=1,2
+ indexh=memind(m)
+ do n=1,2
+ indzh=indz+n-1
+
+ if (ngrid.lt.0) then
+ u1(n)=p1*uupol(ix ,jy ,indzh,indexh) &
+ +p2*uupol(ixp,jy ,indzh,indexh) &
+ +p3*uupol(ix ,jyp,indzh,indexh) &
+ +p4*uupol(ixp,jyp,indzh,indexh)
+ v1(n)=p1*vvpol(ix ,jy ,indzh,indexh) &
+ +p2*vvpol(ixp,jy ,indzh,indexh) &
+ +p3*vvpol(ix ,jyp,indzh,indexh) &
+ +p4*vvpol(ixp,jyp,indzh,indexh)
+ usl=usl+uupol(ix ,jy ,indzh,indexh)+ &
+ uupol(ixp,jy ,indzh,indexh) &
+ +uupol(ix ,jyp,indzh,indexh)+uupol(ixp,jyp,indzh,indexh)
+ vsl=vsl+vvpol(ix ,jy ,indzh,indexh)+ &
+ vvpol(ixp,jy ,indzh,indexh) &
+ +vvpol(ix ,jyp,indzh,indexh)+vvpol(ixp,jyp,indzh,indexh)
+
+ usq=usq+uupol(ix ,jy ,indzh,indexh)* &
+ uupol(ix ,jy ,indzh,indexh)+ &
+ uupol(ixp,jy ,indzh,indexh)*uupol(ixp,jy ,indzh,indexh)+ &
+ uupol(ix ,jyp,indzh,indexh)*uupol(ix ,jyp,indzh,indexh)+ &
+ uupol(ixp,jyp,indzh,indexh)*uupol(ixp,jyp,indzh,indexh)
+ vsq=vsq+vvpol(ix ,jy ,indzh,indexh)* &
+ vvpol(ix ,jy ,indzh,indexh)+ &
+ vvpol(ixp,jy ,indzh,indexh)*vvpol(ixp,jy ,indzh,indexh)+ &
+ vvpol(ix ,jyp,indzh,indexh)*vvpol(ix ,jyp,indzh,indexh)+ &
+ vvpol(ixp,jyp,indzh,indexh)*vvpol(ixp,jyp,indzh,indexh)
+ else
+ u1(n)=p1*uu(ix ,jy ,indzh,indexh) &
+ +p2*uu(ixp,jy ,indzh,indexh) &
+ +p3*uu(ix ,jyp,indzh,indexh) &
+ +p4*uu(ixp,jyp,indzh,indexh)
+ v1(n)=p1*vv(ix ,jy ,indzh,indexh) &
+ +p2*vv(ixp,jy ,indzh,indexh) &
+ +p3*vv(ix ,jyp,indzh,indexh) &
+ +p4*vv(ixp,jyp,indzh,indexh)
+ usl=usl+uu(ix ,jy ,indzh,indexh)+uu(ixp,jy ,indzh,indexh) &
+ +uu(ix ,jyp,indzh,indexh)+uu(ixp,jyp,indzh,indexh)
+ vsl=vsl+vv(ix ,jy ,indzh,indexh)+vv(ixp,jy ,indzh,indexh) &
+ +vv(ix ,jyp,indzh,indexh)+vv(ixp,jyp,indzh,indexh)
+
+ usq=usq+uu(ix ,jy ,indzh,indexh)*uu(ix ,jy ,indzh,indexh)+ &
+ uu(ixp,jy ,indzh,indexh)*uu(ixp,jy ,indzh,indexh)+ &
+ uu(ix ,jyp,indzh,indexh)*uu(ix ,jyp,indzh,indexh)+ &
+ uu(ixp,jyp,indzh,indexh)*uu(ixp,jyp,indzh,indexh)
+ vsq=vsq+vv(ix ,jy ,indzh,indexh)*vv(ix ,jy ,indzh,indexh)+ &
+ vv(ixp,jy ,indzh,indexh)*vv(ixp,jy ,indzh,indexh)+ &
+ vv(ix ,jyp,indzh,indexh)*vv(ix ,jyp,indzh,indexh)+ &
+ vv(ixp,jyp,indzh,indexh)*vv(ixp,jyp,indzh,indexh)
+ endif
+ w1(n)=p1*ww(ix ,jy ,indzh,indexh) &
+ +p2*ww(ixp,jy ,indzh,indexh) &
+ +p3*ww(ix ,jyp,indzh,indexh) &
+ +p4*ww(ixp,jyp,indzh,indexh)
+ wsl=wsl+ww(ix ,jy ,indzh,indexh)+ww(ixp,jy ,indzh,indexh) &
+ +ww(ix ,jyp,indzh,indexh)+ww(ixp,jyp,indzh,indexh)
+ wsq=wsq+ww(ix ,jy ,indzh,indexh)*ww(ix ,jy ,indzh,indexh)+ &
+ ww(ixp,jy ,indzh,indexh)*ww(ixp,jy ,indzh,indexh)+ &
+ ww(ix ,jyp,indzh,indexh)*ww(ix ,jyp,indzh,indexh)+ &
+ ww(ixp,jyp,indzh,indexh)*ww(ixp,jyp,indzh,indexh)
+ end do
+
+
+ !**********************************
+ ! 2.) Linear vertical interpolation
+ !**********************************
+
+ uh(m)=dz2*u1(1)+dz1*u1(2)
+ vh(m)=dz2*v1(1)+dz1*v1(2)
+ wh(m)=dz2*w1(1)+dz1*w1(2)
+ end do
+
+
+ !************************************
+ ! 3.) Temporal interpolation (linear)
+ !************************************
+
+ u=(uh(1)*dt2+uh(2)*dt1)*dtt
+ v=(vh(1)*dt2+vh(2)*dt1)*dtt
+ w=(wh(1)*dt2+wh(2)*dt1)*dtt
+
+
+ ! Compute standard deviations
+ !****************************
+
+ xaux=usq-usl*usl/16.
+ if (xaux.lt.eps) then
+ usig=0.
+ else
+ usig=sqrt(xaux/15.)
+ endif
+
+ xaux=vsq-vsl*vsl/16.
+ if (xaux.lt.eps) then
+ vsig=0.
+ else
+ vsig=sqrt(xaux/15.)
+ endif
+
+
+ xaux=wsq-wsl*wsl/16.
+ if (xaux.lt.eps) then
+ wsig=0.
+ else
+ wsig=sqrt(xaux/15.)
+ endif
+
+end subroutine interpol_wind
diff --git a/src/interpol_wind_nests.f90 b/src/interpol_wind_nests.f90
new file mode 100644
index 0000000000000000000000000000000000000000..da7da835cff8efab9d8add97a32ba4eaeaac7387
--- /dev/null
+++ b/src/interpol_wind_nests.f90
@@ -0,0 +1,218 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine interpol_wind_nests(itime,xt,yt,zt)
+ ! i i i i
+ !*****************************************************************************
+ ! *
+ ! This subroutine interpolates the wind data to current trajectory position.*
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 16 December 1997 *
+ ! 16 December 1997 *
+ ! *
+ ! Revision March 2005 by AST : all output variables in common block cal- *
+ ! culation of standard deviation done in this *
+ ! routine rather than subroutine call in order *
+ ! to save computation time *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! u,v,w wind components *
+ ! itime [s] current temporal position *
+ ! memtime(3) [s] times of the wind fields in memory *
+ ! xt,yt,zt coordinates position for which wind data shall be *
+ ! calculated *
+ ! *
+ ! Constants: *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+ use interpol_mod
+
+ implicit none
+
+ integer :: itime
+ real :: xt,yt,zt
+
+ ! Auxiliary variables needed for interpolation
+ real :: dz1,dz2,dz
+ real :: u1(2),v1(2),w1(2),uh(2),vh(2),wh(2)
+ real :: usl,vsl,wsl,usq,vsq,wsq,xaux
+ integer :: i,m,n,indexh,indzh
+ real,parameter :: eps=1.0e-30
+
+
+ !********************************************
+ ! Multilinear interpolation in time and space
+ !********************************************
+
+ ! Determine the lower left corner and its distance to the current position
+ !*************************************************************************
+
+ ddx=xt-real(ix)
+ ddy=yt-real(jy)
+ rddx=1.-ddx
+ rddy=1.-ddy
+ p1=rddx*rddy
+ p2=ddx*rddy
+ p3=rddx*ddy
+ p4=ddx*ddy
+
+ ! Calculate variables for time interpolation
+ !*******************************************
+
+ dt1=real(itime-memtime(1))
+ dt2=real(memtime(2)-itime)
+ dtt=1./(dt1+dt2)
+
+ ! Determine the level below the current position for u,v
+ !*******************************************************
+
+ do i=2,nz
+ if (height(i).gt.zt) then
+ indz=i-1
+ goto 6
+ endif
+ end do
+6 continue
+
+
+ ! Vertical distance to the level below and above current position
+ !****************************************************************
+
+ dz=1./(height(indz+1)-height(indz))
+ dz1=(zt-height(indz))*dz
+ dz2=(height(indz+1)-zt)*dz
+
+
+ !**********************************************************************
+ ! 1.) Bilinear horizontal interpolation
+ ! This has to be done separately for 6 fields (Temporal(2)*Vertical(3))
+ !**********************************************************************
+
+ ! Loop over 2 time steps and 2 levels
+ !************************************
+
+ usl=0.
+ vsl=0.
+ wsl=0.
+ usq=0.
+ vsq=0.
+ wsq=0.
+ do m=1,2
+ indexh=memind(m)
+ do n=1,2
+ indzh=indz+n-1
+
+ u1(n)=p1*uun(ix ,jy ,indzh,indexh,ngrid) &
+ +p2*uun(ixp,jy ,indzh,indexh,ngrid) &
+ +p3*uun(ix ,jyp,indzh,indexh,ngrid) &
+ +p4*uun(ixp,jyp,indzh,indexh,ngrid)
+ v1(n)=p1*vvn(ix ,jy ,indzh,indexh,ngrid) &
+ +p2*vvn(ixp,jy ,indzh,indexh,ngrid) &
+ +p3*vvn(ix ,jyp,indzh,indexh,ngrid) &
+ +p4*vvn(ixp,jyp,indzh,indexh,ngrid)
+ w1(n)=p1*wwn(ix ,jy ,indzh,indexh,ngrid) &
+ +p2*wwn(ixp,jy ,indzh,indexh,ngrid) &
+ +p3*wwn(ix ,jyp,indzh,indexh,ngrid) &
+ +p4*wwn(ixp,jyp,indzh,indexh,ngrid)
+
+ usl=usl+uun(ix ,jy ,indzh,indexh,ngrid)+ &
+ uun(ixp,jy ,indzh,indexh,ngrid) &
+ +uun(ix ,jyp,indzh,indexh,ngrid)+ &
+ uun(ixp,jyp,indzh,indexh,ngrid)
+ vsl=vsl+vvn(ix ,jy ,indzh,indexh,ngrid)+ &
+ vvn(ixp,jy ,indzh,indexh,ngrid) &
+ +vvn(ix ,jyp,indzh,indexh,ngrid)+ &
+ vvn(ixp,jyp,indzh,indexh,ngrid)
+ wsl=wsl+wwn(ix ,jy ,indzh,indexh,ngrid)+ &
+ wwn(ixp,jy ,indzh,indexh,ngrid) &
+ +wwn(ix ,jyp,indzh,indexh,ngrid)+ &
+ wwn(ixp,jyp,indzh,indexh,ngrid)
+
+ usq=usq+uun(ix ,jy ,indzh,indexh,ngrid)* &
+ uun(ix ,jy ,indzh,indexh,ngrid)+ &
+ uun(ixp,jy ,indzh,indexh,ngrid)*uun(ixp,jy ,indzh,indexh,ngrid)+ &
+ uun(ix ,jyp,indzh,indexh,ngrid)*uun(ix ,jyp,indzh,indexh,ngrid)+ &
+ uun(ixp,jyp,indzh,indexh,ngrid)*uun(ixp,jyp,indzh,indexh,ngrid)
+ vsq=vsq+vvn(ix ,jy ,indzh,indexh,ngrid)* &
+ vvn(ix ,jy ,indzh,indexh,ngrid)+ &
+ vvn(ixp,jy ,indzh,indexh,ngrid)*vvn(ixp,jy ,indzh,indexh,ngrid)+ &
+ vvn(ix ,jyp,indzh,indexh,ngrid)*vvn(ix ,jyp,indzh,indexh,ngrid)+ &
+ vvn(ixp,jyp,indzh,indexh,ngrid)*vvn(ixp,jyp,indzh,indexh,ngrid)
+ wsq=wsq+wwn(ix ,jy ,indzh,indexh,ngrid)* &
+ wwn(ix ,jy ,indzh,indexh,ngrid)+ &
+ wwn(ixp,jy ,indzh,indexh,ngrid)*wwn(ixp,jy ,indzh,indexh,ngrid)+ &
+ wwn(ix ,jyp,indzh,indexh,ngrid)*wwn(ix ,jyp,indzh,indexh,ngrid)+ &
+ wwn(ixp,jyp,indzh,indexh,ngrid)*wwn(ixp,jyp,indzh,indexh,ngrid)
+ end do
+
+
+ !**********************************
+ ! 2.) Linear vertical interpolation
+ !**********************************
+
+ uh(m)=dz2*u1(1)+dz1*u1(2)
+ vh(m)=dz2*v1(1)+dz1*v1(2)
+ wh(m)=dz2*w1(1)+dz1*w1(2)
+ end do
+
+
+ !************************************
+ ! 3.) Temporal interpolation (linear)
+ !************************************
+
+ u=(uh(1)*dt2+uh(2)*dt1)*dtt
+ v=(vh(1)*dt2+vh(2)*dt1)*dtt
+ w=(wh(1)*dt2+wh(2)*dt1)*dtt
+
+
+ ! Compute standard deviations
+ !****************************
+
+ xaux=usq-usl*usl/16.
+ if (xaux.lt.eps) then
+ usig=0.
+ else
+ usig=sqrt(xaux/15.)
+ endif
+
+ xaux=vsq-vsl*vsl/16.
+ if (xaux.lt.eps) then
+ vsig=0.
+ else
+ vsig=sqrt(xaux/15.)
+ endif
+
+
+ xaux=wsq-wsl*wsl/16.
+ if (xaux.lt.eps) then
+ wsig=0.
+ else
+ wsig=sqrt(xaux/15.)
+ endif
+
+end subroutine interpol_wind_nests
diff --git a/src/interpol_wind_short.f90 b/src/interpol_wind_short.f90
new file mode 100644
index 0000000000000000000000000000000000000000..196fbf8dd3184da7f0fa8871801da93d2de72aec
--- /dev/null
+++ b/src/interpol_wind_short.f90
@@ -0,0 +1,160 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine interpol_wind_short(itime,xt,yt,zt)
+ ! i i i i
+ !*****************************************************************************
+ ! *
+ ! This subroutine interpolates the wind data to current trajectory position.*
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 16 December 1997 *
+ ! *
+ ! Revision March 2005 by AST : all output variables in common block *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! u,v,w wind components *
+ ! itime [s] current temporal position *
+ ! memtime(3) [s] times of the wind fields in memory *
+ ! xt,yt,zt coordinates position for which wind data shall be *
+ ! calculated *
+ ! *
+ ! Constants: *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+ use interpol_mod
+
+ implicit none
+
+ integer :: itime
+ real :: xt,yt,zt
+
+ ! Auxiliary variables needed for interpolation
+ real :: dz1,dz2,dz
+ real :: u1(2),v1(2),w1(2),uh(2),vh(2),wh(2)
+ integer :: i,m,n,indexh,indzh
+
+
+ !********************************************
+ ! Multilinear interpolation in time and space
+ !********************************************
+
+ ddx=xt-real(ix)
+ ddy=yt-real(jy)
+ rddx=1.-ddx
+ rddy=1.-ddy
+ p1=rddx*rddy
+ p2=ddx*rddy
+ p3=rddx*ddy
+ p4=ddx*ddy
+
+ ! Calculate variables for time interpolation
+ !*******************************************
+
+ dt1=real(itime-memtime(1))
+ dt2=real(memtime(2)-itime)
+ dtt=1./(dt1+dt2)
+
+ ! Determine the level below the current position for u,v
+ !*******************************************************
+
+ do i=2,nz
+ if (height(i).gt.zt) then
+ indz=i-1
+ goto 6
+ endif
+ end do
+6 continue
+
+
+ ! Vertical distance to the level below and above current position
+ !****************************************************************
+
+ dz=1./(height(indz+1)-height(indz))
+ dz1=(zt-height(indz))*dz
+ dz2=(height(indz+1)-zt)*dz
+
+
+ !**********************************************************************
+ ! 1.) Bilinear horizontal interpolation
+ ! This has to be done separately for 6 fields (Temporal(2)*Vertical(3))
+ !**********************************************************************
+
+ ! Loop over 2 time steps and 2 levels
+ !************************************
+
+ do m=1,2
+ indexh=memind(m)
+ do n=1,2
+ indzh=indz+n-1
+
+ if (ngrid.lt.0) then
+ u1(n)=p1*uupol(ix ,jy ,indzh,indexh) &
+ +p2*uupol(ixp,jy ,indzh,indexh) &
+ +p3*uupol(ix ,jyp,indzh,indexh) &
+ +p4*uupol(ixp,jyp,indzh,indexh)
+ v1(n)=p1*vvpol(ix ,jy ,indzh,indexh) &
+ +p2*vvpol(ixp,jy ,indzh,indexh) &
+ +p3*vvpol(ix ,jyp,indzh,indexh) &
+ +p4*vvpol(ixp,jyp,indzh,indexh)
+ else
+ u1(n)=p1*uu(ix ,jy ,indzh,indexh) &
+ +p2*uu(ixp,jy ,indzh,indexh) &
+ +p3*uu(ix ,jyp,indzh,indexh) &
+ +p4*uu(ixp,jyp,indzh,indexh)
+ v1(n)=p1*vv(ix ,jy ,indzh,indexh) &
+ +p2*vv(ixp,jy ,indzh,indexh) &
+ +p3*vv(ix ,jyp,indzh,indexh) &
+ +p4*vv(ixp,jyp,indzh,indexh)
+ endif
+ w1(n)=p1*ww(ix ,jy ,indzh,indexh) &
+ +p2*ww(ixp,jy ,indzh,indexh) &
+ +p3*ww(ix ,jyp,indzh,indexh) &
+ +p4*ww(ixp,jyp,indzh,indexh)
+ end do
+
+
+ !**********************************
+ ! 2.) Linear vertical interpolation
+ !**********************************
+
+ uh(m)=dz2*u1(1)+dz1*u1(2)
+ vh(m)=dz2*v1(1)+dz1*v1(2)
+ wh(m)=dz2*w1(1)+dz1*w1(2)
+ end do
+
+
+
+ !************************************
+ ! 3.) Temporal interpolation (linear)
+ !************************************
+
+ u=(uh(1)*dt2+uh(2)*dt1)*dtt
+ v=(vh(1)*dt2+vh(2)*dt1)*dtt
+ w=(wh(1)*dt2+wh(2)*dt1)*dtt
+
+end subroutine interpol_wind_short
diff --git a/src/interpol_wind_short_nests.f90 b/src/interpol_wind_short_nests.f90
new file mode 100644
index 0000000000000000000000000000000000000000..160b0ea281814c2c24810e1a2554deef44b743ce
--- /dev/null
+++ b/src/interpol_wind_short_nests.f90
@@ -0,0 +1,149 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine interpol_wind_short_nests(itime,xt,yt,zt)
+ ! i i i i
+ !*****************************************************************************
+ ! *
+ ! This subroutine interpolates the wind data to current trajectory position.*
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 16 December 1997 *
+ ! *
+ ! Revision March 2005 by AST : all output variables in common block *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! u,v,w wind components *
+ ! itime [s] current temporal position *
+ ! memtime(3) [s] times of the wind fields in memory *
+ ! xt,yt,zt coordinates position for which wind data shall be *
+ ! calculated *
+ ! *
+ ! Constants: *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+ use interpol_mod
+
+ implicit none
+
+ integer :: itime
+ real :: xt,yt,zt
+
+ ! Auxiliary variables needed for interpolation
+ real :: dz1,dz2,dz
+ real :: u1(2),v1(2),w1(2),uh(2),vh(2),wh(2)
+ integer :: i,m,n,indexh,indzh
+
+
+ !********************************************
+ ! Multilinear interpolation in time and space
+ !********************************************
+
+ ddx=xt-real(ix)
+ ddy=yt-real(jy)
+ rddx=1.-ddx
+ rddy=1.-ddy
+ p1=rddx*rddy
+ p2=ddx*rddy
+ p3=rddx*ddy
+ p4=ddx*ddy
+
+ ! Calculate variables for time interpolation
+ !*******************************************
+
+ dt1=real(itime-memtime(1))
+ dt2=real(memtime(2)-itime)
+ dtt=1./(dt1+dt2)
+
+ ! Determine the level below the current position for u,v
+ !*******************************************************
+
+ do i=2,nz
+ if (height(i).gt.zt) then
+ indz=i-1
+ goto 6
+ endif
+ end do
+6 continue
+
+
+ ! Vertical distance to the level below and above current position
+ !****************************************************************
+
+ dz=1./(height(indz+1)-height(indz))
+ dz1=(zt-height(indz))*dz
+ dz2=(height(indz+1)-zt)*dz
+
+
+ !**********************************************************************
+ ! 1.) Bilinear horizontal interpolation
+ ! This has to be done separately for 6 fields (Temporal(2)*Vertical(3))
+ !**********************************************************************
+
+ ! Loop over 2 time steps and 2 levels
+ !************************************
+
+ do m=1,2
+ indexh=memind(m)
+ do n=1,2
+ indzh=indz+n-1
+
+ u1(n)=p1*uun(ix ,jy ,indzh,indexh,ngrid) &
+ +p2*uun(ixp,jy ,indzh,indexh,ngrid) &
+ +p3*uun(ix ,jyp,indzh,indexh,ngrid) &
+ +p4*uun(ixp,jyp,indzh,indexh,ngrid)
+ v1(n)=p1*vvn(ix ,jy ,indzh,indexh,ngrid) &
+ +p2*vvn(ixp,jy ,indzh,indexh,ngrid) &
+ +p3*vvn(ix ,jyp,indzh,indexh,ngrid) &
+ +p4*vvn(ixp,jyp,indzh,indexh,ngrid)
+ w1(n)=p1*wwn(ix ,jy ,indzh,indexh,ngrid) &
+ +p2*wwn(ixp,jy ,indzh,indexh,ngrid) &
+ +p3*wwn(ix ,jyp,indzh,indexh,ngrid) &
+ +p4*wwn(ixp,jyp,indzh,indexh,ngrid)
+
+ end do
+
+
+ !**********************************
+ ! 2.) Linear vertical interpolation
+ !**********************************
+
+ uh(m)=dz2*u1(1)+dz1*u1(2)
+ vh(m)=dz2*v1(1)+dz1*v1(2)
+ wh(m)=dz2*w1(1)+dz1*w1(2)
+ end do
+
+
+ !************************************
+ ! 3.) Temporal interpolation (linear)
+ !************************************
+
+ u=(uh(1)*dt2+uh(2)*dt1)*dtt
+ v=(vh(1)*dt2+vh(2)*dt1)*dtt
+ w=(wh(1)*dt2+wh(2)*dt1)*dtt
+
+end subroutine interpol_wind_short_nests
diff --git a/src/juldate.f90 b/src/juldate.f90
new file mode 100644
index 0000000000000000000000000000000000000000..6d0303ef8a663b84a1272cf148a04a4071e500e0
--- /dev/null
+++ b/src/juldate.f90
@@ -0,0 +1,85 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+function juldate(yyyymmdd,hhmiss)
+
+ !*****************************************************************************
+ ! *
+ ! Calculates the Julian date *
+ ! *
+ ! AUTHOR: Andreas Stohl (15 October 1993) *
+ ! *
+ ! Variables: *
+ ! dd Day *
+ ! hh Hour *
+ ! hhmiss Hour, minute + second *
+ ! ja,jm,jy help variables *
+ ! juldate Julian Date *
+ ! julday help variable *
+ ! mi Minute *
+ ! mm Month *
+ ! ss Second *
+ ! yyyy Year *
+ ! yyyymmddhh Date and Time *
+ ! *
+ ! Constants: *
+ ! igreg help constant *
+ ! *
+ !*****************************************************************************
+
+ use par_mod, only: dp
+
+ implicit none
+
+ integer :: yyyymmdd,yyyy,mm,dd,hh,mi,ss,hhmiss
+ integer :: julday,jy,jm,ja
+ integer,parameter :: igreg=15+31*(10+12*1582)
+ real(kind=dp) :: juldate
+
+ yyyy=yyyymmdd/10000
+ mm=(yyyymmdd-10000*yyyy)/100
+ dd=yyyymmdd-10000*yyyy-100*mm
+ hh=hhmiss/10000
+ mi=(hhmiss-10000*hh)/100
+ ss=hhmiss-10000*hh-100*mi
+
+ if (yyyy.eq.0) then
+ print*, 'there is no year zero.'
+ stop
+ end if
+ if (yyyy.lt.0) yyyy=yyyy+1
+ if (mm.gt.2) then
+ jy=yyyy
+ jm=mm+1
+ else
+ jy=yyyy-1
+ jm=mm+13
+ endif
+ julday=int(365.25*jy)+int(30.6001*jm)+dd+1720995
+ if (dd+31*(mm+12*yyyy).ge.igreg) then
+ ja=int(0.01*jy)
+ julday=julday+2-ja+int(0.25*ja)
+ endif
+
+ juldate=real(julday,kind=dp) + real(hh,kind=dp)/24._dp + &
+ real(mi,kind=dp)/1440._dp + real(ss,kind=dp)/86400._dp
+
+end function juldate
diff --git a/src/makefile b/src/makefile
new file mode 100644
index 0000000000000000000000000000000000000000..4275e31523ba1d6b603c8a418cc9ba4307fe9cca
--- /dev/null
+++ b/src/makefile
@@ -0,0 +1,119 @@
+SHELL = /bin/bash
+TARGET = local
+WINDS=ecmwf
+#WINDS=gfs
+#WINDS=fnl
+
+FC = gfortran
+FFLAGS = -O2 -m64 -mcmodel=medium -fconvert=little-endian -frecord-marker=4 -I$(INCPATH)
+
+ifeq ($(TARGET),dmz)
+ # options for ganglia
+ INCPATH = /xnilu_wrk/flex_wrk/bin64/grib_api/include
+ LIBPATH1 = /xnilu_wrk/flex_wrk/bin64/grib_api/lib
+ LIBPATH2 = /usr/lib/x86_64-linux-gnu/
+ MAIN = FLEXPART_dmz_
+endif
+ifeq ($(TARGET),local)
+ # local options
+ #libs_dir=/.../flexpart/libs/
+ libs_dir=/Users/ignacio/flexpart/libs/
+ INCPATH = $(libs_dir)/grib_api-1.9.9_dir/include
+ LIBPATH1 = $(libs_dir)/grib_api-1.9.9_dir/lib
+ LIBPATH2 = $(libs_dir)/jasper_dir/lib
+ MAIN = FLEXPART_local_
+endif
+
+LDFLAGS = $(FFLAGS) -L$(LIBPATH2) -L$(LIBPATH1) -lgrib_api_f90 -lgrib_api -lm -ljasper
+
+MODOBJS = \
+par_mod.o com_mod.o \
+conv_mod.o hanna_mod.o \
+interpol_mod.o cmapf_mod.o \
+unc_mod.o oh_mod.o \
+xmass_mod.o flux_mod.o \
+point_mod.o outg_mod.o
+
+OBJECTS = \
+writeheader.o writeheader_txt.o writeheader_surf.o assignland.o\
+ part0.o \
+caldate.o partdep.o \
+coordtrafo.o psih.o \
+raerod.o \
+drydepokernel.o random.o \
+erf.o readavailable.o \
+ew.o readcommand.o \
+advance.o readdepo.o \
+releaseparticles.o psim.o \
+FLEXPART.o readlanduse.o \
+getfields.o init_domainfill.o\
+interpol_wind.o readoutgrid.o \
+interpol_all.o readpaths.o \
+getrb.o readreceptors.o \
+getrc.o readreleases.o \
+getvdep.o readspecies.o \
+interpol_misslev.o \
+conccalc.o \
+concoutput.o concoutput_surf.o scalev.o \
+pbl_profile.o readOHfield.o\
+juldate.o timemanager.o \
+interpol_vdep.o interpol_rain.o \
+partoutput.o \
+hanna.o wetdepokernel.o \
+mean.o wetdepo.o \
+hanna_short.o windalign.o \
+hanna1.o initialize.o \
+ calcpar_nests.o \
+verttransform_nests.o interpol_all_nests.o \
+interpol_wind_nests.o interpol_misslev_nests.o \
+interpol_vdep_nests.o interpol_rain_nests.o \
+getvdep_nests.o gridcheck_nests.o \
+readwind_nests.o \
+readageclasses.o readpartpositions.o \
+calcfluxes.o fluxoutput.o \
+qvsat.o skplin.o \
+convect43c.o redist.o \
+sort2.o distance.o \
+centerofmass.o plumetraj.o \
+openouttraj.o calcpv.o \
+calcpv_nests.o distance2.o \
+clustering.o interpol_wind_short.o \
+interpol_wind_short_nests.o shift_field_0.o \
+shift_field.o outgrid_init.o \
+openreceptors.o boundcond_domainfill.o\
+partoutput_short.o readoutgrid_nest.o \
+outgrid_init_nest.o writeheader_nest.o writeheader_nest_surf.o \
+concoutput_nest.o concoutput_surf_nest.o wetdepokernel_nest.o \
+drydepokernel_nest.o zenithangle.o \
+ohreaction.o getvdep_nests.o \
+initial_cond_calc.o initial_cond_output.o \
+dynamic_viscosity.o get_settling.o
+
+
+ifeq ($(WINDS),ecmwf)
+ OBJECTS_WINDS = \
+ calcpar.o readwind.o \
+ richardson.o verttransform.o \
+ obukhov.o gridcheck.o \
+ convmix.o calcmatrix.o
+endif
+
+ifeq ($(WINDS),gfs)
+ OBJECTS_WINDS = \
+ calcpar_gfs.o readwind_gfs.o \
+ richardson_gfs.o verttransform_gfs.o \
+ obukhov_gfs.o gridcheck_gfs.o \
+ convmix_gfs.o calcmatrix_gfs.o
+endif
+
+$(MAIN): $(MODOBJS) $(OBJECTS) $(OBJECTS_WINDS)
+ $(FC) *.o -o $(MAIN)_$(WINDS) $(LDFLAGS)
+
+$(OBJECTS): $(MODOBJS)
+
+%.o: %.f90
+ $(FC) -c $(FFLAGS) $<
+
+clean:
+ rm *.o *.mod
+
diff --git a/src/mean.f90 b/src/mean.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d662f7f4665b1bf0c58ec33acfc534cba526fee8
--- /dev/null
+++ b/src/mean.f90
@@ -0,0 +1,66 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine mean(x,xm,xs,number)
+
+ !*****************************************************************************
+ ! *
+ ! This subroutine calculates mean and standard deviation of a given element.*
+ ! *
+ ! AUTHOR: Andreas Stohl, 25 January 1994 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! x(number) field of input data *
+ ! xm mean *
+ ! xs standard deviation *
+ ! number number of elements of field x *
+ ! *
+ ! Constants: *
+ ! eps tiny number *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ integer :: number,i
+ real :: x(number),xm,xs,xl,xq,xaux
+ real,parameter :: eps=1.0e-30
+
+ xl=0.
+ xq=0.
+ do i=1,number
+ xl=xl+x(i)
+ xq=xq+x(i)*x(i)
+ end do
+
+ xm=xl/real(number)
+
+ xaux=xq-xl*xl/real(number)
+
+ if (xaux.lt.eps) then
+ xs=0.
+ else
+ xs=sqrt(xaux/real(number-1))
+ endif
+
+end subroutine mean
diff --git a/src/obukhov.f90 b/src/obukhov.f90
new file mode 100644
index 0000000000000000000000000000000000000000..a9fd70ea9d946aaed7c7fb4a8108ac578ba3c555
--- /dev/null
+++ b/src/obukhov.f90
@@ -0,0 +1,78 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+real function obukhov(ps,tsurf,tdsurf,tlev,ustar,hf,akm,bkm)
+
+ !********************************************************************
+ ! *
+ ! Author: G. WOTAWA *
+ ! Date: 1994-06-27 *
+ ! *
+ ! Update: A. Stohl, 2000-09-25, avoid division by zero by *
+ ! setting ustar to minimum value *
+ ! *
+ !********************************************************************
+ ! *
+ ! This program calculates Obukhov scale height from surface *
+ ! meteorological data and sensible heat flux. *
+ ! *
+ !********************************************************************
+ ! *
+ ! INPUT: *
+ ! *
+ ! ps surface pressure [Pa] *
+ ! tsurf surface temperature [K] *
+ ! tdsurf surface dew point [K] *
+ ! tlev temperature first model level [K] *
+ ! ustar scale velocity [m/s] *
+ ! hf surface sensible heat flux [W/m2] *
+ ! akm ECMWF vertical discretization parameter *
+ ! bkm ECMWF vertical discretization parameter *
+ ! *
+ !********************************************************************
+
+ use par_mod
+
+ implicit none
+
+ real :: akm(nwzmax),bkm(nwzmax)
+ real :: ps,tsurf,tdsurf,tlev,ustar,hf,e,ew,tv,rhoa,plev
+ real :: ak1,bk1,theta,thetastar
+
+
+ e=ew(tdsurf) ! vapor pressure
+ tv=tsurf*(1.+0.378*e/ps) ! virtual temperature
+ rhoa=ps/(r_air*tv) ! air density
+ ak1=(akm(1)+akm(2))/2.
+ bk1=(bkm(1)+bkm(2))/2.
+ plev=ak1+bk1*ps ! Pressure level 1
+ theta=tlev*(100000./plev)**(r_air/cpa) ! potential temperature
+ if (ustar.le.0.) ustar=1.e-8
+ thetastar=hf/(rhoa*cpa*ustar) ! scale temperature
+ if(abs(thetastar).gt.1.e-10) then
+ obukhov=theta*ustar**2/(karman*ga*thetastar)
+ else
+ obukhov=9999 ! zero heat flux
+ endif
+ if (obukhov.gt. 9999.) obukhov= 9999.
+ if (obukhov.lt.-9999.) obukhov=-9999.
+
+end function obukhov
diff --git a/src/obukhov_gfs.f90 b/src/obukhov_gfs.f90
new file mode 100644
index 0000000000000000000000000000000000000000..ad3c5a2b8e4b3cb9d338ab70492993d4d80de346
--- /dev/null
+++ b/src/obukhov_gfs.f90
@@ -0,0 +1,76 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+real function obukhov(ps,tsurf,tdsurf,tlev,ustar,hf,plev)
+
+ !********************************************************************
+ ! *
+ ! Author: G. WOTAWA *
+ ! Date: 1994-06-27 *
+ ! *
+ ! Update: A. Stohl, 2000-09-25, avoid division by zero by *
+ ! setting ustar to minimum value *
+ ! *
+ ! CHANGE: 17/11/2005 Caroline Forster NCEP GFS version *
+ ! *
+ !********************************************************************
+ ! *
+ ! This program calculates Obukhov scale height from surface *
+ ! meteorological data and sensible heat flux. *
+ ! *
+ !********************************************************************
+ ! *
+ ! INPUT: *
+ ! *
+ ! ps surface pressure [Pa] *
+ ! tsurf surface temperature [K] *
+ ! tdsurf surface dew point [K] *
+ ! tlev temperature first model level [K] *
+ ! ustar scale velocity [m/s] *
+ ! hf surface sensible heat flux [W/m2] *
+ ! akm ECMWF vertical discretization parameter *
+ ! bkm ECMWF vertical discretization parameter *
+ ! *
+ !********************************************************************
+
+ use par_mod
+
+ implicit none
+
+ real :: ps,tsurf,tdsurf,tlev,ustar,hf,e,ew,tv,rhoa,plev
+ real :: theta,thetastar
+
+
+ e=ew(tdsurf) ! vapor pressure
+ tv=tsurf*(1.+0.378*e/ps) ! virtual temperature
+ rhoa=ps/(r_air*tv) ! air density
+ theta=tlev*(100000./plev)**(r_air/cpa) ! potential temperature
+ if (ustar.le.0.) ustar=1.e-8
+ thetastar=hf/(rhoa*cpa*ustar) ! scale temperature
+ if(abs(thetastar).gt.1.e-10) then
+ obukhov=theta*ustar**2/(karman*ga*thetastar)
+ else
+ obukhov=9999 ! zero heat flux
+ endif
+ if (obukhov.gt. 9999.) obukhov= 9999.
+ if (obukhov.lt.-9999.) obukhov=-9999.
+
+end function obukhov
diff --git a/src/oh_mod.f90 b/src/oh_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..0cb0b01eda1b6905fba3a1586f41bc067e4dfe06
--- /dev/null
+++ b/src/oh_mod.f90
@@ -0,0 +1,32 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+module oh_mod
+
+ !includes OH concentration field as well as the height information
+ !for this field
+
+ implicit none
+
+ real,allocatable, dimension (:,:,:,:) :: OH_field
+ real,allocatable, dimension (:) :: OH_field_height
+
+end module oh_mod
diff --git a/src/ohreaction.f90 b/src/ohreaction.f90
new file mode 100644
index 0000000000000000000000000000000000000000..ea0bb0c4c269fa965d700d90dca22fe5af0e4084
--- /dev/null
+++ b/src/ohreaction.f90
@@ -0,0 +1,213 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine ohreaction(itime,ltsample,loutnext)
+ ! i i i
+ !*****************************************************************************
+ ! *
+ ! *
+ ! Author: S. Eckhardt *
+ ! *
+ ! June 2007 *
+ ! *
+ ! *
+ !*****************************************************************************
+ ! Variables: *
+ ! ix,jy indices of output grid cell for each particle *
+ ! itime [s] actual simulation time [s] *
+ ! jpart particle index *
+ ! ldeltat [s] interval since radioactive decay was computed *
+ ! loutnext [s] time for which gridded deposition is next output *
+ ! loutstep [s] interval at which gridded deposition is output *
+ ! oh_average [mol/m^3] OH Concentration *
+ ! ltsample [s] interval over which mass is deposited *
+ ! *
+ !*****************************************************************************
+
+ use oh_mod
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: jpart,itime,ltsample,loutnext,ldeltat,j,k,ix,jy
+ integer :: ngrid,il,interp_time,n,mm,indz,i
+ integer :: jjjjmmdd,ihmmss,OHx,OHy,dOHx,dOHy,OHz
+ real :: xtn,ytn,oh_average
+ !real oh_diurn_var,sum_ang
+ !real zenithangle, ang
+ real :: restmass,ohreacted,OHinc
+ real :: xlon, ylat, gas_const, act_energy
+ real :: ohreact_temp_corr, act_temp
+ real,parameter :: smallnum = tiny(0.0) ! smallest number that can be handled
+ real(kind=dp) :: jul
+
+ ! Compute interval since radioactive decay of deposited mass was computed
+ !************************************************************************
+
+ gas_const=8.314 ! define gas constant
+ act_energy=10000 ! activation energy
+
+ !write(*,*) 'OH reaction n:',n,ohreact(1)
+ if (itime.le.loutnext) then
+ ldeltat=itime-(loutnext-loutstep)
+ else ! first half of next interval
+ ldeltat=itime-loutnext
+ endif
+
+
+ dOHx=360/(maxxOH-1)
+ dOHy=180/(maxyOH-1)
+
+ jul=bdate+real(itime,kind=dp)/86400._dp
+ call caldate(jul,jjjjmmdd,ihmmss)
+ mm=int((jjjjmmdd-(jjjjmmdd/10000)*10000)/100)
+
+ do jpart=1,numpart
+
+ ! Determine which nesting level to be used
+ !*****************************************
+
+ ngrid=0
+ do j=numbnests,1,-1
+ if ((xtra1(jpart).gt.xln(j)).and.(xtra1(jpart).lt.xrn(j)).and. &
+ (ytra1(jpart).gt.yln(j)).and.(ytra1(jpart).lt.yrn(j))) then
+ ngrid=j
+ goto 23
+ endif
+ end do
+23 continue
+
+
+ ! Determine nested grid coordinates
+ !**********************************
+
+ if (ngrid.gt.0) then
+ xtn=(xtra1(jpart)-xln(ngrid))*xresoln(ngrid)
+ ytn=(ytra1(jpart)-yln(ngrid))*yresoln(ngrid)
+ ix=int(xtn)
+ jy=int(ytn)
+ else
+ ix=int(xtra1(jpart))
+ jy=int(ytra1(jpart))
+ endif
+
+ n=2
+ if (abs(memtime(1)-interp_time).lt.abs(memtime(2)-interp_time)) &
+ n=1
+
+ do i=2,nz
+ if (height(i).gt.ztra1(jpart)) then
+ indz=i-1
+ goto 6
+ endif
+ end do
+6 continue
+
+ ! The concentration from the nearest available gridcell is taken
+ ! get OH concentration for the specific month and solar angle
+
+ ! write(*,*) OH_field(1,1,1,1),OH_field(10,1,1,10)
+ ! write(*,*) OH_field(1,maxxOH-1,maxyOH-1,1)
+ ! write(*,*) OH_field(10,maxxOH-1,maxyOH-1,10)
+ ! write(*,*) OH_field_height(1,10,4,1),OH_field_height(10,4,10,10)
+ ! write(*,*) OH_field_height(1,maxxOH-1,maxyOH-1,1)
+ ! write(*,*) OH_field_height(10,maxxOH-1,maxyOH-1,10)
+ interp_time=nint(itime-0.5*ltsample)
+
+ ! World coordinates
+ xlon=xtra1(jpart)*dx+xlon0
+ if (xlon.gt.180) then
+ xlon=xlon-360
+ endif
+ ylat=ytra1(jpart)*dy+ylat0
+ ! get position in the OH field - assume that the OH field is global
+ OHx=(180+xlon-1)/dOHx
+ OHy=(90+ylat-1)/dOHy
+ ! sum_ang=0
+ ! get the level of the OH height field were the actual particle is in
+ ! ztra1 is the z-coordinate of the trajectory above model orography in m
+ ! OH_field_height is the heigth of the OH field above orography
+ OHz=maxzOH
+ ! assume equally distrib. OH field, OH_field_height gives the middle of
+ ! the z coordinate
+ OHinc=(OH_field_height(3)-OH_field_height(2))/2
+ do il=2,maxzOH+1
+ if ((OH_field_height(il-1)+OHinc).gt.ztra1(jpart)) goto 26
+ end do
+26 continue
+
+ OHz=il-1
+ ! loop was not interrupted il would be 8 (9-1)
+ if (OHz.gt.maxzOH) OHz=7
+ ! write (*,*) 'OH height: '
+ ! + ,ztra1(jpart),jpart,OHz,OH_field_height(OHz),OHinc,
+ ! + OH_field_height
+
+ oh_average=OH_field(mm,OHx,OHy,OHz)
+ if (oh_average.gt.smallnum) then
+ !**********************************************************
+ ! if there is noOH concentration no reaction
+ ! for performance reason take average concentration and
+ ! ignore diurnal variation
+ ! do 28 il=1,24
+ ! ang=70-zenithangle(ylat,xlon,jul+(24-il)/24.)
+ ! if (ang.lt.0) then
+ ! ang=0
+ ! endif
+ ! sum_ang=sum_ang+ang
+ !28 enddo
+ ! oh_diurn_var=(ang/sum_ang)*(oh_average*24)
+ ! oh_average=oh_diurn_var
+ !**********************************************************
+
+
+ ! Computation of the OH reaction
+ !**********************************************************
+ act_temp=tt(ix,jy,indz,n)
+
+ do k=1,nspec ! loop over species
+ if (ohreact(k).gt.0.) then
+ ohreact_temp_corr=ohreact(k)*oh_average* &
+ exp((act_energy/gas_const)*(1/298.15-1/act_temp))
+ ohreacted=xmass1(jpart,k)* &
+ (1.-exp(-1*ohreact_temp_corr*abs(ltsample)))
+ ! new particle mass:
+ restmass = xmass1(jpart,k)-ohreacted
+ if (restmass .gt. smallnum) then
+ xmass1(jpart,k)=restmass
+ ! write (104) xlon,ylat,ztra1(jpart),k,oh_diurn_var,jjjjmmdd,
+ ! + ihmmss,restmass,ohreacted
+ else
+ xmass1(jpart,k)=0.
+ endif
+ ! write (*,*) 'restmass: ',restmass
+ else
+ ohreacted=0.
+ endif
+ end do
+
+ endif
+ !endif OH concentration gt 0
+ end do
+ !continue loop over all particles
+
+end subroutine ohreaction
diff --git a/src/openouttraj.f90 b/src/openouttraj.f90
new file mode 100644
index 0000000000000000000000000000000000000000..1844668cef550b7c5d6d1d2dded4b25e469424d2
--- /dev/null
+++ b/src/openouttraj.f90
@@ -0,0 +1,85 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine openouttraj
+
+ !*****************************************************************************
+ ! *
+ ! This routine opens the output file for the plume trajectory output *
+ ! produced by the cluster analysis. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 27 January 2001 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ !*****************************************************************************
+
+ use point_mod
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: i
+ real :: xp1,yp1,xp2,yp2
+
+
+ ! Open output file for trajectory output
+ !***************************************
+
+ open(unitouttraj,file=path(2)(1:length(2))//'trajectories.txt', &
+ form='formatted',err=998)
+
+ if (ldirect.eq.1) then
+ write(unitouttraj,'(i8,1x,i6,1x,a)') ibdate,ibtime, trim(flexversion)
+ else
+ write(unitouttraj,'(i8,1x,i6,1x,a)') iedate,ietime, trim(flexversion)
+ endif
+ write(unitouttraj,*) method,lsubgrid,lconvection
+ write(unitouttraj,*) numpoint
+ do i=1,numpoint
+ xp1=xpoint1(i)*dx+xlon0
+ yp1=ypoint1(i)*dy+ylat0
+ xp2=xpoint2(i)*dx+xlon0
+ yp2=ypoint2(i)*dy+ylat0
+ write(unitouttraj,*) ireleasestart(i),ireleaseend(i), &
+ xp1,yp1,xp2,yp2,zpoint1(i),zpoint2(i),kindz(i),npart(i)
+ if (numpoint.le.1000) then
+ write(unitouttraj,'(a)') compoint(i)(1:40)
+ else
+ write(unitouttraj,'(a)') compoint(1001)(1:40)
+ endif
+ end do
+
+ return
+
+998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### '
+ write(*,*) ' #### trajectories.txt #### '
+ write(*,*) ' #### CANNOT BE OPENED. IF A FILE WITH THIS #### '
+ write(*,*) ' #### NAME ALREADY EXISTS, DELETE IT AND START #### '
+ write(*,*) ' #### THE PROGRAM AGAIN. #### '
+ stop
+
+end subroutine openouttraj
diff --git a/src/openreceptors.f90 b/src/openreceptors.f90
new file mode 100644
index 0000000000000000000000000000000000000000..4958b6b8b8f30c96cccd22f275ea0075785701c0
--- /dev/null
+++ b/src/openreceptors.f90
@@ -0,0 +1,93 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine openreceptors
+
+ !*****************************************************************************
+ ! *
+ ! This routine opens the receptor output files and writes out the receptor *
+ ! names and the receptor locations. The receptor output files are not *
+ ! closed, but kept open throughout the simulation. Concentrations are *
+ ! continuously dumped to these files. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 7 August 2002 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! numreceptor actual number of receptor points specified *
+ ! receptornames names of the receptor points *
+ ! xreceptor,yreceptor coordinates of the receptor points *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: j
+
+ ! Open output file for receptor points and write out a short header
+ ! containing receptor names and locations
+ !******************************************************************
+
+ if (numreceptor.ge.1) then ! do it only if receptors are specified
+
+ ! Concentration output
+ !*********************
+
+ if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then
+ open(unitoutrecept,file=path(2)(1:length(2))//'receptor_conc', &
+ form='unformatted',err=997)
+ write(unitoutrecept) (receptorname(j),j=1,numreceptor)
+ write(unitoutrecept) (xreceptor(j)*dx+xlon0, &
+ yreceptor(j)*dy+ylat0,j=1,numreceptor)
+ endif
+
+ ! Mixing ratio output
+ !********************
+
+ if ((iout.eq.2).or.(iout.eq.3)) then
+ open(unitoutreceptppt,file=path(2)(1:length(2))//'receptor_pptv', &
+ form='unformatted',err=998)
+ write(unitoutreceptppt) (receptorname(j),j=1,numreceptor)
+ write(unitoutreceptppt) (xreceptor(j)*dx+xlon0, &
+ yreceptor(j)*dy+ylat0,j=1,numreceptor)
+ endif
+ endif
+
+ return
+
+
+997 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### '
+ write(*,*) ' #### receptor_conc #### '
+ write(*,*) ' #### CANNOT BE OPENED. #### '
+ stop
+
+998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### '
+ write(*,*) ' #### receptor_pptv #### '
+ write(*,*) ' #### CANNOT BE OPENED. #### '
+ stop
+
+end subroutine openreceptors
diff --git a/src/outg_mod.f90 b/src/outg_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..dfa74d58623d93aedfe9e90dbc30066aba1ef5a0
--- /dev/null
+++ b/src/outg_mod.f90
@@ -0,0 +1,48 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+module outg_mod
+
+ implicit none
+
+ real,allocatable, dimension (:) :: outheight
+ real,allocatable, dimension (:) :: outheighthalf
+ real,allocatable, dimension (:,:) :: oroout
+ real,allocatable, dimension (:,:) :: orooutn
+ real,allocatable, dimension (:,:) :: area
+ real,allocatable, dimension (:,:) :: arean
+ real,allocatable, dimension (:,:,:) :: volume
+ real,allocatable, dimension (:,:,:) :: volumen
+ real,allocatable, dimension (:,:,:) :: areaeast
+ real,allocatable, dimension (:,:,:) :: areanorth
+ real,allocatable, dimension (:,:,:) :: densityoutgrid
+ real,allocatable, dimension (:,:,:) :: factor3d
+ real,allocatable, dimension (:,:,:) :: grid
+ real,allocatable, dimension (:,:) :: wetgrid
+ real,allocatable, dimension (:,:) :: drygrid
+ real,allocatable, dimension (:,:,:) :: gridsigma
+ real,allocatable, dimension (:,:) :: drygridsigma
+ real,allocatable, dimension (:,:) :: wetgridsigma
+ real,allocatable, dimension (:) :: sparse_dump_r
+ real,allocatable, dimension (:) :: sparse_dump_u
+ integer,allocatable, dimension (:) :: sparse_dump_i
+
+end module outg_mod
diff --git a/src/outgrid_init.f90 b/src/outgrid_init.f90
new file mode 100644
index 0000000000000000000000000000000000000000..64cd47e039ebcafe7391ac3b712fd38037d613ba
--- /dev/null
+++ b/src/outgrid_init.f90
@@ -0,0 +1,323 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine outgrid_init
+ !
+ !*****************************************************************************
+ ! *
+ ! This routine initializes the output grids *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 7 August 2002 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! area surface area of all output grid cells *
+ ! areaeast eastward facing wall area of all output grid cells *
+ ! areanorth northward facing wall area of all output grid cells *
+ ! volume volumes of all output grid cells *
+ ! *
+ !*****************************************************************************
+
+ use flux_mod
+ use oh_mod
+ use unc_mod
+ use outg_mod
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: ix,jy,kz,i,nage,l,iix,jjy,ixp,jyp,i1,j1,j,ngrid
+ integer :: ks,kp,stat
+ real :: ylat,gridarea,ylatp,ylatm,hzone,cosfactm,cosfactp
+ real :: xlon,xl,yl,ddx,ddy,rddx,rddy,p1,p2,p3,p4,xtn,ytn,oroh
+ real,parameter :: eps=nxmax/3.e5
+
+
+ ! Compute surface area and volume of each grid cell: area, volume;
+ ! and the areas of the northward and eastward facing walls: areaeast, areanorth
+ !***********************************************************************
+ do jy=0,numygrid-1
+ ylat=outlat0+(real(jy)+0.5)*dyout
+ ylatp=ylat+0.5*dyout
+ ylatm=ylat-0.5*dyout
+ if ((ylatm.lt.0).and.(ylatp.gt.0.)) then
+ hzone=dyout*r_earth*pi180
+ else
+
+ ! Calculate area of grid cell with formula M=2*pi*R*h*dx/360,
+ ! see Netz, Formeln der Mathematik, 5. Auflage (1983), p.90
+ !************************************************************
+
+ cosfactp=cos(ylatp*pi180)
+ cosfactm=cos(ylatm*pi180)
+ if (cosfactp.lt.cosfactm) then
+ hzone=sqrt(1-cosfactp**2)- &
+ sqrt(1-cosfactm**2)
+ hzone=hzone*r_earth
+ else
+ hzone=sqrt(1-cosfactm**2)- &
+ sqrt(1-cosfactp**2)
+ hzone=hzone*r_earth
+ endif
+ endif
+
+ ! Surface are of a grid cell at a latitude ylat
+ !**********************************************
+
+ gridarea=2.*pi*r_earth*hzone*dxout/360.
+
+ do ix=0,numxgrid-1
+ area(ix,jy)=gridarea
+
+ ! Volume = area x box height
+ !***************************
+
+ volume(ix,jy,1)=area(ix,jy)*outheight(1)
+ areaeast(ix,jy,1)=dyout*r_earth*pi180*outheight(1)
+ areanorth(ix,jy,1)=cos(ylat*pi180)*dxout*r_earth*pi180* &
+ outheight(1)
+ do kz=2,numzgrid
+ areaeast(ix,jy,kz)=dyout*r_earth*pi180* &
+ (outheight(kz)-outheight(kz-1))
+ areanorth(ix,jy,kz)=cos(ylat*pi180)*dxout*r_earth*pi180* &
+ (outheight(kz)-outheight(kz-1))
+ volume(ix,jy,kz)=area(ix,jy)*(outheight(kz)-outheight(kz-1))
+ end do
+ end do
+ end do
+
+
+
+
+ !******************************************************************
+ ! Determine average height of model topography in output grid cells
+ !******************************************************************
+
+ ! Loop over all output grid cells
+ !********************************
+
+ do jjy=0,numygrid-1
+ do iix=0,numxgrid-1
+ oroh=0.
+
+ ! Take 100 samples of the topography in every grid cell
+ !******************************************************
+
+ do j1=1,10
+ ylat=outlat0+(real(jjy)+real(j1)/10.-0.05)*dyout
+ yl=(ylat-ylat0)/dy
+ do i1=1,10
+ xlon=outlon0+(real(iix)+real(i1)/10.-0.05)*dxout
+ xl=(xlon-xlon0)/dx
+
+ ! Determine the nest we are in
+ !*****************************
+
+ ngrid=0
+ do j=numbnests,1,-1
+ if ((xl.gt.xln(j)+eps).and.(xl.lt.xrn(j)-eps).and. &
+ (yl.gt.yln(j)+eps).and.(yl.lt.yrn(j)-eps)) then
+ ngrid=j
+ goto 43
+ endif
+ end do
+43 continue
+
+ ! Determine (nested) grid coordinates and auxiliary parameters used for interpolation
+ !*****************************************************************************
+
+ if (ngrid.gt.0) then
+ xtn=(xl-xln(ngrid))*xresoln(ngrid)
+ ytn=(yl-yln(ngrid))*yresoln(ngrid)
+ ix=int(xtn)
+ jy=int(ytn)
+ ddy=ytn-real(jy)
+ ddx=xtn-real(ix)
+ else
+ ix=int(xl)
+ jy=int(yl)
+ ddy=yl-real(jy)
+ ddx=xl-real(ix)
+ endif
+ ixp=ix+1
+ jyp=jy+1
+ rddx=1.-ddx
+ rddy=1.-ddy
+ p1=rddx*rddy
+ p2=ddx*rddy
+ p3=rddx*ddy
+ p4=ddx*ddy
+
+ if (ngrid.gt.0) then
+ oroh=oroh+p1*oron(ix ,jy ,ngrid) &
+ + p2*oron(ixp,jy ,ngrid) &
+ + p3*oron(ix ,jyp,ngrid) &
+ + p4*oron(ixp,jyp,ngrid)
+ else
+ oroh=oroh+p1*oro(ix ,jy) &
+ + p2*oro(ixp,jy) &
+ + p3*oro(ix ,jyp) &
+ + p4*oro(ixp,jyp)
+ endif
+ end do
+ end do
+
+ ! Divide by the number of samples taken
+ !**************************************
+
+ oroout(iix,jjy)=oroh/100.
+ end do
+ end do
+
+ ! if necessary allocate flux fields
+ if (iflux.eq.1) then
+ allocate(flux(6,0:numxgrid-1,0:numygrid-1,numzgrid, &
+ 1:nspec,1:maxpointspec_act,1:nageclass),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate flux array '
+ endif
+
+ !write (*,*) 'allocating: in a sec',OHREA
+ if (OHREA.eqv..TRUE.) then
+ ! write (*,*) 'allocating: ',maxxOH,maxyOH,maxzOH
+ allocate(OH_field(12,0:maxxOH-1,0:maxyOH-1,maxzOH) &
+ ,stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate OH array '
+ allocate(OH_field_height(7) &
+ ,stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate OH array '
+ endif
+ ! gridunc,griduncn uncertainty of outputted concentrations
+ allocate(gridunc(0:numxgrid-1,0:numygrid-1,numzgrid,maxspec, &
+ maxpointspec_act,nclassunc,maxageclass),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
+ if (ldirect.gt.0) then
+ allocate(wetgridunc(0:numxgrid-1,0:numygrid-1,maxspec, &
+ maxpointspec_act,nclassunc,maxageclass),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
+ allocate(drygridunc(0:numxgrid-1,0:numygrid-1,maxspec, &
+ maxpointspec_act,nclassunc,maxageclass),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
+ endif
+ !write (*,*) 'Dimensions for fields', numxgrid,numygrid, &
+ ! maxspec,maxpointspec_act,nclassunc,maxageclass
+
+ write (*,*) ' Allocating fields for nested and global output (x,y): ', &
+ max(numxgrid,numxgridn),max(numygrid,numygridn)
+
+ ! allocate fields for concoutput with maximum dimension of outgrid
+ ! and outgrid_nest
+
+ allocate(gridsigma(0:max(numxgrid,numxgridn)-1, &
+ 0:max(numygrid,numygridn)-1,numzgrid),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
+ allocate(grid(0:max(numxgrid,numxgridn)-1, &
+ 0:max(numygrid,numygridn)-1,numzgrid),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
+ allocate(densityoutgrid(0:max(numxgrid,numxgridn)-1, &
+ 0:max(numygrid,numygridn)-1,numzgrid),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
+
+ allocate(factor3d(0:max(numxgrid,numxgridn)-1, &
+ 0:max(numygrid,numygridn)-1,numzgrid),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
+ allocate(sparse_dump_r(max(numxgrid,numxgridn)* &
+ max(numygrid,numygridn)*numzgrid),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
+
+ allocate(sparse_dump_u(max(numxgrid,numxgridn)* &
+ max(numygrid,numygridn)*numzgrid),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
+
+ allocate(sparse_dump_i(max(numxgrid,numxgridn)* &
+ max(numygrid,numygridn)*numzgrid),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
+
+ ! deposition fields are only allocated for forward runs
+ if (ldirect.gt.0) then
+ allocate(wetgridsigma(0:max(numxgrid,numxgridn)-1, &
+ 0:max(numygrid,numygridn)-1),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
+ allocate(drygridsigma(0:max(numxgrid,numxgridn)-1, &
+ 0:max(numygrid,numygridn)-1),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
+ allocate(wetgrid(0:max(numxgrid,numxgridn)-1, &
+ 0:max(numygrid,numygridn)-1),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
+ allocate(drygrid(0:max(numxgrid,numxgridn)-1, &
+ 0:max(numygrid,numygridn)-1),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
+ endif
+
+ ! Initial condition field
+
+ if (linit_cond.gt.0) then
+ allocate(init_cond(0:numxgrid-1,0:numygrid-1,numzgrid,maxspec, &
+ maxpointspec_act),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate init_cond'
+ endif
+
+ !************************
+ ! Initialize output grids
+ !************************
+
+ do ks=1,nspec
+ do kp=1,maxpointspec_act
+ do i=1,numreceptor
+ ! Receptor points
+ creceptor(i,ks)=0.
+ end do
+ do nage=1,nageclass
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ do l=1,nclassunc
+ ! Deposition fields
+ if (ldirect.gt.0) then
+ wetgridunc(ix,jy,ks,kp,l,nage)=0.
+ drygridunc(ix,jy,ks,kp,l,nage)=0.
+ endif
+ do kz=1,numzgrid
+ if (iflux.eq.1) then
+ ! Flux fields
+ do i=1,5
+ flux(i,ix,jy,kz,ks,kp,nage)=0.
+ end do
+ endif
+ ! Initial condition field
+ if ((l.eq.1).and.(nage.eq.1).and.(linit_cond.gt.0)) &
+ init_cond(ix,jy,kz,ks,kp)=0.
+ ! Concentration fields
+ gridunc(ix,jy,kz,ks,kp,l,nage)=0.
+ end do
+ end do
+ end do
+ end do
+ end do
+ end do
+ end do
+
+
+
+end subroutine outgrid_init
diff --git a/src/outgrid_init_nest.f90 b/src/outgrid_init_nest.f90
new file mode 100644
index 0000000000000000000000000000000000000000..b33e7293a7840ae12fc67e09610717bb1bf50176
--- /dev/null
+++ b/src/outgrid_init_nest.f90
@@ -0,0 +1,230 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine outgrid_init_nest
+
+ !*****************************************************************************
+ ! *
+ ! This routine calculates, for each grid cell of the output nest, the *
+ ! volume and the surface area. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 30 August 2004 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! arean surface area of all output nest cells *
+ ! volumen volumes of all output nest cells *
+ ! *
+ !*****************************************************************************
+
+ use unc_mod
+ use outg_mod
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: ix,jy,kz,ks,kp,nage,l,iix,jjy,ixp,jyp,i1,j1,j,ngrid
+ integer :: stat
+ real :: ylat,gridarea,ylatp,ylatm,hzone,cosfactm,cosfactp
+ real :: xlon,xl,yl,ddx,ddy,rddx,rddy,p1,p2,p3,p4,xtn,ytn,oroh
+ real,parameter :: eps=nxmax/3.e5
+
+
+
+ ! gridunc,griduncn uncertainty of outputted concentrations
+ allocate(griduncn(0:numxgridn-1,0:numygridn-1,numzgrid,maxspec, &
+ maxpointspec_act,nclassunc,maxageclass),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR:could not allocate nested gridunc'
+
+ if (ldirect.gt.0) then
+ allocate(wetgriduncn(0:numxgridn-1,0:numygridn-1,maxspec, &
+ maxpointspec_act,nclassunc,maxageclass),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR:could not allocate nested gridunc'
+ allocate(drygriduncn(0:numxgridn-1,0:numygridn-1,maxspec, &
+ maxpointspec_act,nclassunc,maxageclass),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR:could not allocate nested gridunc'
+ endif
+
+ ! Compute surface area and volume of each grid cell: area, volume;
+ ! and the areas of the northward and eastward facing walls: areaeast, areanorth
+ !***********************************************************************
+
+ do jy=0,numygridn-1
+ ylat=outlat0n+(real(jy)+0.5)*dyoutn
+ ylatp=ylat+0.5*dyoutn
+ ylatm=ylat-0.5*dyoutn
+ if ((ylatm.lt.0).and.(ylatp.gt.0.)) then
+ hzone=dyoutn*r_earth*pi180
+ else
+
+ ! Calculate area of grid cell with formula M=2*pi*R*h*dx/360,
+ ! see Netz, Formeln der Mathematik, 5. Auflage (1983), p.90
+ !************************************************************
+
+ cosfactp=cos(ylatp*pi180)
+ cosfactm=cos(ylatm*pi180)
+ if (cosfactp.lt.cosfactm) then
+ hzone=sqrt(1-cosfactp**2)- &
+ sqrt(1-cosfactm**2)
+ hzone=hzone*r_earth
+ else
+ hzone=sqrt(1-cosfactm**2)- &
+ sqrt(1-cosfactp**2)
+ hzone=hzone*r_earth
+ endif
+ endif
+
+
+
+ ! Surface are of a grid cell at a latitude ylat
+ !**********************************************
+
+ gridarea=2.*pi*r_earth*hzone*dxoutn/360.
+
+ do ix=0,numxgridn-1
+ arean(ix,jy)=gridarea
+
+ ! Volume = area x box height
+ !***************************
+
+ volumen(ix,jy,1)=arean(ix,jy)*outheight(1)
+ do kz=2,numzgrid
+ volumen(ix,jy,kz)=arean(ix,jy)*(outheight(kz)-outheight(kz-1))
+ end do
+ end do
+ end do
+
+
+ !**************************************************************************
+ ! Determine average height of model topography in nesteed output grid cells
+ !**************************************************************************
+
+ ! Loop over all output grid cells
+ !********************************
+
+ do jjy=0,numygridn-1
+ do iix=0,numxgridn-1
+ oroh=0.
+
+ ! Take 100 samples of the topography in every grid cell
+ !******************************************************
+
+ do j1=1,10
+ ylat=outlat0n+(real(jjy)+real(j1)/10.-0.05)*dyoutn
+ yl=(ylat-ylat0)/dy
+ do i1=1,10
+ xlon=outlon0n+(real(iix)+real(i1)/10.-0.05)*dxoutn
+ xl=(xlon-xlon0)/dx
+
+ ! Determine the nest we are in
+ !*****************************
+
+ ngrid=0
+ do j=numbnests,1,-1
+ if ((xl.gt.xln(j)+eps).and.(xl.lt.xrn(j)-eps).and. &
+ (yl.gt.yln(j)+eps).and.(yl.lt.yrn(j)-eps)) then
+ ngrid=j
+ goto 43
+ endif
+ end do
+43 continue
+
+ ! Determine (nested) grid coordinates and auxiliary parameters used for interpolation
+ !*****************************************************************************
+
+ if (ngrid.gt.0) then
+ xtn=(xl-xln(ngrid))*xresoln(ngrid)
+ ytn=(yl-yln(ngrid))*yresoln(ngrid)
+ ix=int(xtn)
+ jy=int(ytn)
+ ddy=ytn-real(jy)
+ ddx=xtn-real(ix)
+ else
+ ix=int(xl)
+ jy=int(yl)
+ ddy=yl-real(jy)
+ ddx=xl-real(ix)
+ endif
+ ixp=ix+1
+ jyp=jy+1
+ rddx=1.-ddx
+ rddy=1.-ddy
+ p1=rddx*rddy
+ p2=ddx*rddy
+ p3=rddx*ddy
+ p4=ddx*ddy
+
+ if (ngrid.gt.0) then
+ oroh=oroh+p1*oron(ix ,jy ,ngrid) &
+ + p2*oron(ixp,jy ,ngrid) &
+ + p3*oron(ix ,jyp,ngrid) &
+ + p4*oron(ixp,jyp,ngrid)
+ else
+ oroh=oroh+p1*oro(ix ,jy) &
+ + p2*oro(ixp,jy) &
+ + p3*oro(ix ,jyp) &
+ + p4*oro(ixp,jyp)
+ endif
+ end do
+ end do
+
+ ! Divide by the number of samples taken
+ !**************************************
+
+ orooutn(iix,jjy)=oroh/100.
+ end do
+ end do
+
+
+
+ !*******************************
+ ! Initialization of output grids
+ !*******************************
+
+ do kp=1,maxpointspec_act
+ do ks=1,nspec
+ do nage=1,nageclass
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ do l=1,nclassunc
+ ! Deposition fields
+ if (ldirect.gt.0) then
+ wetgriduncn(ix,jy,ks,kp,l,nage)=0.
+ drygriduncn(ix,jy,ks,kp,l,nage)=0.
+ endif
+ ! Concentration fields
+ do kz=1,numzgrid
+ griduncn(ix,jy,kz,ks,kp,l,nage)=0.
+ end do
+ end do
+ end do
+ end do
+ end do
+ end do
+ end do
+
+
+end subroutine outgrid_init_nest
diff --git a/src/par_mod.f90 b/src/par_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..0f6478322a7c36869f023628dce7cd3f212aa4cc
--- /dev/null
+++ b/src/par_mod.f90
@@ -0,0 +1,276 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+!*******************************************************************************
+! Include file for calculation of particle trajectories (Program FLEXPART) *
+! This file contains the parameter statements used in FLEXPART *
+! *
+! Author: A. Stohl *
+! *
+! 1997 *
+! *
+! Last update 15 August 2013 IP *
+! *
+!*******************************************************************************
+
+module par_mod
+
+ implicit none
+
+ !****************************************************************
+ ! Parameter defining KIND parameter for "double precision"
+ !****************************************************************
+
+ integer,parameter :: dp=selected_real_kind(P=15)
+
+
+ !***********************************************************
+ ! Number of directories/files used for FLEXPART input/output
+ !***********************************************************
+
+ integer,parameter :: numpath=4
+
+ ! numpath Number of different pathnames for input/output files
+
+
+ !*****************************
+ ! Physical and other constants
+ !*****************************
+
+ real,parameter :: pi=3.14159265, r_earth=6.371e6, r_air=287.05, ga=9.81
+ real,parameter :: cpa=1004.6, kappa=0.286, pi180=pi/180., vonkarman=0.4
+
+ ! pi number "pi"
+ ! pi180 pi/180.
+ ! r_earth radius of earth [m]
+ ! r_air individual gas constant for dry air [J/kg/K]
+ ! ga gravity acceleration of earth [m/s**2]
+ ! cpa specific heat for dry air
+ ! kappa exponent of formula for potential temperature
+ ! vonkarman von Karman constant
+
+ real,parameter :: karman=0.40, href=15., convke=2.0
+ real,parameter :: hmixmin=100., hmixmax=4500., turbmesoscale=0.16
+ real,parameter :: d_trop=50., d_strat=0.1
+
+ ! karman Karman's constant
+ ! href [m] Reference height for dry deposition
+ ! konvke Relative share of kinetic energy used for parcel lifting
+ ! hmixmin,hmixmax Minimum and maximum allowed PBL height
+ ! turbmesoscale the factor by which standard deviations of winds at grid
+ ! points surrounding the particle positions are scaled to
+ ! yield the scales for the mesoscale wind velocity fluctuations
+ ! d_trop [m2/s] Turbulent diffusivity for horizontal components in the troposphere
+ ! d_strat [m2/s] Turbulent diffusivity for vertical component in the stratosphere
+
+ real,parameter :: xmwml=18.016/28.960
+
+ ! xmwml ratio of molar weights of water vapor and dry air
+ !****************************************************
+ ! Constants related to the stratospheric ozone tracer
+ !****************************************************
+
+ real,parameter :: ozonescale=60., pvcrit=2.0
+
+ ! ozonescale ppbv O3 per PV unit
+ ! pvcrit PV level of the tropopause
+
+
+
+ !********************
+ ! Some time constants
+ !********************
+
+ integer,parameter :: idiffnorm=10800, idiffmax=2*idiffnorm, minstep=1
+
+ ! idiffnorm [s] normal time interval between two wind fields
+ ! idiffmax [s] maximum time interval between two wind fields
+ ! minstep [s] minimum time step to be used within FLEXPART
+
+
+ !*****************************************************************
+ ! Parameters for polar stereographic projection close to the poles
+ !*****************************************************************
+
+ real,parameter :: switchnorth=75., switchsouth=-75.
+
+ ! switchnorth use polar stereographic grid north of switchnorth
+ ! switchsouth use polar stereographic grid south of switchsouth
+
+
+ !*********************************************
+ ! Maximum dimensions of the input mother grids
+ !*********************************************
+
+ integer,parameter :: nxmax=361,nymax=181,nuvzmax=92,nwzmax=92,nzmax=92 !FNL
+ !integer,parameter :: nxmax=361,nymax=181,nuvzmax=92,nwzmax=92,nzmax=92 !ECMWF
+ !integer,parameter :: nxmax=361,nymax=181,nuvzmax=26,nwzmax=26,nzmax=26
+ !integer,parameter :: nxmax=721,nymax=361,nuvzmax=64,nwzmax=64,nzmax=64
+ !integer,parameter :: nxmax=1201,nymax=235,nuvzmax=58,nwzmax=58,nzmax=58
+
+ integer,parameter :: nxshift=359 ! for ECMWF
+ !integer,parameter :: nxshift=0 ! for GFS or FNL (XF)
+
+ integer,parameter :: nconvlevmax = nuvzmax-1
+ integer,parameter :: na = nconvlevmax+1
+
+
+ ! nxmax,nymax maximum dimension of wind fields in x and y
+ ! direction, respectively
+ ! nuvzmax,nwzmax maximum dimension of (u,v) and (w) wind fields in z
+ ! direction (for fields on eta levels)
+ ! nzmax maximum dimension of wind fields in z direction
+ ! for the transformed Cartesian coordinates
+ ! nxshift for global grids (in x), the grid can be shifted by
+ ! nxshift grid points, in order to accomodate nested
+ ! grids, and output grids overlapping the domain "boundary"
+ ! nxshift must not be negative; "normal" setting would be 0
+ ! ntracermax maximum number of tracer species in convection
+ ! nconvlevmax maximum number of levels for convection
+ ! na parameter used in Emanuel's convect subroutine
+
+
+ !*********************************************
+ ! Maximum dimensions of the nested input grids
+ !*********************************************
+
+ !integer,parameter :: maxnests=0, nxmaxn=0, nymaxn=0
+ !integer,parameter :: maxnests=1,nxmaxn=251,nymaxn=151 !ECMWF
+ integer,parameter :: maxnests=1, nxmaxn=201, nymaxn=161 ! FNL XF
+ ! maxnests maximum number of nested grids
+ ! nxmaxn,nymaxn maximum dimension of nested wind fields in
+ ! x and y direction, respectively
+
+
+ !*********************************
+ ! Parmaters for GRIB file decoding
+ !*********************************
+
+ integer,parameter :: jpack=4*nxmax*nymax, jpunp=4*jpack
+
+ ! jpack,jpunp maximum dimensions needed for GRIB file decoding
+
+
+ !**************************************
+ ! Maximum dimensions of the output grid
+ !**************************************
+
+ !integer,parameter :: maxageclass=1,maxzgrid=10,nclassunc=1
+ integer,parameter :: maxageclass=1,nclassunc=1
+
+ ! nclassunc number of classes used to calculate the uncertainty
+ ! of the output
+ ! maxageclass maximum number of age classes used for output
+
+ ! Sabine Eckhardt, June, 2008
+ ! the dimensions of the OUTGRID are now set dynamically during runtime
+ ! maxxgrid,maxygrid,maxzgrid maximum dimensions in x,y,z direction
+ ! maxxgridn,maxygridn maximum dimension of the nested grid
+ !integer maxxgrid,maxygrid,maxzgrid,maxxgridn,maxygridn
+ !integer,parameter :: maxxgrid=361,maxygrid=181,maxxgridn=0,maxygridn=0)
+
+ integer,parameter :: maxreceptor=200
+
+ ! maxreceptor maximum number of receptor points
+
+
+ !**************************************************
+ ! Maximum number of particles, species, and similar
+ !**************************************************
+
+ !integer,parameter :: maxpart=4000000
+ integer,parameter :: maxpart=2000
+ integer,parameter :: maxspec=6
+
+
+ ! maxpart Maximum number of particles
+ ! maxspec Maximum number of chemical species per release
+
+ ! maxpoint is also set dynamically during runtime
+ ! maxpoint Maximum number of release locations
+
+ ! ---------
+ ! Sabine Eckhardt: change of landuse inventary numclass=13
+ ! ---------
+ integer,parameter :: maxwf=50000, maxtable=1000, numclass=13, ni=11
+
+ ! maxwf maximum number of wind fields to be used for simulation
+ ! maxtable Maximum number of chemical species that can be
+ ! tabulated for FLEXPART
+ ! numclass Number of landuse classes available to FLEXPART
+ ! ni Number of diameter classes of particles
+
+ !**************************************************************************
+ ! dimension of the OH field
+ !**************************************************************************
+ integer,parameter :: maxxOH=72, maxyOH=46, maxzOH=7
+
+ !**************************************************************************
+ ! Maximum number of particles to be released in a single atmospheric column
+ ! for the domain-filling trajectories option
+ !**************************************************************************
+
+ integer,parameter :: maxcolumn=3000
+
+
+ !*********************************
+ ! Dimension of random number field
+ !*********************************
+
+ integer,parameter :: maxrand=2000000
+
+ ! maxrand number of random numbers used
+
+
+ !*****************************************************
+ ! Number of clusters to be used for plume trajectories
+ !*****************************************************
+
+ integer,parameter :: ncluster=5
+
+ !************************************
+ ! Unit numbers for input/output files
+ !************************************
+
+ integer,parameter :: unitpath=1, unitcommand=1, unitageclasses=1, unitgrid=1
+ integer,parameter :: unitavailab=1, unitreleases=88, unitpartout=93
+ integer,parameter :: unitpartin=93, unitflux=98, unitouttraj=96
+ integer,parameter :: unitvert=1, unitoro=1, unitpoin=1, unitreceptor=1
+ integer,parameter :: unitoutgrid=97, unitoutgridppt=99, unitoutinfo=1
+ integer,parameter :: unitspecies=1, unitoutrecept=91, unitoutreceptppt=92
+ integer,parameter :: unitlsm=1, unitsurfdata=1, unitland=1, unitwesely=1
+ integer,parameter :: unitOH=1
+ integer,parameter :: unitdates=94, unitheader=90,unitheader_txt=100, unitshortpart=95
+ integer,parameter :: unitboundcond=89
+
+!******************************************************
+! integer code for missing values, used in wet scavenging (PS, 2012)
+!******************************************************
+
+ ! integer icmv
+ ! parameter(icmv=-9999)
+ integer,parameter :: icmv=-9999
+
+! Parameters for testing
+!*******************************************
+! integer :: verbosity=0
+
+end module par_mod
diff --git a/src/part0.f90 b/src/part0.f90
new file mode 100644
index 0000000000000000000000000000000000000000..91132be742276e8746355ce6547cdc61725575e9
--- /dev/null
+++ b/src/part0.f90
@@ -0,0 +1,136 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine part0(dquer,dsigma,density,fract,schmi,cun,vsh)
+ ! i i i o o o o
+ !*****************************************************************************
+ ! *
+ ! Calculation of time independent factors of the dry deposition of *
+ ! particles: *
+ ! Log-Normal-distribution of mass [dM/dlog(dp)], unimodal *
+ ! *
+ ! AUTHOR: Matthias Langer, adapted by Andreas Stohl, 13 November 1993 *
+ ! *
+ ! Literature: *
+ ! [1] Scire/Yamartino/Carmichael/Chang (1989), *
+ ! CALGRID: A Mesoscale Photochemical Grid Model. *
+ ! Vol II: User's Guide. (Report No.A049-1, June, 1989) *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! alpha help variable *
+ ! cun 'slip-flow' correction after Cunningham *
+ ! d01 [um] upper diameter *
+ ! d02 [um] lower diameter *
+ ! dc [m2/s] coefficient of Brownian diffusion *
+ ! delta distance given in standard deviation units *
+ ! density [kg/m3] density of the particle *
+ ! dmean geometric mean diameter of interval *
+ ! dquer [um] geometric mass mean particle diameter *
+ ! dsigma e.g. dsigma=10 or dsigma=0.1 means that 68% of the mass *
+ ! are between 0.1*dquer and 10*dquer *
+ ! fract(ni) mass fraction of each diameter interval *
+ ! kn Knudsen number *
+ ! ni number of diameter intervals, for which deposition *
+ ! is calculated *
+ ! schmidt Schmidt number *
+ ! schmi schmidt**2/3 *
+ ! vsh [m/s] gravitational settling velocity of the particle *
+ ! x01 normalized upper diameter *
+ ! x02 normalized lower diameter *
+ ! *
+ ! Constants: *
+ ! g [m/s2] Acceleration of gravity *
+ ! kb [J/K] Stefan-Boltzmann constant *
+ ! lam [m] mean free path of air molecules *
+ ! myl [kg/m/s] dynamical viscosity of air *
+ ! nyl [m2/s] kinematic viscosity of air *
+ ! tr reference temperature *
+ ! *
+ ! Function: *
+ ! erf calculates the integral of the Gauss function *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+
+ implicit none
+
+ real,parameter :: tr=293.15
+
+ integer :: i
+ real :: dquer,dsigma,density,xdummy,d01,d02,delta,x01,x02,fract(ni)
+ real :: dmean,alpha,cun,dc,schmidt,schmi(ni),vsh(ni),kn,erf
+ real,parameter :: myl=1.81e-5,nyl=0.15e-4
+ real,parameter :: lam=6.53e-8,kb=1.38e-23,eps=1.2e-38
+
+
+ ! xdummy constant for all intervals
+ !**********************************
+
+ xdummy=sqrt(2.)*alog(dsigma)
+
+
+ ! particles diameters are split up to ni intervals between
+ ! dquer-3*dsigma and dquer+3*dsigma
+ !*********************************************************
+
+ delta=6./real(ni)
+
+ d01=dquer*dsigma**(-3)
+ do i=1,ni
+ d02=d01
+ d01=dquer*dsigma**(-3.+delta*real(i))
+ x01=alog(d01/dquer)/xdummy
+ x02=alog(d02/dquer)/xdummy
+
+
+ ! Area under Gauss-function is calculated and gives mass fraction of interval
+ !****************************************************************************
+
+ fract(i)=0.5*(erf(x01)-erf(x02))
+
+
+ ! Geometric mean diameter of interval in [m]
+ !*******************************************
+
+ dmean=1.E-6*exp(0.5*alog(d01*d02))
+
+
+ ! Calculation of time independent parameters of each interval
+ !************************************************************
+
+ kn=2.*lam/dmean
+ if ((-1.1/kn).le.log10(eps)*log(10.)) then
+ alpha=1.257
+ else
+ alpha=1.257+0.4*exp(-1.1/kn)
+ endif
+ cun=1.+alpha*kn
+ dc=kb*tr*cun/(3.*pi*myl*dmean)
+ schmidt=nyl/dc
+ schmi(i)=schmidt**(-2./3.)
+ vsh(i)=ga*density*dmean*dmean*cun/(18.*myl)
+
+ end do
+
+end subroutine part0
diff --git a/src/partdep.f90 b/src/partdep.f90
new file mode 100644
index 0000000000000000000000000000000000000000..358165c4f584838d787462b29d3843efa9b0043a
--- /dev/null
+++ b/src/partdep.f90
@@ -0,0 +1,116 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine partdep(nc,density,fract,schmi,vset,ra,ustar,nyl,vdep)
+ ! i i i i i i i i i/o
+ !*****************************************************************************
+ ! *
+ ! Calculation of the dry deposition velocities of particles. *
+ ! This routine is based on Stokes' law for considering settling and *
+ ! assumes constant dynamic viscosity of the air. *
+ ! *
+ ! AUTHOR: Andreas Stohl, 12 November 1993 *
+ ! Update: 20 December 1996 *
+ ! *
+ ! Literature: *
+ ! [1] Hicks/Baldocchi/Meyers/Hosker/Matt (1987), A Preliminary *
+ ! Multiple Resistance Routine for Deriving Dry Deposition *
+ ! Velocities from Measured Quantities. *
+ ! Water, Air and Soil Pollution 36 (1987), pp.311-330. *
+ ! [2] Slinn (1982), Predictions for Particle Deposition to *
+ ! Vegetative Canopies. Atm.Env.16-7 (1982), pp.1785-1794. *
+ ! [3] Slinn/Slinn (1980), Predictions for Particle Deposition on *
+ ! Natural Waters. Atm.Env.14 (1980), pp.1013-1016. *
+ ! [4] Scire/Yamartino/Carmichael/Chang (1989), *
+ ! CALGRID: A Mesoscale Photochemical Grid Model. *
+ ! Vol II: User's Guide. (Report No.A049-1, June, 1989) *
+ ! [5] Langer M. (1992): Ein einfaches Modell zur Abschaetzung der *
+ ! Depositionsgeschwindigkeit von Teilchen und Gasen. *
+ ! Internal report. *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! alpha help variable *
+ ! fract(nc,ni) mass fraction of each diameter interval *
+ ! lpdep(nc) 1 for particle deposition, 0 else *
+ ! nc actual number of chemical components *
+ ! ni number of diameter intervals, for which vdepj is calc.*
+ ! rdp [s/m] deposition layer resistance *
+ ! ra [s/m] aerodynamical resistance *
+ ! schmi(nc,ni) Schmidt number**2/3 of each diameter interval *
+ ! stokes Stokes number *
+ ! ustar [m/s] friction velocity *
+ ! vdep(nc) [m/s] deposition velocities of all components *
+ ! vdepj [m/s] help, deposition velocity of 1 interval *
+ ! vset(nc,ni) gravitational settling velocity of each interval *
+ ! *
+ ! Constants: *
+ ! nc number of chemical species *
+ ! ni number of diameter intervals, for which deposition *
+ ! is calculated *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+
+ implicit none
+
+ real :: density(maxspec),schmi(maxspec,ni),fract(maxspec,ni)
+ real :: vset(maxspec,ni)
+ real :: vdep(maxspec),stokes,vdepj,rdp,ustar,alpha,ra,nyl
+ real,parameter :: eps=1.e-5
+ integer :: ic,j,nc
+
+
+ do ic=1,nc ! loop over all species
+ if (density(ic).gt.0.) then
+ do j=1,ni ! loop over all diameter intervals
+ if (ustar.gt.eps) then
+
+ ! Stokes number for each diameter interval
+ !*****************************************
+
+ stokes=vset(ic,j)/ga*ustar*ustar/nyl
+ alpha=-3./stokes
+
+ ! Deposition layer resistance
+ !****************************
+
+ if (alpha.le.log10(eps)) then
+ rdp=1./(schmi(ic,j)*ustar)
+ else
+ rdp=1./((schmi(ic,j)+10.**alpha)*ustar)
+ endif
+ vdepj=vset(ic,j)+1./(ra+rdp+ra*rdp*vset(ic,j))
+ else
+ vdepj=vset(ic,j)
+ endif
+
+ ! deposition velocities of each interval are weighted with mass fraction
+ !***********************************************************************
+
+ vdep(ic)=vdep(ic)+vdepj*fract(ic,j)
+ end do
+ endif
+ end do
+
+end subroutine partdep
diff --git a/src/partoutput.f90 b/src/partoutput.f90
new file mode 100644
index 0000000000000000000000000000000000000000..53528eae877405497685fe14c486b8dac3bde620
--- /dev/null
+++ b/src/partoutput.f90
@@ -0,0 +1,209 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine partoutput(itime)
+ ! i
+ !*****************************************************************************
+ ! *
+ ! Dump all particle positions *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 12 March 1999 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ real(kind=dp) :: jul
+ integer :: itime,i,j,jjjjmmdd,ihmmss
+ integer :: ix,jy,ixp,jyp,indexh,m,il,ind,indz,indzp
+ real :: xlon,ylat
+ real :: dt1,dt2,dtt,ddx,ddy,rddx,rddy,p1,p2,p3,p4,dz1,dz2,dz
+ real :: topo,hm(2),hmixi,pv1(2),pvprof(2),pvi,qv1(2),qvprof(2),qvi
+ real :: tt1(2),ttprof(2),tti,rho1(2),rhoprof(2),rhoi
+ real :: tr(2),tri
+ character :: adate*8,atime*6
+
+
+ ! Determine current calendar date, needed for the file name
+ !**********************************************************
+
+ jul=bdate+real(itime,kind=dp)/86400._dp
+ call caldate(jul,jjjjmmdd,ihmmss)
+ write(adate,'(i8.8)') jjjjmmdd
+ write(atime,'(i6.6)') ihmmss
+
+
+ ! Some variables needed for temporal interpolation
+ !*************************************************
+
+ dt1=real(itime-memtime(1))
+ dt2=real(memtime(2)-itime)
+ dtt=1./(dt1+dt2)
+
+ ! Open output file and write the output
+ !**************************************
+
+ if (ipout.eq.1) then
+ open(unitpartout,file=path(2)(1:length(2))//'partposit_'//adate// &
+ atime,form='unformatted')
+ else
+ open(unitpartout,file=path(2)(1:length(2))//'partposit_end', &
+ form='unformatted')
+ endif
+
+ ! Write current time to file
+ !***************************
+
+ write(unitpartout) itime
+ do i=1,numpart
+
+ ! Take only valid particles
+ !**************************
+
+ if (itra1(i).eq.itime) then
+ xlon=xlon0+xtra1(i)*dx
+ ylat=ylat0+ytra1(i)*dy
+
+ !*****************************************************************************
+ ! Interpolate several variables (PV, specific humidity, etc.) to particle position
+ !*****************************************************************************
+
+ ix=xtra1(i)
+ jy=ytra1(i)
+ ixp=ix+1
+ jyp=jy+1
+ ddx=xtra1(i)-real(ix)
+ ddy=ytra1(i)-real(jy)
+ rddx=1.-ddx
+ rddy=1.-ddy
+ p1=rddx*rddy
+ p2=ddx*rddy
+ p3=rddx*ddy
+ p4=ddx*ddy
+
+ ! Topography
+ !***********
+
+ topo=p1*oro(ix ,jy) &
+ + p2*oro(ixp,jy) &
+ + p3*oro(ix ,jyp) &
+ + p4*oro(ixp,jyp)
+
+ ! Potential vorticity, specific humidity, temperature, and density
+ !*****************************************************************
+
+ do il=2,nz
+ if (height(il).gt.ztra1(i)) then
+ indz=il-1
+ indzp=il
+ goto 6
+ endif
+ end do
+6 continue
+
+ dz1=ztra1(i)-height(indz)
+ dz2=height(indzp)-ztra1(i)
+ dz=1./(dz1+dz2)
+
+
+ do ind=indz,indzp
+ do m=1,2
+ indexh=memind(m)
+
+ ! Potential vorticity
+ pv1(m)=p1*pv(ix ,jy ,ind,indexh) &
+ +p2*pv(ixp,jy ,ind,indexh) &
+ +p3*pv(ix ,jyp,ind,indexh) &
+ +p4*pv(ixp,jyp,ind,indexh)
+ ! Specific humidity
+ qv1(m)=p1*qv(ix ,jy ,ind,indexh) &
+ +p2*qv(ixp,jy ,ind,indexh) &
+ +p3*qv(ix ,jyp,ind,indexh) &
+ +p4*qv(ixp,jyp,ind,indexh)
+ ! Temperature
+ tt1(m)=p1*tt(ix ,jy ,ind,indexh) &
+ +p2*tt(ixp,jy ,ind,indexh) &
+ +p3*tt(ix ,jyp,ind,indexh) &
+ +p4*tt(ixp,jyp,ind,indexh)
+ ! Density
+ rho1(m)=p1*rho(ix ,jy ,ind,indexh) &
+ +p2*rho(ixp,jy ,ind,indexh) &
+ +p3*rho(ix ,jyp,ind,indexh) &
+ +p4*rho(ixp,jyp,ind,indexh)
+ end do
+ pvprof(ind-indz+1)=(pv1(1)*dt2+pv1(2)*dt1)*dtt
+ qvprof(ind-indz+1)=(qv1(1)*dt2+qv1(2)*dt1)*dtt
+ ttprof(ind-indz+1)=(tt1(1)*dt2+tt1(2)*dt1)*dtt
+ rhoprof(ind-indz+1)=(rho1(1)*dt2+rho1(2)*dt1)*dtt
+ end do
+ pvi=(dz1*pvprof(2)+dz2*pvprof(1))*dz
+ qvi=(dz1*qvprof(2)+dz2*qvprof(1))*dz
+ tti=(dz1*ttprof(2)+dz2*ttprof(1))*dz
+ rhoi=(dz1*rhoprof(2)+dz2*rhoprof(1))*dz
+
+ ! Tropopause and PBL height
+ !**************************
+
+ do m=1,2
+ indexh=memind(m)
+
+ ! Tropopause
+ tr(m)=p1*tropopause(ix ,jy ,1,indexh) &
+ + p2*tropopause(ixp,jy ,1,indexh) &
+ + p3*tropopause(ix ,jyp,1,indexh) &
+ + p4*tropopause(ixp,jyp,1,indexh)
+
+ ! PBL height
+ hm(m)=p1*hmix(ix ,jy ,1,indexh) &
+ + p2*hmix(ixp,jy ,1,indexh) &
+ + p3*hmix(ix ,jyp,1,indexh) &
+ + p4*hmix(ixp,jyp,1,indexh)
+ end do
+
+ hmixi=(hm(1)*dt2+hm(2)*dt1)*dtt
+ tri=(tr(1)*dt2+tr(2)*dt1)*dtt
+
+
+ ! Write the output
+ !*****************
+
+ write(unitpartout) npoint(i),xlon,ylat,ztra1(i), &
+ itramem(i),topo,pvi,qvi,rhoi,hmixi,tri,tti, &
+ (xmass1(i,j),j=1,nspec)
+ endif
+ end do
+ write(unitpartout) -99999,-9999.9,-9999.9,-9999.9,-99999, &
+ -9999.9,-9999.9,-9999.9,-9999.9,-9999.9,-9999.9,-9999.9, &
+ (-9999.9,j=1,nspec)
+
+
+ close(unitpartout)
+
+end subroutine partoutput
diff --git a/src/partoutput_short.f90 b/src/partoutput_short.f90
new file mode 100644
index 0000000000000000000000000000000000000000..042ddb95947bba475c3a224997a4f039d44f17d7
--- /dev/null
+++ b/src/partoutput_short.f90
@@ -0,0 +1,152 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine partoutput_short(itime)
+ ! i
+ !*****************************************************************************
+ ! *
+ ! Dump all particle positions *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 12 March 1999 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ real(kind=dp) :: jul
+ integer :: itime,i,j,jjjjmmdd,ihmmss,numshortout,numshortall
+ integer :: ix,jy,ixp,jyp
+ real :: xlon,ylat,zlim,dt1,dt2,dtt,ddx,ddy,rddx,rddy,p1,p2,p3,p4,topo
+ character :: adate*8,atime*6
+
+ integer(kind=2) :: idump(3,maxpart)
+ integer :: i4dump(maxpart)
+
+
+ ! Determine current calendar date, needed for the file name
+ !**********************************************************
+
+ jul=bdate+real(itime,kind=dp)/86400._dp
+ call caldate(jul,jjjjmmdd,ihmmss)
+ write(adate,'(i8.8)') jjjjmmdd
+ write(atime,'(i6.6)') ihmmss
+
+
+ ! Some variables needed for temporal interpolation
+ !*************************************************
+
+ dt1=real(itime-memtime(1))
+ dt2=real(memtime(2)-itime)
+ dtt=1./(dt1+dt2)
+
+
+ ! Loop about all particles
+ !*************************
+
+ numshortout=0
+ numshortall=0
+ do i=1,numpart
+
+ ! Take only valid particles
+ !**************************
+
+ if (itra1(i).eq.itime) then
+ xlon=xlon0+xtra1(i)*dx
+ ylat=ylat0+ytra1(i)*dy
+
+ !*****************************************************************************
+ ! Interpolate several variables (PV, specific humidity, etc.) to particle position
+ !*****************************************************************************
+
+ ix=xtra1(i)
+ jy=ytra1(i)
+ ixp=ix+1
+ jyp=jy+1
+ ddx=xtra1(i)-real(ix)
+ ddy=ytra1(i)-real(jy)
+ rddx=1.-ddx
+ rddy=1.-ddy
+ p1=rddx*rddy
+ p2=ddx*rddy
+ p3=rddx*ddy
+ p4=ddx*ddy
+
+ ! Topography
+ !***********
+
+ topo=p1*oro(ix ,jy) &
+ + p2*oro(ixp,jy) &
+ + p3*oro(ix ,jyp) &
+ + p4*oro(ixp,jyp)
+
+
+ ! Convert positions to integer*2 variables (from -32768 to 32767)
+ ! Do this only for region of main interest, i.e. extended North Atlantic region,
+ ! and for the tracer of interest, i.e. the North American one
+ !*****************************************************************************
+
+ if (xlon.gt.180.) xlon=xlon-360.
+ if (xlon.lt.-180.) xlon=xlon+360.
+
+ numshortall=numshortall+1
+ if ((xlon.gt.-140).and.(xlon.lt.60).and.(ylat.gt.10).and. &
+ (xmass1(i,1).gt.0.)) then
+ numshortout=numshortout+1
+ idump(1,numshortout)=nint(xlon*180.)
+ idump(2,numshortout)=nint(ylat*360.)
+ zlim=min(ztra1(i)+topo,32766.)
+ idump(3,numshortout)=nint(zlim)
+ i4dump(numshortout)=npoint(i)
+ endif
+
+ endif
+ end do
+
+
+ ! Open output file and write the output
+ !**************************************
+
+ open(unitshortpart,file=path(2)(1:length(2))//'shortposit_'//adate// &
+ atime,form='unformatted')
+
+ ! Write current time to file
+ !***************************
+
+ write(unitshortpart) itime
+ write(unitshortpart) numshortout
+ write(unitshortpart) &
+ (i4dump(i),(idump(j,i),j=1,3),i=1,numshortout)
+
+
+ write(*,*) numshortout,numshortall
+
+ close(unitshortpart)
+
+end subroutine partoutput_short
diff --git a/src/pbl_profile.f90 b/src/pbl_profile.f90
new file mode 100644
index 0000000000000000000000000000000000000000..7d83505a9f782cd5254a62d7eb54fba40188da1d
--- /dev/null
+++ b/src/pbl_profile.f90
@@ -0,0 +1,132 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine pbl_profile(ps,td2m,zml1,t2m,tml1,u10m,uml1,stress,hf)
+
+ !********************************************************************
+ ! *
+ ! G. WOTAWA, 1995-07-07 *
+ ! *
+ !********************************************************************
+ ! *
+ ! DESCRIPTION: CALCULATION OF FRICTION VELOCITY AND SURFACE SENS- *
+ ! IBLE HEAT FLUX USING THE PROFILE METHOD (BERKOVICZ *
+ ! AND PRAHM, 1982) *
+ ! *
+ ! Output now is surface stress instead of ustar *
+ ! *
+ ! *
+ !********************************************************************
+ ! *
+ ! INPUT: *
+ ! *
+ ! *
+ ! ps surface pressure(Pa) *
+ ! td2m two metre dew point(K) *
+ ! zml1 heigth of first model level (m) *
+ ! t2m two metre temperature (K) *
+ ! tml1 temperature first model level (K) *
+ ! u10m ten metre wind speed (ms-1) *
+ ! uml1 wind speed first model level (ms-1) *
+ ! *
+ !********************************************************************
+ ! *
+ ! OUTPUT: *
+ ! *
+ ! stress surface stress (i.e., friction velocity (ms-1) squared *
+ ! multiplied with air density) *
+ ! hf surface sensible heat flux (Wm-2) *
+ ! *
+ !********************************************************************
+ ! ustar friction velocity (ms-1) *
+ ! maxiter maximum number of iterations *
+ !********************************************************************
+
+ use par_mod
+
+ implicit none
+
+ integer :: iter
+ real :: ps,td2m,rhoa,zml1,t2m,tml1,u10m,uml1,ustar,hf
+ real :: al,alold,aldiff,tmean,crit
+ real :: deltau,deltat,thetastar,psim,psih,e,ew,tv,stress
+ integer,parameter :: maxiter=10
+ real,parameter :: r1=0.74
+
+ e=ew(td2m) ! vapor pressure
+ tv=t2m*(1.+0.378*e/ps) ! virtual temperature
+ rhoa=ps/(r_air*tv) ! air density
+
+ deltau=uml1-u10m !! Wind Speed difference between
+ !! Model level 1 and 10 m
+
+ if(deltau.le.0.001) then !! Monin-Obukhov Theory not
+ al=9999. !! applicable --> Set dummy values
+ ustar=0.01
+ stress=ustar*ustar*rhoa
+ hf=0.0
+ return
+ endif
+ deltat=tml1-t2m+0.0098*(zml1-2.) !! Potential temperature difference
+ !! between model level 1 and 10 m
+
+ if(abs(deltat).le.0.03) then !! Neutral conditions
+ hf=0.0
+ al=9999.
+ ustar=(vonkarman*deltau)/ &
+ (log(zml1/10.)-psim(zml1,al)+psim(10.,al))
+ stress=ustar*ustar*rhoa
+ return
+ endif
+
+ tmean=0.5*(t2m+tml1)
+ crit=(0.0219*tmean*(zml1-2.0)*deltau**2)/ &
+ (deltat*(zml1-10.0)**2)
+ if((deltat.gt.0).and.(crit.le.1.)) then
+ !! Successive approximation will
+ al=50. !! not converge
+ ustar=(vonkarman*deltau)/ &
+ (log(zml1/10.)-psim(zml1,al)+psim(10.,al))
+ thetastar=(vonkarman*deltat/r1)/ &
+ (log(zml1/2.)-psih(zml1,al)+psih(2.,al))
+ hf=rhoa*cpa*ustar*thetastar
+ stress=ustar*ustar*rhoa
+ return
+ endif
+
+ al=9999. ! Start iteration assuming neutral conditions
+ do iter=1,maxiter
+ alold=al
+ ustar=(vonkarman*deltau)/ &
+ (log(zml1/10.)-psim(zml1,al)+psim(10.,al))
+ thetastar=(vonkarman*deltat/r1)/ &
+ (log(zml1/2.)-psih(zml1,al)+psih(2.,al))
+ al=(tmean*ustar**2)/(ga*vonkarman*thetastar)
+ aldiff=abs((al-alold)/alold)
+ if(aldiff.lt.0.01) goto 30 !! Successive approximation successful
+ end do
+30 hf=rhoa*cpa*ustar*thetastar
+ if(al.gt.9999.) al=9999.
+ if(al.lt.-9999.) al=-9999.
+
+ stress=ustar*ustar*rhoa
+
+end subroutine pbl_profile
diff --git a/src/plumetraj.f90 b/src/plumetraj.f90
new file mode 100644
index 0000000000000000000000000000000000000000..0df59c641003f744405022e5d0a20f7722831b88
--- /dev/null
+++ b/src/plumetraj.f90
@@ -0,0 +1,250 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine plumetraj(itime)
+ ! i
+ !*****************************************************************************
+ ! *
+ ! Determines a plume centroid trajectory for each release site, and manages *
+ ! clustering of particle locations. Certain parameters (average PV, *
+ ! tropopause height, etc., are provided along the plume trajectories. *
+ ! At the end, output is written to file 'trajectories.txt'. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 24 January 2002 *
+ ! *
+ ! Variables: *
+ ! fclust fraction of particles belonging to each cluster *
+ ! hmixcenter mean mixing height for all particles *
+ ! ncluster number of clusters to be used *
+ ! pvcenter mean PV for all particles *
+ ! pvfract fraction of particles with PV<2pvu *
+ ! rms total horizontal rms distance after clustering *
+ ! rmsdist total horizontal rms distance before clustering *
+ ! rmsclust horizontal rms distance for each individual cluster *
+ ! topocenter mean topography underlying all particles *
+ ! tropocenter mean tropopause height at the positions of particles *
+ ! tropofract fraction of particles within the troposphere *
+ ! zrms total vertical rms distance after clustering *
+ ! zrmsdist total vertical rms distance before clustering *
+ ! xclust,yclust, Cluster centroid positions *
+ ! zclust *
+ ! *
+ !*****************************************************************************
+
+ use point_mod
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: itime,ix,jy,ixp,jyp,indexh,i,j,k,m,n,il,ind,indz,indzp
+ real :: xl(maxpart),yl(maxpart),zl(maxpart)
+ real :: xcenter,ycenter,zcenter,dist,distance,rmsdist,zrmsdist
+
+ real :: xclust(ncluster),yclust(ncluster),zclust(ncluster)
+ real :: fclust(ncluster),rms,rmsclust(ncluster),zrms
+
+ real :: dt1,dt2,dtt,ddx,ddy,rddx,rddy,p1,p2,p3,p4,dz1,dz2,dz
+ real :: topo,topocenter,hm(2),hmixi,hmixfract,hmixcenter
+ real :: pv1(2),pvprof(2),pvi,pvcenter,pvfract,tr(2),tri,tropofract
+ real :: tropocenter
+
+
+ dt1=real(itime-memtime(1))
+ dt2=real(memtime(2)-itime)
+ dtt=1./(dt1+dt2)
+
+
+ ! Loop about all release points
+ !******************************
+
+ do j=1,numpoint
+ if (abs(ireleasestart(j)-itime).gt.lage(nageclass)) goto 10
+ topocenter=0.
+ hmixcenter=0.
+ hmixfract=0.
+ tropocenter=0.
+ tropofract=0.
+ pvfract=0.
+ pvcenter=0.
+ rmsdist=0.
+ zrmsdist=0.
+
+ n=0
+ do i=1,numpart
+ if (itra1(i).ne.itime) goto 20
+ if (npoint(i).ne.j) goto 20
+ n=n+1
+ xl(n)=xlon0+xtra1(i)*dx
+ yl(n)=ylat0+ytra1(i)*dy
+ zl(n)=ztra1(i)
+
+
+ ! Interpolate PBL height, PV, and tropopause height to each
+ ! particle position in order to determine fraction of particles
+ ! within the PBL, above tropopause height, and average PV.
+ ! Interpolate topography, too, and convert to altitude asl
+ !**************************************************************
+
+ ix=int(xtra1(i))
+ jy=int(ytra1(i))
+ ixp=ix+1
+ jyp=jy+1
+ ddx=xtra1(i)-real(ix)
+ ddy=ytra1(i)-real(jy)
+ rddx=1.-ddx
+ rddy=1.-ddy
+ p1=rddx*rddy
+ p2=ddx*rddy
+ p3=rddx*ddy
+ p4=ddx*ddy
+
+ ! Topography
+ !***********
+
+ topo=p1*oro(ix ,jy) &
+ + p2*oro(ixp,jy) &
+ + p3*oro(ix ,jyp) &
+ + p4*oro(ixp,jyp)
+ topocenter=topocenter+topo
+
+ ! Potential vorticity
+ !********************
+
+ do il=2,nz
+ if (height(il).gt.zl(n)) then
+ indz=il-1
+ indzp=il
+ goto 6
+ endif
+ end do
+6 continue
+
+ dz1=zl(n)-height(indz)
+ dz2=height(indzp)-zl(n)
+ dz=1./(dz1+dz2)
+
+
+ do ind=indz,indzp
+ do m=1,2
+ indexh=memind(m)
+ pv1(m)=p1*pv(ix ,jy ,ind,indexh) &
+ +p2*pv(ixp,jy ,ind,indexh) &
+ +p3*pv(ix ,jyp,ind,indexh) &
+ +p4*pv(ixp,jyp,ind,indexh)
+ end do
+ pvprof(ind-indz+1)=(pv1(1)*dt2+pv1(2)*dt1)*dtt
+ end do
+ pvi=(dz1*pvprof(2)+dz2*pvprof(1))*dz
+ pvcenter=pvcenter+pvi
+ if (yl(n).gt.0.) then
+ if (pvi.lt.2.) pvfract=pvfract+1.
+ else
+ if (pvi.gt.-2.) pvfract=pvfract+1.
+ endif
+
+
+ ! Tropopause and PBL height
+ !**************************
+
+ do m=1,2
+ indexh=memind(m)
+
+ tr(m)=p1*tropopause(ix ,jy ,1,indexh) &
+ + p2*tropopause(ixp,jy ,1,indexh) &
+ + p3*tropopause(ix ,jyp,1,indexh) &
+ + p4*tropopause(ixp,jyp,1,indexh)
+
+ hm(m)=p1*hmix(ix ,jy ,1,indexh) &
+ + p2*hmix(ixp,jy ,1,indexh) &
+ + p3*hmix(ix ,jyp,1,indexh) &
+ + p4*hmix(ixp,jyp,1,indexh)
+ end do
+
+ hmixi=(hm(1)*dt2+hm(2)*dt1)*dtt
+ tri=(tr(1)*dt2+tr(2)*dt1)*dtt
+ if (zl(n).lt.tri) tropofract=tropofract+1.
+ tropocenter=tropocenter+tri+topo
+ if (zl(n).lt.hmixi) hmixfract=hmixfract+1.
+ zl(n)=zl(n)+topo ! convert to height asl
+ hmixcenter=hmixcenter+hmixi
+
+
+20 continue
+ end do
+
+
+ ! Make statistics for all plumes with n>0 particles
+ !**************************************************
+
+ if (n.gt.0) then
+ topocenter=topocenter/real(n)
+ hmixcenter=hmixcenter/real(n)
+ pvcenter=pvcenter/real(n)
+ tropocenter=tropocenter/real(n)
+ hmixfract=100.*hmixfract/real(n)
+ pvfract=100.*pvfract/real(n)
+ tropofract=100.*tropofract/real(n)
+
+ ! Cluster the particle positions
+ !*******************************
+
+ call clustering(xl,yl,zl,n,xclust,yclust,zclust,fclust,rms, &
+ rmsclust,zrms)
+
+
+ ! Determine center of mass position on earth and average height
+ !**************************************************************
+
+ call centerofmass(xl,yl,n,xcenter,ycenter)
+ call mean(zl,zcenter,zrmsdist,n)
+
+ ! Root mean square distance from center of mass
+ !**********************************************
+
+ do k=1,n
+ dist=distance(yl(k),xl(k),ycenter,xcenter)
+ rmsdist=rmsdist+dist*dist
+ end do
+ if (rmsdist.gt.0.) rmsdist=sqrt(rmsdist/real(n))
+ rmsdist=max(rmsdist,0.)
+
+ ! Write out results in trajectory data file
+ !******************************************
+
+ write(unitouttraj,'(i5,i8,2f9.4,4f8.1,f8.2,4f8.1,3f6.1,&
+ &5(2f8.3,f7.0,f6.1,f8.1))')&
+ &j,itime-(ireleasestart(j)+ireleaseend(j))/2, &
+ xcenter,ycenter,zcenter,topocenter,hmixcenter,tropocenter, &
+ pvcenter,rmsdist,rms,zrmsdist,zrms,hmixfract,pvfract, &
+ tropofract, &
+ (xclust(k),yclust(k),zclust(k),fclust(k),rmsclust(k), &
+ k=1,ncluster)
+ endif
+
+
+10 continue
+ end do
+
+
+end subroutine plumetraj
diff --git a/src/point_mod.f90 b/src/point_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..0e1a2a1d1a47a5fa0604b262ad8f5c44ef685222
--- /dev/null
+++ b/src/point_mod.f90
@@ -0,0 +1,41 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+module point_mod
+
+ implicit none
+
+ integer, allocatable, dimension (:) :: ireleasestart
+ integer, allocatable, dimension (:) :: ireleaseend
+ integer, allocatable, dimension (:) :: npart
+ integer*2, allocatable, dimension (:) :: kindz
+
+ real,allocatable, dimension (:) :: xpoint1
+ real,allocatable, dimension (:) :: xpoint2
+ real,allocatable, dimension (:) :: ypoint1
+ real,allocatable, dimension (:) :: ypoint2
+ real,allocatable, dimension (:) :: zpoint1
+ real,allocatable, dimension (:) :: zpoint2
+
+ real,allocatable, dimension (:,:) :: xmass
+ real,allocatable, dimension (:) :: rho_rel
+
+end module point_mod
diff --git a/src/psih.f90 b/src/psih.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d1116c4a581bb676c50c24e14e888e955a44946c
--- /dev/null
+++ b/src/psih.f90
@@ -0,0 +1,76 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+function psih (z,l)
+
+ !*****************************************************************************
+ ! *
+ ! Calculation of the stability correction term *
+ ! *
+ ! AUTHOR: Matthias Langer, adapted by Andreas Stohl (6 August 1993) *
+ ! Update: G. Wotawa, 11 October 1994 *
+ ! *
+ ! Literature: *
+ ! [1] C.A.Paulson (1970), A Mathematical Representation of Wind Speed *
+ ! and Temperature Profiles in the Unstable Atmospheric Surface *
+ ! Layer. J.Appl.Met.,Vol.9.(1970), pp.857-861. *
+ ! *
+ ! [2] A.C.M. Beljaars, A.A.M. Holtslag (1991), Flux Parameterization over*
+ ! Land Surfaces for Atmospheric Models. J.Appl.Met. Vol. 30,pp 327-*
+ ! 341 *
+ ! *
+ ! Variables: *
+ ! L = Monin-Obukhov-length [m] *
+ ! z = height [m] *
+ ! zeta = auxiliary variable *
+ ! *
+ ! Constants: *
+ ! eps = 1.2E-38, SUN-underflow: to avoid division by zero errors *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+
+ implicit none
+
+ real :: psih,x,z,zeta,l
+ real,parameter :: a=1.,b=0.667,c=5.,d=0.35,eps=1.e-20
+
+ if ((l.ge.0).and.(l.lt.eps)) then
+ l=eps
+ else if ((l.lt.0).and.(l.gt.(-1.*eps))) then
+ l=-1.*eps
+ endif
+
+ if ((log10(z)-log10(abs(l))).lt.log10(eps)) then
+ psih=0.
+ else
+ zeta=z/l
+ if (zeta.gt.0.) then
+ psih = - (1.+0.667*a*zeta)**(1.5) - b*(zeta-c/d)*exp(-d*zeta) &
+ - b*c/d + 1.
+ else
+ x=(1.-16.*zeta)**(.25)
+ psih=2.*log((1.+x*x)/2.)
+ end if
+ end if
+
+end function psih
diff --git a/src/psim.f90 b/src/psim.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d1d570b6ed1143839128cadd734dfee8db483e07
--- /dev/null
+++ b/src/psim.f90
@@ -0,0 +1,50 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+real function psim(z,al)
+
+ !**********************************************************************
+ ! *
+ ! DESCRIPTION: CALCULATION OF THE STABILITY CORRECTION FUNCTION FOR *
+ ! MOMENTUM AS FUNCTION OF HEIGHT Z AND OBUKHOV SCALE *
+ ! HEIGHT L *
+ ! *
+ !**********************************************************************
+
+ use par_mod
+
+ implicit none
+
+ real :: z,al,zeta,x,a1,a2
+
+ zeta=z/al
+ if(zeta.le.0.) then
+ ! UNSTABLE CASE
+ x=(1.-15.*zeta)**0.25
+ a1=((1.+x)/2.)**2
+ a2=(1.+x**2)/2.
+ psim=log(a1*a2)-2.*atan(x)+pi/2.
+ else
+ ! STABLE CASE
+ psim=-4.7*zeta
+ endif
+
+end function psim
diff --git a/src/qvsat.f90 b/src/qvsat.f90
new file mode 100644
index 0000000000000000000000000000000000000000..55692ded240cc3a854e572d54b5f66a317a7a717
--- /dev/null
+++ b/src/qvsat.f90
@@ -0,0 +1,157 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+!##################################################################
+!##################################################################
+!###### ######
+!###### Developed by ######
+!###### Center for Analysis and Prediction of Storms ######
+!###### University of Oklahoma ######
+!###### ######
+!##################################################################
+!##################################################################
+
+function f_qvsat( p, t )
+
+ !PURPOSE:
+ !
+ !Calculate the saturation specific humidity using enhanced Teten's
+ !formula.
+ !
+ !AUTHOR: Yuhe Liu
+ !01/08/1998
+ !
+ !MODIFICATION HISTORY:
+ !
+ !INPUT :
+ ! p Pressure (Pascal)
+ ! t Temperature (K)
+ !OUTPUT:
+ ! f_qvsat Saturation water vapor specific humidity (kg/kg).
+ !
+ !Variable Declarations.
+ !
+
+ implicit none
+
+ real :: p ! Pressure (Pascal)
+ real :: t ! Temperature (K)
+ real :: f_qvsat ! Saturation water vapor specific humidity (kg/kg)
+ real :: f_esl,f_esi,fespt
+
+ real,parameter :: rd = 287.0 ! Gas constant for dry air (m**2/(s**2*K))
+ real,parameter :: rv = 461.0 ! Gas constant for water vapor (m**2/(s**2*K)).
+ real,parameter :: rddrv = rd/rv
+
+
+ ! Change by A. Stohl to save computation time:
+ ! IF ( t.ge.273.15 ) THEN ! for water
+ if ( t.ge.253.15 ) then ! modification Petra Seibert
+ ! (supercooled water may be present)
+ fespt=f_esl(p,t)
+ else
+ fespt=f_esi(p,t)
+ endif
+
+!!$ f_qvsat = rddrv * fespt / (p-(1.0-rddrv)*fespt) !old
+ if (p-(1.0-rddrv)*fespt == 0.) then !bugfix
+ f_qvsat = 1.
+ else
+ f_qvsat = rddrv * fespt / (p-(1.0-rddrv)*fespt)
+ end if
+
+ return
+end function f_qvsat
+
+
+function f_esl( p, t )
+
+ implicit none
+
+ real :: p ! Pressure (Pascal)
+ real :: t ! Temperature (K)
+ real :: f_esl ! Saturation water vapor pressure over liquid water
+
+ real :: f
+
+ !#######################################################################
+ !
+ !Saturation specific humidity parameters used in enhanced Teten's
+ !formula. (See A. Buck, JAM 1981)
+ !
+ !#######################################################################
+
+ real,parameter :: satfwa = 1.0007
+ real,parameter :: satfwb = 3.46e-8 ! for p in Pa
+
+ real,parameter :: satewa = 611.21 ! es in Pa
+ real,parameter :: satewb = 17.502
+ real,parameter :: satewc = 32.18
+
+ real,parameter :: satfia = 1.0003
+ real,parameter :: satfib = 4.18e-8 ! for p in Pa
+
+ real,parameter :: sateia = 611.15 ! es in Pa
+ real,parameter :: sateib = 22.452
+ real,parameter :: sateic = 0.6
+
+ f = satfwa + satfwb * p
+ f_esl = f * satewa * exp( satewb*(t-273.15)/(t-satewc) )
+
+ return
+end function f_esl
+
+function f_esi( p, t )
+
+ implicit none
+
+ real :: p ! Pressure (Pascal)
+ real :: t ! Temperature (K)
+ real :: f_esi ! Saturation water vapor pressure over ice (Pa)
+
+ real :: f
+
+ !#######################################################################
+ !
+ !Saturation specific humidity parameters used in enhanced Teten's
+ !formula. (See A. Buck, JAM 1981)
+ !
+ !#######################################################################
+ !
+ real,parameter :: satfwa = 1.0007
+ real,parameter :: satfwb = 3.46e-8 ! for p in Pa
+
+ real,parameter :: satewa = 611.21 ! es in Pa
+ real,parameter :: satewb = 17.502
+ real,parameter :: satewc = 32.18
+
+ real,parameter :: satfia = 1.0003
+ real,parameter :: satfib = 4.18e-8 ! for p in Pa
+
+ real,parameter :: sateia = 611.15 ! es in Pa
+ real,parameter :: sateib = 22.452
+ real,parameter :: sateic = 0.6
+
+ f = satfia + satfib * p
+ f_esi = f * sateia * exp( sateib*(t-273.15)/(t-sateic) )
+
+ return
+end function f_esi
diff --git a/src/raerod.f90 b/src/raerod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..50205c5c95b7562ba2b02dcfb84970edc82db852
--- /dev/null
+++ b/src/raerod.f90
@@ -0,0 +1,63 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+function raerod (l,ust,z0)
+
+ !*****************************************************************************
+ ! *
+ ! Calculation of the aerodynamical resistance ra from ground up to href *
+ ! *
+ ! AUTHOR: Matthias Langer, modified by Andreas Stohl (6 August 1993) *
+ ! *
+ ! Literature: *
+ ! [1] Hicks/Baldocchi/Meyers/Hosker/Matt (1987), A Preliminary *
+ ! Multiple Resistance Routine for Deriving Dry Deposition *
+ ! Velocities from Measured Quantities. *
+ ! Water, Air and Soil Pollution 36 (1987), pp.311-330. *
+ ! [2] Scire/Yamartino/Carmichael/Chang (1989), *
+ ! CALGRID: A Mesoscale Photochemical Grid Model. *
+ ! Vol II: User's Guide. (Report No.A049-1, June, 1989) *
+ ! *
+ ! Variable list: *
+ ! L = Monin-Obukhov-length [m] *
+ ! ust = friction velocity [m/sec] *
+ ! z0 = surface roughness length [m] *
+ ! href = reference height [m], for which deposition velocity is *
+ ! calculated *
+ ! *
+ ! Constants: *
+ ! karman = von Karman-constant (~0.4) *
+ ! ramin = minimum resistence of ra (1 s/m) *
+ ! *
+ ! Subprograms and functions: *
+ ! function psih (z/L) *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+
+ implicit none
+
+ real :: l,psih,raerod,ust,z0
+
+ raerod=(alog(href/z0)-psih(href,l)+psih(z0,l))/(karman*ust)
+
+end function raerod
diff --git a/src/random.f90 b/src/random.f90
new file mode 100644
index 0000000000000000000000000000000000000000..fe9ce21e52b08e30ea2a59b04fa47fec0ff0d048
--- /dev/null
+++ b/src/random.f90
@@ -0,0 +1,154 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+! Taken from Press et al., Numerical Recipes
+
+function ran1(idum)
+
+ implicit none
+
+ integer :: idum
+ real :: ran1
+ integer,parameter :: ia=16807, im=2147483647, iq=127773, ir=2836
+ integer,parameter :: ntab=32, ndiv=1+(im-1)/ntab
+ real,parameter :: am=1./im, eps=1.2e-7, rnmx=1.-eps
+ integer :: j, k
+ integer :: iv(ntab) = (/ (0,j=1,ntab) /)
+ integer :: iy=0
+
+ if (idum.le.0.or.iy.eq.0) then
+ idum=max(-idum,1)
+ do j=ntab+8,1,-1
+ k=idum/iq
+ idum=ia*(idum-k*iq)-ir*k
+ if (idum.lt.0) idum=idum+im
+ if (j.le.ntab) iv(j)=idum
+ enddo
+ iy=iv(1)
+ endif
+ k=idum/iq
+ idum=ia*(idum-k*iq)-ir*k
+ if (idum.lt.0) idum=idum+im
+ j=1+iy/ndiv
+ iy=iv(j)
+ iv(j)=idum
+ ran1=min(am*iy,rnmx)
+end function ran1
+
+
+function gasdev(idum)
+
+ implicit none
+
+ integer :: idum
+ real :: gasdev, fac, r, v1, v2
+ integer :: iset = 0
+ real :: gset = 0.
+ real, external :: ran3
+
+ if (iset.eq.0) then
+1 v1=2.*ran3(idum)-1.
+ v2=2.*ran3(idum)-1.
+ r=v1**2+v2**2
+ if(r.ge.1.0 .or. r.eq.0.0) go to 1
+ fac=sqrt(-2.*log(r)/r)
+ gset=v1*fac
+ gasdev=v2*fac
+ iset=1
+ else
+ gasdev=gset
+ iset=0
+ endif
+end function gasdev
+
+
+subroutine gasdev1(idum,random1,random2)
+
+ implicit none
+
+ integer :: idum
+ real :: random1, random2, fac, v1, v2, r
+ real, external :: ran3
+
+1 v1=2.*ran3(idum)-1.
+ v2=2.*ran3(idum)-1.
+ r=v1**2+v2**2
+ if(r.ge.1.0 .or. r.eq.0.0) go to 1
+ fac=sqrt(-2.*log(r)/r)
+ random1=v1*fac
+ random2=v2*fac
+ ! Limit the random numbers to lie within the interval -3 and +3
+ !**************************************************************
+ if (random1.lt.-3.) random1=-3.
+ if (random2.lt.-3.) random2=-3.
+ if (random1.gt.3.) random1=3.
+ if (random2.gt.3.) random2=3.
+end subroutine gasdev1
+
+
+function ran3(idum)
+
+ implicit none
+
+ integer :: idum
+ real :: ran3
+
+ integer,parameter :: mbig=1000000000, mseed=161803398, mz=0
+ real,parameter :: fac=1./mbig
+ integer :: i,ii,inext,inextp,k
+ integer :: mj,mk,ma(55)
+
+ save inext,inextp,ma
+ integer :: iff = 0
+
+ if(idum.lt.0.or.iff.eq.0)then
+ iff=1
+ mj=mseed-iabs(idum)
+ mj=mod(mj,mbig)
+ ma(55)=mj
+ mk=1
+ do i=1,54
+ ii=mod(21*i,55)
+ ma(ii)=mk
+ mk=mj-mk
+ if(mk.lt.mz)mk=mk+mbig
+ mj=ma(ii)
+ end do
+ do k=1,4
+ do i=1,55
+ ma(i)=ma(i)-ma(1+mod(i+30,55))
+ if(ma(i).lt.mz)ma(i)=ma(i)+mbig
+ end do
+ end do
+ inext=0
+ inextp=31
+ idum=1
+ endif
+ inext=inext+1
+ if(inext.eq.56)inext=1
+ inextp=inextp+1
+ if(inextp.eq.56)inextp=1
+ mj=ma(inext)-ma(inextp)
+ if(mj.lt.mz)mj=mj+mbig
+ ma(inext)=mj
+ ran3=mj*fac
+end function ran3
+! (C) Copr. 1986-92 Numerical Recipes Software US.
diff --git a/src/readOHfield.f90 b/src/readOHfield.f90
new file mode 100644
index 0000000000000000000000000000000000000000..814e1fd5665dcf0f39e5923a7d92a8011704c143
--- /dev/null
+++ b/src/readOHfield.f90
@@ -0,0 +1,84 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine readOHfield
+
+ !*****************************************************************************
+ ! *
+ ! Reads the OH field into memory *
+ ! *
+ ! AUTHOR: Sabine Eckhardt, June 2007 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! i loop indices *
+ ! LENGTH(numpath) length of the path names *
+ ! PATH(numpath) contains the path names *
+ ! unitoh unit connected with OH field *
+ ! *
+ ! ----- *
+ ! *
+ !*****************************************************************************
+
+ use oh_mod
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: ix,jy,lev,m
+
+
+ ! Read OH field and level heights
+ !********************************
+
+! write (*,*) 'reading OH'
+ open(unitOH,file=path(1)(1:length(1))//'OH_7lev_agl.dat', &
+ status='old',form='UNFORMATTED', err=998)
+ do m=1,12
+ do lev=1,maxzOH
+ do ix=0,maxxOH-1
+ ! do 10 jy=0,maxyOH-1
+ read(unitOH) (OH_field(m,ix,jy,lev),jy=0,maxyOH-1)
+ ! if ((ix.eq.20).and.(lev.eq.1)) then
+ ! write(*,*) 'reading: ', m, OH_field(m,ix,20,lev)
+ ! endif
+ end do
+ end do
+ end do
+ close(unitOH)
+
+ do lev=1,7
+ OH_field_height(lev)=1000+real(lev-1)*2.*1000.
+ end do
+
+! write (*,*) 'OH read'
+ return
+
+ ! Issue error messages
+ !*********************
+
+998 write(*,*) ' #### FLEXPART ERROR! FILE CONTAINING ####'
+ write(*,*) ' #### OH FIELD DOES NOT EXIST ####'
+ stop
+
+end subroutine readohfield
diff --git a/src/readageclasses.f90 b/src/readageclasses.f90
new file mode 100644
index 0000000000000000000000000000000000000000..4ed04c8e759cd0ef134a446f20ddb2f2f29d83d6
--- /dev/null
+++ b/src/readageclasses.f90
@@ -0,0 +1,107 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine readageclasses
+
+ !*****************************************************************************
+ ! *
+ ! This routine reads the age classes to be used for the current model *
+ ! run. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 20 March 2000 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! Constants: *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: i
+
+
+ ! If age spectra calculation is switched off, set number of age classes
+ ! to 1 and maximum age to a large number
+ !**********************************************************************
+
+ if (lagespectra.ne.1) then
+ nageclass=1
+ lage(nageclass)=999999999
+ return
+ endif
+
+
+ ! If age spectra claculation is switched on,
+ ! open the AGECLASSSES file and read user options
+ !************************************************
+
+ open(unitageclasses,file=path(1)(1:length(1))//'AGECLASSES', &
+ status='old',err=999)
+
+ do i=1,13
+ read(unitageclasses,*)
+ end do
+ read(unitageclasses,*) nageclass
+
+
+ if (nageclass.gt.maxageclass) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! NUMBER OF AGE #### '
+ write(*,*) ' #### CLASSES GREATER THAN MAXIMUM ALLOWED. #### '
+ write(*,*) ' #### CHANGE SETTINGS IN FILE AGECLASSES OR #### '
+ write(*,*) ' #### RECOMPILE WITH LARGER MAXAGECLASS IN #### '
+ write(*,*) ' #### FILE PAR_MOD. #### '
+ stop
+ endif
+
+ read(unitageclasses,*) lage(1)
+ if (lage(1).le.0) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! AGE OF FIRST #### '
+ write(*,*) ' #### CLASS MUST BE GREATER THAN ZERO. CHANGE #### '
+ write(*,*) ' #### SETTINGS IN FILE AGECLASSES. #### '
+ stop
+ endif
+
+ do i=2,nageclass
+ read(unitageclasses,*) lage(i)
+ if (lage(i).le.lage(i-1)) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! AGE CLASSES #### '
+ write(*,*) ' #### MUST BE GIVEN IN TEMPORAL ORDER. #### '
+ write(*,*) ' #### CHANGE SETTINGS IN FILE AGECLASSES. #### '
+ stop
+ endif
+ end do
+
+ return
+
+999 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "AGECLASSES" #### '
+ write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### '
+ write(*,'(a)') path(1)(1:length(1))
+ stop
+
+end subroutine readageclasses
diff --git a/src/readavailable.f90 b/src/readavailable.f90
new file mode 100644
index 0000000000000000000000000000000000000000..1e3bf9bfd0c9e399365fd52e7060d62fab54a069
--- /dev/null
+++ b/src/readavailable.f90
@@ -0,0 +1,290 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine readavailable
+
+ !*****************************************************************************
+ ! *
+ ! This routine reads the dates and times for which windfields are *
+ ! available. *
+ ! *
+ ! Authors: A. Stohl *
+ ! *
+ ! 6 February 1994 *
+ ! 8 February 1999, Use of nested fields, A. Stohl *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! bdate beginning date as Julian date *
+ ! beg beginning date for windfields *
+ ! end ending date for windfields *
+ ! fname filename of wind field, help variable *
+ ! ideltas [s] duration of modelling period *
+ ! idiff time difference between 2 wind fields *
+ ! idiffnorm normal time difference between 2 wind fields *
+ ! idiffmax [s] maximum allowable time between 2 wind fields *
+ ! jul julian date, help variable *
+ ! numbwf actual number of wind fields *
+ ! wfname(maxwf) file names of needed wind fields *
+ ! wfspec(maxwf) file specifications of wind fields (e.g., if on disc) *
+ ! wftime(maxwf) [s]times of wind fields relative to beginning time *
+ ! wfname1,wfspec1,wftime1 = same as above, but only local (help variables) *
+ ! *
+ ! Constants: *
+ ! maxwf maximum number of wind fields *
+ ! unitavailab unit connected to file AVAILABLE *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: i,idiff,ldat,ltim,wftime1(maxwf),numbwfn(maxnests),k
+ integer :: wftime1n(maxnests,maxwf),wftimen(maxnests,maxwf)
+ real(kind=dp) :: juldate,jul,beg,end
+ character(len=255) :: fname,spec,wfname1(maxwf),wfspec1(maxwf)
+ character(len=255) :: wfname1n(maxnests,maxwf)
+ character(len=40) :: wfspec1n(maxnests,maxwf)
+
+
+ ! Windfields are only used, if they are within the modelling period.
+ ! However, 1 additional day at the beginning and at the end is used for
+ ! interpolation. -> Compute beginning and ending date for the windfields.
+ !************************************************************************
+
+ if (ideltas.gt.0) then ! forward trajectories
+ beg=bdate-1._dp
+ end=bdate+real(ideltas,kind=dp)/86400._dp+real(idiffmax,kind=dp)/ &
+ 86400._dp
+ else ! backward trajectories
+ beg=bdate+real(ideltas,kind=dp)/86400._dp-real(idiffmax,kind=dp)/ &
+ 86400._dp
+ end=bdate+1._dp
+ endif
+
+ ! Open the wind field availability file and read available wind fields
+ ! within the modelling period.
+ !*********************************************************************
+
+ open(unitavailab,file=path(4)(1:length(4)),status='old', &
+ err=999)
+
+ do i=1,3
+ read(unitavailab,*)
+ end do
+
+ numbwf=0
+100 read(unitavailab,'(i8,1x,i6,2(6x,a255))',end=99) &
+ ldat,ltim,fname,spec
+ jul=juldate(ldat,ltim)
+ if ((jul.ge.beg).and.(jul.le.end)) then
+ numbwf=numbwf+1
+ if (numbwf.gt.maxwf) then ! check exceedance of dimension
+ write(*,*) 'Number of wind fields needed is too great.'
+ write(*,*) 'Reduce modelling period (file "COMMAND") or'
+ write(*,*) 'reduce number of wind fields (file "AVAILABLE").'
+ stop
+ endif
+
+ wfname1(numbwf)=fname(1:index(fname,' '))
+ wfspec1(numbwf)=spec
+ wftime1(numbwf)=nint((jul-bdate)*86400._dp)
+ endif
+ goto 100 ! next wind field
+
+99 continue
+
+ close(unitavailab)
+
+ ! Open the wind field availability file and read available wind fields
+ ! within the modelling period (nested grids)
+ !*********************************************************************
+
+ do k=1,numbnests
+ print*,length(numpath+2*(k-1)+1),length(numpath+2*(k-1)+2),length(4),length(3)
+ print*,path(numpath+2*(k-1)+2)(1:length(numpath+2*(k-1)+2))
+ open(unitavailab,file=path(numpath+2*(k-1)+2) &
+ (1:length(numpath+2*(k-1)+2)),status='old',err=998)
+
+ do i=1,3
+ read(unitavailab,*)
+ end do
+
+ numbwfn(k)=0
+700 read(unitavailab,'(i8,1x,i6,2(6x,a255))',end=699) ldat, &
+ ltim,fname,spec
+ jul=juldate(ldat,ltim)
+ if ((jul.ge.beg).and.(jul.le.end)) then
+ numbwfn(k)=numbwfn(k)+1
+ if (numbwfn(k).gt.maxwf) then ! check exceedance of dimension
+ write(*,*) 'Number of nested wind fields is too great.'
+ write(*,*) 'Reduce modelling period (file "COMMAND") or'
+ write(*,*) 'reduce number of wind fields (file "AVAILABLE").'
+ stop
+ endif
+
+ wfname1n(k,numbwfn(k))=fname
+ wfspec1n(k,numbwfn(k))=spec
+ wftime1n(k,numbwfn(k))=nint((jul-bdate)*86400._dp)
+ endif
+ goto 700 ! next wind field
+
+699 continue
+
+ close(unitavailab)
+ end do
+
+
+ ! Check wind field times of file AVAILABLE (expected to be in temporal order)
+ !****************************************************************************
+
+ if (numbwf.eq.0) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! NO WIND FIELDS #### '
+ write(*,*) ' #### AVAILABLE FOR SELECTED TIME PERIOD. #### '
+ stop
+ endif
+
+ do i=2,numbwf
+ if (wftime1(i).le.wftime1(i-1)) then
+ write(*,*) 'FLEXPART ERROR: FILE AVAILABLE IS CORRUPT.'
+ write(*,*) 'THE WIND FIELDS ARE NOT IN TEMPORAL ORDER.'
+ write(*,*) 'PLEASE CHECK FIELD ',wfname1(i)
+ stop
+ endif
+ end do
+
+ ! Check wind field times of file AVAILABLE for the nested fields
+ ! (expected to be in temporal order)
+ !***************************************************************
+
+ do k=1,numbnests
+ if (numbwfn(k).eq.0) then
+ write(*,*) '#### FLEXPART MODEL ERROR! NO WIND FIELDS ####'
+ write(*,*) '#### AVAILABLE FOR SELECTED TIME PERIOD. ####'
+ stop
+ endif
+
+ do i=2,numbwfn(k)
+ if (wftime1n(k,i).le.wftime1n(k,i-1)) then
+ write(*,*) 'FLEXPART ERROR: FILE AVAILABLE IS CORRUPT. '
+ write(*,*) 'THE NESTED WIND FIELDS ARE NOT IN TEMPORAL ORDER.'
+ write(*,*) 'PLEASE CHECK FIELD ',wfname1n(k,i)
+ write(*,*) 'AT NESTING LEVEL ',k
+ stop
+ endif
+ end do
+
+ end do
+
+
+ ! For backward trajectories, reverse the order of the windfields
+ !***************************************************************
+
+ if (ideltas.ge.0) then
+ do i=1,numbwf
+ wfname(i)=wfname1(i)
+ wfspec(i)=wfspec1(i)
+ wftime(i)=wftime1(i)
+ end do
+ do k=1,numbnests
+ do i=1,numbwfn(k)
+ wfnamen(k,i)=wfname1n(k,i)
+ wfspecn(k,i)=wfspec1n(k,i)
+ wftimen(k,i)=wftime1n(k,i)
+ end do
+ end do
+ else
+ do i=1,numbwf
+ wfname(numbwf-i+1)=wfname1(i)
+ wfspec(numbwf-i+1)=wfspec1(i)
+ wftime(numbwf-i+1)=wftime1(i)
+ end do
+ do k=1,numbnests
+ do i=1,numbwfn(k)
+ wfnamen(k,numbwfn(k)-i+1)=wfname1n(k,i)
+ wfspecn(k,numbwfn(k)-i+1)=wfspec1n(k,i)
+ wftimen(k,numbwfn(k)-i+1)=wftime1n(k,i)
+ end do
+ end do
+ endif
+
+ ! Check the time difference between the wind fields. If it is big,
+ ! write a warning message. If it is too big, terminate the trajectory.
+ !*********************************************************************
+
+ do i=2,numbwf
+ idiff=abs(wftime(i)-wftime(i-1))
+ if (idiff.gt.idiffmax) then
+ write(*,*) 'FLEXPART WARNING: TIME DIFFERENCE BETWEEN TWO'
+ write(*,*) 'WIND FIELDS IS TOO BIG FOR TRANSPORT CALCULATION.&
+ &'
+ write(*,*) 'THEREFORE, TRAJECTORIES HAVE TO BE SKIPPED.'
+ else if (idiff.gt.idiffnorm) then
+ write(*,*) 'FLEXPART WARNING: TIME DIFFERENCE BETWEEN TWO'
+ write(*,*) 'WIND FIELDS IS BIG. THIS MAY CAUSE A DEGRADATION'
+ write(*,*) 'OF SIMULATION QUALITY.'
+ endif
+ end do
+
+ do k=1,numbnests
+ if (numbwfn(k).ne.numbwf) then
+ write(*,*) 'FLEXPART ERROR: THE AVAILABLE FILES FOR THE'
+ write(*,*) 'NESTED WIND FIELDS ARE NOT CONSISTENT WITH'
+ write(*,*) 'THE AVAILABLE FILE OF THE MOTHER DOMAIN. '
+ write(*,*) 'ERROR AT NEST LEVEL: ',k
+ stop
+ endif
+ do i=1,numbwf
+ if (wftimen(k,i).ne.wftime(i)) then
+ write(*,*) 'FLEXPART ERROR: THE AVAILABLE FILES FOR THE'
+ write(*,*) 'NESTED WIND FIELDS ARE NOT CONSISTENT WITH'
+ write(*,*) 'THE AVAILABLE FILE OF THE MOTHER DOMAIN. '
+ write(*,*) 'ERROR AT NEST LEVEL: ',k
+ stop
+ endif
+ end do
+ end do
+
+ ! Reset the times of the wind fields that are kept in memory to no time
+ !**********************************************************************
+
+ do i=1,2
+ memind(i)=i
+ memtime(i)=999999999
+ end do
+
+ return
+
+998 write(*,*) ' #### FLEXPART MODEL ERROR! AVAILABLE FILE #### '
+ write(*,'(a)') ' '//path(numpath+2*(k-1)+2) &
+ (1:length(numpath+2*(k-1)+2))
+ write(*,*) ' #### CANNOT BE OPENED #### '
+ stop
+
+999 write(*,*) ' #### FLEXPART MODEL ERROR! AVAILABLE IILE #### '
+ write(*,'(a)') ' '//path(4)(1:length(4))
+ write(*,*) ' #### CANNOT BE OPENED #### '
+ stop
+
+end subroutine readavailable
diff --git a/src/readcommand.f90 b/src/readcommand.f90
new file mode 100644
index 0000000000000000000000000000000000000000..2221493fcecfd5cba4125d4a557fadc54da22bc0
--- /dev/null
+++ b/src/readcommand.f90
@@ -0,0 +1,597 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine readcommand
+
+ !*****************************************************************************
+ ! *
+ ! This routine reads the user specifications for the current model run. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 18 May 1996 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! bdate beginning date as Julian date *
+ ! ctl factor by which time step must be smaller than *
+ ! Lagrangian time scale *
+ ! ibdate,ibtime beginnning date and time (YYYYMMDD, HHMISS) *
+ ! ideltas [s] modelling period *
+ ! iedate,ietime ending date and time (YYYYMMDD, HHMISS) *
+ ! ifine reduction factor for vertical wind time step *
+ ! outputforeachrel for forward runs it is possible either to create *
+ ! one outputfield or several for each releasepoint *
+ ! iflux switch to turn on (1)/off (0) flux calculations *
+ ! iout 1 for conc. (residence time for backward runs) output,*
+ ! 2 for mixing ratio output, 3 both, 4 for plume *
+ ! trajectory output, 5 = options 1 and 4 *
+ ! ipin 1 continue simulation with dumped particle data, 0 no *
+ ! ipout 0 no particle dump, 1 every output time, 3 only at end*
+ ! itsplit [s] time constant for particle splitting *
+ ! loutaver [s] concentration output is an average over loutaver *
+ ! seconds *
+ ! loutsample [s] average is computed from samples taken every [s] *
+ ! seconds *
+ ! loutstep [s] time interval of concentration output *
+ ! lsynctime [s] synchronisation time interval for all particles *
+ ! lagespectra switch to turn on (1)/off (0) calculation of age *
+ ! spectra *
+ ! lconvection value of either 0 and 1 indicating mixing by *
+ ! convection *
+ ! = 0 .. no convection *
+ ! + 1 .. parameterisation of mixing by subgrid-scale *
+ ! convection = on *
+ ! lsubgrid switch to turn on (1)/off (0) subgrid topography *
+ ! parameterization *
+ ! method method used to compute the particle pseudovelocities *
+ ! mdomainfill 1 use domain-filling option, 0 not, 2 use strat. O3 *
+ ! *
+ ! Constants: *
+ ! unitcommand unit connected to file COMMAND *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ real(kind=dp) :: juldate
+ character(len=50) :: line
+ logical :: old
+ logical :: nmlout=.true. !.false.
+ integer :: readerror
+
+ namelist /command/ &
+ ldirect, &
+ ibdate,ibtime, &
+ iedate,ietime, &
+ loutstep, &
+ loutaver, &
+ loutsample, &
+ itsplit, &
+ lsynctime, &
+ ctl, &
+ ifine, &
+ iout, &
+ ipout, &
+ lsubgrid, &
+ lconvection, &
+ lagespectra, &
+ ipin, &
+ ioutputforeachrelease, &
+ iflux, &
+ mdomainfill, &
+ ind_source, &
+ ind_receptor, &
+ mquasilag, &
+ nested_output, &
+ linit_cond, &
+ surf_only
+
+ ! Presetting namelist command
+ ldirect=1
+ ibdate=20000101
+ ibtime=0
+ iedate=20000102
+ ietime=0
+ loutstep=10800
+ loutaver=10800
+ loutsample=900
+ itsplit=999999999
+ lsynctime=900
+ ctl=-5.0
+ ifine=4
+ iout=3
+ ipout=0
+ lsubgrid=1
+ lconvection=1
+ lagespectra=0
+ ipin=1
+ ioutputforeachrelease=1
+ iflux=1
+ mdomainfill=0
+ ind_source=1
+ ind_receptor=1
+ mquasilag=0
+ nested_output=0
+ linit_cond=0
+ surf_only=0
+
+ ! Open the command file and read user options
+ ! Namelist input first: try to read as namelist file
+ !**************************************************************************
+ open(unitcommand,file=path(1)(1:length(1))//'COMMAND',status='old', &
+ form='formatted',iostat=readerror)
+ ! If fail, check if file does not exist
+ if (readerror.ne.0) then
+
+ print*,'***ERROR: file COMMAND not found in '
+ print*, path(1)(1:length(1))//'COMMAND'
+ print*, 'Check your pathnames file.'
+ stop
+
+ endif
+
+ read(unitcommand,command,iostat=readerror)
+ close(unitcommand)
+
+ ! If error in namelist format, try to open with old input code
+ if (readerror.ne.0) then
+
+ open(unitcommand,file=path(1)(1:length(1))//'COMMAND',status='old', &
+ err=999)
+
+ ! Check the format of the COMMAND file (either in free format,
+ ! or using formatted mask)
+ ! Use of formatted mask is assumed if line 10 contains the word 'DIRECTION'
+ !**************************************************************************
+
+ call skplin(9,unitcommand)
+ read (unitcommand,901) line
+ 901 format (a)
+ if (index(line,'LDIRECT') .eq. 0) then
+ old = .false.
+ else
+ old = .true.
+ endif
+ rewind(unitcommand)
+
+ ! Read parameters
+ !****************
+
+ call skplin(7,unitcommand)
+ if (old) call skplin(1,unitcommand)
+
+ read(unitcommand,*) ldirect
+ if (old) call skplin(3,unitcommand)
+ read(unitcommand,*) ibdate,ibtime
+ if (old) call skplin(3,unitcommand)
+ read(unitcommand,*) iedate,ietime
+ if (old) call skplin(3,unitcommand)
+ read(unitcommand,*) loutstep
+ if (old) call skplin(3,unitcommand)
+ read(unitcommand,*) loutaver
+ if (old) call skplin(3,unitcommand)
+ read(unitcommand,*) loutsample
+ if (old) call skplin(3,unitcommand)
+ read(unitcommand,*) itsplit
+ if (old) call skplin(3,unitcommand)
+ read(unitcommand,*) lsynctime
+ if (old) call skplin(3,unitcommand)
+ read(unitcommand,*) ctl
+ if (old) call skplin(3,unitcommand)
+ read(unitcommand,*) ifine
+ if (old) call skplin(3,unitcommand)
+ read(unitcommand,*) iout
+ if (old) call skplin(3,unitcommand)
+ read(unitcommand,*) ipout
+ if (old) call skplin(3,unitcommand)
+ read(unitcommand,*) lsubgrid
+ if (old) call skplin(3,unitcommand)
+ read(unitcommand,*) lconvection
+ if (old) call skplin(3,unitcommand)
+ read(unitcommand,*) lagespectra
+ if (old) call skplin(3,unitcommand)
+ read(unitcommand,*) ipin
+ if (old) call skplin(3,unitcommand)
+ read(unitcommand,*) ioutputforeachrelease
+ if (old) call skplin(3,unitcommand)
+ read(unitcommand,*) iflux
+ if (old) call skplin(3,unitcommand)
+ read(unitcommand,*) mdomainfill
+ if (old) call skplin(3,unitcommand)
+ read(unitcommand,*) ind_source
+ if (old) call skplin(3,unitcommand)
+ read(unitcommand,*) ind_receptor
+ if (old) call skplin(3,unitcommand)
+ read(unitcommand,*) mquasilag
+ if (old) call skplin(3,unitcommand)
+ read(unitcommand,*) nested_output
+ if (old) call skplin(3,unitcommand)
+ read(unitcommand,*) linit_cond
+ close(unitcommand)
+
+ endif ! input format
+
+ ! write command file in namelist format to output directory if requested
+ if (nmlout.eqv..true.) then
+ !open(unitcommand,file=path(2)(1:length(2))//'COMMAND.namelist.out',status='new',err=1000)
+ open(unitcommand,file=path(2)(1:length(2))//'COMMAND.namelist',err=1000)
+ write(unitcommand,nml=command)
+ close(unitcommand)
+ ! open(unitheader,file=path(2)(1:length(2))//'header_nml',status='new',err=999)
+ ! write(unitheader,NML=COMMAND)
+ !close(unitheader)
+ endif
+
+ ifine=max(ifine,1)
+
+ ! Determine how Markov chain is formulated (for w or for w/sigw)
+ !***************************************************************
+
+ if (ctl.ge.0.1) then
+ turbswitch=.true.
+ else
+ turbswitch=.false.
+ ifine=1
+ endif
+ fine=1./real(ifine)
+ ctl=1./ctl
+
+ ! Set the switches required for the various options for input/output units
+ !*************************************************************************
+ !AF Set the switches IND_REL and IND_SAMP for the release and sampling
+ !Af switches for the releasefile:
+ !Af IND_REL = 1 : xmass * rho
+ !Af IND_REL = 0 : xmass * 1
+
+ !Af switches for the conccalcfile:
+ !AF IND_SAMP = 0 : xmass * 1
+ !Af IND_SAMP = -1 : xmass / rho
+
+ !AF IND_SOURCE switches between different units for concentrations at the source
+ !Af NOTE that in backward simulations the release of computational particles
+ !Af takes place at the "receptor" and the sampling of p[articles at the "source".
+ !Af 1 = mass units
+ !Af 2 = mass mixing ratio units
+ !Af IND_RECEPTOR switches between different units for concentrations at the receptor
+ !Af 1 = mass units
+ !Af 2 = mass mixing ratio units
+
+ if ( ldirect .eq. 1 ) then ! FWD-Run
+ !Af set release-switch
+ if (ind_source .eq. 1 ) then !mass
+ ind_rel = 0
+ else ! mass mix
+ ind_rel = 1
+ endif
+ !Af set sampling switch
+ if (ind_receptor .eq. 1) then !mass
+ ind_samp = 0
+ else ! mass mix
+ ind_samp = -1
+ endif
+ elseif (ldirect .eq. -1 ) then !BWD-Run
+ !Af set sampling switch
+ if (ind_source .eq. 1 ) then !mass
+ ind_samp = -1
+ else ! mass mix
+ ind_samp = 0
+ endif
+ !Af set release-switch
+ if (ind_receptor .eq. 1) then !mass
+ ind_rel = 1
+ else ! mass mix
+ ind_rel = 0
+ endif
+ endif
+
+ !*************************************************************
+ ! Check whether valid options have been chosen in file COMMAND
+ !*************************************************************
+
+ ! Check options for initial condition output: Switch off for forward runs
+ !************************************************************************
+
+ if (ldirect.eq.1) linit_cond=0
+ if ((linit_cond.lt.0).or.(linit_cond.gt.2)) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! INVALID OPTION #### '
+ write(*,*) ' #### FOR LINIT_COND IN FILE "COMMAND". #### '
+ stop
+ endif
+
+ ! Check input dates
+ !******************
+
+ if (iedate.lt.ibdate) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! BEGINNING DATE #### '
+ write(*,*) ' #### IS LARGER THAN ENDING DATE. CHANGE #### '
+ write(*,*) ' #### EITHER POINT 2 OR POINT 3 IN FILE #### '
+ write(*,*) ' #### "COMMAND". #### '
+ stop
+ else if (iedate.eq.ibdate) then
+ if (ietime.lt.ibtime) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! BEGINNING TIME #### '
+ write(*,*) ' #### IS LARGER THAN ENDING TIME. CHANGE #### '
+ write(*,*) ' #### EITHER POINT 2 OR POINT 3 IN FILE #### '
+ write(*,*) ' #### "COMMAND". #### '
+ stop
+ endif
+ endif
+
+
+ ! Determine kind of dispersion method
+ !************************************
+
+ if (ctl.gt.0.) then
+ method=1
+ mintime=minstep
+ else
+ method=0
+ mintime=lsynctime
+ endif
+
+ ! Check whether a valid option for gridded model output has been chosen
+ !**********************************************************************
+
+ if ((iout.lt.1).or.(iout.gt.5)) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! FILE COMMAND: #### '
+ write(*,*) ' #### IOUT MUST BE 1, 2, 3, 4, OR 5! #### '
+ stop
+ endif
+
+ !AF check consistency between units and volume mixing ratio
+ if ( ((iout.eq.2).or.(iout.eq.3)).and. &
+ (ind_source.gt.1 .or.ind_receptor.gt.1) ) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! FILE COMMAND: #### '
+ write(*,*) ' #### VOLUME MIXING RATIO ONLY SUPPORTED #### '
+ write(*,*) ' #### FOR MASS UNITS (at the moment) #### '
+ stop
+ endif
+
+
+
+ ! For quasilag output for each release is forbidden
+ !*****************************************************************************
+
+ if ((ioutputforeachrelease.eq.1).and.(mquasilag.eq.1)) then
+ write(*,*) '#### FLEXPART MODEL ERROR! FILE COMMAND: ####'
+ write(*,*) '#### OUTPUTFOREACHRELEASE AND QUASILAGRANGIAN####'
+ write(*,*) '#### MODE IS NOT POSSIBLE ! ####'
+ stop
+ endif
+
+
+ ! For quasilag backward is forbidden
+ !*****************************************************************************
+
+ if ((ldirect.lt.0).and.(mquasilag.eq.1)) then
+ write(*,*) '#### FLEXPART MODEL ERROR! FILE COMMAND: ####'
+ write(*,*) '#### FOR BACKWARD RUNS, QUASILAGRANGIAN MODE ####'
+ write(*,*) '#### IS NOT POSSIBLE ! ####'
+ stop
+ endif
+
+
+ ! For backward runs one releasefield for all releases makes no sense,
+ ! For quasilag and domainfill ioutputforechrelease is forbidden
+ !*****************************************************************************
+
+ if ((ldirect.lt.0).and.(ioutputforeachrelease.eq.0)) then
+ write(*,*) '#### FLEXPART MODEL ERROR! FILE COMMAND: ####'
+ write(*,*) '#### FOR BACKWARD RUNS, IOUTPUTFOREACHRLEASE ####'
+ write(*,*) '#### MUST BE SET TO ONE! ####'
+ stop
+ endif
+
+
+ ! For backward runs one releasefield for all releases makes no sense,
+ ! and is "forbidden"
+ !*****************************************************************************
+
+ if ((mdomainfill.eq.1).and.(ioutputforeachrelease.eq.1)) then
+ write(*,*) '#### FLEXPART MODEL ERROR! FILE COMMAND: ####'
+ write(*,*) '#### FOR DOMAIN FILLING RUNS OUTPUT FOR ####'
+ write(*,*) '#### EACH RELEASE IS FORBIDDEN ! ####'
+ stop
+ endif
+
+
+ ! For domain-filling trajectories, a plume centroid trajectory makes no sense,
+ ! For backward runs, only residence time output (iout=1) or plume trajectories (iout=4),
+ ! or both (iout=5) makes sense; other output options are "forbidden"
+ !*****************************************************************************
+
+ if (ldirect.lt.0) then
+ if ((iout.eq.2).or.(iout.eq.3)) then
+ write(*,*) '#### FLEXPART MODEL ERROR! FILE COMMAND: ####'
+ write(*,*) '#### FOR BACKWARD RUNS, IOUT MUST BE 1,4,OR 5####'
+ stop
+ endif
+ endif
+
+
+ ! For domain-filling trajectories, a plume centroid trajectory makes no sense,
+ ! and is "forbidden"
+ !*****************************************************************************
+
+ if (mdomainfill.ge.1) then
+ if ((iout.eq.4).or.(iout.eq.5)) then
+ write(*,*) '#### FLEXPART MODEL ERROR! FILE COMMAND: ####'
+ write(*,*) '#### FOR DOMAIN-FILLING TRAJECTORY OPTION, ####'
+ write(*,*) '#### IOUT MUST NOT BE SET TO 4 OR 5. ####'
+ stop
+ endif
+ endif
+
+
+
+ ! Check whether a valid options for particle dump has been chosen
+ !****************************************************************
+
+ if ((ipout.ne.0).and.(ipout.ne.1).and.(ipout.ne.2)) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! FILE COMMAND: #### '
+ write(*,*) ' #### IPOUT MUST BE 1, 2 OR 3! #### '
+ stop
+ endif
+
+ if(lsubgrid.ne.1.and.verbosity.eq.0) then
+ write(*,*) ' ---------------- '
+ write(*,*) ' INFORMATION: SUBGRIDSCALE TERRAIN EFFECT IS'
+ write(*,*) ' NOT PARAMETERIZED DURING THIS SIMULATION. '
+ write(*,*) ' ---------------- '
+ endif
+
+
+ ! Check whether convection scheme is either turned on or off
+ !***********************************************************
+
+ if ((lconvection.ne.0).and.(lconvection.ne.1)) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! FILE COMMAND: #### '
+ write(*,*) ' #### LCONVECTION MUST BE SET TO EITHER 1 OR 0#### '
+ stop
+ endif
+
+
+ ! Check whether synchronisation interval is sufficiently short
+ !*************************************************************
+
+ if (lsynctime.gt.(idiffnorm/2)) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! SYNCHRONISATION #### '
+ write(*,*) ' #### TIME IS TOO LONG. MAKE IT SHORTER. #### '
+ write(*,*) ' #### MINIMUM HAS TO BE: ', idiffnorm/2
+ stop
+ endif
+
+
+ ! Check consistency of the intervals, sampling periods, etc., for model output
+ !*****************************************************************************
+
+ if (loutaver.eq.0) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! TIME AVERAGE OF #### '
+ write(*,*) ' #### CONCENTRATION FIELD OUTPUT MUST NOT BE #### '
+ write(*,*) ' #### ZERO. #### '
+ write(*,*) ' #### CHANGE INPUT IN FILE COMMAND. #### '
+ stop
+ endif
+
+ if (loutaver.gt.loutstep) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! TIME AVERAGE OF #### '
+ write(*,*) ' #### CONCENTRATION FIELD OUTPUT MUST NOT BE #### '
+ write(*,*) ' #### GREATER THAN INTERVAL OF OUTPUT. #### '
+ write(*,*) ' #### CHANGE INPUT IN FILE COMMAND. #### '
+ stop
+ endif
+
+ if (loutsample.gt.loutaver) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! SAMPLING TIME OF #### '
+ write(*,*) ' #### CONCENTRATION FIELD OUTPUT MUST NOT BE #### '
+ write(*,*) ' #### GREATER THAN TIME AVERAGE OF OUTPUT. #### '
+ write(*,*) ' #### CHANGE INPUT IN FILE COMMAND. #### '
+ stop
+ endif
+
+ if (mod(loutaver,lsynctime).ne.0) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! AVERAGING TIME OF #### '
+ write(*,*) ' #### CONCENTRATION FIELD MUST BE A MULTIPLE #### '
+ write(*,*) ' #### OF THE SYNCHRONISATION INTERVAL #### '
+ stop
+ endif
+
+ if ((loutaver/lsynctime).lt.2) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! AVERAGING TIME OF #### '
+ write(*,*) ' #### CONCENTRATION FIELD MUST BE AT LEAST #### '
+ write(*,*) ' #### TWICE THE SYNCHRONISATION INTERVAL #### '
+ stop
+ endif
+
+ if (mod(loutstep,lsynctime).ne.0) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! INTERVAL BETWEEN #### '
+ write(*,*) ' #### CONCENTRATION FIELDS MUST BE A MULTIPLE #### '
+ write(*,*) ' #### OF THE SYNCHRONISATION INTERVAL #### '
+ stop
+ endif
+
+ if ((loutstep/lsynctime).lt.2) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! INTERVAL BETWEEN #### '
+ write(*,*) ' #### CONCENTRATION FIELDS MUST BE AT LEAST #### '
+ write(*,*) ' #### TWICE THE SYNCHRONISATION INTERVAL #### '
+ stop
+ endif
+
+ if (mod(loutsample,lsynctime).ne.0) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! SAMPLING TIME OF #### '
+ write(*,*) ' #### CONCENTRATION FIELD MUST BE A MULTIPLE #### '
+ write(*,*) ' #### OF THE SYNCHRONISATION INTERVAL #### '
+ stop
+ endif
+
+ if (itsplit.lt.loutaver) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! SPLITTING TIME FOR#### '
+ write(*,*) ' #### PARTICLES IS TOO SHORT. PLEASE INCREASE #### '
+ write(*,*) ' #### SPLITTING TIME CONSTANT. #### '
+ stop
+ endif
+
+ if ((mquasilag.eq.1).and.(iout.ge.4)) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! CONFLICTING #### '
+ write(*,*) ' #### OPTIONS: IF MQUASILAG=1, PLUME #### '
+ write(*,*) ' #### TRAJECTORY OUTPUT IS IMPOSSIBLE. #### '
+ stop
+ endif
+
+ ! Compute modeling time in seconds and beginning date in Julian date
+ !*******************************************************************
+
+ outstep=real(abs(loutstep))
+ if (ldirect.eq.1) then
+ bdate=juldate(ibdate,ibtime)
+ edate=juldate(iedate,ietime)
+ ideltas=nint((edate-bdate)*86400.)
+ else if (ldirect.eq.-1) then
+ loutaver=-1*loutaver
+ loutstep=-1*loutstep
+ loutsample=-1*loutsample
+ lsynctime=-1*lsynctime
+ bdate=juldate(iedate,ietime)
+ edate=juldate(ibdate,ibtime)
+ ideltas=nint((edate-bdate)*86400.)
+ else
+ write(*,*) ' #### FLEXPART MODEL ERROR! DIRECTION IN #### '
+ write(*,*) ' #### FILE "COMMAND" MUST BE EITHER -1 OR 1. #### '
+ stop
+ endif
+
+ return
+
+999 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "COMMAND" #### '
+ write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### '
+ write(*,'(a)') path(1)(1:length(1))
+ stop
+
+1000 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "COMMAND" #### '
+ write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### '
+ write(*,'(a)') path(2)(1:length(1))
+ stop
+end subroutine readcommand
diff --git a/src/readdepo.f90 b/src/readdepo.f90
new file mode 100644
index 0000000000000000000000000000000000000000..b9a6d3f60210696d4b8c343a1f0a74b6352e1c42
--- /dev/null
+++ b/src/readdepo.f90
@@ -0,0 +1,145 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine readdepo
+
+ !*****************************************************************************
+ ! *
+ ! Reads dry deposition parameters needed by the procedure of Wesely (1989). *
+ ! Wesely (1989): Parameterization of surface resistances to gaseous *
+ ! dry deposition in regional-scale numerical models. *
+ ! Atmos. Environ. 23, 1293-1304. *
+ ! *
+ ! *
+ ! AUTHOR: Andreas Stohl, 19 May 1995 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! rcl(maxspec,5,9) [s/m] Lower canopy resistance *
+ ! rgs(maxspec,5,9) [s/m] Ground resistance *
+ ! rlu(maxspec,5,9) [s/m] Leaf cuticular resistance *
+ ! rm(maxspec) [s/m] Mesophyll resistance, set in readreleases *
+ ! ri(maxspec) [s/m] Stomatal resistance *
+ ! *
+ ! Constants: *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ ! FOR THIS SUBROUTINE, numclass=9 IS ASSUMED
+ !*******************************************
+
+ real :: rluh(5,numclass),rgssh(5,numclass),rgsoh(5,numclass)
+ real :: rclsh(5,numclass),rcloh(5,numclass)
+ integer :: i,j,ic
+
+
+ ! Read deposition constants related with landuse and seasonal category
+ !*********************************************************************
+ open(unitwesely,file=path(1)(1:length(1))//'surfdepo.t', &
+ status='old',err=999)
+
+ do i=1,16
+ read(unitwesely,*)
+ end do
+ do i=1,5
+ read(unitwesely,*)
+ read(unitwesely,'(8x,13f8.0)') (ri(i,j),j=1,numclass)
+ read(unitwesely,'(8x,13f8.0)') (rluh(i,j),j=1,numclass)
+ read(unitwesely,'(8x,13f8.0)') (rac(i,j),j=1,numclass)
+ read(unitwesely,'(8x,13f8.0)') (rgssh(i,j),j=1,numclass)
+ read(unitwesely,'(8x,13f8.0)') (rgsoh(i,j),j=1,numclass)
+ read(unitwesely,'(8x,13f8.0)') (rclsh(i,j),j=1,numclass)
+ read(unitwesely,'(8x,13f8.0)') (rcloh(i,j),j=1,numclass)
+ end do
+
+ ! TEST
+ ! do 31 i=1,5
+ ! ri(i,13)=ri(i,5)
+ ! rluh(i,13)=rluh(i,5)
+ ! rac(i,13)=rac(i,5)
+ ! rgssh(i,13)=rgssh(i,5)
+ ! rgsoh(i,13)=rgsoh(i,5)
+ ! rclsh(i,13)=rclsh(i,5)
+ ! rcloh(i,13)=rcloh(i,5)
+ !31 continue
+ ! TEST
+ ! Sabine Eckhardt, Dec 06, set resistances of 9999 to 'infinite' (1E25)
+ do i=1,5
+ do j=1,numclass
+ if (ri(i,j).eq.9999.) ri(i,j)=1.E25
+ if (rluh(i,j).eq.9999.) rluh(i,j)=1.E25
+ if (rac(i,j).eq.9999.) rac(i,j)=1.E25
+ if (rgssh(i,j).eq.9999.) rgssh(i,j)=1.E25
+ if (rgsoh(i,j).eq.9999.) rgsoh(i,j)=1.E25
+ if (rclsh(i,j).eq.9999.) rclsh(i,j)=1.E25
+ if (rcloh(i,j).eq.9999.) rcloh(i,j)=1.E25
+ end do
+ end do
+
+
+
+ do i=1,5
+ do j=1,numclass
+ ri(i,j)=max(ri(i,j),0.001)
+ rluh(i,j)=max(rluh(i,j),0.001)
+ rac(i,j)=max(rac(i,j),0.001)
+ rgssh(i,j)=max(rgssh(i,j),0.001)
+ rgsoh(i,j)=max(rgsoh(i,j),0.001)
+ rclsh(i,j)=max(rclsh(i,j),0.001)
+ rcloh(i,j)=max(rcloh(i,j),0.001)
+ end do
+ end do
+ close(unitwesely)
+
+
+ ! Compute additional parameters
+ !******************************
+
+ do ic=1,nspec
+ if (reldiff(ic).gt.0.) then ! gas is dry deposited
+ do i=1,5
+ do j=1,numclass
+ rlu(ic,i,j)=rluh(i,j)/(1.e-5*henry(ic)+f0(ic))
+ rgs(ic,i,j)=1./(henry(ic)/(10.e5*rgssh(i,j))+f0(ic)/ &
+ rgsoh(i,j))
+ rcl(ic,i,j)=1./(henry(ic)/(10.e5*rclsh(i,j))+f0(ic)/ &
+ rcloh(i,j))
+ end do
+ end do
+ endif
+ end do
+
+
+ return
+
+
+999 write(*,*) '### FLEXPART ERROR! FILE ###'
+ write(*,*) '### surfdepo.t DOES NOT EXIST. ###'
+ stop
+
+end subroutine readdepo
diff --git a/src/readlanduse.f90 b/src/readlanduse.f90
new file mode 100644
index 0000000000000000000000000000000000000000..43a227be9d7ec96b445bdc29215daa0826c86071
--- /dev/null
+++ b/src/readlanduse.f90
@@ -0,0 +1,159 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine readlanduse
+
+ !*****************************************************************************
+ ! *
+ ! Reads the landuse inventory into memory and relates it to Leaf Area *
+ ! Index and roughness length. *
+ ! *
+ ! AUTHOR: Andreas Stohl, 10 January 1994 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! i loop indices *
+ ! landinvent(1200,600,13) area fractions of 13 landuse categories *
+ ! LENGTH(numpath) length of the path names *
+ ! PATH(numpath) contains the path names *
+ ! unitland unit connected with landuse inventory *
+ ! *
+ ! ----- *
+ ! Sabine Eckhardt, Dec 06 - new landuse inventary *
+ ! after *
+ ! Belward, A.S., Estes, J.E., and Kline, K.D., 1999, *
+ ! The IGBP-DIS 1-Km Land-Cover Data Set DISCover: *
+ ! A Project Overview: Photogrammetric Engineering and Remote Sensing, *
+ ! v. 65, no. 9, p. 1013-1020 *
+ ! *
+ ! LANDUSE CATEGORIES: *
+ ! *
+ ! 1 Urban land *
+ ! 2 Agricultural land *
+ ! 3 Range land *
+ ! 4 Deciduous forest *
+ ! 5 Coniferous forest *
+ ! 6 Mixed forest including wetland *
+ ! 7 water, both salt and fresh *
+ ! 8 barren land mostly desert *
+ ! 9 nonforested wetland *
+ ! 10 mixed agricultural and range land *
+ ! 11 rocky open areas with low growing shrubs *
+ ! 12 ice *
+ ! 13 rainforest *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: ix,jy,i,k,lu_cat,lu_perc
+ integer(kind=1) :: ilr
+ integer(kind=1) :: ilr_buffer(2160000)
+ integer :: il,irecread
+ real :: rlr, r2lr
+
+
+ ! Read landuse inventory
+ !***********************
+ ! The landuse information is saved in a compressed format and written
+ ! out by records of the length of 1 BYTE. Each grid cell consists of 3
+ ! Bytes, which include 3 landuse categories (val 1-13 and 16 percentage
+ ! categories) So one half byte is used to store the Landusecat the other
+ ! for the percentageclass in 6.25 steps (100/6.25=16)
+ ! e.g.
+ ! 4 3 percentage 4 = 4*6.25 => 25% landuse class 3
+ ! 2 1 percentage 2 = 2*6.25 => 13% landuse class 1
+ ! 1 12 percentage 1 = 1*6.26 => 6.25% landuse class 12
+
+ open(unitland,file=path(1)(1:length(1)) &
+ //'IGBP_int1.dat',status='old', &
+ ! +form='UNFORMATTED', err=998)
+ form='UNFORMATTED', err=998, convert='little_endian')
+! print*,unitland
+ read (unitland) (ilr_buffer(i),i=1,2160000)
+ close(unitland)
+
+ irecread=1
+ do ix=1,1200
+ do jy=1,600
+ ! the 3 most abundant landuse categories in the inventory
+ ! first half byte contains the landuse class
+ ! second half byte contains the respective percentage
+ do k=1,3
+ ! 1 byte is read
+ ilr=ilr_buffer(irecread)
+ ! ilr=0
+ irecread=irecread+1
+ ! as only signed integer values exist an unsigned value is constructed
+ if (ilr.lt.0) then
+ il=ilr+256
+ else
+ il=ilr
+ endif
+ ! dividing by 16 has the effect to get rid of the right half of the byte
+ ! so just the left half remains, this corresponds to a shift right of 4
+ ! bits
+ rlr=real(il)/16.
+ lu_cat=int(rlr)
+ ! the left half of the byte is substracted from the whole in order to
+ ! get only the right half of the byte
+ r2lr=rlr-int(rlr)
+ ! shift left by 4
+ lu_perc=r2lr*16.
+ landinvent(ix,jy,k)=lu_cat
+ landinvent(ix,jy,k+3)=lu_perc
+ ! if ((jy.lt.10).and.(ix.lt.10)) write(*,*) 'reading: ' , ix, jy, lu_cat, lu_perc
+ end do
+ end do
+ end do
+
+ ! Read relation landuse,z0
+ !*****************************
+
+ open(unitsurfdata,file=path(1)(1:length(1))//'surfdata.t', &
+ status='old',err=999)
+
+ do i=1,4
+ read(unitsurfdata,*)
+ end do
+ do i=1,numclass
+ read(unitsurfdata,'(45x,f15.3)') z0(i)
+ end do
+ close(unitsurfdata)
+
+ return
+
+ ! Issue error messages
+ !*********************
+
+998 write(*,*) ' #### FLEXPART ERROR! FILE CONTAINING ####'
+ write(*,*) ' #### LANDUSE INVENTORY DOES NOT EXIST ####'
+ stop
+
+999 write(*,*) ' #### FLEXPART ERROR! FILE CONTAINING ####'
+ write(*,*) ' #### RELATION LANDUSE,z0 DOES NOT EXIST ####'
+ stop
+
+end subroutine readlanduse
diff --git a/src/readlanduse_int1.f90 b/src/readlanduse_int1.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d2a33c303f94aceb324800665c0e5923f3eb4f67
--- /dev/null
+++ b/src/readlanduse_int1.f90
@@ -0,0 +1,161 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine readlanduse
+
+ !*****************************************************************************
+ ! *
+ ! Reads the landuse inventory into memory and relates it to Leaf Area *
+ ! Index and roughness length. *
+ ! *
+ ! AUTHOR: Andreas Stohl, 10 January 1994 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! i loop indices *
+ ! landinvent(1200,600,13) area fractions of 13 landuse categories *
+ ! LENGTH(numpath) length of the path names *
+ ! PATH(numpath) contains the path names *
+ ! unitland unit connected with landuse inventory *
+ ! *
+ ! ----- *
+ ! Sabine Eckhardt, Dec 06 - new landuse inventary *
+ ! after *
+ ! Belward, A.S., Estes, J.E., and Kline, K.D., 1999, *
+ ! The IGBP-DIS 1-Km Land-Cover Data Set DISCover: *
+ ! A Project Overview: Photogrammetric Engineering and Remote Sensing, *
+ ! v. 65, no. 9, p. 1013-1020 *
+ ! *
+ ! LANDUSE CATEGORIES: *
+ ! *
+ ! 1 Urban land *
+ ! 2 Agricultural land *
+ ! 3 Range land *
+ ! 4 Deciduous forest *
+ ! 5 Coniferous forest *
+ ! 6 Mixed forest including wetland *
+ ! 7 water, both salt and fresh *
+ ! 8 barren land mostly desert *
+ ! 9 nonforested wetland *
+ ! 10 mixed agricultural and range land *
+ ! 11 rocky open areas with low growing shrubs *
+ ! 12 ice *
+ ! 13 rainforest *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: ix,jy,i,k,lu_cat,lu_perc
+ integer(kind=1) :: ilr
+ integer(kind=1) :: ilr_buffer(2160000)
+ integer :: il,irecread
+ real :: rlr, r2lr
+
+
+ ! Read landuse inventory
+ !***********************
+ ! The landuse information is saved in a compressed format and written
+ ! out by records of the length of 1 BYTE. Each grid cell consists of 3
+ ! Bytes, which include 3 landuse categories (val 1-13 and 16 percentage
+ ! categories) So one half byte is used to store the Landusecat the other
+ ! for the percentageclass in 6.25 steps (100/6.25=16)
+ ! e.g.
+ ! 4 3 percentage 4 = 4*6.25 => 25% landuse class 3
+ ! 2 1 percentage 2 = 2*6.25 => 13% landuse class 1
+ ! 1 12 percentage 1 = 1*6.26 => 6.25% landuse class 12
+
+
+ write (*,*) 'reading: ',path(1)(1:length(1))
+ open(unitland,file=path(1)(1:length(1)) &
+ //'IGBP_int1.dat',status='old', &
+ form='UNFORMATTED', err=998)
+ read (unitland) (ilr_buffer(i),i=1,2160000)
+ close(unitland)
+ write (*,*) 'reading: '
+
+ irecread=1
+ do ix=1,1200
+ do jy=1,600
+ ! the 3 most abundant landuse categories in the inventory
+ ! first half byte contains the landuse class
+ ! second half byte contains the respective percentage
+ do k=1,3
+ ! 1 byte is read
+ ilr=ilr_buffer(irecread)
+ irecread=irecread+1
+ ! as only signed integer values exist an unsigned value is constructed
+ if (ilr.lt.0) then
+ il=ilr+256
+ else
+ il=ilr
+ endif
+ ! dividing by 16 has the effect to get rid of the right half of the byte
+ ! so just the left half remains, this corresponds to a shift right of 4
+ ! bits
+ rlr=real(il)/16.
+ lu_cat=int(rlr)
+ ! the left half of the byte is substracted from the whole in order to
+ ! get only the right half of the byte
+ r2lr=rlr-int(rlr)
+ ! shift left by 4
+ lu_perc=r2lr*16.
+ landinvent(ix,jy,k)=lu_cat
+ landinvent(ix,jy,k+3)=lu_perc
+ if ((jy.lt.10).and.(ix.lt.10)) then
+ write(*,*) 'reading: ', ix, jy, lu_cat, lu_perc
+ endif
+ end do
+ end do
+ end do
+
+ ! Read relation landuse,z0
+ !*****************************
+
+ open(unitsurfdata,file=path(1)(1:length(1))//'surfdata.t', &
+ status='old',err=999)
+
+ do i=1,4
+ read(unitsurfdata,*)
+ end do
+ do i=1,numclass
+ read(unitsurfdata,'(45x,f15.3)') z0(i)
+ end do
+ close(unitsurfdata)
+
+ return
+
+ ! Issue error messages
+ !*********************
+
+998 write(*,*) ' #### FLEXPART ERROR! FILE CONTAINING ####'
+ write(*,*) ' #### LANDUSE INVENTORY DOES NOT EXIST ####'
+ stop
+
+999 write(*,*) ' #### FLEXPART ERROR! FILE CONTAINING ####'
+ write(*,*) ' #### RELATION LANDUSE,z0 DOES NOT EXIST ####'
+ stop
+
+end subroutine readlanduse
diff --git a/src/readoutgrid.f90 b/src/readoutgrid.f90
new file mode 100644
index 0000000000000000000000000000000000000000..60f19ed44d731135681019e5d17ed4bb6caf1541
--- /dev/null
+++ b/src/readoutgrid.f90
@@ -0,0 +1,190 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine readoutgrid
+
+ !*****************************************************************************
+ ! *
+ ! This routine reads the user specifications for the output grid. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 4 June 1996 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! dxout,dyout grid distance *
+ ! numxgrid,numygrid,numzgrid grid dimensions *
+ ! outlon0,outlat0 lower left corner of grid *
+ ! outheight(maxzgrid) height levels of output grid [m] *
+ ! *
+ ! Constants: *
+ ! unitoutgrid unit connected to file OUTGRID *
+ ! *
+ !*****************************************************************************
+
+ use outg_mod
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: i,j,stat
+ real :: outhelp,xr,xr1,yr,yr1
+ real,parameter :: eps=1.e-4
+
+
+
+ ! Open the OUTGRID file and read output grid specifications
+ !**********************************************************
+
+ open(unitoutgrid,file=path(1)(1:length(1))//'OUTGRID',status='old', &
+ err=999)
+
+
+ call skplin(5,unitoutgrid)
+
+
+ ! 1. Read horizontal grid specifications
+ !****************************************
+
+ call skplin(3,unitoutgrid)
+ read(unitoutgrid,'(4x,f11.4)') outlon0
+ call skplin(3,unitoutgrid)
+ read(unitoutgrid,'(4x,f11.4)') outlat0
+ call skplin(3,unitoutgrid)
+ read(unitoutgrid,'(4x,i5)') numxgrid
+ call skplin(3,unitoutgrid)
+ read(unitoutgrid,'(4x,i5)') numygrid
+ call skplin(3,unitoutgrid)
+ read(unitoutgrid,'(4x,f12.5)') dxout
+ call skplin(3,unitoutgrid)
+ read(unitoutgrid,'(4x,f12.5)') dyout
+
+
+ ! Check validity of output grid (shall be within model domain)
+ !*************************************************************
+
+ xr=outlon0+real(numxgrid)*dxout
+ yr=outlat0+real(numygrid)*dyout
+ xr1=xlon0+real(nxmin1)*dx
+ yr1=ylat0+real(nymin1)*dy
+ if ((outlon0+eps.lt.xlon0).or.(outlat0+eps.lt.ylat0) &
+ .or.(xr.gt.xr1+eps).or.(yr.gt.yr1+eps)) then
+ write(*,*) 'outlon0,outlat0:'
+ write(*,*) outlon0,outlat0
+ write(*,*) 'xr1,yr1,xlon0,ylat0,xr,yr,dxout,dyout:'
+ write(*,*) xr1,yr1,xlon0,ylat0,xr,yr,dxout,dyout
+ write(*,*) ' #### FLEXPART MODEL ERROR! PART OF OUTPUT ####'
+ write(*,*) ' #### GRID IS OUTSIDE MODEL DOMAIN. CHANGE ####'
+ write(*,*) ' #### FILE OUTGRID IN DIRECTORY ####'
+ write(*,'(a)') path(1)(1:length(1))
+ stop
+ endif
+
+ ! 2. Count Vertical levels of output grid
+ !****************************************
+ j=0
+100 j=j+1
+ do i=1,3
+ read(unitoutgrid,*,end=99)
+ end do
+ read(unitoutgrid,'(4x,f7.1)',end=99) outhelp
+ if (outhelp.eq.0.) goto 99
+ goto 100
+99 numzgrid=j-1
+
+ allocate(outheight(numzgrid) &
+ ,stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate outh'
+ allocate(outheighthalf(numzgrid) &
+ ,stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate outh'
+
+
+ rewind(unitoutgrid)
+ call skplin(29,unitoutgrid)
+
+ ! 2. Vertical levels of output grid
+ !**********************************
+
+ j=0
+1000 j=j+1
+ do i=1,3
+ read(unitoutgrid,*,end=990)
+ end do
+ read(unitoutgrid,'(4x,f7.1)',end=990) outhelp
+ if (outhelp.eq.0.) goto 99
+ outheight(j)=outhelp
+ goto 1000
+990 numzgrid=j-1
+
+
+ ! Check whether vertical levels are specified in ascending order
+ !***************************************************************
+
+ do j=2,numzgrid
+ if (outheight(j).le.outheight(j-1)) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! YOUR SPECIFICATION#### '
+ write(*,*) ' #### OF OUTPUT LEVELS IS CORRUPT AT LEVEL #### '
+ write(*,*) ' #### ',j,' #### '
+ write(*,*) ' #### PLEASE MAKE CHANGES IN FILE OUTGRID. #### '
+ endif
+ end do
+
+ ! Determine the half levels, i.e. middle levels of the output grid
+ !*****************************************************************
+
+ outheighthalf(1)=outheight(1)/2.
+ do j=2,numzgrid
+ outheighthalf(j)=(outheight(j-1)+outheight(j))/2.
+ end do
+
+
+ xoutshift=xlon0-outlon0
+ youtshift=ylat0-outlat0
+ close(unitoutgrid)
+
+ allocate(oroout(0:numxgrid-1,0:numygrid-1) &
+ ,stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate outh'
+ allocate(area(0:numxgrid-1,0:numygrid-1) &
+ ,stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate outh'
+ allocate(volume(0:numxgrid-1,0:numygrid-1,numzgrid) &
+ ,stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate outh'
+ allocate(areaeast(0:numxgrid-1,0:numygrid-1,numzgrid) &
+ ,stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate outh'
+ allocate(areanorth(0:numxgrid-1,0:numygrid-1,numzgrid) &
+ ,stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate outh'
+ return
+
+
+999 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "OUTGRID" #### '
+ write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### '
+ write(*,*) ' #### xxx/flexpart/options #### '
+ stop
+
+end subroutine readoutgrid
diff --git a/src/readoutgrid_nest.f90 b/src/readoutgrid_nest.f90
new file mode 100644
index 0000000000000000000000000000000000000000..0e8629ec9d401cdf45c2fe59ece752e90d386e8e
--- /dev/null
+++ b/src/readoutgrid_nest.f90
@@ -0,0 +1,121 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine readoutgrid_nest
+
+ !*****************************************************************************
+ ! *
+ ! This routine reads the user specifications for the output nest. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 4 June 1996 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! dxoutn,dyoutn grid distances of output nest *
+ ! numxgridn,numygridn,numzgrid nest dimensions *
+ ! outlon0n,outlat0n lower left corner of nest *
+ ! outheight(maxzgrid) height levels of output grid [m] *
+ ! *
+ ! Constants: *
+ ! unitoutgrid unit connected to file OUTGRID *
+ ! *
+ !*****************************************************************************
+
+ use outg_mod
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: stat
+ real :: xr,xr1,yr,yr1
+ real,parameter :: eps=1.e-4
+
+
+
+ ! Open the OUTGRID file and read output grid specifications
+ !**********************************************************
+
+ open(unitoutgrid,file=path(1)(1:length(1))//'OUTGRID_NEST', &
+ status='old',err=999)
+
+
+ call skplin(5,unitoutgrid)
+
+
+ ! 1. Read horizontal grid specifications
+ !****************************************
+
+ call skplin(3,unitoutgrid)
+ read(unitoutgrid,'(4x,f11.4)') outlon0n
+ call skplin(3,unitoutgrid)
+ read(unitoutgrid,'(4x,f11.4)') outlat0n
+ call skplin(3,unitoutgrid)
+ read(unitoutgrid,'(4x,i5)') numxgridn
+ call skplin(3,unitoutgrid)
+ read(unitoutgrid,'(4x,i5)') numygridn
+ call skplin(3,unitoutgrid)
+ read(unitoutgrid,'(4x,f12.5)') dxoutn
+ call skplin(3,unitoutgrid)
+ read(unitoutgrid,'(4x,f12.5)') dyoutn
+
+
+ allocate(orooutn(0:numxgridn-1,0:numygridn-1) &
+ ,stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate outh'
+ allocate(arean(0:numxgridn-1,0:numygridn-1) &
+ ,stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate outh'
+ allocate(volumen(0:numxgridn-1,0:numygridn-1,numzgrid) &
+ ,stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate outh'
+
+ ! Check validity of output grid (shall be within model domain)
+ !*************************************************************
+
+ xr=outlon0n+real(numxgridn)*dxoutn
+ yr=outlat0n+real(numygridn)*dyoutn
+ xr1=xlon0+real(nxmin1)*dx
+ yr1=ylat0+real(nymin1)*dy
+ if ((outlon0n+eps.lt.xlon0).or.(outlat0n+eps.lt.ylat0) &
+ .or.(xr.gt.xr1+eps).or.(yr.gt.yr1+eps)) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! PART OF OUTPUT ####'
+ write(*,*) ' #### NEST IS OUTSIDE MODEL DOMAIN. CHANGE ####'
+ write(*,*) ' #### FILE OUTGRID IN DIRECTORY ####'
+ write(*,'(a)') path(1)(1:length(1))
+ stop
+ endif
+
+ xoutshiftn=xlon0-outlon0n
+ youtshiftn=ylat0-outlat0n
+ close(unitoutgrid)
+ return
+
+
+999 write(*,*) ' #### FLEXPART MODEL ERROR! FILE OUTGRID_NEST #### '
+ write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### '
+ write(*,*) ' #### xxx/flexpart/options #### '
+ stop
+
+end subroutine readoutgrid_nest
diff --git a/src/readpartpositions.f90 b/src/readpartpositions.f90
new file mode 100644
index 0000000000000000000000000000000000000000..f26d0506490e23a6d3de496651cdcba653e6a621
--- /dev/null
+++ b/src/readpartpositions.f90
@@ -0,0 +1,173 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine readpartpositions
+
+ !*****************************************************************************
+ ! *
+ ! This routine opens the particle dump file and reads all the particle *
+ ! positions from a previous run to initialize the current run. *
+ ! *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 24 March 2000 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: ibdatein,ibtimein,nspecin,itimein,numpointin,i,j,ix
+ integer :: id1,id2,it1,it2
+ real :: xlonin,ylatin,ran1,topo,hmixi,pvi,qvi,rhoi,tri,tti
+ character :: specin*7
+ real(kind=dp) :: julin,julpartin,juldate
+
+ integer :: idummy = -8
+
+ numparticlecount=0
+
+ ! Open header file of dumped particle data
+ !*****************************************
+
+ open(unitpartin,file=path(2)(1:length(2))//'header', &
+ form='unformatted',err=998)
+
+ read(unitpartin) ibdatein,ibtimein
+ read(unitpartin)
+ read(unitpartin)
+
+ read(unitpartin)
+ read(unitpartin)
+ read(unitpartin) nspecin
+ nspecin=nspecin/3
+ if ((ldirect.eq.1).and.(nspec.ne.nspecin)) goto 997
+
+ do i=1,nspecin
+ read(unitpartin)
+ read(unitpartin)
+ read(unitpartin) j,specin
+ if ((ldirect.eq.1).and.(species(i)(1:7).ne.specin)) goto 996
+ end do
+
+ read(unitpartin) numpointin
+ if (numpointin.ne.numpoint) goto 995
+999 continue
+ do i=1,numpointin
+ read(unitpartin)
+ read(unitpartin)
+ read(unitpartin)
+ read(unitpartin)
+ do j=1,nspec
+ read(unitpartin)
+ read(unitpartin)
+ read(unitpartin)
+ end do
+ end do
+ read(unitpartin)
+ read(unitpartin)
+
+ do ix=0,numxgrid-1
+ read(unitpartin)
+ end do
+
+
+ ! Open data file of dumped particle data
+ !***************************************
+
+ close(unitpartin)
+ open(unitpartin,file=path(2)(1:length(2))//'partposit_end', &
+ form='unformatted',err=998)
+
+
+100 read(unitpartin,end=99) itimein
+ i=0
+200 i=i+1
+ read(unitpartin) npoint(i),xlonin,ylatin,ztra1(i),itramem(i), &
+ topo,pvi,qvi,rhoi,hmixi,tri,tti,(xmass1(i,j),j=1,nspec)
+
+ if (xlonin.eq.-9999.9) goto 100
+ xtra1(i)=(xlonin-xlon0)/dx
+ ytra1(i)=(ylatin-ylat0)/dy
+ numparticlecount=max(numparticlecount,npoint(i))
+ goto 200
+
+99 numpart=i-1
+
+ close(unitpartin)
+
+ julin=juldate(ibdatein,ibtimein)+real(itimein,kind=dp)/86400._dp
+ if (abs(julin-bdate).gt.1.e-5) goto 994
+ do i=1,numpart
+ julpartin=juldate(ibdatein,ibtimein)+ &
+ real(itramem(i),kind=dp)/86400._dp
+ nclass(i)=min(int(ran1(idummy)*real(nclassunc))+1, &
+ nclassunc)
+ idt(i)=mintime
+ itra1(i)=0
+ itramem(i)=nint((julpartin-bdate)*86400.)
+ itrasplit(i)=ldirect*itsplit
+ end do
+
+ return
+
+
+994 write(*,*) ' #### FLEXPART MODEL ERROR IN READPARTPOSITIONS#### '
+ write(*,*) ' #### ENDING TIME OF PREVIOUS MODEL RUN DOES #### '
+ write(*,*) ' #### NOT AGREE WITH STARTING TIME OF THIS RUN.#### '
+ call caldate(julin,id1,it1)
+ call caldate(bdate,id2,it2)
+ write(*,*) 'julin: ',julin,id1,it1
+ write(*,*) 'bdate: ',bdate,id2,it2
+ stop
+
+!995 write(*,*) ' #### FLEXPART MODEL ERROR IN READPARTPOSITIONS#### '
+995 write(*,*) ' #### FLEXPART MODEL WARNING IN READPARTPOSITIONS#### '
+ write(*,*) ' #### NUMBER OF RELEASE LOCATIONS DOES NOT #### '
+ write(*,*) ' #### AGREE WITH CURRENT SETTINGS! #### '
+! stop
+ goto 999
+
+996 write(*,*) ' #### FLEXPART MODEL ERROR IN READPARTPOSITIONS#### '
+ write(*,*) ' #### SPECIES NAMES TO BE READ IN DO NOT #### '
+ write(*,*) ' #### AGREE WITH CURRENT SETTINGS! #### '
+ stop
+
+997 write(*,*) ' #### FLEXPART MODEL ERROR IN READPARTPOSITIONS#### '
+ write(*,*) ' #### THE NUMBER OF SPECIES TO BE READ IN DOES #### '
+ write(*,*) ' #### NOT AGREE WITH CURRENT SETTINGS! #### '
+ stop
+
+998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### '
+ write(*,*) ' #### '//path(2)(1:length(2))//'grid'//' #### '
+ write(*,*) ' #### CANNOT BE OPENED. IF A FILE WITH THIS #### '
+ write(*,*) ' #### NAME ALREADY EXISTS, DELETE IT AND START #### '
+ write(*,*) ' #### THE PROGRAM AGAIN. #### '
+ stop
+
+end subroutine readpartpositions
diff --git a/src/readpaths.f90 b/src/readpaths.f90
new file mode 100644
index 0000000000000000000000000000000000000000..22a97286e0a42c4e58cef466e610119e97ff1e41
--- /dev/null
+++ b/src/readpaths.f90
@@ -0,0 +1,110 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine readpaths !(pathfile)
+
+ !*****************************************************************************
+ ! *
+ ! Reads the pathnames, where input/output files are expected to be. *
+ ! The file pathnames must be available in the current working directory. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 1 February 1994 *
+ ! last modified *
+ ! HS, 7.9.2012 *
+ ! option to give pathnames file as command line option *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! length(numpath) lengths of the path names *
+ ! path(numpath) pathnames of input/output files *
+ ! *
+ ! Constants: *
+ ! numpath number of pathnames to be read in *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: i
+ character(256) :: string_test
+ character(1) :: character_test
+
+ ! Read the pathname information stored in unitpath
+ !*************************************************
+
+ open(unitpath,file=trim(pathfile),status='old',err=999)
+
+ do i=1,numpath
+ read(unitpath,'(a)',err=998) path(i)
+ length(i)=index(path(i),' ')-1
+
+
+ string_test = path(i)
+ character_test = string_test(length(i):length(i))
+ !print*, 'character_test, string_test ', character_test, string_test
+ if ((character_test .NE. '/') .AND. (i .LT. 4)) then
+ print*, 'WARNING: path not ending in /'
+ print*, path(i)
+ path(i) = string_test(1:length(i)) // '/'
+ length(i)=length(i)+1
+ print*, 'fix: padded with /'
+ print*, path(i)
+ print*, 'length(i) increased 1'
+ endif
+ end do
+
+ ! Check whether any nested subdomains are to be used
+ !***************************************************
+
+ do i=1,maxnests
+ read(unitpath,'(a)') path(numpath+2*(i-1)+1)
+ read(unitpath,'(a)') path(numpath+2*(i-1)+2)
+ if (path(numpath+2*(i-1)+1)(1:5).eq.'=====') goto 30
+ length(numpath+2*(i-1)+1)=index(path(numpath+2*(i-1)+1),' ')-1
+ length(numpath+2*(i-1)+2)=index(path(numpath+2*(i-1)+2),' ')-1
+ end do
+ print*,length(5),length(6)
+
+
+ ! Determine number of available nested domains
+ !*********************************************
+
+30 numbnests=i-1
+
+ close(unitpath)
+ return
+
+998 write(*,*) ' #### TRAJECTORY MODEL ERROR! ERROR WHILE #### '
+ write(*,*) ' #### READING FILE PATHNAMES. #### '
+ stop
+
+999 write(*,*) ' #### TRAJECTORY MODEL ERROR! FILE "pathnames"#### '
+ write(*,*) ' #### CANNOT BE OPENED IN THE CURRENT WORKING #### '
+ write(*,*) ' #### DIRECTORY. #### '
+ stop
+
+end subroutine readpaths
diff --git a/src/readreceptors.f90 b/src/readreceptors.f90
new file mode 100644
index 0000000000000000000000000000000000000000..9f4d8b6e568cfa8c632beb950d99bbabe5b6845c
--- /dev/null
+++ b/src/readreceptors.f90
@@ -0,0 +1,114 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine readreceptors
+
+ !*****************************************************************************
+ ! *
+ ! This routine reads the user specifications for the receptor points. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 1 August 1996 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! receptorarea(maxreceptor) area of dx*dy at location of receptor *
+ ! receptorname(maxreceptor) names of receptors *
+ ! xreceptor,yreceptor coordinates of receptor points *
+ ! *
+ ! Constants: *
+ ! unitreceptor unit connected to file RECEPTORS *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: j
+ real :: x,y,xm,ym
+ character(len=16) :: receptor
+
+
+ ! For backward runs, do not allow receptor output. Thus, set number of receptors to zero
+ !*****************************************************************************
+
+ if (ldirect.lt.0) then
+ numreceptor=0
+ return
+ endif
+
+
+ ! Open the RECEPTORS file and read output grid specifications
+ !************************************************************
+
+ open(unitreceptor,file=path(1)(1:length(1))//'RECEPTORS', &
+ status='old',err=999)
+
+ call skplin(5,unitreceptor)
+
+
+ ! Read the names and coordinates of the receptors
+ !************************************************
+
+ j=0
+100 j=j+1
+ read(unitreceptor,*,end=99)
+ read(unitreceptor,*,end=99)
+ read(unitreceptor,*,end=99)
+ read(unitreceptor,'(4x,a16)',end=99) receptor
+ call skplin(3,unitreceptor)
+ read(unitreceptor,'(4x,f11.4)',end=99) x
+ call skplin(3,unitreceptor)
+ read(unitreceptor,'(4x,f11.4)',end=99) y
+ if ((x.eq.0.).and.(y.eq.0.).and. &
+ (receptor.eq.' ')) then
+ j=j-1
+ goto 100
+ endif
+ if (j.gt.maxreceptor) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! TOO MANY RECEPTOR #### '
+ write(*,*) ' #### POINTS ARE GIVEN. #### '
+ write(*,*) ' #### MAXIMUM NUMBER IS ',maxreceptor,' #### '
+ write(*,*) ' #### PLEASE MAKE CHANGES IN FILE RECEPTORS #### '
+ endif
+ receptorname(j)=receptor
+ xreceptor(j)=(x-xlon0)/dx ! transform to grid coordinates
+ yreceptor(j)=(y-ylat0)/dy
+ xm=r_earth*cos(y*pi/180.)*dx/180.*pi
+ ym=r_earth*dy/180.*pi
+ receptorarea(j)=xm*ym
+ goto 100
+
+99 numreceptor=j-1
+ close(unitreceptor)
+ return
+
+
+999 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "RECEPTORS" #### '
+ write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### '
+ write(*,'(a)') path(1)(1:length(1))
+ stop
+
+end subroutine readreceptors
diff --git a/src/readreleases.f90 b/src/readreleases.f90
new file mode 100644
index 0000000000000000000000000000000000000000..3f842292ca5b168552a5359f03f1f34d1e24e80d
--- /dev/null
+++ b/src/readreleases.f90
@@ -0,0 +1,508 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine readreleases
+
+ !*****************************************************************************
+ ! *
+ ! This routine reads the release point specifications for the current *
+ ! model run. Several release points can be used at the same time. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 18 May 1996 *
+ ! *
+ ! Update: 29 January 2001 *
+ ! Release altitude can be either in magl or masl *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! decay decay constant of species *
+ ! dquer [um] mean particle diameters *
+ ! dsigma e.g. dsigma=10 or dsigma=0.1 means that 68% of the mass*
+ ! are between 0.1*dquer and 10*dquer *
+ ! ireleasestart, ireleaseend [s] starting time and ending time of each *
+ ! release *
+ ! kindz 1: zpoint is in m agl, 2: zpoint is in m asl, 3: zpoint*
+ ! is in hPa *
+ ! npart number of particles to be released *
+ ! nspec number of species to be released *
+ ! density [kg/m3] density of the particles *
+ ! rm [s/m] Mesophyll resistance *
+ ! species name of species *
+ ! xmass total mass of each species *
+ ! xpoint1,ypoint1 geograf. coordinates of lower left corner of release *
+ ! area *
+ ! xpoint2,ypoint2 geograf. coordinates of upper right corner of release *
+ ! area *
+ ! weta, wetb parameters to determine the wet scavenging coefficient *
+ ! zpoint1,zpoint2 height range, over which release takes place *
+ ! num_min_discrete if less, release cannot be randomized and happens at *
+ ! time mid-point of release interval *
+ ! *
+ !*****************************************************************************
+
+ use point_mod
+ use xmass_mod
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: numpartmax,i,j,id1,it1,id2,it2,specnum_rel,idum,stat
+ integer,parameter :: num_min_discrete=100
+ real :: vsh(ni),fracth(ni),schmih(ni),releaserate,xdum,cun
+ real(kind=dp) :: jul1,jul2,julm,juldate
+ character(len=50) :: line
+ logical :: old
+
+ !sec, read release to find how many releasepoints should be allocated
+
+ open(unitreleases,file=path(1)(1:length(1))//'RELEASES',status='old', &
+ err=999)
+
+ ! Check the format of the RELEASES file (either in free format,
+ ! or using a formatted mask)
+ ! Use of formatted mask is assumed if line 10 contains the word 'DIRECTION'
+ !**************************************************************************
+
+ call skplin(12,unitreleases)
+ read (unitreleases,901) line
+901 format (a)
+ if (index(line,'Total') .eq. 0) then
+ old = .false.
+ else
+ old = .true.
+ endif
+ rewind(unitreleases)
+
+
+ ! Skip first 11 lines (file header)
+ !**********************************
+
+ call skplin(11,unitreleases)
+
+
+ read(unitreleases,*,err=998) nspec
+ if (old) call skplin(2,unitreleases)
+ do i=1,nspec
+ read(unitreleases,*,err=998) specnum_rel
+ if (old) call skplin(2,unitreleases)
+ end do
+
+ numpoint=0
+100 numpoint=numpoint+1
+ read(unitreleases,*,end=25)
+ read(unitreleases,*,err=998,end=25) idum,idum
+ if (old) call skplin(2,unitreleases)
+ read(unitreleases,*,err=998) idum,idum
+ if (old) call skplin(2,unitreleases)
+ read(unitreleases,*,err=998) xdum
+ if (old) call skplin(2,unitreleases)
+ read(unitreleases,*,err=998) xdum
+ if (old) call skplin(2,unitreleases)
+ read(unitreleases,*,err=998) xdum
+ if (old) call skplin(2,unitreleases)
+ read(unitreleases,*,err=998) xdum
+ if (old) call skplin(2,unitreleases)
+ read(unitreleases,*,err=998) idum
+ if (old) call skplin(2,unitreleases)
+ read(unitreleases,*,err=998) xdum
+ if (old) call skplin(2,unitreleases)
+ read(unitreleases,*,err=998) xdum
+ if (old) call skplin(2,unitreleases)
+ read(unitreleases,*,err=998) idum
+ if (old) call skplin(2,unitreleases)
+ do i=1,nspec
+ read(unitreleases,*,err=998) xdum
+ if (old) call skplin(2,unitreleases)
+ end do
+ !save compoint only for the first 1000 release points
+ read(unitreleases,'(a40)',err=998) compoint(1)(1:40)
+ if (old) call skplin(1,unitreleases)
+
+ goto 100
+
+25 numpoint=numpoint-1
+
+ !allocate memory for numpoint releaspoint
+ allocate(ireleasestart(numpoint) &
+ ,stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT'
+ allocate(ireleaseend(numpoint) &
+ ,stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT'
+ allocate(xpoint1(numpoint) &
+ ,stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT'
+ allocate(xpoint2(numpoint) &
+ ,stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT'
+ allocate(ypoint1(numpoint) &
+ ,stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT'
+ allocate(ypoint2(numpoint) &
+ ,stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT'
+ allocate(zpoint1(numpoint) &
+ ,stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT'
+ allocate(zpoint2(numpoint) &
+ ,stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT'
+ allocate(kindz(numpoint) &
+ ,stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT'
+ allocate(xmass(numpoint,maxspec) &
+ ,stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT'
+ allocate(rho_rel(numpoint) &
+ ,stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT'
+ allocate(npart(numpoint) &
+ ,stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT'
+ allocate(xmasssave(numpoint) &
+ ,stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT'
+
+ write (*,*) ' Releasepoints allocated: ', numpoint
+
+ do i=1,numpoint
+ xmasssave(i)=0.
+ end do
+
+ !now save the information
+ DEP=.false.
+ DRYDEP=.false.
+ WETDEP=.false.
+ OHREA=.false.
+ do i=1,maxspec
+ DRYDEPSPEC(i)=.false.
+ end do
+
+ rewind(unitreleases)
+
+
+ ! Skip first 11 lines (file header)
+ !**********************************
+
+ call skplin(11,unitreleases)
+
+
+ ! Assign species-specific parameters needed for physical processes
+ !*************************************************************************
+
+ read(unitreleases,*,err=998) nspec
+ if (nspec.gt.maxspec) goto 994
+ if (old) call skplin(2,unitreleases)
+ do i=1,nspec
+ read(unitreleases,*,err=998) specnum_rel
+ if (old) call skplin(2,unitreleases)
+ call readspecies(specnum_rel,i)
+
+ ! For backward runs, only 1 species is allowed
+ !*********************************************
+
+ !if ((ldirect.lt.0).and.(nspec.gt.1)) then
+ !write(*,*) '#####################################################'
+ !write(*,*) '#### FLEXPART MODEL SUBROUTINE READRELEASES: ####'
+ !write(*,*) '#### FOR BACKWARD RUNS, ONLY 1 SPECIES IS ALLOWED####'
+ !write(*,*) '#####################################################'
+ ! stop
+ !endif
+
+ ! Molecular weight
+ !*****************
+
+ if (((iout.eq.2).or.(iout.eq.3)).and. &
+ (weightmolar(i).lt.0.)) then
+ write(*,*) 'For mixing ratio output, valid molar weight'
+ write(*,*) 'must be specified for all simulated species.'
+ write(*,*) 'Check table SPECIES or choose concentration'
+ write(*,*) 'output instead if molar weight is not known.'
+ stop
+ endif
+
+
+ ! Radioactive decay
+ !******************
+
+ decay(i)=0.693147/decay(i) !conversion half life to decay constant
+
+
+ ! Dry deposition of gases
+ !************************
+
+ if (reldiff(i).gt.0.) &
+ rm(i)=1./(henry(i)/3000.+100.*f0(i)) ! mesophyll resistance
+
+ ! Dry deposition of particles
+ !****************************
+
+ vsetaver(i)=0.
+ cunningham(i)=0.
+ dquer(i)=dquer(i)*1000000. ! Conversion m to um
+ if (density(i).gt.0.) then ! Additional parameters
+ call part0(dquer(i),dsigma(i),density(i),fracth,schmih,cun,vsh)
+ do j=1,ni
+ fract(i,j)=fracth(j)
+ schmi(i,j)=schmih(j)
+ vset(i,j)=vsh(j)
+ cunningham(i)=cunningham(i)+cun*fract(i,j)
+ vsetaver(i)=vsetaver(i)-vset(i,j)*fract(i,j)
+ end do
+ write(*,*) 'Average setting velocity: ',i,vsetaver(i)
+ endif
+
+ ! Dry deposition for constant deposition velocity
+ !************************************************
+
+ dryvel(i)=dryvel(i)*0.01 ! conversion to m/s
+
+ ! Check if wet deposition or OH reaction shall be calculated
+ !***********************************************************
+ if (weta(i).gt.0.) then
+ WETDEP=.true.
+ write (*,*) 'Wetdeposition switched on: ',weta(i),i
+ endif
+ if (ohreact(i).gt.0) then
+ OHREA=.true.
+ write (*,*) 'OHreaction switched on: ',ohreact(i),i
+ endif
+
+
+ if ((reldiff(i).gt.0.).or.(density(i).gt.0.).or. &
+ (dryvel(i).gt.0.)) then
+ DRYDEP=.true.
+ DRYDEPSPEC(i)=.true.
+ endif
+
+ end do
+
+ if (WETDEP.or.DRYDEP) DEP=.true.
+
+ ! Read specifications for each release point
+ !*******************************************
+
+ numpoint=0
+ numpartmax=0
+ releaserate=0.
+1000 numpoint=numpoint+1
+ read(unitreleases,*,end=250)
+ read(unitreleases,*,err=998,end=250) id1,it1
+ if (old) call skplin(2,unitreleases)
+ read(unitreleases,*,err=998) id2,it2
+ if (old) call skplin(2,unitreleases)
+ read(unitreleases,*,err=998) xpoint1(numpoint)
+ if (old) call skplin(2,unitreleases)
+ read(unitreleases,*,err=998) ypoint1(numpoint)
+ if (old) call skplin(2,unitreleases)
+ read(unitreleases,*,err=998) xpoint2(numpoint)
+ if (old) call skplin(2,unitreleases)
+ read(unitreleases,*,err=998) ypoint2(numpoint)
+ if (old) call skplin(2,unitreleases)
+ read(unitreleases,*,err=998) kindz(numpoint)
+ if (old) call skplin(2,unitreleases)
+ read(unitreleases,*,err=998) zpoint1(numpoint)
+ if (old) call skplin(2,unitreleases)
+ read(unitreleases,*,err=998) zpoint2(numpoint)
+ if (old) call skplin(2,unitreleases)
+ read(unitreleases,*,err=998) npart(numpoint)
+ if (old) call skplin(2,unitreleases)
+ do i=1,nspec
+ read(unitreleases,*,err=998) xmass(numpoint,i)
+ if (old) call skplin(2,unitreleases)
+ end do
+ !save compoint only for the first 1000 release points
+ if (numpoint.le.1000) then
+ read(unitreleases,'(a40)',err=998) compoint(numpoint)(1:40)
+ else
+ read(unitreleases,'(a40)',err=998) compoint(1001)(1:40)
+ endif
+ if (old) call skplin(1,unitreleases)
+ if (numpoint.le.1000) then
+ if((xpoint1(numpoint).eq.0.).and.(ypoint1(numpoint).eq.0.).and. &
+ (xpoint2(numpoint).eq.0.).and.(ypoint2(numpoint).eq.0.).and. &
+ (compoint(numpoint)(1:8).eq.' ')) goto 250
+ else
+ if((xpoint1(numpoint).eq.0.).and.(ypoint1(numpoint).eq.0.).and. &
+ (xpoint2(numpoint).eq.0.).and.(ypoint2(numpoint).eq.0.)) goto 250
+ endif
+
+
+ ! If a release point contains no particles, stop and issue error message
+ !***********************************************************************
+
+ if (npart(numpoint).eq.0) then
+ write(*,*) 'FLEXPART MODEL ERROR'
+ write(*,*) 'RELEASES file is corrupt.'
+ write(*,*) 'At least for one release point, there are zero'
+ write(*,*) 'particles released. Make changes to RELEASES.'
+ stop
+ endif
+
+ ! Check whether x coordinates of release point are within model domain
+ !*********************************************************************
+
+ if (xpoint1(numpoint).lt.xlon0) &
+ xpoint1(numpoint)=xpoint1(numpoint)+360.
+ if (xpoint1(numpoint).gt.xlon0+(nxmin1)*dx) &
+ xpoint1(numpoint)=xpoint1(numpoint)-360.
+ if (xpoint2(numpoint).lt.xlon0) &
+ xpoint2(numpoint)=xpoint2(numpoint)+360.
+ if (xpoint2(numpoint).gt.xlon0+(nxmin1)*dx) &
+ xpoint2(numpoint)=xpoint2(numpoint)-360.
+
+ ! Determine relative beginning and ending times of particle release
+ !******************************************************************
+
+ jul1=juldate(id1,it1)
+ jul2=juldate(id2,it2)
+ julm=(jul1+jul2)/2.
+ if (jul1.gt.jul2) then
+ write(*,*) 'FLEXPART MODEL ERROR'
+ write(*,*) 'Release stops before it begins.'
+ write(*,*) 'Make changes to file RELEASES.'
+ stop
+ endif
+ if (mdomainfill.eq.0) then ! no domain filling
+ if (ldirect.eq.1) then
+ if ((jul1.lt.bdate).or.(jul2.gt.edate)) then
+ write(*,*) 'FLEXPART MODEL ERROR'
+ write(*,*) 'Release starts before simulation begins or ends'
+ write(*,*) 'after simulation stops.'
+ write(*,*) 'Make files COMMAND and RELEASES consistent.'
+ stop
+ endif
+ if (npart(numpoint).gt.num_min_discrete) then
+ ireleasestart(numpoint)=int((jul1-bdate)*86400.)
+ ireleaseend(numpoint)=int((jul2-bdate)*86400.)
+ else
+ ireleasestart(numpoint)=int((julm-bdate)*86400.)
+ ireleaseend(numpoint)=int((julm-bdate)*86400.)
+ endif
+ else if (ldirect.eq.-1) then
+ if ((jul1.lt.edate).or.(jul2.gt.bdate)) then
+ write(*,*) 'FLEXPART MODEL ERROR'
+ write(*,*) 'Release starts before simulation begins or ends'
+ write(*,*) 'after simulation stops.'
+ write(*,*) 'Make files COMMAND and RELEASES consistent.'
+ stop
+ endif
+ if (npart(numpoint).gt.num_min_discrete) then
+ ireleasestart(numpoint)=int((jul1-bdate)*86400.)
+ ireleaseend(numpoint)=int((jul2-bdate)*86400.)
+ else
+ ireleasestart(numpoint)=int((julm-bdate)*86400.)
+ ireleaseend(numpoint)=int((julm-bdate)*86400.)
+ endif
+ endif
+ endif
+
+
+ ! Check, whether the total number of particles may exceed totally allowed
+ ! number of particles at some time during the simulation
+ !************************************************************************
+
+ ! Determine the release rate (particles per second) and total number
+ ! of particles released during the simulation
+ !*******************************************************************
+
+ if (ireleasestart(numpoint).ne.ireleaseend(numpoint)) then
+ releaserate=releaserate+real(npart(numpoint))/ &
+ real(ireleaseend(numpoint)-ireleasestart(numpoint))
+ else
+ releaserate=99999999
+ endif
+ numpartmax=numpartmax+npart(numpoint)
+ goto 1000
+
+
+250 close(unitreleases)
+
+ write (*,*) ' Particles allocated for this run: ',maxpart, ', released in simulation: ', numpartmax
+ numpoint=numpoint-1
+
+ if (ioutputforeachrelease.eq.1) then
+ maxpointspec_act=numpoint
+ else
+ maxpointspec_act=1
+ endif
+
+ if (releaserate.gt. &
+ 0.99*real(maxpart)/real(lage(nageclass))) then
+ if (numpartmax.gt.maxpart) then
+ write(*,*) '#####################################################'
+ write(*,*) '#### FLEXPART MODEL SUBROUTINE READRELEASES: ####'
+ write(*,*) '#### ####'
+ write(*,*) '####WARNING - TOTAL NUMBER OF PARTICLES SPECIFIED####'
+ write(*,*) '#### IN FILE "RELEASES" MAY AT SOME POINT DURING ####'
+ write(*,*) '#### THE SIMULATION EXCEED THE MAXIMUM ALLOWED ####'
+ write(*,*) '#### NUMBER (MAXPART).IF RELEASES DO NOT OVERLAP,####'
+ write(*,*) '#### FLEXPART CAN POSSIBLY COMPLETE SUCCESSFULLY.####'
+ write(*,*) '#### HOWEVER, FLEXPART MAY HAVE TO STOP ####'
+ write(*,*) '#### AT SOME TIME DURING THE SIMULATION. PLEASE ####'
+ write(*,*) '#### MAKE SURE THAT YOUR SETTINGS ARE CORRECT. ####'
+ write(*,*) '#####################################################'
+ write(*,*) 'Maximum release rate may be: ',releaserate, &
+ ' particles per second'
+ write(*,*) 'Maximum allowed release rate is: ', &
+ real(maxpart)/real(lage(nageclass)),' particles per second'
+ write(*,*) &
+ 'Total number of particles released during the simulation is: ', &
+ numpartmax
+ write(*,*) 'Maximum allowed number of particles is: ',maxpart
+ endif
+ endif
+
+ return
+
+994 write(*,*) '#####################################################'
+ write(*,*) '#### FLEXPART MODEL SUBROUTINE READRELEASES: ####'
+ write(*,*) '#### ####'
+ write(*,*) '#### ERROR - MAXIMUM NUMBER OF EMITTED SPECIES IS####'
+ write(*,*) '#### TOO LARGE. PLEASE REDUCE NUMBER OF SPECIES. ####'
+ write(*,*) '#####################################################'
+ stop
+
+998 write(*,*) '#####################################################'
+ write(*,*) '#### FLEXPART MODEL SUBROUTINE READRELEASES: ####'
+ write(*,*) '#### ####'
+ write(*,*) '#### FATAL ERROR - FILE "RELEASES" IS ####'
+ write(*,*) '#### CORRUPT. PLEASE CHECK YOUR INPUTS FOR ####'
+ write(*,*) '#### MISTAKES OR GET A NEW "RELEASES"- ####'
+ write(*,*) '#### FILE ... ####'
+ write(*,*) '#####################################################'
+ stop
+
+
+999 write(*,*) '#####################################################'
+ write(*,*) ' FLEXPART MODEL SUBROUTINE READRELEASES: '
+ write(*,*)
+ write(*,*) 'FATAL ERROR - FILE CONTAINING PARTICLE RELEASE POINTS'
+ write(*,*) 'POINTS IS NOT AVAILABLE OR YOU ARE NOT'
+ write(*,*) 'PERMITTED FOR ANY ACCESS'
+ write(*,*) '#####################################################'
+ stop
+
+end subroutine readreleases
diff --git a/src/readspecies.f90 b/src/readspecies.f90
new file mode 100644
index 0000000000000000000000000000000000000000..c62d339a74e4a0e368e1973fefe3a2a77d7624b9
--- /dev/null
+++ b/src/readspecies.f90
@@ -0,0 +1,188 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine readspecies(id_spec,pos_spec)
+
+ !*****************************************************************************
+ ! *
+ ! This routine reads names and physical constants of chemical species/ *
+ ! radionuclides given in the parameter pos_spec *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 11 July 1996 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! decaytime(maxtable) half time for radiological decay *
+ ! specname(maxtable) names of chemical species, radionuclides *
+ ! wetscava, wetscavb Parameters for determining scavenging coefficient *
+ ! ohreact OH reaction rate *
+ ! id_spec SPECIES number as referenced in RELEASE file *
+ ! id_pos position where SPECIES data shall be stored *
+ ! *
+ ! Constants: *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: i, pos_spec,j
+ integer :: idow,ihour,id_spec
+ character(len=3) :: aspecnumb
+ logical :: spec_found
+
+ ! Open the SPECIES file and read species names and properties
+ !************************************************************
+ specnum(pos_spec)=id_spec
+ write(aspecnumb,'(i3.3)') specnum(pos_spec)
+ open(unitspecies,file= &
+ path(1)(1:length(1))//'SPECIES/SPECIES_'//aspecnumb,status='old', &
+ err=998)
+ !write(*,*) 'reading SPECIES',specnum(pos_spec)
+
+ ASSSPEC=.FALSE.
+
+ do i=1,6
+ read(unitspecies,*)
+ end do
+
+ read(unitspecies,'(a10)',end=22) species(pos_spec)
+ ! write(*,*) species(pos_spec)
+ read(unitspecies,'(f18.1)',end=22) decay(pos_spec)
+ ! write(*,*) decay(pos_spec)
+ read(unitspecies,'(e18.1)',end=22) weta(pos_spec)
+ ! write(*,*) weta(pos_spec)
+ read(unitspecies,'(f18.2)',end=22) wetb(pos_spec)
+ ! write(*,*) wetb(pos_spec)
+ read(unitspecies,'(f18.1)',end=22) reldiff(pos_spec)
+ ! write(*,*) reldiff(pos_spec)
+ read(unitspecies,'(e18.1)',end=22) henry(pos_spec)
+ ! write(*,*) henry(pos_spec)
+ read(unitspecies,'(f18.1)',end=22) f0(pos_spec)
+ ! write(*,*) f0(pos_spec)
+ read(unitspecies,'(e18.1)',end=22) density(pos_spec)
+ ! write(*,*) density(pos_spec)
+ read(unitspecies,'(e18.1)',end=22) dquer(pos_spec)
+ ! write(*,*) dquer(pos_spec)
+ read(unitspecies,'(e18.1)',end=22) dsigma(pos_spec)
+ ! write(*,*) dsigma(pos_spec)
+ read(unitspecies,'(f18.2)',end=22) dryvel(pos_spec)
+ ! write(*,*) dryvel(pos_spec)
+ read(unitspecies,'(f18.2)',end=22) weightmolar(pos_spec)
+ ! write(*,*) weightmolar(pos_spec)
+ read(unitspecies,'(e18.1)',end=22) ohreact(pos_spec)
+ ! write(*,*) ohreact(pos_spec)
+ read(unitspecies,'(i18)',end=22) spec_ass(pos_spec)
+ ! write(*,*) spec_ass(pos_spec)
+ read(unitspecies,'(f18.2)',end=22) kao(pos_spec)
+ ! write(*,*) kao(pos_spec)
+ i=pos_spec
+
+ if ((weta(pos_spec).gt.0).and.(henry(pos_spec).le.0)) then
+ if (dquer(pos_spec).le.0) goto 996 ! no particle, no henry set
+ endif
+
+ if (spec_ass(pos_spec).gt.0) then
+ spec_found=.FALSE.
+ do j=1,pos_spec-1
+ if (spec_ass(pos_spec).eq.specnum(j)) then
+ spec_ass(pos_spec)=j
+ spec_found=.TRUE.
+ ASSSPEC=.TRUE.
+ endif
+ end do
+ if (spec_found.eqv..FALSE.) then
+ goto 997
+ endif
+ endif
+
+ if (dsigma(i).eq.1.) dsigma(i)=1.0001 ! avoid floating exception
+ if (dsigma(i).eq.0.) dsigma(i)=1.0001 ! avoid floating exception
+
+ if ((reldiff(i).gt.0.).and.(density(i).gt.0.)) then
+ write(*,*) '#### FLEXPART MODEL ERROR! FILE "SPECIES" ####'
+ write(*,*) '#### IS CORRUPT. SPECIES CANNOT BE BOTH ####'
+ write(*,*) '#### PARTICLE AND GAS. ####'
+ write(*,*) '#### SPECIES NUMBER',aspecnumb
+ stop
+ endif
+20 continue
+
+
+ ! Read in daily and day-of-week variation of emissions, if available
+ !*******************************************************************
+
+ do j=1,24 ! initialize everything to no variation
+ area_hour(i,j)=1.
+ point_hour(i,j)=1.
+ end do
+ do j=1,7
+ area_dow(i,j)=1.
+ point_dow(i,j)=1.
+ end do
+
+ read(unitspecies,*,end=22)
+ do j=1,24 ! 24 hours, starting with 0-1 local time
+ read(unitspecies,*) ihour,area_hour(i,j),point_hour(i,j)
+ end do
+ read(unitspecies,*)
+ do j=1,7 ! 7 days of the week, starting with Monday
+ read(unitspecies,*) idow,area_dow(i,j),point_dow(i,j)
+ end do
+
+22 close(unitspecies)
+
+ return
+
+996 write(*,*) '#####################################################'
+ write(*,*) '#### FLEXPART MODEL ERROR! #### '
+ write(*,*) '#### WET DEPOSITION SWITCHED ON, BUT NO HENRYS #### '
+ write(*,*) '#### CONSTANT IS SET ####'
+ write(*,*) '#### PLEASE MODIFY SPECIES DESCR. FILE! #### '
+ write(*,*) '#####################################################'
+ stop
+
+
+997 write(*,*) '#####################################################'
+ write(*,*) '#### FLEXPART MODEL ERROR! #### '
+ write(*,*) '#### THE ASSSOCIATED SPECIES HAS TO BE DEFINED #### '
+ write(*,*) '#### BEFORE THE ONE WHICH POINTS AT IT #### '
+ write(*,*) '#### PLEASE CHANGE ORDER IN RELEASES OR ADD #### '
+ write(*,*) '#### THE ASSOCIATED SPECIES IN RELEASES #### '
+ write(*,*) '#####################################################'
+ stop
+
+
+998 write(*,*) '#####################################################'
+ write(*,*) '#### FLEXPART MODEL ERROR! #### '
+ write(*,*) '#### THE SPECIES FILE FOR SPECIES ', id_spec
+ write(*,*) '#### CANNOT BE FOUND: CREATE FILE'
+ write(*,*) '#### ',path(1)(1:length(1)),'SPECIES/SPECIES_',aspecnumb
+ write(*,*) '#####################################################'
+ stop
+
+
+end subroutine readspecies
diff --git a/src/readwind.f90 b/src/readwind.f90
new file mode 100644
index 0000000000000000000000000000000000000000..28297b253f450a8dcdf9af3ecb1eadd580fb7946
--- /dev/null
+++ b/src/readwind.f90
@@ -0,0 +1,480 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine readwind(indj,n,uuh,vvh,wwh)
+
+ !**********************************************************************
+ ! *
+ ! TRAJECTORY MODEL SUBROUTINE READWIND *
+ ! *
+ !**********************************************************************
+ ! *
+ ! AUTHOR: G. WOTAWA *
+ ! DATE: 1997-08-05 *
+ ! LAST UPDATE: 2000-10-17, Andreas Stohl *
+ ! CHANGE: 11/01/2008, Harald Sodemann, GRIB1/2 input with *
+ ! ECMWF grib_api *
+ ! CHANGE: 03/12/2008, Harald Sodemann, update to f90 with *
+ ! ECMWF grib_api *
+ ! *
+ !**********************************************************************
+ ! Changes, Bernd C. Krueger, Feb. 2001:
+ ! Variables tth and qvh (on eta coordinates) in common block
+ !**********************************************************************
+ ! *
+ ! DESCRIPTION: *
+ ! *
+ ! READING OF ECMWF METEOROLOGICAL FIELDS FROM INPUT DATA FILES. THE *
+ ! INPUT DATA FILES ARE EXPECTED TO BE AVAILABLE IN GRIB CODE *
+ ! *
+ ! INPUT: *
+ ! indj indicates number of the wind field to be read in *
+ ! n temporal index for meteorological fields (1 to 3)*
+ ! *
+ ! IMPORTANT VARIABLES FROM COMMON BLOCK: *
+ ! *
+ ! wfname File name of data to be read in *
+ ! nx,ny,nuvz,nwz expected field dimensions *
+ ! nlev_ec number of vertical levels ecmwf model *
+ ! uu,vv,ww wind fields *
+ ! tt,qv temperature and specific humidity *
+ ! ps surface pressure *
+ ! *
+ !**********************************************************************
+
+ use GRIB_API
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ !HSO parameters for grib_api
+ integer :: ifile
+ integer :: iret
+ integer :: igrib
+ integer :: gribVer,parCat,parNum,typSurf,valSurf,discipl
+ integer :: gotGrid
+ !HSO end
+
+ real(kind=4) :: uuh(0:nxmax-1,0:nymax-1,nuvzmax)
+ real(kind=4) :: vvh(0:nxmax-1,0:nymax-1,nuvzmax)
+ real(kind=4) :: wwh(0:nxmax-1,0:nymax-1,nwzmax)
+ integer :: indj,i,j,k,n,levdiff2,ifield,iumax,iwmax
+
+ ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING
+
+ ! dimension of isec2 at least (22+n), where n is the number of parallels or
+ ! meridians in a quasi-regular (reduced) Gaussian or lat/long grid
+
+ ! dimension of zsec2 at least (10+nn), where nn is the number of vertical
+ ! coordinate parameters
+
+ integer :: isec1(56),isec2(22+nxmax+nymax)
+ real(kind=4) :: zsec4(jpunp)
+ real(kind=4) :: xaux,yaux,xaux0,yaux0
+ real(kind=8) :: xauxin,yauxin
+ real,parameter :: eps=1.e-4
+ real(kind=4) :: nsss(0:nxmax-1,0:nymax-1),ewss(0:nxmax-1,0:nymax-1)
+ real :: plev1,pmean,tv,fu,hlev1,ff10m,fflev1
+
+ logical :: hflswitch,strswitch
+
+ !HSO grib api error messages
+ character(len=24) :: gribErrorMsg = 'Error reading grib file'
+ character(len=20) :: gribFunction = 'readwind'
+
+ !HSO conversion of ECMWF etadot to etadot*dp/deta
+ logical :: etacon=.false.
+ real,parameter :: p00=101325.
+ real :: dak,dbk
+
+ hflswitch=.false.
+ strswitch=.false.
+ levdiff2=nlev_ec-nwz+1
+ iumax=0
+ iwmax=0
+
+ !
+ ! OPENING OF DATA FILE (GRIB CODE)
+ !
+5 call grib_open_file(ifile,path(3)(1:length(3)) &
+ //trim(wfname(indj)),'r',iret)
+ if (iret.ne.GRIB_SUCCESS) then
+ goto 888 ! ERROR DETECTED
+ endif
+ !turn on support for multi fields messages */
+ !call grib_multi_support_on
+
+ gotGrid=0
+ ifield=0
+10 ifield=ifield+1
+ !
+ ! GET NEXT FIELDS
+ !
+ call grib_new_from_file(ifile,igrib,iret)
+ if (iret.eq.GRIB_END_OF_FILE) then
+ goto 50 ! EOF DETECTED
+ elseif (iret.ne.GRIB_SUCCESS) then
+ goto 888 ! ERROR DETECTED
+ endif
+
+ !first see if we read GRIB1 or GRIB2
+ call grib_get_int(igrib,'editionNumber',gribVer,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ if (gribVer.eq.1) then ! GRIB Edition 1
+
+ !print*,'GRiB Edition 1'
+ !read the grib2 identifiers
+ call grib_get_int(igrib,'indicatorOfParameter',isec1(6),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'level',isec1(8),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ !change code for etadot to code for omega
+ if (isec1(6).eq.77) then
+ isec1(6)=135
+ endif
+
+ else
+
+ !print*,'GRiB Edition 2'
+ !read the grib2 identifiers
+ call grib_get_int(igrib,'discipline',discipl,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'parameterCategory',parCat,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'parameterNumber',parNum,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'typeOfFirstFixedSurface',typSurf,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'level',valSurf,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ !print*,discipl,parCat,parNum,typSurf,valSurf
+
+ !convert to grib1 identifiers
+ isec1(6)=-1
+ isec1(7)=-1
+ isec1(8)=-1
+ isec1(8)=valSurf ! level
+ if ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.105)) then ! T
+ isec1(6)=130 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.105)) then ! U
+ isec1(6)=131 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.105)) then ! V
+ isec1(6)=132 ! indicatorOfParameter
+ elseif ((parCat.eq.1).and.(parNum.eq.0).and.(typSurf.eq.105)) then ! Q
+ isec1(6)=133 ! indicatorOfParameter
+ elseif ((parCat.eq.3).and.(parNum.eq.0).and.(typSurf.eq.1)) then !SP
+ isec1(6)=134 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.32)) then ! W, actually eta dot
+ isec1(6)=135 ! indicatorOfParameter
+ elseif ((parCat.eq.3).and.(parNum.eq.0).and.(typSurf.eq.101)) then !SLP
+ isec1(6)=151 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.103)) then ! 10U
+ isec1(6)=165 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.103)) then ! 10V
+ isec1(6)=166 ! indicatorOfParameter
+ elseif ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.103)) then ! 2T
+ isec1(6)=167 ! indicatorOfParameter
+ elseif ((parCat.eq.0).and.(parNum.eq.6).and.(typSurf.eq.103)) then ! 2D
+ isec1(6)=168 ! indicatorOfParameter
+ elseif ((parCat.eq.1).and.(parNum.eq.11).and.(typSurf.eq.1)) then ! SD
+ isec1(6)=141 ! indicatorOfParameter
+ elseif ((parCat.eq.6).and.(parNum.eq.1)) then ! CC
+ isec1(6)=164 ! indicatorOfParameter
+ elseif ((parCat.eq.1).and.(parNum.eq.9)) then ! LSP
+ isec1(6)=142 ! indicatorOfParameter
+ elseif ((parCat.eq.1).and.(parNum.eq.10)) then ! CP
+ isec1(6)=143 ! indicatorOfParameter
+ elseif ((parCat.eq.0).and.(parNum.eq.11).and.(typSurf.eq.1)) then ! SHF
+ isec1(6)=146 ! indicatorOfParameter
+ elseif ((parCat.eq.4).and.(parNum.eq.9).and.(typSurf.eq.1)) then ! SR
+ isec1(6)=176 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.17)) then ! EWSS
+ isec1(6)=180 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.18)) then ! NSSS
+ isec1(6)=181 ! indicatorOfParameter
+ elseif ((parCat.eq.3).and.(parNum.eq.4)) then ! ORO
+ isec1(6)=129 ! indicatorOfParameter
+ elseif ((parCat.eq.3).and.(parNum.eq.7)) then ! SDO
+ isec1(6)=160 ! indicatorOfParameter
+ elseif ((discipl.eq.2).and.(parCat.eq.0).and.(parNum.eq.0).and. &
+ (typSurf.eq.1)) then ! LSM
+ isec1(6)=172 ! indicatorOfParameter
+ else
+ print*,'***ERROR: undefined GRiB2 message found!',discipl, &
+ parCat,parNum,typSurf
+ endif
+
+ endif
+
+ !HSO get the size and data of the values array
+ if (isec1(6).ne.-1) then
+ call grib_get_real4_array(igrib,'values',zsec4,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ endif
+
+ !HSO get the required fields from section 2 in a gribex compatible manner
+ if (ifield.eq.1) then
+ call grib_get_int(igrib,'numberOfPointsAlongAParallel', &
+ isec2(2),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'numberOfPointsAlongAMeridian', &
+ isec2(3),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'numberOfVerticalCoordinateValues', &
+ isec2(12))
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ ! CHECK GRID SPECIFICATIONS
+ if(isec2(2).ne.nxfield) stop 'READWIND: NX NOT CONSISTENT'
+ if(isec2(3).ne.ny) stop 'READWIND: NY NOT CONSISTENT'
+ if(isec2(12)/2-1.ne.nlev_ec) &
+ stop 'READWIND: VERTICAL DISCRETIZATION NOT CONSISTENT'
+ endif ! ifield
+
+ !HSO get the second part of the grid dimensions only from GRiB1 messages
+ if ((gribVer.eq.1).and.(gotGrid.eq.0)) then
+ call grib_get_real8(igrib,'longitudeOfFirstGridPointInDegrees', &
+ xauxin,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_real8(igrib,'latitudeOfLastGridPointInDegrees', &
+ yauxin,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ xaux=xauxin+real(nxshift)*dx
+ yaux=yauxin
+ xaux0=xlon0
+ yaux0=ylat0
+ if(xaux.lt.0.) xaux=xaux+360.
+ if(yaux.lt.0.) yaux=yaux+360.
+ if(xaux0.lt.0.) xaux0=xaux0+360.
+ if(yaux0.lt.0.) yaux0=yaux0+360.
+ if(abs(xaux-xaux0).gt.eps) &
+ stop 'READWIND: LOWER LEFT LONGITUDE NOT CONSISTENT'
+ if(abs(yaux-yaux0).gt.eps) &
+ stop 'READWIND: LOWER LEFT LATITUDE NOT CONSISTENT'
+ gotGrid=1
+ endif ! gotGrid
+
+ do j=0,nymin1
+ do i=0,nxfield-1
+ k=isec1(8)
+ if(isec1(6).eq.130) tth(i,j,nlev_ec-k+2,n)= &!! TEMPERATURE
+ zsec4(nxfield*(ny-j-1)+i+1)
+ if(isec1(6).eq.131) uuh(i,j,nlev_ec-k+2)= &!! U VELOCITY
+ zsec4(nxfield*(ny-j-1)+i+1)
+ if(isec1(6).eq.132) vvh(i,j,nlev_ec-k+2)= &!! V VELOCITY
+ zsec4(nxfield*(ny-j-1)+i+1)
+ if(isec1(6).eq.133) then !! SPEC. HUMIDITY
+ qvh(i,j,nlev_ec-k+2,n)=zsec4(nxfield*(ny-j-1)+i+1)
+ if (qvh(i,j,nlev_ec-k+2,n) .lt. 0.) &
+ qvh(i,j,nlev_ec-k+2,n) = 0.
+ ! this is necessary because the gridded data may contain
+ ! spurious negative values
+ endif
+ if(isec1(6).eq.134) ps(i,j,1,n)= &!! SURF. PRESS.
+ zsec4(nxfield*(ny-j-1)+i+1)
+
+ if(isec1(6).eq.135) wwh(i,j,nlev_ec-k+1)= &!! W VELOCITY
+ zsec4(nxfield*(ny-j-1)+i+1)
+ if(isec1(6).eq.141) sd(i,j,1,n)= &!! SNOW DEPTH
+ zsec4(nxfield*(ny-j-1)+i+1)
+ if(isec1(6).eq.151) msl(i,j,1,n)= &!! SEA LEVEL PRESS.
+ zsec4(nxfield*(ny-j-1)+i+1)
+ if(isec1(6).eq.164) tcc(i,j,1,n)= &!! CLOUD COVER
+ zsec4(nxfield*(ny-j-1)+i+1)
+ if(isec1(6).eq.165) u10(i,j,1,n)= &!! 10 M U VELOCITY
+ zsec4(nxfield*(ny-j-1)+i+1)
+ if(isec1(6).eq.166) v10(i,j,1,n)= &!! 10 M V VELOCITY
+ zsec4(nxfield*(ny-j-1)+i+1)
+ if(isec1(6).eq.167) tt2(i,j,1,n)= &!! 2 M TEMPERATURE
+ zsec4(nxfield*(ny-j-1)+i+1)
+ if(isec1(6).eq.168) td2(i,j,1,n)= &!! 2 M DEW POINT
+ zsec4(nxfield*(ny-j-1)+i+1)
+ if(isec1(6).eq.142) then !! LARGE SCALE PREC.
+ lsprec(i,j,1,n)=zsec4(nxfield*(ny-j-1)+i+1)
+ if (lsprec(i,j,1,n).lt.0.) lsprec(i,j,1,n)=0.
+ endif
+ if(isec1(6).eq.143) then !! CONVECTIVE PREC.
+ convprec(i,j,1,n)=zsec4(nxfield*(ny-j-1)+i+1)
+ if (convprec(i,j,1,n).lt.0.) convprec(i,j,1,n)=0.
+ endif
+ if(isec1(6).eq.146) sshf(i,j,1,n)= &!! SENS. HEAT FLUX
+ zsec4(nxfield*(ny-j-1)+i+1)
+ if((isec1(6).eq.146).and.(zsec4(nxfield*(ny-j-1)+i+1).ne.0.)) &
+ hflswitch=.true. ! Heat flux available
+ if(isec1(6).eq.176) then !! SOLAR RADIATION
+ ssr(i,j,1,n)=zsec4(nxfield*(ny-j-1)+i+1)
+ if (ssr(i,j,1,n).lt.0.) ssr(i,j,1,n)=0.
+ endif
+ if(isec1(6).eq.180) ewss(i,j)= &!! EW SURFACE STRESS
+ zsec4(nxfield*(ny-j-1)+i+1)
+ if(isec1(6).eq.181) nsss(i,j)= &!! NS SURFACE STRESS
+ zsec4(nxfield*(ny-j-1)+i+1)
+ if(((isec1(6).eq.180).or.(isec1(6).eq.181)).and. &
+ (zsec4(nxfield*(ny-j-1)+i+1).ne.0.)) strswitch=.true. ! stress available
+ !sec strswitch=.true.
+ if(isec1(6).eq.129) oro(i,j)= &!! ECMWF OROGRAPHY
+ zsec4(nxfield*(ny-j-1)+i+1)/ga
+ if(isec1(6).eq.160) excessoro(i,j)= &!! STANDARD DEVIATION OF OROGRAPHY
+ zsec4(nxfield*(ny-j-1)+i+1)
+ if(isec1(6).eq.172) lsm(i,j)= &!! ECMWF LAND SEA MASK
+ zsec4(nxfield*(ny-j-1)+i+1)
+ if(isec1(6).eq.131) iumax=max(iumax,nlev_ec-k+1)
+ if(isec1(6).eq.135) iwmax=max(iwmax,nlev_ec-k+1)
+
+ end do
+ end do
+
+ call grib_release(igrib)
+ goto 10 !! READ NEXT LEVEL OR PARAMETER
+ !
+ ! CLOSING OF INPUT DATA FILE
+ !
+
+50 call grib_close_file(ifile)
+
+ !error message if no fields found with correct first longitude in it
+ if (gotGrid.eq.0) then
+ print*,'***ERROR: input file needs to contain GRiB1 formatted'// &
+ 'messages'
+ stop
+ endif
+
+ if(levdiff2.eq.0) then
+ iwmax=nlev_ec+1
+ do i=0,nxmin1
+ do j=0,nymin1
+ wwh(i,j,nlev_ec+1)=0.
+ end do
+ end do
+ endif
+
+ ! convert from ECMWF etadot to etadot*dp/deta as needed by FLEXPART
+ if(etacon.eqv..true.) then
+ do k=1,nwzmax
+ dak=akm(k+1)-akm(k)
+ dbk=bkm(k+1)-bkm(k)
+ do i=0,nxmin1
+ do j=0,nymin1
+ wwh(i,j,k)=2*wwh(i,j,k)*ps(i,j,1,n)*(dak/ps(i,j,1,n)+dbk)/(dak/p00+dbk)
+ if (k.gt.1) then
+ wwh(i,j,k)=wwh(i,j,k)-wwh(i,j,k-1)
+ endif
+ end do
+ end do
+ end do
+ endif
+
+ ! For global fields, assign the leftmost data column also to the rightmost
+ ! data column; if required, shift whole grid by nxshift grid points
+ !*************************************************************************
+
+ if (xglobal) then
+ call shift_field_0(ewss,nxfield,ny)
+ call shift_field_0(nsss,nxfield,ny)
+ call shift_field_0(oro,nxfield,ny)
+ call shift_field_0(excessoro,nxfield,ny)
+ call shift_field_0(lsm,nxfield,ny)
+ call shift_field(ps,nxfield,ny,1,1,2,n)
+ call shift_field(sd,nxfield,ny,1,1,2,n)
+ call shift_field(msl,nxfield,ny,1,1,2,n)
+ call shift_field(tcc,nxfield,ny,1,1,2,n)
+ call shift_field(u10,nxfield,ny,1,1,2,n)
+ call shift_field(v10,nxfield,ny,1,1,2,n)
+ call shift_field(tt2,nxfield,ny,1,1,2,n)
+ call shift_field(td2,nxfield,ny,1,1,2,n)
+ call shift_field(lsprec,nxfield,ny,1,1,2,n)
+ call shift_field(convprec,nxfield,ny,1,1,2,n)
+ call shift_field(sshf,nxfield,ny,1,1,2,n)
+ call shift_field(ssr,nxfield,ny,1,1,2,n)
+ call shift_field(tth,nxfield,ny,nuvzmax,nuvz,2,n)
+ call shift_field(qvh,nxfield,ny,nuvzmax,nuvz,2,n)
+ call shift_field(uuh,nxfield,ny,nuvzmax,nuvz,1,1)
+ call shift_field(vvh,nxfield,ny,nuvzmax,nuvz,1,1)
+ call shift_field(wwh,nxfield,ny,nwzmax,nwz,1,1)
+ endif
+
+ do i=0,nxmin1
+ do j=0,nymin1
+ surfstr(i,j,1,n)=sqrt(ewss(i,j)**2+nsss(i,j)**2)
+ end do
+ end do
+
+ if ((.not.hflswitch).or.(.not.strswitch)) then
+ write(*,*) 'WARNING: No flux data contained in GRIB file ', &
+ wfname(indj)
+
+ ! CALCULATE USTAR AND SSHF USING THE PROFILE METHOD
+ ! As ECMWF has increased the model resolution, such that now the first model
+ ! level is at about 10 m (where 10-m wind is given), use the 2nd ECMWF level
+ ! (3rd model level in FLEXPART) for the profile method
+ !***************************************************************************
+
+ do i=0,nxmin1
+ do j=0,nymin1
+ plev1=akz(3)+bkz(3)*ps(i,j,1,n)
+ pmean=0.5*(ps(i,j,1,n)+plev1)
+ tv=tth(i,j,3,n)*(1.+0.61*qvh(i,j,3,n))
+ fu=-r_air*tv/ga/pmean
+ hlev1=fu*(plev1-ps(i,j,1,n)) ! HEIGTH OF FIRST MODEL LAYER
+ ff10m= sqrt(u10(i,j,1,n)**2+v10(i,j,1,n)**2)
+ fflev1=sqrt(uuh(i,j,3)**2+vvh(i,j,3)**2)
+ call pbl_profile(ps(i,j,1,n),td2(i,j,1,n),hlev1, &
+ tt2(i,j,1,n),tth(i,j,3,n),ff10m,fflev1, &
+ surfstr(i,j,1,n),sshf(i,j,1,n))
+ if(sshf(i,j,1,n).gt.200.) sshf(i,j,1,n)=200.
+ if(sshf(i,j,1,n).lt.-400.) sshf(i,j,1,n)=-400.
+ end do
+ end do
+ endif
+
+
+ ! Assign 10 m wind to model level at eta=1.0 to have one additional model
+ ! level at the ground
+ ! Specific humidity is taken the same as at one level above
+ ! Temperature is taken as 2 m temperature
+ !**************************************************************************
+
+ do i=0,nxmin1
+ do j=0,nymin1
+ uuh(i,j,1)=u10(i,j,1,n)
+ vvh(i,j,1)=v10(i,j,1,n)
+ qvh(i,j,1,n)=qvh(i,j,2,n)
+ tth(i,j,1,n)=tt2(i,j,1,n)
+ end do
+ end do
+
+ if(iumax.ne.nuvz-1) stop 'READWIND: NUVZ NOT CONSISTENT'
+ if(iwmax.ne.nwz) stop 'READWIND: NWZ NOT CONSISTENT'
+
+ return
+888 write(*,*) ' #### FLEXPART MODEL ERROR! WINDFIELD #### '
+ write(*,*) ' #### ',wfname(indj),' #### '
+ write(*,*) ' #### IS NOT GRIB FORMAT !!! #### '
+ stop 'Execution terminated'
+999 write(*,*) ' #### FLEXPART MODEL ERROR! WINDFIELD #### '
+ write(*,*) ' #### ',wfname(indj),' #### '
+ write(*,*) ' #### CANNOT BE OPENED !!! #### '
+ stop 'Execution terminated'
+
+end subroutine readwind
diff --git a/src/readwind_emos.f90 b/src/readwind_emos.f90
new file mode 100644
index 0000000000000000000000000000000000000000..cc7dd3597f3a171563e164ec922af05396d36811
--- /dev/null
+++ b/src/readwind_emos.f90
@@ -0,0 +1,325 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine readwind(indj,n,uuh,vvh,wwh)
+
+ !**********************************************************************
+ ! *
+ ! TRAJECTORY MODEL SUBROUTINE READWIND *
+ ! *
+ !**********************************************************************
+ ! *
+ ! AUTHOR: G. WOTAWA *
+ ! DATE: 1997-08-05 *
+ ! LAST UPDATE: 2000-10-17, Andreas Stohl *
+ ! *
+ !**********************************************************************
+ ! Changes, Bernd C. Krueger, Feb. 2001:
+ ! Variables tth and qvh (on eta coordinates) in common block
+ !**********************************************************************
+ ! *
+ ! DESCRIPTION: *
+ ! *
+ ! READING OF ECMWF METEOROLOGICAL FIELDS FROM INPUT DATA FILES. THE *
+ ! INPUT DATA FILES ARE EXPECTED TO BE AVAILABLE IN GRIB CODE *
+ ! *
+ ! INPUT: *
+ ! indj indicates number of the wind field to be read in *
+ ! n temporal index for meteorological fields (1 to 3)*
+ ! *
+ ! IMPORTANT VARIABLES FROM COMMON BLOCK: *
+ ! *
+ ! wfname File name of data to be read in *
+ ! nx,ny,nuvz,nwz expected field dimensions *
+ ! nlev_ec number of vertical levels ecmwf model *
+ ! uu,vv,ww wind fields *
+ ! tt,qv temperature and specific humidity *
+ ! ps surface pressure *
+ ! *
+ !**********************************************************************
+
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ real :: uuh(0:nxmax-1,0:nymax-1,nuvzmax)
+ real :: vvh(0:nxmax-1,0:nymax-1,nuvzmax)
+ real :: wwh(0:nxmax-1,0:nymax-1,nwzmax)
+ integer :: indj,i,j,k,n,levdiff2,ifield,iumax,iwmax,lunit
+
+ ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING
+
+ ! dimension of isec2 at least (22+n), where n is the number of parallels or
+ ! meridians in a quasi-regular (reduced) Gaussian or lat/long grid
+
+ ! dimension of zsec2 at least (10+nn), where nn is the number of vertical
+ ! coordinate parameters
+
+ integer :: isec0(2),isec1(56),isec2(22+nxmax+nymax),isec3(2)
+ integer :: isec4(64),inbuff(jpack),ilen,ierr,iword
+ !integer iswap
+ real :: zsec2(60+2*nuvzmax),zsec3(2),zsec4(jpunp)
+ real :: xaux,yaux,xaux0,yaux0
+ real,parameter :: eps=1.e-4
+ real :: ewss(0:nxmax-1,0:nymax-1),nsss(0:nxmax-1,0:nymax-1)
+ real :: plev1,pmean,tv,fu,hlev1,ff10m,fflev1
+
+ character(len=1) :: yoper = 'D'
+ logical :: hflswitch,strswitch
+
+ hflswitch=.false.
+ strswitch=.false.
+ levdiff2=nlev_ec-nwz+1
+ iumax=0
+ iwmax=0
+
+ !
+ ! OPENING OF DATA FILE (GRIB CODE)
+ !
+5 call pbopen(lunit,path(3)(1:length(3))//wfname(indj),'r',ierr)
+ if(ierr.lt.0) goto 999
+
+ ifield=0
+10 ifield=ifield+1
+ !
+ ! GET NEXT FIELDS
+ !
+ call pbgrib(lunit,inbuff,jpack,ilen,ierr)
+ if(ierr.eq.-1) goto 50 ! EOF DETECTED
+ if(ierr.lt.-1) goto 888 ! ERROR DETECTED
+
+ ierr=1
+
+ ! Check whether we are on a little endian or on a big endian computer
+ !********************************************************************
+
+ !if (inbuff(1).eq.1112101447) then ! little endian, swap bytes
+ ! iswap=1+ilen/4
+ ! call swap32(inbuff,iswap)
+ !else if (inbuff(1).ne.1196575042) then ! big endian
+ ! stop 'subroutine gridcheck: corrupt GRIB data'
+ !endif
+
+
+ call gribex(isec0,isec1,isec2,zsec2,isec3,zsec3,isec4, &
+ zsec4,jpunp,inbuff,jpack,iword,yoper,ierr)
+ if (ierr.ne.0) goto 888 ! ERROR DETECTED
+
+ if(ifield.eq.1) then
+
+ ! CHECK GRID SPECIFICATIONS
+
+ if(isec2(2).ne.nxfield) stop 'READWIND: NX NOT CONSISTENT'
+ if(isec2(3).ne.ny) stop 'READWIND: NY NOT CONSISTENT'
+ if(isec2(12)/2-1.ne.nlev_ec) &
+ stop 'READWIND: VERTICAL DISCRETIZATION NOT CONSISTENT'
+ xaux=real(isec2(5))/1000.+real(nxshift)*dx
+ yaux=real(isec2(7))/1000.
+ xaux0=xlon0
+ yaux0=ylat0
+ if(xaux.lt.0.) xaux=xaux+360.
+ if(yaux.lt.0.) yaux=yaux+360.
+ if(xaux0.lt.0.) xaux0=xaux0+360.
+ if(yaux0.lt.0.) yaux0=yaux0+360.
+ if(abs(xaux-xaux0).gt.eps) &
+ stop 'READWIND: LOWER LEFT LONGITUDE NOT CONSISTENT'
+ if(abs(yaux-yaux0).gt.eps) &
+ stop 'READWIND: LOWER LEFT LATITUDE NOT CONSISTENT'
+ endif
+
+ do j=0,nymin1
+ do i=0,nxfield-1
+ k=isec1(8)
+ if(isec1(6).eq.130) tth(i,j,nlev_ec-k+2,n)= &!! TEMPERATURE
+ zsec4(nxfield*(ny-j-1)+i+1)
+ if(isec1(6).eq.131) uuh(i,j,nlev_ec-k+2)= &!! U VELOCITY
+ zsec4(nxfield*(ny-j-1)+i+1)
+ if(isec1(6).eq.132) vvh(i,j,nlev_ec-k+2)= &!! V VELOCITY
+ zsec4(nxfield*(ny-j-1)+i+1)
+ if(isec1(6).eq.133) then !! SPEC. HUMIDITY
+ qvh(i,j,nlev_ec-k+2,n)=zsec4(nxfield*(ny-j-1)+i+1)
+ if (qvh(i,j,nlev_ec-k+2,n) .lt. 0.) &
+ qvh(i,j,nlev_ec-k+2,n) = 0.
+ ! this is necessary because the gridded data may contain
+ ! spurious negative values
+ endif
+ if(isec1(6).eq.134) ps(i,j,1,n)= &!! SURF. PRESS.
+ zsec4(nxfield*(ny-j-1)+i+1)
+
+ if(isec1(6).eq.135) wwh(i,j,nlev_ec-k+1)= &!! W VELOCITY
+ zsec4(nxfield*(ny-j-1)+i+1)
+ if(isec1(6).eq.141) sd(i,j,1,n)= &!! SNOW DEPTH
+ zsec4(nxfield*(ny-j-1)+i+1)
+ if(isec1(6).eq.151) msl(i,j,1,n)= &!! SEA LEVEL PRESS.
+ zsec4(nxfield*(ny-j-1)+i+1)
+ if(isec1(6).eq.164) tcc(i,j,1,n)= &!! CLOUD COVER
+ zsec4(nxfield*(ny-j-1)+i+1)
+ if(isec1(6).eq.165) u10(i,j,1,n)= &!! 10 M U VELOCITY
+ zsec4(nxfield*(ny-j-1)+i+1)
+ if(isec1(6).eq.166) v10(i,j,1,n)= &!! 10 M V VELOCITY
+ zsec4(nxfield*(ny-j-1)+i+1)
+ if(isec1(6).eq.167) tt2(i,j,1,n)= &!! 2 M TEMPERATURE
+ zsec4(nxfield*(ny-j-1)+i+1)
+ if(isec1(6).eq.168) td2(i,j,1,n)= &!! 2 M DEW POINT
+ zsec4(nxfield*(ny-j-1)+i+1)
+ if(isec1(6).eq.142) then !! LARGE SCALE PREC.
+ lsprec(i,j,1,n)=zsec4(nxfield*(ny-j-1)+i+1)
+ if (lsprec(i,j,1,n).lt.0.) lsprec(i,j,1,n)=0.
+ endif
+ if(isec1(6).eq.143) then !! CONVECTIVE PREC.
+ convprec(i,j,1,n)=zsec4(nxfield*(ny-j-1)+i+1)
+ if (convprec(i,j,1,n).lt.0.) convprec(i,j,1,n)=0.
+ endif
+ if(isec1(6).eq.146) sshf(i,j,1,n)= &!! SENS. HEAT FLUX
+ zsec4(nxfield*(ny-j-1)+i+1)
+ if((isec1(6).eq.146).and.(zsec4(nxfield*(ny-j-1)+i+1).ne.0.)) &
+ hflswitch=.true. ! Heat flux available
+ if(isec1(6).eq.176) then !! SOLAR RADIATION
+ ssr(i,j,1,n)=zsec4(nxfield*(ny-j-1)+i+1)
+ if (ssr(i,j,1,n).lt.0.) ssr(i,j,1,n)=0.
+ endif
+ if(isec1(6).eq.180) ewss(i,j)= &!! EW SURFACE STRESS
+ zsec4(nxfield*(ny-j-1)+i+1)
+ if(isec1(6).eq.181) nsss(i,j)= &!! NS SURFACE STRESS
+ zsec4(nxfield*(ny-j-1)+i+1)
+ if(((isec1(6).eq.180).or.(isec1(6).eq.181)).and. &
+ (zsec4(nxfield*(ny-j-1)+i+1).ne.0.)) strswitch=.true. ! stress available
+ if(isec1(6).eq.129) oro(i,j)= &!! ECMWF OROGRAPHY
+ zsec4(nxfield*(ny-j-1)+i+1)/ga
+ if(isec1(6).eq.160) excessoro(i,j)= &!! STANDARD DEVIATION OF OROGRAPHY
+ zsec4(nxfield*(ny-j-1)+i+1)
+ if(isec1(6).eq.172) lsm(i,j)= &!! ECMWF LAND SEA MASK
+ zsec4(nxfield*(ny-j-1)+i+1)
+ if(isec1(6).eq.131) iumax=max(iumax,nlev_ec-k+1)
+ if(isec1(6).eq.135) iwmax=max(iwmax,nlev_ec-k+1)
+ end do
+ end do
+
+ goto 10 !! READ NEXT LEVEL OR PARAMETER
+ !
+ ! CLOSING OF INPUT DATA FILE
+ !
+50 call pbclose(lunit,ierr) !! FINNISHED READING / CLOSING GRIB FILE
+
+ if(levdiff2.eq.0) then
+ iwmax=nlev_ec+1
+ do i=0,nxmin1
+ do j=0,nymin1
+ wwh(i,j,nlev_ec+1)=0.
+ end do
+ end do
+ endif
+
+
+ ! For global fields, assign the leftmost data column also to the rightmost
+ ! data column; if required, shift whole grid by nxshift grid points
+ !*************************************************************************
+
+ if (xglobal) then
+ call shift_field_0(ewss,nxfield,ny)
+ call shift_field_0(nsss,nxfield,ny)
+ call shift_field_0(oro,nxfield,ny)
+ call shift_field_0(excessoro,nxfield,ny)
+ call shift_field_0(lsm,nxfield,ny)
+ call shift_field(ps,nxfield,ny,1,1,2,n)
+ call shift_field(sd,nxfield,ny,1,1,2,n)
+ call shift_field(msl,nxfield,ny,1,1,2,n)
+ call shift_field(tcc,nxfield,ny,1,1,2,n)
+ call shift_field(u10,nxfield,ny,1,1,2,n)
+ call shift_field(v10,nxfield,ny,1,1,2,n)
+ call shift_field(tt2,nxfield,ny,1,1,2,n)
+ call shift_field(td2,nxfield,ny,1,1,2,n)
+ call shift_field(lsprec,nxfield,ny,1,1,2,n)
+ call shift_field(convprec,nxfield,ny,1,1,2,n)
+ call shift_field(sshf,nxfield,ny,1,1,2,n)
+ call shift_field(ssr,nxfield,ny,1,1,2,n)
+ call shift_field(tth,nxfield,ny,nuvzmax,nuvz,2,n)
+ call shift_field(qvh,nxfield,ny,nuvzmax,nuvz,2,n)
+ call shift_field(uuh,nxfield,ny,nuvzmax,nuvz,1,1)
+ call shift_field(vvh,nxfield,ny,nuvzmax,nuvz,1,1)
+ call shift_field(wwh,nxfield,ny,nwzmax,nwz,1,1)
+ endif
+
+ do i=0,nxmin1
+ do j=0,nymin1
+ surfstr(i,j,1,n)=sqrt(ewss(i,j)**2+nsss(i,j)**2)
+ end do
+ end do
+
+ if ((.not.hflswitch).or.(.not.strswitch)) then
+ write(*,*) 'WARNING: No flux data contained in GRIB file ', &
+ wfname(indj)
+
+ ! CALCULATE USTAR AND SSHF USING THE PROFILE METHOD
+ ! As ECMWF has increased the model resolution, such that now the first model
+ ! level is at about 10 m (where 10-m wind is given), use the 2nd ECMWF level
+ ! (3rd model level in FLEXPART) for the profile method
+ !***************************************************************************
+
+ do i=0,nxmin1
+ do j=0,nymin1
+ plev1=akz(3)+bkz(3)*ps(i,j,1,n)
+ pmean=0.5*(ps(i,j,1,n)+plev1)
+ tv=tth(i,j,3,n)*(1.+0.61*qvh(i,j,3,n))
+ fu=-r_air*tv/ga/pmean
+ hlev1=fu*(plev1-ps(i,j,1,n)) ! HEIGTH OF FIRST MODEL LAYER
+ ff10m= sqrt(u10(i,j,1,n)**2+v10(i,j,1,n)**2)
+ fflev1=sqrt(uuh(i,j,3)**2+vvh(i,j,3)**2)
+ call pbl_profile(ps(i,j,1,n),td2(i,j,1,n),hlev1, &
+ tt2(i,j,1,n),tth(i,j,3,n),ff10m,fflev1, &
+ surfstr(i,j,1,n),sshf(i,j,1,n))
+ if(sshf(i,j,1,n).gt.200.) sshf(i,j,1,n)=200.
+ if(sshf(i,j,1,n).lt.-400.) sshf(i,j,1,n)=-400.
+ end do
+ end do
+ endif
+
+
+ ! Assign 10 m wind to model level at eta=1.0 to have one additional model
+ ! level at the ground
+ ! Specific humidity is taken the same as at one level above
+ ! Temperature is taken as 2 m temperature
+ !**************************************************************************
+
+ do i=0,nxmin1
+ do j=0,nymin1
+ uuh(i,j,1)=u10(i,j,1,n)
+ vvh(i,j,1)=v10(i,j,1,n)
+ qvh(i,j,1,n)=qvh(i,j,2,n)
+ tth(i,j,1,n)=tt2(i,j,1,n)
+ end do
+ end do
+
+ if(iumax.ne.nuvz-1) stop 'READWIND: NUVZ NOT CONSISTENT'
+ if(iwmax.ne.nwz) stop 'READWIND: NWZ NOT CONSISTENT'
+
+ return
+888 write(*,*) ' #### FLEXPART MODEL ERROR! WINDFIELD #### '
+ write(*,*) ' #### ',wfname(indj),' #### '
+ write(*,*) ' #### IS NOT GRIB FORMAT !!! #### '
+ stop 'Execution terminated'
+999 write(*,*) ' #### FLEXPART MODEL ERROR! WINDFIELD #### '
+ write(*,*) ' #### ',wfname(indj),' #### '
+ write(*,*) ' #### CANNOT BE OPENED !!! #### '
+ stop 'Execution terminated'
+
+end subroutine readwind
diff --git a/src/readwind_gfs.f90 b/src/readwind_gfs.f90
new file mode 100644
index 0000000000000000000000000000000000000000..b52c6f4fe444095098883a935bfd0bd5868c1fc4
--- /dev/null
+++ b/src/readwind_gfs.f90
@@ -0,0 +1,718 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine readwind(indj,n,uuh,vvh,wwh)
+
+ !***********************************************************************
+ !* *
+ !* TRAJECTORY MODEL SUBROUTINE READWIND *
+ !* *
+ !***********************************************************************
+ !* *
+ !* AUTHOR: G. WOTAWA *
+ !* DATE: 1997-08-05 *
+ !* LAST UPDATE: 2000-10-17, Andreas Stohl *
+ !* CHANGE: 01/02/2001, Bernd C. Krueger, Variables tth and *
+ !* qvh (on eta coordinates) in common block *
+ !* CHANGE: 16/11/2005, Caroline Forster, GFS data *
+ !* CHANGE: 11/01/2008, Harald Sodemann, Input of GRIB1/2 *
+ !* data with the ECMWF grib_api library *
+ !* CHANGE: 03/12/2008, Harald Sodemann, update to f90 with *
+ !* ECMWF grib_api *
+ !* *
+ !***********************************************************************
+ !* *
+ !* DESCRIPTION: *
+ !* *
+ !* READING OF ECMWF METEOROLOGICAL FIELDS FROM INPUT DATA FILES. THE *
+ !* INPUT DATA FILES ARE EXPECTED TO BE AVAILABLE IN GRIB CODE *
+ !* *
+ !* INPUT: *
+ !* indj indicates number of the wind field to be read in *
+ !* n temporal index for meteorological fields (1 to 3)*
+ !* *
+ !* IMPORTANT VARIABLES FROM COMMON BLOCK: *
+ !* *
+ !* wfname File name of data to be read in *
+ !* nx,ny,nuvz,nwz expected field dimensions *
+ !* nlev_ec number of vertical levels ecmwf model *
+ !* uu,vv,ww wind fields *
+ !* tt,qv temperature and specific humidity *
+ !* ps surface pressure *
+ !* *
+ !***********************************************************************
+
+ use grib_api
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ !HSO new parameters for grib_api
+ integer :: ifile
+ integer :: iret
+ integer :: igrib
+ integer :: gribVer,parCat,parNum,typSurf,valSurf,discipl
+ !HSO end edits
+ real :: uuh(0:nxmax-1,0:nymax-1,nuvzmax)
+ real :: vvh(0:nxmax-1,0:nymax-1,nuvzmax)
+ real :: wwh(0:nxmax-1,0:nymax-1,nwzmax)
+ integer :: ii,indj,i,j,k,n,levdiff2,ifield,iumax,iwmax
+
+ ! NCEP
+ integer :: numpt,numpu,numpv,numpw,numprh
+ real :: help, temp, ew
+ real :: elev
+ real :: ulev1(0:nxmax-1,0:nymax-1),vlev1(0:nxmax-1,0:nymax-1)
+ real :: tlev1(0:nxmax-1,0:nymax-1)
+ real :: qvh2(0:nxmax-1,0:nymax-1)
+
+ integer :: i179,i180,i181
+
+ ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING
+ !HSO kept isec1, isec2 and zsec4 for consistency with gribex GRIB input
+
+ integer :: isec1(8),isec2(3)
+ real(kind=4) :: zsec4(jpunp)
+ real(kind=4) :: xaux,yaux,xaux0,yaux0
+ real(kind=8) :: xauxin,yauxin
+ real,parameter :: eps=1.e-4
+ real(kind=4) :: ewss(0:nxmax-1,0:nymax-1),nsss(0:nxmax-1,0:nymax-1)
+ real :: plev1,hlev1,ff10m,fflev1
+
+ logical :: hflswitch,strswitch
+
+ !HSO for grib api error messages
+ character(len=24) :: gribErrorMsg = 'Error reading grib file'
+ character(len=20) :: gribFunction = 'readwind_gfs'
+
+
+ hflswitch=.false.
+ strswitch=.false.
+ levdiff2=nlev_ec-nwz+1
+ iumax=0
+ iwmax=0
+
+
+ ! OPENING OF DATA FILE (GRIB CODE)
+
+ !HSO
+5 call grib_open_file(ifile,path(3)(1:length(3)) &
+ //trim(wfname(indj)),'r',iret)
+ if (iret.ne.GRIB_SUCCESS) then
+ goto 888 ! ERROR DETECTED
+ endif
+ !turn on support for multi fields messages
+ call grib_multi_support_on
+
+ numpt=0
+ numpu=0
+ numpv=0
+ numpw=0
+ numprh=0
+ ifield=0
+10 ifield=ifield+1
+ !
+ ! GET NEXT FIELDS
+ !
+ call grib_new_from_file(ifile,igrib,iret)
+ if (iret.eq.GRIB_END_OF_FILE) then
+ goto 50 ! EOF DETECTED
+ elseif (iret.ne.GRIB_SUCCESS) then
+ goto 888 ! ERROR DETECTED
+ endif
+
+ !first see if we read GRIB1 or GRIB2
+ call grib_get_int(igrib,'editionNumber',gribVer,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ if (gribVer.eq.1) then ! GRIB Edition 1
+
+ !read the grib1 identifiers
+ call grib_get_int(igrib,'indicatorOfParameter',isec1(6),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'indicatorOfTypeOfLevel',isec1(7),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'level',isec1(8),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ else ! GRIB Edition 2
+
+ !read the grib2 identifiers
+ call grib_get_int(igrib,'discipline',discipl,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'parameterCategory',parCat,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'parameterNumber',parNum,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'typeOfFirstFixedSurface',typSurf,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'scaledValueOfFirstFixedSurface', &
+ valSurf,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ !convert to grib1 identifiers
+ isec1(6)=-1
+ isec1(7)=-1
+ isec1(8)=-1
+ if ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.100)) then ! T
+ isec1(6)=11 ! indicatorOfParameter
+ isec1(7)=100 ! indicatorOfTypeOfLevel
+ isec1(8)=valSurf/100 ! level, convert to hPa
+ elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.100)) then ! U
+ isec1(6)=33 ! indicatorOfParameter
+ isec1(7)=100 ! indicatorOfTypeOfLevel
+ isec1(8)=valSurf/100 ! level, convert to hPa
+ elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.100)) then ! V
+ isec1(6)=34 ! indicatorOfParameter
+ isec1(7)=100 ! indicatorOfTypeOfLevel
+ isec1(8)=valSurf/100 ! level, convert to hPa
+ elseif ((parCat.eq.2).and.(parNum.eq.8).and.(typSurf.eq.100)) then ! W
+ isec1(6)=39 ! indicatorOfParameter
+ isec1(7)=100 ! indicatorOfTypeOfLevel
+ isec1(8)=valSurf/100 ! level, convert to hPa
+ elseif ((parCat.eq.1).and.(parNum.eq.1).and.(typSurf.eq.100)) then ! RH
+ isec1(6)=52 ! indicatorOfParameter
+ isec1(7)=100 ! indicatorOfTypeOfLevel
+ isec1(8)=valSurf/100 ! level, convert to hPa
+ elseif ((parCat.eq.1).and.(parNum.eq.1).and.(typSurf.eq.103)) then ! RH2
+ isec1(6)=52 ! indicatorOfParameter
+ isec1(7)=105 ! indicatorOfTypeOfLevel
+ isec1(8)=2
+ elseif ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.103)) then ! T2
+ isec1(6)=11 ! indicatorOfParameter
+ isec1(7)=105 ! indicatorOfTypeOfLevel
+ isec1(8)=2
+ elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.103)) then ! U10
+ isec1(6)=33 ! indicatorOfParameter
+ isec1(7)=105 ! indicatorOfTypeOfLevel
+ isec1(8)=10
+ elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.103)) then ! V10
+ isec1(6)=34 ! indicatorOfParameter
+ isec1(7)=105 ! indicatorOfTypeOfLevel
+ isec1(8)=10
+ elseif ((parCat.eq.3).and.(parNum.eq.1).and.(typSurf.eq.101)) then ! SLP
+ isec1(6)=2 ! indicatorOfParameter
+ isec1(7)=102 ! indicatorOfTypeOfLevel
+ isec1(8)=0
+ elseif ((parCat.eq.3).and.(parNum.eq.0).and.(typSurf.eq.1)) then ! SP
+ isec1(6)=1 ! indicatorOfParameter
+ isec1(7)=1 ! indicatorOfTypeOfLevel
+ isec1(8)=0
+ elseif ((parCat.eq.1).and.(parNum.eq.13).and.(typSurf.eq.1)) then ! SNOW
+ isec1(6)=66 ! indicatorOfParameter
+ isec1(7)=1 ! indicatorOfTypeOfLevel
+ isec1(8)=0
+ elseif ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.104)) then ! T sigma 0
+ isec1(6)=11 ! indicatorOfParameter
+ isec1(7)=107 ! indicatorOfTypeOfLevel
+ isec1(8)=0.995 ! lowest sigma level
+ elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.104)) then ! U sigma 0
+ isec1(6)=33 ! indicatorOfParameter
+ isec1(7)=107 ! indicatorOfTypeOfLevel
+ isec1(8)=0.995 ! lowest sigma level
+ elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.104)) then ! V sigma 0
+ isec1(6)=34 ! indicatorOfParameter
+ isec1(7)=107 ! indicatorOfTypeOfLevel
+ isec1(8)=0.995 ! lowest sigma level
+ elseif ((parCat.eq.3).and.(parNum.eq.5).and.(typSurf.eq.1)) then ! TOPO
+ isec1(6)=7 ! indicatorOfParameter
+ isec1(7)=1 ! indicatorOfTypeOfLevel
+ isec1(8)=0
+ elseif ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.1) &
+ .and.(discipl.eq.2)) then ! LSM
+ isec1(6)=81 ! indicatorOfParameter
+ isec1(7)=1 ! indicatorOfTypeOfLevel
+ isec1(8)=0
+ elseif ((parCat.eq.3).and.(parNum.eq.196).and.(typSurf.eq.1)) then ! BLH
+ isec1(6)=221 ! indicatorOfParameter
+ isec1(7)=1 ! indicatorOfTypeOfLevel
+ isec1(8)=0
+ elseif ((parCat.eq.1).and.(parNum.eq.7).and.(typSurf.eq.1)) then ! LSP/TP
+ isec1(6)=62 ! indicatorOfParameter
+ isec1(7)=1 ! indicatorOfTypeOfLevel
+ isec1(8)=0
+ elseif ((parCat.eq.1).and.(parNum.eq.196).and.(typSurf.eq.1)) then ! CP
+ isec1(6)=63 ! indicatorOfParameter
+ isec1(7)=1 ! indicatorOfTypeOfLevel
+ isec1(8)=0
+ endif
+
+ endif ! gribVer
+
+ if (isec1(6).ne.-1) then
+ ! get the size and data of the values array
+ call grib_get_real4_array(igrib,'values',zsec4,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ endif
+
+ if(ifield.eq.1) then
+
+ !get the required fields from section 2
+ !store compatible to gribex input
+ call grib_get_int(igrib,'numberOfPointsAlongAParallel', &
+ isec2(2),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'numberOfPointsAlongAMeridian', &
+ isec2(3),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_real8(igrib,'longitudeOfFirstGridPointInDegrees', &
+ xauxin,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_real8(igrib,'latitudeOfLastGridPointInDegrees', &
+ yauxin,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ xaux=xauxin+real(nxshift)*dx
+ yaux=yauxin
+
+ ! CHECK GRID SPECIFICATIONS
+
+ if(isec2(2).ne.nxfield) stop 'READWIND: NX NOT CONSISTENT'
+ if(isec2(3).ne.ny) stop 'READWIND: NY NOT CONSISTENT'
+ if(xaux.eq.0.) xaux=-179.0 ! NCEP DATA
+ xaux0=xlon0
+ yaux0=ylat0
+ if(xaux.lt.0.) xaux=xaux+360.
+ if(yaux.lt.0.) yaux=yaux+360.
+ if(xaux0.lt.0.) xaux0=xaux0+360.
+ if(yaux0.lt.0.) yaux0=yaux0+360.
+ if(abs(xaux-xaux0).gt.eps) &
+ stop 'READWIND: LOWER LEFT LONGITUDE NOT CONSISTENT'
+ if(abs(yaux-yaux0).gt.eps) &
+ stop 'READWIND: LOWER LEFT LATITUDE NOT CONSISTENT'
+ endif
+ !HSO end of edits
+
+ i179=nint(179./dx)
+ if (dx.lt.0.7) then
+ i180=nint(180./dx)+1 ! 0.5 deg data
+ else
+ i180=nint(179./dx)+1 ! 1 deg data
+ endif
+ i181=i180+1
+
+ if (isec1(6).ne.-1) then
+
+ do j=0,nymin1
+ do i=0,nxfield-1
+ if((isec1(6).eq.011).and.(isec1(7).eq.100)) then
+ ! TEMPERATURE
+ if((i.eq.0).and.(j.eq.0)) then
+ do ii=1,nuvz
+ if ((isec1(8)*100.0).eq.akz(ii)) numpt=ii
+ end do
+ endif
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ tth(i179+i,j,numpt,n)=help
+ else
+ tth(i-i181,j,numpt,n)=help
+ endif
+ endif
+ if((isec1(6).eq.033).and.(isec1(7).eq.100)) then
+ ! U VELOCITY
+ if((i.eq.0).and.(j.eq.0)) then
+ do ii=1,nuvz
+ if ((isec1(8)*100.0).eq.akz(ii)) numpu=ii
+ end do
+ endif
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ uuh(i179+i,j,numpu)=help
+ else
+ uuh(i-i181,j,numpu)=help
+ endif
+ endif
+ if((isec1(6).eq.034).and.(isec1(7).eq.100)) then
+ ! V VELOCITY
+ if((i.eq.0).and.(j.eq.0)) then
+ do ii=1,nuvz
+ if ((isec1(8)*100.0).eq.akz(ii)) numpv=ii
+ end do
+ endif
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ vvh(i179+i,j,numpv)=help
+ else
+ vvh(i-i181,j,numpv)=help
+ endif
+ endif
+ if((isec1(6).eq.052).and.(isec1(7).eq.100)) then
+ ! RELATIVE HUMIDITY -> CONVERT TO SPECIFIC HUMIDITY LATER
+ if((i.eq.0).and.(j.eq.0)) then
+ do ii=1,nuvz
+ if ((isec1(8)*100.0).eq.akz(ii)) numprh=ii
+ end do
+ endif
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ qvh(i179+i,j,numprh,n)=help
+ else
+ qvh(i-i181,j,numprh,n)=help
+ endif
+ endif
+ if((isec1(6).eq.001).and.(isec1(7).eq.001)) then
+ ! SURFACE PRESSURE
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ ps(i179+i,j,1,n)=help
+ else
+ ps(i-i181,j,1,n)=help
+ endif
+ endif
+ if((isec1(6).eq.039).and.(isec1(7).eq.100)) then
+ ! W VELOCITY
+ if((i.eq.0).and.(j.eq.0)) then
+ do ii=1,nuvz
+ if ((isec1(8)*100.0).eq.akz(ii)) numpw=ii
+ end do
+ endif
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ wwh(i179+i,j,numpw)=help
+ else
+ wwh(i-i181,j,numpw)=help
+ endif
+ endif
+ if((isec1(6).eq.066).and.(isec1(7).eq.001)) then
+ ! SNOW DEPTH
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ sd(i179+i,j,1,n)=help
+ else
+ sd(i-i181,j,1,n)=help
+ endif
+ endif
+ if((isec1(6).eq.002).and.(isec1(7).eq.102)) then
+ ! MEAN SEA LEVEL PRESSURE
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ msl(i179+i,j,1,n)=help
+ else
+ msl(i-i181,j,1,n)=help
+ endif
+ endif
+ if((isec1(6).eq.071).and.(isec1(7).eq.244)) then
+ ! TOTAL CLOUD COVER
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ tcc(i179+i,j,1,n)=help
+ else
+ tcc(i-i181,j,1,n)=help
+ endif
+ endif
+ if((isec1(6).eq.033).and.(isec1(7).eq.105).and. &
+ (isec1(8).eq.10)) then
+ ! 10 M U VELOCITY
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ u10(i179+i,j,1,n)=help
+ else
+ u10(i-i181,j,1,n)=help
+ endif
+ endif
+ if((isec1(6).eq.034).and.(isec1(7).eq.105).and. &
+ (isec1(8).eq.10)) then
+ ! 10 M V VELOCITY
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ v10(i179+i,j,1,n)=help
+ else
+ v10(i-i181,j,1,n)=help
+ endif
+ endif
+ if((isec1(6).eq.011).and.(isec1(7).eq.105).and. &
+ (isec1(8).eq.02)) then
+ ! 2 M TEMPERATURE
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ tt2(i179+i,j,1,n)=help
+ else
+ tt2(i-i181,j,1,n)=help
+ endif
+ endif
+ if((isec1(6).eq.017).and.(isec1(7).eq.105).and. &
+ (isec1(8).eq.02)) then
+ ! 2 M DEW POINT TEMPERATURE
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ td2(i179+i,j,1,n)=help
+ else
+ td2(i-i181,j,1,n)=help
+ endif
+ endif
+ if((isec1(6).eq.062).and.(isec1(7).eq.001)) then
+ ! LARGE SCALE PREC.
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ lsprec(i179+i,j,1,n)=help
+ else
+ lsprec(i-i181,j,1,n)=help
+ endif
+ endif
+ if((isec1(6).eq.063).and.(isec1(7).eq.001)) then
+ ! CONVECTIVE PREC.
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ convprec(i179+i,j,1,n)=help
+ else
+ convprec(i-i181,j,1,n)=help
+ endif
+ endif
+ if((isec1(6).eq.007).and.(isec1(7).eq.001)) then
+ ! TOPOGRAPHY
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ oro(i179+i,j)=help
+ excessoro(i179+i,j)=0.0 ! ISOBARIC SURFACES: SUBGRID TERRAIN DISREGARDED
+ else
+ oro(i-i181,j)=help
+ excessoro(i-i181,j)=0.0 ! ISOBARIC SURFACES: SUBGRID TERRAIN DISREGARDED
+ endif
+ endif
+ if((isec1(6).eq.081).and.(isec1(7).eq.001)) then
+ ! LAND SEA MASK
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ lsm(i179+i,j)=help
+ else
+ lsm(i-i181,j)=help
+ endif
+ endif
+ if((isec1(6).eq.221).and.(isec1(7).eq.001)) then
+ ! MIXING HEIGHT
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ hmix(i179+i,j,1,n)=help
+ else
+ hmix(i-i181,j,1,n)=help
+ endif
+ endif
+ if((isec1(6).eq.052).and.(isec1(7).eq.105).and. &
+ (isec1(8).eq.02)) then
+ ! 2 M RELATIVE HUMIDITY
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ qvh2(i179+i,j)=help
+ else
+ qvh2(i-i181,j)=help
+ endif
+ endif
+ if((isec1(6).eq.011).and.(isec1(7).eq.107)) then
+ ! TEMPERATURE LOWEST SIGMA LEVEL
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ tlev1(i179+i,j)=help
+ else
+ tlev1(i-i181,j)=help
+ endif
+ endif
+ if((isec1(6).eq.033).and.(isec1(7).eq.107)) then
+ ! U VELOCITY LOWEST SIGMA LEVEL
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ ulev1(i179+i,j)=help
+ else
+ ulev1(i-i181,j)=help
+ endif
+ endif
+ if((isec1(6).eq.034).and.(isec1(7).eq.107)) then
+ ! V VELOCITY LOWEST SIGMA LEVEL
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ vlev1(i179+i,j)=help
+ else
+ vlev1(i-i181,j)=help
+ endif
+ endif
+
+ end do
+ end do
+
+ endif
+
+ if((isec1(6).eq.33).and.(isec1(7).eq.100)) then
+ ! NCEP ISOBARIC LEVELS
+ iumax=iumax+1
+ endif
+
+ call grib_release(igrib)
+ goto 10 !! READ NEXT LEVEL OR PARAMETER
+ !
+ ! CLOSING OF INPUT DATA FILE
+ !
+
+ !HSO close grib file
+50 continue
+ call grib_close_file(ifile)
+
+ ! SENS. HEAT FLUX
+ sshf(:,:,1,n)=0.0 ! not available from gfs.tccz.pgrbfxx files
+ hflswitch=.false. ! Heat flux not available
+ ! SOLAR RADIATIVE FLUXES
+ ssr(:,:,1,n)=0.0 ! not available from gfs.tccz.pgrbfxx files
+ ! EW SURFACE STRESS
+ ewss=0.0 ! not available from gfs.tccz.pgrbfxx files
+ ! NS SURFACE STRESS
+ nsss=0.0 ! not available from gfs.tccz.pgrbfxx files
+ strswitch=.false. ! stress not available
+
+ ! CONVERT TP TO LSP (GRIB2 only)
+ if (gribVer.eq.2) then
+ do j=0,nymin1
+ do i=0,nxfield-1
+ if(i.le.i180) then
+ if (convprec(i179+i,j,1,n).lt.lsprec(i179+i,j,1,n)) then ! neg precip would occur
+ lsprec(i179+i,j,1,n)= &
+ lsprec(i179+i,j,1,n)-convprec(i179+i,j,1,n)
+ else
+ lsprec(i179+i,j,1,n)=0
+ endif
+ else
+ if (convprec(i-i181,j,1,n).lt.lsprec(i-i181,j,1,n)) then
+ lsprec(i-i181,j,1,n)= &
+ lsprec(i-i181,j,1,n)-convprec(i-i181,j,1,n)
+ else
+ lsprec(i-i181,j,1,n)=0
+ endif
+ endif
+ enddo
+ enddo
+ endif
+ !HSO end edits
+
+
+ ! TRANSFORM RH TO SPECIFIC HUMIDITY
+
+ do j=0,ny-1
+ do i=0,nxfield-1
+ do k=1,nuvz
+ help=qvh(i,j,k,n)
+ temp=tth(i,j,k,n)
+ plev1=akm(k)+bkm(k)*ps(i,j,1,n)
+ elev=ew(temp)*help/100.0
+ qvh(i,j,k,n)=xmwml*(elev/(plev1-((1.0-xmwml)*elev)))
+ end do
+ end do
+ end do
+
+ ! CALCULATE 2 M DEW POINT FROM 2 M RELATIVE HUMIDITY
+ ! USING BOLTON'S (1980) FORMULA
+ ! BECAUSE td2 IS NOT AVAILABLE FROM NCEP GFS DATA
+
+ do j=0,ny-1
+ do i=0,nxfield-1
+ help=qvh2(i,j)
+ temp=tt2(i,j,1,n)
+ elev=ew(temp)/100.*help/100. !vapour pressure in hPa
+ td2(i,j,1,n)=243.5/(17.67/log(elev/6.112)-1)+273.
+ if (help.le.0.) td2(i,j,1,n)=tt2(i,j,1,n)
+ end do
+ end do
+
+ if(levdiff2.eq.0) then
+ iwmax=nlev_ec+1
+ do i=0,nxmin1
+ do j=0,nymin1
+ wwh(i,j,nlev_ec+1)=0.
+ end do
+ end do
+ endif
+
+
+ ! For global fields, assign the leftmost data column also to the rightmost
+ ! data column; if required, shift whole grid by nxshift grid points
+ !*************************************************************************
+
+ if (xglobal) then
+ call shift_field_0(ewss,nxfield,ny)
+ call shift_field_0(nsss,nxfield,ny)
+ call shift_field_0(oro,nxfield,ny)
+ call shift_field_0(excessoro,nxfield,ny)
+ call shift_field_0(lsm,nxfield,ny)
+ call shift_field_0(ulev1,nxfield,ny)
+ call shift_field_0(vlev1,nxfield,ny)
+ call shift_field_0(tlev1,nxfield,ny)
+ call shift_field_0(qvh2,nxfield,ny)
+ call shift_field(ps,nxfield,ny,1,1,2,n)
+ call shift_field(sd,nxfield,ny,1,1,2,n)
+ call shift_field(msl,nxfield,ny,1,1,2,n)
+ call shift_field(tcc,nxfield,ny,1,1,2,n)
+ call shift_field(u10,nxfield,ny,1,1,2,n)
+ call shift_field(v10,nxfield,ny,1,1,2,n)
+ call shift_field(tt2,nxfield,ny,1,1,2,n)
+ call shift_field(td2,nxfield,ny,1,1,2,n)
+ call shift_field(lsprec,nxfield,ny,1,1,2,n)
+ call shift_field(convprec,nxfield,ny,1,1,2,n)
+ call shift_field(sshf,nxfield,ny,1,1,2,n)
+ call shift_field(ssr,nxfield,ny,1,1,2,n)
+ call shift_field(hmix,nxfield,ny,1,1,2,n)
+ call shift_field(tth,nxfield,ny,nuvzmax,nuvz,2,n)
+ call shift_field(qvh,nxfield,ny,nuvzmax,nuvz,2,n)
+ call shift_field(uuh,nxfield,ny,nuvzmax,nuvz,1,1)
+ call shift_field(vvh,nxfield,ny,nuvzmax,nuvz,1,1)
+ call shift_field(wwh,nxfield,ny,nwzmax,nwz,1,1)
+ endif
+
+ do i=0,nxmin1
+ do j=0,nymin1
+ ! Convert precip. from mm/s -> mm/hour
+ convprec(i,j,1,n)=convprec(i,j,1,n)*3600.
+ lsprec(i,j,1,n)=lsprec(i,j,1,n)*3600.
+ surfstr(i,j,1,n)=sqrt(ewss(i,j)**2+nsss(i,j)**2)
+ end do
+ end do
+
+ if ((.not.hflswitch).or.(.not.strswitch)) then
+ ! write(*,*) 'WARNING: No flux data contained in GRIB file ',
+ ! + wfname(indj)
+
+ ! CALCULATE USTAR AND SSHF USING THE PROFILE METHOD
+ !***************************************************************************
+
+ do i=0,nxmin1
+ do j=0,nymin1
+ hlev1=30.0 ! HEIGHT OF FIRST MODEL SIGMA LAYER
+ ff10m= sqrt(u10(i,j,1,n)**2+v10(i,j,1,n)**2)
+ fflev1=sqrt(ulev1(i,j)**2+vlev1(i,j)**2)
+ call pbl_profile(ps(i,j,1,n),td2(i,j,1,n),hlev1, &
+ tt2(i,j,1,n),tlev1(i,j),ff10m,fflev1, &
+ surfstr(i,j,1,n),sshf(i,j,1,n))
+ if(sshf(i,j,1,n).gt.200.) sshf(i,j,1,n)=200.
+ if(sshf(i,j,1,n).lt.-400.) sshf(i,j,1,n)=-400.
+ end do
+ end do
+ endif
+
+ if(iumax.ne.nuvz) stop 'READWIND: NUVZ NOT CONSISTENT'
+ if(iumax.ne.nwz) stop 'READWIND: NWZ NOT CONSISTENT'
+
+ return
+888 write(*,*) ' #### FLEXPART MODEL ERROR! WINDFIELD #### '
+ write(*,*) ' #### ',wfname(indj),' #### '
+ write(*,*) ' #### IS NOT GRIB FORMAT !!! #### '
+ stop 'Execution terminated'
+999 write(*,*) ' #### FLEXPART MODEL ERROR! WINDFIELD #### '
+ write(*,*) ' #### ',wfname(indj),' #### '
+ write(*,*) ' #### CANNOT BE OPENED !!! #### '
+ stop 'Execution terminated'
+
+end subroutine readwind
diff --git a/src/readwind_gfs_emos.f90 b/src/readwind_gfs_emos.f90
new file mode 100644
index 0000000000000000000000000000000000000000..f5c384f08f4a6243eaaa36265b26977e26aaa0f0
--- /dev/null
+++ b/src/readwind_gfs_emos.f90
@@ -0,0 +1,533 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine readwind(indj,n,uuh,vvh,wwh)
+
+ !**********************************************************************
+ ! *
+ ! TRAJECTORY MODEL SUBROUTINE READWIND *
+ ! *
+ !**********************************************************************
+ ! *
+ ! AUTHOR: G. WOTAWA *
+ ! DATE: 1997-08-05 *
+ ! LAST UPDATE: 2000-10-17, Andreas Stohl *
+ ! CAHENGE: 16/11/2005, Caroline Forster, GFS data *
+ ! *
+ !**********************************************************************
+ ! Changes, Bernd C. Krueger, Feb. 2001:
+ ! Variables tth and qvh (on eta coordinates) in common block
+ !**********************************************************************
+ ! *
+ ! DESCRIPTION: *
+ ! *
+ ! READING OF ECMWF METEOROLOGICAL FIELDS FROM INPUT DATA FILES. THE *
+ ! INPUT DATA FILES ARE EXPECTED TO BE AVAILABLE IN GRIB CODE *
+ ! *
+ ! INPUT: *
+ ! indj indicates number of the wind field to be read in *
+ ! n temporal index for meteorological fields (1 to 3)*
+ ! *
+ ! IMPORTANT VARIABLES FROM COMMON BLOCK: *
+ ! *
+ ! wfname File name of data to be read in *
+ ! nx,ny,nuvz,nwz expected field dimensions *
+ ! nlev_ec number of vertical levels ecmwf model *
+ ! uu,vv,ww wind fields *
+ ! tt,qv temperature and specific humidity *
+ ! ps surface pressure *
+ ! *
+ !**********************************************************************
+
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ real :: uuh(0:nxmax-1,0:nymax-1,nuvzmax)
+ real :: vvh(0:nxmax-1,0:nymax-1,nuvzmax)
+ real :: wwh(0:nxmax-1,0:nymax-1,nwzmax)
+ integer :: ii,indj,i,j,k,n,levdiff2,ifield,iumax,iwmax,lunit
+
+ ! NCEP
+
+ integer :: numpt,numpu,numpv,numpw,numprh
+ real :: help, temp, ew
+ real :: elev
+ real :: ulev1(0:nxmax-1,0:nymax-1),vlev1(0:nxmax-1,0:nymax-1)
+ real :: tlev1(0:nxmax-1,0:nymax-1)
+ real :: qvh2(0:nxmax-1,0:nymax-1)
+
+ ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING
+
+ ! dimension of isec2 at least (22+n), where n is the number of parallels or
+ ! meridians in a quasi-regular (reduced) Gaussian or lat/long grid
+
+ ! dimension of zsec2 at least (10+nn), where nn is the number of vertical
+ ! coordinate parameters
+
+ integer :: isec0(2),isec1(56),isec2(22+nxmax+nymax),isec3(2)
+ integer :: isec4(64),inbuff(jpack),ilen,iswap,ierr,iword
+ real :: zsec2(60+2*nuvzmax),zsec3(2),zsec4(jpunp)
+ real :: xaux,yaux,xaux0,yaux0
+ real,parameter :: eps=1.e-4
+ real :: ewss(0:nxmax-1,0:nymax-1),nsss(0:nxmax-1,0:nymax-1)
+ real :: plev1,hlev1,ff10m,fflev1
+
+ character(len=1) :: yoper = 'D'
+ logical :: hflswitch,strswitch
+
+ hflswitch=.false.
+ strswitch=.false.
+ levdiff2=nlev_ec-nwz+1
+ iumax=0
+ iwmax=0
+
+ !
+ ! OPENING OF DATA FILE (GRIB CODE)
+ !
+5 call pbopen(lunit,path(3)(1:length(3))//wfname(indj),'r',ierr)
+ if(ierr.lt.0) goto 999
+
+ numpt=0
+ numpu=0
+ numpv=0
+ numpw=0
+ numprh=0
+ ifield=0
+10 ifield=ifield+1
+ !
+ ! GET NEXT FIELDS
+ !
+ call pbgrib(lunit,inbuff,jpack,ilen,ierr)
+ if(ierr.eq.-1) goto 50 ! EOF DETECTED
+ if(ierr.lt.-1) goto 888 ! ERROR DETECTED
+
+ ierr=1
+
+ ! Check whether we are on a little endian or on a big endian computer
+ !********************************************************************
+
+ !if (inbuff(1).eq.1112101447) then ! little endian, swap bytes
+ ! iswap=1+ilen/4
+ ! call swap32(inbuff,iswap)
+ !else if (inbuff(1).ne.1196575042) then ! big endian
+ ! stop 'subroutine gridcheck: corrupt GRIB data'
+ !endif
+
+
+ call gribex(isec0,isec1,isec2,zsec2,isec3,zsec3,isec4, &
+ zsec4,jpunp,inbuff,jpack,iword,yoper,ierr)
+ if (ierr.ne.0) goto 10 ! ERROR DETECTED
+
+ if(ifield.eq.1) then
+
+ ! CHECK GRID SPECIFICATIONS
+
+ if(isec2(2).ne.nxfield) stop 'READWIND: NX NOT CONSISTENT'
+ if(isec2(3).ne.ny) stop 'READWIND: NY NOT CONSISTENT'
+ xaux=real(isec2(5))/1000.+real(nxshift)*dx
+ if(xaux.eq.0.) xaux=-179.0 ! NCEP DATA
+ yaux=real(isec2(7))/1000.
+ xaux0=xlon0
+ yaux0=ylat0
+ if(xaux.lt.0.) xaux=xaux+360.
+ if(yaux.lt.0.) yaux=yaux+360.
+ if(xaux0.lt.0.) xaux0=xaux0+360.
+ if(yaux0.lt.0.) yaux0=yaux0+360.
+ if(abs(xaux-xaux0).gt.eps) &
+ stop 'READWIND: LOWER LEFT LONGITUDE NOT CONSISTENT'
+ if(abs(yaux-yaux0).gt.eps) &
+ stop 'READWIND: LOWER LEFT LATITUDE NOT CONSISTENT'
+ endif
+
+ do j=0,nymin1
+ do i=0,nxfield-1
+ if((isec1(6).eq.011).and.(isec1(7).eq.100)) then
+ ! TEMPERATURE
+ if((i.eq.0).and.(j.eq.0)) then
+ do ii=1,nuvz
+ if ((isec1(8)*100.0).eq.akz(ii)) numpt=ii
+ end do
+ endif
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.180) then
+ tth(179+i,j,numpt,n)=help
+ else
+ tth(i-181,j,numpt,n)=help
+ endif
+ endif
+ if((isec1(6).eq.033).and.(isec1(7).eq.100)) then
+ ! U VELOCITY
+ if((i.eq.0).and.(j.eq.0)) then
+ do ii=1,nuvz
+ if ((isec1(8)*100.0).eq.akz(ii)) numpu=ii
+ end do
+ endif
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.180) then
+ uuh(179+i,j,numpu)=help
+ else
+ uuh(i-181,j,numpu)=help
+ endif
+ endif
+ if((isec1(6).eq.034).and.(isec1(7).eq.100)) then
+ ! V VELOCITY
+ if((i.eq.0).and.(j.eq.0)) then
+ do ii=1,nuvz
+ if ((isec1(8)*100.0).eq.akz(ii)) numpv=ii
+ end do
+ endif
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.180) then
+ vvh(179+i,j,numpv)=help
+ else
+ vvh(i-181,j,numpv)=help
+ endif
+ endif
+ if((isec1(6).eq.052).and.(isec1(7).eq.100)) then
+ ! RELATIVE HUMIDITY -> CONVERT TO SPECIFIC HUMIDITY LATER
+ if((i.eq.0).and.(j.eq.0)) then
+ do ii=1,nuvz
+ if ((isec1(8)*100.0).eq.akz(ii)) numprh=ii
+ end do
+ endif
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.180) then
+ qvh(179+i,j,numprh,n)=help
+ else
+ qvh(i-181,j,numprh,n)=help
+ endif
+ endif
+ if((isec1(6).eq.001).and.(isec1(7).eq.001)) then
+ ! SURFACE PRESSURE
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.180) then
+ ps(179+i,j,1,n)=help
+ else
+ ps(i-181,j,1,n)=help
+ endif
+ endif
+ if((isec1(6).eq.039).and.(isec1(7).eq.100)) then
+ ! W VELOCITY
+ if((i.eq.0).and.(j.eq.0)) then
+ do ii=1,nuvz
+ if ((isec1(8)*100.0).eq.akz(ii)) numpw=ii
+ end do
+ endif
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.180) then
+ wwh(179+i,j,numpw)=help
+ else
+ wwh(i-181,j,numpw)=help
+ endif
+ endif
+ if((isec1(6).eq.066).and.(isec1(7).eq.001)) then
+ ! SNOW DEPTH
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.180) then
+ sd(179+i,j,1,n)=help
+ else
+ sd(i-181,j,1,n)=help
+ endif
+ endif
+ if((isec1(6).eq.002).and.(isec1(7).eq.102)) then
+ ! MEAN SEA LEVEL PRESSURE
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.180) then
+ msl(179+i,j,1,n)=help
+ else
+ msl(i-181,j,1,n)=help
+ endif
+ endif
+ if((isec1(6).eq.071).and.(isec1(7).eq.244)) then
+ ! TOTAL CLOUD COVER
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.180) then
+ tcc(179+i,j,1,n)=help
+ else
+ tcc(i-181,j,1,n)=help
+ endif
+ endif
+ if((isec1(6).eq.033).and.(isec1(7).eq.105).and. &
+ (isec1(8).eq.10)) then
+ ! 10 M U VELOCITY
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.180) then
+ u10(179+i,j,1,n)=help
+ else
+ u10(i-181,j,1,n)=help
+ endif
+ endif
+ if((isec1(6).eq.034).and.(isec1(7).eq.105).and. &
+ (isec1(8).eq.10)) then
+ ! 10 M V VELOCITY
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.180) then
+ v10(179+i,j,1,n)=help
+ else
+ v10(i-181,j,1,n)=help
+ endif
+ endif
+ if((isec1(6).eq.011).and.(isec1(7).eq.105).and. &
+ (isec1(8).eq.02)) then
+ ! 2 M TEMPERATURE
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.180) then
+ tt2(179+i,j,1,n)=help
+ else
+ tt2(i-181,j,1,n)=help
+ endif
+ endif
+ if((isec1(6).eq.017).and.(isec1(7).eq.105).and. &
+ (isec1(8).eq.02)) then
+ ! 2 M DEW POINT TEMPERATURE
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.180) then
+ td2(179+i,j,1,n)=help
+ else
+ td2(i-181,j,1,n)=help
+ endif
+ endif
+ if((isec1(6).eq.062).and.(isec1(7).eq.001)) then
+ ! LARGE SCALE PREC.
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.180) then
+ lsprec(179+i,j,1,n)=help
+ else
+ lsprec(i-181,j,1,n)=help
+ endif
+ endif
+ if((isec1(6).eq.063).and.(isec1(7).eq.001)) then
+ ! CONVECTIVE PREC.
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.180) then
+ convprec(179+i,j,1,n)=help
+ else
+ convprec(i-181,j,1,n)=help
+ endif
+ endif
+ ! SENS. HEAT FLUX
+ sshf(i,j,1,n)=0.0 ! not available from gfs.tccz.pgrbfxx files
+ hflswitch=.false. ! Heat flux not available
+ ! SOLAR RADIATIVE FLUXES
+ ssr(i,j,1,n)=0.0 ! not available from gfs.tccz.pgrbfxx files
+ ! EW SURFACE STRESS
+ ewss(i,j)=0.0 ! not available from gfs.tccz.pgrbfxx files
+ ! NS SURFACE STRESS
+ nsss(i,j)=0.0 ! not available from gfs.tccz.pgrbfxx files
+ strswitch=.false. ! stress not available
+ if((isec1(6).eq.007).and.(isec1(7).eq.001)) then
+ ! TOPOGRAPHY
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.180) then
+ oro(179+i,j)=help
+ excessoro(179+i,j)=0.0 ! ISOBARIC SURFACES: SUBGRID TERRAIN DISREGARDED
+ else
+ oro(i-181,j)=help
+ excessoro(i-181,j)=0.0 ! ISOBARIC SURFACES: SUBGRID TERRAIN DISREGARDED
+ endif
+ endif
+ if((isec1(6).eq.081).and.(isec1(7).eq.001)) then
+ ! LAND SEA MASK
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.180) then
+ lsm(179+i,j)=help
+ else
+ lsm(i-181,j)=help
+ endif
+ endif
+ if((isec1(6).eq.221).and.(isec1(7).eq.001)) then
+ ! MIXING HEIGHT
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.180) then
+ hmix(179+i,j,1,n)=help
+ else
+ hmix(i-181,j,1,n)=help
+ endif
+ endif
+ if((isec1(6).eq.052).and.(isec1(7).eq.105).and. &
+ (isec1(8).eq.02)) then
+ ! 2 M RELATIVE HUMIDITY
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.180) then
+ qvh2(179+i,j)=help
+ else
+ qvh2(i-181,j)=help
+ endif
+ endif
+ if((isec1(6).eq.011).and.(isec1(7).eq.107)) then
+ ! TEMPERATURE LOWEST SIGMA LEVEL
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.180) then
+ tlev1(179+i,j)=help
+ else
+ tlev1(i-181,j)=help
+ endif
+ endif
+ if((isec1(6).eq.033).and.(isec1(7).eq.107)) then
+ ! U VELOCITY LOWEST SIGMA LEVEL
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.180) then
+ ulev1(179+i,j)=help
+ else
+ ulev1(i-181,j)=help
+ endif
+ endif
+ if((isec1(6).eq.034).and.(isec1(7).eq.107)) then
+ ! V VELOCITY LOWEST SIGMA LEVEL
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.180) then
+ vlev1(179+i,j)=help
+ else
+ vlev1(i-181,j)=help
+ endif
+ endif
+
+ end do
+ end do
+
+ if((isec1(6).eq.33).and.(isec1(7).eq.100)) then
+ ! NCEP ISOBARIC LEVELS
+ iumax=iumax+1
+ endif
+
+
+ goto 10 !! READ NEXT LEVEL OR PARAMETER
+ !
+ ! CLOSING OF INPUT DATA FILE
+ !
+50 call pbclose(lunit,ierr) !! FINNISHED READING / CLOSING GRIB FILE
+
+ ! TRANSFORM RH TO SPECIFIC HUMIDITY
+
+ do j=0,ny-1
+ do i=0,nxfield-1
+ do k=1,nuvz
+ help=qvh(i,j,k,n)
+ temp=tth(i,j,k,n)
+ plev1=akm(k)+bkm(k)*ps(i,j,1,n)
+ elev=ew(temp)*help/100.0
+ qvh(i,j,k,n)=xmwml*(elev/(plev1-((1.0-xmwml)*elev)))
+ end do
+ end do
+ end do
+
+ ! CALCULATE 2 M DEW POINT FROM 2 M RELATIVE HUMIDITY
+ ! USING BOLTON'S (1980) FORMULA
+ ! BECAUSE td2 IS NOT AVAILABLE FROM NCEP GFS DATA
+
+ do j=0,ny-1
+ do i=0,nxfield-1
+ help=qvh2(i,j)
+ temp=tt2(i,j,1,n)
+ elev=ew(temp)/100.*help/100. !vapour pressure in hPa
+ td2(i,j,1,n)=243.5/(17.67/log(elev/6.112)-1)+273.
+ if (help.le.0.) td2(i,j,1,n)=tt2(i,j,1,n)
+ end do
+ end do
+
+ if(levdiff2.eq.0) then
+ iwmax=nlev_ec+1
+ do i=0,nxmin1
+ do j=0,nymin1
+ wwh(i,j,nlev_ec+1)=0.
+ end do
+ end do
+ endif
+
+
+ ! For global fields, assign the leftmost data column also to the rightmost
+ ! data column; if required, shift whole grid by nxshift grid points
+ !*************************************************************************
+
+ if (xglobal) then
+ call shift_field_0(ewss,nxfield,ny)
+ call shift_field_0(nsss,nxfield,ny)
+ call shift_field_0(oro,nxfield,ny)
+ call shift_field_0(excessoro,nxfield,ny)
+ call shift_field_0(lsm,nxfield,ny)
+ call shift_field_0(ulev1,nxfield,ny)
+ call shift_field_0(vlev1,nxfield,ny)
+ call shift_field_0(tlev1,nxfield,ny)
+ call shift_field_0(qvh2,nxfield,ny)
+ call shift_field(ps,nxfield,ny,1,1,2,n)
+ call shift_field(sd,nxfield,ny,1,1,2,n)
+ call shift_field(msl,nxfield,ny,1,1,2,n)
+ call shift_field(tcc,nxfield,ny,1,1,2,n)
+ call shift_field(u10,nxfield,ny,1,1,2,n)
+ call shift_field(v10,nxfield,ny,1,1,2,n)
+ call shift_field(tt2,nxfield,ny,1,1,2,n)
+ call shift_field(td2,nxfield,ny,1,1,2,n)
+ call shift_field(lsprec,nxfield,ny,1,1,2,n)
+ call shift_field(convprec,nxfield,ny,1,1,2,n)
+ call shift_field(sshf,nxfield,ny,1,1,2,n)
+ call shift_field(ssr,nxfield,ny,1,1,2,n)
+ call shift_field(hmix,nxfield,ny,1,1,2,n)
+ call shift_field(tth,nxfield,ny,nuvzmax,nuvz,2,n)
+ call shift_field(qvh,nxfield,ny,nuvzmax,nuvz,2,n)
+ call shift_field(uuh,nxfield,ny,nuvzmax,nuvz,1,1)
+ call shift_field(vvh,nxfield,ny,nuvzmax,nuvz,1,1)
+ call shift_field(wwh,nxfield,ny,nwzmax,nwz,1,1)
+ endif
+
+ do i=0,nxmin1
+ do j=0,nymin1
+ surfstr(i,j,1,n)=sqrt(ewss(i,j)**2+nsss(i,j)**2)
+ end do
+ end do
+
+ if ((.not.hflswitch).or.(.not.strswitch)) then
+ ! write(*,*) 'WARNING: No flux data contained in GRIB file ',
+ ! + wfname(indj)
+
+ ! CALCULATE USTAR AND SSHF USING THE PROFILE METHOD
+ !***************************************************************************
+
+ do i=0,nxmin1
+ do j=0,nymin1
+ hlev1=30.0 ! HEIGHT OF FIRST MODEL SIGMA LAYER
+ ff10m= sqrt(u10(i,j,1,n)**2+v10(i,j,1,n)**2)
+ fflev1=sqrt(ulev1(i,j)**2+vlev1(i,j)**2)
+ call pbl_profile(ps(i,j,1,n),td2(i,j,1,n),hlev1, &
+ tt2(i,j,1,n),tlev1(i,j),ff10m,fflev1, &
+ surfstr(i,j,1,n),sshf(i,j,1,n))
+ if(sshf(i,j,1,n).gt.200.) sshf(i,j,1,n)=200.
+ if(sshf(i,j,1,n).lt.-400.) sshf(i,j,1,n)=-400.
+ end do
+ end do
+ endif
+
+
+ if(iumax.ne.nuvz) stop 'READWIND: NUVZ NOT CONSISTENT'
+ if(iumax.ne.nwz) stop 'READWIND: NWZ NOT CONSISTENT'
+
+ return
+888 write(*,*) ' #### FLEXPART MODEL ERROR! WINDFIELD #### '
+ write(*,*) ' #### ',wfname(indj),' #### '
+ write(*,*) ' #### IS NOT GRIB FORMAT !!! #### '
+ stop 'Execution terminated'
+999 write(*,*) ' #### FLEXPART MODEL ERROR! WINDFIELD #### '
+ write(*,*) ' #### ',wfname(indj),' #### '
+ write(*,*) ' #### CANNOT BE OPENED !!! #### '
+ stop 'Execution terminated'
+
+end subroutine readwind
diff --git a/src/readwind_nests.f90 b/src/readwind_nests.f90
new file mode 100644
index 0000000000000000000000000000000000000000..b7bb9ff74862080cf096f44f41462c6ef0532d9b
--- /dev/null
+++ b/src/readwind_nests.f90
@@ -0,0 +1,420 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine readwind_nests(indj,n,uuhn,vvhn,wwhn)
+ ! i i o o o
+ !*****************************************************************************
+ ! *
+ ! This routine reads the wind fields for the nested model domains. *
+ ! It is similar to subroutine readwind, which reads the mother domain. *
+ ! *
+ ! Authors: A. Stohl, G. Wotawa *
+ ! *
+ ! 8 February 1999 *
+ ! *
+ ! Last update: 17 October 2000, A. Stohl *
+ ! *
+ !*****************************************************************************
+ ! Changes, Bernd C. Krueger, Feb. 2001: *
+ ! Variables tthn and qvhn (on eta coordinates) in common block *
+ ! CHANGE: 11/01/2008, Harald Sodemann, GRIB1/2 input with ECMWF grib_api *
+ ! CHANGE: 03/12/2008, Harald Sodemann, update to f90 with ECMWF grib_api *
+ !*****************************************************************************
+
+ use grib_api
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ !HSO parameters for grib_api
+ integer :: ifile
+ integer :: iret
+ integer :: igrib
+ integer :: gribVer,parCat,parNum,typSurf,valSurf,discipl
+ integer :: gotGrid
+ !HSO end
+
+ real :: uuhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
+ real :: vvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
+ real :: wwhn(0:nxmaxn-1,0:nymaxn-1,nwzmax,maxnests)
+ integer :: indj,i,j,k,n,levdiff2,ifield,iumax,iwmax,l
+
+ ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING
+
+ ! dimension of isec2 at least (22+n), where n is the number of parallels or
+ ! meridians in a quasi-regular (reduced) Gaussian or lat/long grid
+
+ ! dimension of zsec2 at least (10+nn), where nn is the number of vertical
+ ! coordinate parameters
+
+ integer :: isec1(56),isec2(22+nxmaxn+nymaxn)
+ real(kind=4) :: zsec4(jpunp)
+ real(kind=8) :: xauxin,yauxin
+ real(kind=4) :: xaux,yaux,xaux0,yaux0
+ real :: ewss(0:nxmaxn-1,0:nymaxn-1),nsss(0:nxmaxn-1,0:nymaxn-1)
+ real :: plev1,pmean,tv,fu,hlev1,ff10m,fflev1
+
+ logical :: hflswitch,strswitch
+
+ !HSO grib api error messages
+ character(len=24) :: gribErrorMsg = 'Error reading grib file'
+ character(len=20) :: gribFunction = 'readwind_nests'
+
+ do l=1,numbnests
+ hflswitch=.false.
+ strswitch=.false.
+ levdiff2=nlev_ec-nwz+1
+ iumax=0
+ iwmax=0
+
+ ifile=0
+ igrib=0
+ iret=0
+
+ !
+ ! OPENING OF DATA FILE (GRIB CODE)
+ !
+
+5 call grib_open_file(ifile,path(numpath+2*(l-1)+1) &
+ (1:length(numpath+2*(l-1)+1))//trim(wfnamen(l,indj)),'r')
+ if (iret.ne.GRIB_SUCCESS) then
+ goto 888 ! ERROR DETECTED
+ endif
+ !turn on support for multi fields messages */
+ !call grib_multi_support_on
+
+ gotGrid=0
+ ifield=0
+10 ifield=ifield+1
+ !
+ ! GET NEXT FIELDS
+ !
+ call grib_new_from_file(ifile,igrib,iret)
+ if (iret.eq.GRIB_END_OF_FILE) then
+ goto 50 ! EOF DETECTED
+ elseif (iret.ne.GRIB_SUCCESS) then
+ goto 888 ! ERROR DETECTED
+ endif
+
+ !first see if we read GRIB1 or GRIB2
+ call grib_get_int(igrib,'editionNumber',gribVer,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ if (gribVer.eq.1) then ! GRIB Edition 1
+
+ !print*,'GRiB Edition 1'
+ !read the grib2 identifiers
+ call grib_get_int(igrib,'indicatorOfParameter',isec1(6),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'level',isec1(8),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ !change code for etadot to code for omega
+ if (isec1(6).eq.77) then
+ isec1(6)=135
+ endif
+
+ else
+
+ !print*,'GRiB Edition 2'
+ !read the grib2 identifiers
+ call grib_get_int(igrib,'discipline',discipl,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'parameterCategory',parCat,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'parameterNumber',parNum,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'typeOfFirstFixedSurface',typSurf,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'level',valSurf,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ !print*,discipl,parCat,parNum,typSurf,valSurf
+
+ !convert to grib1 identifiers
+ isec1(6)=-1
+ isec1(7)=-1
+ isec1(8)=-1
+ isec1(8)=valSurf ! level
+ if ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.105)) then ! T
+ isec1(6)=130 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.105)) then ! U
+ isec1(6)=131 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.105)) then ! V
+ isec1(6)=132 ! indicatorOfParameter
+ elseif ((parCat.eq.1).and.(parNum.eq.0).and.(typSurf.eq.105)) then ! Q
+ isec1(6)=133 ! indicatorOfParameter
+ elseif ((parCat.eq.3).and.(parNum.eq.0).and.(typSurf.eq.1)) then !SP
+ isec1(6)=134 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.32)) then ! W, actually eta dot
+ isec1(6)=135 ! indicatorOfParameter
+ elseif ((parCat.eq.3).and.(parNum.eq.0).and.(typSurf.eq.101)) then !SLP
+ isec1(6)=151 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.103)) then ! 10U
+ isec1(6)=165 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.103)) then ! 10V
+ isec1(6)=166 ! indicatorOfParameter
+ elseif ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.103)) then ! 2T
+ isec1(6)=167 ! indicatorOfParameter
+ elseif ((parCat.eq.0).and.(parNum.eq.6).and.(typSurf.eq.103)) then ! 2D
+ isec1(6)=168 ! indicatorOfParameter
+ elseif ((parCat.eq.1).and.(parNum.eq.11).and.(typSurf.eq.1)) then ! SD
+ isec1(6)=141 ! indicatorOfParameter
+ elseif ((parCat.eq.6).and.(parNum.eq.1)) then ! CC
+ isec1(6)=164 ! indicatorOfParameter
+ elseif ((parCat.eq.1).and.(parNum.eq.9)) then ! LSP
+ isec1(6)=142 ! indicatorOfParameter
+ elseif ((parCat.eq.1).and.(parNum.eq.10)) then ! CP
+ isec1(6)=143 ! indicatorOfParameter
+ elseif ((parCat.eq.0).and.(parNum.eq.11).and.(typSurf.eq.1)) then ! SHF
+ isec1(6)=146 ! indicatorOfParameter
+ elseif ((parCat.eq.4).and.(parNum.eq.9).and.(typSurf.eq.1)) then ! SR
+ isec1(6)=176 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.17)) then ! EWSS
+ isec1(6)=180 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.18)) then ! NSSS
+ isec1(6)=181 ! indicatorOfParameter
+ elseif ((parCat.eq.3).and.(parNum.eq.4)) then ! ORO
+ isec1(6)=129 ! indicatorOfParameter
+ elseif ((parCat.eq.3).and.(parNum.eq.7)) then ! SDO
+ isec1(6)=160 ! indicatorOfParameter
+ elseif ((discipl.eq.2).and.(parCat.eq.0).and.(parNum.eq.0).and. &
+ (typSurf.eq.1)) then ! LSM
+ isec1(6)=172 ! indicatorOfParameter
+ else
+ print*,'***ERROR: undefined GRiB2 message found!',discipl, &
+ parCat,parNum,typSurf
+ endif
+
+ endif
+
+ !HSO get the size and data of the values array
+ if (isec1(6).ne.-1) then
+ call grib_get_real4_array(igrib,'values',zsec4,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ endif
+
+ !HSO get the required fields from section 2 in a gribex compatible manner
+ if(ifield.eq.1) then
+ call grib_get_int(igrib,'numberOfPointsAlongAParallel', &
+ isec2(2),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'numberOfPointsAlongAMeridian', &
+ isec2(3),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'numberOfVerticalCoordinateValues', &
+ isec2(12))
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ ! CHECK GRID SPECIFICATIONS
+ if(isec2(2).ne.nxn(l)) stop &
+ 'READWIND: NX NOT CONSISTENT FOR A NESTING LEVEL'
+ if(isec2(3).ne.nyn(l)) stop &
+ 'READWIND: NY NOT CONSISTENT FOR A NESTING LEVEL'
+ if(isec2(12)/2-1.ne.nlev_ec) stop 'READWIND: VERTICAL DISCRET&
+ &IZATION NOT CONSISTENT FOR A NESTING LEVEL'
+ endif ! ifield
+
+ !HSO get the second part of the grid dimensions only from GRiB1 messages
+ if ((gribVer.eq.1).and.(gotGrid.eq.0)) then
+ call grib_get_real8(igrib,'longitudeOfFirstGridPointInDegrees', &
+ xauxin,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_real8(igrib,'latitudeOfLastGridPointInDegrees', &
+ yauxin,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ xaux=xauxin
+ yaux=yauxin
+ xaux0=xlon0n(l)
+ yaux0=ylat0n(l)
+ if(xaux.lt.0.) xaux=xaux+360.
+ if(yaux.lt.0.) yaux=yaux+360.
+ if(xaux0.lt.0.) xaux0=xaux0+360.
+ if(yaux0.lt.0.) yaux0=yaux0+360.
+ if(xaux.ne.xaux0) &
+ stop 'READWIND: LOWER LEFT LONGITUDE NOT CONSISTENT FOR A NES&
+ &TING LEVEL'
+ if(yaux.ne.yaux0) &
+ stop 'READWIND: LOWER LEFT LATITUDE NOT CONSISTENT FOR A NEST&
+ &ING LEVEL'
+ gotGrid=1
+ endif
+
+ do j=0,nyn(l)-1
+ do i=0,nxn(l)-1
+ k=isec1(8)
+ if(isec1(6).eq.130) tthn(i,j,nlev_ec-k+2,n,l)= &!! TEMPERATURE
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.131) uuhn(i,j,nlev_ec-k+2,l)= &!! U VELOCITY
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.132) vvhn(i,j,nlev_ec-k+2,l)= &!! V VELOCITY
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.133) then !! SPEC. HUMIDITY
+ qvhn(i,j,nlev_ec-k+2,n,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if (qvhn(i,j,nlev_ec-k+2,n,l) .lt. 0.) &
+ qvhn(i,j,nlev_ec-k+2,n,l) = 0.
+ ! this is necessary because the gridded data may contain
+ ! spurious negative values
+ endif
+ if(isec1(6).eq.134) psn(i,j,1,n,l)= &!! SURF. PRESS.
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.135) wwhn(i,j,nlev_ec-k+1,l)= &!! W VELOCITY
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.141) sdn(i,j,1,n,l)= &!! SNOW DEPTH
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.151) msln(i,j,1,n,l)= &!! SEA LEVEL PRESS.
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.164) tccn(i,j,1,n,l)= &!! CLOUD COVER
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.165) u10n(i,j,1,n,l)= &!! 10 M U VELOCITY
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.166) v10n(i,j,1,n,l)= &!! 10 M V VELOCITY
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.167) tt2n(i,j,1,n,l)= &!! 2 M TEMPERATURE
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.168) td2n(i,j,1,n,l)= &!! 2 M DEW POINT
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.142) then !! LARGE SCALE PREC.
+ lsprecn(i,j,1,n,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if (lsprecn(i,j,1,n,l).lt.0.) lsprecn(i,j,1,n,l)=0.
+ endif
+ if(isec1(6).eq.143) then !! CONVECTIVE PREC.
+ convprecn(i,j,1,n,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if (convprecn(i,j,1,n,l).lt.0.) convprecn(i,j,1,n,l)=0.
+ endif
+ if(isec1(6).eq.146) sshfn(i,j,1,n,l)= &!! SENS. HEAT FLUX
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if((isec1(6).eq.146).and. &
+ (zsec4(nxn(l)*(nyn(l)-j-1)+i+1).ne.0.)) hflswitch=.true. ! Heat flux available
+ if(isec1(6).eq.176) then !! SOLAR RADIATION
+ ssrn(i,j,1,n,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if (ssrn(i,j,1,n,l).lt.0.) ssrn(i,j,1,n,l)=0.
+ endif
+ if(isec1(6).eq.180) ewss(i,j)= &!! EW SURFACE STRESS
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.181) nsss(i,j)= &!! NS SURFACE STRESS
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(((isec1(6).eq.180).or.(isec1(6).eq.181)).and. &
+ (zsec4(nxn(l)*(nyn(l)-j-1)+i+1).ne.0.)) strswitch=.true. ! stress available
+ if(isec1(6).eq.129) oron(i,j,l)= &!! ECMWF OROGRAPHY
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)/ga
+ if(isec1(6).eq.160) excessoron(i,j,l)= &!! STANDARD DEVIATION OF OROGRAPHY
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.172) lsmn(i,j,l)= &!! ECMWF LAND SEA MASK
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.131) iumax=max(iumax,nlev_ec-k+1)
+ if(isec1(6).eq.135) iwmax=max(iwmax,nlev_ec-k+1)
+
+ end do
+ end do
+
+ call grib_release(igrib)
+ goto 10 !! READ NEXT LEVEL OR PARAMETER
+ !
+ ! CLOSING OF INPUT DATA FILE
+ !
+50 call grib_close_file(ifile)
+
+ !error message if no fields found with correct first longitude in it
+ if (gotGrid.eq.0) then
+ print*,'***ERROR: input file needs to contain GRiB1 formatted'// &
+ 'messages'
+ stop
+ endif
+
+ if(levdiff2.eq.0) then
+ iwmax=nlev_ec+1
+ do i=0,nxn(l)-1
+ do j=0,nyn(l)-1
+ wwhn(i,j,nlev_ec+1,l)=0.
+ end do
+ end do
+ endif
+
+ do i=0,nxn(l)-1
+ do j=0,nyn(l)-1
+ surfstrn(i,j,1,n,l)=sqrt(ewss(i,j)**2+nsss(i,j)**2)
+ end do
+ end do
+
+ if ((.not.hflswitch).or.(.not.strswitch)) then
+ write(*,*) 'WARNING: No flux data contained in GRIB file ', &
+ wfnamen(l,indj)
+
+ ! CALCULATE USTAR AND SSHF USING THE PROFILE METHOD
+ ! As ECMWF has increased the model resolution, such that now the first model
+ ! level is at about 10 m (where 10-m wind is given), use the 2nd ECMWF level
+ ! (3rd model level in FLEXPART) for the profile method
+ !***************************************************************************
+
+ do i=0,nxn(l)-1
+ do j=0,nyn(l)-1
+ plev1=akz(3)+bkz(3)*psn(i,j,1,n,l)
+ pmean=0.5*(psn(i,j,1,n,l)+plev1)
+ tv=tthn(i,j,3,n,l)*(1.+0.61*qvhn(i,j,3,n,l))
+ fu=-r_air*tv/ga/pmean
+ hlev1=fu*(plev1-psn(i,j,1,n,l)) ! HEIGTH OF FIRST MODEL LAYER
+ ff10m= sqrt(u10n(i,j,1,n,l)**2+v10n(i,j,1,n,l)**2)
+ fflev1=sqrt(uuhn(i,j,3,l)**2+vvhn(i,j,3,l)**2)
+ call pbl_profile(psn(i,j,1,n,l),td2n(i,j,1,n,l),hlev1, &
+ tt2n(i,j,1,n,l),tthn(i,j,3,n,l),ff10m,fflev1, &
+ surfstrn(i,j,1,n,l),sshfn(i,j,1,n,l))
+ if(sshfn(i,j,1,n,l).gt.200.) sshfn(i,j,1,n,l)=200.
+ if(sshfn(i,j,1,n,l).lt.-400.) sshfn(i,j,1,n,l)=-400.
+ end do
+ end do
+ endif
+
+
+ ! Assign 10 m wind to model level at eta=1.0 to have one additional model
+ ! level at the ground
+ ! Specific humidity is taken the same as at one level above
+ ! Temperature is taken as 2 m temperature
+ !**************************************************************************
+
+ do i=0,nxn(l)-1
+ do j=0,nyn(l)-1
+ uuhn(i,j,1,l)=u10n(i,j,1,n,l)
+ vvhn(i,j,1,l)=v10n(i,j,1,n,l)
+ qvhn(i,j,1,n,l)=qvhn(i,j,2,n,l)
+ tthn(i,j,1,n,l)=tt2n(i,j,1,n,l)
+ end do
+ end do
+
+ if(iumax.ne.nuvz-1) stop &
+ 'READWIND: NUVZ NOT CONSISTENT FOR A NESTING LEVEL'
+ if(iwmax.ne.nwz) stop &
+ 'READWIND: NWZ NOT CONSISTENT FOR A NESTING LEVEL'
+
+ end do
+
+ return
+888 write(*,*) ' #### FLEXPART MODEL ERROR! WINDFIELD #### '
+ write(*,*) ' #### ',wfnamen(l,indj),' FOR NESTING LEVEL #### '
+ write(*,*) ' #### ',l,' IS NOT GRIB FORMAT !!! #### '
+ stop 'Execution terminated'
+
+
+999 write(*,*) ' #### FLEXPART MODEL ERROR! WINDFIELD #### '
+ write(*,*) ' #### ',wfnamen(l,indj),' #### '
+ write(*,*) ' #### CANNOT BE OPENED FOR NESTING LEVEL ',l,'####'
+
+end subroutine readwind_nests
diff --git a/src/readwind_nests_emos.f90 b/src/readwind_nests_emos.f90
new file mode 100644
index 0000000000000000000000000000000000000000..682a068fe3a4ae557db0007ac6e80f17905fd4c2
--- /dev/null
+++ b/src/readwind_nests_emos.f90
@@ -0,0 +1,286 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine readwind_nests(indj,n,uuhn,vvhn,wwhn)
+ ! i i o o o
+ !*****************************************************************************
+ ! *
+ ! This routine reads the wind fields for the nested model domains. *
+ ! It is similar to subroutine readwind, which reads the mother domain. *
+ ! *
+ ! Authors: A. Stohl, G. Wotawa *
+ ! *
+ ! 8 February 1999 *
+ ! *
+ ! Last update: 17 October 2000, A. Stohl *
+ ! *
+ !*****************************************************************************
+ ! Changes, Bernd C. Krueger, Feb. 2001:
+ ! Variables tthn and qvhn (on eta coordinates) in common block
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ real :: uuhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
+ real :: vvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
+ real :: wwhn(0:nxmaxn-1,0:nymaxn-1,nwzmax,maxnests)
+ integer :: indj,i,j,k,n,levdiff2,ifield,iumax,iwmax,lunit,l
+
+ ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING
+
+ ! dimension of isec2 at least (22+n), where n is the number of parallels or
+ ! meridians in a quasi-regular (reduced) Gaussian or lat/long grid
+
+ ! dimension of zsec2 at least (10+nn), where nn is the number of vertical
+ ! coordinate parameters
+
+ integer :: isec0(2),isec1(56),isec2(22+nxmaxn+nymaxn),isec3(2)
+ integer :: isec4(64),inbuff(jpack),ilen,ierr,iword
+ !integer iswap
+ real :: zsec2(60+2*nuvzmax),zsec3(2),zsec4(jpunp)
+ real :: xaux,yaux,xaux0,yaux0
+ real :: ewss(0:nxmaxn-1,0:nymaxn-1),nsss(0:nxmaxn-1,0:nymaxn-1)
+ real :: plev1,pmean,tv,fu,hlev1,ff10m,fflev1
+
+ character(len=1) :: yoper = 'D'
+ logical :: hflswitch,strswitch
+
+
+ do l=1,numbnests
+ hflswitch=.false.
+ strswitch=.false.
+ levdiff2=nlev_ec-nwz+1
+ iumax=0
+ iwmax=0
+
+ !
+ ! OPENING OF DATA FILE (GRIB CODE)
+ !
+5 call pbopen(lunit,path(numpath+2*(l-1)+1) &
+ (1:length(numpath+2*(l-1)+1))//wfnamen(l,indj),'r',ierr)
+ if(ierr.lt.0) goto 999
+
+ ifield=0
+10 ifield=ifield+1
+ !
+ ! GET NEXT FIELDS
+ !
+ call pbgrib(lunit,inbuff,jpack,ilen,ierr)
+ if(ierr.eq.-1) goto 50 ! EOF DETECTED
+ if(ierr.lt.-1) goto 888 ! ERROR DETECTED
+
+ ierr=1
+
+ ! Check whether we are on a little endian or on a big endian computer
+ !********************************************************************
+
+ ! if (inbuff(1).eq.1112101447) then ! little endian, swap bytes
+ ! iswap=1+ilen/4
+ ! call swap32(inbuff,iswap)
+ ! else if (inbuff(1).ne.1196575042) then ! big endian
+ ! stop 'subroutine gridcheck: corrupt GRIB data'
+ ! endif
+
+ call gribex(isec0,isec1,isec2,zsec2,isec3,zsec3,isec4, &
+ zsec4,jpunp,inbuff,jpack,iword,yoper,ierr)
+ if (ierr.ne.0) goto 888 ! ERROR DETECTED
+
+ if(ifield.eq.1) then
+
+ ! CHECK GRID SPECIFICATIONS
+
+ if(isec2(2).ne.nxn(l)) stop &
+ 'READWIND: NX NOT CONSISTENT FOR A NESTING LEVEL'
+ if(isec2(3).ne.nyn(l)) stop &
+ 'READWIND: NY NOT CONSISTENT FOR A NESTING LEVEL'
+ if(isec2(12)/2-1.ne.nlev_ec) stop 'READWIND: VERTICAL DISCRET&
+ &IZATION NOT CONSISTENT FOR A NESTING LEVEL'
+ xaux=real(isec2(5))/1000.
+ yaux=real(isec2(7))/1000.
+ xaux0=xlon0n(l)
+ yaux0=ylat0n(l)
+ if(xaux.lt.0.) xaux=xaux+360.
+ if(yaux.lt.0.) yaux=yaux+360.
+ if(xaux0.lt.0.) xaux0=xaux0+360.
+ if(yaux0.lt.0.) yaux0=yaux0+360.
+ if(xaux.ne.xaux0) &
+ stop 'READWIND: LOWER LEFT LONGITUDE NOT CONSISTENT FOR A NES&
+ &TING LEVEL'
+ if(yaux.ne.yaux0) &
+ stop 'READWIND: LOWER LEFT LATITUDE NOT CONSISTENT FOR A NEST&
+ &ING LEVEL'
+ endif
+
+
+ do j=0,nyn(l)-1
+ do i=0,nxn(l)-1
+ k=isec1(8)
+ if(isec1(6).eq.130) tthn(i,j,nlev_ec-k+2,n,l)= &!! TEMPERATURE
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.131) uuhn(i,j,nlev_ec-k+2,l)= &!! U VELOCITY
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.132) vvhn(i,j,nlev_ec-k+2,l)= &!! V VELOCITY
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.133) then !! SPEC. HUMIDITY
+ qvhn(i,j,nlev_ec-k+2,n,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if (qvhn(i,j,nlev_ec-k+2,n,l) .lt. 0.) &
+ qvhn(i,j,nlev_ec-k+2,n,l) = 0.
+ ! this is necessary because the gridded data may contain
+ ! spurious negative values
+ endif
+ if(isec1(6).eq.134) psn(i,j,1,n,l)= &!! SURF. PRESS.
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.135) wwhn(i,j,nlev_ec-k+1,l)= &!! W VELOCITY
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.141) sdn(i,j,1,n,l)= &!! SNOW DEPTH
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.151) msln(i,j,1,n,l)= &!! SEA LEVEL PRESS.
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.164) tccn(i,j,1,n,l)= &!! CLOUD COVER
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.165) u10n(i,j,1,n,l)= &!! 10 M U VELOCITY
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.166) v10n(i,j,1,n,l)= &!! 10 M V VELOCITY
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.167) tt2n(i,j,1,n,l)= &!! 2 M TEMPERATURE
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.168) td2n(i,j,1,n,l)= &!! 2 M DEW POINT
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.142) then !! LARGE SCALE PREC.
+ lsprecn(i,j,1,n,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if (lsprecn(i,j,1,n,l).lt.0.) lsprecn(i,j,1,n,l)=0.
+ endif
+ if(isec1(6).eq.143) then !! CONVECTIVE PREC.
+ convprecn(i,j,1,n,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if (convprecn(i,j,1,n,l).lt.0.) convprecn(i,j,1,n,l)=0.
+ endif
+ if(isec1(6).eq.146) sshfn(i,j,1,n,l)= &!! SENS. HEAT FLUX
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if((isec1(6).eq.146).and. &
+ (zsec4(nxn(l)*(nyn(l)-j-1)+i+1).ne.0.)) hflswitch=.true. ! Heat flux available
+ if(isec1(6).eq.176) then !! SOLAR RADIATION
+ ssrn(i,j,1,n,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if (ssrn(i,j,1,n,l).lt.0.) ssrn(i,j,1,n,l)=0.
+ endif
+ if(isec1(6).eq.180) ewss(i,j)= &!! EW SURFACE STRESS
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.181) nsss(i,j)= &!! NS SURFACE STRESS
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(((isec1(6).eq.180).or.(isec1(6).eq.181)).and. &
+ (zsec4(nxn(l)*(nyn(l)-j-1)+i+1).ne.0.)) strswitch=.true. ! stress available
+ if(isec1(6).eq.129) oron(i,j,l)= &!! ECMWF OROGRAPHY
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)/ga
+ if(isec1(6).eq.160) excessoron(i,j,l)= &!! STANDARD DEVIATION OF OROGRAPHY
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.172) lsmn(i,j,l)= &!! ECMWF LAND SEA MASK
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.131) iumax=max(iumax,nlev_ec-k+1)
+ if(isec1(6).eq.135) iwmax=max(iwmax,nlev_ec-k+1)
+ end do
+ end do
+
+ goto 10 !! READ NEXT LEVEL OR PARAMETER
+ !
+ ! CLOSING OF INPUT DATA FILE
+ !
+50 call pbclose(lunit,ierr) !! FINISHED READING / CLOSING GRIB FILE
+
+ if(levdiff2.eq.0) then
+ iwmax=nlev_ec+1
+ do i=0,nxn(l)-1
+ do j=0,nyn(l)-1
+ wwhn(i,j,nlev_ec+1,l)=0.
+ end do
+ end do
+ endif
+
+ do i=0,nxn(l)-1
+ do j=0,nyn(l)-1
+ surfstrn(i,j,1,n,l)=sqrt(ewss(i,j)**2+nsss(i,j)**2)
+ end do
+ end do
+
+ if ((.not.hflswitch).or.(.not.strswitch)) then
+ write(*,*) 'WARNING: No flux data contained in GRIB file ', &
+ wfnamen(l,indj)
+
+ ! CALCULATE USTAR AND SSHF USING THE PROFILE METHOD
+ ! As ECMWF has increased the model resolution, such that now the first model
+ ! level is at about 10 m (where 10-m wind is given), use the 2nd ECMWF level
+ ! (3rd model level in FLEXPART) for the profile method
+ !***************************************************************************
+
+ do i=0,nxn(l)-1
+ do j=0,nyn(l)-1
+ plev1=akz(3)+bkz(3)*psn(i,j,1,n,l)
+ pmean=0.5*(psn(i,j,1,n,l)+plev1)
+ tv=tthn(i,j,3,n,l)*(1.+0.61*qvhn(i,j,3,n,l))
+ fu=-r_air*tv/ga/pmean
+ hlev1=fu*(plev1-psn(i,j,1,n,l)) ! HEIGTH OF FIRST MODEL LAYER
+ ff10m= sqrt(u10n(i,j,1,n,l)**2+v10n(i,j,1,n,l)**2)
+ fflev1=sqrt(uuhn(i,j,3,l)**2+vvhn(i,j,3,l)**2)
+ call pbl_profile(psn(i,j,1,n,l),td2n(i,j,1,n,l),hlev1, &
+ tt2n(i,j,1,n,l),tthn(i,j,3,n,l),ff10m,fflev1, &
+ surfstrn(i,j,1,n,l),sshfn(i,j,1,n,l))
+ if(sshfn(i,j,1,n,l).gt.200.) sshfn(i,j,1,n,l)=200.
+ if(sshfn(i,j,1,n,l).lt.-400.) sshfn(i,j,1,n,l)=-400.
+ end do
+ end do
+ endif
+
+
+ ! Assign 10 m wind to model level at eta=1.0 to have one additional model
+ ! level at the ground
+ ! Specific humidity is taken the same as at one level above
+ ! Temperature is taken as 2 m temperature
+ !**************************************************************************
+
+ do i=0,nxn(l)-1
+ do j=0,nyn(l)-1
+ uuhn(i,j,1,l)=u10n(i,j,1,n,l)
+ vvhn(i,j,1,l)=v10n(i,j,1,n,l)
+ qvhn(i,j,1,n,l)=qvhn(i,j,2,n,l)
+ tthn(i,j,1,n,l)=tt2n(i,j,1,n,l)
+ end do
+ end do
+
+ if(iumax.ne.nuvz-1) stop &
+ 'READWIND: NUVZ NOT CONSISTENT FOR A NESTING LEVEL'
+ if(iwmax.ne.nwz) stop &
+ 'READWIND: NWZ NOT CONSISTENT FOR A NESTING LEVEL'
+
+ end do
+
+ return
+888 write(*,*) ' #### FLEXPART MODEL ERROR! WINDFIELD #### '
+ write(*,*) ' #### ',wfnamen(l,indj),' FOR NESTING LEVEL #### '
+ write(*,*) ' #### ',l,' IS NOT GRIB FORMAT !!! #### '
+ stop 'Execution terminated'
+
+
+999 write(*,*) ' #### FLEXPART MODEL ERROR! WINDFIELD #### '
+ write(*,*) ' #### ',wfnamen(l,indj),' #### '
+ write(*,*) ' #### CANNOT BE OPENED FOR NESTING LEVEL ',l,'####'
+
+end subroutine readwind_nests
diff --git a/src/redist.f90 b/src/redist.f90
new file mode 100644
index 0000000000000000000000000000000000000000..3858ef64d32236920cfefa276e0aa7d88ba8cedf
--- /dev/null
+++ b/src/redist.f90
@@ -0,0 +1,253 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine redist (ipart,ktop,ipconv)
+
+ !**************************************************************************
+ ! Do the redistribution of particles due to convection
+ ! This subroutine is called for each particle which is assigned
+ ! a new vertical position randomly, based on the convective redistribution
+ ! matrix
+ !**************************************************************************
+
+ ! Petra Seibert, Feb 2001, Apr 2001, May 2001, Jan 2002, Nov 2002 and
+ ! Andreas Frank, Nov 2002
+
+ ! Caroline Forster: November 2004 - February 2005
+
+ use par_mod
+ use com_mod
+ use conv_mod
+
+ implicit none
+
+ real,parameter :: const=r_air/ga
+ integer :: ipart, ktop,ipconv
+ integer :: k, kz, levnew, levold
+ real,save :: uvzlev(nuvzmax)
+ real :: wsub(nuvzmax)
+ real :: totlevmass, wsubpart
+ real :: temp_levold,temp_levold1
+ real :: sub_levold,sub_levold1
+ real :: pint, pold, rn, tv, tvold, dlevfrac
+ real :: ew,ran3, ztold,ffraction
+ real :: tv1, tv2, dlogp, dz, dz1, dz2
+ integer :: iseed = -88
+
+ ! ipart ... number of particle to be treated
+
+ ipconv=1
+
+ ! determine height of the eta half-levels (uvzlev)
+ ! do that only once for each grid column
+ ! i.e. when ktop.eq.1
+ !**************************************************************
+
+ if (ktop .le. 1) then
+
+ tvold=tt2conv*(1.+0.378*ew(td2conv)/psconv)
+ pold=psconv
+ uvzlev(1)=0.
+
+ pint = phconv(2)
+ ! determine next virtual temperatures
+ tv1 = tconv(1)*(1.+0.608*qconv(1))
+ tv2 = tconv(2)*(1.+0.608*qconv(2))
+ ! interpolate virtual temperature to half-level
+ tv = tv1 + (tv2-tv1)*(pconv(1)-phconv(2))/(pconv(1)-pconv(2))
+ if (abs(tv-tvold).gt.0.2) then
+ uvzlev(2) = uvzlev(1) + &
+ const*log(pold/pint)* &
+ (tv-tvold)/log(tv/tvold)
+ else
+ uvzlev(2) = uvzlev(1)+ &
+ const*log(pold/pint)*tv
+ endif
+ tvold=tv
+ tv1=tv2
+ pold=pint
+
+ ! integrate profile (calculation of height agl of eta layers) as required
+ do kz = 3, nconvtop+1
+ ! note that variables defined in calcmatrix.f (pconv,tconv,qconv)
+ ! start at the first real ECMWF model level whereas kz and
+ ! thus uvzlev(kz) starts at the surface. uvzlev is defined at the
+ ! half-levels (between the tconv, qconv etc. values !)
+ ! Thus, uvzlev(kz) is the lower boundary of the tconv(kz) cell.
+ pint = phconv(kz)
+ ! determine next virtual temperatures
+ tv2 = tconv(kz)*(1.+0.608*qconv(kz))
+ ! interpolate virtual temperature to half-level
+ tv = tv1 + (tv2-tv1)*(pconv(kz-1)-phconv(kz))/ &
+ (pconv(kz-1)-pconv(kz))
+ if (abs(tv-tvold).gt.0.2) then
+ uvzlev(kz) = uvzlev(kz-1) + &
+ const*log(pold/pint)* &
+ (tv-tvold)/log(tv/tvold)
+ else
+ uvzlev(kz) = uvzlev(kz-1)+ &
+ const*log(pold/pint)*tv
+ endif
+ tvold=tv
+ tv1=tv2
+ pold=pint
+
+ end do
+
+ ktop = 2
+
+ endif ! (if ktop .le. 1) then
+
+ ! determine vertical grid position of particle in the eta system
+ !****************************************************************
+
+ ztold = ztra1(abs(ipart))
+ ! find old particle grid position
+ do kz = 2, nconvtop
+ if (uvzlev(kz) .ge. ztold ) then
+ levold = kz-1
+ goto 30
+ endif
+ end do
+
+ ! Particle is above the potentially convective domain. Skip it.
+ goto 90
+
+30 continue
+
+ ! now redistribute particles
+ !****************************
+
+ ! Choose a random number and find corresponding level of destination
+ ! Random numbers to be evenly distributed in [0,1]
+
+ rn = ran3(iseed)
+
+ ! initialize levnew
+
+ levnew = levold
+
+ ffraction = 0.
+ totlevmass=dpr(levold)/ga
+ do k = 1,nconvtop
+ ! for backward runs use the transposed matrix
+ if (ldirect.eq.1) then
+ ffraction=ffraction+fmassfrac(levold,k) &
+ /totlevmass
+ else
+ ffraction=ffraction+fmassfrac(k,levold) &
+ /totlevmass
+ endif
+ if (rn.le.ffraction) then
+ levnew=k
+ ! avoid division by zero or a too small number
+ ! if division by zero or a too small number happens the
+ ! particle is assigned to the center of the grid cell
+ if (ffraction.gt.1.e-20) then
+ if (ldirect.eq.1) then
+ dlevfrac = (ffraction-rn) / fmassfrac(levold,k) * totlevmass
+ else
+ dlevfrac = (ffraction-rn) / fmassfrac(k,levold) * totlevmass
+ endif
+ else
+ dlevfrac = 0.5
+ endif
+ goto 40
+ endif
+ end do
+
+40 continue
+
+ ! now assign new position to particle
+
+ if (levnew.le.nconvtop) then
+ if (levnew.eq.levold) then
+ ztra1(abs(ipart)) = ztold
+ else
+ dlogp = (1.-dlevfrac)* &
+ (log(phconv(levnew+1))-log(phconv(levnew)))
+ pint = log(phconv(levnew))+dlogp
+ dz1 = pint - log(phconv(levnew))
+ dz2 = log(phconv(levnew+1)) - pint
+ dz = dz1 + dz2
+ ztra1(abs(ipart)) = (uvzlev(levnew)*dz2+uvzlev(levnew+1)*dz1)/dz
+ if (ztra1(abs(ipart)).lt.0.) &
+ ztra1(abs(ipart))=-1.*ztra1(abs(ipart))
+ if (ipconv.gt.0) ipconv=-1
+ endif
+ endif
+
+ ! displace particle according to compensating subsidence
+ ! this is done to those particles, that were not redistributed
+ ! by the matrix
+ !**************************************************************
+
+ if (levnew.le.nconvtop.and.levnew.eq.levold) then
+
+ ztold = ztra1(abs(ipart))
+
+ ! determine compensating vertical velocity at the levels
+ ! above and below the particel position
+ ! increase compensating subsidence by the fraction that
+ ! is displaced by convection to this level
+
+ if (levold.gt.1) then
+ temp_levold = tconv(levold-1) + &
+ (tconv(levold)-tconv(levold-1)) &
+ *(pconv(levold-1)-phconv(levold))/ &
+ (pconv(levold-1)-pconv(levold))
+ sub_levold = sub(levold)/(1.-sub(levold)/dpr(levold)*ga)
+ wsub(levold)=-1.*sub_levold*r_air*temp_levold/(phconv(levold))
+ else
+ wsub(levold)=0.
+ endif
+
+ temp_levold1 = tconv(levold) + &
+ (tconv(levold+1)-tconv(levold)) &
+ *(pconv(levold)-phconv(levold+1))/ &
+ (pconv(levold)-pconv(levold+1))
+ sub_levold1 = sub(levold+1)/(1.-sub(levold+1)/dpr(levold+1)*ga)
+ wsub(levold+1)=-1.*sub_levold1*r_air*temp_levold1/ &
+ (phconv(levold+1))
+
+ ! interpolate wsub to the vertical particle position
+
+ dz1 = ztold - uvzlev(levold)
+ dz2 = uvzlev(levold+1) - ztold
+ dz = dz1 + dz2
+
+ wsubpart = (dz2*wsub(levold)+dz1*wsub(levold+1))/dz
+ ztra1(abs(ipart)) = ztold+wsubpart*real(lsynctime)
+ if (ztra1(abs(ipart)).lt.0.) then
+ ztra1(abs(ipart))=-1.*ztra1(abs(ipart))
+ endif
+
+ endif !(levnew.le.nconvtop.and.levnew.eq.levold)
+
+ ! Maximum altitude .5 meter below uppermost model level
+ !*******************************************************
+
+ 90 continue
+
+ if (ztra1(abs(ipart)) .gt. height(nz)-0.5) &
+ ztra1(abs(ipart)) = height(nz)-0.5
+
+end subroutine redist
diff --git a/src/releaseparticles.f90 b/src/releaseparticles.f90
new file mode 100644
index 0000000000000000000000000000000000000000..23846afaf7e2434ad92594e34309bfc1fe07b7d6
--- /dev/null
+++ b/src/releaseparticles.f90
@@ -0,0 +1,401 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine releaseparticles(itime)
+ ! o
+ !*****************************************************************************
+ ! *
+ ! This subroutine releases particles from the release locations. *
+ ! *
+ ! It searches for a "vacant" storage space and assigns all particle *
+ ! information to that space. A space is vacant either when no particle *
+ ! is yet assigned to it, or when it's particle is expired and, thus, *
+ ! the storage space is made available to a new particle. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 29 June 2002 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! itime [s] current time *
+ ! ireleasestart, ireleaseend start and end times of all releases *
+ ! npart(maxpoint) number of particles to be released in total *
+ ! numrel number of particles to be released during this time *
+ ! step *
+ ! *
+ !*****************************************************************************
+
+ use point_mod
+ use xmass_mod
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ !real xaux,yaux,zaux,ran1,rfraction,xmasssave(maxpoint)
+ real :: xaux,yaux,zaux,ran1,rfraction
+ real :: topo,rhoaux(2),r,t,rhoout,ddx,ddy,rddx,rddy,p1,p2,p3,p4
+ real :: dz1,dz2,dz,xtn,ytn,xlonav,timecorrect(maxspec),press,pressold
+ real :: presspart,average_timecorrect
+ integer :: itime,numrel,i,j,k,n,ix,jy,ixp,jyp,ipart,minpart,ii
+ integer :: indz,indzp,kz,ngrid
+ integer :: nweeks,ndayofweek,nhour,jjjjmmdd,ihmmss,mm
+ real(kind=dp) :: juldate,julmonday,jul,jullocal,juldiff
+ real,parameter :: eps=nxmax/3.e5,eps2=1.e-6
+
+ integer :: idummy = -7
+ !save idummy,xmasssave
+ !data idummy/-7/,xmasssave/maxpoint*0./
+
+
+ ! Determine the actual date and time in Greenwich (i.e., UTC + correction for daylight savings time)
+ !*****************************************************************************
+
+ julmonday=juldate(19000101,0) ! this is a Monday
+ jul=bdate+real(itime,kind=dp)/86400._dp ! this is the current day
+ call caldate(jul,jjjjmmdd,ihmmss)
+ mm=(jjjjmmdd-10000*(jjjjmmdd/10000))/100
+ if ((mm.ge.4).and.(mm.le.9)) jul=jul+1._dp/24._dp ! daylight savings time in summer
+
+
+ ! For every release point, check whether we are in the release time interval
+ !***************************************************************************
+
+ minpart=1
+ do i=1,numpoint
+ if ((itime.ge.ireleasestart(i)).and. &! are we within release interval?
+ (itime.le.ireleaseend(i))) then
+
+ ! Determine the local day and time
+ !*********************************
+
+ xlonav=xlon0+(xpoint2(i)+xpoint1(i))/2.*dx ! longitude needed to determine local time
+ if (xlonav.lt.-180.) xlonav=xlonav+360.
+ if (xlonav.gt.180.) xlonav=xlonav-360.
+ jullocal=jul+real(xlonav,kind=dp)/360._dp ! correct approximately for time zone to obtain local time
+
+ juldiff=jullocal-julmonday
+ nweeks=int(juldiff/7._dp)
+ juldiff=juldiff-real(nweeks,kind=dp)*7._dp
+ ndayofweek=int(juldiff)+1 ! this is the current day of week, starting with Monday
+ nhour=nint((juldiff-real(ndayofweek-1,kind=dp))*24._dp) ! this is the current hour
+ if (nhour.eq.0) then
+ nhour=24
+ ndayofweek=ndayofweek-1
+ if (ndayofweek.eq.0) ndayofweek=7
+ endif
+
+ ! Calculate a species- and time-dependent correction factor, distinguishing between
+ ! area (those with release starting at surface) and point (release starting above surface) sources
+ ! Also, calculate an average time correction factor (species independent)
+ !*****************************************************************************
+ average_timecorrect=0.
+ do k=1,nspec
+ if (zpoint1(i).gt.0.5) then ! point source
+ timecorrect(k)=point_hour(k,nhour)*point_dow(k,ndayofweek)
+ else ! area source
+ timecorrect(k)=area_hour(k,nhour)*area_dow(k,ndayofweek)
+ endif
+ average_timecorrect=average_timecorrect+timecorrect(k)
+ end do
+ average_timecorrect=average_timecorrect/real(nspec)
+
+ ! Determine number of particles to be released this time; at start and at end of release,
+ ! only half the particles are released
+ !*****************************************************************************
+
+ if (ireleasestart(i).ne.ireleaseend(i)) then
+ rfraction=abs(real(npart(i))*real(lsynctime)/ &
+ real(ireleaseend(i)-ireleasestart(i)))
+ if ((itime.eq.ireleasestart(i)).or. &
+ (itime.eq.ireleaseend(i))) rfraction=rfraction/2.
+
+ ! Take the species-average time correction factor in order to scale the
+ ! number of particles released this time
+ !**********************************************************************
+ rfraction=rfraction*average_timecorrect
+
+ rfraction=rfraction+xmasssave(i) ! number to be released at this time
+ numrel=int(rfraction)
+ xmasssave(i)=rfraction-real(numrel)
+ else
+ numrel=npart(i)
+ endif
+
+ xaux=xpoint2(i)-xpoint1(i)
+ yaux=ypoint2(i)-ypoint1(i)
+ zaux=zpoint2(i)-zpoint1(i)
+ do j=1,numrel ! loop over particles to be released this time
+ do ipart=minpart,maxpart ! search for free storage space
+
+ ! If a free storage space is found, attribute everything to this array element
+ !*****************************************************************************
+
+ if (itra1(ipart).ne.itime) then
+
+ ! Particle coordinates are determined by using a random position within the release volume
+ !*****************************************************************************
+
+ ! Determine horizontal particle position
+ !***************************************
+
+ xtra1(ipart)=xpoint1(i)+ran1(idummy)*xaux
+ if (xglobal) then
+ if (xtra1(ipart).gt.real(nxmin1)) xtra1(ipart)= &
+ xtra1(ipart)-real(nxmin1)
+ if (xtra1(ipart).lt.0.) xtra1(ipart)= &
+ xtra1(ipart)+real(nxmin1)
+ endif
+ ytra1(ipart)=ypoint1(i)+ran1(idummy)*yaux
+
+ ! Assign mass to particle: Total mass divided by total number of particles.
+ ! Time variation has partly been taken into account already by a species-average
+ ! correction factor, by which the number of particles released this time has been
+ ! scaled. Adjust the mass per particle by the species-dependent time correction factor
+ ! divided by the species-average one
+ !*****************************************************************************
+ do k=1,nspec
+ xmass1(ipart,k)=xmass(i,k)/real(npart(i)) &
+ *timecorrect(k)/average_timecorrect
+ ! write (*,*) 'xmass1: ',xmass1(ipart,k),ipart,k
+ ! Assign certain properties to particle
+ !**************************************
+ end do
+ nclass(ipart)=min(int(ran1(idummy)*real(nclassunc))+1, &
+ nclassunc)
+ numparticlecount=numparticlecount+1
+ if (mquasilag.eq.0) then
+ npoint(ipart)=i
+ else
+ npoint(ipart)=numparticlecount
+ endif
+ idt(ipart)=mintime ! first time step
+ itra1(ipart)=itime
+ itramem(ipart)=itra1(ipart)
+ itrasplit(ipart)=itra1(ipart)+ldirect*itsplit
+
+
+ ! Determine vertical particle position
+ !*************************************
+
+ ztra1(ipart)=zpoint1(i)+ran1(idummy)*zaux
+
+ ! Interpolation of topography and density
+ !****************************************
+
+ ! Determine the nest we are in
+ !*****************************
+
+ ngrid=0
+ do k=numbnests,1,-1
+ if ((xtra1(ipart).gt.xln(k)+eps).and. &
+ (xtra1(ipart).lt.xrn(k)-eps).and. &
+ (ytra1(ipart).gt.yln(k)+eps).and. &
+ (ytra1(ipart).lt.yrn(k)-eps)) then
+ ngrid=k
+ goto 43
+ endif
+ end do
+43 continue
+
+ ! Determine (nested) grid coordinates and auxiliary parameters used for interpolation
+ !*****************************************************************************
+
+ if (ngrid.gt.0) then
+ xtn=(xtra1(ipart)-xln(ngrid))*xresoln(ngrid)
+ ytn=(ytra1(ipart)-yln(ngrid))*yresoln(ngrid)
+ ix=int(xtn)
+ jy=int(ytn)
+ ddy=ytn-real(jy)
+ ddx=xtn-real(ix)
+ else
+ ix=int(xtra1(ipart))
+ jy=int(ytra1(ipart))
+ ddy=ytra1(ipart)-real(jy)
+ ddx=xtra1(ipart)-real(ix)
+ endif
+ ixp=ix+1
+ jyp=jy+1
+ rddx=1.-ddx
+ rddy=1.-ddy
+ p1=rddx*rddy
+ p2=ddx*rddy
+ p3=rddx*ddy
+ p4=ddx*ddy
+
+ if (ngrid.gt.0) then
+ topo=p1*oron(ix ,jy ,ngrid) &
+ + p2*oron(ixp,jy ,ngrid) &
+ + p3*oron(ix ,jyp,ngrid) &
+ + p4*oron(ixp,jyp,ngrid)
+ else
+ topo=p1*oro(ix ,jy) &
+ + p2*oro(ixp,jy) &
+ + p3*oro(ix ,jyp) &
+ + p4*oro(ixp,jyp)
+ endif
+
+ ! If starting height is in pressure coordinates, retrieve pressure profile and convert zpart1 to meters
+ !*****************************************************************************
+ if (kindz(i).eq.3) then
+ presspart=ztra1(ipart)
+ do kz=1,nz
+ if (ngrid.gt.0) then
+ r=p1*rhon(ix ,jy ,kz,2,ngrid) &
+ +p2*rhon(ixp,jy ,kz,2,ngrid) &
+ +p3*rhon(ix ,jyp,kz,2,ngrid) &
+ +p4*rhon(ixp,jyp,kz,2,ngrid)
+ t=p1*ttn(ix ,jy ,kz,2,ngrid) &
+ +p2*ttn(ixp,jy ,kz,2,ngrid) &
+ +p3*ttn(ix ,jyp,kz,2,ngrid) &
+ +p4*ttn(ixp,jyp,kz,2,ngrid)
+ else
+ r=p1*rho(ix ,jy ,kz,2) &
+ +p2*rho(ixp,jy ,kz,2) &
+ +p3*rho(ix ,jyp,kz,2) &
+ +p4*rho(ixp,jyp,kz,2)
+ t=p1*tt(ix ,jy ,kz,2) &
+ +p2*tt(ixp,jy ,kz,2) &
+ +p3*tt(ix ,jyp,kz,2) &
+ +p4*tt(ixp,jyp,kz,2)
+ endif
+ press=r*r_air*t/100.
+ if (kz.eq.1) pressold=press
+
+ if (press.lt.presspart) then
+ if (kz.eq.1) then
+ ztra1(ipart)=height(1)/2.
+ else
+ dz1=pressold-presspart
+ dz2=presspart-press
+ ztra1(ipart)=(height(kz-1)*dz2+height(kz)*dz1) &
+ /(dz1+dz2)
+ endif
+ goto 71
+ endif
+ pressold=press
+ end do
+71 continue
+ endif
+
+ ! If release positions are given in meters above sea level, subtract the
+ ! topography from the starting height
+ !***********************************************************************
+
+ if (kindz(i).eq.2) ztra1(ipart)=ztra1(ipart)-topo
+ if (ztra1(ipart).lt.eps2) ztra1(ipart)=eps2 ! Minimum starting height is eps2
+ if (ztra1(ipart).gt.height(nz)-0.5) ztra1(ipart)= &
+ height(nz)-0.5 ! Maximum starting height is uppermost level - 0.5 meters
+
+
+
+ ! For special simulations, multiply particle concentration air density;
+ ! Simply take the 2nd field in memory to do this (accurate enough)
+ !***********************************************************************
+ !AF IND_SOURCE switches between different units for concentrations at the source
+ !Af NOTE that in backward simulations the release of particles takes place at the
+ !Af receptor and the sampling at the source.
+ !Af 1="mass"
+ !Af 2="mass mixing ratio"
+ !Af IND_RECEPTOR switches between different units for concentrations at the receptor
+ !Af 1="mass"
+ !Af 2="mass mixing ratio"
+
+ !Af switches for the releasefile:
+ !Af IND_REL = 1 : xmass * rho
+ !Af IND_REL = 0 : xmass * 1
+
+ !Af ind_rel is defined in readcommand.f
+
+ if (ind_rel .eq. 1) then
+
+ ! Interpolate the air density
+ !****************************
+
+ do ii=2,nz
+ if (height(ii).gt.ztra1(ipart)) then
+ indz=ii-1
+ indzp=ii
+ goto 6
+ endif
+ end do
+6 continue
+
+ dz1=ztra1(ipart)-height(indz)
+ dz2=height(indzp)-ztra1(ipart)
+ dz=1./(dz1+dz2)
+
+ if (ngrid.gt.0) then
+ do n=1,2
+ rhoaux(n)=p1*rhon(ix ,jy ,indz+n-1,2,ngrid) &
+ +p2*rhon(ixp,jy ,indz+n-1,2,ngrid) &
+ +p3*rhon(ix ,jyp,indz+n-1,2,ngrid) &
+ +p4*rhon(ixp,jyp,indz+n-1,2,ngrid)
+ end do
+ else
+ do n=1,2
+ rhoaux(n)=p1*rho(ix ,jy ,indz+n-1,2) &
+ +p2*rho(ixp,jy ,indz+n-1,2) &
+ +p3*rho(ix ,jyp,indz+n-1,2) &
+ +p4*rho(ixp,jyp,indz+n-1,2)
+ end do
+ endif
+ rhoout=(dz2*rhoaux(1)+dz1*rhoaux(2))*dz
+ rho_rel(i)=rhoout
+
+
+ ! Multiply "mass" (i.e., mass mixing ratio in forward runs) with density
+ !********************************************************************
+
+ do k=1,nspec
+ xmass1(ipart,k)=xmass1(ipart,k)*rhoout
+ end do
+ endif
+
+
+ numpart=max(numpart,ipart)
+ goto 34 ! Storage space has been found, stop searching
+ endif
+ end do
+ if (ipart.gt.maxpart) goto 996
+
+34 minpart=ipart+1
+ end do
+ endif
+ end do
+
+
+ return
+
+996 continue
+ write(*,*) '#####################################################'
+ write(*,*) '#### FLEXPART MODEL SUBROUTINE RELEASEPARTICLES: ####'
+ write(*,*) '#### ####'
+ write(*,*) '#### ERROR - TOTAL NUMBER OF PARTICLES REQUIRED ####'
+ write(*,*) '#### EXCEEDS THE MAXIMUM ALLOWED NUMBER. REDUCE ####'
+ write(*,*) '#### EITHER NUMBER OF PARTICLES PER RELEASE POINT####'
+ write(*,*) '#### OR REDUCE NUMBER OF RELEASE POINTS. ####'
+ write(*,*) '#####################################################'
+ stop
+
+end subroutine releaseparticles
diff --git a/src/richardson.f90 b/src/richardson.f90
new file mode 100644
index 0000000000000000000000000000000000000000..da4fcf56de4866e85ccd5c48e7bbc7792b6c0ae2
--- /dev/null
+++ b/src/richardson.f90
@@ -0,0 +1,182 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine richardson(psurf,ust,ttlev,qvlev,ulev,vlev,nuvz, &
+ akz,bkz,hf,tt2,td2,h,wst,hmixplus)
+ ! i i i i i i i
+ ! i i i i i o o o
+ !****************************************************************************
+ ! *
+ ! Calculation of mixing height based on the critical Richardson number. *
+ ! Calculation of convective time scale. *
+ ! For unstable conditions, one iteration is performed. An excess *
+ ! temperature (dependent on hf and wst) is calculated, added to the *
+ ! temperature at the lowest model level. Then the procedure is repeated.*
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 22 August 1996 *
+ ! *
+ ! Literature: *
+ ! Vogelezang DHP and Holtslag AAM (1996): Evaluation and model impacts *
+ ! of alternative boundary-layer height formulations. Boundary-Layer *
+ ! Meteor. 81, 245-269. *
+ ! *
+ ! Update: 1999-02-01 by G. Wotawa *
+ ! *
+ ! Two meter level (temperature, humidity) is taken as reference level *
+ ! instead of first model level. *
+ ! New input variables tt2, td2 introduced. *
+ ! *
+ !****************************************************************************
+ ! *
+ ! Variables: *
+ ! h mixing height [m] *
+ ! hf sensible heat flux *
+ ! psurf surface pressure at point (xt,yt) [Pa] *
+ ! tv virtual temperature *
+ ! wst convective velocity scale *
+ ! *
+ ! Constants: *
+ ! ric critical Richardson number *
+ ! *
+ !****************************************************************************
+
+ use par_mod
+
+ implicit none
+
+ integer :: i,k,nuvz,iter
+ real :: tv,tvold,zref,z,zold,pint,pold,theta,thetaref,ri
+ real :: akz(nuvz),bkz(nuvz),ulev(nuvz),vlev(nuvz),hf,wst,tt2,td2,ew
+ real :: psurf,ust,ttlev(nuvz),qvlev(nuvz),h,excess
+ real :: thetaold,zl,ul,vl,thetal,ril,hmixplus,wspeed,bvfsq,bvf
+ real :: f_qvsat,rh,rhold,rhl,theta1,theta2,zl1,zl2,thetam
+ real,parameter :: const=r_air/ga, ric=0.25, b=100., bs=8.5
+ integer,parameter :: itmax=3
+
+ excess=0.0
+ iter=0
+
+ ! Compute virtual temperature and virtual potential temperature at
+ ! reference level (2 m)
+ !*****************************************************************
+
+30 iter=iter+1
+
+ pold=psurf
+ tvold=tt2*(1.+0.378*ew(td2)/psurf)
+ zold=2.0
+ zref=zold
+ rhold=ew(td2)/ew(tt2)
+
+ thetaref=tvold*(100000./pold)**(r_air/cpa)+excess
+ thetaold=thetaref
+
+
+ ! Integrate z up to one level above zt
+ !*************************************
+
+ do k=2,nuvz
+ pint=akz(k)+bkz(k)*psurf ! pressure on model layers
+ tv=ttlev(k)*(1.+0.608*qvlev(k))
+
+ if (abs(tv-tvold).gt.0.2) then
+ z=zold+const*log(pold/pint)*(tv-tvold)/log(tv/tvold)
+ else
+ z=zold+const*log(pold/pint)*tv
+ endif
+
+ theta=tv*(100000./pint)**(r_air/cpa)
+ ! Petra
+ rh = qvlev(k) / f_qvsat( pint, ttlev(k) )
+
+
+ !alculate Richardson number at each level
+ !****************************************
+
+ ri=ga/thetaref*(theta-thetaref)*(z-zref)/ &
+ max(((ulev(k)-ulev(2))**2+(vlev(k)-vlev(2))**2+b*ust**2),0.1)
+
+ ! addition of second condition: MH should not be placed in an
+ ! unstable layer (PS / Feb 2000)
+ if (ri.gt.ric .and. thetaold.lt.theta) goto 20
+
+ tvold=tv
+ pold=pint
+ rhold=rh
+ thetaold=theta
+ zold=z
+ end do
+
+20 continue
+
+ ! Determine Richardson number between the critical levels
+ !********************************************************
+
+ zl1=zold
+ theta1=thetaold
+ do i=1,20
+ zl=zold+real(i)/20.*(z-zold)
+ ul=ulev(k-1)+real(i)/20.*(ulev(k)-ulev(k-1))
+ vl=vlev(k-1)+real(i)/20.*(vlev(k)-vlev(k-1))
+ thetal=thetaold+real(i)/20.*(theta-thetaold)
+ rhl=rhold+real(i)/20.*(rh-rhold)
+ ril=ga/thetaref*(thetal-thetaref)*(zl-zref)/ &
+ max(((ul-ulev(2))**2+(vl-vlev(2))**2+b*ust**2),0.1)
+ zl2=zl
+ theta2=thetal
+ if (ril.gt.ric) goto 25
+ zl1=zl
+ theta1=thetal
+ end do
+
+25 continue
+ h=zl
+ thetam=0.5*(theta1+theta2)
+ wspeed=sqrt(ul**2+vl**2) ! Wind speed at z=hmix
+ bvfsq=(ga/thetam)*(theta2-theta1)/(zl2-zl1) ! Brunt-Vaisala frequency
+ ! at z=hmix
+
+ ! Under stable conditions, limit the maximum effect of the subgrid-scale topography
+ ! by the maximum lifting possible from the available kinetic energy
+ !*****************************************************************************
+
+ if(bvfsq.le.0.) then
+ hmixplus=9999.
+ else
+ bvf=sqrt(bvfsq)
+ hmixplus=wspeed/bvf*convke
+ endif
+
+
+ ! Calculate convective velocity scale
+ !************************************
+
+ if (hf.lt.0.) then
+ wst=(-h*ga/thetaref*hf/cpa)**0.333
+ excess=-bs*hf/cpa/wst
+ if (iter.lt.itmax) goto 30
+ else
+ wst=0.
+ endif
+
+end subroutine richardson
diff --git a/src/richardson_gfs.f90 b/src/richardson_gfs.f90
new file mode 100644
index 0000000000000000000000000000000000000000..6c67d224f062bb261f51725561b0740e777619ea
--- /dev/null
+++ b/src/richardson_gfs.f90
@@ -0,0 +1,196 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine richardson(psurf,ust,ttlev,qvlev,ulev,vlev,nuvz, &
+ akz,bkz,hf,tt2,td2,h,wst,hmixplus)
+ ! i i i i i i i
+ ! i i i i i o o o
+ !****************************************************************************
+ ! *
+ ! Calculation of mixing height based on the critical Richardson number. *
+ ! Calculation of convective time scale. *
+ ! For unstable conditions, one iteration is performed. An excess *
+ ! temperature (dependent on hf and wst) is calculated, added to the *
+ ! temperature at the lowest model level. Then the procedure is repeated.*
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 22 August 1996 *
+ ! *
+ ! Literature: *
+ ! Vogelezang DHP and Holtslag AAM (1996): Evaluation and model impacts *
+ ! of alternative boundary-layer height formulations. Boundary-Layer *
+ ! Meteor. 81, 245-269. *
+ ! *
+ ! Update: 1999-02-01 by G. Wotawa *
+ ! CHANGE: 17/11/2005 Caroline Forster NCEP GFS version *
+ ! *
+ ! Two meter level (temperature, humidity) is taken as reference level *
+ ! instead of first model level. *
+ ! New input variables tt2, td2 introduced. *
+ ! *
+ !****************************************************************************
+ ! *
+ ! Variables: *
+ ! h mixing height [m] *
+ ! hf sensible heat flux *
+ ! psurf surface pressure at point (xt,yt) [Pa] *
+ ! tv virtual temperature *
+ ! wst convective velocity scale *
+ ! *
+ ! Constants: *
+ ! ric critical Richardson number *
+ ! *
+ !****************************************************************************
+
+ use par_mod
+
+ implicit none
+
+ integer :: i,k,nuvz,iter,llev
+ real :: tv,tvold,zref,z,zold,pint,pold,theta,thetaref,ri
+ real :: akz(nuvz),bkz(nuvz),ulev(nuvz),vlev(nuvz),hf,wst,tt2,td2,ew
+ real :: psurf,ust,ttlev(nuvz),qvlev(nuvz),h,excess
+ real :: thetaold,zl,ul,vl,thetal,ril,hmixplus,wspeed,bvfsq,bvf
+ real :: f_qvsat,rh,rhold,rhl,theta1,theta2,zl1,zl2,thetam
+ real,parameter :: const=r_air/ga, ric=0.25, b=100., bs=8.5
+ integer,parameter :: itmax=3
+
+ excess=0.0
+ iter=0
+
+ ! NCEP version: find first model level above ground
+ !**************************************************
+
+ llev = 0
+ do i=1,nuvz
+ if (psurf.lt.akz(i)) llev=i
+ end do
+ llev = llev+1
+ ! sec llev should not be 1!
+ if (llev.eq.1) llev = 2
+ if (llev.gt.nuvz) llev = nuvz-1
+ ! NCEP version
+
+
+ ! Compute virtual temperature and virtual potential temperature at
+ ! reference level (2 m)
+ !*****************************************************************
+
+30 iter=iter+1
+
+ pold=psurf
+ tvold=tt2*(1.+0.378*ew(td2)/psurf)
+ zold=2.0
+ zref=zold
+ rhold=ew(td2)/ew(tt2)
+
+ thetaref=tvold*(100000./pold)**(r_air/cpa)+excess
+ thetaold=thetaref
+
+ ! Integrate z up to one level above zt
+ !*************************************
+
+ do k=llev,nuvz
+ pint=akz(k)+bkz(k)*psurf ! pressure on model layers
+ tv=ttlev(k)*(1.+0.608*qvlev(k))
+
+ if (abs(tv-tvold).gt.0.2) then
+ z=zold+const*log(pold/pint)*(tv-tvold)/log(tv/tvold)
+ else
+ z=zold+const*log(pold/pint)*tv
+ endif
+
+ theta=tv*(100000./pint)**(r_air/cpa)
+ ! Petra
+ rh = qvlev(k) / f_qvsat( pint, ttlev(k) )
+
+
+ !alculate Richardson number at each level
+ !****************************************
+
+ ri=ga/thetaref*(theta-thetaref)*(z-zref)/ &
+ max(((ulev(k)-ulev(2))**2+(vlev(k)-vlev(2))**2+b*ust**2),0.1)
+
+ ! addition of second condition: MH should not be placed in an
+ ! unstable layer (PS / Feb 2000)
+ if (ri.gt.ric .and. thetaold.lt.theta) goto 20
+
+ tvold=tv
+ pold=pint
+ rhold=rh
+ thetaold=theta
+ zold=z
+ end do
+
+20 continue
+
+ ! Determine Richardson number between the critical levels
+ !********************************************************
+
+ zl1=zold
+ theta1=thetaold
+ do i=1,20
+ zl=zold+real(i)/20.*(z-zold)
+ ul=ulev(k-1)+real(i)/20.*(ulev(k)-ulev(k-1))
+ vl=vlev(k-1)+real(i)/20.*(vlev(k)-vlev(k-1))
+ thetal=thetaold+real(i)/20.*(theta-thetaold)
+ rhl=rhold+real(i)/20.*(rh-rhold)
+ ril=ga/thetaref*(thetal-thetaref)*(zl-zref)/ &
+ max(((ul-ulev(2))**2+(vl-vlev(2))**2+b*ust**2),0.1)
+ zl2=zl
+ theta2=thetal
+ if (ril.gt.ric) goto 25
+ zl1=zl
+ theta1=thetal
+ end do
+
+25 continue
+ h=zl
+ thetam=0.5*(theta1+theta2)
+ wspeed=sqrt(ul**2+vl**2) ! Wind speed at z=hmix
+ bvfsq=(ga/thetam)*(theta2-theta1)/(zl2-zl1) ! Brunt-Vaisala frequency
+ ! at z=hmix
+
+ ! Under stable conditions, limit the maximum effect of the subgrid-scale topography
+ ! by the maximum lifting possible from the available kinetic energy
+ !*****************************************************************************
+
+ if(bvfsq.le.0.) then
+ hmixplus=9999.
+ else
+ bvf=sqrt(bvfsq)
+ hmixplus=wspeed/bvf*convke
+ endif
+
+
+ ! Calculate convective velocity scale
+ !************************************
+
+ if (hf.lt.0.) then
+ wst=(-h*ga/thetaref*hf/cpa)**0.333
+ excess=-bs*hf/cpa/wst
+ if (iter.lt.itmax) goto 30
+ else
+ wst=0.
+ endif
+
+end subroutine richardson
diff --git a/src/scalev.f90 b/src/scalev.f90
new file mode 100644
index 0000000000000000000000000000000000000000..1249d8f5fcf8e601be7837014cc3e713d846559a
--- /dev/null
+++ b/src/scalev.f90
@@ -0,0 +1,57 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+real function scalev(ps,t,td,stress)
+
+ !********************************************************************
+ ! *
+ ! Author: G. WOTAWA *
+ ! Date: 1994-06-27 *
+ ! Update: 1996-05-21 A. Stohl *
+ ! *
+ !********************************************************************
+ ! *
+ ! This Programm calculates scale velocity ustar from surface *
+ ! stress and air density. *
+ ! *
+ !********************************************************************
+ ! *
+ ! INPUT: *
+ ! *
+ ! ps surface pressure [Pa] *
+ ! t surface temperature [K] *
+ ! td surface dew point [K] *
+ ! stress surface stress [N/m2] *
+ ! *
+ !********************************************************************
+
+ use par_mod
+
+ implicit none
+
+ real :: ps,t,td,e,ew,tv,rhoa,stress
+
+ e=ew(td) ! vapor pressure
+ tv=t*(1.+0.378*e/ps) ! virtual temperature
+ rhoa=ps/(r_air*tv) ! air density
+ scalev=sqrt(abs(stress)/rhoa)
+
+end function scalev
diff --git a/src/shift_field.f90 b/src/shift_field.f90
new file mode 100644
index 0000000000000000000000000000000000000000..aceb9e49bd7ecbfea44ddd5df17b68bbb2c08dde
--- /dev/null
+++ b/src/shift_field.f90
@@ -0,0 +1,79 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine shift_field(field,nxf,nyf,nzfmax,nzf,nmax,n)
+ ! i/o i i i i i i
+ !*****************************************************************************
+ ! *
+ ! This subroutine shifts global fields by nxshift grid cells, in order to *
+ ! facilitate all sorts of nested wind fields, or output grids, which, *
+ ! without shifting, would overlap with the domain "boundary". *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 3 July 2002 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! Constants: *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+
+ implicit none
+
+ integer :: nxf,nyf,nzf,n,ix,jy,kz,ixs,nzfmax,nmax
+ real :: field(0:nxmax-1,0:nymax-1,nzfmax,nmax),xshiftaux(0:nxmax-1)
+
+ ! Loop over y and z
+ !******************
+
+ do kz=1,nzf
+ do jy=0,nyf-1
+
+ ! Shift the data
+ !***************
+
+ if (nxshift.ne.0) then
+ do ix=0,nxf-1
+ if (ix.ge.nxshift) then
+ ixs=ix-nxshift
+ else
+ ixs=nxf-nxshift+ix
+ endif
+ xshiftaux(ixs)=field(ix,jy,kz,n)
+ end do
+ do ix=0,nxf-1
+ field(ix,jy,kz,n)=xshiftaux(ix)
+ end do
+ endif
+
+ ! Repeat the westernmost grid cells at the easternmost domain "boundary"
+ !***********************************************************************
+
+ field(nxf,jy,kz,n)=field(0,jy,kz,n)
+ end do
+ end do
+
+end subroutine shift_field
diff --git a/src/shift_field_0.f90 b/src/shift_field_0.f90
new file mode 100644
index 0000000000000000000000000000000000000000..690753c8ff468b163901b062ed5c1c0d95441009
--- /dev/null
+++ b/src/shift_field_0.f90
@@ -0,0 +1,78 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine shift_field_0(field,nxf,nyf)
+ ! i/o i i
+ !*****************************************************************************
+ ! *
+ ! This subroutine shifts global fields by nxshift grid cells, in order to *
+ ! facilitate all sorts of nested wind fields, or output grids, which, *
+ ! without shifting, would overlap with the domain "boundary". *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 3 July 2002 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! Constants: *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+
+ implicit none
+
+ integer :: nxf,nyf,ix,jy,ixs
+ real :: field(0:nxmax-1,0:nymax-1),xshiftaux(0:nxmax-1)
+
+ ! Loop over y and z
+ !******************
+
+ do jy=0,nyf-1
+
+ ! Shift the data
+ !***************
+
+ if (nxshift.ne.0) then
+ do ix=0,nxf-1
+ if (ix.ge.nxshift) then
+ ixs=ix-nxshift
+ else
+ ixs=nxf-nxshift+ix
+ endif
+ xshiftaux(ixs)=field(ix,jy)
+ end do
+ do ix=0,nxf-1
+ field(ix,jy)=xshiftaux(ix)
+ end do
+ endif
+
+ ! Repeat the westernmost grid cells at the easternmost domain "boundary"
+ !***********************************************************************
+
+ field(nxf,jy)=field(0,jy)
+ end do
+
+ return
+end subroutine shift_field_0
diff --git a/src/skplin.f90 b/src/skplin.f90
new file mode 100644
index 0000000000000000000000000000000000000000..2db7b8f4f94f8971330509429df29ae46555051f
--- /dev/null
+++ b/src/skplin.f90
@@ -0,0 +1,49 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine skplin(nlines,iunit)
+ ! i i
+ !*****************************************************************************
+ ! *
+ ! This routine reads nlines from unit iunit and discards them *
+ ! *
+ ! Authors: Petra Seibert *
+ ! *
+ ! 31 Dec 1998 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! iunit unit number from which lines are to be skipped *
+ ! nlines number of lines to be skipped *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ integer :: i,iunit, nlines
+
+ do i=1,nlines
+ read(iunit,*)
+ end do
+
+end subroutine skplin
diff --git a/src/sort2.f90 b/src/sort2.f90
new file mode 100644
index 0000000000000000000000000000000000000000..ecd6df31a6243de1c034689c53d89db59d0641a6
--- /dev/null
+++ b/src/sort2.f90
@@ -0,0 +1,125 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+! From numerical recipes
+! Change by A. Stohl: Use of integer instead of real values
+
+subroutine sort2(n,arr,brr)
+
+ implicit none
+
+ integer :: n
+ integer :: arr(n),brr(n)
+ integer,parameter :: m=7,nstack=50
+ integer :: i,ir,j,jstack,k,l,istack(nstack)
+ integer :: a,b,temp
+ jstack=0
+ l=1
+ ir=n
+1 if(ir-l.lt.m)then
+ do j=l+1,ir
+ a=arr(j)
+ b=brr(j)
+ do i=j-1,1,-1
+ if(arr(i).le.a)goto 2
+ arr(i+1)=arr(i)
+ brr(i+1)=brr(i)
+ end do
+ i=0
+2 arr(i+1)=a
+ brr(i+1)=b
+ end do
+ if(jstack.eq.0)return
+ ir=istack(jstack)
+ l=istack(jstack-1)
+ jstack=jstack-2
+ else
+ k=(l+ir)/2
+ temp=arr(k)
+ arr(k)=arr(l+1)
+ arr(l+1)=temp
+ temp=brr(k)
+ brr(k)=brr(l+1)
+ brr(l+1)=temp
+ if(arr(l+1).gt.arr(ir))then
+ temp=arr(l+1)
+ arr(l+1)=arr(ir)
+ arr(ir)=temp
+ temp=brr(l+1)
+ brr(l+1)=brr(ir)
+ brr(ir)=temp
+ endif
+ if(arr(l).gt.arr(ir))then
+ temp=arr(l)
+ arr(l)=arr(ir)
+ arr(ir)=temp
+ temp=brr(l)
+ brr(l)=brr(ir)
+ brr(ir)=temp
+ endif
+ if(arr(l+1).gt.arr(l))then
+ temp=arr(l+1)
+ arr(l+1)=arr(l)
+ arr(l)=temp
+ temp=brr(l+1)
+ brr(l+1)=brr(l)
+ brr(l)=temp
+ endif
+ i=l+1
+ j=ir
+ a=arr(l)
+ b=brr(l)
+3 continue
+ i=i+1
+ if(arr(i).lt.a)goto 3
+4 continue
+ j=j-1
+ if(arr(j).gt.a)goto 4
+ if(j.lt.i)goto 5
+ temp=arr(i)
+ arr(i)=arr(j)
+ arr(j)=temp
+ temp=brr(i)
+ brr(i)=brr(j)
+ brr(j)=temp
+ goto 3
+5 arr(l)=arr(j)
+ arr(j)=a
+ brr(l)=brr(j)
+ brr(j)=b
+ jstack=jstack+2
+ if(jstack.gt.nstack) then
+ print*, 'nstack too small in sort2'
+ stop
+ end if
+ if(ir-i+1.ge.j-l)then
+ istack(jstack)=ir
+ istack(jstack-1)=i
+ ir=j-1
+ else
+ istack(jstack)=j-1
+ istack(jstack-1)=l
+ l=i
+ endif
+ endif
+ goto 1
+end subroutine sort2
+! (C) Copr. 1986-92 Numerical Recipes Software us.
diff --git a/src/timemanager.f90 b/src/timemanager.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d34586b8ef9786c3ddbc47e513a469559a807ce8
--- /dev/null
+++ b/src/timemanager.f90
@@ -0,0 +1,606 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine timemanager
+
+ !*****************************************************************************
+ ! *
+ ! Handles the computation of trajectories, i.e. determines which *
+ ! trajectories have to be computed at what time. *
+ ! Manages dry+wet deposition routines, radioactive decay and the computation *
+ ! of concentrations. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 20 May 1996 *
+ ! *
+ !*****************************************************************************
+ ! Changes, Bernd C. Krueger, Feb. 2001: *
+ ! Call of convmix when new windfield is read *
+ !------------------------------------ *
+ ! Changes Petra Seibert, Sept 2002 *
+ ! fix wet scavenging problem *
+ ! Code may not be correct for decay of deposition! *
+ ! Changes Petra Seibert, Nov 2002 *
+ ! call convection BEFORE new fields are read in BWD mode *
+ ! Changes Caroline Forster, Feb 2005 *
+ !new interface between flexpart and convection scheme *
+ !Emanuel's latest subroutine convect43c.f is used *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! DEP .true. if either wet or dry deposition is switched on *
+ ! decay(maxspec) [1/s] decay constant for radioactive decay *
+ ! DRYDEP .true. if dry deposition is switched on *
+ ! ideltas [s] modelling period *
+ ! itime [s] actual temporal position of calculation *
+ ! ldeltat [s] time since computation of radioact. decay of depositions*
+ ! loutaver [s] averaging period for concentration calculations *
+ ! loutend [s] end of averaging for concentration calculations *
+ ! loutnext [s] next time at which output fields shall be centered *
+ ! loutsample [s] sampling interval for averaging of concentrations *
+ ! loutstart [s] start of averaging for concentration calculations *
+ ! loutstep [s] time interval for which concentrations shall be *
+ ! calculated *
+ ! npoint(maxpart) index, which starting point the trajectory has *
+ ! starting positions of trajectories *
+ ! nstop serves as indicator for fate of particles *
+ ! in the particle loop *
+ ! nstop1 serves as indicator for wind fields (see getfields) *
+ ! outnum number of samples for each concentration calculation *
+ ! outnum number of samples for each concentration calculation *
+ ! prob probability of absorption at ground due to dry *
+ ! deposition *
+ ! WETDEP .true. if wet deposition is switched on *
+ ! weight weight for each concentration sample (1/2 or 1) *
+ ! uap(maxpart),ucp(maxpart),uzp(maxpart) = random velocities due to *
+ ! turbulence *
+ ! us(maxpart),vs(maxpart),ws(maxpart) = random velocities due to inter- *
+ ! polation *
+ ! xtra1(maxpart), ytra1(maxpart), ztra1(maxpart) = *
+ ! spatial positions of trajectories *
+ ! *
+ ! Constants: *
+ ! maxpart maximum number of trajectories *
+ ! *
+ !*****************************************************************************
+
+ use unc_mod
+ use point_mod
+ use xmass_mod
+ use flux_mod
+ use outg_mod
+ use oh_mod
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: j,ks,kp,l,n,itime,nstop,nstop1
+! integer :: ksp
+ integer :: loutnext,loutstart,loutend
+ integer :: ix,jy,ldeltat,itage,nage
+ real :: outnum,weight,prob(maxspec)
+ real :: uap(maxpart),ucp(maxpart),uzp(maxpart),decfact
+ real :: us(maxpart),vs(maxpart),ws(maxpart)
+ integer(kind=2) :: cbt(maxpart)
+ real :: drydeposit(maxspec),gridtotalunc,wetgridtotalunc
+ real :: drygridtotalunc,xold,yold,zold,xmassfract
+ !double precision xm(maxspec,maxpointspec_act),
+ ! + xm_depw(maxspec,maxpointspec_act),
+ ! + xm_depd(maxspec,maxpointspec_act)
+
+
+ !open(88,file='TEST.dat')
+
+ ! First output for time 0
+ !************************
+
+ loutnext=loutstep/2
+ outnum=0.
+ loutstart=loutnext-loutaver/2
+ loutend=loutnext+loutaver/2
+
+ ! open(127,file=path(2)(1:length(2))//'depostat.dat'
+ ! + ,form='unformatted')
+ !write (*,*) 'writing deposition statistics depostat.dat!'
+
+ !**********************************************************************
+ ! Loop over the whole modelling period in time steps of mintime seconds
+ !**********************************************************************
+
+
+ if (verbosity.gt.0) then
+ write (*,*) 'timemanager> starting simulation'
+ if (verbosity.gt.1) then
+ CALL SYSTEM_CLOCK(count_clock)
+ WRITE(*,*) 'timemanager> SYSTEM CLOCK',(count_clock - count_clock0)/real(count_rate)
+ endif
+ endif
+
+ do itime=0,ideltas,lsynctime
+
+
+ ! Computation of wet deposition, OH reaction and mass transfer
+ ! between two species every lsynctime seconds
+ ! maybe wet depo frequency can be relaxed later but better be on safe side
+ ! wetdepo must be called BEFORE new fields are read in but should not
+ ! be called in the very beginning before any fields are loaded, or
+ ! before particles are in the system
+ ! Code may not be correct for decay of deposition
+ ! changed by Petra Seibert 9/02
+ !********************************************************************
+
+ if (WETDEP .and. itime .ne. 0 .and. numpart .gt. 0) then
+ if (verbosity.gt.0) then
+ write (*,*) 'timemanager> call wetdepo'
+ endif
+ call wetdepo(itime,lsynctime,loutnext)
+ endif
+
+ if (OHREA .and. itime .ne. 0 .and. numpart .gt. 0) &
+ call ohreaction(itime,lsynctime,loutnext)
+
+ if (ASSSPEC .and. itime .ne. 0 .and. numpart .gt. 0) then
+ stop 'associated species not yet implemented!'
+ ! call transferspec(itime,lsynctime,loutnext)
+ endif
+
+ ! compute convection for backward runs
+ !*************************************
+
+ if ((ldirect.eq.-1).and.(lconvection.eq.1).and.(itime.lt.0)) then
+ if (verbosity.gt.0) then
+ write (*,*) 'timemanager> call convmix -- backward'
+ endif
+ call convmix(itime)
+ if (verbosity.gt.1) then
+ !CALL SYSTEM_CLOCK(count_clock, count_rate, count_max)
+ CALL SYSTEM_CLOCK(count_clock)
+ WRITE(*,*) 'timemanager> SYSTEM CLOCK',(count_clock - count_clock0)/real(count_rate)
+ endif
+ endif
+
+ ! Get necessary wind fields if not available
+ !*******************************************
+ if (verbosity.gt.0) then
+ write (*,*) 'timemanager> call getfields'
+ endif
+ call getfields(itime,nstop1)
+ if (verbosity.gt.1) then
+ CALL SYSTEM_CLOCK(count_clock)
+ WRITE(*,*) 'timemanager> SYSTEM CLOCK',(count_clock - count_clock0)/real(count_rate)
+ endif
+ if (nstop1.gt.1) stop 'NO METEO FIELDS AVAILABLE'
+
+ ! Release particles
+ !******************
+
+ if (verbosity.gt.0) then
+ write (*,*) 'timemanager> Release particles'
+ endif
+
+ if (mdomainfill.ge.1) then
+ if (itime.eq.0) then
+ if (verbosity.gt.0) then
+ write (*,*) 'timemanager> call init_domainfill'
+ endif
+ call init_domainfill
+ else
+ if (verbosity.gt.0) then
+ write (*,*) 'timemanager> call boundcond_domainfill'
+ endif
+ call boundcond_domainfill(itime,loutend)
+ endif
+ else
+ if (verbosity.gt.0) then
+ print*,'call releaseparticles'
+ endif
+ call releaseparticles(itime)
+ if (verbosity.gt.1) then
+ CALL SYSTEM_CLOCK(count_clock)
+ WRITE(*,*) 'timemanager> SYSTEM CLOCK',(count_clock - count_clock0)/real(count_rate)
+ endif
+ endif
+
+
+ ! Compute convective mixing for forward runs
+ ! for backward runs it is done before next windfield is read in
+ !**************************************************************
+
+ if ((ldirect.eq.1).and.(lconvection.eq.1)) then
+ if (verbosity.gt.0) then
+ write (*,*) 'timemanager> call convmix -- forward'
+ endif
+ call convmix(itime)
+ endif
+
+ ! If middle of averaging period of output fields is reached, accumulated
+ ! deposited mass radioactively decays
+ !***********************************************************************
+
+ if (DEP.and.(itime.eq.loutnext).and.(ldirect.gt.0)) then
+ do ks=1,nspec
+ do kp=1,maxpointspec_act
+ if (decay(ks).gt.0.) then
+ do nage=1,nageclass
+ do l=1,nclassunc
+ ! Mother output grid
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ wetgridunc(ix,jy,ks,kp,l,nage)= &
+ wetgridunc(ix,jy,ks,kp,l,nage)* &
+ exp(-1.*outstep*decay(ks))
+ drygridunc(ix,jy,ks,kp,l,nage)= &
+ drygridunc(ix,jy,ks,kp,l,nage)* &
+ exp(-1.*outstep*decay(ks))
+ end do
+ end do
+ ! Nested output grid
+ if (nested_output.eq.1) then
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ wetgriduncn(ix,jy,ks,kp,l,nage)= &
+ wetgriduncn(ix,jy,ks,kp,l,nage)* &
+ exp(-1.*outstep*decay(ks))
+ drygriduncn(ix,jy,ks,kp,l,nage)= &
+ drygriduncn(ix,jy,ks,kp,l,nage)* &
+ exp(-1.*outstep*decay(ks))
+ end do
+ end do
+ endif
+ end do
+ end do
+ endif
+ end do
+ end do
+ endif
+
+ !!! CHANGE: These lines may be switched on to check the conservation
+ !!! of mass within FLEXPART
+ ! if (itime.eq.loutnext) then
+ ! do 247 ksp=1, nspec
+ ! do 247 kp=1, maxpointspec_act
+ !47 xm(ksp,kp)=0.
+
+ ! do 249 ksp=1, nspec
+ ! do 249 j=1,numpart
+ ! if (ioutputforeachrelease.eq.1) then
+ ! kp=npoint(j)
+ ! else
+ ! kp=1
+ ! endif
+ ! if (itra1(j).eq.itime) then
+ ! xm(ksp,kp)=xm(ksp,kp)+xmass1(j,ksp)
+ ! write(*,*) 'xmass: ',xmass1(j,ksp),j,ksp,nspec
+ ! endif
+ !49 continue
+ ! do 248 ksp=1,nspec
+ ! do 248 kp=1,maxpointspec_act
+ ! xm_depw(ksp,kp)=0.
+ ! xm_depd(ksp,kp)=0.
+ ! do 248 nage=1,nageclass
+ ! do 248 ix=0,numxgrid-1
+ ! do 248 jy=0,numygrid-1
+ ! do 248 l=1,nclassunc
+ ! xm_depw(ksp,kp)=xm_depw(ksp,kp)
+ ! + +wetgridunc(ix,jy,ksp,kp,l,nage)
+ !48 xm_depd(ksp,kp)=xm_depd(ksp,kp)
+ ! + +drygridunc(ix,jy,ksp,kp,l,nage)
+ ! do 246 ksp=1,nspec
+ !46 write(88,'(2i10,3e12.3)')
+ ! + itime,ksp,(xm(ksp,kp),kp=1,maxpointspec_act),
+ ! + (xm_depw(ksp,kp),kp=1,maxpointspec_act),
+ ! + (xm_depd(ksp,kp),kp=1,maxpointspec_act)
+ ! endif
+ !!! CHANGE
+
+
+
+ ! Check whether concentrations are to be calculated
+ !**************************************************
+
+ if ((ldirect*itime.ge.ldirect*loutstart).and. &
+ (ldirect*itime.le.ldirect*loutend)) then ! add to grid
+ if (mod(itime-loutstart,loutsample).eq.0) then
+
+ ! If we are exactly at the start or end of the concentration averaging interval,
+ ! give only half the weight to this sample
+ !*****************************************************************************
+
+ if ((itime.eq.loutstart).or.(itime.eq.loutend)) then
+ weight=0.5
+ else
+ weight=1.0
+ endif
+ outnum=outnum+weight
+ call conccalc(itime,weight)
+ endif
+
+
+ if ((mquasilag.eq.1).and.(itime.eq.(loutstart+loutend)/2)) &
+ call partoutput_short(itime) ! dump particle positions in extremely compressed format
+
+
+ ! Output and reinitialization of grid
+ ! If necessary, first sample of new grid is also taken
+ !*****************************************************
+
+ if ((itime.eq.loutend).and.(outnum.gt.0.)) then
+ if ((iout.le.3.).or.(iout.eq.5)) then
+ if (surf_only.ne.1) then
+ call concoutput(itime,outnum,gridtotalunc, &
+ wetgridtotalunc,drygridtotalunc)
+ else
+ if (verbosity.eq.1) then
+ print*,'call concoutput_surf '
+ CALL SYSTEM_CLOCK(count_clock)
+ WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0
+ endif
+ call concoutput_surf(itime,outnum,gridtotalunc, &
+ wetgridtotalunc,drygridtotalunc)
+ if (verbosity.eq.1) then
+ print*,'called concoutput_surf '
+ CALL SYSTEM_CLOCK(count_clock)
+ WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0
+ endif
+ endif
+
+ if ((nested_output.eq.1).and.(surf_only.ne.1)) call concoutput_nest(itime,outnum)
+ if ((nested_output.eq.1).and.(surf_only.eq.1)) call concoutput_surf_nest(itime,outnum)
+ outnum=0.
+ endif
+ if ((iout.eq.4).or.(iout.eq.5)) call plumetraj(itime)
+ if (iflux.eq.1) call fluxoutput(itime)
+ write(*,45) itime,numpart,gridtotalunc,wetgridtotalunc, &
+ drygridtotalunc
+45 format(i9,' SECONDS SIMULATED: ',i8, &
+ ' PARTICLES: Uncertainty: ',3f7.3)
+ if (ipout.ge.1) call partoutput(itime) ! dump particle positions
+ loutnext=loutnext+loutstep
+ loutstart=loutnext-loutaver/2
+ loutend=loutnext+loutaver/2
+ if (itime.eq.loutstart) then
+ weight=0.5
+ outnum=outnum+weight
+ call conccalc(itime,weight)
+ endif
+
+
+ ! Check, whether particles are to be split:
+ ! If so, create new particles and attribute all information from the old
+ ! particles also to the new ones; old and new particles both get half the
+ ! mass of the old ones
+ !************************************************************************
+
+ if (ldirect*itime.ge.ldirect*itsplit) then
+ n=numpart
+ do j=1,numpart
+ if (ldirect*itime.ge.ldirect*itrasplit(j)) then
+ if (n.lt.maxpart) then
+ n=n+1
+ itrasplit(j)=2*(itrasplit(j)-itramem(j))+itramem(j)
+ itrasplit(n)=itrasplit(j)
+ itramem(n)=itramem(j)
+ itra1(n)=itra1(j)
+ idt(n)=idt(j)
+ npoint(n)=npoint(j)
+ nclass(n)=nclass(j)
+ xtra1(n)=xtra1(j)
+ ytra1(n)=ytra1(j)
+ ztra1(n)=ztra1(j)
+ uap(n)=uap(j)
+ ucp(n)=ucp(j)
+ uzp(n)=uzp(j)
+ us(n)=us(j)
+ vs(n)=vs(j)
+ ws(n)=ws(j)
+ cbt(n)=cbt(j)
+ do ks=1,nspec
+ xmass1(j,ks)=xmass1(j,ks)/2.
+ xmass1(n,ks)=xmass1(j,ks)
+ end do
+ endif
+ endif
+ end do
+ numpart=n
+ endif
+ endif
+ endif
+
+
+ if (itime.eq.ideltas) exit ! almost finished
+
+ ! Compute interval since radioactive decay of deposited mass was computed
+ !************************************************************************
+
+ if (itime.lt.loutnext) then
+ ldeltat=itime-(loutnext-loutstep)
+ else ! first half of next interval
+ ldeltat=itime-loutnext
+ endif
+
+
+ ! Loop over all particles
+ !************************
+
+ do j=1,numpart
+
+
+ ! If integration step is due, do it
+ !**********************************
+
+ if (itra1(j).eq.itime) then
+
+ if (ioutputforeachrelease.eq.1) then
+ kp=npoint(j)
+ else
+ kp=1
+ endif
+ ! Determine age class of the particle
+ itage=abs(itra1(j)-itramem(j))
+ do nage=1,nageclass
+ if (itage.lt.lage(nage)) exit
+ end do
+
+ ! Initialize newly released particle
+ !***********************************
+
+ if ((itramem(j).eq.itime).or.(itime.eq.0)) &
+ call initialize(itime,idt(j),uap(j),ucp(j),uzp(j), &
+ us(j),vs(j),ws(j),xtra1(j),ytra1(j),ztra1(j),cbt(j))
+
+ ! Memorize particle positions
+ !****************************
+
+ xold=xtra1(j)
+ yold=ytra1(j)
+ zold=ztra1(j)
+
+ ! Integrate Lagevin equation for lsynctime seconds
+ !*************************************************
+
+ call advance(itime,npoint(j),idt(j),uap(j),ucp(j),uzp(j), &
+ us(j),vs(j),ws(j),nstop,xtra1(j),ytra1(j),ztra1(j),prob, &
+ cbt(j))
+
+ ! Calculate the gross fluxes across layer interfaces
+ !***************************************************
+
+ if (iflux.eq.1) call calcfluxes(nage,j,xold,yold,zold)
+
+
+ ! Determine, when next time step is due
+ ! If trajectory is terminated, mark it
+ !**************************************
+
+ if (nstop.gt.1) then
+ if (linit_cond.ge.1) call initial_cond_calc(itime,j)
+ itra1(j)=-999999999
+ else
+ itra1(j)=itime+lsynctime
+
+
+ ! Dry deposition and radioactive decay for each species
+ ! Also check maximum (of all species) of initial mass remaining on the particle;
+ ! if it is below a threshold value, terminate particle
+ !*****************************************************************************
+
+ xmassfract=0.
+ do ks=1,nspec
+ if (decay(ks).gt.0.) then ! radioactive decay
+ decfact=exp(-real(abs(lsynctime))*decay(ks))
+ else
+ decfact=1.
+ endif
+
+ if (DRYDEPSPEC(ks)) then ! dry deposition
+ drydeposit(ks)=xmass1(j,ks)*prob(ks)*decfact
+ xmass1(j,ks)=xmass1(j,ks)*(1.-prob(ks))*decfact
+ if (decay(ks).gt.0.) then ! correct for decay (see wetdepo)
+ drydeposit(ks)=drydeposit(ks)* &
+ exp(real(abs(ldeltat))*decay(ks))
+ endif
+ else ! no dry deposition
+ xmass1(j,ks)=xmass1(j,ks)*decfact
+ endif
+
+
+ if (mdomainfill.eq.0) then
+ if (xmass(npoint(j),ks).gt.0.) &
+ xmassfract=max(xmassfract,real(npart(npoint(j)))* &
+ xmass1(j,ks)/xmass(npoint(j),ks))
+ else
+ xmassfract=1.
+ endif
+ end do
+
+ if (xmassfract.lt.0.0001) then ! terminate all particles carrying less mass
+ itra1(j)=-999999999
+ endif
+
+ ! Sabine Eckhardt, June 2008
+ ! don't create depofield for backward runs
+ if (DRYDEP.AND.(ldirect.eq.1)) then
+ call drydepokernel(nclass(j),drydeposit,real(xtra1(j)), &
+ real(ytra1(j)),nage,kp)
+ if (nested_output.eq.1) call drydepokernel_nest( &
+ nclass(j),drydeposit,real(xtra1(j)),real(ytra1(j)), &
+ nage,kp)
+ endif
+
+ ! Terminate trajectories that are older than maximum allowed age
+ !***************************************************************
+
+ if (abs(itra1(j)-itramem(j)).ge.lage(nageclass)) then
+ if (linit_cond.ge.1) &
+ call initial_cond_calc(itime+lsynctime,j)
+ itra1(j)=-999999999
+ endif
+ endif
+
+ endif
+
+ end do
+
+ end do
+
+
+ ! Complete the calculation of initial conditions for particles not yet terminated
+ !*****************************************************************************
+
+ do j=1,numpart
+ if (linit_cond.ge.1) call initial_cond_calc(itime,j)
+ end do
+
+ if (ipout.eq.2) call partoutput(itime) ! dump particle positions
+
+ if (linit_cond.ge.1) call initial_cond_output(itime) ! dump initial cond. field
+
+ close(104)
+
+ ! De-allocate memory and end
+ !***************************
+
+ if (iflux.eq.1) then
+ deallocate(flux)
+ endif
+ if (OHREA.eqv..TRUE.) then
+ deallocate(OH_field,OH_field_height)
+ endif
+ if (ldirect.gt.0) then
+ deallocate(drygridunc,wetgridunc)
+ endif
+ deallocate(gridunc)
+ deallocate(xpoint1,xpoint2,ypoint1,ypoint2,zpoint1,zpoint2,xmass)
+ deallocate(ireleasestart,ireleaseend,npart,kindz)
+ deallocate(xmasssave)
+ if (nested_output.eq.1) then
+ deallocate(orooutn, arean, volumen)
+ if (ldirect.gt.0) then
+ deallocate(griduncn,drygriduncn,wetgriduncn)
+ endif
+ endif
+ deallocate(outheight,outheighthalf)
+ deallocate(oroout, area, volume)
+
+end subroutine timemanager
+
diff --git a/src/unc_mod.f90 b/src/unc_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..3ba2de3b9ef64433c68703afccae45845e960d9a
--- /dev/null
+++ b/src/unc_mod.f90
@@ -0,0 +1,35 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+module unc_mod
+
+ implicit none
+
+ real,allocatable, dimension (:,:,:,:,:,:,:) :: gridunc
+ real,allocatable, dimension (:,:,:,:,:,:,:) :: griduncn
+ real,allocatable, dimension (:,:,:,:,:,:) :: drygridunc
+ real,allocatable, dimension (:,:,:,:,:,:) :: drygriduncn
+ real,allocatable, dimension (:,:,:,:,:,:) :: wetgridunc
+ real,allocatable, dimension (:,:,:,:,:,:) :: wetgriduncn
+
+ real,allocatable, dimension (:,:,:,:,:) :: init_cond
+
+end module unc_mod
diff --git a/src/verttransform.f90 b/src/verttransform.f90
new file mode 100644
index 0000000000000000000000000000000000000000..88fbe830850f4b19eb92a3babfa022fc65a849f7
--- /dev/null
+++ b/src/verttransform.f90
@@ -0,0 +1,685 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine verttransform(n,uuh,vvh,wwh,pvh)
+ ! i i i i i
+ !*****************************************************************************
+ ! *
+ ! This subroutine transforms temperature, dew point temperature and *
+ ! wind components from eta to meter coordinates. *
+ ! The vertical wind component is transformed from Pa/s to m/s using *
+ ! the conversion factor pinmconv. *
+ ! In addition, this routine calculates vertical density gradients *
+ ! needed for the parameterization of the turbulent velocities. *
+ ! *
+ ! Author: A. Stohl, G. Wotawa *
+ ! *
+ ! 12 August 1996 *
+ ! Update: 16 January 1998 *
+ ! *
+ ! Major update: 17 February 1999 *
+ ! by G. Wotawa *
+ ! *
+ ! - Vertical levels for u, v and w are put together *
+ ! - Slope correction for vertical velocity: Modification of calculation *
+ ! procedure *
+ ! *
+ !*****************************************************************************
+ ! Changes, Bernd C. Krueger, Feb. 2001:
+ ! Variables tth and qvh (on eta coordinates) from common block
+ !*****************************************************************************
+ ! Sabine Eckhardt, March 2007
+ ! added the variable cloud for use with scavenging - descr. in com_mod
+ ! Petra Seibert, 2011/2012: Fixing some deficiencies in this modification
+ ! note that also other subroutines are affected by the fix
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! nx,ny,nz field dimensions in x,y and z direction *
+ ! clouds(0:nxmax,0:nymax,0:nzmax,2) cloud field for wet deposition *
+ ! uu(0:nxmax,0:nymax,nzmax,2) wind components in x-direction [m/s] *
+ ! vv(0:nxmax,0:nymax,nzmax,2) wind components in y-direction [m/s] *
+ ! ww(0:nxmax,0:nymax,nzmax,2) wind components in z-direction [deltaeta/s]*
+ ! tt(0:nxmax,0:nymax,nzmax,2) temperature [K] *
+ ! pv(0:nxmax,0:nymax,nzmax,2) potential voriticity (pvu) *
+ ! ps(0:nxmax,0:nymax,2) surface pressure [Pa] *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+ use cmapf_mod, only: cc2gll
+
+ implicit none
+
+ integer :: ix,jy,kz,iz,n,kmin,kl,klp,ix1,jy1,ixp,jyp,ixm,jym
+ integer :: rain_cloud_above,kz_inv !SE
+ integer icloudtop !PS
+ real :: f_qvsat,pressure
+ !real :: rh,lsp,convp
+ real :: rh,lsp,convp,prec,rhmin
+ real :: uvzlev(nuvzmax),rhoh(nuvzmax),pinmconv(nzmax)
+ real :: ew,pint,tv,tvold,pold,dz1,dz2,dz,ui,vi
+ real :: xlon,ylat,xlonr,dzdx,dzdy
+ real :: dzdx1,dzdx2,dzdy1,dzdy2, precmin
+ real :: uuaux,vvaux,uupolaux,vvpolaux,ddpol,ffpol,wdummy
+ real :: uuh(0:nxmax-1,0:nymax-1,nuvzmax)
+ real :: vvh(0:nxmax-1,0:nymax-1,nuvzmax)
+ real :: pvh(0:nxmax-1,0:nymax-1,nuvzmax)
+ real :: wwh(0:nxmax-1,0:nymax-1,nwzmax)
+ real :: wzlev(nwzmax),uvwzlev(0:nxmax-1,0:nymax-1,nzmax)
+ logical lconvectprec
+ real,parameter :: const=r_air/ga
+ parameter (precmin = 0.002) ! minimum prec in mm/h for cloud diagnostics
+
+ logical :: init = .true.
+
+
+ !*************************************************************************
+ ! If verttransform is called the first time, initialize heights of the *
+ ! z levels in meter. The heights are the heights of model levels, where *
+ ! u,v,T and qv are given, and of the interfaces, where w is given. So, *
+ ! the vertical resolution in the z system is doubled. As reference point,*
+ ! the lower left corner of the grid is used. *
+ ! Unlike in the eta system, no difference between heights for u,v and *
+ ! heights for w exists. *
+ !*************************************************************************
+
+
+ ! do 897 kz=1,nuvz
+ ! write (*,*) 'akz: ',akz(kz),'bkz',bkz(kz)
+ !897 continue
+
+ if (init) then
+
+ ! Search for a point with high surface pressure (i.e. not above significant topography)
+ ! Then, use this point to construct a reference z profile, to be used at all times
+ !*****************************************************************************
+
+ do jy=0,nymin1
+ do ix=0,nxmin1
+ if (ps(ix,jy,1,n).gt.100000.) then
+ ixm=ix
+ jym=jy
+ goto 3
+ endif
+ end do
+ end do
+3 continue
+
+
+ tvold=tt2(ixm,jym,1,n)*(1.+0.378*ew(td2(ixm,jym,1,n))/ &
+ ps(ixm,jym,1,n))
+ pold=ps(ixm,jym,1,n)
+ height(1)=0.
+
+ do kz=2,nuvz
+ pint=akz(kz)+bkz(kz)*ps(ixm,jym,1,n)
+ tv=tth(ixm,jym,kz,n)*(1.+0.608*qvh(ixm,jym,kz,n))
+
+
+ ! NOTE: In FLEXPART versions up to 4.0, the number of model levels was doubled
+ ! upon the transformation to z levels. In order to save computer memory, this is
+ ! not done anymore in the standard version. However, this option can still be
+ ! switched on by replacing the following lines with those below, that are
+ ! currently commented out.
+ ! Note that two more changes are necessary in this subroutine below.
+ ! One change is also necessary in gridcheck.f, and another one in verttransform_nests.
+ !*****************************************************************************
+
+ if (abs(tv-tvold).gt.0.2) then
+ height(kz)= &
+ height(kz-1)+const*log(pold/pint)* &
+ (tv-tvold)/log(tv/tvold)
+ else
+ height(kz)=height(kz-1)+ &
+ const*log(pold/pint)*tv
+ endif
+
+ ! Switch on following lines to use doubled vertical resolution
+ !*************************************************************
+ ! if (abs(tv-tvold).gt.0.2) then
+ ! height((kz-1)*2)=
+ ! + height(max((kz-2)*2,1))+const*log(pold/pint)*
+ ! + (tv-tvold)/log(tv/tvold)
+ ! else
+ ! height((kz-1)*2)=height(max((kz-2)*2,1))+
+ ! + const*log(pold/pint)*tv
+ ! endif
+ ! End doubled vertical resolution
+
+ tvold=tv
+ pold=pint
+ end do
+
+
+ ! Switch on following lines to use doubled vertical resolution
+ !*************************************************************
+ ! do 7 kz=3,nz-1,2
+ ! height(kz)=0.5*(height(kz-1)+height(kz+1))
+ ! height(nz)=height(nz-1)+height(nz-1)-height(nz-2)
+ ! End doubled vertical resolution
+
+
+ ! Determine highest levels that can be within PBL
+ !************************************************
+
+ do kz=1,nz
+ if (height(kz).gt.hmixmax) then
+ nmixz=kz
+ goto 9
+ endif
+ end do
+9 continue
+
+ ! Do not repeat initialization of the Cartesian z grid
+ !*****************************************************
+
+ init=.false.
+
+ endif
+
+
+ ! Loop over the whole grid
+ !*************************
+
+ do jy=0,nymin1
+ do ix=0,nxmin1
+ tvold=tt2(ix,jy,1,n)*(1.+0.378*ew(td2(ix,jy,1,n))/ &
+ ps(ix,jy,1,n))
+ pold=ps(ix,jy,1,n)
+ uvzlev(1)=0.
+ wzlev(1)=0.
+ rhoh(1)=pold/(r_air*tvold)
+
+
+ ! Compute heights of eta levels
+ !******************************
+
+ do kz=2,nuvz
+ pint=akz(kz)+bkz(kz)*ps(ix,jy,1,n)
+ tv=tth(ix,jy,kz,n)*(1.+0.608*qvh(ix,jy,kz,n))
+ rhoh(kz)=pint/(r_air*tv)
+
+ if (abs(tv-tvold).gt.0.2) then
+ uvzlev(kz)=uvzlev(kz-1)+const*log(pold/pint)* &
+ (tv-tvold)/log(tv/tvold)
+ else
+ uvzlev(kz)=uvzlev(kz-1)+const*log(pold/pint)*tv
+ endif
+
+ tvold=tv
+ pold=pint
+ end do
+
+
+ do kz=2,nwz-1
+ wzlev(kz)=(uvzlev(kz+1)+uvzlev(kz))/2.
+ end do
+ wzlev(nwz)=wzlev(nwz-1)+ &
+ uvzlev(nuvz)-uvzlev(nuvz-1)
+
+ uvwzlev(ix,jy,1)=0.0
+ do kz=2,nuvz
+ uvwzlev(ix,jy,kz)=uvzlev(kz)
+ end do
+
+ ! Switch on following lines to use doubled vertical resolution
+ ! Switch off the three lines above.
+ !*************************************************************
+ !22 uvwzlev(ix,jy,(kz-1)*2)=uvzlev(kz)
+ ! do 23 kz=2,nwz
+ !23 uvwzlev(ix,jy,(kz-1)*2+1)=wzlev(kz)
+ ! End doubled vertical resolution
+
+ ! pinmconv=(h2-h1)/(p2-p1)
+
+ pinmconv(1)=(uvwzlev(ix,jy,2)-uvwzlev(ix,jy,1))/ &
+ ((aknew(2)+bknew(2)*ps(ix,jy,1,n))- &
+ (aknew(1)+bknew(1)*ps(ix,jy,1,n)))
+ do kz=2,nz-1
+ pinmconv(kz)=(uvwzlev(ix,jy,kz+1)-uvwzlev(ix,jy,kz-1))/ &
+ ((aknew(kz+1)+bknew(kz+1)*ps(ix,jy,1,n))- &
+ (aknew(kz-1)+bknew(kz-1)*ps(ix,jy,1,n)))
+ end do
+ pinmconv(nz)=(uvwzlev(ix,jy,nz)-uvwzlev(ix,jy,nz-1))/ &
+ ((aknew(nz)+bknew(nz)*ps(ix,jy,1,n))- &
+ (aknew(nz-1)+bknew(nz-1)*ps(ix,jy,1,n)))
+
+ ! Levels, where u,v,t and q are given
+ !************************************
+
+ uu(ix,jy,1,n)=uuh(ix,jy,1)
+ vv(ix,jy,1,n)=vvh(ix,jy,1)
+ tt(ix,jy,1,n)=tth(ix,jy,1,n)
+ qv(ix,jy,1,n)=qvh(ix,jy,1,n)
+ pv(ix,jy,1,n)=pvh(ix,jy,1)
+ rho(ix,jy,1,n)=rhoh(1)
+ uu(ix,jy,nz,n)=uuh(ix,jy,nuvz)
+ vv(ix,jy,nz,n)=vvh(ix,jy,nuvz)
+ tt(ix,jy,nz,n)=tth(ix,jy,nuvz,n)
+ qv(ix,jy,nz,n)=qvh(ix,jy,nuvz,n)
+ pv(ix,jy,nz,n)=pvh(ix,jy,nuvz)
+ rho(ix,jy,nz,n)=rhoh(nuvz)
+ kmin=2
+ do iz=2,nz-1
+ do kz=kmin,nuvz
+ if(height(iz).gt.uvzlev(nuvz)) then
+ uu(ix,jy,iz,n)=uu(ix,jy,nz,n)
+ vv(ix,jy,iz,n)=vv(ix,jy,nz,n)
+ tt(ix,jy,iz,n)=tt(ix,jy,nz,n)
+ qv(ix,jy,iz,n)=qv(ix,jy,nz,n)
+ pv(ix,jy,iz,n)=pv(ix,jy,nz,n)
+ rho(ix,jy,iz,n)=rho(ix,jy,nz,n)
+ goto 30
+ endif
+ if ((height(iz).gt.uvzlev(kz-1)).and. &
+ (height(iz).le.uvzlev(kz))) then
+ dz1=height(iz)-uvzlev(kz-1)
+ dz2=uvzlev(kz)-height(iz)
+ dz=dz1+dz2
+ uu(ix,jy,iz,n)=(uuh(ix,jy,kz-1)*dz2+uuh(ix,jy,kz)*dz1)/dz
+ vv(ix,jy,iz,n)=(vvh(ix,jy,kz-1)*dz2+vvh(ix,jy,kz)*dz1)/dz
+ tt(ix,jy,iz,n)=(tth(ix,jy,kz-1,n)*dz2 &
+ +tth(ix,jy,kz,n)*dz1)/dz
+ qv(ix,jy,iz,n)=(qvh(ix,jy,kz-1,n)*dz2 &
+ +qvh(ix,jy,kz,n)*dz1)/dz
+ pv(ix,jy,iz,n)=(pvh(ix,jy,kz-1)*dz2+pvh(ix,jy,kz)*dz1)/dz
+ rho(ix,jy,iz,n)=(rhoh(kz-1)*dz2+rhoh(kz)*dz1)/dz
+ kmin=kz
+ goto 30
+ endif
+ end do
+30 continue
+ end do
+
+
+ ! Levels, where w is given
+ !*************************
+
+ ww(ix,jy,1,n)=wwh(ix,jy,1)*pinmconv(1)
+ ww(ix,jy,nz,n)=wwh(ix,jy,nwz)*pinmconv(nz)
+ kmin=2
+ do iz=2,nz
+ do kz=kmin,nwz
+ if ((height(iz).gt.wzlev(kz-1)).and. &
+ (height(iz).le.wzlev(kz))) then
+ dz1=height(iz)-wzlev(kz-1)
+ dz2=wzlev(kz)-height(iz)
+ dz=dz1+dz2
+ ww(ix,jy,iz,n)=(wwh(ix,jy,kz-1)*pinmconv(kz-1)*dz2 &
+ +wwh(ix,jy,kz)*pinmconv(kz)*dz1)/dz
+ kmin=kz
+ goto 40
+ endif
+ end do
+40 continue
+ end do
+
+ ! Compute density gradients at intermediate levels
+ !*************************************************
+
+ drhodz(ix,jy,1,n)=(rho(ix,jy,2,n)-rho(ix,jy,1,n))/ &
+ (height(2)-height(1))
+ do kz=2,nz-1
+ drhodz(ix,jy,kz,n)=(rho(ix,jy,kz+1,n)-rho(ix,jy,kz-1,n))/ &
+ (height(kz+1)-height(kz-1))
+ end do
+ drhodz(ix,jy,nz,n)=drhodz(ix,jy,nz-1,n)
+
+ end do
+ end do
+
+
+ !****************************************************************
+ ! Compute slope of eta levels in windward direction and resulting
+ ! vertical wind correction
+ !****************************************************************
+
+ do jy=1,ny-2
+ do ix=1,nx-2
+
+ kmin=2
+ do iz=2,nz-1
+
+ ui=uu(ix,jy,iz,n)*dxconst/cos((real(jy)*dy+ylat0)*pi180)
+ vi=vv(ix,jy,iz,n)*dyconst
+
+ do kz=kmin,nz
+ if ((height(iz).gt.uvwzlev(ix,jy,kz-1)).and. &
+ (height(iz).le.uvwzlev(ix,jy,kz))) then
+ dz1=height(iz)-uvwzlev(ix,jy,kz-1)
+ dz2=uvwzlev(ix,jy,kz)-height(iz)
+ dz=dz1+dz2
+ kl=kz-1
+ klp=kz
+ kmin=kz
+ goto 47
+ endif
+ end do
+
+47 ix1=ix-1
+ jy1=jy-1
+ ixp=ix+1
+ jyp=jy+1
+
+ dzdx1=(uvwzlev(ixp,jy,kl)-uvwzlev(ix1,jy,kl))/2.
+ dzdx2=(uvwzlev(ixp,jy,klp)-uvwzlev(ix1,jy,klp))/2.
+ dzdx=(dzdx1*dz2+dzdx2*dz1)/dz
+
+ dzdy1=(uvwzlev(ix,jyp,kl)-uvwzlev(ix,jy1,kl))/2.
+ dzdy2=(uvwzlev(ix,jyp,klp)-uvwzlev(ix,jy1,klp))/2.
+ dzdy=(dzdy1*dz2+dzdy2*dz1)/dz
+
+ ww(ix,jy,iz,n)=ww(ix,jy,iz,n)+(dzdx*ui+dzdy*vi)
+
+ end do
+
+ end do
+ end do
+
+
+ ! If north pole is in the domain, calculate wind velocities in polar
+ ! stereographic coordinates
+ !*******************************************************************
+
+ if (nglobal) then
+ do jy=int(switchnorthg)-2,nymin1
+ ylat=ylat0+real(jy)*dy
+ do ix=0,nxmin1
+ xlon=xlon0+real(ix)*dx
+ do iz=1,nz
+ call cc2gll(northpolemap,ylat,xlon,uu(ix,jy,iz,n), &
+ vv(ix,jy,iz,n),uupol(ix,jy,iz,n), &
+ vvpol(ix,jy,iz,n))
+ end do
+ end do
+ end do
+
+
+ do iz=1,nz
+
+ ! CALCULATE FFPOL, DDPOL FOR CENTRAL GRID POINT
+ !
+ ! AMSnauffer Nov 18 2004 Added check for case vv=0
+ !
+ xlon=xlon0+real(nx/2-1)*dx
+ xlonr=xlon*pi/180.
+ ffpol=sqrt(uu(nx/2-1,nymin1,iz,n)**2+ &
+ vv(nx/2-1,nymin1,iz,n)**2)
+ if (vv(nx/2-1,nymin1,iz,n).lt.0.) then
+ ddpol=atan(uu(nx/2-1,nymin1,iz,n)/ &
+ vv(nx/2-1,nymin1,iz,n))-xlonr
+ else if (vv(nx/2-1,nymin1,iz,n).gt.0.) then
+ ddpol=pi+atan(uu(nx/2-1,nymin1,iz,n)/ &
+ vv(nx/2-1,nymin1,iz,n))-xlonr
+ else
+ ddpol=pi/2-xlonr
+ endif
+ if(ddpol.lt.0.) ddpol=2.0*pi+ddpol
+ if(ddpol.gt.2.0*pi) ddpol=ddpol-2.0*pi
+
+ ! CALCULATE U,V FOR 180 DEG, TRANSFORM TO POLAR STEREOGRAPHIC GRID
+ xlon=180.0
+ xlonr=xlon*pi/180.
+ ylat=90.0
+ uuaux=-ffpol*sin(xlonr+ddpol)
+ vvaux=-ffpol*cos(xlonr+ddpol)
+ call cc2gll(northpolemap,ylat,xlon,uuaux,vvaux,uupolaux, &
+ vvpolaux)
+
+ jy=nymin1
+ do ix=0,nxmin1
+ uupol(ix,jy,iz,n)=uupolaux
+ vvpol(ix,jy,iz,n)=vvpolaux
+ end do
+ end do
+
+
+ ! Fix: Set W at pole to the zonally averaged W of the next equator-
+ ! ward parallel of latitude
+
+ do iz=1,nz
+ wdummy=0.
+ jy=ny-2
+ do ix=0,nxmin1
+ wdummy=wdummy+ww(ix,jy,iz,n)
+ end do
+ wdummy=wdummy/real(nx)
+ jy=nymin1
+ do ix=0,nxmin1
+ ww(ix,jy,iz,n)=wdummy
+ end do
+ end do
+
+ endif
+
+
+ ! If south pole is in the domain, calculate wind velocities in polar
+ ! stereographic coordinates
+ !*******************************************************************
+
+ if (sglobal) then
+ do jy=0,int(switchsouthg)+3
+ ylat=ylat0+real(jy)*dy
+ do ix=0,nxmin1
+ xlon=xlon0+real(ix)*dx
+ do iz=1,nz
+ call cc2gll(southpolemap,ylat,xlon,uu(ix,jy,iz,n), &
+ vv(ix,jy,iz,n),uupol(ix,jy,iz,n), &
+ vvpol(ix,jy,iz,n))
+ end do
+ end do
+ end do
+
+ do iz=1,nz
+
+ ! CALCULATE FFPOL, DDPOL FOR CENTRAL GRID POINT
+ !
+ ! AMSnauffer Nov 18 2004 Added check for case vv=0
+ !
+ xlon=xlon0+real(nx/2-1)*dx
+ xlonr=xlon*pi/180.
+ ffpol=sqrt(uu(nx/2-1,0,iz,n)**2+ &
+ vv(nx/2-1,0,iz,n)**2)
+ if (vv(nx/2-1,0,iz,n).lt.0.) then
+ ddpol=atan(uu(nx/2-1,0,iz,n)/ &
+ vv(nx/2-1,0,iz,n))+xlonr
+ else if (vv(nx/2-1,0,iz,n).gt.0.) then
+ ddpol=pi+atan(uu(nx/2-1,0,iz,n)/ &
+ vv(nx/2-1,0,iz,n))+xlonr
+ else
+ ddpol=pi/2-xlonr
+ endif
+ if(ddpol.lt.0.) ddpol=2.0*pi+ddpol
+ if(ddpol.gt.2.0*pi) ddpol=ddpol-2.0*pi
+
+ ! CALCULATE U,V FOR 180 DEG, TRANSFORM TO POLAR STEREOGRAPHIC GRID
+ xlon=180.0
+ xlonr=xlon*pi/180.
+ ylat=-90.0
+ uuaux=+ffpol*sin(xlonr-ddpol)
+ vvaux=-ffpol*cos(xlonr-ddpol)
+ call cc2gll(northpolemap,ylat,xlon,uuaux,vvaux,uupolaux, &
+ vvpolaux)
+
+ jy=0
+ do ix=0,nxmin1
+ uupol(ix,jy,iz,n)=uupolaux
+ vvpol(ix,jy,iz,n)=vvpolaux
+ end do
+ end do
+
+
+ ! Fix: Set W at pole to the zonally averaged W of the next equator-
+ ! ward parallel of latitude
+
+ do iz=1,nz
+ wdummy=0.
+ jy=1
+ do ix=0,nxmin1
+ wdummy=wdummy+ww(ix,jy,iz,n)
+ end do
+ wdummy=wdummy/real(nx)
+ jy=0
+ do ix=0,nxmin1
+ ww(ix,jy,iz,n)=wdummy
+ end do
+ end do
+ endif
+
+
+ !write (*,*) 'initializing clouds, n:',n,nymin1,nxmin1,nz
+ ! create a cloud and rainout/washout field, clouds occur where rh>80%
+ ! total cloudheight is stored at level 0
+
+
+
+ do jy=0,nymin1
+ do ix=0,nxmin1
+
+
+
+ ! rain_cloud_above=0
+ ! lsp=lsprec(ix,jy,1,n)
+ ! convp=convprec(ix,jy,1,n)
+ ! cloudsh(ix,jy,n)=0
+ ! do kz_inv=1,nz-1
+ ! kz=nz-kz_inv+1
+ ! pressure=rho(ix,jy,kz,n)*r_air*tt(ix,jy,kz,n)
+ ! rh=qv(ix,jy,kz,n)/f_qvsat(pressure,tt(ix,jy,kz,n))
+ ! clouds(ix,jy,kz,n)=0
+ ! if (rh.gt.0.8) then ! in cloud
+ ! if ((lsp.gt.0.01).or.(convp.gt.0.01)) then ! cloud and precipitation
+ ! rain_cloud_above=1
+ ! cloudsh(ix,jy,n)=cloudsh(ix,jy,n)+ &
+ ! height(kz)-height(kz-1)
+ ! if (lsp.ge.convp) then
+ ! clouds(ix,jy,kz,n)=3 ! lsp dominated rainout
+ ! else
+ ! clouds(ix,jy,kz,n)=2 ! convp dominated rainout
+ ! endif
+ ! else ! no precipitation
+ ! clouds(ix,jy,kz,n)=1 ! cloud
+ ! endif
+ ! else ! no cloud
+ ! if (rain_cloud_above.eq.1) then ! scavenging
+ ! if (lsp.ge.convp) then
+ ! clouds(ix,jy,kz,n)=5 ! lsp dominated washout
+ ! else
+ ! clouds(ix,jy,kz,n)=4 ! convp dominated washout
+ ! endif
+ ! endif
+ ! endif
+ ! end do
+
+
+ ! PS 3012
+
+ lsp=lsprec(ix,jy,1,n)
+ convp=convprec(ix,jy,1,n)
+ prec=lsp+convp
+ if (lsp.gt.convp) then ! prectype='lsp'
+ lconvectprec = .false.
+ else ! prectype='cp '
+ lconvectprec = .true.
+ endif
+ rhmin = 0.90 ! standard condition for presence of clouds
+!PS note that original by Sabine Eckhart was 80%
+!PS however, for T<-20 C we consider saturation over ice
+!PS so I think 90% should be enough
+ icloudbot(ix,jy,n)=icmv
+ icloudtop=icmv ! this is just a local variable
+98 do kz=1,nz
+ pressure=rho(ix,jy,kz,n)*r_air*tt(ix,jy,kz,n)
+ rh=qv(ix,jy,kz,n)/f_qvsat(pressure,tt(ix,jy,kz,n))
+!ps if (prec.gt.0.01) print*,'relhum',prec,kz,rh,height(kz)
+ if (rh .gt. rhmin) then
+ if (icloudbot(ix,jy,n) .eq. icmv) then
+ icloudbot(ix,jy,n)=nint(height(kz))
+ endif
+ icloudtop=nint(height(kz)) ! use int to save memory
+ endif
+ enddo
+
+!PS try to get a cloud thicker than 50 m
+!PS if there is at least .01 mm/h - changed to 0.002 and put into
+!PS parameter precpmin
+ if ((icloudbot(ix,jy,n) .eq. icmv .or. &
+ icloudtop-icloudbot(ix,jy,n) .lt. 50) .and. &
+ prec .gt. precmin) then
+ rhmin = rhmin - 0.05
+ if (rhmin .ge. 0.30) goto 98 ! give up for <= 25% rel.hum.
+ endif
+!PS implement a rough fix for badly represented convection
+!PS is based on looking at a limited set of comparison data
+ if (lconvectprec .and. icloudtop .lt. 6000 .and. &
+ prec .gt. precmin) then
+
+ if (convp .lt. 0.1) then
+ icloudbot(ix,jy,n) = 500
+ icloudtop = 8000
+ else
+ icloudbot(ix,jy,n) = 0
+ icloudtop = 10000
+ endif
+ endif
+ if (icloudtop .ne. icmv) then
+ icloudthck(ix,jy,n) = icloudtop-icloudbot(ix,jy,n)
+ else
+ icloudthck(ix,jy,n) = icmv
+ endif
+!PS get rid of too thin clouds
+ if (icloudthck(ix,jy,n) .lt. 50) then
+ icloudbot(ix,jy,n)=icmv
+ icloudthck(ix,jy,n)=icmv
+ endif
+
+
+ end do
+ end do
+
+ !do 102 kz=1,nuvz
+ !write(an,'(i02)') kz+10
+ !write(*,*) nuvz,nymin1,nxmin1,'--',an,'--'
+ !open(4,file='/nilu_wrk2/sec/cloudtest/cloud'//an,form='formatted')
+ !do 101 jy=0,nymin1
+ ! write(4,*) (clouds(ix,jy,kz,n),ix=1,nxmin1)
+ !101 continue
+ ! close(4)
+ !102 continue
+
+ ! open(4,file='/nilu_wrk2/sec/cloudtest/height',form='formatted')
+ ! do 103 jy=0,nymin1
+ ! write (4,*)
+ !+ (height(kz),kz=1,nuvz)
+ !103 continue
+ ! close(4)
+
+ !open(4,file='/nilu_wrk2/sec/cloudtest/p',form='formatted')
+ ! do 104 jy=0,nymin1
+ ! write (4,*)
+ !+ (r_air*tt(ix,jy,1,n)*rho(ix,jy,1,n),ix=1,nxmin1)
+ !104 continue
+ ! close(4)
+
+
+end subroutine verttransform
diff --git a/src/verttransform_gfs.f90 b/src/verttransform_gfs.f90
new file mode 100644
index 0000000000000000000000000000000000000000..4826b3ee23e4d55fb0a2154345cc9494ddc8ec59
--- /dev/null
+++ b/src/verttransform_gfs.f90
@@ -0,0 +1,590 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine verttransform(n,uuh,vvh,wwh,pvh)
+ ! i i i i i
+ !*****************************************************************************
+ ! *
+ ! This subroutine transforms temperature, dew point temperature and *
+ ! wind components from eta to meter coordinates. *
+ ! The vertical wind component is transformed from Pa/s to m/s using *
+ ! the conversion factor pinmconv. *
+ ! In addition, this routine calculates vertical density gradients *
+ ! needed for the parameterization of the turbulent velocities. *
+ ! *
+ ! Author: A. Stohl, G. Wotawa *
+ ! *
+ ! 12 August 1996 *
+ ! Update: 16 January 1998 *
+ ! *
+ ! Major update: 17 February 1999 *
+ ! by G. Wotawa *
+ ! CHANGE 17/11/2005 Caroline Forster, NCEP GFS version *
+ ! *
+ ! - Vertical levels for u, v and w are put together *
+ ! - Slope correction for vertical velocity: Modification of calculation *
+ ! procedure *
+ ! *
+ !*****************************************************************************
+ ! Changes, Bernd C. Krueger, Feb. 2001:
+ ! Variables tth and qvh (on eta coordinates) from common block
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! nx,ny,nz field dimensions in x,y and z direction *
+ ! uu(0:nxmax,0:nymax,nzmax,2) wind components in x-direction [m/s] *
+ ! vv(0:nxmax,0:nymax,nzmax,2) wind components in y-direction [m/s] *
+ ! ww(0:nxmax,0:nymax,nzmax,2) wind components in z-direction [deltaeta/s]*
+ ! tt(0:nxmax,0:nymax,nzmax,2) temperature [K] *
+ ! pv(0:nxmax,0:nymax,nzmax,2) potential voriticity (pvu) *
+ ! ps(0:nxmax,0:nymax,2) surface pressure [Pa] *
+ ! clouds(0:nxmax,0:nymax,0:nzmax,2) cloud field for wet deposition *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+ use cmapf_mod
+
+ implicit none
+
+ integer :: ix,jy,kz,iz,n,kmin,kl,klp,ix1,jy1,ixp,jyp,ixm,jym
+ integer :: rain_cloud_above,kz_inv
+ real :: f_qvsat,pressure
+ real :: rh,lsp,convp
+ real :: uvzlev(nuvzmax),rhoh(nuvzmax),pinmconv(nzmax)
+ real :: ew,pint,tv,tvold,pold,dz1,dz2,dz,ui,vi
+ real :: xlon,ylat,xlonr,dzdx,dzdy
+ real :: dzdx1,dzdx2,dzdy1,dzdy2
+ real :: uuaux,vvaux,uupolaux,vvpolaux,ddpol,ffpol,wdummy
+ real :: uuh(0:nxmax-1,0:nymax-1,nuvzmax)
+ real :: vvh(0:nxmax-1,0:nymax-1,nuvzmax)
+ real :: pvh(0:nxmax-1,0:nymax-1,nuvzmax)
+ real :: wwh(0:nxmax-1,0:nymax-1,nwzmax)
+ real :: wzlev(nwzmax),uvwzlev(0:nxmax-1,0:nymax-1,nzmax)
+ real,parameter :: const=r_air/ga
+
+ ! NCEP version
+ integer :: llev, i
+
+ logical :: init = .true.
+
+
+ !*************************************************************************
+ ! If verttransform is called the first time, initialize heights of the *
+ ! z levels in meter. The heights are the heights of model levels, where *
+ ! u,v,T and qv are given, and of the interfaces, where w is given. So, *
+ ! the vertical resolution in the z system is doubled. As reference point,*
+ ! the lower left corner of the grid is used. *
+ ! Unlike in the eta system, no difference between heights for u,v and *
+ ! heights for w exists. *
+ !*************************************************************************
+
+ if (init) then
+
+ ! Search for a point with high surface pressure (i.e. not above significant topography)
+ ! Then, use this point to construct a reference z profile, to be used at all times
+ !*****************************************************************************
+
+ do jy=0,nymin1
+ do ix=0,nxmin1
+ if (ps(ix,jy,1,n).gt.100000.) then
+ ixm=ix
+ jym=jy
+ goto 3
+ endif
+ end do
+ end do
+3 continue
+
+
+ tvold=tt2(ixm,jym,1,n)*(1.+0.378*ew(td2(ixm,jym,1,n))/ &
+ ps(ixm,jym,1,n))
+ pold=ps(ixm,jym,1,n)
+ height(1)=0.
+
+ do kz=2,nuvz
+ pint=akz(kz)+bkz(kz)*ps(ixm,jym,1,n)
+ tv=tth(ixm,jym,kz,n)*(1.+0.608*qvh(ixm,jym,kz,n))
+
+
+ ! NOTE: In FLEXPART versions up to 4.0, the number of model levels was doubled
+ ! upon the transformation to z levels. In order to save computer memory, this is
+ ! not done anymore in the standard version. However, this option can still be
+ ! switched on by replacing the following lines with those below, that are
+ ! currently commented out.
+ ! Note that two more changes are necessary in this subroutine below.
+ ! One change is also necessary in gridcheck.f, and another one in verttransform_nests.
+ !*****************************************************************************
+
+ if (abs(tv-tvold).gt.0.2) then
+ height(kz)= &
+ height(kz-1)+const*log(pold/pint)* &
+ (tv-tvold)/log(tv/tvold)
+ else
+ height(kz)=height(kz-1)+ &
+ const*log(pold/pint)*tv
+ endif
+
+ ! Switch on following lines to use doubled vertical resolution
+ !*************************************************************
+ ! if (abs(tv-tvold).gt.0.2) then
+ ! height((kz-1)*2)=
+ ! + height(max((kz-2)*2,1))+const*log(pold/pint)*
+ ! + (tv-tvold)/log(tv/tvold)
+ ! else
+ ! height((kz-1)*2)=height(max((kz-2)*2,1))+
+ ! + const*log(pold/pint)*tv
+ ! endif
+ ! End doubled vertical resolution
+
+ tvold=tv
+ pold=pint
+ end do
+
+
+ ! Switch on following lines to use doubled vertical resolution
+ !*************************************************************
+ ! do 7 kz=3,nz-1,2
+ ! height(kz)=0.5*(height(kz-1)+height(kz+1))
+ ! height(nz)=height(nz-1)+height(nz-1)-height(nz-2)
+ ! End doubled vertical resolution
+
+
+ ! Determine highest levels that can be within PBL
+ !************************************************
+
+ do kz=1,nz
+ if (height(kz).gt.hmixmax) then
+ nmixz=kz
+ goto 9
+ endif
+ end do
+9 continue
+
+ ! Do not repeat initialization of the Cartesian z grid
+ !*****************************************************
+
+ init=.false.
+
+ endif
+
+
+ ! Loop over the whole grid
+ !*************************
+
+ do jy=0,nymin1
+ do ix=0,nxmin1
+
+ ! NCEP version: find first level above ground
+ llev = 0
+ do i=1,nuvz
+ if (ps(ix,jy,1,n).lt.akz(i)) llev=i
+ end do
+ llev = llev+1
+ if (llev.gt.nuvz-2) llev = nuvz-2
+ ! if (llev.eq.nuvz-2) write(*,*) 'verttransform
+ ! +WARNING: LLEV eq NUZV-2'
+ ! NCEP version
+
+
+ ! compute height of pressure levels above ground
+ !***********************************************
+
+ tvold=tth(ix,jy,llev,n)*(1.+0.608*qvh(ix,jy,llev,n))
+ pold=akz(llev)
+ uvzlev(llev)=0.
+ wzlev(llev)=0.
+ uvwzlev(ix,jy,llev)=0.
+ rhoh(llev)=pold/(r_air*tvold)
+
+ do kz=llev+1,nuvz
+ pint=akz(kz)+bkz(kz)*ps(ix,jy,1,n)
+ tv=tth(ix,jy,kz,n)*(1.+0.608*qvh(ix,jy,kz,n))
+ rhoh(kz)=pint/(r_air*tv)
+
+ if (abs(tv-tvold).gt.0.2) then
+ uvzlev(kz)=uvzlev(kz-1)+const*log(pold/pint)* &
+ (tv-tvold)/log(tv/tvold)
+ else
+ uvzlev(kz)=uvzlev(kz-1)+const*log(pold/pint)*tv
+ endif
+ wzlev(kz)=uvzlev(kz)
+ uvwzlev(ix,jy,kz)=uvzlev(kz)
+
+ tvold=tv
+ pold=pint
+ end do
+
+
+ ! Switch on following lines to use doubled vertical resolution
+ ! Switch off the three lines above.
+ !*************************************************************
+ !22 uvwzlev(ix,jy,(kz-1)*2)=uvzlev(kz)
+ ! do 23 kz=2,nwz
+ !23 uvwzlev(ix,jy,(kz-1)*2+1)=wzlev(kz)
+ ! End doubled vertical resolution
+
+ ! pinmconv=(h2-h1)/(p2-p1)
+
+ pinmconv(llev)=(uvwzlev(ix,jy,llev+1)-uvwzlev(ix,jy,llev))/ &
+ ((aknew(llev+1)+bknew(llev+1)*ps(ix,jy,1,n))- &
+ (aknew(llev)+bknew(llev)*ps(ix,jy,1,n)))
+ do kz=llev+1,nz-1
+ pinmconv(kz)=(uvwzlev(ix,jy,kz+1)-uvwzlev(ix,jy,kz-1))/ &
+ ((aknew(kz+1)+bknew(kz+1)*ps(ix,jy,1,n))- &
+ (aknew(kz-1)+bknew(kz-1)*ps(ix,jy,1,n)))
+ end do
+ pinmconv(nz)=(uvwzlev(ix,jy,nz)-uvwzlev(ix,jy,nz-1))/ &
+ ((aknew(nz)+bknew(nz)*ps(ix,jy,1,n))- &
+ (aknew(nz-1)+bknew(nz-1)*ps(ix,jy,1,n)))
+
+
+ ! Levels, where u,v,t and q are given
+ !************************************
+
+ uu(ix,jy,1,n)=uuh(ix,jy,llev)
+ vv(ix,jy,1,n)=vvh(ix,jy,llev)
+ tt(ix,jy,1,n)=tth(ix,jy,llev,n)
+ qv(ix,jy,1,n)=qvh(ix,jy,llev,n)
+ pv(ix,jy,1,n)=pvh(ix,jy,llev)
+ rho(ix,jy,1,n)=rhoh(llev)
+ pplev(ix,jy,1,n)=akz(llev)
+ uu(ix,jy,nz,n)=uuh(ix,jy,nuvz)
+ vv(ix,jy,nz,n)=vvh(ix,jy,nuvz)
+ tt(ix,jy,nz,n)=tth(ix,jy,nuvz,n)
+ qv(ix,jy,nz,n)=qvh(ix,jy,nuvz,n)
+ pv(ix,jy,nz,n)=pvh(ix,jy,nuvz)
+ rho(ix,jy,nz,n)=rhoh(nuvz)
+ pplev(ix,jy,nz,n)=akz(nuvz)
+ kmin=llev+1
+ do iz=2,nz-1
+ do kz=kmin,nuvz
+ if(height(iz).gt.uvzlev(nuvz)) then
+ uu(ix,jy,iz,n)=uu(ix,jy,nz,n)
+ vv(ix,jy,iz,n)=vv(ix,jy,nz,n)
+ tt(ix,jy,iz,n)=tt(ix,jy,nz,n)
+ qv(ix,jy,iz,n)=qv(ix,jy,nz,n)
+ pv(ix,jy,iz,n)=pv(ix,jy,nz,n)
+ rho(ix,jy,iz,n)=rho(ix,jy,nz,n)
+ pplev(ix,jy,iz,n)=pplev(ix,jy,nz,n)
+ goto 30
+ endif
+ if ((height(iz).gt.uvzlev(kz-1)).and. &
+ (height(iz).le.uvzlev(kz))) then
+ dz1=height(iz)-uvzlev(kz-1)
+ dz2=uvzlev(kz)-height(iz)
+ dz=dz1+dz2
+ uu(ix,jy,iz,n)=(uuh(ix,jy,kz-1)*dz2+uuh(ix,jy,kz)*dz1)/dz
+ vv(ix,jy,iz,n)=(vvh(ix,jy,kz-1)*dz2+vvh(ix,jy,kz)*dz1)/dz
+ tt(ix,jy,iz,n)=(tth(ix,jy,kz-1,n)*dz2 &
+ +tth(ix,jy,kz,n)*dz1)/dz
+ qv(ix,jy,iz,n)=(qvh(ix,jy,kz-1,n)*dz2 &
+ +qvh(ix,jy,kz,n)*dz1)/dz
+ pv(ix,jy,iz,n)=(pvh(ix,jy,kz-1)*dz2+pvh(ix,jy,kz)*dz1)/dz
+ rho(ix,jy,iz,n)=(rhoh(kz-1)*dz2+rhoh(kz)*dz1)/dz
+ pplev(ix,jy,iz,n)=(akz(kz-1)*dz2+akz(kz)*dz1)/dz
+ endif
+ end do
+30 continue
+ end do
+
+
+ ! Levels, where w is given
+ !*************************
+
+ ww(ix,jy,1,n)=wwh(ix,jy,llev)*pinmconv(llev)
+ ww(ix,jy,nz,n)=wwh(ix,jy,nwz)*pinmconv(nz)
+ kmin=llev+1
+ do iz=2,nz
+ do kz=kmin,nwz
+ if ((height(iz).gt.wzlev(kz-1)).and. &
+ (height(iz).le.wzlev(kz))) then
+ dz1=height(iz)-wzlev(kz-1)
+ dz2=wzlev(kz)-height(iz)
+ dz=dz1+dz2
+ ww(ix,jy,iz,n)=(wwh(ix,jy,kz-1)*pinmconv(kz-1)*dz2 &
+ +wwh(ix,jy,kz)*pinmconv(kz)*dz1)/dz
+
+ endif
+ end do
+ end do
+
+
+ ! Compute density gradients at intermediate levels
+ !*************************************************
+
+ drhodz(ix,jy,1,n)=(rho(ix,jy,2,n)-rho(ix,jy,1,n))/ &
+ (height(2)-height(1))
+ do kz=2,nz-1
+ drhodz(ix,jy,kz,n)=(rho(ix,jy,kz+1,n)-rho(ix,jy,kz-1,n))/ &
+ (height(kz+1)-height(kz-1))
+ end do
+ drhodz(ix,jy,nz,n)=drhodz(ix,jy,nz-1,n)
+
+ end do
+ end do
+
+
+ !****************************************************************
+ ! Compute slope of eta levels in windward direction and resulting
+ ! vertical wind correction
+ !****************************************************************
+
+ do jy=1,ny-2
+ do ix=1,nx-2
+
+ ! NCEP version: find first level above ground
+ llev = 0
+ do i=1,nuvz
+ if (ps(ix,jy,1,n).lt.akz(i)) llev=i
+ end do
+ llev = llev+1
+ if (llev.gt.nuvz-2) llev = nuvz-2
+ ! if (llev.eq.nuvz-2) write(*,*) 'verttransform
+ ! +WARNING: LLEV eq NUZV-2'
+ ! NCEP version
+
+ kmin=llev+1
+ do iz=2,nz-1
+
+ ui=uu(ix,jy,iz,n)*dxconst/cos((real(jy)*dy+ylat0)*pi180)
+ vi=vv(ix,jy,iz,n)*dyconst
+
+ do kz=kmin,nz
+ if ((height(iz).gt.uvwzlev(ix,jy,kz-1)).and. &
+ (height(iz).le.uvwzlev(ix,jy,kz))) then
+ dz1=height(iz)-uvwzlev(ix,jy,kz-1)
+ dz2=uvwzlev(ix,jy,kz)-height(iz)
+ dz=dz1+dz2
+ kl=kz-1
+ klp=kz
+ goto 47
+ endif
+ end do
+
+47 ix1=ix-1
+ jy1=jy-1
+ ixp=ix+1
+ jyp=jy+1
+
+ dzdx1=(uvwzlev(ixp,jy,kl)-uvwzlev(ix1,jy,kl))/2.
+ dzdx2=(uvwzlev(ixp,jy,klp)-uvwzlev(ix1,jy,klp))/2.
+ dzdx=(dzdx1*dz2+dzdx2*dz1)/dz
+
+ dzdy1=(uvwzlev(ix,jyp,kl)-uvwzlev(ix,jy1,kl))/2.
+ dzdy2=(uvwzlev(ix,jyp,klp)-uvwzlev(ix,jy1,klp))/2.
+ dzdy=(dzdy1*dz2+dzdy2*dz1)/dz
+
+ ww(ix,jy,iz,n)=ww(ix,jy,iz,n)+(dzdx*ui+dzdy*vi)
+
+ end do
+
+ end do
+ end do
+
+
+ ! If north pole is in the domain, calculate wind velocities in polar
+ ! stereographic coordinates
+ !*******************************************************************
+
+ if (nglobal) then
+ do jy=int(switchnorthg)-2,nymin1
+ ylat=ylat0+real(jy)*dy
+ do ix=0,nxmin1
+ xlon=xlon0+real(ix)*dx
+ do iz=1,nz
+ call cc2gll(northpolemap,ylat,xlon,uu(ix,jy,iz,n), &
+ vv(ix,jy,iz,n),uupol(ix,jy,iz,n), &
+ vvpol(ix,jy,iz,n))
+ end do
+ end do
+ end do
+
+
+ do iz=1,nz
+
+ ! CALCULATE FFPOL, DDPOL FOR CENTRAL GRID POINT
+ xlon=xlon0+real(nx/2-1)*dx
+ xlonr=xlon*pi/180.
+ ffpol=sqrt(uu(nx/2-1,nymin1,iz,n)**2+ &
+ vv(nx/2-1,nymin1,iz,n)**2)
+ if(vv(nx/2-1,nymin1,iz,n).lt.0.) then
+ ddpol=atan(uu(nx/2-1,nymin1,iz,n)/ &
+ vv(nx/2-1,nymin1,iz,n))-xlonr
+ elseif (vv(nx/2-1,nymin1,iz,n).gt.0.) then
+ ddpol=pi+atan(uu(nx/2-1,nymin1,iz,n)/ &
+ vv(nx/2-1,nymin1,iz,n))-xlonr
+ else
+ ddpol=pi/2-xlonr
+ endif
+ if(ddpol.lt.0.) ddpol=2.0*pi+ddpol
+ if(ddpol.gt.2.0*pi) ddpol=ddpol-2.0*pi
+
+ ! CALCULATE U,V FOR 180 DEG, TRANSFORM TO POLAR STEREOGRAPHIC GRID
+ xlon=180.0
+ xlonr=xlon*pi/180.
+ ylat=90.0
+ uuaux=-ffpol*sin(xlonr+ddpol)
+ vvaux=-ffpol*cos(xlonr+ddpol)
+ call cc2gll(northpolemap,ylat,xlon,uuaux,vvaux,uupolaux, &
+ vvpolaux)
+
+ jy=nymin1
+ do ix=0,nxmin1
+ uupol(ix,jy,iz,n)=uupolaux
+ vvpol(ix,jy,iz,n)=vvpolaux
+ end do
+ end do
+
+
+ ! Fix: Set W at pole to the zonally averaged W of the next equator-
+ ! ward parallel of latitude
+
+ do iz=1,nz
+ wdummy=0.
+ jy=ny-2
+ do ix=0,nxmin1
+ wdummy=wdummy+ww(ix,jy,iz,n)
+ end do
+ wdummy=wdummy/real(nx)
+ jy=nymin1
+ do ix=0,nxmin1
+ ww(ix,jy,iz,n)=wdummy
+ end do
+ end do
+
+ endif
+
+
+ ! If south pole is in the domain, calculate wind velocities in polar
+ ! stereographic coordinates
+ !*******************************************************************
+
+ if (sglobal) then
+ do jy=0,int(switchsouthg)+3
+ ylat=ylat0+real(jy)*dy
+ do ix=0,nxmin1
+ xlon=xlon0+real(ix)*dx
+ do iz=1,nz
+ call cc2gll(southpolemap,ylat,xlon,uu(ix,jy,iz,n), &
+ vv(ix,jy,iz,n),uupol(ix,jy,iz,n), &
+ vvpol(ix,jy,iz,n))
+ end do
+ end do
+ end do
+
+ do iz=1,nz
+
+ ! CALCULATE FFPOL, DDPOL FOR CENTRAL GRID POINT
+ xlon=xlon0+real(nx/2-1)*dx
+ xlonr=xlon*pi/180.
+ ffpol=sqrt(uu(nx/2-1,0,iz,n)**2+ &
+ vv(nx/2-1,0,iz,n)**2)
+ if(vv(nx/2-1,0,iz,n).lt.0.) then
+ ddpol=atan(uu(nx/2-1,0,iz,n)/ &
+ vv(nx/2-1,0,iz,n))+xlonr
+ elseif (vv(nx/2-1,0,iz,n).gt.0.) then
+ ddpol=pi+atan(uu(nx/2-1,0,iz,n)/ &
+ vv(nx/2-1,0,iz,n))-xlonr
+ else
+ ddpol=pi/2-xlonr
+ endif
+ if(ddpol.lt.0.) ddpol=2.0*pi+ddpol
+ if(ddpol.gt.2.0*pi) ddpol=ddpol-2.0*pi
+
+ ! CALCULATE U,V FOR 180 DEG, TRANSFORM TO POLAR STEREOGRAPHIC GRID
+ xlon=180.0
+ xlonr=xlon*pi/180.
+ ylat=-90.0
+ uuaux=+ffpol*sin(xlonr-ddpol)
+ vvaux=-ffpol*cos(xlonr-ddpol)
+ call cc2gll(northpolemap,ylat,xlon,uuaux,vvaux,uupolaux, &
+ vvpolaux)
+
+ jy=0
+ do ix=0,nxmin1
+ uupol(ix,jy,iz,n)=uupolaux
+ vvpol(ix,jy,iz,n)=vvpolaux
+ end do
+ end do
+
+
+ ! Fix: Set W at pole to the zonally averaged W of the next equator-
+ ! ward parallel of latitude
+
+ do iz=1,nz
+ wdummy=0.
+ jy=1
+ do ix=0,nxmin1
+ wdummy=wdummy+ww(ix,jy,iz,n)
+ end do
+ wdummy=wdummy/real(nx)
+ jy=0
+ do ix=0,nxmin1
+ ww(ix,jy,iz,n)=wdummy
+ end do
+ end do
+ endif
+
+
+ ! write (*,*) 'initializing clouds, n:',n,nymin1,nxmin1,nz
+ ! create a cloud and rainout/washout field, clouds occur where rh>80%
+ ! total cloudheight is stored at level 0
+ do jy=0,nymin1
+ do ix=0,nxmin1
+ rain_cloud_above=0
+ lsp=lsprec(ix,jy,1,n)
+ convp=convprec(ix,jy,1,n)
+ cloudsh(ix,jy,n)=0
+ do kz_inv=1,nz-1
+ kz=nz-kz_inv+1
+ pressure=rho(ix,jy,kz,n)*r_air*tt(ix,jy,kz,n)
+ rh=qv(ix,jy,kz,n)/f_qvsat(pressure,tt(ix,jy,kz,n))
+ clouds(ix,jy,kz,n)=0
+ if (rh.gt.0.8) then ! in cloud
+ if ((lsp.gt.0.01).or.(convp.gt.0.01)) then ! cloud and precipitation
+ rain_cloud_above=1
+ cloudsh(ix,jy,n)=cloudsh(ix,jy,n)+ &
+ height(kz)-height(kz-1)
+ if (lsp.ge.convp) then
+ clouds(ix,jy,kz,n)=3 ! lsp dominated rainout
+ else
+ clouds(ix,jy,kz,n)=2 ! convp dominated rainout
+ endif
+ else ! no precipitation
+ clouds(ix,jy,kz,n)=1 ! cloud
+ endif
+ else ! no cloud
+ if (rain_cloud_above.eq.1) then ! scavenging
+ if (lsp.ge.convp) then
+ clouds(ix,jy,kz,n)=5 ! lsp dominated washout
+ else
+ clouds(ix,jy,kz,n)=4 ! convp dominated washout
+ endif
+ endif
+ endif
+ end do
+ end do
+ end do
+
+
+end subroutine verttransform
diff --git a/src/verttransform_nests.f90 b/src/verttransform_nests.f90
new file mode 100644
index 0000000000000000000000000000000000000000..aa23753a56e48510967c0e8f2ee358fd4e4bfe17
--- /dev/null
+++ b/src/verttransform_nests.f90
@@ -0,0 +1,345 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine verttransform_nests(n,uuhn,vvhn,wwhn,pvhn)
+ ! i i i i i
+ !*****************************************************************************
+ ! *
+ ! This subroutine transforms temperature, dew point temperature and *
+ ! wind components from eta to meter coordinates. *
+ ! The vertical wind component is transformed from Pa/s to m/s using *
+ ! the conversion factor pinmconv. *
+ ! In addition, this routine calculates vertical density gradients *
+ ! needed for the parameterization of the turbulent velocities. *
+ ! It is similar to verttransform, but makes the transformations for *
+ ! the nested grids. *
+ ! *
+ ! Author: A. Stohl, G. Wotawa *
+ ! *
+ ! 12 August 1996 *
+ ! Update: 16 January 1998 *
+ ! *
+ ! Major update: 17 February 1999 *
+ ! by G. Wotawa *
+ ! *
+ ! - Vertical levels for u, v and w are put together *
+ ! - Slope correction for vertical velocity: Modification of calculation *
+ ! procedure *
+ ! *
+ !*****************************************************************************
+ ! Changes, Bernd C. Krueger, Feb. 2001: (marked "C-cv")
+ ! Variables tthn and qvhn (on eta coordinates) from common block
+ !*****************************************************************************
+ ! Sabine Eckhardt, March 2007
+ ! add the variable cloud for use with scavenging - descr. in com_mod
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! nxn,nyn,nuvz,nwz field dimensions in x,y and z direction *
+ ! uun wind components in x-direction [m/s] *
+ ! vvn wind components in y-direction [m/s] *
+ ! wwn wind components in z-direction [deltaeta/s]*
+ ! ttn temperature [K] *
+ ! pvn potential vorticity (pvu) *
+ ! psn surface pressure [Pa] *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: ix,jy,kz,iz,n,l,kmin,kl,klp,ix1,jy1,ixp,jyp
+ integer :: rain_cloud_above,kz_inv
+ real :: f_qvsat,pressure,rh,lsp,convp
+ real :: uvzlev(nuvzmax),wzlev(nwzmax),rhoh(nuvzmax),pinmconv(nzmax)
+ real :: uvwzlev(0:nxmaxn-1,0:nymaxn-1,nzmax)
+ real :: ew,pint,tv,tvold,pold,dz1,dz2,dz,ui,vi
+ real :: dzdx,dzdy
+ real :: dzdx1,dzdx2,dzdy1,dzdy2
+ real :: uuhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
+ real :: vvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
+ real :: pvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
+ real :: wwhn(0:nxmaxn-1,0:nymaxn-1,nwzmax,maxnests)
+ real,parameter :: const=r_air/ga
+
+
+ ! Loop over all nests
+ !********************
+
+ do l=1,numbnests
+
+ ! Loop over the whole grid
+ !*************************
+
+ do jy=0,nyn(l)-1
+ do ix=0,nxn(l)-1
+
+ tvold=tt2n(ix,jy,1,n,l)*(1.+0.378*ew(td2n(ix,jy,1,n,l))/ &
+ psn(ix,jy,1,n,l))
+ pold=psn(ix,jy,1,n,l)
+ uvzlev(1)=0.
+ wzlev(1)=0.
+ rhoh(1)=pold/(r_air*tvold)
+
+
+ ! Compute heights of eta levels
+ !******************************
+
+ do kz=2,nuvz
+ pint=akz(kz)+bkz(kz)*psn(ix,jy,1,n,l)
+ tv=tthn(ix,jy,kz,n,l)*(1.+0.608*qvhn(ix,jy,kz,n,l))
+ rhoh(kz)=pint/(r_air*tv)
+
+ if (abs(tv-tvold).gt.0.2) then
+ uvzlev(kz)=uvzlev(kz-1)+const*log(pold/pint)* &
+ (tv-tvold)/log(tv/tvold)
+ else
+ uvzlev(kz)=uvzlev(kz-1)+const*log(pold/pint)*tv
+ endif
+
+ tvold=tv
+ pold=pint
+ end do
+
+
+ do kz=2,nwz-1
+ wzlev(kz)=(uvzlev(kz+1)+uvzlev(kz))/2.
+ end do
+ wzlev(nwz)=wzlev(nwz-1)+ &
+ uvzlev(nuvz)-uvzlev(nuvz-1)
+
+ ! NOTE: In FLEXPART versions up to 4.0, the number of model levels was doubled
+ ! upon the transformation to z levels. In order to save computer memory, this is
+ ! not done anymore in the standard version. However, this option can still be
+ ! switched on by replacing the following lines with those below, that are
+ ! currently commented out.
+ ! Note that one change is also necessary in gridcheck.f,
+ ! and three changes in verttransform.f
+ !*****************************************************************************
+ uvwzlev(ix,jy,1)=0.0
+ do kz=2,nuvz
+ uvwzlev(ix,jy,kz)=uvzlev(kz)
+ end do
+
+ ! Switch on following lines to use doubled vertical resolution
+ ! Switch off the three lines above.
+ !*************************************************************
+ !22 uvwzlev(ix,jy,(kz-1)*2)=uvzlev(kz)
+ ! do 23 kz=2,nwz
+ !23 uvwzlev(ix,jy,(kz-1)*2+1)=wzlev(kz)
+ ! End doubled vertical resolution
+
+ ! pinmconv=(h2-h1)/(p2-p1)
+
+ pinmconv(1)=(uvwzlev(ix,jy,2)-uvwzlev(ix,jy,1))/ &
+ ((aknew(2)+bknew(2)*psn(ix,jy,1,n,l))- &
+ (aknew(1)+bknew(1)*psn(ix,jy,1,n,l)))
+ do kz=2,nz-1
+ pinmconv(kz)=(uvwzlev(ix,jy,kz+1)-uvwzlev(ix,jy,kz-1))/ &
+ ((aknew(kz+1)+bknew(kz+1)*psn(ix,jy,1,n,l))- &
+ (aknew(kz-1)+bknew(kz-1)*psn(ix,jy,1,n,l)))
+ end do
+ pinmconv(nz)=(uvwzlev(ix,jy,nz)-uvwzlev(ix,jy,nz-1))/ &
+ ((aknew(nz)+bknew(nz)*psn(ix,jy,1,n,l))- &
+ (aknew(nz-1)+bknew(nz-1)*psn(ix,jy,1,n,l)))
+
+
+ ! Levels, where u,v,t and q are given
+ !************************************
+
+ uun(ix,jy,1,n,l)=uuhn(ix,jy,1,l)
+ vvn(ix,jy,1,n,l)=vvhn(ix,jy,1,l)
+ ttn(ix,jy,1,n,l)=tthn(ix,jy,1,n,l)
+ qvn(ix,jy,1,n,l)=qvhn(ix,jy,1,n,l)
+ pvn(ix,jy,1,n,l)=pvhn(ix,jy,1,l)
+ rhon(ix,jy,1,n,l)=rhoh(1)
+ uun(ix,jy,nz,n,l)=uuhn(ix,jy,nuvz,l)
+ vvn(ix,jy,nz,n,l)=vvhn(ix,jy,nuvz,l)
+ ttn(ix,jy,nz,n,l)=tthn(ix,jy,nuvz,n,l)
+ qvn(ix,jy,nz,n,l)=qvhn(ix,jy,nuvz,n,l)
+ pvn(ix,jy,nz,n,l)=pvhn(ix,jy,nuvz,l)
+ rhon(ix,jy,nz,n,l)=rhoh(nuvz)
+ kmin=2
+ do iz=2,nz-1
+ do kz=kmin,nuvz
+ if(height(iz).gt.uvzlev(nuvz)) then
+ uun(ix,jy,iz,n,l)=uun(ix,jy,nz,n,l)
+ vvn(ix,jy,iz,n,l)=vvn(ix,jy,nz,n,l)
+ ttn(ix,jy,iz,n,l)=ttn(ix,jy,nz,n,l)
+ qvn(ix,jy,iz,n,l)=qvn(ix,jy,nz,n,l)
+ pvn(ix,jy,iz,n,l)=pvn(ix,jy,nz,n,l)
+ rhon(ix,jy,iz,n,l)=rhon(ix,jy,nz,n,l)
+ goto 30
+ endif
+ if ((height(iz).gt.uvzlev(kz-1)).and. &
+ (height(iz).le.uvzlev(kz))) then
+ dz1=height(iz)-uvzlev(kz-1)
+ dz2=uvzlev(kz)-height(iz)
+ dz=dz1+dz2
+ uun(ix,jy,iz,n,l)=(uuhn(ix,jy,kz-1,l)*dz2+ &
+ uuhn(ix,jy,kz,l)*dz1)/dz
+ vvn(ix,jy,iz,n,l)=(vvhn(ix,jy,kz-1,l)*dz2+ &
+ vvhn(ix,jy,kz,l)*dz1)/dz
+ ttn(ix,jy,iz,n,l)=(tthn(ix,jy,kz-1,n,l)*dz2+ &
+ tthn(ix,jy,kz,n,l)*dz1)/dz
+ qvn(ix,jy,iz,n,l)=(qvhn(ix,jy,kz-1,n,l)*dz2+ &
+ qvhn(ix,jy,kz,n,l)*dz1)/dz
+ pvn(ix,jy,iz,n,l)=(pvhn(ix,jy,kz-1,l)*dz2+ &
+ pvhn(ix,jy,kz,l)*dz1)/dz
+ rhon(ix,jy,iz,n,l)=(rhoh(kz-1)*dz2+rhoh(kz)*dz1)/dz
+ kmin=kz
+ goto 30
+ endif
+ end do
+30 continue
+ end do
+
+
+ ! Levels, where w is given
+ !*************************
+
+ wwn(ix,jy,1,n,l)=wwhn(ix,jy,1,l)*pinmconv(1)
+ wwn(ix,jy,nz,n,l)=wwhn(ix,jy,nwz,l)*pinmconv(nz)
+ kmin=2
+ do iz=2,nz
+ do kz=kmin,nwz
+ if ((height(iz).gt.wzlev(kz-1)).and. &
+ (height(iz).le.wzlev(kz))) then
+ dz1=height(iz)-wzlev(kz-1)
+ dz2=wzlev(kz)-height(iz)
+ dz=dz1+dz2
+ wwn(ix,jy,iz,n,l)=(wwhn(ix,jy,kz-1,l)*pinmconv(kz-1)*dz2 &
+ +wwhn(ix,jy,kz,l)*pinmconv(kz)*dz1)/dz
+ kmin=kz
+ goto 40
+ endif
+ end do
+40 continue
+ end do
+
+ ! Compute density gradients at intermediate levels
+ !*************************************************
+
+ drhodzn(ix,jy,1,n,l)=(rhon(ix,jy,2,n,l)-rhon(ix,jy,1,n,l))/ &
+ (height(2)-height(1))
+ do kz=2,nz-1
+ drhodzn(ix,jy,kz,n,l)=(rhon(ix,jy,kz+1,n,l)- &
+ rhon(ix,jy,kz-1,n,l))/(height(kz+1)-height(kz-1))
+ end do
+ drhodzn(ix,jy,nz,n,l)=drhodzn(ix,jy,nz-1,n,l)
+
+ end do
+ end do
+
+
+ !****************************************************************
+ ! Compute slope of eta levels in windward direction and resulting
+ ! vertical wind correction
+ !****************************************************************
+
+ do jy=1,nyn(l)-2
+ do ix=1,nxn(l)-2
+
+ kmin=2
+ do iz=2,nz-1
+
+ ui=uun(ix,jy,iz,n,l)*dxconst*xresoln(l)/ &
+ cos((real(jy)*dyn(l)+ylat0n(l))*pi180)
+ vi=vvn(ix,jy,iz,n,l)*dyconst*yresoln(l)
+
+ do kz=kmin,nz
+ if ((height(iz).gt.uvwzlev(ix,jy,kz-1)).and. &
+ (height(iz).le.uvwzlev(ix,jy,kz))) then
+ dz1=height(iz)-uvwzlev(ix,jy,kz-1)
+ dz2=uvwzlev(ix,jy,kz)-height(iz)
+ dz=dz1+dz2
+ kl=kz-1
+ klp=kz
+ kmin=kz
+ goto 47
+ endif
+ end do
+
+47 ix1=ix-1
+ jy1=jy-1
+ ixp=ix+1
+ jyp=jy+1
+
+ dzdx1=(uvwzlev(ixp,jy,kl)-uvwzlev(ix1,jy,kl))/2.
+ dzdx2=(uvwzlev(ixp,jy,klp)-uvwzlev(ix1,jy,klp))/2.
+ dzdx=(dzdx1*dz2+dzdx2*dz1)/dz
+
+ dzdy1=(uvwzlev(ix,jyp,kl)-uvwzlev(ix,jy1,kl))/2.
+ dzdy2=(uvwzlev(ix,jyp,klp)-uvwzlev(ix,jy1,klp))/2.
+ dzdy=(dzdy1*dz2+dzdy2*dz1)/dz
+
+ wwn(ix,jy,iz,n,l)=wwn(ix,jy,iz,n,l)+(dzdx*ui+dzdy*vi)
+
+ end do
+
+ end do
+ end do
+
+
+ !write (*,*) 'initializing nested cloudsn, n:',n
+ ! create a cloud and rainout/washout field, cloudsn occur where rh>80%
+ do jy=0,nyn(l)-1
+ do ix=0,nxn(l)-1
+ rain_cloud_above=0
+ lsp=lsprecn(ix,jy,1,n,l)
+ convp=convprecn(ix,jy,1,n,l)
+ cloudsnh(ix,jy,n,l)=0
+ do kz_inv=1,nz-1
+ kz=nz-kz_inv+1
+ pressure=rhon(ix,jy,kz,n,l)*r_air*ttn(ix,jy,kz,n,l)
+ rh=qvn(ix,jy,kz,n,l)/f_qvsat(pressure,ttn(ix,jy,kz,n,l))
+ cloudsn(ix,jy,kz,n,l)=0
+ if (rh.gt.0.8) then ! in cloud
+ if ((lsp.gt.0.01).or.(convp.gt.0.01)) then
+ rain_cloud_above=1
+ cloudsnh(ix,jy,n,l)=cloudsnh(ix,jy,n,l)+ &
+ height(kz)-height(kz-1)
+ if (lsp.ge.convp) then
+ cloudsn(ix,jy,kz,n,l)=3 ! lsp dominated rainout
+ else
+ cloudsn(ix,jy,kz,n,l)=2 ! convp dominated rainout
+ endif
+ else ! no precipitation
+ cloudsn(ix,jy,kz,n,l)=1 ! cloud
+ endif
+ else ! no cloud
+ if (rain_cloud_above.eq.1) then ! scavenging
+ if (lsp.ge.convp) then
+ cloudsn(ix,jy,kz,n,l)=5 ! lsp dominated washout
+ else
+ cloudsn(ix,jy,kz,n,l)=4 ! convp dominated washout
+ endif
+ endif
+ endif
+ end do
+ end do
+ end do
+
+ end do
+
+end subroutine verttransform_nests
diff --git a/src/wetdepo.f90 b/src/wetdepo.f90
new file mode 100644
index 0000000000000000000000000000000000000000..ee848e4f6c5009ed36976060e3a0d41bdd9e23b3
--- /dev/null
+++ b/src/wetdepo.f90
@@ -0,0 +1,438 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine wetdepo(itime,ltsample,loutnext)
+ ! i i i
+ !*****************************************************************************
+ ! *
+ ! Calculation of wet deposition using the concept of scavenging coefficients.*
+ ! For lack of detailed information, washout and rainout are jointly treated. *
+ ! It is assumed that precipitation does not occur uniformly within the whole *
+ ! grid cell, but that only a fraction of the grid cell experiences rainfall. *
+ ! This fraction is parameterized from total cloud cover and rates of large *
+ ! scale and convective precipitation. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 1 December 1996 *
+ ! *
+ ! Correction by Petra Seibert, Sept 2002: *
+ ! use centred precipitation data for integration *
+ ! Code may not be correct for decay of deposition! *
+ ! *
+ ! Modification by Sabine Eckhart to introduce a new in-/below-cloud
+ ! scheme, not dated
+ ! Petra Seibert, 2011/2012: Fixing some deficiencies in this modification
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! cc [0-1] total cloud cover *
+ ! convp [mm/h] convective precipitation rate *
+ ! grfraction [0-1] fraction of grid, for which precipitation occurs *
+ ! ix,jy indices of output grid cell for each particle *
+ ! itime [s] actual simulation time [s] *
+ ! jpart particle index *
+ ! ldeltat [s] interval since radioactive decay was computed *
+ ! lfr, cfr area fraction covered by precipitation for large scale *
+ ! and convective precipitation (dependent on prec. rate) *
+ ! loutnext [s] time for which gridded deposition is next output *
+ ! loutstep [s] interval at which gridded deposition is output *
+ ! lsp [mm/h] large scale precipitation rate *
+ ! ltsample [s] interval over which mass is deposited *
+ ! prec [mm/h] precipitation rate in subgrid, where precipitation occurs*
+ ! wetdeposit mass that is wet deposited *
+ ! wetgrid accumulated deposited mass on output grid *
+ ! wetscav scavenging coefficient *
+ ! *
+ ! Constants: *
+ ! *
+ !*****************************************************************************
+
+ use point_mod
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: jpart,itime,ltsample,loutnext,ldeltat,i,j,ix,jy
+ integer :: ngrid,itage,nage,hz,il,interp_time, n , clouds_v !NIK scheme
+ integer :: kz !PS scheme
+ integer :: ks, kp, n1,n2, icbot,ictop, indcloud
+ integer :: scheme_number ! NIK==1, PS ==2
+ real :: S_i, act_temp, cl, cle ! in cloud scavenging
+ real :: clouds_h ! cloud height for the specific grid point
+ real :: xtn,ytn,lsp,convp,cc,grfraction,prec,wetscav, precsub,f
+ real :: wetdeposit(maxspec),restmass
+ real,parameter :: smallnum = tiny(0.0) ! smallest number that can be handled
+ save lfr,cfr
+
+
+ real :: lfr(5) = (/ 0.5,0.65,0.8,0.9,0.95/)
+ real :: cfr(5) = (/ 0.4,0.55,0.7,0.8,0.9 /)
+
+ ! Compute interval since radioactive decay of deposited mass was computed
+ !************************************************************************
+
+ if (itime.le.loutnext) then
+ ldeltat=itime-(loutnext-loutstep)
+ else ! first half of next interval
+ ldeltat=itime-loutnext
+ endif
+
+
+ ! Loop over all particles
+ !************************
+
+ do jpart=1,numpart
+ if (itra1(jpart).eq.-999999999) goto 20
+ if(ldirect.eq.1)then
+ if (itra1(jpart).gt.itime) goto 20
+ else
+ if (itra1(jpart).lt.itime) goto 20
+ endif
+ ! Determine age class of the particle
+ itage=abs(itra1(jpart)-itramem(jpart))
+ do nage=1,nageclass
+ if (itage.lt.lage(nage)) goto 33
+ end do
+33 continue
+
+
+ ! Determine which nesting level to be used
+ !*****************************************
+
+ ngrid=0
+ do j=numbnests,1,-1
+ if ((xtra1(jpart).gt.xln(j)).and.(xtra1(jpart).lt.xrn(j)).and. &
+ (ytra1(jpart).gt.yln(j)).and.(ytra1(jpart).lt.yrn(j))) then
+ ngrid=j
+ goto 23
+ endif
+ end do
+23 continue
+
+
+ ! Determine nested grid coordinates
+ !**********************************
+
+ if (ngrid.gt.0) then
+ xtn=(xtra1(jpart)-xln(ngrid))*xresoln(ngrid)
+ ytn=(ytra1(jpart)-yln(ngrid))*yresoln(ngrid)
+ ix=int(xtn)
+ jy=int(ytn)
+ else
+ ix=int(xtra1(jpart))
+ jy=int(ytra1(jpart))
+ endif
+
+
+ ! Interpolate large scale precipitation, convective precipitation and
+ ! total cloud cover
+ ! Note that interpolated time refers to itime-0.5*ltsample [PS]
+ !********************************************************************
+ interp_time=nint(itime-0.5*ltsample)
+
+! PS nest case still needs to be implemented!!
+! if (ngrid.eq.0) then
+! call interpol_rain(lsprec,convprec,tcc,nxmax,nymax, &
+! 1,nx,ny,memind,real(xtra1(jpart)),real(ytra1(jpart)),1, &
+! memtime(1),memtime(2),interp_time,lsp,convp,cc)
+ call interpol_rain(lsprec,convprec,tcc, &
+ icloudbot,icloudthck,nxmax,nymax,1,nx,ny, &
+ memind,sngl(xtra1(jpart)),sngl(ytra1(jpart)),1,memtime(1), &
+ memtime(2),interp_time,lsp,convp,cc,icbot,ictop,icmv)
+! else
+! call interpol_rain_nests(lsprecn,convprecn,tccn, &
+! nxmaxn,nymaxn,1,maxnests,ngrid,nxn,nyn,memind,xtn,ytn,1, &
+! memtime(1),memtime(2),interp_time,lsp,convp,cc)
+! endif
+
+
+ ! if ((lsp.lt.0.01).and.(convp.lt.0.01)) goto 20
+ !PS 2012: subtract a small value, eg 0.01 mm/h, to remove spurious precip
+ prec = lsp+convp
+ precsub = 0.01
+ if (prec .lt. precsub) then
+ goto 20
+ else
+ f = (prec-precsub)/prec
+ lsp = f*lsp
+ convp = f*convp
+ endif
+
+
+ ! get the level were the actual particle is in
+ do il=2,nz
+ if (height(il).gt.ztra1(jpart)) then
+ !hz=il-1
+ kz=il-1
+ goto 26
+ endif
+ end do
+26 continue
+
+ n=memind(2)
+ if (abs(memtime(1)-interp_time).lt.abs(memtime(2)-interp_time)) &
+ n=memind(1)
+
+ ! if there is no precipitation or the particle is above the clouds no
+ ! scavenging is done
+
+!old scheme
+! if (ngrid.eq.0) then
+! clouds_v=clouds(ix,jy,hz,n)
+! clouds_h=cloudsh(ix,jy,n)
+! else
+! clouds_v=cloudsn(ix,jy,hz,n,ngrid)
+! clouds_h=cloudsnh(ix,jy,n,ngrid)
+! endif
+! !write(*,*) 'there is
+! ! + precipitation',(clouds(ix,jy,ihz,n),ihz=1,20),lsp,convp,hz
+! if (clouds_v.le.1) goto 20
+! !write (*,*) 'there is scavenging'
+
+ ! PS: part of 2011/2012 fix
+
+ if (ztra1(jpart) .le. float(ictop)) then
+ if (ztra1(jpart) .gt. float(icbot)) then
+ indcloud = 2 ! in-cloud
+ else
+ indcloud = 1 ! below-cloud
+ endif
+ elseif (ictop .eq. icmv) then
+ indcloud = 0 ! no cloud found, use old scheme
+ else
+ goto 20 ! above cloud
+ endif
+
+
+ ! 1) Parameterization of the the area fraction of the grid cell where the
+ ! precipitation occurs: the absolute limit is the total cloud cover, but
+ ! for low precipitation rates, an even smaller fraction of the grid cell
+ ! is used. Large scale precipitation occurs over larger areas than
+ ! convective precipitation.
+ !**************************************************************************
+
+ if (lsp.gt.20.) then
+ i=5
+ else if (lsp.gt.8.) then
+ i=4
+ else if (lsp.gt.3.) then
+ i=3
+ else if (lsp.gt.1.) then
+ i=2
+ else
+ i=1
+ endif
+
+ if (convp.gt.20.) then
+ j=5
+ else if (convp.gt.8.) then
+ j=4
+ else if (convp.gt.3.) then
+ j=3
+ else if (convp.gt.1.) then
+ j=2
+ else
+ j=1
+ endif
+
+ grfraction=max(0.05,cc*(lsp*lfr(i)+convp*cfr(j))/(lsp+convp))
+
+ ! 2) Computation of precipitation rate in sub-grid cell
+ !******************************************************
+
+ prec=(lsp+convp)/grfraction
+
+ ! 3) Computation of scavenging coefficients for all species
+ ! Computation of wet deposition
+ !**********************************************************
+
+ do ks=1,nspec ! loop over species
+ wetdeposit(ks)=0.
+
+
+ !conflicting changes to the same routine: 1=NIK 2 =PS
+ scheme_number=2
+ if (scheme_number.eq.1) then !NIK
+
+ if (weta(ks).gt.0.) then
+ if (clouds_v.ge.4) then
+ ! BELOW CLOUD SCAVENGING
+ ! for aerosols and not highliy soluble substances weta=5E-6
+ wetscav=weta(ks)*prec**wetb(ks) ! scavenging coeff.
+ ! write(*,*) 'bel. wetscav: ',wetscav
+
+ else ! below_cloud clouds_v is lt 4 and gt 1 -> in cloud scavenging
+ ! IN CLOUD SCAVENGING
+ ! BUGFIX tt for nested fields should be ttn
+ ! sec may 2008
+ if (ngrid.gt.0) then
+ act_temp=ttn(ix,jy,hz,n,ngrid)
+ else
+ act_temp=tt(ix,jy,hz,n)
+ endif
+
+! NIK 31.01.2013: SPECIES defined parameters for the in-cloud scavening
+! weta_in=2.0E-07 (default)
+! wetb_in=0.36 (default)
+! wetc_in=0.9 (default)
+! wetd_in: Scaling factor for the total in-cloud scavenging (default 1.0-no scaling)
+ cl=weta_in(ks)*prec**wetb_in(ks)
+ if (dquer(ks).gt.0) then ! is particle
+ S_i=wetc_in(ks)/cl
+ else ! is gas
+ cle=(1-cl)/(henry(ks)*(r_air/3500.)*act_temp)+cl
+ S_i=1/cle
+ endif
+ wetscav=S_i*prec/3.6E6/clouds_h/wetd_in(ks)
+ ! write(*,*) 'in. wetscav:'
+ ! + ,wetscav,cle,cl,act_temp,prec,clouds_h
+ endif
+
+
+ ! if (wetscav.le.0) write (*,*) 'neg, or 0 wetscav!'
+ ! + ,wetscav,cle,cl,act_temp,prec,clouds_h,clouds_v
+ wetdeposit(ks)=xmass1(jpart,ks)* &
+ (1.-exp(-wetscav*abs(ltsample)))*grfraction ! wet deposition
+ ! new particle mass:
+ ! if (wetdeposit(ks).gt.0) then
+ ! write(*,*) 'wetdepo: ',wetdeposit(ks),ks
+ ! endif
+ restmass = xmass1(jpart,ks)-wetdeposit(ks)
+ if (ioutputforeachrelease.eq.1) then
+ kp=npoint(jpart)
+ else
+ kp=1
+ endif
+ if (restmass .gt. smallnum) then
+ xmass1(jpart,ks)=restmass
+ !ccccccccccccccc depostatistic
+ ! wetdepo_sum(ks,kp)=wetdepo_sum(ks,kp)+wetdeposit(ks)
+ !ccccccccccccccc depostatistic
+ else
+ xmass1(jpart,ks)=0.
+ endif
+ ! Correct deposited mass to the last time step when radioactive decay of
+ ! gridded deposited mass was calculated
+ if (decay(ks).gt.0.) then
+ wetdeposit(ks)=wetdeposit(ks) &
+ *exp(abs(ldeltat)*decay(ks))
+ endif
+ else ! weta(k)
+ wetdeposit(ks)=0.
+ endif ! weta(k)
+
+ elseif (scheme_number.eq.2) then ! PS
+
+!PS indcloud=0 ! Use this for FOR TESTING,
+!PS will skip the new in/below cloud method !!!
+
+ if (weta(ks).gt.0.) then
+ if (indcloud .eq. 1) then ! BELOW CLOUD SCAVENGING
+!C for aerosols and not highliy soluble substances weta=5E-6
+ wetscav=weta(ks)*prec**wetb(ks) ! scavenging coeff.
+!c write(*,*) 'bel. wetscav: ',wetscav
+ elseif (indcloud .eq. 2) then ! IN CLOUD SCAVENGING
+ if (ngrid.gt.0) then
+ act_temp=ttn(ix,jy,kz,n,ngrid)
+ else
+ act_temp=tt(ix,jy,kz,n)
+ endif
+
+! from NIK
+! weta_in=2.0E-07 (default)
+! wetb_in=0.36 (default)
+! wetc_in=0.9 (default)
+
+
+ cl=2E-7*prec**0.36
+ if (dquer(ks).gt.0) then ! is particle
+ S_i=0.9/cl
+ else ! is gas
+ cle=(1-cl)/(henry(ks)*(r_air/3500.)*act_temp)+cl
+ S_i=1/cle
+ endif
+ wetscav=S_i*prec/3.6E6/(ictop-icbot) ! 3.6e6 converts mm/h to m/s
+ else ! PS: no cloud diagnosed, old scheme,
+!CPS using with fixed a,b for simplicity, one may wish to change!!
+ wetscav = 1.e-4*prec**0.62
+ endif
+
+
+ wetdeposit(ks)=xmass1(jpart,ks)* &
+ ! (1.-exp(-wetscav*abs(ltsample)))*fraction ! wet deposition
+ (1.-exp(-wetscav*abs(ltsample)))*grfraction ! fraction = grfraction (PS)
+ restmass = xmass1(jpart,ks)-wetdeposit(ks)
+ if (ioutputforeachrelease.eq.1) then
+ kp=npoint(jpart)
+ else
+ kp=1
+ endif
+ if (restmass .gt. smallnum) then
+ xmass1(jpart,ks)=restmass
+!cccccccccccccccc depostatistic
+!c wetdepo_sum(ks,kp)=wetdepo_sum(ks,kp)+wetdeposit(ks)
+!cccccccccccccccc depostatistic
+ else
+ xmass1(jpart,ks)=0.
+ endif
+!C Correct deposited mass to the last time step when radioactive decay of
+!C gridded deposited mass was calculated
+ if (decay(ks).gt.0.) then
+ wetdeposit(ks)=wetdeposit(ks)*exp(abs(ldeltat)*decay(ks))
+ endif
+ else ! weta(k)<0
+ wetdeposit(ks)=0.
+ endif
+
+ endif !on scheme
+
+
+
+ end do
+
+ ! Sabine Eckhard, June 2008 create deposition runs only for forward runs
+ ! Add the wet deposition to accumulated amount on output grid and nested output grid
+ !*****************************************************************************
+
+! if (ldirect.eq.1) then
+! call wetdepokernel(nclass(jpart),wetdeposit,real(xtra1(jpart)), &
+! real(ytra1(jpart)),nage,kp)
+! if (nested_output.eq.1) call wetdepokernel_nest(nclass(jpart), &
+! wetdeposit,real(xtra1(jpart)),real(ytra1(jpart)), &
+! nage,kp)
+! endif
+
+ !PS
+ if (ldirect.eq.1) then
+ call wetdepokernel(nclass(jpart),wetdeposit, &
+ sngl(xtra1(jpart)),sngl(ytra1(jpart)),nage,kp)
+ if (nested_output.eq.1) &
+ call wetdepokernel_nest(nclass(jpart),wetdeposit, &
+ sngl(xtra1(jpart)),sngl(ytra1(jpart)),nage,kp)
+ endif
+
+
+20 continue
+ end do
+
+end subroutine wetdepo
diff --git a/src/wetdepokernel.f90 b/src/wetdepokernel.f90
new file mode 100644
index 0000000000000000000000000000000000000000..e90fca67ddae51b666a149a5d7e9105fa3fca103
--- /dev/null
+++ b/src/wetdepokernel.f90
@@ -0,0 +1,110 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine wetdepokernel(nunc,deposit,x,y,nage,kp)
+ ! i i i i i
+ !*****************************************************************************
+ ! *
+ ! Attribution of the deposition from an individual particle to the *
+ ! deposition fields using a uniform kernel with bandwidths dxout and dyout.*
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 26 December 1996 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! nunc uncertainty class of the respective particle *
+ ! nage age class of the respective particle *
+ ! deposit amount (kg) to be deposited *
+ ! *
+ !*****************************************************************************
+
+ use unc_mod
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ real :: x,y,deposit(maxspec),ddx,ddy,xl,yl,wx,wy,w
+ integer :: ix,jy,ixp,jyp,nunc,nage,ks,kp
+
+ xl=(x*dx+xoutshift)/dxout
+ yl=(y*dy+youtshift)/dyout
+ ix=int(xl)
+ jy=int(yl)
+ ddx=xl-real(ix) ! distance to left cell border
+ ddy=yl-real(jy) ! distance to lower cell border
+
+ if (ddx.gt.0.5) then
+ ixp=ix+1
+ wx=1.5-ddx
+ else
+ ixp=ix-1
+ wx=0.5+ddx
+ endif
+
+ if (ddy.gt.0.5) then
+ jyp=jy+1
+ wy=1.5-ddy
+ else
+ jyp=jy-1
+ wy=0.5+ddy
+ endif
+
+
+ ! Determine mass fractions for four grid points
+ !**********************************************
+
+ do ks=1,nspec
+
+ if ((ix.ge.0).and.(jy.ge.0).and.(ix.le.numxgrid-1).and. &
+ (jy.le.numygrid-1)) then
+ w=wx*wy
+ wetgridunc(ix,jy,ks,kp,nunc,nage)= &
+ wetgridunc(ix,jy,ks,kp,nunc,nage)+deposit(ks)*w
+ endif
+
+ if ((ixp.ge.0).and.(jyp.ge.0).and.(ixp.le.numxgrid-1).and. &
+ (jyp.le.numygrid-1)) then
+ w=(1.-wx)*(1.-wy)
+ wetgridunc(ixp,jyp,ks,kp,nunc,nage)= &
+ wetgridunc(ixp,jyp,ks,kp,nunc,nage)+deposit(ks)*w
+ endif
+
+ if ((ixp.ge.0).and.(jy.ge.0).and.(ixp.le.numxgrid-1).and. &
+ (jy.le.numygrid-1)) then
+ w=(1.-wx)*wy
+ wetgridunc(ixp,jy,ks,kp,nunc,nage)= &
+ wetgridunc(ixp,jy,ks,kp,nunc,nage)+deposit(ks)*w
+ endif
+
+ if ((ix.ge.0).and.(jyp.ge.0).and.(ix.le.numxgrid-1).and. &
+ (jyp.le.numygrid-1)) then
+ w=wx*(1.-wy)
+ wetgridunc(ix,jyp,ks,kp,nunc,nage)= &
+ wetgridunc(ix,jyp,ks,kp,nunc,nage)+deposit(ks)*w
+ endif
+ end do
+
+end subroutine wetdepokernel
diff --git a/src/wetdepokernel_nest.f90 b/src/wetdepokernel_nest.f90
new file mode 100644
index 0000000000000000000000000000000000000000..f3aea688452f87d4ff85b0c920c86fbaf97faa15
--- /dev/null
+++ b/src/wetdepokernel_nest.f90
@@ -0,0 +1,117 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine wetdepokernel_nest &
+ (nunc,deposit,x,y,nage,kp)
+ ! i i i i i i
+ !*****************************************************************************
+ ! *
+ ! Attribution of the deposition from an individual particle to the *
+ ! nested deposition fields using a uniform kernel with bandwidths *
+ ! dxoutn and dyoutn. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 26 December 1996 *
+ ! *
+ ! 2 September 2004: Adaptation from wetdepokernel. *
+ ! *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! nunc uncertainty class of the respective particle *
+ ! nage age class of the respective particle *
+ ! deposit amount (kg) to be deposited *
+ ! *
+ !*****************************************************************************
+
+ use unc_mod
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ real :: x,y,deposit(maxspec),ddx,ddy,xl,yl,wx,wy,w
+ integer :: ix,jy,ixp,jyp,ks,kp,nunc,nage
+
+
+
+ xl=(x*dx+xoutshiftn)/dxoutn
+ yl=(y*dy+youtshiftn)/dyoutn
+ ix=int(xl)
+ jy=int(yl)
+ ddx=xl-real(ix) ! distance to left cell border
+ ddy=yl-real(jy) ! distance to lower cell border
+
+ if (ddx.gt.0.5) then
+ ixp=ix+1
+ wx=1.5-ddx
+ else
+ ixp=ix-1
+ wx=0.5+ddx
+ endif
+
+ if (ddy.gt.0.5) then
+ jyp=jy+1
+ wy=1.5-ddy
+ else
+ jyp=jy-1
+ wy=0.5+ddy
+ endif
+
+
+ ! Determine mass fractions for four grid points
+ !**********************************************
+
+ do ks=1,nspec
+
+ if ((ix.ge.0).and.(jy.ge.0).and.(ix.le.numxgridn-1).and. &
+ (jy.le.numygridn-1)) then
+ w=wx*wy
+ wetgriduncn(ix,jy,ks,kp,nunc,nage)= &
+ wetgriduncn(ix,jy,ks,kp,nunc,nage)+deposit(ks)*w
+ endif
+
+ if ((ixp.ge.0).and.(jyp.ge.0).and.(ixp.le.numxgridn-1).and. &
+ (jyp.le.numygridn-1)) then
+ w=(1.-wx)*(1.-wy)
+ wetgriduncn(ixp,jyp,ks,kp,nunc,nage)= &
+ wetgriduncn(ixp,jyp,ks,kp,nunc,nage)+deposit(ks)*w
+ endif
+
+ if ((ixp.ge.0).and.(jy.ge.0).and.(ixp.le.numxgridn-1).and. &
+ (jy.le.numygridn-1)) then
+ w=(1.-wx)*wy
+ wetgriduncn(ixp,jy,ks,kp,nunc,nage)= &
+ wetgriduncn(ixp,jy,ks,kp,nunc,nage)+deposit(ks)*w
+ endif
+
+ if ((ix.ge.0).and.(jyp.ge.0).and.(ix.le.numxgridn-1).and. &
+ (jyp.le.numygridn-1)) then
+ w=wx*(1.-wy)
+ wetgriduncn(ix,jyp,ks,kp,nunc,nage)= &
+ wetgriduncn(ix,jyp,ks,kp,nunc,nage)+deposit(ks)*w
+ endif
+
+ end do
+end subroutine wetdepokernel_nest
diff --git a/src/windalign.f90 b/src/windalign.f90
new file mode 100644
index 0000000000000000000000000000000000000000..ba77f0728eaaa22a854f05b5c2423be680934fec
--- /dev/null
+++ b/src/windalign.f90
@@ -0,0 +1,74 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine windalign(u,v,ffap,ffcp,ux,vy)
+ ! i i i i o o
+ !*****************************************************************************
+ ! *
+ ! Transformation from along- and cross-wind components to u and v *
+ ! components. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 3 June 1996 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! ffap turbulent wind in along wind direction *
+ ! ffcp turbulent wind in cross wind direction *
+ ! u main wind component in x direction *
+ ! ux turbulent wind in x direction *
+ ! v main wind component in y direction *
+ ! vy turbulent wind in y direction *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ real :: u,v,ffap,ffcp,ux,vy,ffinv,ux1,ux2,vy1,vy2,sinphi,cosphi
+ real,parameter :: eps=1.e-30
+
+
+ ! Transform along wind components
+ !********************************
+
+ ffinv=1./max(sqrt(u*u+v*v),eps)
+ sinphi=v*ffinv
+ vy1=sinphi*ffap
+ cosphi=u*ffinv
+ ux1=cosphi*ffap
+
+
+ ! Transform cross wind components
+ !********************************
+
+ ux2=-sinphi*ffcp
+ vy2=cosphi*ffcp
+
+
+ ! Add contributions from along and cross wind components
+ !*******************************************************
+
+ ux=ux1+ux2
+ vy=vy1+vy2
+
+end subroutine windalign
diff --git a/src/writeheader.f90 b/src/writeheader.f90
new file mode 100644
index 0000000000000000000000000000000000000000..c624592a0911e75baba55716ac0e46252950b511
--- /dev/null
+++ b/src/writeheader.f90
@@ -0,0 +1,156 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine writeheader
+
+ !*****************************************************************************
+ ! *
+ ! This routine produces a file header containing basic information on the *
+ ! settings of the FLEXPART run. *
+ ! The header file is essential and must be read in by any postprocessing *
+ ! program before reading in the output data. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 7 August 2002 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! xlon longitude *
+ ! xl model x coordinate *
+ ! ylat latitude *
+ ! yl model y coordinate *
+ ! *
+ !*****************************************************************************
+
+ use point_mod
+ use outg_mod
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: jjjjmmdd,ihmmss,i,ix,jy,j
+ real :: xp1,yp1,xp2,yp2
+
+
+ !************************
+ ! Open header output file
+ !************************
+
+ open(unitheader,file=path(2)(1:length(2))//'header', &
+ form='unformatted',err=998)
+
+
+ ! Write the header information
+ !*****************************
+
+ if (ldirect.eq.1) then
+ write(unitheader) ibdate,ibtime, trim(flexversion)
+ else
+ write(unitheader) iedate,ietime, trim(flexversion)
+ endif
+
+ ! Write info on output interval, averaging time, sampling time
+ !*************************************************************
+
+ write(unitheader) loutstep,loutaver,loutsample
+
+ ! Write information on output grid setup
+ !***************************************
+
+ write(unitheader) outlon0,outlat0,numxgrid,numygrid, &
+ dxout,dyout
+ write(unitheader) numzgrid,(outheight(i),i=1,numzgrid)
+
+ call caldate(bdate,jjjjmmdd,ihmmss)
+ write(unitheader) jjjjmmdd,ihmmss
+
+ ! Write number of species, and name for each species (+extra name for depositions)
+ ! Indicate the dimension of the fields (i.e., 1 for deposition fields, numzgrid for
+ ! concentration fields
+ !*****************************************************************************
+
+ write(unitheader) 3*nspec,maxpointspec_act
+ do i=1,nspec
+ write(unitheader) 1,'WD_'//species(i)(1:7)
+ write(unitheader) 1,'DD_'//species(i)(1:7)
+ write(unitheader) numzgrid,species(i)
+ end do
+
+ ! Write information on release points: total number, then for each point:
+ ! start, end, coordinates, # of particles, name, mass
+ !************************************************************************
+
+ write(unitheader) numpoint
+ do i=1,numpoint
+ write(unitheader) ireleasestart(i),ireleaseend(i),kindz(i)
+ xp1=xpoint1(i)*dx+xlon0
+ yp1=ypoint1(i)*dy+ylat0
+ xp2=xpoint2(i)*dx+xlon0
+ yp2=ypoint2(i)*dy+ylat0
+ write(unitheader) xp1,yp1,xp2,yp2,zpoint1(i),zpoint2(i)
+ write(unitheader) npart(i),1
+ if (numpoint.le.1000) then
+ write(unitheader) compoint(i)
+ else
+ write(unitheader) compoint(1001)
+ endif
+ do j=1,nspec
+ write(unitheader) xmass(i,j)
+ write(unitheader) xmass(i,j)
+ write(unitheader) xmass(i,j)
+ end do
+ end do
+
+ ! Write information on some model switches
+ !*****************************************
+
+ write(unitheader) method,lsubgrid,lconvection, &
+ ind_source,ind_receptor
+
+ ! Write age class information
+ !****************************
+
+ write(unitheader) nageclass,(lage(i),i=1,nageclass)
+
+
+ ! Write topography to output file
+ !********************************
+
+ do ix=0,numxgrid-1
+ write(unitheader) (oroout(ix,jy),jy=0,numygrid-1)
+ end do
+ close(unitheader)
+
+ return
+
+
+998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### '
+ write(*,*) ' #### '//path(2)(1:length(2))//'header'//' #### '
+ write(*,*) ' #### CANNOT BE OPENED. IF A FILE WITH THIS #### '
+ write(*,*) ' #### NAME ALREADY EXISTS, DELETE IT AND START #### '
+ write(*,*) ' #### THE PROGRAM AGAIN. #### '
+ stop
+
+end subroutine writeheader
diff --git a/src/writeheader_nest.f90 b/src/writeheader_nest.f90
new file mode 100644
index 0000000000000000000000000000000000000000..8f3eb7177a25e252d19bf5012581eaa2b4bdbd7e
--- /dev/null
+++ b/src/writeheader_nest.f90
@@ -0,0 +1,156 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine writeheader_nest
+
+ !*****************************************************************************
+ ! *
+ ! This routine produces a file header containing basic information on the *
+ ! settings of the FLEXPART run. *
+ ! The header file is essential and must be read in by any postprocessing *
+ ! program before reading in the output data. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 7 August 2002 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! xlon longitude *
+ ! xl model x coordinate *
+ ! ylat latitude *
+ ! yl model y coordinate *
+ ! *
+ !*****************************************************************************
+
+ use point_mod
+ use outg_mod
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: jjjjmmdd,ihmmss,i,ix,jy,j
+ real :: xp1,yp1,xp2,yp2
+
+
+ !************************
+ ! Open header output file
+ !************************
+
+ open(unitheader,file=path(2)(1:length(2))//'header_nest', &
+ form='unformatted',err=998)
+
+
+ ! Write the header information
+ !*****************************
+
+ if (ldirect.eq.1) then
+ write(unitheader) ibdate,ibtime,'FLEXPART V8.2'
+ else
+ write(unitheader) iedate,ietime,'FLEXPART V8.2'
+ endif
+
+ ! Write info on output interval, averaging time, sampling time
+ !*************************************************************
+
+ write(unitheader) loutstep,loutaver,loutsample
+
+ ! Write information on output grid setup
+ !***************************************
+
+ write(unitheader) outlon0n,outlat0n,numxgridn,numygridn, &
+ dxoutn,dyoutn
+ write(unitheader) numzgrid,(outheight(i),i=1,numzgrid)
+
+ call caldate(bdate,jjjjmmdd,ihmmss)
+ write(unitheader) jjjjmmdd,ihmmss
+
+ ! Write number of species, and name for each species (+extra name for depositions)
+ ! Indicate the dimension of the fields (i.e., 1 for deposition fields, numzgrid for
+ ! concentration fields
+ !*****************************************************************************
+
+ write(unitheader) 3*nspec,maxpointspec_act
+ do i=1,nspec
+ write(unitheader) 1,'WD_'//species(i)(1:7)
+ write(unitheader) 1,'DD_'//species(i)(1:7)
+ write(unitheader) numzgrid,species(i)
+ end do
+
+ ! Write information on release points: total number, then for each point:
+ ! start, end, coordinates, # of particles, name, mass
+ !************************************************************************
+
+ write(unitheader) numpoint
+ do i=1,numpoint
+ write(unitheader) ireleasestart(i),ireleaseend(i),kindz(i)
+ xp1=xpoint1(i)*dx+xlon0
+ yp1=ypoint1(i)*dy+ylat0
+ xp2=xpoint2(i)*dx+xlon0
+ yp2=ypoint2(i)*dy+ylat0
+ write(unitheader) xp1,yp1,xp2,yp2,zpoint1(i),zpoint2(i)
+ write(unitheader) npart(i),1
+ if (numpoint.le.1000) then
+ write(unitheader) compoint(i)
+ else
+ write(unitheader) compoint(1001)
+ endif
+ do j=1,nspec
+ write(unitheader) xmass(i,j)
+ write(unitheader) xmass(i,j)
+ write(unitheader) xmass(i,j)
+ end do
+ end do
+
+ ! Write information on some model switches
+ !*****************************************
+
+ write(unitheader) method,lsubgrid,lconvection, &
+ ind_source,ind_receptor
+
+ ! Write age class information
+ !****************************
+
+ write(unitheader) nageclass,(lage(i),i=1,nageclass)
+
+
+ ! Write topography to output file
+ !********************************
+
+ do ix=0,numxgridn-1
+ write(unitheader) (orooutn(ix,jy),jy=0,numygridn-1)
+ end do
+ close(unitheader)
+
+ return
+
+
+998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### '
+ write(*,*) ' #### '//path(2)(1:length(2))//'header'//' #### '
+ write(*,*) ' #### CANNOT BE OPENED. IF A FILE WITH THIS #### '
+ write(*,*) ' #### NAME ALREADY EXISTS, DELETE IT AND START #### '
+ write(*,*) ' #### THE PROGRAM AGAIN. #### '
+ stop
+
+end subroutine writeheader_nest
diff --git a/src/writeheader_nest_surf.f90 b/src/writeheader_nest_surf.f90
new file mode 100644
index 0000000000000000000000000000000000000000..53cfa06adffe7e3fa8d43c99baec5fba68cd7c64
--- /dev/null
+++ b/src/writeheader_nest_surf.f90
@@ -0,0 +1,156 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine writeheader_nest_surf
+
+ !*****************************************************************************
+ ! *
+ ! This routine produces a file header containing basic information on the *
+ ! settings of the FLEXPART run. *
+ ! The header file is essential and must be read in by any postprocessing *
+ ! program before reading in the output data. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 7 August 2002 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! xlon longitude *
+ ! xl model x coordinate *
+ ! ylat latitude *
+ ! yl model y coordinate *
+ ! *
+ !*****************************************************************************
+
+ use point_mod
+ use outg_mod
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: jjjjmmdd,ihmmss,i,ix,jy,j
+ real :: xp1,yp1,xp2,yp2
+
+
+ !************************
+ ! Open header output file
+ !************************
+
+ open(unitheader,file=path(2)(1:length(2))//'header_nest_grid_time', &
+ form='unformatted',err=998)
+
+
+ ! Write the header information
+ !*****************************
+
+ if (ldirect.eq.1) then
+ write(unitheader) ibdate,ibtime,trim(flexversion)
+ else
+ write(unitheader) iedate,ietime,trim(flexversion)
+ endif
+
+ ! Write info on output interval, averaging time, sampling time
+ !*************************************************************
+
+ write(unitheader) loutstep,loutaver,loutsample
+
+ ! Write information on output grid setup
+ !***************************************
+
+ write(unitheader) outlon0n,outlat0n,numxgridn,numygridn, &
+ dxoutn,dyoutn
+ write(unitheader) 1,(outheight(1),i=1,1)
+
+ call caldate(bdate,jjjjmmdd,ihmmss)
+ write(unitheader) jjjjmmdd,ihmmss
+
+ ! Write number of species, and name for each species (+extra name for depositions)
+ ! Indicate the dimension of the fields (i.e., 1 for deposition fields, numzgrid for
+ ! concentration fields
+ !*****************************************************************************
+
+ write(unitheader) 3*nspec,maxpointspec_act
+ do i=1,nspec
+ write(unitheader) 1,'WD_'//species(i)(1:7)
+ write(unitheader) 1,'DD_'//species(i)(1:7)
+ write(unitheader) 1,species(i)
+ end do
+
+ ! Write information on release points: total number, then for each point:
+ ! start, end, coordinates, # of particles, name, mass
+ !************************************************************************
+
+ write(unitheader) numpoint
+ do i=1,numpoint
+ write(unitheader) ireleasestart(i),ireleaseend(i),kindz(i)
+ xp1=xpoint1(i)*dx+xlon0
+ yp1=ypoint1(i)*dy+ylat0
+ xp2=xpoint2(i)*dx+xlon0
+ yp2=ypoint2(i)*dy+ylat0
+ write(unitheader) xp1,yp1,xp2,yp2,zpoint1(i),zpoint2(i)
+ write(unitheader) npart(i),1
+ if (numpoint.le.1000) then
+ write(unitheader) compoint(i)
+ else
+ write(unitheader) compoint(1001)
+ endif
+ do j=1,nspec
+ write(unitheader) xmass(i,j)
+ write(unitheader) xmass(i,j)
+ write(unitheader) xmass(i,j)
+ end do
+ end do
+
+ ! Write information on some model switches
+ !*****************************************
+
+ write(unitheader) method,lsubgrid,lconvection, &
+ ind_source,ind_receptor
+
+ ! Write age class information
+ !****************************
+
+ write(unitheader) nageclass,(lage(i),i=1,nageclass)
+
+
+ ! Write topography to output file
+ !********************************
+
+ do ix=0,numxgridn-1
+ write(unitheader) (orooutn(ix,jy),jy=0,numygridn-1)
+ end do
+ close(unitheader)
+
+ return
+
+
+998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### '
+ write(*,*) ' #### '//path(2)(1:length(2))//'header'//' #### '
+ write(*,*) ' #### CANNOT BE OPENED. IF A FILE WITH THIS #### '
+ write(*,*) ' #### NAME ALREADY EXISTS, DELETE IT AND START #### '
+ write(*,*) ' #### THE PROGRAM AGAIN. #### '
+ stop
+
+end subroutine writeheader_nest_surf
diff --git a/src/writeheader_surf.f90 b/src/writeheader_surf.f90
new file mode 100644
index 0000000000000000000000000000000000000000..07a659da36ee383e7290c21650c31711bbb1214d
--- /dev/null
+++ b/src/writeheader_surf.f90
@@ -0,0 +1,156 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine writeheader_surf
+
+ !*****************************************************************************
+ ! *
+ ! This routine produces a file header containing basic information on the *
+ ! settings of the FLEXPART run. *
+ ! The header file is essential and must be read in by any postprocessing *
+ ! program before reading in the output data. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 7 August 2002 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! xlon longitude *
+ ! xl model x coordinate *
+ ! ylat latitude *
+ ! yl model y coordinate *
+ ! *
+ !*****************************************************************************
+
+ use point_mod
+ use outg_mod
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: jjjjmmdd,ihmmss,i,ix,jy,j
+ real :: xp1,yp1,xp2,yp2
+
+
+ !************************
+ ! Open header output file
+ !************************
+
+ open(unitheader,file=path(2)(1:length(2))//'header_grid_time', &
+ form='unformatted',err=998)
+
+
+ ! Write the header information
+ !*****************************
+
+ if (ldirect.eq.1) then
+ write(unitheader) ibdate,ibtime, trim(flexversion)
+ else
+ write(unitheader) iedate,ietime, trim(flexversion)
+ endif
+
+ ! Write info on output interval, averaging time, sampling time
+ !*************************************************************
+
+ write(unitheader) loutstep,loutaver,loutsample
+
+ ! Write information on output grid setup
+ !***************************************
+
+ write(unitheader) outlon0,outlat0,numxgrid,numygrid, &
+ dxout,dyout
+ write(unitheader) 1,(outheight(1),i=1,1)
+
+ call caldate(bdate,jjjjmmdd,ihmmss)
+ write(unitheader) jjjjmmdd,ihmmss
+
+ ! Write number of species, and name for each species (+extra name for depositions)
+ ! Indicate the dimension of the fields (i.e., 1 for deposition fields, numzgrid for
+ ! concentration fields
+ !*****************************************************************************
+
+ write(unitheader) 3*nspec,maxpointspec_act
+ do i=1,nspec
+ write(unitheader) 1,'WD_'//species(i)(1:7)
+ write(unitheader) 1,'DD_'//species(i)(1:7)
+ write(unitheader) 1,species(i)
+ end do
+
+ ! Write information on release points: total number, then for each point:
+ ! start, end, coordinates, # of particles, name, mass
+ !************************************************************************
+
+ write(unitheader) numpoint
+ do i=1,numpoint
+ write(unitheader) ireleasestart(i),ireleaseend(i),kindz(i)
+ xp1=xpoint1(i)*dx+xlon0
+ yp1=ypoint1(i)*dy+ylat0
+ xp2=xpoint2(i)*dx+xlon0
+ yp2=ypoint2(i)*dy+ylat0
+ write(unitheader) xp1,yp1,xp2,yp2,zpoint1(i),zpoint2(i)
+ write(unitheader) npart(i),1
+ if (numpoint.le.1000) then
+ write(unitheader) compoint(i)
+ else
+ write(unitheader) compoint(1001)
+ endif
+ do j=1,nspec
+ write(unitheader) xmass(i,j)
+ write(unitheader) xmass(i,j)
+ write(unitheader) xmass(i,j)
+ end do
+ end do
+
+ ! Write information on some model switches
+ !*****************************************
+
+ write(unitheader) method,lsubgrid,lconvection, &
+ ind_source,ind_receptor
+
+ ! Write age class information
+ !****************************
+
+ write(unitheader) nageclass,(lage(i),i=1,nageclass)
+
+
+ ! Write topography to output file
+ !********************************
+
+ do ix=0,numxgrid-1
+ write(unitheader) (oroout(ix,jy),jy=0,numygrid-1)
+ end do
+ close(unitheader)
+
+ return
+
+
+998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### '
+ write(*,*) ' #### '//path(2)(1:length(2))//'header'//' #### '
+ write(*,*) ' #### CANNOT BE OPENED. IF A FILE WITH THIS #### '
+ write(*,*) ' #### NAME ALREADY EXISTS, DELETE IT AND START #### '
+ write(*,*) ' #### THE PROGRAM AGAIN. #### '
+ stop
+
+end subroutine writeheader_surf
diff --git a/src/writeheader_txt.f90 b/src/writeheader_txt.f90
new file mode 100644
index 0000000000000000000000000000000000000000..adb84fa186f9861c6264586098d6c5240cf07765
--- /dev/null
+++ b/src/writeheader_txt.f90
@@ -0,0 +1,190 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+subroutine writeheader_txt
+
+ !*****************************************************************************
+ ! *
+ ! This routine produces a file header containing basic information on the *
+ ! settings of the FLEXPART run. *
+ ! The header file is essential and must be read in by any postprocessing *
+ ! program before reading in the output data. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 7 August 2002 *
+ ! modified IP 2013 for text output *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! xlon longitude *
+ ! xl model x coordinate *
+ ! ylat latitude *
+ ! yl model y coordinate *
+ ! *
+ !*****************************************************************************
+
+ use point_mod
+ use outg_mod
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: jjjjmmdd,ihmmss,i,ix,jy,j
+ real :: xp1,yp1,xp2,yp2
+
+
+ !************************
+ ! Open header output file
+ !************************
+
+ open(unitheader,file=path(2)(1:length(2))//'header_txt', &
+ form='formatted',err=998)
+ open(unitheader_txt,file=path(2)(1:length(2))//'header_txt_releases', &
+ form='formatted',err=998)
+
+
+ ! Write the header information
+ !*****************************
+
+ write(unitheader,*) '# ibdate,ibtime, iedate, ietime, flexversion'
+ write(unitheader,*) ibdate, ibtime, iedate, ietime, trim(flexversion) ! 'FLEXPART V9.0'
+ !if (ldirect.eq.1) then
+ ! write(unitheader,*) ibdate,ibtime,trim(flexversion) ! 'FLEXPART V9.0'
+ !else
+ ! write(unitheader,*) iedate,ietime,trim(flexversion) ! 'FLEXPART V9.0'
+ !endif
+
+ ! Write info on output interval, averaging time, sampling time
+ !*************************************************************
+
+ write(unitheader,*) '# interval, averaging time, sampling time'
+ write(unitheader,*) loutstep,loutaver,loutsample
+
+ ! Write information on output grid setup
+ !***************************************
+
+ write(unitheader,*) '# information on grid setup '
+ write(unitheader,*) '#outlon0,outlat0,numxgrid,numygrid,dxout,dyout'
+ write(unitheader,*) outlon0,outlat0,numxgrid,numygrid, &
+ dxout,dyout
+ write(unitheader,*) '# numzgrid, outheight(.) '
+ write(unitheader,*) numzgrid,(outheight(i),i=1,numzgrid)
+
+ write(unitheader,*) '# jjjjmmdd,ihmmss'
+ call caldate(bdate,jjjjmmdd,ihmmss)
+ write(unitheader,*) jjjjmmdd,ihmmss
+
+ ! Write number of species, and name for each species (+extra name for depositions)
+ ! Indicate the vertical dimension of the fields (i.e., 1 for deposition fields, numzgrid for
+ ! concentration fields
+ !*****************************************************************************
+
+ write(unitheader,*) '# information on species'
+ write(unitheader,*) '# 3*nspec,maxpointspec_act'
+ write(unitheader,*) 3*nspec,maxpointspec_act
+ write(unitheader,*) '# for nspec:'
+ write(unitheader,*) '# 1, WD_ '
+ write(unitheader,*) '# 1, DD_ '
+ write(unitheader,*) '# numzgrid,species'
+ do i=1,nspec
+ write(unitheader,*) 1,'WD_'//species(i)(1:7)
+ write(unitheader,*) 1,'DD_'//species(i)(1:7)
+ write(unitheader,*) numzgrid,species(i)
+ end do
+
+ ! Write information on release points: total number, then for each point:
+ ! start, end, coordinates, # of particles, name, mass
+ !************************************************************************
+
+
+ write(unitheader_txt,*) '# information on release points'
+ write(unitheader_txt,*) '# numpoint'
+ write(unitheader_txt,*) numpoint
+ write(unitheader_txt,*) '# for numpoint:'
+ do i=1,numpoint
+ write(unitheader_txt,*) ireleasestart(i),ireleaseend(i),kindz(i)
+ xp1=xpoint1(i)*dx+xlon0
+ yp1=ypoint1(i)*dy+ylat0
+ xp2=xpoint2(i)*dx+xlon0
+ yp2=ypoint2(i)*dy+ylat0
+ write(unitheader_txt,*) xp1,yp1,xp2,yp2,zpoint1(i),zpoint2(i)
+ write(unitheader_txt,*) npart(i),1
+ if (numpoint.le.1000) then
+ write(unitheader_txt,*) compoint(i)
+ else
+ write(unitheader_txt,*) compoint(1001)
+ endif
+ do j=1,nspec
+ write(unitheader_txt,*) xmass(i,j)
+ write(unitheader_txt,*) xmass(i,j)
+ write(unitheader_txt,*) xmass(i,j)
+ end do
+ end do
+
+ ! Write information on model switches
+ !*****************************************
+
+ write(unitheader,*) '# information on model switches'
+ write(unitheader,*) '# method,lsubgrid,lconvection, ind_source,ind_receptor'
+ write(unitheader,*) method,lsubgrid,lconvection, &
+ ind_source,ind_receptor
+
+ ! Write age class information
+ !****************************
+
+ write(unitheader,*) '# information on age class '
+ write(unitheader,*) nageclass,(lage(i),i=1,nageclass)
+
+
+ !Do not write topography to text output file. Keep it on the binary one
+ !********************************
+
+ !do ix=0,numxgrid-1
+ ! write(unitheader,*) (oroout(ix,jy),jy=0,numygrid-1)
+ !end do
+
+
+
+
+
+ close(unitheader)
+ close(unitheader_txt)
+
+
+! open(unitheader,file=path(2)(1:length(2))//'header_nml', &
+! form='formatted',err=998)
+! write(unitheader,NML=COMMAND)
+! close(unitheader)
+
+ return
+
+
+998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### '
+ write(*,*) ' #### '//path(2)(1:length(2))//'header_txt'//' #### '
+ write(*,*) ' #### CANNOT BE OPENED. IF A FILE WITH THIS #### '
+ write(*,*) ' #### NAME ALREADY EXISTS, DELETE IT AND START #### '
+ write(*,*) ' #### THE PROGRAM AGAIN. #### '
+ stop
+
+end subroutine writeheader_txt
diff --git a/src/xmass_mod.f90 b/src/xmass_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d97c63bc2cd5e0da00cec349e4fdf196ae747541
--- /dev/null
+++ b/src/xmass_mod.f90
@@ -0,0 +1,28 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+module xmass_mod
+
+ implicit none
+
+ real,allocatable, dimension (:) :: xmasssave
+
+end module xmass_mod
diff --git a/src/zenithangle.f90 b/src/zenithangle.f90
new file mode 100644
index 0000000000000000000000000000000000000000..86126f627cec051e9912d2f741a32bb53e5a37cf
--- /dev/null
+++ b/src/zenithangle.f90
@@ -0,0 +1,95 @@
+!**********************************************************************
+! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
+! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
+! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
+! *
+! This file is part of FLEXPART. *
+! *
+! FLEXPART is free software: you can redistribute it and/or modify *
+! it under the terms of the GNU General Public License as published by*
+! the Free Software Foundation, either version 3 of the License, or *
+! (at your option) any later version. *
+! *
+! FLEXPART is distributed in the hope that it will be useful, *
+! but WITHOUT ANY WARRANTY; without even the implied warranty of *
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
+! GNU General Public License for more details. *
+! *
+! You should have received a copy of the GNU General Public License *
+! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
+!**********************************************************************
+
+real function zenithangle(ylat,xlon,jul)
+
+ !*********************************************************************
+ ! *
+ ! Author: G. WOTAWA *
+ ! Date: 1993-11-17 *
+ ! Project: POP-M *
+ ! Last update: *
+ ! *
+ !*********************************************************************
+ ! *
+ ! DESCRIPTION: This function returns the sinus of solar *
+ ! elevation as a function of geographic longitude, *
+ ! latitude and GMT-Time. *
+ ! *
+ !*********************************************************************
+ ! *
+ ! INPUT: *
+ ! *
+ ! ylat geographical latitude [DEG] *
+ ! xlon geographical longitude [DEG] *
+ ! jjjj Year *
+ ! mm Month *
+ ! dd Day *
+ ! hh Hour *
+ ! minute Minute *
+ ! *
+ !*********************************************************************
+
+ use par_mod, only: dp
+
+ implicit none
+
+ integer :: jjjj,mm,id,iu,minute,yyyymmdd,hhmmss
+ integer :: ndaynum
+ real :: sinsol,solelev,ylat,xlon
+ real :: rnum,rylat,ttime,dekl,rdekl,eq
+ real,parameter :: pi=3.1415927
+ real(kind=dp) :: jul
+
+ call caldate(jul,yyyymmdd,hhmmss)
+ jjjj=yyyymmdd/10000
+ mm=yyyymmdd/100-jjjj*100
+ id=yyyymmdd-jjjj*10000-mm*100
+ iu=hhmmss/10000
+ minute=hhmmss/100-100*iu
+
+ ndaynum=31*(mm-1)+id
+ if(mm.gt.2) ndaynum=ndaynum-int(0.4*mm+2.3)
+ if((mm.gt.2).and.(jjjj/4*4.eq.jjjj)) ndaynum=ndaynum+1
+
+ rnum=2.*pi*ndaynum/365.
+ rylat=pi*ylat/180.
+ ttime=real(iu)+real(minute)/60.
+
+ dekl=0.396+3.631*sin(rnum)+0.038*sin(2.*rnum)+0.077*sin(3.*rnum)- &
+ 22.97*cos(rnum)-0.389*cos(2.*rnum)-0.158*cos(3.*rnum)
+ rdekl=pi*dekl/180.
+
+ eq=(0.003-7.343*sin(rnum)-9.47*sin(2.*rnum)- &
+ 0.329*sin(3.*rnum)-0.196*sin(4.*rnum)+ &
+ 0.552*cos(rnum)-3.020*cos(2.*rnum)- &
+ 0.076*cos(3.*rnum)-0.125*cos(4.*rnum))/60.
+
+ sinsol=sin(rylat)*sin(rdekl)+cos(rylat)*cos(rdekl)* &
+ cos((ttime-12.+xlon/15.+eq)*pi/12.)
+ ! Calculate the maximum solar elevation on that day
+ !sinsol=sin(rylat)*sin(rdekl)+cos(rylat)*cos(rdekl)*
+ ! & cos((eq)*pi/12.)
+ solelev=asin(sinsol)*180./pi
+ zenithangle=90.-solelev
+
+ return
+end function zenithangle