| blob | 1b55e65d1b1b63c605bf830c0ea3d49e3ac69daf |
1 ! =============================================================================
2 !
3 ! This set of modules contains the fire code ported from the CAWFE model.
4 !
5 ! http://www.mmm.ucar.edu/research/wildfire/afm/afm.html
6 !
7 ! This version is no longer compatible with the Clark-Hall model. It is
8 ! now WRF specific.
9 !
10 ! Created by: Edward (Ned) G. Patton
11 ! National Center for Atmospheric Research
12 ! Mesoscale and Microscale Meteorology Division
13 ! Boulder, Colorado 80307-3000
14 ! patton@ucar.edu
15 !
16 ! Under guidance by: Janice L. Coen
17 ! National Center for Atmospheric Research
18 ! Mesoscale and Microscale Meteorology Division
19 ! Boulder, Colorado 80307-3000
20 ! coen@ucar.edu
21 !
22 ! Based on: Clark, T. L., J. L. Coen and D. Latham: 2004,
23 ! "Description of a coupled atmosphere-fire model",
24 ! International Journal of Wildland Fire, 13, 49-63.
25 !
26 ! See below for a description of the variables.
27 !
28 ! There are two modules: 1) module_fr_cawfe_fuel (sets fuel params)
29 ! 2) module_fr_cawfe (the fire code)
30 !
31 ! =============================================================================
33 MODULE module_fr_cawfe_fuel
35 INTEGER, PARAMETER :: nfuelcats = 14
37 INTEGER, DIMENSION( nfuelcats ) :: ichap
38 REAL , DIMENSION( nfuelcats ) :: weight,fgi,fci,fci_d,fct,fcbr, &
39 fueldepthm,fueldens,fuelmce, &
40 savr,st,se
42 ! =============================================================================
43 ! ----- Specification of fuel properties for the standard 13 fire
44 ! behavior fuel models (for surface fires), along with some
45 ! estimated canopy properties (for crown fire).
46 ! =============================================================================
47 ! FUEL MODEL 1: Short grass (1 ft)
48 ! FUEL MODEL 2: Timber (grass and understory)
49 ! FUEL MODEL 3: Tall grass (2.5 ft)
50 ! FUEL MODEL 4: Chaparral (6 ft)
51 ! FUEL MODEL 5: Brush (2 ft)
52 ! FUEL MODEL 6: Dormant brush, hardwood slash
53 ! FUEL MODEL 7: Southern rough
54 ! FUEL MODEL 8: Closed timber litter
55 ! FUEL MODEL 9: Hardwood litter
56 ! FUEL MODEL 10: Timber (litter + understory)
57 ! FUEL MODEL 11: Light logging slash
58 ! FUEL MODEL 12: Medium logging slash
59 ! FUEL MODEL 13: Heavy logging slash
60 !
61 DATA fgi / 0.166, 0.897, 0.675, 2.468, 0.785, 1.345, 1.092, &
62 1.121, 0.780, 2.694, 2.582, 7.749, 13.024, 1.e-7 /
63 DATA fueldepthm /0.305, 0.305, 0.762, 1.829, 0.61, 0.762,0.762, &
64 0.0610, 0.0610, 0.305, 0.305, 0.701, 0.914, 0.305 /
65 DATA savr / 3500., 2784., 1500., 1739., 1683., 1564., 1562., &
66 1889., 2484., 1764., 1182., 1145., 1159., 3500. /
67 DATA fuelmce / 0.12, 0.15, 0.25, 0.20, 0.20, 0.25, 0.40, &
68 0.30, 0.25, 0.25, 0.15, 0.20, 0.25, 0.12 /
69 DATA fueldens / nfuelcats * 32. / ! 32 if solid, 19 if rotten.
70 DATA st / nfuelcats* 0.0555 /
71 DATA se / nfuelcats* 0.010 /
73 ! ----- Notes on weight: (4) - best fit of Latham data;
74 ! (5)-(7) could be 60-120; (8)-(10) could be 300-1600;
75 ! (11)-(13) could be 300-1600
76 DATA weight / 7., 7., 7., 180., 100., 100., 100., &
77 900., 900., 900., 900., 900., 900., 7. /
79 ! ----- 1.12083 is 5 tons/acre. 5-50 tons/acre orig., 100-300 after blowdown
80 DATA fci_d / 0., 0., 0., 1.123, 0., 0., 0., &
81 1.121, 1.121, 1.121, 1.121, 1.121, 1.121, 0./
82 DATA fct / 60., 60., 60., 60., 60., 60., 60., &
83 60., 120., 180., 180., 180., 180. , 60. /
84 DATA ichap / 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 /
86 ! =========================================================================
88 CONTAINS
90 SUBROUTINE init_module_fire_fuel
91 END SUBROUTINE init_module_fire_fuel
93 END MODULE module_fr_cawfe_fuel
96 ! =========================================================================
97 !
98 ! The following module contains the fire code ported from the Clark-Hall model.
99 !
100 ! =========================================================================
103 MODULE module_fr_cawfe
105 USE module_model_constants
107 INTEGER, SAVE :: igwiz
109 REAL, PARAMETER :: cmbcnst = 17.433e+06 ! J/kg dry fuel
110 REAL, PARAMETER :: hfgl = 17.e4 ! W/m^2
111 REAL, PARAMETER :: fuelheat = cmbcnst * 4.30e-04 ! convert J/kg to BTU/lb
112 REAL, PARAMETER :: fuelmc_g = 0.08 ! set = 0 for dry ground fuel
113 REAL, PARAMETER :: fuelmc_c = 1.00 ! set = 0 for dry canopy
114 REAL, PARAMETER :: bmst = fuelmc_g/(1+fuelmc_g)
115 ! REAL, PARAMETER :: ep = epsilon ! epsilon a very small number
116 ! REAL, PARAMETER :: ep_sq = epsilon**2
117 REAL, PARAMETER :: ep = 1.e-7 ! epsilon a very small number
118 REAL, PARAMETER :: ep_sq = ep**2
120 REAL :: tignm
121 REAL :: dxf,dyf
122 REAL :: betaop,c,e
123 REAL :: grndhx,grndqx,canhx,canqx
125 REAL, DIMENSION( 4 ) :: xlm,ylm
127 DATA igwiz /0/ ! igwiz=0 1st time through firecode at startup,restart
129 CONTAINS
131 ! =========================================================================
133 SUBROUTINE cawfe(ids,ide, kds,kde, jds,jde, & ! incoming
134 ims,ime, kms,kme, jms,jme, &
135 its,ite, kts,kte, jts,jte, &
136 ifds,ifde, kfds,kfde, jfds,jfde, &
137 ifms,ifme, kfms,kfme, jfms,jfme, &
138 itimestep,dt,dx,dy, &
139 grid_id,cen_lat,cen_lon,lat_ll,lon_ll, &
140 moad_cen_lat,moad_cen_lon, &
141 moad_lat_ll,moad_lon_ll,moad_dx,moad_dy, &
142 moad_s_we,moad_e_we,moad_s_sn,moad_e_sn, &
143 nfrx,nfry, &
144 tlat_stf,tlon_stf,t_ignite,ishape,ibeh, &
145 z1can,alfg,alfc,ifuelread,nfuel_cat0, &
146 z,z_at_w,dz8w,zs,u,v,mu,rho, &
147 nfuel_cat,nfl,nfl_t,nfl_c,ncod, & ! in and out
148 in1,in2,ixb,iyb,icn, &
149 fg,fc,r_0,bbb,betafl,phiwc,area,area2, &
150 zf,zsf,tign_g,tign_c,tign_crt, &
151 xfg,yfg,xcd,ycd,xcn,ycn,sprdx,sprdy, &
152 rthfrten,rqvfrten,grnhfx,grnqfx,canhfx,canqfx) ! outgoing
154 ! -------------------------------------------------------------------------
155 !
156 ! ---- key indicies
157 !
158 ! ids,ide start,end domain indicies for atmos. variables in x
159 ! kds,kde start,end domain indicies for atmos. variables in z
160 ! jds,jde start,end domain indicies for atmos. variables in y
161 ! ims,ime start,end memory dimensions for atmos. variables in x
162 ! kms,kme start,end memory dimensions for atmos. variables in z
163 ! jms,jme start,end memory dimensions for atmos. variables in y
164 ! its,ite start,end tile indicies for atmos. variables in x
165 ! kts,kte start,end tile indicies for atmos. variables in z
166 ! jts,jte start,end tile indicies for atmos. variables in y
167 !
168 ! ifds,ifde start,end domain dimensions for fire variables indicies in x
169 ! jfds,jfde start,end domain dimensions for fire variables indicies in y
170 ! ifms,ifme start,end memory dimensions for fire variables indicies in x
171 ! jfms,jfme start,end memory dimensions for fire variables indicies in y
172 !
173 ! if_st,if_en start,end tile indicies for fire variables indicies in x
174 ! jf_st,jf_en start,end tile indicies for fire variables indicies in y
175 !
176 ! ---- incoming WRF variables
177 !
178 ! itimestep integer time step
179 ! dt time increment of atmos. grid that contains the fire grid
180 ! dx,dy delta x,y of innermost atmos. grid that contains the fire grid
181 ! grid_id integer grid id pointing to the WRF domain which are we on
182 ! cen_lat latitude of the center of the fire domain
183 ! cen_lon longitude of the center of the fire domain
184 ! lat_ll latitude of the south-west corner of the fire domain
185 ! lon_ll longitude of the south-west corner of the fire domain
186 ! moad_cen_lat latitude of the center of the mother of all domains (moad)
187 ! moad_cen_lon longitude of the center of the moad
188 ! moad_lat_ll latitude of the south-west corner of the moad
189 ! moad_lon_ll longitude of the south-west corner of the moad
190 ! moad_dx delta x of moad grid
191 ! moad_dy delta y of moad grid
192 ! moad_s_we starting west-east index of moad grid
193 ! moad_e_we ending west-east index of moad grid
194 ! moad_s_sn starting south-north index of moad grid
195 ! moad_e_sn ending south-north index of moad grid
196 !
197 ! nfrx,nfry specified innermost atmos. grid refinement for fire grid in x,y
198 ! tlat_stf latitude of inital fire location (degrees lat)
199 ! tlon_stf longitude of inital fire location (degrees lon)
200 ! t_ignite time of fire initiation (s)
201 ! ishape what initial fire shape?
202 ! ibeh which fire spread model? = 0 McArthur, =1 BEHAVE
203 ! z1can lowest height crown fire heat is released (m)
204 ! alfc extinction depth of crown fire heat (m)
205 ! alfg extinction depth of ground fire heat (m)
206 ! ifuelread read fuel parameters from file? or specify them?
207 ! nfuel_cat0 if fuel parameters are specified, what category?
208 !
209 ! z height above sea level of mass points (m)
210 ! z_at_w height above sea level of w points (m)
211 ! dz8w delta z between w points (m)
212 ! zs height of surface above sea level (m)
213 ! u,v incoming atmos. winds (m/s at arakawa-c grid locations)
214 ! mu
215 ! rho incoming atmos. density (kg/m^3 at arakawa-c grid mass points)
216 !
217 ! ---- in and out fire variables
218 !
219 ! nfuel_cat(i,j) integer NFFL fuel category at each fire grid cell
220 ! nfl(i,j) = 0 means no fire line points in that cell
221 ! nfl(i,j) = 1 means there are some fire line points in that cell
222 ! ncod(i,j,it) is number of fire line coordinates in fire grid (i,j)
223 ! in1(i,j,1) is i1 index for (i,j) grid
224 ! in1(i,j,2) is j1 index for (i,j) grid
225 ! in2(i,j,1) is i2 index for (i,j) grid
226 ! in2(i,j,2) is j2 index for (i,j) grid
227 ! ixb(i,j,it) = 0 means the x coord of the it tracer is within ep of boundary
228 ! ixb(i,j,it) = 1 means the x coord of the it tracer is an interior point
229 ! iyb(i,j,it) = 0 means the y coord of the it tracer is within ep of boundary
230 ! iyb(i,j,it) = 1 means the y coord of the it tracer is an interior point
231 ! icn(i,j,it) = 0 means the it coord is not a corner point
232 ! icn(i,j,it) = 1 means the it coord is a corner point
233 ! fg(i,j) mass of surface fuel (kg/m^2)
234 ! fc(i,j) total mass of canopy fuel (kg/m^2)
235 ! r_0(i,j) is the spread rate for a fire on flat ground with no wind
236 ! bbb(i,j) is a constant in the wind correction for fire spread
237 ! betafl(i,j) is a constant in the wind correction for fire spread
238 ! phiwc(i,j) is a constant in the wind correction for fire spread
239 ! area(i,j)
240 ! area2(i,j) the sum over this is the fire area (m^2)
241 ! zf(i,j) hgt of kds+1 mass point above sea level interp. to fire grid (m)
242 ! zsf(i,j) hgt of surface above sea level interpolated to fire grid (m)
243 ! tign_g(i,j) time this cell ignited ground fire (s); < 0 -> no ignition
244 ! tign_c(i,j) time this cell ignited crown fire (s); < 0 -> no ignition
245 ! tign_crt(i,j) time this cell ignited completely (s); < 0 -> not entirely aflame
246 ! xfg(i,j,4) x coord of the 4 surface fuel tracers specific to grid (i,j)
247 ! yfg(i,j,4) y coord of the 4 surface fuel tracers specific to grid (i,j)
248 ! xcd(i,j,it) x coord of the it fire line coordinate in grid (i,j)
249 ! ycd(i,j,it) y coord of the it fire line coordinate in grid (i,j)
250 ! xcn(i,j,it) x coord of the normal vector at point (i,j)
251 ! ycn(i,j,it) y coord of the normal vector at point (i,j)
252 ! sprdx(i,j,it) spread rate in x normalized units (mostly for debug)
253 ! sprdy(i,j,it) spread rate in y normalized units (mostly for debug)
254 !
255 ! ---- key output variables from fire
256 !
257 ! rthfrten theta tendency due to fire induced heat flux divergence
258 ! rqvfrten Qv tendency due to fire induced moisture flux divergence
259 !
260 ! grnhfx heat flux from ground fire (W/m^2)
261 ! grnqfx moisture flux from ground fire (W/m^2)
262 ! canhfx heat flux from crown fire (W/m^2)
263 ! canqfx moisture flux from crown fire (W/m^2)
264 !
265 ! ---- local fire variables
266 !
267 ! fgi initial total mass of surface fuel (kg/m^2)
268 ! fci initial total mass of crown fuel
269 ! fci_d initial dry mass of crown fuel
270 ! fuelmc_c initial moisture/dry mass ratio for crown fuel
271 ! fct burn out time for crown fuel, after dry (s)
272 ! fcbr crown fuel burn rate (kg/m^2/s)
273 ! cmbcnst joules per kg of dry fuel
274 ! fuelmc_g fuel particle (surface) moisture content
275 ! fuel moisture fuelmc_g = (h2o)/(dry)
276 ! bmst ratio of latent to sensible heat from sfc burn:
277 ! % of total fuel mass that is water (not quite
278 ! = % fuel moisture). bmst= (h2o)/(h2o+dry)
279 ! so bmst = fuelmc_g / (1 + fuelmc_g) where
280 ! fuelmc_g = ground fuel moisture
281 ! hfgl surface fire heat flux threshold to ignite canopy (W/m^2)
282 ! fuelloadm ovendry fuel loading, kg/m^2 (converted to lb/ft^2)
283 ! fueldepthm fuel depth, in m (converted to ft)
284 ! savr fuel particle surface-area-to-volume ratio (1/ft)
285 ! grass: 3500., 10 hr fuel: 109., 100 hr fuel: 30.
286 ! fuelheat fuel particle low heat content (btu/lb)
287 ! fueldens ovendry particle density (lb/ft^3)
288 ! st fuel particle total mineral content
289 ! se fuel particle effective mineral content
290 ! fuelmce moisture content of extinction;
291 ! 0.30 for many dead fuels; 0.15 for grass
292 ! weight weighting parameter determining the slope of the mass loss curve
293 ! ranges from ~5 (fast burnup) to 1000 ( ~40% decr over 10 min).
294 ! sfcu(i,j,6) surface wind in x-direction interpolated to grid corners (m/s)
295 ! sfcv(i,j,6) surface wind in y-direction interpolated to grid corners (m/s)
296 !
297 ! when deriving fireline coordinates we always keep the fire to our left
298 !
299 ! -------------------------------------------------------------------------
300 !
301 ! .... Three components to this subroutine:
302 !
303 ! Initialization
304 ! IGWIZ loop: Initialization of variables for all
305 ! runs including restart. Executed once each time the
306 ! model is started on 1st pass through fire_sfc .
307 ! Pass through tracer scheme.
308 ! This defines fire boundary and (ground) fire line
309 ! progression in this time step.
310 ! Calculation of fluxes to be fed into atmosphere.
311 ! Calculates macroscale properties of this
312 ! fire line progression back on atmosphere in terms of
313 ! mass burned -> heat and vapor fluxes to be fed into atmos.
314 ! 3 parts to this:
315 ! 1) ground fire heat+vapor release.
316 ! 2) some ground fire heat used to dry overlying canopy.
317 ! 3) canopy fire ignition, heat+vapor release.
318 !
319 ! -------------------------------------------------------------------------
320 !
321 ! - should sometime integrate fuel depth (veg type) with ZNOT?
322 !
323 ! Conversions:
324 ! Fuel loads: 1 ton/acre = 0.224166 kg/m^2
325 ! -------------------------------------------------------------------------
327 USE module_fr_cawfe_fuel
328 USE module_wrf_error
329 ! USE module_tecplot
331 IMPLICIT NONE
333 ! ----- incoming variables
335 INTEGER, INTENT(in) :: ids,ide, kds,kde, jds,jde ! atmosphere domain indices
336 INTEGER, INTENT(in) :: ims,ime, kms,kme, jms,jme ! atmosphere memory indices
337 INTEGER, INTENT(in) :: its,ite, kts,kte, jts,jte ! atmosphere tile indices
339 INTEGER, INTENT(in) :: ifds,ifde, jfds,jfde, kfds,kfde ! fire domain indices
340 INTEGER, INTENT(in) :: ifms,ifme, jfms,jfme, kfms,kfme ! fire memory indices
342 INTEGER, INTENT(in) :: itimestep ! current time step (cumulative)
343 REAL, INTENT(in) :: dt ! time step
344 REAL, INTENT(in) :: dx,dy ! dx,dy on innermost atm mesh
345 INTEGER, INTENT(in) :: grid_id ! grid id of innermost atm mesh
346 REAL, INTENT(in) :: cen_lat,cen_lon ! center lat,lon of " " "
347 REAL, INTENT(in) :: lat_ll,lon_ll ! lat,lon of sw corner of " " "
348 REAL, INTENT(in) :: moad_cen_lat,moad_cen_lon ! lat,lon of center of moad
349 REAL, INTENT(in) :: moad_lat_ll,moad_lon_ll ! lat,lon of sw corner of moad
350 REAL, INTENT(in) :: moad_dx,moad_dy ! dx,dy of moad
351 INTEGER, INTENT(in) :: moad_s_we,moad_e_we ! strt/stop grd pts in x moad
352 INTEGER, INTENT(in) :: moad_s_sn,moad_e_sn ! strt/stop grd pts in y moad
354 INTEGER, INTENT(in) :: nfrx,nfry
355 REAL, INTENT(in) :: tlat_stf
356 REAL, INTENT(in) :: tlon_stf
357 REAL, INTENT(in) :: t_ignite
358 INTEGER, INTENT(in) :: ifuelread
359 INTEGER, INTENT(in) :: ishape
360 REAL, INTENT(in) :: z1can
361 REAL, INTENT(in) :: alfg
362 REAL, INTENT(in) :: alfc
363 INTEGER, INTENT(in) :: ibeh
364 INTEGER, INTENT(in) :: nfuel_cat0
366 REAL, INTENT(in), DIMENSION( ims:ime, kms:kme, jms:jme ) :: u,v
367 REAL, INTENT(in), DIMENSION( ims:ime, kms:kme, jms:jme ) :: z,z_at_w
368 REAL, INTENT(in), DIMENSION( ims:ime, kms:kme, jms:jme ) :: rho
369 REAL, INTENT(in), DIMENSION( ims:ime, kms:kme, jms:jme ) :: dz8w
370 REAL, INTENT(in), DIMENSION( ims:ime, jms:jme ) :: mu
371 REAL, INTENT(in), DIMENSION( ims:ime, jms:jme ) :: zs
373 ! ----- inout variables
375 INTEGER, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: nfuel_cat
376 INTEGER, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: nfl,nfl_t,nfl_c
377 INTEGER, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: ncod
378 INTEGER, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme,2 ) :: in1,in2
379 INTEGER, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: ixb,iyb,icn
381 REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: fg,fc
382 REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: r_0,bbb,betafl,phiwc
383 REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: area,area2
384 REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: zf,zsf
385 REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: tign_g,tign_c,tign_crt
386 REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xfg,yfg
387 REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xcd,ycd
388 REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xcn,ycn
389 REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: sprdx,sprdy
391 REAL, INTENT(inout), DIMENSION( ims:ime,kms:kme,jms:jme ) :: rthfrten
392 REAL, INTENT(inout), DIMENSION( ims:ime,kms:kme,jms:jme ) :: rqvfrten
394 ! ----- out variables
396 REAL, INTENT(out), DIMENSION( ims:ime,jms:jme ) :: grnhfx,grnqfx
397 REAL, INTENT(out), DIMENSION( ims:ime,jms:jme ) :: canhfx,canqfx
399 ! ----- local variables
401 INTEGER :: if_st,if_en, jf_st,jf_en
402 INTEGER :: nf
403 INTEGER :: it
404 INTEGER :: i,j
405 INTEGER :: ib,jb
406 INTEGER :: idts
407 INTEGER :: iyes
408 INTEGER :: ig,jg
409 INTEGER :: ic,jc
411 REAL :: time
412 REAL :: delplot
413 REAL :: rad
414 REAL :: sumarea
415 REAL :: a_fl
416 REAL :: burn_frac
417 REAL :: delm
418 REAL :: bratio
419 REAL :: dmass
420 REAL :: fcav
421 REAL :: delh
422 REAL :: grnhsum,canhsum
423 REAL :: ratg,ratc
424 REAL :: teps
425 REAL :: ratio
427 REAL, DIMENSION( ims:ime,jms:jme,6 ) :: sfcu,sfcv
429 REAL, DIMENSION( ifms:ifme,jfms:jfme ) :: grnhft,grnqft
430 REAL, DIMENSION( ifms:ifme,jfms:jfme ) :: canhft,canqft
432 CHARACTER (LEN=80) :: msg
434 ! --- take incoming horizontal atmos. winds on arakawa-c grid and
435 ! interpolate them to the cube corners. resulting winds (sfcu,sfcv)
436 ! are at the south west corner of the atmos. cell and shifted up
437 ! one-half grid point to the w-level. sfcu,sfcv will be further
438 ! interpolated to the needed locations behind the fire line in
439 ! sr. fire_tr.
441 CALL fire_winds(u,v, & ! send
442 ids,ide, kds,kde, jds,jde, &
443 ims,ime, kms,kme, jms,jme, &
444 its,ite, kts,kte, jts,jte, &
445 sfcu,sfcv) ! receive
447 ! ----- get the time from model start (assumes non-variable dt)
449 time = FLOAT(itimestep) * dt
451 ! ----- set indicies over which fire grid exists
452 !
453 ! these indicies are needed so that we are properly handling
454 ! fire calculations within tiles that butt up against domain
455 ! boundaries where the halo information is not available.
456 ! therefore the fire exists on one less atmospheric grid point
457 ! than the innermost domain is dimensioned.
459 if_st = MAX( (its-1)*nfrx+1, ids*nfrx+1 )
460 if_en = MIN( (ite)*nfrx , (ide-1)*nfrx )
461 jf_st = MAX( (jts-1)*nfry+1, jds*nfry+1 )
462 jf_en = MIN( (jte)*nfry , (jde-1)*nfry )
464 ! ----- begin initialization for all runs, including restart
466 IF (igwiz == 0) THEN ! igwiz loop
468 igwiz = 1
470 dxf = dx / FLOAT(nfrx)
471 dyf = dy / FLOAT(nfry)
473 WRITE(msg,*)'fire: dx,dy, dxf,dyf=', dx,dy, dxf,dyf
474 CALL wrf_message ( msg )
476 ! ----- fuel moisture parameters
478 DO nf = 1,nfuelcats
479 fci(nf) = (1.+fuelmc_c)*fci_d(nf)
480 fcbr(nf) = fci_d(nf)/fct(nf)
481 END DO
483 ! ----- initialize fire-related constants, and fuel category data
485 CALL fire_startup( grid_id,z,zs, & ! send
486 ids,ide, kds,kde, jds,jde, &
487 ims,ime, kms,kme, jms,jme, &
488 its,ite, kts,kte, jts,jte, &
489 ifms,ifme, kfms,kfme, jfms,jfme, &
490 if_st,if_en,jf_st,jf_en, &
491 nfrx,nfry, &
492 ifuelread, nfuel_cat0, &
493 zf,zsf,nfuel_cat,betafl,bbb,r_0,phiwc ) ! recv
495 ! -- EGP converted data statements from blockdata.f (check this for restarts...)
497 DO j = jf_st,jf_en
498 DO i = if_st,if_en
499 tign_g(i,j) = -100.
500 tign_c(i,j) = -100.
501 tign_crt(i,j) = -100.
502 DO it = 1,4
503 xfg(i,j,it) = 0.
504 yfg(i,j,it) = 0.
505 END DO
506 nfl(i,j) = 0
507 END DO
508 END DO
510 ! ----- check if fire has been ignited (i.e. TIGNM > 0.)
512 tignm = -100.
513 DO j = jf_st,jf_en
514 DO i = if_st,if_en
515 tignm = MAX(tign_g(i,j),tign_c(i,j),tignm)
516 END DO
517 END DO
519 !!!! EGP for MPI we need to communicate tignm to all processors
521 ! ----- if no fire has been ignited, initialize some fireline variables,
522 ! including fuel loads.
524 IF (tignm < -10.) THEN
526 ! ----- iof=1
528 CALL fire_init(1,dt, & ! send
529 cen_lat,cen_lon,lat_ll,lon_ll, &
530 moad_cen_lat,moad_cen_lon,moad_dx,moad_dy,&
531 moad_s_we,moad_e_we,moad_s_sn,moad_e_sn, &
532 nfl_t,time,dx,dy,nfuel_cat, &
533 zs,xcd,ycd,xcn,ycn,sprdx,sprdy, &
534 ids,ide, kds,kde, jds,jde, &
535 ims,ime, kms,kme, jms,jme, &
536 its,ite, kts,kte, jts,jte, &
537 ifds,ifde, kfds,kfde, jfds,jfde, &
538 ifms,ifme, kfms,kfme, jfms,jfme, &
539 if_st,if_en,jf_st,jf_en, &
540 nfrx,nfry, &
541 ishape,tlat_stf,tlon_stf,t_ignite,icn, &
542 fg,fc,tign_g,nfl,xfg,yfg, & ! send&recv
543 ixb,iyb) ! recv
545 END IF
547 END IF ! igwiz loop
549 ! ----- end initialization
551 ! ----- t_ignite is time we want the fire ignited (in model time).
552 !
553 ! This call:
554 ! - ignites a fire if t_ignite-time/60. < dt/60.
555 ! (i.e. if we are within 1 time step of designated ignition)
556 ! - sets tignm=now (a time > 0.).
558 WRITE(msg,*)'tignm = ',tignm
559 CALL wrf_message ( msg )
561 WRITE(msg,*)'t_ignite = ',t_ignite
562 CALL wrf_message ( msg )
564 WRITE(msg,*)'time = ',time
565 CALL wrf_message ( msg )
567 WRITE(msg,*)'diff = ',t_ignite-time,dt
568 CALL wrf_message ( msg )
570 CALL fire_init(2,dt, & ! send
571 cen_lat,cen_lon,lat_ll,lon_ll, &
572 moad_cen_lat,moad_cen_lon,moad_dx,moad_dy, &
573 moad_s_we,moad_e_we,moad_s_sn,moad_e_sn, &
574 nfl_t,time,dx,dy,nfuel_cat, &
575 zs,xcd,ycd,xcn,ycn,sprdx,sprdy, &
576 ids,ide, kds,kde, jds,jde, &
577 ims,ime, kms,kme, jms,jme, &
578 its,ite, kts,kte, jts,jte, &
579 ifds,ifde, kfds,kfde, jfds,jfde, &
580 ifms,ifme, kfms,kfme, jfms,jfme, &
581 if_st,if_en,jf_st,jf_en, &
582 nfrx,nfry, &
583 ishape,tlat_stf,tlon_stf,t_ignite,icn, &
584 fg,fc,tign_g,nfl,xfg,yfg, & ! send&recv
585 ixb,iyb) ! recv
588 IF (tignm < -10.) RETURN ! if nothing has ignited yet, return.
590 ! ----- begin pass through tracer scheme
592 DO jb = jts,MIN(jte,jde-1)
593 DO ib = its,MIN(ite,ide-1)
594 grnhfx(ib,jb) = 0.0
595 grnqfx(ib,jb) = 0.0
596 canhfx(ib,jb) = 0.0
597 canqfx(ib,jb) = 0.0
598 END DO
599 END DO
601 DO j = jf_st,jf_en
602 DO i = if_st,if_en
603 grnhft(i,j) = 0.0
604 grnqft(i,j) = 0.0
605 canqft(i,j) = 0.0
606 canhft(i,j) = 0.0
607 END DO
608 END DO
610 CALL fire_stat(1,dt,time, & ! send
611 zs,xcd,ycd,xcn,ycn,sprdx,sprdy, &
612 ids,ide, kds,kde, jds,jde, &
613 ims,ime, kms,kme, jms,jme, &
614 its,ite, kts,kte, jts,jte, &
615 ifms,ifme, kfms,kfme, jfms,jfme, &
616 if_st,if_en,jf_st,jf_en, &
617 nfrx,nfry, &
618 nfl,nfl_t,tign_g,tign_crt, & ! send&recv
619 area,area2,xfg,yfg, &
620 ixb,iyb,icn) ! recv
622 ! EGP --- temporarily dump fire line for tecplot
624 ! CALL fire_write_fire_ln(itimestep, &
625 ! nfl,icn,xfg,yfg,dxf,dyf, &
626 ! ifms,ifme, kfms,kfme, jfms,jfme, &
627 ! if_st,if_en, jf_st,jf_en)
629 ! EGP ---
631 ! ----- create points outlining fire
633 CALL fire_ln(dt,time,zs,sprdx,sprdy, & ! send
634 ids,ide, kds,kde, jds,jde, &
635 ims,ime, kms,kme, jms,jme, &
636 its,ite, kts,kte, jts,jte, &
637 ifms,ifme, kfms,kfme, jfms,jfme, &
638 if_st,if_en,jf_st,jf_en, &
639 nfrx,nfry, &
640 ncod,in1,in2,ixb,iyb,icn, & ! send&recv
641 tign_g,tign_crt,area,area2,xfg,yfg, &
642 nfl,nfl_t,rad,xcd,ycd,xcn,ycn) ! recv
644 ! ----- advect fire line points using spread rate
646 CALL fire_tr(dt,ibeh,nfuel_cat,ncod,nfl,zf,zsf,zs, & ! send
647 sfcu,sfcv,xcd,ycd,bbb,phiwc,betafl,r_0, &
648 ids,ide, kds,kde, jds,jde, &
649 ims,ime, kms,kme, jms,jme, &
650 its,ite, kts,kte, jts,jte, &
651 ifms,ifme, kfms,kfme, jfms,jfme, &
652 if_st,if_en,jf_st,jf_en, &
653 nfrx,nfry, &
654 xcn,ycn, & ! send&recv
655 sprdx,sprdy) ! recv
657 ! ----- reset coordinates for fire line grids
659 CALL fire_ds(ixb,iyb,icn,nfl,ncod,in1,in2, & ! send
660 time,xcn,ycn,xcd,ycd, &
661 ids,ide, kds,kde, jds,jde, &
662 ims,ime, kms,kme, jms,jme, &
663 its,ite, kts,kte, jts,jte, &
664 ifms,ifme, kfms,kfme, jfms,jfme, &
665 if_st,if_en,jf_st,jf_en, &
666 nfrx,nfry, &
667 xfg,yfg,tign_g) ! send&recv
669 ! ----- identify and treat newly ignited cells
671 CALL fire_igs(ixb,iyb,icn,in1,in2,ncod,time, & ! send
672 xcn,ycn,zs,xcd,ycd,sprdx,sprdy, &
673 ids,ide, kds,kde, jds,jde, &
674 ims,ime, kms,kme, jms,jme, &
675 its,ite, kts,kte, jts,jte, &
676 ifms,ifme, kfms,kfme, jfms,jfme, &
677 if_st,if_en,jf_st,jf_en, &
678 nfrx,nfry, &
679 nfl,tign_g,xfg,yfg) ! send&recv
681 ! -----
683 CALL fire_stat(2,dt,time, & ! send
684 zs,xcd,ycd,xcn,ycn,sprdx,sprdy, &
685 ids,ide, kds,kde, jds,jde, &
686 ims,ime, kms,kme, jms,jme, &
687 its,ite, kts,kte, jts,jte, &
688 ifms,ifme, kfms,kfme, jfms,jfme, &
689 if_st,if_en,jf_st,jf_en, &
690 nfrx,nfry, &
691 nfl,nfl_t,tign_g,tign_crt, & ! send&recv
692 area,area2,xfg,yfg, &
693 ixb,iyb,icn) ! recv
695 ! ----- end pass through tracer scheme
696 ! ----- now begin calculation of flux feedback to atmosphere
698 sumarea = 0.
700 DO 95 j = jf_st+1,jf_en-1
702 jb = INT(FLOAT((j-2)/nfry+2)+ep)
704 DO 96 i = if_st+1,if_en-1 !start of I,J fuel grid physics
706 ib = INT(FLOAT((i-2)/nfrx+2)+ep)
708 ! ----- ground fuel
710 IF (fg(i,j) < ep) GO TO 97 !grid point is burned out
711 IF (tign_g(i,j) < ep) GO TO 97 !grid point has not ignited !error
713 ! ----- calc. change in burning area
715 a_fl = area2(i,j)
716 sumarea = sumarea + area2(i,j)
718 ! ----- calc. mass burned based on time since ignition from mass loss curve
720 CALL fire_burn_fcn(i,j, & ! send
721 nfuel_cat,nfl,ncod,in1,in2, &
722 ixb,iyb,icn,time,area2, &
723 tign_g,tign_crt, &
724 xcd,ycd,xcn,ycn,xfg,yfg, &
725 ids,ide, kds,kde, jds,jde, &
726 ims,ime, kms,kme, jms,jme, &
727 its,ite, kts,kte, jts,jte, &
728 ifms,ifme, kfms,kfme, jfms,jfme, &
729 if_st,if_en,jf_st,jf_en, &
730 nfrx,nfry, &
731 burn_frac) ! recv
733 delm = MAX(fg(i,j) - (1.-burn_frac)*fgi(nfuel_cat(i,j)),0.0)
735 ! ----- all ground fuel burns off at the same rate
736 ! add random component to burn rate for excitation
738 bratio = 1.0
739 dmass = delm
740 fg(i,j) = MAX(fg(i,j)-dmass,0.0)
742 grnhft(i,j) = dmass/dt*(1.-bmst)*cmbcnst ! J/m^2/sec
743 grnqft(i,j) = (bmst+(1.-bmst)*.56)*dmass/dt*xlv
745 ! ----- drying out canopy
747 fcav = fc(i,j)-(1.-a_fl)*fci(nfuel_cat(i,j)) &
748 -a_fl*fci_d(nfuel_cat(i,j)) ! canopy moist. to be dried
750 IF (fcav > 0.0) THEN
751 delh = MIN(grnhft(i,j)*dt,fcav*xlv) ! J/m^2
752 grnhft(i,j) = grnhft(i,j) - delh/dt ! J/m^2/sec
753 fc(i,j) = fc(i,j) - delh/xlv
754 fcav = fcav - delh/xlv
755 canqft(i,j) = canqft(i,j) + delh/dt
756 END IF
758 ! ----- ignition of canopy follows
759 ! if surface fire heat flux over threshold, has not yet ignited,
761 IF (grnhft(i,j) > hfgl .AND. tign_c(i,j) < -10. &
762 .AND. fcav < ep) tign_c(i,j) = time
764 97 CONTINUE !end of ground fire physics
766 ! ----- canopy
768 IF (tign_c(i,j) < -10.) GO TO 98 !grid point has not yet been ignited
770 a_fl = .5*((xfg(i,j,4)-xfg(i,j,1))*(yfg(i,j,3)-yfg(i,j,2)) &
771 +(yfg(i,j,4)-yfg(i,j,1))*(xfg(i,j,2)-xfg(i,j,3)))
773 IF (fc(i,j) < ep) GO TO 98 !canopy grid point is burned out
775 ! ----- define mass available to burn
777 delm = MAX(fc(i,j)-(1.-a_fl)*fci_d(nfuel_cat(i,j)),0.0)
778 dmass = MIN(a_fl*fcbr(nfuel_cat(i,j))*dt,bratio*delm)
780 fc(i,j) = fc(i,j) - dmass
782 canhft(i,j) = dmass / dt * cmbcnst
783 canqft(i,j) = .56 * dmass / dt * xlv
785 98 CONTINUE !end of canopy fire physics
787 ! ----- ib,jb are atm grid pt counters; i,j grid pt counters
788 ! grnhft, grnhfx are in J/m^2/s (W/m^2)
790 canhfx(ib,jb) = canhfx(ib,jb) + canhft(i,j)/FLOAT(nfrx*nfry)
791 canqfx(ib,jb) = canqfx(ib,jb) + canqft(i,j)/FLOAT(nfrx*nfry)
792 grnhfx(ib,jb) = grnhfx(ib,jb) + grnhft(i,j)/FLOAT(nfrx*nfry)
793 grnqfx(ib,jb) = grnqfx(ib,jb) + grnqft(i,j)/FLOAT(nfrx*nfry)
795 96 END DO
796 95 END DO ! end of i,j fuel grid physics
798 !--- EGP need to handle MPI issues with sumarea
800 sumarea = sumarea * dxf * dyf
802 WRITE(msg,23)'time (min)=',time/60.,' AREA (acre)=',sumarea/4047.
803 23 FORMAT (1x,a11,f10.4,3x,a13,f15.5)
804 CALL wrf_message ( msg )
806 ! ----- end calculation of flux feedback to atmosphere
808 ! ----- generate some statistics for printout and future plotting
810 grndhx = 0.0
811 canhx = 0.0
812 grnhsum = 0.0
813 canhsum = 0.0
814 grndqx = 0.0
815 canhx = 0.0
816 canqx = 0.0
818 ! DO j = jts,jte
819 ! DO i = its,ite
821 DO j = MAX(jts,jds+1),MIN(jte,jde-1)
822 DO i = MAX(its,ids+1),MIN(ite,ide-1)
823 grndhx = MAX(grndhx,grnhfx(i,j))
824 canhx = MAX(canhx,canhfx(i,j))
825 grnhsum = grnhsum + grnhfx(i,j)*dx*dy
826 canhsum = canhsum + canhfx(i,j)*dx*dy
827 grndqx = MAX(grndqx,grnqfx(i,j))
828 canqx = MAX(canqx,canqfx(i,j))
829 END DO
830 END DO
832 WRITE(msg,93)grndhx,grndqx,canhx,canqx
833 93 FORMAT(1x,'GRNDHX=',e11.4,' GRNDQX=',e11.4,' CANHX=',e11.4,' CANQX=',e11.4/2x)
834 CALL wrf_message( msg )
836 WRITE(msg,68)grnhsum,canhsum
837 68 FORMAT(1x,'TOTAL FIRE SENS-HEAT FLUXES GRNH/CANH = ',2e11.4,' WATTS')
838 CALL wrf_message( msg )
840 ! ----- end of statistics print out
842 ig = 0
843 jg = 0
844 ratg = 0.0
845 ic = 0
846 jc = 0
847 ratc = 0.0
848 teps = 1.
850 DO j = MAX(jts,jds+1),MIN(jte,jde-1)
851 DO i = MAX(its,ids+1),MIN(ite,ide-1)
852 ratio = grnqfx(i,j)/(teps+grnhfx(i,j))
853 IF (ratio > ratg) THEN
854 ig = i
855 jg = j
856 ratg = ratio
857 END IF
858 ratio = canqfx(i,j)/(teps+canhfx(i,j))
859 IF (ratio > ratc) THEN
860 ic = i
861 jc = j
862 ratc = ratio
863 END IF
864 END DO
865 END DO
867 IF (ratg > 1. .OR. ratc > 1.) THEN
868 WRITE(msg,441)ratg,ig,jg,ratc,ic,jc, &
869 grnhfx(ig,jg),grnqfx(ig,jg),canhfx(ic,jc),canqfx(ic,jc)
870 441 FORMAT(1x,'RATG(I,J)=',e11.4,2i3,' RATC(I,J)=',e11.4,2i3/1x, &
871 'GRNH/QFX=',2e11.4,' CANH/CANQFX=',2e11.4)
872 CALL wrf_message( msg )
873 END IF
875 ! --- add heat and moisture fluxes to tendency variables
877 CALL fire_tendency(grnhfx,grnqfx,canhfx,canqfx, & ! send
878 alfg,alfc,z1can, &
879 zs,z_at_w,dz8w,mu,rho, &
880 ids,ide, kds,kde, jds,jde, &
881 ims,ime, kms,kme, jms,jme, &
882 its,ite, kts,kte, jts,jte, &
883 rthfrten,rqvfrten) ! recv
885 RETURN
887 END SUBROUTINE cawfe
889 ! =========================================================================
891 SUBROUTINE fire_startup( grid_id,z,zs, & ! incoming
892 ids,ide, kds,kde, jds,jde, &
893 ims,ime, kms,kme, jms,jme, &
894 its,ite, kts,kte, jts,jte, &
895 ifms,ifme, kfms,kfme, jfms,jfme, &
896 if_st,if_en,jf_st,jf_en, &
897 nfrx,nfry, &
898 ifuelread,nfuel_cat0, &
899 zf,zsf,nfuel_cat,betafl,bbb,r_0,phiwc ) ! outgoing
901 ! ... Initialize things that need to be set every time the
902 ! model starts up,
903 ! including restart, including constants, pre-multipliers,
904 ! and fuel map.
906 USE module_fr_cawfe_fuel
907 USE module_wrf_error
909 IMPLICIT NONE
911 ! ----- incoming variables
913 INTEGER, INTENT(in) :: ids,ide, kds,kde, jds,jde
914 INTEGER, INTENT(in) :: ims,ime, kms,kme, jms,jme
915 INTEGER, INTENT(in) :: its,ite, kts,kte, jts,jte
916 INTEGER, INTENT(in) :: ifms,ifme, kfms,kfme, jfms,jfme
917 INTEGER, INTENT(in) :: if_st,if_en,jf_st,jf_en
918 INTEGER, INTENT(in) :: nfrx,nfry
920 INTEGER, INTENT(in) :: ifuelread
921 INTEGER, INTENT(in) :: nfuel_cat0
923 INTEGER, INTENT(in) :: grid_id
925 REAL, INTENT(in), DIMENSION( ims:ime,jms:jme ):: zs
926 REAL, INTENT(in), DIMENSION( ims:ime, kms:kme, jms:jme ) :: z
928 ! ----- outgoing variables
930 INTEGER, INTENT(out), DIMENSION( ifms:ifme,jfms:jfme ) :: nfuel_cat
932 REAL, INTENT(out), DIMENSION( ifms:ifme,jfms:jfme ) :: zf,zsf
933 REAL, INTENT(out), DIMENSION( ifms:ifme,jfms:jfme ) :: betafl,bbb,r_0,phiwc
935 ! ----- local variables
937 INTEGER :: i,j,ii,jj
938 INTEGER :: nvl
939 INTEGER :: iu1
941 REAL :: t1
942 REAL :: fuelloadm,fuelload,fueldepth,qig,epsilon,rhob
943 REAL :: rtemp2,gammax,a,ratio,gamma,wn,rtemp1,etam,etas,ir,irm,xifr
944 REAL :: tii,tjj,epx,epy
946 INTEGER :: nfxy,nf,ni,nj,ci,cj,ip,jp
947 REAL, DIMENSION( ims:ime,jms:jme,nfrx*nfry) :: ztmp,zstmp
948 LOGICAL, DIMENSION(ims:ime, jms:jme ) :: icmask
950 CHARACTER (LEN=80) :: lfile2
951 CHARACTER (LEN=128) :: msg
954 ! ----- begin subroutine
956 xlm(1) = -.5
957 xlm(3) = -.5
958 xlm(2) = +.5
959 xlm(4) = +.5
960 ylm(1) = -.5
961 ylm(2) = -.5
962 ylm(3) = +.5
963 ylm(4) = +.5
965 ! ----- constants
966 !
967 ! interpolates topography on atm grid to fire/fuel grid (zs -> zsf)
968 ! and also interpolates height above sea level of first grid
969 ! point to fire grid (z -> zf). Note that these are valid at
970 ! the center of the cell.
972 DO j = jf_st,jf_en
973 tjj = 1.5 + (FLOAT(j) - 1.5) / FLOAT(nfry)
974 jj = INT(tjj)
975 epy = tjj - FLOAT(jj)
976 DO i = if_st,if_en
977 tii = 1.5 + (FLOAT(i)-1.5)/FLOAT(nfrx)
978 ii = INT(tii)
979 epx = tii - FLOAT(ii)
980 zsf(i,j) = (1.-epy)*((1.-epx)*zs(ii,jj)+epx*zs(ii+1,jj)) &
981 + epy*((1.-epx)*zs(ii,jj+1)+epx*zs(ii+1,jj+1))
982 zf(i,j) = (1.-epy)*((1.-epx)*z(ii,kds+1,jj)+epx*z(ii+1,kds+1,jj)) &
983 + epy*((1.-epx)*z(ii,kds+1,jj+1)+epx*z(ii+1,kds+1,jj+1))
984 enddo
985 enddo
987 ! ----- load fuel categories (or constant) here
988 !
989 ! ... How will fuel categories be set? IFUELREAD= 0 - uniform;
990 ! 1 - user-prescribed algorithm; 2 - read files
992 WRITE(msg,*)'fire_startup: ifuelread=', ifuelread
993 CALL wrf_message ( msg )
995 IF (ifuelread == 0) THEN
997 DO j = jf_st,jf_en
998 DO i = if_st,if_en
999 nfuel_cat(i,j) = nfuel_cat0
1000 END DO
1001 END DO
1003 ELSE IF (ifuelread == 1) THEN
1005 ! Make dependent on altitude (CO mountains/forest vs. plains)
1006 ! 2000 m : 6562 ft ; 1600 m: 5249 ft
1008 ! ... User defines fuel category spatial variability ! param!
1010 DO j = jf_st,jf_en
1011 DO i = if_st,if_en
1012 nfuel_cat(i,j) = 2 ! Grass with understory
1013 t1 = zsf(i,j)
1014 IF (t1 <= 1524.) THEN ! up to 5000 ft
1015 nfuel_cat(i,j) = 3 ! Tall grass
1016 ELSE IF (t1 >= 1524. .AND. t1 <= 2073.) THEN ! 5.0-6.8 kft.
1017 nfuel_cat(i,j) = 2 ! Grass with understory
1018 ELSE IF (t1 >= 2073. .AND. t1 <= 2438.) THEN ! 6.8-8.0 kft.
1019 nfuel_cat(i,j) = 8 ! Timber litter - 10 (ponderosa)
1020 ELSE IF (t1 > 2438. .AND. t1 <= 3354.) THEN ! 8.0-11.0 kft.
1021 ! ... could also be mixed conifer.
1022 nfuel_cat(i,j) = 10 ! Timber litter - 8 (lodgepole)
1023 ELSE IF (t1 > 3354. .AND. t1 <= 3658.) THEN ! 11.0-12.0 kft
1024 nfuel_cat(i,j) = 1 ! Alpine meadow - 1
1025 ELSE IF (t1 > 3658. ) THEN ! > 12.0 kft
1026 nfuel_cat(i,j) = 14 ! No fuel.
1027 END IF
1028 END DO
1029 END DO
1031 ELSE IF (ifuelread == 2) THEN
1033 ! -- EGP need to fix this so that when reading fuel data from
1034 ! a file that each if_st:if_en and jf_st:jf_en reads the
1035 ! correct chunk of the file....
1036 !
1037 ! NOTE: changed nvl=nvlm to nvl=model
1039 ! ----- written assuming NVERT=0, no parallelization
1040 ! ... Read fuel files
1042 ! nvl = nvlm ! Load fuel for innermost domain.
1043 nvl = grid_id ! Load fuel for innermost domain.
1044 IF (nvl <= 9) THEN
1045 WRITE(lfile2,80) nvl
1046 80 FORMAT('fuel_layer_',I1,'.dat')
1047 ELSE
1048 WRITE (msg,*) 'STOP, fire_startup: Generalize filename format for NVL > 9'
1049 CALL wrf_error_fatal ( msg )
1050 END IF
1052 iu1 = 10
1053 OPEN(iu1,FILE=lfile2,STATUS='unknown',FORM='formatted')
1055 DO j = jf_st,jf_en
1056 DO i = if_st,if_en
1057 READ(iu1,'(I2)') nfuel_cat(i,j)
1058 ! ... If no fuel category specified (i.e. '99'), set to '14',
1059 ! which (in the current 13 category NFFL category system)
1060 ! is 'no fuel'
1061 IF (nfuel_cat(i,j) < 1) nfuel_cat(i,j) = 14 ! not generalized
1062 IF (nfuel_cat(i,j) > nfuelcats) nfuel_cat(i,j) = 14 ! not generalized
1063 END DO
1064 END DO
1066 CLOSE (iu1)
1068 ELSE
1070 WRITE (msg,*) &
1071 'STOP, in fire_startup: error reading fuel categories from file: iu1'
1072 CALL wrf_error_fatal ( msg )
1074 END IF
1076 ! ----- end LOAD FUEL CATEGORIES (OR CONSTANT) HERE.
1078 ! ----- Settings of fire spread parameters from BEHAVE follows. These
1079 ! don't need to be recalculated later.
1080 !
1081 DO j = jf_st,jf_en
1082 DO i = if_st,if_en
1083 fuelloadm = (1.-bmst) * fgi(nfuel_cat(i,j)) ! fuelload without moisture
1084 fuelload = fuelloadm * (.3048)**2 * 2.205 ! to lb/ft^2
1085 fueldepth = fueldepthm(nfuel_cat(i,j))/0.3048 ! to ft
1086 betafl(i,j) = fuelload/(fueldepth * fueldens(nfuel_cat(i,j))) !packing ratio
1087 betaop = 3.348 * savr(nfuel_cat(i,j))**(-0.8189) ! optimum packing ratio
1088 qig = 250. + 1116.*fuelmc_g ! heat of preigntn., btu/lb
1089 epsilon = EXP(-138./savr(nfuel_cat(i,j)) ) ! eff. heating number
1090 rhob = fuelload/fueldepth ! ovendry bulk density, lb/ft^3
1092 c = 7.47 * EXP( -0.133 * savr(nfuel_cat(i,j))**0.55) ! const in wind coef
1093 bbb(i,j) = 0.02526 * savr(nfuel_cat(i,j))**0.54 ! const in wind coef
1094 e = 0.715 * EXP( -3.59E-4 * savr(nfuel_cat(i,j))) ! const in wind coef
1095 phiwc(i,j) = c * (betafl(i,j)/betaop)**(-e)
1097 rtemp2 = savr(nfuel_cat(i,j))**1.5
1098 gammax = rtemp2/(495. + 0.0594*rtemp2) ! maximum rxn vel, 1/min
1099 a = 1./(4.774 * savr(nfuel_cat(i,j))**0.1 - 7.27) ! coef for optimum rxn vel
1100 ratio = betafl(i,j)/betaop
1101 gamma = gammax *(ratio**a) *EXP(a*(1.-ratio)) ! optimum rxn vel, 1/min
1103 wn = fuelload/(1 + st(nfuel_cat(i,j))) ! net fuel loading, lb/ft^2
1104 rtemp1 = fuelmc_g/fuelmce(nfuel_cat(i,j))
1105 etam = 1.-2.59*rtemp1 +5.11*rtemp1**2 -3.52*rtemp1**3 !moist damp coef
1106 etas = 0.174* se(nfuel_cat(i,j))**(-0.19) !mineral damping coef
1107 ir = gamma * wn * fuelheat * etam * etas ! rxn intensity, btu/ft^2 min
1108 irm = ir * 1055./( 0.3048**2 * 60.) * 1.e-6 !for MW/m^2
1110 ! ----- propagating flux ratio
1111 xifr = EXP( (0.792 + 0.681*savr(nfuel_cat(i,j))**0.5) &
1112 * (betafl(i,j)+0.1)) /(192. + 0.2595*savr(nfuel_cat(i,j)))
1114 ! ----- r_0 is the spread rate for a fire on flat ground with no wind.
1115 r_0(i,j) = ir*xifr/(rhob * epsilon *qig) ! default spread rate in ft/min
1116 IF (nfuel_cat(i,j) == 14) r_0(i,j) = 0. ! no fuel, no spread.
1117 ! WRITE (msg,*) 'irm,r0 (m/s)=',i,j,irm, (r_0(i,j)/196.85)
1118 ! CALL wrf_message ( msg )
1121 END DO
1122 END DO
1124 RETURN
1126 END SUBROUTINE fire_startup
1128 ! =========================================================================
1130 SUBROUTINE fire_init(iof,dt, & ! incoming
1131 cen_lat,cen_lon,lat_ll,lon_ll, &
1132 moad_cen_lat,moad_cen_lon,moad_dx,moad_dy, &
1133 moad_s_we,moad_e_we,moad_s_sn,moad_e_sn, &
1134 nfl_t,time,dx,dy,nfuel_cat, &
1135 zs,xcd,ycd,xcn,ycn,sprdx,sprdy, &
1136 ids,ide, kds,kde, jds,jde, &
1137 ims,ime, kms,kme, jms,jme, &
1138 its,ite, kts,kte, jts,jte, &
1139 ifds,ifde, kfds,kfde, jfds,jfde, &
1140 ifms,ifme, kfms,kfme, jfms,jfme, &
1141 if_st,if_en,jf_st,jf_en, &
1142 nfrx,nfry, &
1143 ishape,tlat_stf,tlon_stf,t_ignite,icn, &
1144 fg,fc,tign_g,nfl,xfg,yfg, & ! in-out
1145 ixb,iyb) ! outgoing
1147 ! -------------------------------------------------------------------
1148 ! If iof = 1: this routine sets some variables to zero and initializes
1149 ! some parameters
1150 !
1151 ! If iof = 2: this routine ignites a fire with shape: ishape
1152 ! -------------------------------------------------------------------
1154 USE module_fr_cawfe_fuel
1156 IMPLICIT NONE
1158 ! ------ incoming variables
1160 INTEGER, INTENT(in) :: iof
1162 INTEGER, INTENT(in) :: ids,ide, kds,kde, jds,jde
1163 INTEGER, INTENT(in) :: ims,ime, kms,kme, jms,jme
1164 INTEGER, INTENT(in) :: its,ite, kts,kte, jts,jte
1165 INTEGER, INTENT(in) :: ifds,ifde, kfds,kfde, jfds,jfde
1166 INTEGER, INTENT(in) :: ifms,ifme, kfms,kfme, jfms,jfme
1167 INTEGER, INTENT(in) :: if_st,if_en, jf_st,jf_en
1168 INTEGER, INTENT(in) :: nfrx,nfry
1170 REAL, INTENT(in) :: cen_lat,cen_lon ! lat,lon center of finest mesh
1171 REAL, INTENT(in) :: lat_ll,lon_ll ! lat,lon lower left of " "
1172 REAL, INTENT(in) :: moad_cen_lat,moad_cen_lon ! lat,lon center of moad
1173 REAL, INTENT(in) :: moad_dx,moad_dy ! dx,dy of moad
1174 INTEGER, INTENT(in) :: moad_s_we,moad_e_we ! strt & end indices in x on moad
1175 INTEGER, INTENT(in) :: moad_s_sn,moad_e_sn ! strt & end indices in y on moad
1177 INTEGER, INTENT(in) :: ishape
1178 REAL, INTENT(in) :: tlat_stf
1179 REAL, INTENT(in) :: tlon_stf
1180 REAL, INTENT(in) :: t_ignite
1182 INTEGER, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme ) :: nfl_t,nfuel_cat
1183 INTEGER, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,4 ):: icn
1185 REAL, INTENT(in) :: time,dt
1186 REAL, INTENT(in) :: dx,dy
1188 REAL, INTENT(in), DIMENSION( ims:ime,jms:jme ) :: zs
1189 REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xcd,ycd
1190 REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xcn,ycn
1191 REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: sprdx,sprdy
1193 ! ------ outgoing variables
1195 INTEGER, INTENT(out), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: ixb,iyb
1197 ! ------ in and out going variables
1199 INTEGER, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: nfl
1201 REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: fg,fc
1202 REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: tign_g
1203 REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xfg,yfg
1205 ! ------ local variables
1207 INTEGER :: i,j
1208 INTEGER :: it
1209 INTEGER :: istf,jstf
1210 INTEGER :: ii,jj
1211 INTEGER :: ixm,iym
1212 INTEGER :: i1,i2,j1,j2
1213 INTEGER :: nfl_max
1214 INTEGER :: ism,isp,jsm,jsp
1215 INTEGER :: nxmm,nymm
1216 INTEGER :: moad_num_pnts_x,moad_num_pnts_y
1218 REAL :: xwidfire,ywidfire,tdiff,dxst,dyst,xcntr,ycntr,stx,sty
1219 REAL :: xf1,yf1,xx1,yy1,fii,fjj
1220 REAL :: rad,x0,y0,x1,y1,x2,y2
1221 REAL :: rmin
1222 REAL :: r1,r2,r3,r4
1223 REAL :: r12,r13,r14,r23,r24,r34
1224 REAL :: a_fl
1225 REAL :: xwd,ywd
1226 REAL :: xmax,ymax,rmax,alpha
1227 REAL :: x,y,spd,ss,dxp,dyp
1229 CHARACTER(LEN=120) :: msg
1231 ! ------ begin routine
1233 IF (tignm > -10.) RETURN ! If there is alrady a fire, return.
1234 ! Generalize this when want to add multiple fires.
1236 IF (iof == 1) THEN ! iof=1
1237 ! ... This is 1st time through sr. fire (either cold start or restart) and
1238 ! NO FIRE YET. Initialize some fire & fuel variables that will change
1239 ! once fire starts.
1240 !
1241 ! Define the initial tracer positions of the ground fuel (XFG,YFG)
1242 ! where the coordinates are relative to the grid center such that
1243 ! XFG and YFG vary between -0.5 to +0.5 where (XFG,YFG)=(0.,0.) is
1244 ! the grid center. |XFG|.le. 0.5 and |YFG|.le. 0.5 .
1245 !
1246 DO j = jf_st,jf_en
1247 DO i = if_st,if_en
1248 fg(i,j) = fgi(nfuel_cat(i,j)) !sfc fuel horiz. homogeneous conditions
1249 fc(i,j) = fci(nfuel_cat(i,j)) !canopy fuel horiz. homogeneous conditions
1250 nfl(i,j) = 0
1251 tign_g(i,j) = -100. ! no fire set yet
1252 DO it = 1,4 ! loop over the 4 tracers per fuel cell
1253 ixb(i,j,it) = 1
1254 iyb(i,j,it) = 1
1255 xfg(i,j,it) = 0.0
1256 yfg(i,j,it) = 0.0
1257 END DO
1258 END DO
1259 END DO
1260 END IF ! iof=1
1262 tdiff = ABS(t_ignite-time/60.) ! T_IGNITE is in minutes
1264 IF (iof == 2 .AND. tdiff < dt/60.) THEN ! iof=2
1266 ! It's time to ignite a fire! (Generalize so that other fires could
1267 ! be burning elsewhere.)
1268 ! T_IGNITE is the designated ignition time in minutes (model time)
1271 ! set tlat_stf,tlon_stf: latitude and longitude of the center of ignition location
1273 WRITE (msg,*) 'FIRE IGNITION AT: TLAT_STF, TLON_STF=',tlat_stf,tlon_stf
1274 CALL wrf_message ( msg )
1278 ! moad_cen_lat = latitude of the center of outermost domain (mother of all domains)
1279 ! moad_cen_lon = longitude of the center of outermost domain
1280 ! get dxst,dyst: fire dist. from domain 1 center in m
1282 dxst = (tlon_stf-moad_cen_lon) * 111.1949 * 1.e3
1283 dyst = (tlat_stf-moad_cen_lat) * 111.1949 * 1.e3
1285 ! EGP
1286 dxst = 0.
1287 dyst = 0.
1289 WRITE (msg,*) 'fire dist dom1 center (m): dxst,dyst=',dxst,dyst
1290 CALL wrf_message ( msg )
1292 ! get xcntr,ycntr: distance from SW corner domain 1 to center of domain 1 (m)
1294 moad_num_pnts_x = moad_e_we - moad_s_we + 1
1295 moad_num_pnts_y = moad_e_sn - moad_s_sn + 1
1297 xcntr = (FLOAT(moad_num_pnts_x) * moad_dx) / 2.
1298 ycntr = (FLOAT(moad_num_pnts_y) * moad_dy) / 2.
1300 WRITE (msg,*) 'dist SW corner dom1 to center dom1 (m): ', &
1301 'xcntr,ycntr=',xcntr,ycntr
1302 CALL wrf_message ( msg )
1305 ! get stx,sty: coords (in m) of fire start wrt the sw corner of model 1 in m
1307 ! WRITE (msg,*) 'ycntr, dyst, sum=',ycntr,dyst, ycntr+dyst
1308 ! CALL wrf_message ( msg )
1310 stx = xcntr + dxst ! in m
1311 sty = ycntr + dyst
1313 WRITE (msg,*) &
1314 'coords fire rel to SW corner mod 1 (m): stx,sty:',stx,sty
1315 CALL wrf_message ( msg )
1318 ! EGP --- FIX this for WRF... currently writing over
1319 ! get xf1,yf1: position of SW corner of fire domain (in m)
1320 !
1321 ! IF (ifs == 1) THEN
1322 ! xf1 = (cen_lon - lon_ll) * 111.1949 * 1.e3
1323 ! yf1 = (cen_lat - lat_ll) * 111.1949 * 1.e3
1324 ! ELSE
1325 ! xf1 = 999999.
1326 ! yf1 = 999999.
1327 ! END IF
1328 ! xf1 = wrf_dm_min_real ( xf1 )
1329 ! yf1 = wrf_dm_min_real ( yf1 )
1331 xf1 = 0.
1332 yf1 = 0.
1334 WRITE (msg,*) 'pos of sw corner of fire domain (m): xfx1,xfy1:',xf1,yf1
1335 CALL wrf_message ( msg )
1338 ! get xx1,yy1: position of fire relative to fire domain (in m)
1340 xx1 = stx - xf1 ! in m
1341 yy1 = sty - yf1
1343 WRITE (msg,*) 'Fire position relative to fire domain (m):',xx1,yy1
1344 CALL wrf_message ( msg )
1347 ! get istf,jstf: position of fire in fire domain in atm grid cells
1349 istf = INT( xx1 / dx ) + 1
1350 jstf = INT( yy1 / dy ) + 1
1352 WRITE (msg,*) 'Fire position in domain atm grid pts:', istf,jstf
1353 CALL wrf_message ( msg )
1355 ! get fii,fjj: dist in m from this model level's SE corner
1357 fii= ( xx1 / dxf ) + 1.
1358 fjj= ( yy1 / dyf ) + 1.
1360 ! WRITE (msg,*) 'calc fii,fjj=',fii,fjj
1361 ! CALL wrf_message ( msg )
1363 ii = AINT(fii)
1364 jj = AINT(fjj)
1366 WRITE (msg,*) 'Fire position in domain in fuel cells:',ii,jj
1367 CALL wrf_message ( msg )
1369 ! .... Or set fire location this way.
1370 ! ... ISTF LSTF are the model dynamic grid positions of ignition point
1371 !
1372 ! istf = 31 ! param ! for 4 dom
1373 ! jstf = 24 ! param ! for 4 dom
1374 ! istf = 30 ! param ! for 3 dom
1375 ! jstf = 38 ! param ! for 3 dom
1376 ! istf = 104 ! param ! for 5 dom ! could/should be 106
1377 ! jstf = 49 ! param ! for 5 dom ! could/should be 50
1378 ! istf = 190 ! param ! for 6 dom
1379 ! jstf = 68 ! param ! for 6 dom
1381 istf = moad_num_pnts_x / 2 ! param !
1382 jstf = moad_num_pnts_y / 2 ! param !
1383 !
1384 ! --- EGP need to fix initialization for MPI... currently the ishape
1385 ! query happens on every CPU, therefore an equivalent fire will
1386 ! be initiated on every CPU
1387 !
1388 ! ------------------------------------------------------------------------
1389 IF (ishape == 0) THEN ! spot fire
1390 ! ...The circular ignition that follows assumes physically small fuel
1391 ! cells. Typical values of about 5 meters or less would be reasonable
1392 ! otherwise use line ignition
1394 rad = 10.01 * SQRT(dxf**2 + dyf**2) ! rad= 1.01 * hypot of fuel cell ! param!
1396 ! set x0,y0: dist in m from this model level's SE corner
1398 x0 = FLOAT(ii-1) * dxf + .5*dxf
1399 y0 = FLOAT(jj-1) * dyf + .5*dyf
1401 WRITE (msg,*) 'Spot fire initialized with rad=',rad,' at ', &
1402 ii,jj,' fuel cell location'
1403 CALL wrf_message ( msg )
1405 DO j = jf_st+1,jf_en-1
1406 DO i = if_st+1,if_en-1
1407 ! ... calc distance of each corner of fuel cell from ig pt.
1408 r1 = SQRT( (FLOAT(i-2)*dxf-x0)**2 + (FLOAT(j-2)*dyf-y0)**2 )
1409 r2 = SQRT( (FLOAT(i-1)*dxf-x0)**2 + (FLOAT(j-2)*dyf-y0)**2 )
1410 r3 = SQRT( (FLOAT(i-2)*dxf-x0)**2 + (FLOAT(j-1)*dyf-y0)**2 )
1411 r4 = SQRT( (FLOAT(i-1)*dxf-x0)**2 + (FLOAT(j-1)*dyf-y0)**2 )
1412 rmin = MIN(r1,r2,r3,r4)
1414 ! ... if any less than spot fire radius, ignite
1415 IF (rmin < rad) THEN !rmin lt rad
1416 tign_g(i,j) = time
1417 nfl(i,j) = 1
1418 IF (rad-r1 > ep) THEN
1419 xfg(i,j,1) = xlm(1)
1420 yfg(i,j,1) = ylm(1)
1421 END IF
1422 IF (rad-r2 > ep) THEN
1423 xfg(i,j,2) = xlm(2)
1424 yfg(i,j,2) = ylm(2)
1425 END IF
1426 IF (rad-r3 > ep) THEN
1427 xfg(i,j,3) = xlm(3)
1428 yfg(i,j,3) = ylm(3)
1429 END IF
1430 IF (rad-r4 > ep) THEN
1431 xfg(i,j,4) = xlm(4)
1432 yfg(i,j,4) = ylm(4)
1433 END IF
1435 IF (r1 < rad .AND. r2 < rad .AND. r3 > rad .AND. r4 > rad) THEN
1436 xfg(i,j,3) = xlm(3)
1437 yfg(i,j,3) = ylm(1) + (rad-r1)/(r3-r1)
1438 xfg(i,j,4) = xlm(4)
1439 yfg(i,j,4) = ylm(2) + (rad-r2)/(r4-r2)
1440 END IF
1441 IF (r1 > rad .AND. r2 > rad .AND. r3 < rad .AND. r4 < rad) THEN
1442 xfg(i,j,1) = xlm(1)
1443 yfg(i,j,1) = ylm(3) - (rad-r3)/(r1-r3)
1444 xfg(i,j,2) = xlm(2)
1445 yfg(i,j,2) = ylm(4) - (rad-r4)/(r2-r4)
1446 END IF
1447 IF (r1 < rad .AND. r3 < rad .AND. r2 > rad .AND. r4 > rad) THEN
1448 xfg(i,j,2) = xlm(1) + (rad-r1)/(r2-r1)
1449 yfg(i,j,2) = ylm(2)
1450 xfg(i,j,4) = xlm(3) + (rad-r3)/(r4-r3)
1451 yfg(i,j,4) = ylm(4)
1452 END IF
1453 IF (r1 > rad .AND. r3 > rad .AND. r2 < rad .AND. r4 < rad) THEN
1454 xfg(i,j,1) = xlm(2) - (rad-r2)/(r1-r2)
1455 yfg(i,j,1) = ylm(1)
1456 xfg(i,j,3) = xlm(4) - (rad-r4)/(r3-r4)
1457 yfg(i,j,3) = ylm(3)
1458 END IF
1460 IF (r1 < rad .AND. r2 > rad .AND. r3 > rad .AND. r4 > rad) THEN
1461 xfg(i,j,2) = xlm(1) + (rad-r1)/(r2-r1)
1462 yfg(i,j,2) = ylm(2)
1463 xfg(i,j,3) = xlm(3)
1464 yfg(i,j,3) = ylm(1) + (rad-r1)/(r3-r1)
1465 xfg(i,j,4) = .5*(xfg(i,j,2)+xfg(i,j,3))
1466 yfg(i,j,4) = .5*(yfg(i,j,2)+yfg(i,j,3))
1467 END IF
1468 IF (r2 < rad .AND. r1 > rad .AND. r3 > rad .AND. r4 > rad) THEN
1469 xfg(i,j,1) = xlm(2) - (rad-r2)/(r1-r2)
1470 yfg(i,j,1) = ylm(1)
1471 xfg(i,j,4) = xlm(4)
1472 yfg(i,j,4) = ylm(2) + (rad-r2)/(r4-r2)
1473 xfg(i,j,3) = .5*(xfg(i,j,1)+xfg(i,j,4))
1474 yfg(i,j,3) = .5*(yfg(i,j,1)+yfg(i,j,4))
1475 END IF
1476 IF (r3 < rad .AND. r1 > rad .AND. r2 > rad .AND. r4 > rad) THEN
1477 xfg(i,j,4) = xlm(3) + (rad-r3)/(r4-r3)
1478 yfg(i,j,4) = ylm(4)
1479 xfg(i,j,1) = xlm(1)
1480 yfg(i,j,1) = ylm(3) - (rad-r3)/(r1-r3)
1481 xfg(i,j,2) = .5*(xfg(i,j,1)+xfg(i,j,4))
1482 yfg(i,j,2) = .5*(yfg(i,j,1)+yfg(i,j,4))
1483 END IF
1484 IF (r4 < rad .AND. r1 > rad .AND. r2 > rad .AND. r3 > rad) THEN
1485 xfg(i,j,3) = xlm(4) - (rad-r4)/(r3-r4)
1486 yfg(i,j,3) = ylm(3)
1487 xfg(i,j,2) = xlm(2)
1488 yfg(i,j,2) = ylm(4) - (rad-r4)/(r2-r4)
1489 xfg(i,j,1) = .5*(xfg(i,j,2)+xfg(i,j,3))
1490 yfg(i,j,1) = .5*(yfg(i,j,2)+yfg(i,j,3))
1491 END IF
1493 IF (r1 > rad .AND. r2 < rad .AND. r3 < rad .AND. r4 < rad) THEN
1494 x1 = xlm(1)
1495 x2 = xlm(2) - (rad-r2)/(r1-r2)
1496 xfg(i,j,1) = .5*(x1+x2)
1497 y1 = ylm(1)
1498 y2 = ylm(3) - (rad-r3)/(r1-r3)
1499 yfg(i,j,1) = .5*(y1+y2)
1500 END IF
1501 IF (r2 > rad .AND. r1 < rad .AND. r3 < rad .AND. r4 < rad) THEN
1502 x1 = xlm(4)
1503 x2 = xlm(1) + (rad-r1)/(r2-r1)
1504 xfg(i,j,2) = .5*(x1+x2)
1505 y1 = ylm(1)
1506 y2 = ylm(4) - (rad-r4)/(r2-r4)
1507 yfg(i,j,2) = .5*(y1+y2)
1508 END IF
1509 IF (r3 > rad .AND. r1 < rad .AND. r2 < rad .AND. r4 < rad) THEN
1510 x1 = xlm(1)
1511 x2 = xlm(4) - (rad-r4)/(r3-r4)
1512 xfg(i,j,3) = .5*(x1+x2)
1513 y1 = ylm(4)
1514 y2 = ylm(1) + (rad-r1)/(r3-r1)
1515 yfg(i,j,3) = .5*(y1+y2)
1516 END IF
1517 IF (r4 > rad .AND. r1 < rad .AND. r2 < rad .AND. r3 < rad) THEN
1518 x1 = xlm(2)
1519 x2 = xlm(3) + (rad-r3)/(r4-r3)
1520 xfg(i,j,4) = .5*(x1+x2)
1521 y1 = ylm(3)
1522 y2 = ylm(2) + (rad-r2)/(r4-r2)
1523 yfg(i,j,4) = .5*(y1+y2)
1524 END IF
1526 r12 = (xfg(i,j,1)-xfg(i,j,2))**2 + (yfg(i,j,1)-yfg(i,j,2))**2
1527 r13 = (xfg(i,j,1)-xfg(i,j,3))**2 + (yfg(i,j,1)-yfg(i,j,3))**2
1528 r14 = (xfg(i,j,1)-xfg(i,j,4))**2 + (yfg(i,j,1)-yfg(i,j,4))**2
1529 r23 = (xfg(i,j,2)-xfg(i,j,3))**2 + (yfg(i,j,2)-yfg(i,j,3))**2
1530 r24 = (xfg(i,j,2)-xfg(i,j,4))**2 + (yfg(i,j,2)-yfg(i,j,4))**2
1531 r34 = (xfg(i,j,3)-xfg(i,j,4))**2 + (yfg(i,j,3)-yfg(i,j,4))**2
1532 rmin = MIN(r12,r13,r14,r23,r24,r34)
1534 a_fl = .5*( &
1535 (xfg(i,j,4)-xfg(i,j,1))*(yfg(i,j,3)-yfg(i,j,2)) &
1536 +(yfg(i,j,4)-yfg(i,j,1))*(xfg(i,j,2)-xfg(i,j,3)))
1538 IF (rmin < ep_sq .AND. a_fl < .5) THEN
1539 IF (r12 < ep_sq) THEN
1540 IF (ABS(xfg(i,j,3)-xlm(3)) < ep .AND. &
1541 ABS(yfg(i,j,3)-ylm(3)) < ep) THEN
1542 xfg(i,j,2) = .5*(xfg(i,j,1)+xfg(i,j,4))
1543 yfg(i,j,2) = .5*(yfg(i,j,1)+yfg(i,j,4))
1544 END IF
1545 IF (ABS(xfg(i,j,4)-xlm(4)) < ep .AND. &
1546 ABS(yfg(i,j,4)-ylm(4)) < ep) THEN
1547 xfg(i,j,1) = .5*(xfg(i,j,2)+xfg(i,j,3))
1548 yfg(i,j,1) = .5*(yfg(i,j,2)+yfg(i,j,3))
1549 END IF
1550 END IF
1552 IF (r13 < ep_sq) THEN
1553 IF (ABS(xfg(i,j,2)-xlm(2)) < ep .AND. &
1554 ABS(yfg(i,j,2)-ylm(2)) < ep) THEN
1555 xfg(i,j,3) = .5*(xfg(i,j,1)+xfg(i,j,4))
1556 yfg(i,j,3) = .5*(yfg(i,j,1)+yfg(i,j,4))
1557 END IF
1558 IF (ABS(xfg(i,j,4)-xlm(4)) < ep .AND. &
1559 ABS(yfg(i,j,4)-ylm(4)) < ep) THEN
1560 xfg(i,j,1) = .5*(xfg(i,j,2)+xfg(i,j,3))
1561 yfg(i,j,1) = .5*(yfg(i,j,2)+yfg(i,j,3))
1562 END IF
1563 END IF
1565 IF (r24 < ep_sq) THEN
1566 IF (ABS(xfg(i,j,3)-xlm(3)) < ep .AND. &
1567 ABS(yfg(i,j,3)-ylm(3)) < ep) THEN
1568 xfg(i,j,2) = .5*(xfg(i,j,1)+xfg(i,j,4))
1569 yfg(i,j,2) = .5*(yfg(i,j,1)+yfg(i,j,4))
1570 END IF
1571 IF (ABS(xfg(i,j,1)-xlm(1)) < ep .AND. &
1572 ABS(yfg(i,j,1)-ylm(1)) < ep) THEN
1573 xfg(i,j,4) = .5*(xfg(i,j,2)+xfg(i,j,3))
1574 yfg(i,j,4) = .5*(yfg(i,j,2)+yfg(i,j,3))
1575 END IF
1576 END IF
1578 IF (r34 < ep_sq) THEN
1579 IF (ABS(xfg(i,j,2)-xlm(2)) < ep .AND. &
1580 ABS(yfg(i,j,2)-ylm(2)) < ep) THEN
1581 xfg(i,j,3) = .5*(xfg(i,j,1)+xfg(i,j,4))
1582 yfg(i,j,3) = .5*(yfg(i,j,1)+yfg(i,j,4))
1583 END IF
1584 IF (ABS(xfg(i,j,1)-xlm(1)) < ep .AND. &
1585 ABS(yfg(i,j,1)-ylm(1)) < ep) THEN
1586 xfg(i,j,4) = .5*(xfg(i,j,2)+xfg(i,j,3))
1587 yfg(i,j,4) = .5*(yfg(i,j,2)+yfg(i,j,3))
1588 END IF
1589 END IF
1590 END IF
1591 END IF !rmin lt rad
1592 END DO ! i loop
1593 END DO ! l loop
1595 END IF ! spot fire
1596 !
1597 ! ------------------------------------------------------------------------
1598 if (ishape == 1) THEN ! line fire
1599 !
1600 ! ----- length and width settings....
1601 !
1602 ! ywidfire = 1. + 1.*dyf ! N-S length in m ! param!
1603 ! ywidfire = 409. ! N-S length in m ! param!
1604 ywidfire = 20. ! N-S length in m ! param!
1605 xwidfire = 10. ! 4 ! W-E width in m ! param!
1606 ! xwidfire = dxf * .01 ! narrow line, 1 cm ! param!
1608 ! ----- following is check on width - must be within 2*DXF as coded
1609 IF (xwidfire >= 2.*dxf) xwidfire = 2.*dxf
1611 ! ----- width of fire line in non-dim lenth
1612 xwd = xwidfire/dxf * .5
1614 ! ----- N-S length fire line in fuel cells
1615 iym = INT(ywidfire/dyf)
1617 ! ----- length of end pieces
1618 ywd = (ywidfire - FLOAT(iym)*dyf)/dyf/2.
1619 ywd = MAX(ywd,2.*ep)
1621 ! ----- Location.....
1622 j1 = jj - (iym/2)
1623 j2 = j1 + iym
1624 i1 = ii
1625 i2 = i1 + 1
1627 ! ----- fire length in m = (j2-j1)*dyf or (i2-i1)*dxf
1629 IF (iym > 0) THEN !fire line longer than one fuel cell
1630 DO j = j1,j2
1631 tign_g(i1,j) = time
1632 tign_g(i2,j) = time
1633 nfl(i1,j) = 1
1634 nfl(i2,j) = 1
1635 xfg(i1,j,1) = +.5 - xwd ! left half of fire line
1636 xfg(i1,j,2) = +.5
1637 xfg(i1,j,3) = +.5 - xwd
1638 xfg(i1,j,4) = +.5
1639 yfg(i1,j,1) = -.5
1640 yfg(i1,j,2) = -.5
1641 yfg(i1,j,3) = +.5
1642 yfg(i1,j,4) = +.5
1643 xfg(i2,j,1) = -.5 ! right half of fire line
1644 xfg(i2,j,2) = -.5 + xwd
1645 xfg(i2,j,3) = -.5
1646 xfg(i2,j,4) = -.5 + xwd
1647 yfg(i2,j,1) = -.5
1648 yfg(i2,j,2) = -.5
1649 yfg(i2,j,3) = +.5
1650 yfg(i2,j,4) = +.5
1651 END DO
1652 nfl_max = nfl_max + 1
1653 END IF !fire line longer than one fuel cell
1655 IF (iym == 0) j2 = j1 - 1
1657 tign_g(i1,j2+1) = time
1658 tign_g(i2,j2+1) = time
1659 tign_g(i1,j1-1) = time
1660 tign_g(i2,j1-1) = time
1661 nfl(i1,j2+1) = 1
1662 nfl(i2,j2+1) = 1
1663 nfl(i1,j1-1) = 1
1664 nfl(i2,j1-1) = 1
1665 nfl_max = nfl_max + 4
1667 xfg(i1,j2+1,1) = +.5 - xwd
1668 xfg(i1,j2+1,2) = +.5
1669 xfg(i1,j2+1,3) = +.5 - xwd*.5
1670 xfg(i1,j2+1,4) = +.5
1671 yfg(i1,j2+1,1) = -.5
1672 yfg(i1,j2+1,2) = -.5
1673 yfg(i1,j2+1,3) = -.5 + ywd*.5
1674 yfg(i1,j2+1,4) = -.5 + ywd
1676 xfg(i2,j2+1,1) = -.5
1677 xfg(i2,j2+1,2) = -.5 + xwd
1678 xfg(i2,j2+1,3) = -.5
1679 xfg(i2,j2+1,4) = -.5 + xwd*.5
1680 yfg(i2,j2+1,1) = -.5
1681 yfg(i2,j2+1,2) = -.5
1682 yfg(i2,j2+1,3) = -.5 + ywd
1683 yfg(i2,j2+1,4) = -.5 + ywd*.5
1685 xfg(i1,j1-1,1) = +.5 - xwd*.5
1686 xfg(i1,j1-1,2) = +.5
1687 xfg(i1,j1-1,3) = +.5 - xwd
1688 xfg(i1,j1-1,4) = +.5
1689 yfg(i1,j1-1,1) = +.5 - ywd*.5
1690 yfg(i1,j1-1,2) = +.5 - ywd
1691 yfg(i1,j1-1,3) = +.5
1692 yfg(i1,j1-1,4) = +.5
1694 xfg(i2,j1-1,1) = -.5
1695 xfg(i2,j1-1,2) = -.5 + xwd*.5
1696 xfg(i2,j1-1,3) = -.5
1697 xfg(i2,j1-1,4) = -.5 + xwd
1698 yfg(i2,j1-1,1) = +.5 - ywd
1699 yfg(i2,j1-1,2) = +.5 - ywd*.5
1700 yfg(i2,j1-1,3) = +.5
1701 yfg(i2,j1-1,4) = +.5
1703 END IF !line fire
1705 ! ------------------------------------------------------------------------
1707 IF (ishape == 2) THEN !windmill fire
1709 nxmm = (ide-ids+1)-2
1710 nymm = (jde-jds+1)-2
1712 iym = 14
1713 j1 = 2 + nfry*(nymm/2-iym-1)
1714 j2 = 1 + nfry*(1+nymm/2+iym)
1715 ixm = 14
1716 i1 = 2 + nfrx*(nxmm/2-ixm-1)
1717 i2 = 1 + nfrx*(1+nxmm/2+ixm)
1719 ! ----- Straight line fire
1720 ! iym = 10
1721 ! j1 = 2 + nfry*(nymm/2-iym-1)
1722 ! j2 = 1 + nfry*(1+nymm/2+iym)
1723 ! ixm = 1
1724 ! i1 = 2 + nfrx*(nxmm/2-ixm-1)
1725 ! i2 = 1 + nfrx*(1+nxmm/2+ixm)
1726 i = 1 + nfrx*nxmm/2
1727 !
1728 xmax = FLOAT(nxmm/2)*dx
1729 ymax = FLOAT(nymm/2)*dy
1730 rmax = SQRT(xmax**2+ymax**2)
1731 alpha = +4.*FLOAT(nxmm)/60.
1733 jsm = (nymm/2)*nfry
1734 jsp = (nymm/2)*nfry+3
1735 jsm = jsm - 2
1736 jsp = jsp + 2
1737 !
1738 DO j = j1,j2
1739 ! IF (j == (nymm/2)*nfry+1 .OR. j == (nymm/2)*nfry+2) GO TO 801
1740 IF (j >= jsm+1 .AND. j <= jsp-1) GO TO 801
1741 tign_g(i,j) = time
1742 tign_g(i+1,j) = time
1743 xfg(i,j,1) = +.25
1744 xfg(i,j,2) = +.50
1745 xfg(i,j,3) = +.25
1746 xfg(i,j,4) = +.50
1747 yfg(i,j,1) = -.5
1748 yfg(i,j,2) = -.5
1749 yfg(i,j,3) = +.5
1750 yfg(i,j,4) = +.5
1751 xfg(i+1,j,1) = -.50
1752 xfg(i+1,j,2) = -.25
1753 xfg(i+1,j,3) = -.50
1754 xfg(i+1,j,4) = -.25
1755 yfg(i+1,j,1) = -.5
1756 yfg(i+1,j,2) = -.5
1757 yfg(i+1,j,3) = +.5
1758 yfg(i+1,j,4) = +.5
1759 END DO
1760 !
1761 801 CONTINUE
1763 yfg(i+1,jsp,1) = -.25
1764 yfg(i+1,jsp,2) = -.25
1765 yfg(i ,jsp,1) = -.25
1766 yfg(i ,jsp,2) = -.25
1767 yfg(i+1,jsm,3) = +.25
1768 yfg(i+1,jsm,4) = +.25
1769 yfg(i ,jsm,3) = +.25
1770 yfg(i ,jsm,4) = +.25
1771 !
1772 y = (j2-((jfde-jfds+1)-2)/2-1.5)*dyf !grid center
1773 spd = alpha*ABS(y)/rmax
1774 ss = 0.018*EXP(.8424*spd) ! why Macarthur in here?
1775 dyp = (0.018*dxf)/(ss*dyf)
1776 dyp = SIGN(1.,alpha)*dyp
1778 yfg(i+1,j2,3) = +.25
1779 yfg(i+1,j2,4) = +.25 - .5*dyp
1780 yfg(i ,j2,3) = +.25 + .5*dyp
1781 yfg(i ,j2,4) = +.25
1782 !
1783 yfg(i+1,j1,1) = -.25
1784 yfg(i+1,j1,2) = -.25 - .5*dyp
1785 yfg(i ,j1,1) = -.25 + .5*dyp
1786 yfg(i ,j1,2) = -.25
1788 ! ----- FIRE WIDTH = .01*dyf
1789 j = 1 + nfry*nymm/2
1790 ism = (nxmm/2)*nfrx
1791 isp = (nxmm/2)*nfrx+3
1792 ism = ism - 2
1793 isp = isp + 2
1795 DO i = i1,i2
1796 ! IF (i == (nxmm/2)*nfrx+1 .OR. i == (nxmm/2)*nfrx+2) GO TO 799
1797 IF (i >= ism+1 .AND. i <= isp-1) GO TO 799
1798 tign_g(i,j) = time
1799 tign_g(i,j+1) = time
1800 xfg(i,j,1) = -.5
1801 xfg(i,j,2) = +.5
1802 xfg(i,j,3) = -.5
1803 xfg(i,j,4) = +.5
1804 yfg(i,j,1) = +.25
1805 yfg(i,j,2) = +.25
1806 yfg(i,j,3) = +.50
1807 yfg(i,j,4) = +.50
1809 xfg(i,j+1,1) = -.5
1810 xfg(i,j+1,2) = +.5
1811 xfg(i,j+1,3) = -.5
1812 xfg(i,j+1,4) = +.5
1813 yfg(i,j+1,1) = -.50
1814 yfg(i,j+1,2) = -.50
1815 yfg(i,j+1,3) = -.25
1816 yfg(i,j+1,4) = -.25
1817 END DO
1819 799 CONTINUE
1821 ! ---- EGP need to make sure only the grid that contains
1822 ! the fire center gets set
1823 !
1824 x = (i2-(nfrx*(ifde-ifds+1)-2)/2-1.5)*dxf !grid center
1825 spd = alpha*ABS(x)/rmax
1826 ss = 0.018*EXP(.8424*spd) ! why Macarthur in here?
1827 dxp = (0.018*dyf)/(ss*dxf)
1828 dxp = SIGN(1.,alpha)*dxp
1830 xfg(i1,j+1,3) = -.25 + .5*dxp
1831 xfg(i1,j+1,1) = -.25
1832 xfg(i1,j ,3) = -.25
1833 xfg(i1,j ,1) = -.25 - .5*dxp
1835 ! ism = (nxmm/2)*nfrx
1836 ! isp = (nxmm/2)*nfrx + 3
1837 xfg(ism,j+1,4) = +.25
1838 xfg(ism,j+1,2) = +.25
1839 xfg(ism,j ,4) = +.25
1840 xfg(ism,j ,2) = +.25
1841 xfg(isp,j+1,3) = -.25
1842 xfg(isp,j+1,1) = -.25
1843 xfg(isp,j ,3) = -.25
1844 xfg(isp,j ,1) = -.25
1846 xfg(i2,j+1,4) = +.25 + .5*dxp
1847 xfg(i2,j+1,2) = +.25
1848 xfg(i2,j ,4) = +.25
1849 xfg(i2,j ,2) = +.25 - .5*dxp
1850 END IF ! END ishape=2, windmill fire
1852 tignm = time
1854 END IF ! iof=2
1856 RETURN
1858 END SUBROUTINE fire_init
1860 ! =========================================================================
1862 SUBROUTINE fire_stat(iffg,dt,time, & ! incoming
1863 zs,xcd,ycd,xcn,ycn,sprdx,sprdy, &
1864 ids,ide, kds,kde, jds,jde, &
1865 ims,ime, kms,kme, jms,jme, &
1866 its,ite, kts,kte, jts,jte, &
1867 ifms,ifme, kfms,kfme, jfms,jfme, &
1868 if_st,if_en,jf_st,jf_en, &
1869 nfrx,nfry, &
1870 nfl,nfl_t,tign_g,tign_crt, & ! inout
1871 area,area2,xfg,yfg, &
1872 ixb,iyb,icn) ! out
1874 ! --- if iffg > 0, this routine resets all the variables
1875 ! defining the fire line, updates the locations of
1876 ! the fire line, and ignites any cells fully surrounded
1877 ! fire
1879 IMPLICIT NONE
1881 ! ----- incoming variables
1883 INTEGER, INTENT(in) :: ids,ide, kds,kde, jds,jde
1884 INTEGER, INTENT(in) :: ims,ime, kms,kme, jms,jme
1885 INTEGER, INTENT(in) :: its,ite, kts,kte, jts,jte
1886 INTEGER, INTENT(in) :: ifms,ifme, kfms,kfme, jfms,jfme
1887 INTEGER, INTENT(in) :: if_st,if_en, jf_st,jf_en
1888 INTEGER, INTENT(in) :: nfrx,nfry
1890 INTEGER, INTENT(in) :: iffg
1892 REAL, INTENT(in) :: dt,time
1894 REAL, INTENT(in), DIMENSION( ims:ime,jms:jme ) :: zs
1895 REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xcd,ycd
1896 REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xcn,ycn
1897 REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: sprdx,sprdy
1899 ! ----- inout variables
1901 INTEGER, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: nfl,nfl_t
1903 REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: tign_g,tign_crt
1904 REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: area,area2
1905 REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xfg,yfg
1907 ! ----- outgoing variables
1909 INTEGER, INTENT(out), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: ixb,iyb,icn
1911 ! ----- local variables
1913 INTEGER :: i,j,it
1914 INTEGER :: i1,j1
1915 INTEGER :: nct,icls
1916 INTEGER :: ic1,ic2,ic3,ic4
1917 INTEGER :: inxt,inyt
1918 INTEGER :: is,js,iss,jss
1919 INTEGER :: iod
1920 INTEGER :: isum,jsum
1921 INTEGER :: itest
1922 INTEGER :: itot
1923 INTEGER :: ita,itb,itc
1925 INTEGER, DIMENSION( ifms:ifme,jfms:jfme ) :: nc,icl,islsum
1927 REAL :: x1,y1
1928 REAL :: x2,y2
1929 REAL :: x3,y3
1930 REAL :: x4,y4
1931 REAL :: an
1932 REAL :: t1
1933 REAL :: xavg,yavg
1934 REAL :: xfg_a,yfg_a
1936 REAL, DIMENSION( ifms:ifme,jfms:jfme ) :: tmp
1938 ! ----- when deriving fireline coordinates we always keep the fire to our left
1940 DO j = jf_st,jf_en
1941 DO i = if_st,if_en
1942 DO it = 1,4
1943 ixb(i,j,it) = INT(ABS(xfg(i,j,it)-xlm(it)) / &
1944 (ABS(xfg(i,j,it)-xlm(it)) + ep) + .5 - ep)
1945 iyb(i,j,it) = INT(ABS(yfg(i,j,it)-ylm(it)) / &
1946 (ABS(yfg(i,j,it)-ylm(it)) + ep) + .5 - ep)
1947 icn(i,j,it) = 1 + ixb(i,j,it)*iyb(i,j,it) - ixb(i,j,it) - iyb(i,j,it)
1948 END DO
1949 END DO
1950 END DO
1952 IF (iffg > 0) THEN ! iffg > 0
1954 DO j = jf_st,jf_en
1955 DO i = if_st,if_en
1956 nc(i,j) = icn(i,j,1) + icn(i,j,2) + icn(i,j,3) + icn(i,j,4)
1957 icl(i,j) = ixb(i,j,1) + ixb(i,j,2) + ixb(i,j,3) + ixb(i,j,4) &
1958 + iyb(i,j,1) + iyb(i,j,2) + iyb(i,j,3) + iyb(i,j,4)
1959 tmp(i,j) = .5 * ((xfg(i,j,4)-xfg(i,j,1)) * (yfg(i,j,3)-yfg(i,j,2)) &
1960 + (yfg(i,j,4)-yfg(i,j,1)) * (xfg(i,j,2)-xfg(i,j,3)))
1961 END DO
1962 END DO
1964 DO j = jf_st+1,jf_en-1
1965 DO i = if_st+1,if_en-1
1967 IF (nfl(i,j) == 1) THEN !NFL=1 LOOP
1969 nct = nc(i,j)
1970 icls = icl(i,j)
1972 IF (nct == 3 .AND. icls == 1) THEN !3/1 TREATMENT
1974 ! ----- natural triangle is (x1,x2) (x2,y2), (x3,y3)
1976 ic1 = 10 - icn(i,j,1) - 2*icn(i,j,2) - 3*icn(i,j,3) - 4*icn(i,j,4)
1977 x1 = xlm(ic1)
1978 y1 = ylm(ic1)
1979 x2 = xfg(i,j,ic1)
1980 y2 = yfg(i,j,ic1)
1982 ic3 = (1 - icn(i,j,1))*(2 + ixb(i,j,1)) &
1983 + (1 - icn(i,j,2))*(1 + 3*ixb(i,j,2)) &
1984 + (1 - icn(i,j,3))*(4 - 3*ixb(i,j,3)) &
1985 + (1 - icn(i,j,4))*(3 - ixb(i,j,4))
1986 x3 = xlm(ic3)
1987 y3 = ylm(ic3)
1989 inxt = (1 - ixb(i,j,ic1))*( & ! 0=no virt, 1=virt x-coord
1990 (1-icn(i,j,1)) * (1-iyb(i,j-1,3)) + &
1991 (1-icn(i,j,2)) * (1-iyb(i,j-1,4)) + &
1992 (1-icn(i,j,3)) * (1-iyb(i,j+1,1)) + &
1993 (1-icn(i,j,4)) * (1-iyb(i,j+1,2)) )
1995 x3 = FLOAT(1-inxt)*x3 + FLOAT(inxt)*( &
1996 FLOAT(1-icn(i,j,1)) * xfg(i,j-1,3)+ &
1997 FLOAT(1-icn(i,j,2)) * xfg(i,j-1,4)+ &
1998 FLOAT(1-icn(i,j,3)) * xfg(i,j+1,1)+ &
1999 FLOAT(1-icn(i,j,4)) * xfg(i,j+1,2))
2001 inyt = ixb(i,j,ic1)*( & ! 0=no virt, 1=virt y-coord
2002 (1-icn(i,j,1)) * (1-ixb(i-1,j,2)) + &
2003 (1-icn(i,j,2)) * (1-ixb(i+1,j,1)) + &
2004 (1-icn(i,j,3)) * (1-ixb(i-1,j,4)) + &
2005 (1-icn(i,j,4)) * (1-ixb(i+1,j,3)) )
2007 y3 = FLOAT(1-inyt)*y3 + FLOAT(inyt) * ( &
2008 FLOAT(1-icn(i,j,1))*yfg(i-1,j,2) + &
2009 FLOAT(1-icn(i,j,2))*yfg(i+1,j,1) + &
2010 FLOAT(1-icn(i,j,3))*yfg(i-1,j,4) + &
2011 FLOAT(1-icn(i,j,4))*yfg(i+1,j,3) )
2013 tmp(i,j) = 1. - .5*ABS((x2-x1)*(y3-y1)) - .5*ABS((y2-y1)*(x3-x1))
2015 IF (tmp(i,j) > 1.-ep) THEN
2016 IF (iffg == 1) tmp(i,j) = 1. - 2.*ep !test
2018 xfg(i,j-1,3) = FLOAT(icn(i,j,1))*xfg(i,j-1,3)+ &
2019 FLOAT(1-icn(i,j,1))*xlm(3)
2020 xfg(i,j-1,4) = FLOAT(icn(i,j,2))*xfg(i,j-1,4)+ &
2021 FLOAT(1-icn(i,j,2))*xlm(4)
2022 xfg(i,j+1,1) = FLOAT(icn(i,j,3))*xfg(i,j+1,1)+ &
2023 FLOAT(1-icn(i,j,3))*xlm(1)
2024 xfg(i,j+1,2) = FLOAT(icn(i,j,4))*xfg(i,j+1,2)+ &
2025 FLOAT(1-icn(i,j,4))*xlm(2)
2027 yfg(i-1,j,2) = FLOAT(icn(i,j,1))*yfg(i-1,j,2)+ &
2028 FLOAT(1-icn(i,j,1))*ylm(2)
2029 yfg(i+1,j,1) = FLOAT(icn(i,j,2))*yfg(i+1,j,1)+ &
2030 FLOAT(1-icn(i,j,2))*ylm(1)
2031 yfg(i-1,j,4) = FLOAT(icn(i,j,3))*yfg(i-1,j,4)+ &
2032 FLOAT(1-icn(i,j,3))*ylm(4)
2033 yfg(i+1,j,3) = FLOAT(icn(i,j,4))*yfg(i+1,j,3)+ &
2034 FLOAT(1-icn(i,j,4))*ylm(3)
2036 END IF
2037 END IF !3/1 TREATMENT
2039 IF (nct == 2 .AND. icls == 3) THEN !2/3 TREATMENT
2041 ! ----- We convert 2/3's to 2/2's because code has no treatment
2042 ! for 2/3's, i.e. it is an unecessary class.
2043 ! IC1 and IC2 are indices of the two corners
2044 ! IC3 is index of point to be moved to near IC1 corner.
2046 ic1 = 1*icn(i,j,1)*(ixb(i,j,3)+iyb(i,j,2)) + &
2047 2*icn(i,j,2)*(ixb(i,j,4)+iyb(i,j,1)) + &
2048 3*icn(i,j,3)*(ixb(i,j,1)+iyb(i,j,4)) + &
2049 4*icn(i,j,4)*(ixb(i,j,2)+iyb(i,j,3))
2051 ic2 = 1*icn(i,j,1)*ixb(i,j,4)*iyb(i,j,4) + &
2052 2*icn(i,j,2)*ixb(i,j,3)*iyb(i,j,3) + &
2053 3*icn(i,j,3)*ixb(i,j,2)*iyb(i,j,2) + &
2054 4*icn(i,j,4)*ixb(i,j,1)*iyb(i,j,1)
2056 ic3 = ixb(i,j,1)*iyb(i,j,1) + &
2057 2*ixb(i,j,2)*iyb(i,j,2) + &
2058 3*ixb(i,j,3)*iyb(i,j,3) + &
2059 4*ixb(i,j,4)*iyb(i,j,4)
2061 ic4 = 10 - ic1 - ic2 - ic3
2063 is = i + (1-ixb(i,j,ic4))*INT((1.+ep)*(xfg(i,j,ic1)-xfg(i,j,ic4)))
2064 js = j + ixb(i,j,ic4) *INT((1.+ep)*(yfg(i,j,ic1)-yfg(i,j,ic4)))
2066 xfg(i,j,ic3) = FLOAT(iyb(i,j,ic4))*xlm(ic3) &
2067 + FLOAT(1-iyb(i,j,ic4))* &
2068 (FLOAT(1-nfl(i,js)*ixb(i,js,ic4))* &
2069 (xlm(ic1)+SIGN(2.*ep,xfg(i,j,ic3)-xfg(i,j,ic1))) &
2070 ! + nfl(i,js)*ixb(i,js,ic4)*xfg(i,js,ic4)) & !old version
2071 + nfl(i,js)*ixb(i,js,ic4)*((1-iyb(i,js,ic4))*xfg(i,js,ic4) &!test
2072 + iyb(i,js,ic4)*(-xlm(ic3)+SIGN(2.*ep,xlm(ic3)))))
2074 ! ixb(i,j,ic3) = 1 - iyb(i,j,ic4) !old version
2075 ixb(i,j,ic3) = INT(ABS(xfg(i,j,ic3)-xlm(ic3))/ &
2076 (ABS(xfg(i,j,ic3)-xlm(ic3))+ep)+.5-ep) !test
2078 yfg(i,j,ic3) = FLOAT(ixb(i,j,ic4))*ylm(ic3) &
2079 + FLOAT(1-ixb(i,j,ic4))*(FLOAT(1-nfl(is,j)*iyb(is,j,ic4))* &
2080 (ylm(ic1)+SIGN(2.*ep,yfg(i,j,ic3)-yfg(i,j,ic1))) &
2081 ! + nfl(is,j)*iyb(is,j,ic4)*yfg(is,j,ic4)) & !old version
2082 + nfl(is,j)*iyb(is,j,ic4)*((1-ixb(is,j,ic4))*yfg(is,j,ic4) & !test
2083 + ixb(is,j,ic4)*(-ylm(ic3)+SIGN(2.*ep,ylm(ic3)))))
2085 ! iyb(i,j,ic3) = 1 - ixb(i,j,ic4) !old version
2086 iyb(i,j,ic3) = INT(ABS(yfg(i,j,ic3)-ylm(ic3))/ &
2087 (ABS(yfg(i,j,ic3)-ylm(ic3))+ep)+.5-ep) !test
2089 tmp(i,j) = .5*((xfg(i,j,4)-xfg(i,j,1))*(yfg(i,j,3)-yfg(i,j,2)) &
2090 +(yfg(i,j,4)-yfg(i,j,1))*(xfg(i,j,2)-xfg(i,j,3)))
2092 IF (nfl(is,js) == 0) THEN
2093 xfg(is,js,ic2) = xlm(ic2)
2094 yfg(is,js,ic2) = ylm(ic2)
2095 xfg(is,js,ic4) = FLOAT(1-iyb(i,j,ic3))*xfg(i,j,ic3) &
2096 + FLOAT( iyb(i,j,ic3))*xlm(ic4)
2097 yfg(is,js,ic4) = FLOAT( iyb(i,j,ic3))*yfg(i,j,ic3) &
2098 + FLOAT(1-iyb(i,j,ic3))*ylm(ic4)
2100 iss = is + INT(SIGN(1.,xfg(i,j,ic2)-xfg(i,j,ic4))) &
2101 * (1-iyb(i,j,ic3))
2102 jss = js + INT(SIGN(1.,yfg(i,j,ic2)-yfg(i,j,ic4))) &
2103 * iyb(i,j,ic3)
2105 ! PRINT *,'debug STAT 23 CONVERSION I J=',i,j
2106 ! PRINT *,'debug IS JS ISS JSS=',is,js,iss,jss
2108 xfg(is,js,ic1) = FLOAT(1-iyb(i,j,ic3))*xlm(ic1) &
2109 + FLOAT(iyb(i,j,ic3))*( &
2110 FLOAT(nfl(iss,jss)*(1-iyb(iss,jss,ic3))) &
2111 * xfg(iss,jss,ic3) &
2112 + FLOAT(1-nfl(iss,jss)*(1-iyb(iss,jss,ic3)))* &
2113 (xlm(ic2)+2.*ep*SIGN(1.,xfg(i,j,ic1)-xfg(i,j,ic2))))
2115 yfg(is,js,ic1) = FLOAT(iyb(i,j,ic3))*ylm(ic1) &
2116 + FLOAT(1-iyb(i,j,ic3))*( &
2117 FLOAT(nfl(iss,jss)*(1-ixb(iss,jss,ic3))) &
2118 * yfg(iss,jss,ic3) &
2119 + FLOAT(1-nfl(iss,jss)*(1-ixb(iss,jss,ic3)))* &
2120 (ylm(ic2)+2.*ep*SIGN(1.,yfg(i,j,ic1)-yfg(i,j,ic2))))
2122 xfg(is,js,ic3) = .5*(xfg(is,js,ic1)+xfg(is,js,ic4))
2123 yfg(is,js,ic3) = .5*(yfg(is,js,ic1)+yfg(is,js,ic4))
2125 nfl(is,js) = 1
2126 tign_g(is,js) = time
2128 ! PRINT *,'debug XFG(IS,JS=',(XFG(IS,JS,IT),IT=1,4)
2129 ! PRINT *,'debug YFG(IS,JS=',(YFG(IS,JS,IT),IT=1,4)
2130 ! PRINT *,'debug IC1 IC2 IC3 IC4=',IC1,IC2,IC3,IC4
2131 !
2132 END IF
2133 END IF !2/3 TREATMENT
2135 IF (nct == 3 .AND. icls == 2) THEN !3/2 TREATMENT
2137 ic1 = 1*(ixb(i,j,1)*iyb(i,j,1)) + &
2138 2*(ixb(i,j,2)*iyb(i,j,2)) + &
2139 3*(ixb(i,j,3)*iyb(i,j,3)) + &
2140 4*(ixb(i,j,4)*iyb(i,j,4))
2141 ic2 = 10 - icn(i,j,1) - 2*icn(i,j,2) - 3*icn(i,j,3) - 4*icn(i,j,4)
2143 x1 = xfg(i,j,ic1)
2144 y1 = yfg(i,j,ic1)
2145 x2 = xlm(ic2)
2146 y2 = ylm(ic2)
2148 iod = ic1 - 2*(ic1/2)
2149 ic3 = ic1 - 1 + 2*iod
2150 ic4 = 6 - ic1 - 2*iod
2151 is = i + 1 - 2*iod
2152 js = j - 1 + 2*(ic1/3)
2154 x3 = FLOAT(1-nfl(i,js)*ixb(i,js,ic4))*xlm(ic3) + &
2155 FLOAT( nfl(i,js)*ixb(i,js,ic4))*xfg(i,js,ic4)
2156 y3 = ylm(ic3)
2157 x4 = xlm(ic4)
2158 y4 = FLOAT(1-nfl(is,j)*iyb(is,j,ic3))*ylm(ic4) + &
2159 FLOAT( nfl(is,j)*iyb(is,j,ic3))*yfg(is,j,ic3)
2161 tmp(i,j) = 1. - .5*(ABS((x2-x1)*(y3-y4)) + ABS((y2-y1)*(x4-x3)))
2163 END IF !3/2 TREATMENT
2165 END IF !NFL=1 LOOP
2167 END DO
2168 END DO
2170 IF (iffg == 1) THEN ! iffg == 1
2172 DO j = jf_st,jf_en
2173 DO i = if_st,if_en
2174 area(i,j) = tmp(i,j)
2175 END DO
2176 END DO
2178 END IF ! iffg == 1
2180 IF(IFFG == 2) THEN !IFFG == 2
2182 ! --- locate and ignite any totally boundary enclosed regions, i.e. where
2183 ! nfl=1 everywhere within a closed burning contour. We only consider
2184 ! regions with area less than 1.-ep
2186 DO j = jf_st,jf_en
2187 DO i = if_st,if_en
2188 an = .5*((xfg(i,j,4)-xfg(i,j,1))*(yfg(i,j,3)-yfg(i,j,2)) &
2189 + (yfg(i,j,4)-yfg(i,j,1))*(xfg(i,j,2)-xfg(i,j,3)))
2190 nfl_t(i,j) = INT((ep+tign_g(i,j)+ABS(ep+tign_g(i,j)))/ &
2191 (2.*ABS(tign_g(i,j))+2.*ep)+.5)
2192 nfl(i,j) = nfl_t(i,j) * (1 - INT(an+ep))
2193 END DO
2194 END DO
2196 DO j = jf_st,jf_en
2197 DO i = if_st,if_en
2198 DO it = 1,4
2199 ixb(i,j,it) = INT(ABS(xfg(i,j,it)-xlm(it))/ &
2200 (ABS(xfg(i,j,it)-xlm(it)) + ep) + .5 - ep)
2201 iyb(i,j,it) = INT(ABS(yfg(i,j,it)-ylm(it))/ &
2202 (ABS(yfg(i,j,it)-ylm(it)) + ep) + .5 - ep)
2203 icn(i,j,it) = 1 + ixb(i,j,it)*iyb(i,j,it) &
2204 - ixb(i,j,it) - iyb(i,j,it)
2205 END DO
2206 END DO
2207 END DO
2209 DO j = jf_st,jf_en
2210 DO i = if_st,if_en
2211 nc(i,j) = icn(i,j,1) + icn(i,j,2) + icn(i,j,3) + icn(i,j,4)
2212 icl(i,j) = ixb(i,j,1) + ixb(i,j,2) + ixb(i,j,3) + ixb(i,j,4) + &
2213 iyb(i,j,1) + iyb(i,j,2) + iyb(i,j,3) + iyb(i,j,4)
2214 END DO
2215 END DO
2217 DO j = jf_st+1,jf_en-1
2218 DO i = if_st+1,if_en-1
2220 IF (nfl(i,j) == 1) THEN !NFL=1
2221 islsum(i,j) = &
2222 INT((tign_g(i+1,j) + ABS(tign_g(i+1,j)) + 2.*ep)/ &
2223 (2.*ABS(tign_g(i+1,j)) + 1.5*ep)) + &
2224 INT((tign_g(i-1,j) + ABS(tign_g(i-1,j)) + 2.*ep)/ &
2225 (2.*ABS(tign_g(i-1,j)) + 1.5*ep)) + &
2226 INT((tign_g(i,j+1) + ABS(tign_g(i,j+1)) + 2.*ep)/ &
2227 (2.*ABS(tign_g(i,j+1)) + 1.5*ep)) + &
2228 INT((tign_g(i,j-1) + ABS(tign_g(i,j-1)) + 2.*ep)/ &
2229 (2.*ABS(tign_g(i,j-1)) + 1.5*ep)) + &
2230 INT((tign_g(i+1,j+1)+ABS(tign_g(i+1,j+1)) + 2.*ep)/ &
2231 (2.*ABS(tign_g(i+1,j+1)) + 1.5*ep)) + &
2232 INT((tign_g(i-1,j+1)+ABS(tign_g(i-1,j+1)) + 2.*ep)/ &
2233 (2.*ABS(tign_g(i-1,j+1)) + 1.5*ep)) + &
2234 INT((tign_g(i+1,j-1)+ABS(tign_g(i+1,j-1)) + 2.*ep)/ &
2235 (2.*ABS(tign_g(i+1,j-1)) + 1.5*ep)) + &
2236 INT((tign_g(i-1,j-1)+ABS(tign_g(i-1,j-1)) + 2.*ep)/ &
2237 (2.*ABS(tign_g(i-1,j-1)) + 1.5*ep))
2238 END IF ! nfl=1
2239 END DO
2240 END DO
2242 DO j = jf_st+1,jf_en-1
2243 DO i = if_st+1,if_en-1
2245 IF (nfl(i,j) == 1) THEN !NFL=1
2247 isum = islsum(i,j)
2249 IF (isum == 8) THEN !ISUM=8
2251 itest = 1
2253 IF (nc(i,j) == 1 .AND. icl(i,j) == 4) THEN !1/4 treatment
2254 ! ----- test for threat of second ignition (itest=0 is necessary to continue)
2255 itest=(1-icn(i,j,1))*(icn(i-1,j,2)+icn(i-1,j-1,4)+icn(i,j-1,3)) &
2256 +(1-icn(i,j,2))*(icn(i+1,j,1)+icn(i+1,j-1,3)+icn(i,j-1,4)) &
2257 +(1-icn(i,j,3))*(icn(i-1,j,4)+icn(i-1,j+1,2)+icn(i,j+1,1)) &
2258 +(1-icn(i,j,4))*(icn(i+1,j,3)+icn(i+1,j+1,1)+icn(i,j+1,2))
2259 END IF !1/4 treatment
2261 IF (itest > 0) THEN
2262 !! nfl(i,j) = 0
2263 area2(i,j) = 1.
2264 DO it = 1,4
2265 ixb(i,j,it) = 0
2266 iyb(i,j,it) = 0
2267 icn(i,j,it) = 1
2268 xfg(i,j,it) = xlm(it)
2269 yfg(i,j,it) = ylm(it)
2270 END DO
2271 END IF ! itest > 0
2272 END IF ! isum = 8
2273 END IF ! nfl = 1
2274 END DO
2275 END DO
2277 DO j = jf_st+1,jf_en-1
2278 DO i = if_st+1,if_en-1
2279 IF (nfl(i,j) == 1) THEN ! nfl=1
2280 isum = islsum(i,j)
2281 IF (isum == 8) THEN ! isum = 8
2282 itest = 1
2284 IF (nc(i,j) == 2 .AND. icl(i,j) == 2) THEN ! 2/2 treatment
2285 IF (icn(i,j,1)+icn(i,j,2) == 2) itest= &
2286 (icn(i-1,j,4)+icn(i-1,j+1,2)+icn(i,j+1,1)) &
2287 + (icn(i+1,j,3)+icn(i+1,j+1,1)+icn(i,j+1,2))
2288 IF (icn(i,j,3)+icn(i,j,4) == 2) itest= &
2289 (icn(i-1,j,2)+icn(i-1,j-1,4)+icn(i,j-1,3)) &
2290 + (icn(i+1,j,1)+icn(i+1,j-1,3)+icn(i,j-1,4))
2291 IF (icn(i,j,1)+icn(i,j,3) == 2) itest= &
2292 (icn(i+1,j,1)+icn(i+1,j-1,3)+icn(i,j-1,4)) &
2293 + (icn(i+1,j,3)+icn(i+1,j+1,1)+icn(i,j+1,2))
2294 IF (icn(i,j,2)+icn(i,j,4) == 2) itest= &
2295 (icn(i-1,j,2)+icn(i-1,j-1,4)+icn(i,j-1,3)) &
2296 + (icn(i-1,j,4)+icn(i-1,j+1,2)+icn(i,j+1,1))
2297 END IF ! 2/2 treatment
2299 IF (itest > 0) THEN
2300 ! itot = itot + 1
2301 !! nfl(i,j) = 0
2302 area2(i,j) = 1.
2303 DO it = 1,4
2304 ixb(i,j,it) = 0
2305 iyb(i,j,it) = 0
2306 icn(i,j,it) = 1
2307 xfg(i,j,it) = xlm(it)
2308 yfg(i,j,it) = ylm(it)
2309 END DO
2310 END IF ! itest > 0
2311 END IF ! isum = 8
2312 END IF ! nfl = 1
2313 END DO
2314 END DO
2316 DO j = jf_st+1,jf_en-1
2317 DO i = if_st+1,if_en-1
2319 IF (nfl(i,j) == 1) THEN !NFL=1
2321 isum = islsum(i,j)
2323 IF (isum == 8) THEN !ISUM=8
2325 itest = 1
2327 IF (nc(i,j) == 3 .AND. icl(i,j) == 1) THEN !3/1 treatment
2329 ic1 = 10-icn(i,j,1)-2*icn(i,j,2)-3*icn(i,j,3)-4*icn(i,j,4)
2331 IF (ic1 == 1) THEN
2332 itest = (1-icn(i,j,ic1)) * &
2333 (icn(i-1,j,2)+icn(i-1,j-1,4) + icn(i,j-1,3) &
2334 + icn(i,j-1,1)*iyb(i,j-1,3) + &
2335 icn(i-1,j,1)*ixb(i,j-1,2) &
2336 + icn(i,j-1,2)*icn(i-1,j-1,2)*iyb(i,j,1) &
2337 + icn(i-1,j,3)*icn(i-1,j-1,3)*ixb(i,j,1))
2338 END IF
2340 IF (ic1 == 2) THEN
2341 itest = (1-icn(i,j,ic1)) * &
2342 (icn(i+1,j,1)+icn(i+1,j-1,3)+icn(i,j-1,4) &
2343 + icn(i,j-1,2)*iyb(i,j-1,4)+ &
2344 icn(i+1,j,2)*ixb(i,j-1,1) &
2345 + icn(i,j-1,1)*icn(i+1,j-1,1)*iyb(i,j,2) &
2346 + icn(i+1,j,4)*icn(i+1,j-1,4)*ixb(i,j,2))
2347 END IF
2349 IF (ic1 == 3) THEN
2350 itest = (1-icn(i,j,ic1)) * &
2351 (icn(i-1,j,4)+icn(i-1,j+1,2)+icn(i,j+1,1) &
2352 + icn(i,j+1,3)*iyb(i,j+1,1) + &
2353 icn(i-1,j,3) * ixb(i-1,j,4) &
2354 + icn(i,j+1,4)*icn(i-1,j+1,4)*iyb(i,j,3) &
2355 + icn(i-1,j,1)*icn(i-1,j+1,1)*ixb(i,j,3))
2356 END IF
2358 IF (ic1 == 4) THEN
2359 itest = (1-icn(i,j,ic1)) * &
2360 (icn(i+1,j,3)+icn(i+1,j+1,1)+icn(i,j+1,2) &
2361 + icn(i,j+1,4)*iyb(i,j+1,2)+ &
2362 icn(i+1,j,4)*ixb(i+1,j,3) &
2363 + icn(i,j+1,3)*icn(i+1,j+1,3)*iyb(i,j,4) &
2364 + icn(i+1,j,2)*icn(i+1,j+1,2)*ixb(i,j,4))
2365 END IF
2367 END IF !3/1 treatment
2369 IF (itest > 0) THEN
2370 area2(i,j) = 1.
2371 DO it = 1,4
2372 ixb(i,j,it) = 0
2373 iyb(i,j,it) = 0
2374 icn(i,j,it) = 1
2375 xfg(i,j,it) = xlm(it)
2376 yfg(i,j,it) = ylm(it)
2377 END DO
2378 END IF ! itest > 0
2379 END IF ! ISUM = 8
2380 END IF ! NFL = 1
2381 END DO
2382 END DO
2384 ! --- here we are figuring out which cells define the fire line
2385 !
2386 ! if tign_g() > 0 then nfl() is set to 1 (this only tells us
2387 ! if the cell is on fire. then we go find out whether our
2388 ! neighbors are on fire and whether their tracers are in the
2389 ! adjacent corner. if all four neighboring cells are on fire
2390 ! and the tracers are in the corners nearest my current point,
2391 ! then we must be in an interior point, nfl()=0. if all four
2392 ! neighboring cells don't have tracers pushed to the corner near
2393 ! me, then we must be at the edge of the fire, nfl() = 1.
2395 DO j = jf_st,jf_en
2396 DO i = if_st,if_en
2397 nfl(i,j) = INT( (ep + tign_g(i,j) + ABS(ep + tign_g(i,j))) / &
2398 (2.*ABS(tign_g(i,j))+2.*ep)+.5 )
2399 nfl_t(i,j) = (1 - INT(area(i,j) + ep)) !test
2400 END DO
2401 END DO
2403 DO j = jf_st+1,jf_en-1
2404 DO i = if_st+1,if_en-1
2405 nfl_t(i,j) = (1 - int(area(i,j) + ep - 2.*ep* &
2406 (1. - FLOAT(( &
2407 ((icn(i+1,j,1) + icn(i+1,j,3))/2)*nfl(i+1,j) + &
2408 ((icn(i-1,j,2) + icn(i-1,j,4))/2)*nfl(i-1,j) + &
2409 ((icn(i,j+1,1) + icn(i,j+1,2))/2)*nfl(i,j+1) + &
2410 ((icn(i,j-1,3) + icn(i,j-1,4))/2)*nfl(i,j-1) &
2411 )/4)))) !test
2412 END DO
2413 END DO
2415 DO j = jf_st,jf_en
2416 DO i = if_st,if_en
2417 nfl(i,j) = nfl(i,j)*nfl_t(i,j)
2418 END DO
2419 END DO
2421 ! --- check on validity of 1/4's and 2/2's
2423 DO j = jf_st+1,jf_en-1
2424 DO i = if_st+1,if_en-1
2425 IF (nfl(i,j) == 1) THEN !NFL=1
2426 nct = icn(i,j,1)+icn(i,j,2)+icn(i,j,3)+icn(i,j,4)
2427 icls = ixb(i,j,1)+ixb(i,j,2)+ixb(i,j,3)+ixb(i,j,4) + &
2428 iyb(i,j,1)+iyb(i,j,2)+iyb(i,j,3)+iyb(i,j,4)
2430 ! --- check that 1/4 is logical
2432 IF (nct == 1 .AND. icls == 4) THEN ! nct=1 icls=4 validity test
2434 CALL fire_valid14(i,j,ic1,ic2,ic3,ic4,ita,itb,itc,nc, &
2435 icl,xfg,yfg,ixb,iyb,icn, &
2436 ifms,ifme, kfms,kfme, jfms,jfme)
2438 IF (ita == 0 .AND. itb == 0 .AND. itc > 0) THEN
2439 xfg(i,j,ic3) = xlm(ic3)
2440 yfg(i,j,ic3) = ylm(ic3)
2441 icn(i,j,ic3) = 1
2442 ixb(i,j,ic3) = 0
2443 iyb(i,j,ic3) = 0
2444 xfg(i,j,ic4) = xlm(ic4)
2445 yfg(i,j,ic4) = ylm(ic4)
2446 icn(i,j,ic4) = 1
2447 ixb(i,j,ic4) = 0
2448 iyb(i,j,ic4) = 0
2450 ! ----- following call takes care of indexing order effects
2452 IF (nc(i-1,j) == 1 .AND. icl(i-1,j) == 4 .AND. i > 2) &
2453 CALL fire_valid14(i-1,j,ic1,ic2,ic3,ic4,ita,itb,itc,nc, &
2454 icl,xfg,yfg,ixb,iyb,icn, &
2455 ifms,ifme, kfms,kfme, jfms,jfme)
2456 IF (nc(i,j-1) == 1 .AND. icl(i,j-1) == 4 .AND. j > 2) &
2457 CALL fire_valid14(i,j-1,ic1,ic2,ic3,ic4,ita,itb,itc,nc, &
2458 icl,xfg,yfg,ixb,iyb,icn, &
2459 ifms,ifme, kfms,kfme, jfms,jfme)
2460 END IF
2461 END IF ! NCT=1 ICLS=4 validity test
2462 END IF ! NFL=1
2463 END DO
2464 END DO
2466 DO j = jf_st+1,jf_en-1
2467 DO i = if_st+1,if_en-1
2468 IF (nfl(i,j) == 1) THEN !NFL=1
2469 nct = icn(i,j,1) + icn(i,j,2) + icn(i,j,3) + icn(i,j,4)
2470 icls = ixb(i,j,1) + ixb(i,j,2) + ixb(i,j,3) + ixb(i,j,4) + &
2471 iyb(i,j,1) + iyb(i,j,2) + iyb(i,j,3) + iyb(i,j,4)
2473 ! -- check on validity of 2/2's
2475 IF (nct == 2 .AND. icls == 2) THEN !2/2 TESTING FOLLOWS
2476 isum = nfl(i+1,j) + nfl(i-1,j)
2478 IF (iyb(i,j,1)+iyb(i,j,2) == 2 .AND. isum < 2) THEN
2479 IF (nfl(i+1,j) == 0 .AND. area2(i+1,j) > 1.-ep) THEN
2480 yfg(i,j,2) = ylm(2)
2481 END IF
2482 IF (nfl(i-1,j) == 0 .AND. area2(i-1,j) > 1.-ep) THEN
2483 yfg(i,j,1) = ylm(1)
2484 END IF
2485 END IF
2487 IF (iyb(i,j,3)+iyb(i,j,4) == 2 .AND. isum < 2) THEN
2488 IF (nfl(i+1,j) == 0 .AND. area2(i+1,j) > 1.-ep) THEN
2489 yfg(i,j,4) = ylm(4)
2490 END IF
2491 IF (nfl(i-1,j) == 0 .AND. area2(i-1,j) > 1.-ep) THEN
2492 yfg(i,j,3) = ylm(3)
2493 END IF
2494 END IF
2496 jsum = nfl(i,j+1) + nfl(i,j-1)
2497 IF (ixb(i,j,1)+ixb(i,j,3) == 2 .AND. jsum < 2) THEN
2498 IF (nfl(i,j+1) == 0 .AND. area2(i,j+1) > 1.-ep) THEN
2499 xfg(i,j,3) = xlm(3)
2500 END IF
2501 IF (nfl(i,j-1) == 0 .AND. area2(i,j-1) > 1.-ep) THEN
2502 xfg(i,j,1) = xlm(1)
2503 END IF
2504 END IF
2506 IF (ixb(i,j,2)+ixb(i,j,4) == 2 .AND. jsum < 2) THEN
2507 IF (nfl(i,j+1) == 0 .AND. area2(i,j+1) > 1.-ep) THEN
2508 xfg(i,j,4) = xlm(4)
2509 END IF
2510 IF (nfl(i,j-1) == 0 .AND. area2(i,j-1) > 1.-ep) THEN
2511 xfg(i,j,2) = xlm(2)
2512 END IF
2513 END IF
2514 END IF !2/2 TESTING ABOVE
2516 ! --- this portion of code was not active in the dand1 testing
2517 ! debug new code follows
2518 IF (nct == 3 .AND. (icls == 1 .OR. icls == 2)) THEN ! 3/1 TESTING
2519 ic2 = (1-icn(i,j,1)) + 2*(1-icn(i,j,2)) &
2520 + 3*(1-icn(i,j,3)) + 4*(1-icn(i,j,4))
2521 ic1 = 5 - ic2
2522 ic3 = 2 - (ic1*ic2)/6
2523 ic4 = 10 - ic1 - ic2 - ic3
2524 t1 = ABS(ABS(xfg(i,j,ic2))-.5) + ABS(ABS(yfg(i,j,ic2))-.5)
2525 IF (t1 < 10.*ep) THEN
2526 PRINT *,'debug 3/1 to 3/2 conversion hit'
2527 xfg(i,j,ic2) = .5*(xfg(i,j,ic3)+xfg(i,j,ic4))
2528 yfg(i,j,ic2) = .5*(yfg(i,j,ic3)+yfg(i,j,ic4))
2529 ixb(i,j,ic2) = 1
2530 iyb(i,j,ic2) = 1
2531 END IF
2532 END IF !3/1 TESTING FOLLOWS
2533 ! debug new code above
2534 ! --- the above portion of code was not active in the dand1 testing
2536 END IF !NFL=1
2537 END DO
2538 END DO
2540 DO j = jf_st,jf_en
2541 DO i = if_st,if_en
2542 nc(i,j) = icn(i,j,1)+icn(i,j,2)+icn(i,j,3)+icn(i,j,4)
2543 icl(i,j) = ixb(i,j,1)+ixb(i,j,2)+ixb(i,j,3)+ixb(i,j,4) + &
2544 iyb(i,j,1)+iyb(i,j,2)+iyb(i,j,3)+iyb(i,j,4)
2545 END DO
2546 END DO
2548 DO j = jf_st+1,jf_en-1
2549 DO i = if_st+1,if_en-1
2551 IF (nfl(i,j) == 1) THEN !NFL=1
2553 nct = nc(i,j)
2554 icls = icl(i,j)
2556 ! --- align neighbors with 2/2s
2558 IF (nct == 2 .AND. icls == 2) THEN !NCT=2 ICLS=2
2560 IF (icn(i,j,1)+icn(i,j,3) == 2) THEN
2561 IF (nfl(i,j+1)*ixb(i,j+1,2) == 1 &
2562 .AND. iyb(i,j+1,2) == 0) THEN
2563 xavg = .5*(xfg(i,j+1,2)+xfg(i,j,4))
2564 ! xavg = amax1(xfg(i,j+1,2),xfg(i,j,4))
2565 xfg(i,j+1,2) = xavg
2566 xfg(i,j,4) = xavg
2567 END IF
2568 IF (nc(i,j+1) == 4) xfg(i,j,4) = xlm(4)
2569 IF (nfl(i,j-1)*ixb(i,j-1,4) == 1 &
2570 .AND. iyb(i,j-1,4) == 0) THEN
2571 xavg = .5*(xfg(i,j-1,4)+xfg(i,j,2))
2572 ! xavg = amax1(xfg(i,j-1,4),xfg(i,j,2))
2573 xfg(i,j-1,4) = xavg
2574 xfg(i,j,2) = xavg
2575 END IF
2576 IF (nc(i,j-1) == 4) xfg(i,j,2) = xlm(2)
2577 END IF
2579 IF (icn(i,j,2)+icn(i,j,4) == 2) THEN
2580 IF (nfl(i,j+1)*ixb(i,j+1,1) == 1 &
2581 .AND. iyb(i,j+1,1) == 0) THEN
2582 xavg = .5*(xfg(i,j+1,1)+xfg(i,j,3))
2583 ! xavg = MIN(xfg(i,j+1,1),xfg(i,j,3))
2584 xfg(i,j+1,1) = xavg
2585 xfg(i,j,3) = xavg
2586 END IF
2587 IF (nc(i,j+1) == 4) xfg(i,j,3) = xlm(3)
2588 IF (nfl(i,j-1)*ixb(i,j-1,3) == 1 &
2589 .AND. iyb(i,j-1,3) == 0) THEN
2590 xavg = .5*(xfg(i,j-1,3)+xfg(i,j,1))
2591 ! xavg = MIN(xfg(i,j-1,3),xfg(i,j,1))
2592 xfg(i,j-1,3) = xavg
2593 xfg(i,j,1) = xavg
2594 END IF
2595 IF (nc(i,j-1) == 4) xfg(i,j,1) = xlm(1)
2596 END IF
2598 IF (icn(i,j,1)+icn(i,j,2) == 2) THEN
2599 IF (nfl(i+1,j)*iyb(i+1,j,3) == 1 &
2600 .AND. ixb(i+1,j,3) == 0) THEN
2601 yavg = .5*(yfg(i+1,j,3)+yfg(i,j,4))
2602 ! yavg = MAX(yfg(i+1,j,3),yfg(i,j,4))
2603 yfg(i+1,j,3) = yavg
2604 yfg(i,j,4) = yavg
2605 END IF
2606 IF (nc(i+1,j) == 4) yfg(i,j,4) = ylm(4)
2607 IF (nfl(i-1,j)*iyb(i-1,j,4) == 1 &
2608 .AND. ixb(i-1,j,4) == 0) THEN
2609 yavg = .5*(yfg(i-1,j,4)+yfg(i,j,3))
2610 ! yavg = MAX(yfg(i-1,j,4),yfg(i,j,3))
2611 yfg(i-1,j,4) = yavg
2612 yfg(i,j,3) = yavg
2613 END IF
2614 IF (nc(i-1,j) == 4) yfg(i,j,3) = ylm(3)
2615 END IF
2617 IF (icn(i,j,3)+icn(i,j,4) == 2) THEN
2618 IF (nfl(i+1,j)*iyb(i+1,j,1) == 1 &
2619 .AND. ixb(i+1,j,1) == 0) THEN
2620 yavg = .5*(yfg(i+1,j,1)+yfg(i,j,2))
2621 ! yavg = MIN(yfg(i+1,j,1),yfg(i,j,2))
2622 yfg(i+1,j,1) = yavg
2623 yfg(i,j,2) = yavg
2624 END IF
2625 IF (nc(i+1,j) == 4) yfg(i,j,2) = ylm(2)
2626 IF (nfl(i-1,j)*iyb(i-1,j,2) == 1 &
2627 .AND. ixb(i-1,j,2) == 0) THEN
2628 yavg = .5*(yfg(i-1,j,2)+yfg(i,j,1))
2629 ! yavg = MIN(yfg(i-1,j,2),yfg(i,j,1))
2630 yfg(i-1,j,2) = yavg
2631 yfg(i,j,1) = yavg
2632 END IF
2633 IF (nc(i-1,j) == 4) yfg(i,j,1) = ylm(1)
2634 END IF
2636 END IF !NCT=2 ICLS=2
2638 ! --- align 1/4 neighbors with 3/1 moving coordinate
2640 IF (nct == 3 .AND. icls == 1) THEN !NCT=3 ICLS=1
2642 IF (icn(i,j,1) == 0) THEN
2643 IF(iyb(i,j,1) == 1 &
2644 .AND. nc(i-1,j) == 1 &
2645 .AND. icl(i-1,j) == 4) THEN
2646 yfg(i-1,j,2) = yfg(i,j,1)
2647 END IF
2648 IF (ixb(i,j,1) == 1 &
2649 .AND. nc(i,j-1) == 1 &
2650 .AND. icl(i,j-1) == 4) THEN
2651 xfg(i,j-1,3) = xfg(i,j,1)
2652 END IF
2653 END IF
2655 IF (icn(i,j,2) == 0) THEN
2656 IF (iyb(i,j,2) == 1 &
2657 .AND. nc(i+1,j) == 1 &
2658 .AND. icl(i+1,j) == 4) THEN
2659 yfg(i+1,j,1) = yfg(i,j,2)
2660 END IF
2661 IF (ixb(i,j,2) == 1 &
2662 .AND. nc(i,j-1) == 1 &
2663 .AND. icl(i,j-1) == 4) THEN
2664 xfg(i,j-1,4) = xfg(i,j,2)
2665 END IF
2666 END IF
2668 IF (icn(i,j,3) == 0) THEN
2669 IF (iyb(i,j,3) == 1 &
2670 .AND. nc(i-1,j) == 1 &
2671 .AND. icl(i-1,j) == 4) THEN
2672 yfg(i-1,j,4) = yfg(i,j,3)
2673 END IF
2674 IF (ixb(i,j,3) == 1 &
2675 .AND. nc(i,j+1) == 1 &
2676 .AND. icl(i,j+1) == 4) THEN
2677 xfg(i,j+1,1) = xfg(i,j,3)
2678 END IF
2679 END IF
2681 IF (icn(i,j,4) == 0) THEN
2682 IF (iyb(i,j,4) == 1 &
2683 .AND. nc(i+1,j) == 1 &
2684 .AND. icl(i+1,j) == 4) THEN
2685 yfg(i+1,j,3) = yfg(i,j,4)
2686 END IF
2687 IF (ixb(i,j,4) == 1 &
2688 .AND. nc(i,j+1) == 1 &
2689 .AND. icl(i,j+1) == 4) THEN
2690 xfg(i,j+1,2) = xfg(i,j,4)
2691 END IF
2692 END IF
2694 END IF !NCT=3 ICLS=1
2696 ! --- align abutting 1/4's
2698 itest=1
2699 if (itest.eq.1) then
2700 IF (nct.eq.1 .AND. icls == 4) THEN !NCT=1 ICLS=4
2701 ic1 =icn(i,j,1) + 2*icn(i,j,2) + 3*icn(i,j,3) + 4*icn(i,j,4)
2702 ic2 = 5 - ic1
2703 ic3 = ixb(i,j,1)*(1-iyb(i,j,1))+2*ixb(i,j,2)*(1-iyb(i,j,2)) + &
2704 3*ixb(i,j,3)*(1-iyb(i,j,3))+4*ixb(i,j,4)*(1-iyb(i,j,4))
2705 ic4 = 10 - ic1 - ic2 - ic3
2706 iod = ic1 - 2*(ic1/2)
2707 is = 1 - 2*iod
2708 js = -1 + 2*(ic1/3)
2710 IF (ic1 >= 1) THEN
2711 IF (nc(i,j+js) == 1 .AND. &
2712 icl(i,j+js) == 4 .AND. &
2713 icn(i,j+js,ic4) == 1) THEN
2714 xfg_a = .5*(xfg(i,j,ic3)+xfg(i,j+js,ic2))
2715 xfg(i,j,ic3) = xfg_a
2716 xfg(i,j+js,ic2) = xfg_a
2717 ! ----- align central coordinate
2718 xfg(i,j,ic2) = .5*(xfg(i,j,ic3)+xfg(i,j,ic4))
2719 ! yfg(i,j,ic2) = .5*(yfg(i,j,ic3)+yfg(i,j,ic4))
2720 END IF
2721 IF (nc(i+is,j).eq.1 .AND. &
2722 icl(i+is,j).eq.4 .AND. &
2723 icn(i+is,j,ic3) == 1) THEN
2724 yfg_a = .5*(yfg(i,j,ic4)+yfg(i+is,j,ic2))
2725 yfg(i,j,ic4) = yfg_a
2726 yfg(i+is,j,ic2) = yfg_a
2727 ! ----- align central coordinate
2728 ! xfg(i,j,ic2) = .5*(xfg(i,j,ic3)+xfg(i,j,ic4))
2729 yfg(i,j,ic2) = .5*(yfg(i,j,ic3)+yfg(i,j,ic4))
2730 END IF
2731 END IF
2733 END IF !NCT=1 ICLS=4
2734 END IF
2735 END IF !NFL=1
2736 END DO
2737 END DO
2739 DO j = jf_st,jf_en
2740 DO i = if_st,if_en
2741 tmp(i,j) = .5*((xfg(i,j,4)-xfg(i,j,1))*(yfg(i,j,3)-yfg(i,j,2)) &
2742 + (yfg(i,j,4)-yfg(i,j,1))*(xfg(i,j,2)-xfg(i,j,3)))
2743 area2(i,j) = tmp(i,j)
2744 If (nfl(i,j) < 0 .AND. ABS(time-tign_g(i,j)) < dt) THEN
2745 tmp(i,j) = 0.0
2746 nfl(i,j) = 0
2747 tign_g(i,j) = -100.
2748 DO it = 1,4
2749 xfg(i,j,it) = 0.0
2750 yfg(i,j,it) = 0.0
2751 END DO
2752 END IF
2753 END DO
2754 END DO
2756 ! --- identify cells that are completely on fire for fire_burn_fcn
2758 DO j = jf_st+1,jf_en-1
2759 DO i = if_st+1,if_en-1
2760 IF (area2(i,j) > (1.-ep) .AND. tign_crt(i,j) < 0.) THEN
2761 tign_crt(i,j) = time
2762 END IF
2763 END DO
2764 END DO
2766 END IF ! iffg == 2
2767 END IF ! iffg > 0
2769 RETURN
2771 END SUBROUTINE fire_stat
2773 ! =========================================================================
2775 SUBROUTINE fire_ln(dt,time,zs,sprdx,sprdy, & ! incoming
2776 ids,ide, kds,kde, jds,jde, &
2777 ims,ime, kms,kme, jms,jme, &
2778 its,ite, kts,kte, jts,jte, &
2779 ifms,ifme, kfms,kfme, jfms,jfme, &
2780 if_st,if_en,jf_st,jf_en, &
2781 nfrx,nfry, &
2782 ncod,in1,in2,ixb,iyb,icn, & ! inout
2783 tign_g,tign_crt,area,area2,xfg,yfg, &
2784 nfl,nfl_t,radhld,xcd,ycd,xcn,ycn) ! outgoing
2786 ! ----- this routine creates points outlining the fire
2788 IMPLICIT NONE
2790 ! ----- incoming variables
2792 INTEGER, INTENT(in) :: ids,ide, kds,kde, jds,jde
2793 INTEGER, INTENT(in) :: ims,ime, kms,kme, jms,jme
2794 INTEGER, INTENT(in) :: its,ite, kts,kte, jts,jte
2795 INTEGER, INTENT(in) :: ifms,ifme, kfms,kfme, jfms,jfme
2796 INTEGER, INTENT(in) :: if_st,if_en, jf_st,jf_en
2797 INTEGER, INTENT(in) :: nfrx,nfry
2799 REAL, INTENT(in) :: dt,time
2801 REAL, INTENT(in), DIMENSION( ims:ime,jms:jme ) :: zs
2802 REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: sprdx,sprdy
2804 ! ----- inout variables
2806 INTEGER, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: ncod
2807 INTEGER, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme,2 ) :: in1,in2
2808 INTEGER, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: ixb,iyb,icn
2810 REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: tign_g,tign_crt
2811 REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: area,area2
2812 REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xfg,yfg
2814 ! ----- outgoing variables
2816 INTEGER, INTENT(out), DIMENSION( ifms:ifme,jfms:jfme ) :: nfl,nfl_t
2818 REAL, INTENT(out) :: radhld
2820 REAL, INTENT(out), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xcd,ycd
2821 REAL, INTENT(out), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xcn,ycn
2823 ! ----- local variables
2825 INTEGER :: i,j,it
2826 INTEGER :: istat
2827 INTEGER :: nct,icls
2828 INTEGER :: ic1,ic2,ic3,ic4
2829 INTEGER :: i1,i2,i3
2830 INTEGER :: j1,j2,j3
2831 INTEGER :: iflt
2832 INTEGER :: inxt,inyt
2833 INTEGER :: iod
2834 INTEGER :: is,js
2835 INTEGER :: isen
2836 INTEGER :: it1,it2,it3,it4
2837 INTEGER :: nh0,nh1,nh2,nh3,nht
2838 INTEGER :: itt
2839 INTEGER :: ihit
2840 INTEGER :: i1tst,j1tst
2841 INTEGER :: i2tst,j2tst
2842 INTEGER :: nh11,nh01,nh10,nhtmp
2843 INTEGER :: ilm1,ilm2,ilm3,ilm4
2844 INTEGER :: itest
2845 INTEGER :: iloc
2846 INTEGER :: ihld,jhld
2848 INTEGER, DIMENSION( ifms:ifme,jfms:jfme ) :: nc,icl
2850 REAL :: t1
2851 REAL :: tlx,tly
2852 REAL :: t1tst
2853 REAL :: x02,y02,r02
2854 REAL :: x20,y20,r20
2855 REAL :: x22,y22,r22
2856 REAL :: x01,y01,r01
2857 REAL :: x10,y10,r10
2858 REAL :: x11,y11,r11
2859 REAL :: r1sq,r2sq
2860 REAL :: radmax,radmin,radavg,radsum,radtst
2861 REAL :: x1,y1
2862 REAL :: x2,y2
2863 REAL :: x3,y3
2864 REAL :: det,aa,bb,x_0,y_0,rad,vtsgn
2866 CHARACTER(LEN=80) :: msg
2868 ! ----- when deriving fireline coordinates we always keep the fire to our left
2870 write(*,*)'in fire_ln: 1'
2872 ! ----- calculate nfl(i,j)
2874 DO j = jf_st,jf_en
2875 DO i = if_st,if_en
2876 nfl(i,j) = INT( (ep+tign_g(i,j) + ABS(ep+tign_g(i,j))) &
2877 / (2.*ABS(tign_g(i,j))+2.*ep) + .5 )
2878 nfl_t(i,j) = (1 - INT(area(i,j) + ep)) !test
2879 END DO
2880 END DO
2882 write(*,*)'in fire_ln: 2'
2883 DO j = jf_st+1,jf_en-1
2884 DO i = if_st+1,if_en-1
2885 nfl_t(i,j) = (1-INT(area(i,j)+ep-2.*ep* &
2886 (1.-FLOAT(( &
2887 ((icn(i+1,j,1)+icn(i+1,j,3))/2)*nfl(i+1,j) + &
2888 ((icn(i-1,j,2)+icn(i-1,j,4))/2)*nfl(i-1,j) + &
2889 ((icn(i,j+1,1)+icn(i,j+1,2))/2)*nfl(i,j+1) + &
2890 ((icn(i,j-1,3)+icn(i,j-1,4))/2)*nfl(i,j-1) &
2891 )/4)))) !test
2892 END DO
2893 END DO
2894 write(*,*)'in fire_ln: 3'
2896 DO j = jf_st,jf_en
2897 DO i = if_st,if_en
2898 nfl(i,j) = nfl(i,j) * nfl_t(i,j)
2899 DO it = 1,4
2900 xcd(i,j,it) = 0.0
2901 ycd(i,j,it) = 0.0
2902 xcn(i,j,it) = 0.0
2903 ycn(i,j,it) = 0.0
2904 END DO
2905 END DO
2906 END DO
2908 write(*,*)'in fire_ln: 4'
2909 CALL fire_stat(0,dt,time, & ! send
2910 zs,xcd,ycd,xcn,ycn,sprdx,sprdy, &
2911 ids,ide, kds,kde, jds,jde, &
2912 ims,ime, kms,kme, jms,jme, &
2913 its,ite, kts,kte, jts,jte, &
2914 ifms,ifme, kfms,kfme, jfms,jfme, &
2915 if_st,if_en,jf_st,jf_en, &
2916 nfrx,nfry, &
2917 nfl,nfl_t,tign_g,tign_crt, & ! send&recv
2918 area,area2,xfg,yfg, &
2919 ixb,iyb,icn) ! recv
2921 write(*,*)'in fire_ln: 5'
2922 DO j = jf_st,jf_en
2923 DO i = if_st,if_en
2924 icl(i,j) = ixb(i,j,1) + ixb(i,j,2) + ixb(i,j,3) + ixb(i,j,4) + &
2925 iyb(i,j,1) + iyb(i,j,2) + iyb(i,j,3) + iyb(i,j,4)
2926 nc(i,j) = icn(i,j,1) + icn(i,j,2) + icn(i,j,3) + icn(i,j,4)
2927 END DO
2928 END DO
2929 write(*,*)'in fire_ln: 6'
2931 ! ----- get xcd,ycd
2933 y_cd: DO j = jf_st+1,jf_en-1
2934 x_cd: DO i = if_st+1,if_en-1
2936 IF (nfl(i,j) == 1) THEN !NFL outer loop
2938 istat = 0
2939 nct = nc(i,j)
2941 IF (nct == 0) THEN !NCT=0
2942 iflt = 1
2943 CALL fire_error_debug(i,j,iflt, &
2944 time,in1,in2,tign_g, &
2945 nfl,ncod,xcd,ycd,xcn,ycn,icn, &
2946 ixb,iyb,xfg,yfg, &
2947 ifms,ifme, kfms,kfme, jfms,jfme, &
2948 if_st,if_en,jf_st,jf_en)
2949 END IF !NCT=0
2951 ncod(i,j) = 0
2952 icls = icl(i,j)
2954 IF (nct == 4) THEN !NCT=4 ICLS=0
2955 ncod(i,j) = 2
2956 IF (tign_g(i+1,j) < 0.0 .OR. &
2957 nfl(i+1,j)*(icn(i+1,j,1)+icn(i+1,j,3)) < 2) THEN
2958 ycd(i,j,1) = (1-icn(i+1,j,1))*yfg(i,j,2) + icn(i+1,j,1)* &
2959 yfg(i+1,j,3)
2960 ycd(i,j,2) = (1-icn(i+1,j,3))*yfg(i,j,4) + icn(i+1,j,3)* &
2961 yfg(i+1,j,1)
2962 xcd(i,j,1) = xlm(2)
2963 xcd(i,j,2) = xlm(4)
2964 istat = istat + 1
2965 END IF
2967 IF (tign_g(i-1,j) < 0.0 .OR. &
2968 nfl(i-1,j)*(icn(i-1,j,2)+icn(i-1,j,4)) < 2) THEN
2969 ycd(i,j,1) = (1-icn(i-1,j,4))*yfg(i,j,3) + icn(i-1,j,4)* &
2970 yfg(i-1,j,2)
2971 ycd(i,j,2) = (1-icn(i-1,j,2))*yfg(i,j,1) + icn(i-1,j,2)* &
2972 yfg(i-1,j,4)
2973 xcd(i,j,1) = xlm(3)
2974 xcd(i,j,2) = xlm(1)
2975 istat = istat + 1
2976 END IF
2978 IF (tign_g(i,j+1) < 0.0 .OR. &
2979 nfl(i,j+1)*(icn(i,j+1,1)+icn(i,j+1,2)) < 2) THEN
2980 xcd(i,j,1) = (1-icn(i,j+1,2))*xfg(i,j,4) + icn(i,j+1,2)* &
2981 xfg(i,j+1,1)
2982 xcd(i,j,2) = (1-icn(i,j+1,1))*xfg(i,j,3) + icn(i,j+1,1)* &
2983 xfg(i,j+1,2)
2984 ycd(i,j,1) = ylm(4)
2985 ycd(i,j,2) = ylm(3)
2986 istat = istat + 1
2987 END IF
2989 IF (tign_g(i,j-1) < 0.0 .OR. &
2990 nfl(i,j-1)*(icn(i,j-1,3)+icn(i,j-1,4)) < 2) THEN
2991 xcd(i,j,1) = (1-icn(i,j-1,3))*xfg(i,j,1)+icn(i,j-1,3)* &
2992 xfg(i,j+1,4)
2993 xcd(i,j,2) = (1-icn(i,j-1,4))*xfg(i,j,2)+icn(i,j-1,4)* &
2994 xfg(i,j+1,3)
2995 ycd(i,j,1) = ylm(1)
2996 ycd(i,j,2) = ylm(2)
2997 istat = istat + 1
2998 END IF
2999 END IF !NCT=4 ICLS=0
3001 IF (nct == 3 .AND. icls == 1) THEN !NCT=3 AND ICLS=1
3002 ncod(i,j) = 2
3003 istat = istat + 1
3004 ic1 = (1-icn(i,j,1)) + 2*(1-icn(i,j,2)) + &
3005 3*(1-icn(i,j,3)) + 4*(1-icn(i,j,4))
3006 ic3 = (1-icn(i,j,1))*(2+ixb(i,j,1)) &
3007 + (1-icn(i,j,2))*(1+3*ixb(i,j,2)) &
3008 + (1-icn(i,j,3))*(4-3*ixb(i,j,3)) &
3009 + (1-icn(i,j,4))*(3-ixb(i,j,4))
3010 i1 = ((ic1-2)*(ic1-3)*(1+ixb(i,j,ic1)) &
3011 + (ic1-1)*(4-ic1)*(2-ixb(i,j,ic1)))/2
3012 i2 = 3 - i1
3013 ! ------------------------------- inxt =0 means no virtual 1=virtual x-coordinate
3014 inxt = (1-ixb(i,j,ic1))*( &
3015 (1-icn(i,j,1))*(1-iyb(i,j-1,3)) + &
3016 (1-icn(i,j,2))*(1-iyb(i,j-1,4)) + &
3017 (1-icn(i,j,3))*(1-iyb(i,j+1,1)) + &
3018 (1-icn(i,j,4))*(1-iyb(i,j+1,2)))
3019 ! ------------------------------- inyt =0 means no virtual 1=virtual y-coordinate
3020 inyt = ixb(i,j,ic1)*( &
3021 (1-icn(i,j,1))*(1-ixb(i-1,j,2)) + &
3022 (1-icn(i,j,2))*(1-ixb(i+1,j,1)) + &
3023 (1-icn(i,j,3))*(1-ixb(i-1,j,4)) + &
3024 (1-icn(i,j,4))*(1-ixb(i+1,j,3)))
3025 xcd(i,j,i1) = xfg(i,j,ic1)
3026 ycd(i,j,i1) = yfg(i,j,ic1)
3027 xcd(i,j,i2) = FLOAT(1-inxt)*xlm(ic3) + FLOAT(inxt)*( &
3028 FLOAT(1-icn(i,j,1))*xfg(i,j-1,3)+ &
3029 FLOAT(1-icn(i,j,2))*xfg(i,j-1,4)+ &
3030 FLOAT(1-icn(i,j,3))*xfg(i,j+1,1)+ &
3031 FLOAT(1-icn(i,j,4))*xfg(i,j+1,2))
3032 ycd(i,j,i2) = FLOAT(1-inyt)*ylm(ic3) + FLOAT(inyt)*( &
3033 FLOAT(1-icn(i,j,1))*yfg(i-1,j,2)+ &
3034 FLOAT(1-icn(i,j,2))*yfg(i+1,j,1)+ &
3035 FLOAT(1-icn(i,j,3))*yfg(i-1,j,4)+ &
3036 FLOAT(1-icn(i,j,4))*yfg(i+1,j,3))
3037 END IF !NCT=3 AND ICLS=1
3039 IF (nct == 3 .AND. icls == 2) THEN !NCT=3 AND ICLS=2
3041 ncod(i,j) = 3
3043 IF (icn(i,j,1) == 0) THEN
3044 xcd(i,j,1) = xfg(i,j,3)
3045 xcd(i,j,2) = xfg(i,j,1)
3046 xcd(i,j,3) = FLOAT(1-nfl(i,j-1)*ixb(i,j-1,3))*xfg(i,j,2) &
3047 + FLOAT(nfl(i,j-1)*ixb(i,j-1,3))*xfg(i,j-1,3)
3048 ycd(i,j,1) = FLOAT(1-nfl(i-1,j)*iyb(i-1,j,2))*yfg(i,j,3) &
3049 + FLOAT(nfl(i-1,j)*iyb(i-1,j,2))*yfg(i-1,j,2)
3050 ycd(i,j,2) = yfg(i,j,1)
3051 ycd(i,j,3) = yfg(i,j,2)
3052 istat = istat + 1
3053 END IF
3055 IF (icn(i,j,2) == 0) THEN
3056 xcd(i,j,1) = FLOAT(1-nfl(i,j-1)*ixb(i,j-1,4))*xfg(i,j,1) &
3057 + FLOAT( nfl(i,j-1)*ixb(i,j-1,4))*xfg(i,j-1,4)
3058 xcd(i,j,2) = xfg(i,j,2)
3059 xcd(i,j,3) = xfg(i,j,4)
3060 ycd(i,j,1) = yfg(i,j,1)
3061 ycd(i,j,2) = yfg(i,j,2)
3062 ycd(i,j,3) = FLOAT(1-nfl(i+1,j)*iyb(i+1,j,1))*yfg(i,j,4) &
3063 + FLOAT( nfl(i+1,j)*iyb(i+1,j,1))*yfg(i+1,j,1)
3064 istat = istat + 1
3065 END IF
3067 IF (icn(i,j,3) == 0) THEN
3068 xcd(i,j,1) = FLOAT(1-nfl(i,j+1)*ixb(i,j+1,1))*xfg(i,j,4) &
3069 + FLOAT( nfl(i,j+1)*ixb(i,j+1,1))*xfg(i,j+1,1)
3070 xcd(i,j,2) = xfg(i,j,3)
3071 xcd(i,j,3) = xfg(i,j,1)
3072 ycd(i,j,1) = yfg(i,j,4)
3073 ycd(i,j,2) = yfg(i,j,3)
3074 ycd(i,j,3) = FLOAT(1-nfl(i-1,j)*iyb(i-1,j,4))*yfg(i,j,1) &
3075 + FLOAT( nfl(i-1,j)*iyb(i-1,j,4))*yfg(i-1,j,4)
3076 istat = istat + 1
3077 END IF
3079 IF (icn(i,j,4) == 0) THEN
3080 xcd(i,j,1) = xfg(i,j,2)
3081 xcd(i,j,2) = xfg(i,j,4)
3082 xcd(i,j,3) = FLOAT(1-nfl(i,j+1)*ixb(i,j+1,2))*xfg(i,j,3) &
3083 + FLOAT( nfl(i,j+1)*ixb(i,j+1,2))*xfg(i,j+1,2)
3084 ycd(i,j,1) = FLOAT(1-nfl(i+1,j)*iyb(i+1,j,3))*yfg(i,j,2) &
3085 + FLOAT( nfl(i+1,j)*iyb(i+1,j,3))*yfg(i+1,j,3)
3086 ycd(i,j,2) = yfg(i,j,4)
3087 ycd(i,j,3) = yfg(i,j,3)
3088 istat = istat + 1
3089 END IF
3091 END IF !NCT=3 AND ICLS=2
3093 IF (nct == 2 .AND. icls == 2) THEN !NCT=2 ICLS=2
3094 ncod(i,j) = 2
3095 IF (icn(i,j,1)+icn(i,j,2) == 2) THEN !IT=1 AND 2
3096 xcd(i,j,1) = xfg(i,j,4)
3097 xcd(i,j,2) = xfg(i,j,3)
3098 ycd(i,j,1) = yfg(i,j,4)
3099 ycd(i,j,2) = yfg(i,j,3)
3100 istat = istat + 1
3101 END IF !IT=1 AND 2
3102 IF (icn(i,j,2)+icn(i,j,4) == 2) THEN !IT=2 AND 4
3103 xcd(i,j,1) = xfg(i,j,3)
3104 xcd(i,j,2) = xfg(i,j,1)
3105 ycd(i,j,1) = yfg(i,j,3)
3106 ycd(i,j,2) = yfg(i,j,1)
3107 istat = istat + 1
3108 END IF !IT=2 AND 4
3109 IF (icn(i,j,3)+icn(i,j,4) == 2) THEN !IT=3 AND 4
3110 xcd(i,j,1) = xfg(i,j,1)
3111 xcd(i,j,2) = xfg(i,j,2)
3112 ycd(i,j,1) = yfg(i,j,1)
3113 ycd(i,j,2) = yfg(i,j,2)
3114 istat = istat + 1
3115 END IF !IT=3 AND 4
3116 IF (icn(i,j,1)+icn(i,j,3) == 2) THEN !IT=1 AND 3
3117 xcd(i,j,1) = xfg(i,j,2)
3118 xcd(i,j,2) = xfg(i,j,4)
3119 ycd(i,j,1) = yfg(i,j,2)
3120 ycd(i,j,2) = yfg(i,j,4)
3121 istat = istat + 1
3122 END IF !IT=1 AND 3
3123 END IF !NCT=2 ICLS=2
3125 IF (nct == 2 .AND. icls == 3) THEN !NCT=2 ICLS=3
3126 ncod(i,j) = 3
3127 IF (icn(i,j,1)+icn(i,j,2) == 2) THEN !IT=1 AND 2
3128 IF (ixb(i,j,3) == 1) THEN
3129 xcd(i,j,1) = xfg(i,j,4)
3130 xcd(i,j,2) = xfg(i,j,3)
3131 xcd(i,j,3) = xfg(i,j,1)
3132 ycd(i,j,1) = yfg(i,j,4)
3133 ycd(i,j,2) = yfg(i,j,3)
3134 ycd(i,j,3) = FLOAT(1-nfl(i-1,j)*iyb(i-1,j,4))*yfg(i,j,1) &
3135 + FLOAT( nfl(i-1,j)*iyb(i-1,j,4))*yfg(i-1,j,4)
3136 istat = istat+1
3137 END IF
3138 IF (ixb(i,j,3) == 0) THEN
3139 xcd(i,j,1) = xfg(i,j,2)
3140 xcd(i,j,2) = xfg(i,j,4)
3141 xcd(i,j,3) = xfg(i,j,3)
3142 ycd(i,j,1) = FLOAT(1-nfl(i+1,j)*iyb(i+1,j,3))*yfg(i,j,2) &
3143 + FLOAT( nfl(i+1,j)*iyb(i+1,j,3))*yfg(i+1,j,3)
3144 ycd(i,j,2) = yfg(i,j,4)
3145 ycd(i,j,3) = yfg(i,j,3)
3146 istat = istat + 1
3147 END IF
3148 END IF !IT=1 AND 2
3149 IF (icn(i,j,2)+icn(i,j,4) == 2) THEN !IT=2 AND 4
3150 IF (iyb(i,j,1) == 1) THEN
3151 xcd(i,j,1) = xfg(i,j,3)
3152 xcd(i,j,2) = xfg(i,j,1)
3153 xcd(i,j,3) = FLOAT(1-nfl(i,j-1)*ixb(i,j-1,3))*xfg(i,j,2) &
3154 + FLOAT( nfl(i,j-1)*ixb(i,j-1,3))*xfg(i,j-1,3)
3155 ycd(i,j,1) = yfg(i,j,3)
3156 ycd(i,j,2) = yfg(i,j,1)
3157 ycd(i,j,3) = yfg(i,j,2)
3158 istat = istat + 1
3159 END IF
3160 IF (iyb(i,j,1) == 0) THEN
3161 xcd(i,j,1) = FLOAT(1-nfl(i,j+1)*ixb(i,j+1,1))*xfg(i,j,4) &
3162 + FLOAT( nfl(i,j+1)*ixb(i,j+1,1))*xfg(i,j+1,1)
3163 xcd(i,j,2) = xfg(i,j,3)
3164 xcd(i,j,3) = xfg(i,j,1)
3165 ycd(i,j,1) = yfg(i,j,4)
3166 ycd(i,j,2) = yfg(i,j,3)
3167 ycd(i,j,3) = yfg(i,j,1)
3168 istat = istat + 1
3169 END IF
3170 END IF !IT=2 AND 4
3171 IF (icn(i,j,3)+icn(i,j,4) == 2) THEN !IT=3 AND 4
3172 IF (ixb(i,j,2) == 0) THEN
3173 xcd(i,j,1) = xfg(i,j,3)
3174 xcd(i,j,2) = xfg(i,j,1)
3175 xcd(i,j,3) = xfg(i,j,2)
3176 ycd(i,j,1) = FLOAT(1-nfl(i-1,j)*iyb(i-1,j,2))*yfg(i,j,3) &
3177 + FLOAT( nfl(i-1,j)*iyb(i-1,j,2))*yfg(i-1,j,2)
3178 ycd(i,j,2) = yfg(i,j,1)
3179 ycd(i,j,3) = yfg(i,j,2)
3180 istat = istat + 1
3181 END IF
3182 IF (ixb(i,j,2) == 1) THEN
3183 xcd(i,j,1) = xfg(i,j,1)
3184 xcd(i,j,2) = xfg(i,j,2)
3185 xcd(i,j,3) = xfg(i,j,4)
3186 ycd(i,j,1) = yfg(i,j,1)
3187 ycd(i,j,2) = yfg(i,j,2)
3188 ycd(i,j,3) = FLOAT(1-nfl(i+1,j)*iyb(i+1,j,1))*yfg(i,j,4) &
3189 + FLOAT( nfl(i+1,j)*iyb(i+1,j,1))*yfg(i+1,j,1)
3190 istat = istat + 1
3191 END IF
3192 END IF !IT=3 AND 4
3193 IF (icn(i,j,1)+icn(i,j,3) == 2) THEN !IT=1 AND 3
3194 IF (iyb(i,j,2) == 0) THEN
3195 xcd(i,j,1) = xfg(i,j,2)
3196 xcd(i,j,2) = xfg(i,j,4)
3197 xcd(i,j,3) = FLOAT(1-nfl(i,j+1)*ixb(i,j+1,2))*xfg(i,j,3) &
3198 + FLOAT( nfl(i,j+1)*ixb(i,j+1,2))*xfg(i,j+1,2)
3199 ycd(i,j,1) = yfg(i,j,2)
3200 ycd(i,j,2) = yfg(i,j,4)
3201 ycd(i,j,3) = yfg(i,j,3)
3202 istat = istat + 1
3203 END IF
3204 IF (iyb(i,j,2) == 1) THEN
3205 xcd(i,j,1) = FLOAT(1-nfl(i,j-1)*ixb(i,j-1,4))*xfg(i,j,1) &
3206 + FLOAT( nfl(i,j-1)*ixb(i,j-1,4))*xfg(i,j-1,4)
3207 xcd(i,j,2) = xfg(i,j,2)
3208 xcd(i,j,3) = xfg(i,j,4)
3209 ycd(i,j,1) = yfg(i,j,1)
3210 ycd(i,j,2) = yfg(i,j,2)
3211 ycd(i,j,3) = yfg(i,j,4)
3212 istat = istat + 1
3213 END IF
3214 END IF !IT=1 AND 3
3215 END IF !NCT=2 ICLS=3
3217 IF (nct == 1 .AND. icls == 4) THEN !NCT=1 ICLS=4
3218 ncod(i,j) = 3
3219 ic1 = icn(i,j,1) + 2*icn(i,j,2) + 3*icn(i,j,3) + 4*icn(i,j,4)
3220 ic2 = 5 - ic1
3221 ic3 = ixb(i,j,1)*(1-iyb(i,j,1)) + 2*ixb(i,j,2)*(1-iyb(i,j,2)) + &
3222 3*ixb(i,j,3)*(1-iyb(i,j,3)) + 4*ixb(i,j,4)*(1-iyb(i,j,4))
3223 ic4 = 10 - ic1 - ic2 - ic3
3224 iod = ic1 - 2*(ic1/2)
3225 is = 1 - 2*iod
3226 js = -1 + 2*(ic1/3)
3227 isen = is*js
3229 ! -------------------- straight lines for stability
3230 xfg(i,j,ic2) = .5*(xfg(i,j,ic3)+xfg(i,j,ic4))
3231 yfg(i,j,ic2) = .5*(yfg(i,j,ic3)+yfg(i,j,ic4))
3233 it1 = ((1+isen)*ic3+(1-isen)*ic4)/2
3234 it3 = ((1+isen)*ic4+(1-isen)*ic3)/2
3236 xcd(i,j,1) = xfg(i,j,it1)
3237 ycd(i,j,1) = yfg(i,j,it1)
3238 xcd(i,j,2) = xfg(i,j,ic2)
3239 ycd(i,j,2) = yfg(i,j,ic2)
3240 xcd(i,j,3) = xfg(i,j,it3)
3241 ycd(i,j,3) = yfg(i,j,it3)
3242 istat = istat + 1
3243 END IF !NCT=1 ICLS=4
3245 IF (istat /= 1) THEN
3246 IF (area(i,j) > (1.-ep) .AND. istat > 1) THEN
3247 nfl(i,j) = 0
3248 ELSE
3249 iflt = 2
3250 PRINT *,'ISTAT=',istat
3251 CALL fire_error_debug(i,j,iflt, &
3252 time,in1,in2,tign_g, &
3253 nfl,ncod,xcd,ycd,xcn,ycn,icn, &
3254 ixb,iyb,xfg,yfg, &
3255 ifms,ifme, kfms,kfme, jfms,jfme, &
3256 if_st,if_en,jf_st,jf_en)
3257 END IF
3258 END IF
3260 END IF !NFL outer loop
3262 END DO x_cd
3263 END DO y_cd
3265 write(*,*)'in fire_ln: 7'
3267 ! ----- test prints for missed grids
3269 DO j = jf_st+1,jf_en-1
3270 DO i = if_st+1,if_en-1
3271 IF (nfl(i,j) == 1 .AND. ncod(i,j) == 0) THEN
3272 iflt = 3
3273 CALL fire_error_debug(i,j,iflt, &
3274 time,in1,in2,tign_g, &
3275 nfl,ncod,xcd,ycd,xcn,ycn,icn, &
3276 ixb,iyb,xfg,yfg, &
3277 ifms,ifme, kfms,kfme, jfms,jfme, &
3278 if_st,if_en,jf_st,jf_en)
3279 END IF
3280 END DO
3281 END DO
3282 write(*,*)'in fire_ln: 8'
3284 ! ...CALCULATING INDEX LOCATIONS OF NEIGHBORS
3285 !
3286 ! ...This is the most critical loop of the code. If this fails
3287 ! the remaining logic will do weird things. This is probably
3288 ! the first place to check when problems occur.
3290 y_in: DO j = jf_st+1,jf_en-1
3291 x_in: DO i = if_st+1,if_en-1
3294 IF (nfl(i,j) == 1) THEN !NFL=1 loop
3296 write(*,*)'in fire_ln: 8.1 : ',i,j
3297 nh0 = ncod(i,j)
3298 nct = icn(i,j,1) + icn(i,j,2) + icn(i,j,3) + icn(i,j,4)
3299 icls = icl(i,j)
3301 itt = nh0
3302 t1 = ABS(xcd(i,j,2)) + ABS(ycd(i,j,2))
3303 IF (nct == 3 .AND. icls == 2 .AND. t1 > .9) itt = 2
3304 tlx = SIGN(1.,xcd(i,j,itt))
3305 tly = SIGN(1.,ycd(i,j,itt))
3306 i2 = i + INT(tlx*1.5)
3307 j2 = j + INT(tly*1.5)
3308 write(*,*)'in fire_ln: 8.1.1 : nh0 = ',nh0
3309 write(*,*)'in fire_ln: 8.1.2 : nct = ',nct
3310 write(*,*)'in fire_ln: 8.1.3 : icls = ',icls
3311 write(*,*)'in fire_ln: 8.1.4 : itt = ',itt
3312 write(*,*)'in fire_ln: 8.1.5 : i,j = ',i,j
3313 write(*,*)'in fire_ln: 8.1.6 : tlx = ',tlx,tly
3314 write(*,*)'in fire_ln: 8.1.7 : int = ',INT(tlx*1.5),INT(tly*1.5)
3315 write(*,*)'in fire_ln: 8.1.8 : i2,j2 =',i2,j2
3317 ihit = 0
3318 j2tst = j2
3319 i2tst = i2
3321 write(*,*)'in fire_ln: 8.2 : ',i,j
3322 IF (nct == 3 .AND. icls == 1) THEN !test code follows
3323 write(*,*)'in fire_ln: 8.2.1 : ',i,j
3324 ! ----- ... looking for anomolous 3/1 situations
3325 ic1 = 1 - icn(i,j,1) + 2*(1-icn(i,j,2)) + 3*(1-icn(i,j,3)) &
3326 + 4*(1-icn(i,j,4))
3327 t1tst = ABS(xcd(i,j,1) + xcd(i,j,2))*FLOAT(iyb(i,j,ic1)) &
3328 + ABS(ycd(i,j,1) + ycd(i,j,2))*FLOAT(ixb(i,j,ic1))
3329 IF (t1tst > 1.-ep) THEN
3330 j2tst = j2
3331 i2tst = i2
3332 ihit = 1
3333 IF (nfl(i,j2) == 0 .AND. iyb(i,j,ic1) == 0) THEN
3334 tlx = SIGN(1.,xcd(i,j,2)-xcd(i,j,1))
3335 i2 = i + INT(tlx*1.5)
3336 END IF
3337 IF (nfl(i2,j) == 0 .AND. ixb(i,j,ic1) == 0) THEN
3338 tly = SIGN(1.,ycd(i,j,2)-ycd(i,j,1))
3339 j2 = j + INT(tly*1.5)
3340 END IF
3341 END IF
3342 END IF !test code above
3343 !
3344 write(*,*)'in fire_ln: 8.3 : ',i,j
3345 x02 = xcd(i,j2,1) + SIGN(ep,xcd(i,j2,2)-xcd(i,j2,1))
3346 y02 = ycd(i,j2,1) + SIGN(ep,ycd(i,j2,2)-ycd(i,j2,1))
3347 x20 = xcd(i2,j,1) + SIGN(ep,xcd(i2,j,2)-xcd(i2,j,1))
3348 y20 = ycd(i2,j,1) + SIGN(ep,ycd(i2,j,2)-ycd(i2,j,1))
3349 x22 = xcd(i2,j2,1) + SIGN(ep,xcd(i2,j2,2)-xcd(i2,j2,1))
3350 y22 = ycd(i2,j2,1) + SIGN(ep,ycd(i2,j2,2)-ycd(i2,j2,1))
3351 r02 = (xcd(i,j,itt)-x02)**2 + (ycd(i,j,itt)-tly-y02)**2 &
3352 + FLOAT(1-nfl(i,j2))
3353 r20 = (xcd(i,j,itt)-tlx-x20)**2 + (ycd(i,j,itt)-y20)**2 &
3354 + FLOAT(1-nfl(i2,j))
3355 r22 = (xcd(i,j,itt)-tlx-x22)**2 + (ycd(i,j,itt)-tly-y22)**2 &
3356 + FLOAT(1-nfl(i2,j2))
3357 write(*,*)'in fire_ln: 8.3.1 : ',i2,j2
3358 is = i2
3359 js = j2
3360 IF (r02 < r22 .AND. r02 < r20) is = i
3361 IF (r20 < r22 .AND. r20 < r02) js = j
3362 i2 = is
3363 j2 = js
3364 write(*,*)'in fire_ln: 8.3.2 : ',i2,j2
3366 itt = 1
3367 t1 = ABS(xcd(i,j,2)) + ABS(ycd(i,j,2))
3368 IF (nct == 3 .AND. icls == 2 .AND. t1 > .9) itt = 2
3369 tlx = SIGN(1.,xcd(i,j,itt))
3370 tly = SIGN(1.,ycd(i,j,itt))
3371 i1 = i + INT(tlx*1.5)
3372 j1 = j + INT(tly*1.5)
3374 j1tst = j1
3375 i1tst = i1
3376 write(*,*)'in fire_ln: 8.4 : ',i,j
3378 IF (nct == 3 .AND. icls == 1) THEN !test code follows
3379 write(*,*)'in fire_ln: 8.4.1 : ',i,j
3380 ! ----- ... looking for anomolous 3/1 situations
3381 ic1 = 1 - icn(i,j,1) + 2*(1-icn(i,j,2)) + 3*(1-icn(i,j,3)) &
3382 + 4*(1-icn(i,j,4))
3383 t1tst = ABS(xcd(i,j,1) + xcd(i,j,2))*FLOAT(iyb(i,j,ic1)) &
3384 + ABS(ycd(i,j,1) + ycd(i,j,2))*FLOAT(ixb(i,j,ic1))
3385 IF (t1tst > 1.-ep) THEN
3386 j1tst = j1
3387 i1tst = i1
3388 ihit = ihit + 2
3389 if (nfl(i,j1) == 0 .AND. iyb(i,j,ic1) == 0) THEN
3390 tlx = SIGN(1.,xcd(i,j,1)-xcd(i,j,2))
3391 i1 = i + INT(tlx*1.5)
3392 END IF
3393 IF (nfl(i1,j) == 0 .AND. ixb(i,j,ic1) == 0) THEN
3394 tly = SIGN(1.,ycd(i,j,1)-ycd(i,j,2))
3395 j1 = j + INT(tly*1.5)
3396 END IF
3397 END IF
3398 END IF !test code above
3399 !
3400 write(*,*)'in fire_ln: 8.5 : ',i,j
3401 write(*,*)'in fire_ln: 8.5.1 : ',i,j
3402 nh11 = nfl(i1,j1)*ncod(i1,j1) + 1 - nfl(i1,j1)
3403 nh01 = nfl(i ,j1)*ncod(i ,j1) + 1 - nfl(i ,j1)
3404 nh10 = nfl(i1, j)*ncod(i1, j) + 1 - nfl(i1, j)
3405 nhtmp = nh01 - nfl(i,j1)
3406 x01 = xcd(i,j1,nh01) + SIGN(ep,xcd(i,j1,nhtmp)-xcd(i,j1,nh01))
3407 y01 = ycd(i,j1,nh01) + SIGN(ep,ycd(i,j1,nhtmp)-ycd(i,j1,nh01))
3408 write(*,*)'in fire_ln: 8.5.2 : ',i,j
3409 nhtmp = nh10 - nfl(i1,j)
3410 x10 = xcd(i1,j,nh10) + SIGN(ep,xcd(i1,j,nhtmp)-xcd(i1,j,nh10))
3411 y10 = ycd(i1,j,nh10) + SIGN(ep,ycd(i1,j,nhtmp)-ycd(i1,j,nh10))
3412 nhtmp = nh11 - nfl(i1,j1)
3413 x11 = xcd(i1,j1,nh11) + SIGN(ep,xcd(i1,j1,nhtmp)-xcd(i1,j1,nh11))
3414 y11 = ycd(i1,j1,nh11) + SIGN(ep,ycd(i1,j1,nhtmp)-ycd(i1,j1,nh11))
3415 r01 = (xcd(i,j,itt)-x01)**2 + (ycd(i,j,itt)-tly-y01)**2 &
3416 + (1.-FLOAT(nfl(i,j1)))
3417 r10 = (xcd(i,j,itt)-tlx-x10)**2 + (ycd(i,j,itt)-y10)**2 &
3418 + (1.-FLOAT(nfl(i1,j)))
3419 r11 = (xcd(i,j,itt)-tlx-x11)**2 + (ycd(i,j,itt)-tly-y11)**2 &
3420 + (1.-FLOAT(nfl(i1,j1)))
3421 write(*,*)'in fire_ln: 8.5.3 : ',i,j
3422 is = i1
3423 js = j1
3424 IF (r01 < r11 .AND. r01 < r10) is = i
3425 IF (r10 < r11 .AND. r10 < r01) js = j
3426 i1 = is
3427 j1 = js
3428 write(*,*)'in fire_ln: 8.5.4 : ',i,j
3429 ! ----- ... end of evaluation
3430 in1(i,j,1) = i1
3431 in1(i,j,2) = j1
3432 in2(i,j,1) = i2
3433 in2(i,j,2) = j2
3434 nh1 = ncod(i1,j1)
3435 nh2 = ncod(i2,j2)
3436 nht = nh0 + nh1 + nh2
3438 write(*,*)'in fire_ln: 8.5.5 : ',i,j
3439 write(*,*)'in fire_ln: 8.5.5 : ncod(',i1,j1,') = ',ncod(i1,j1),nfl(i1,j1)
3440 write(*,*)'in fire_ln: 8.5.5 : ncod(',i2,j2,') = ',ncod(i2,j2),nfl(i2,j2)
3441 write(*,*)'in fire_ln: 8.5.5 : xcd(',i,j,1,') = ',xcd(i,j,1)
3442 write(*,*)'in fire_ln: 8.5.5 : xcd(',i2,j2,nh2,') = ',xcd(i2,j2,nh2)
3443 write(*,*)'in fire_ln: 8.5.5 : i2-i = ',i2-i
3444 write(*,*)'in fire_ln: 8.5.5 : ycd(',i,j,1,') = ',ycd(i,j,1)
3445 write(*,*)'in fire_ln: 8.5.5 : ycd(',i2,j2,nh2,') = ',ycd(i2,j2,nh2)
3446 write(*,*)'in fire_ln: 8.5.5 : j2-j = ',j2-j
3448 write(*,*)'in fire_ln: 8.5.5 : xcd(',i,j,nh0,') = ',xcd(i,j,nh0)
3449 write(*,*)'in fire_ln: 8.5.5 : xcd(',i1,j1,1,') = ',xcd(i1,j1,1)
3450 write(*,*)'in fire_ln: 8.5.5 : i1-i = ',i1-i
3451 write(*,*)'in fire_ln: 8.5.5 : ycd(',i,j,nh0,') = ',ycd(i,j,nh0)
3452 write(*,*)'in fire_ln: 8.5.5 : ycd(',i1,j1,1,') = ',ycd(i1,j1,1)
3453 write(*,*)'in fire_ln: 8.5.5 : j1-j = ',j1-j
3454 r2sq = (xcd(i,j,1)-xcd(i2,j2,nh2)-FLOAT(i2-i))**2 + &
3455 (ycd(i,j,1)-ycd(i2,j2,nh2)-FLOAT(j2-j))**2
3456 r1sq = (xcd(i,j,nh0)-xcd(i1,j1,1)-FLOAT(i1-i))**2 + &
3457 (ycd(i,j,nh0)-ycd(i1,j1,1)-FLOAT(j1-j))**2
3459 ! IF (nh0 == 0) then
3460 ! r2sq = (xcd(i,j,1)-xcd(i2,j2,nh2)-FLOAT(i2-i))**2 + &
3461 ! (ycd(i,j,1)-ycd(i2,j2,nh2)-FLOAT(j2-j))**2
3462 ! IF (r2sq < ep_sq) THEN
3463 ! iflt = 184
3464 ! CALL fire_error_debug(i,j,iflt, &
3465 ! time,in1,in2,tign_g, &
3466 ! nfl,ncod,xcd,ycd,xcn,ycn,icn, &
3467 ! ixb,iyb,xfg,yfg, &
3468 ! ifms,ifme, kfms,kfme, jfms,jfme, &
3469 ! if_st,if_en,jf_st,jf_en)
3470 ! END IF
3471 ! ELSE IF (nh2 == 0) THEN
3472 ! r1sq = (xcd(i,j,nh0)-xcd(i1,j1,1)-FLOAT(i1-i))**2 + &
3473 ! (ycd(i,j,nh0)-ycd(i1,j1,1)-FLOAT(j1-j))**2
3474 ! IF (r1sq < ep_sq) THEN
3475 ! iflt = 185
3476 ! CALL fire_error_debug(i,j,iflt, &
3477 ! time,in1,in2,tign_g, &
3478 ! nfl,ncod,xcd,ycd,xcn,ycn,icn, &
3479 ! ixb,iyb,xfg,yfg, &
3480 ! ifms,ifme, kfms,kfme, jfms,jfme, &
3481 ! if_st,if_en,jf_st,jf_en)
3482 ! END IF
3483 ! ELSE
3484 ! r2sq = (xcd(i,j,1)-xcd(i2,j2,nh2)-FLOAT(i2-i))**2 + &
3485 ! (ycd(i,j,1)-ycd(i2,j2,nh2)-FLOAT(j2-j))**2
3486 ! r1sq = (xcd(i,j,nh0)-xcd(i1,j1,1)-FLOAT(i1-i))**2 + &
3487 ! (ycd(i,j,nh0)-ycd(i1,j1,1)-FLOAT(j1-j))**2
3488 ! IF (r1sq < ep_sq .OR. r2sq < ep_sq) THEN
3489 ! PRINT *,'DEBUG R1SQ R2SQ=',r1sq,r2sq
3490 ! iflt = 84
3491 ! CALL fire_error_debug(i,j,iflt, &
3492 ! time,in1,in2,tign_g, &
3493 ! nfl,ncod,xcd,ycd,xcn,ycn,icn, &
3494 ! ixb,iyb,xfg,yfg, &
3495 ! ifms,ifme, kfms,kfme, jfms,jfme, &
3496 ! if_st,if_en,jf_st,jf_en)
3497 !
3498 ! END IF
3499 ! END IF
3501 write(*,*)'in fire_ln: 8.5.6 : ',i,j
3503 ! IF (r1sq < ep_sq .OR. r2sq < ep_sq) THEN
3504 ! PRINT *,'DEBUG R1SQ R2SQ=',r1sq,r2sq
3505 ! iflt = 84
3506 ! CALL fire_error_debug(i,j,iflt, &
3507 ! time,in1,in2,tign_g, &
3508 ! nfl,ncod,xcd,ycd,xcn,ycn,icn, &
3509 ! ixb,iyb,xfg,yfg, &
3510 ! ifms,ifme, kfms,kfme, jfms,jfme, &
3511 ! if_st,if_en,jf_st,jf_en)
3513 ! END IF
3515 write(*,*)'in fire_ln: 8.6 : ',i,j
3516 IF (i1 < if_st .OR. i1 > if_en .OR. j1 < jf_st .OR. j1 > jf_en) THEN
3517 iflt = 85
3518 CALL fire_error_debug(i,j,iflt, &
3519 time,in1,in2,tign_g, &
3520 nfl,ncod,xcd,ycd,xcn,ycn,icn, &
3521 ixb,iyb,xfg,yfg, &
3522 ifms,ifme, kfms,kfme, jfms,jfme, &
3523 if_st,if_en,jf_st,jf_en)
3524 END IF
3525 IF (i2 < if_st .OR. i2 > if_en .OR. j2 < jf_st .OR. j2 > jf_en) THEN
3526 iflt = 87
3527 CALL fire_error_debug(i,j,iflt, &
3528 time,in1,in2,tign_g, &
3529 nfl,ncod,xcd,ycd,xcn,ycn,icn, &
3530 ixb,iyb,xfg,yfg, &
3531 ifms,ifme, kfms,kfme, jfms,jfme, &
3532 if_st,if_en,jf_st,jf_en)
3533 END IF
3535 write(*,*)'in fire_ln: 8.7 : ',i,j
3536 ilm1 = IABS(in1(i,j,1)-i)
3537 ilm2 = IABS(in2(i,j,1)-i)
3538 ilm3 = IABS(in1(i,j,2)-j)
3539 ilm4 = IABS(in2(i,j,2)-j)
3541 write(*,*)'in fire_ln: 8.8 : ',i,j
3542 IF (ilm1 > 1 .OR. ilm2 > 1 .OR. ilm3 > 1 .OR. ilm4 > 1) THEN
3543 iflt = 83
3544 CALL fire_error_debug(i,j,iflt, &
3545 time,in1,in2,tign_g, &
3546 nfl,ncod,xcd,ycd,xcn,ycn,icn, &
3547 ixb,iyb,xfg,yfg, &
3548 ifms,ifme, kfms,kfme, jfms,jfme, &
3549 if_st,if_en,jf_st,jf_en)
3550 END IF
3552 IF (i1 == i .AND. j1 == j) THEN
3553 iflt = 4
3554 CALL fire_error_debug(i,j,iflt, &
3555 time,in1,in2,tign_g, &
3556 nfl,ncod,xcd,ycd,xcn,ycn,icn, &
3557 ixb,iyb,xfg,yfg, &
3558 ifms,ifme, kfms,kfme, jfms,jfme, &
3559 if_st,if_en,jf_st,jf_en)
3560 END IF
3562 IF (i2 == i .AND. j2 == j) THEN
3563 iflt = 5
3564 CALL fire_error_debug(i,j,iflt, &
3565 time,in1,in2,tign_g, &
3566 nfl,ncod,xcd,ycd,xcn,ycn,icn, &
3567 ixb,iyb,xfg,yfg, &
3568 ifms,ifme, kfms,kfme, jfms,jfme, &
3569 if_st,if_en,jf_st,jf_en)
3570 END IF
3572 IF (i2 == i1 .AND. j2 == j1) THEN
3573 ! ----- ... fireline brushes corner of 3/1. Odd normal vector pts inwards.
3574 iflt = 6
3575 PRINT *,'IC1 T1TST=',ic1,t1tst
3576 PRINT *,'IHIT=',ihit
3577 PRINT *,'I1TST J1TST=',i1tst,j1tst
3578 PRINT *,'I2TST J2TST=',i2tst,j2tst
3579 WRITE (msg,*) 'i,i2,i1=',i,i2,i1,' j,j2,j1=',j,j2,j1
3580 CALL wrf_message( msg )
3581 CALL fire_error_debug(i,j,iflt, &
3582 time,in1,in2,tign_g, &
3583 nfl,ncod,xcd,ycd,xcn,ycn,icn, &
3584 ixb,iyb,xfg,yfg, &
3585 ifms,ifme, kfms,kfme, jfms,jfme, &
3586 if_st,if_en,jf_st,jf_en)
3587 END IF
3589 write(*,*)'in fire_ln: 8.9 : ',i,j
3590 itest = 0
3591 IF (itest == 0) THEN
3593 IF (i1 /= in1(i,j,1) .OR. j1 /= in1(i,j,2) .OR. i2 /= in2(i,j,1) &
3594 .OR. j2 /= in2(i,j,2)) THEN
3595 iflt = 80
3596 CALL fire_error_debug(i,j,iflt, &
3597 time,in1,in2,tign_g, &
3598 nfl,ncod,xcd,ycd,xcn,ycn,icn, &
3599 ixb,iyb,xfg,yfg, &
3600 ifms,ifme, kfms,kfme, jfms,jfme, &
3601 if_st,if_en,jf_st,jf_en)
3602 END IF
3604 IF (ABS(xcd(i,j,1)) > .5 .OR. ABS(ycd(i,j,1)) > .5) THEN
3605 iflt = 81
3606 CALL fire_error_debug(i,j,iflt, &
3607 time,in1,in2,tign_g, &
3608 nfl,ncod,xcd,ycd,xcn,ycn,icn, &
3609 ixb,iyb,xfg,yfg, &
3610 ifms,ifme, kfms,kfme, jfms,jfme, &
3611 if_st,if_en,jf_st,jf_en)
3612 END IF
3614 IF (ABS(xcd(i,j,nh0)) > .5 .OR. ABS(ycd(i,j,nh0)) > .5) THEN
3615 iflt = 82
3616 CALL fire_error_debug(i,j,iflt, &
3617 time,in1,in2,tign_g, &
3618 nfl,ncod,xcd,ycd,xcn,ycn,icn, &
3619 ixb,iyb,xfg,yfg, &
3620 ifms,ifme, kfms,kfme, jfms,jfme, &
3621 if_st,if_en,jf_st,jf_en)
3622 END IF
3624 END IF
3625 write(*,*)'in fire_ln: 8.10 : ',i,j
3626 END IF !NFL=1 LOOP
3627 !
3628 END DO x_in
3629 END DO y_in
3631 write(*,*)'in fire_ln: 9'
3632 !
3633 radmax = -1.e5
3634 radmin = 1.e5
3635 radavg = 0.0
3636 radsum = 0.0
3637 radtst = 10000.
3639 ! ...This is the second most critical loop of the code. If this
3640 ! fails the remaining logic may fail. This is probably the second
3641 ! place to check when problems occur.
3643 y_cn: DO j = jf_st+1,jf_en-1
3644 x_cn: DO i = if_st+1,if_en-1
3646 IF (nfl(i,j) == 1) THEN !NFL=1 LOOP
3648 nh0 = ncod(i,j)
3649 i1 = in1(i,j,1)
3650 j1 = in1(i,j,2)
3651 i2 = in2(i,j,1)
3652 j2 = in2(i,j,2)
3653 nh1 = ncod(i1,j1)
3654 nh2 = ncod(i2,j2)
3656 ! ----- ...calculate xcn and ycn for points 1,nh0 at grid i,j
3658 x1 = xcd(i1,j1, 1) + FLOAT(i1-i)
3659 y1 = ycd(i1,j1, 1) + FLOAT(j1-j)
3660 x2 = xcd(i ,j , 1)
3661 y2 = ycd(i ,j , 1)
3662 x3 = xcd(i ,j ,nh0)
3663 y3 = ycd(i ,j ,nh0)
3664 iloc = 0
3666 IF (icl(i,j) == 4 .AND. nc(i,j) == 1) THEN
3667 IF (icl(i1,j1) == 4 .AND. nc(i1,j1) == 1) THEN
3668 i3 = in1(i1,j1,1)
3669 j3 = in1(i1,j1,2)
3670 ! IF (nfl(i3,j3) == 1) THEN
3671 IF (nfl(i3,j3) == 1 .AND. icl(i3,j3) /= 4) THEN
3672 iloc = 1
3673 x1 = xcd(i3,j3,1) + FLOAT(i3-i)
3674 y1 = ycd(i3,j3,1) + FLOAT(j3-j)
3675 x2 = xcd(i ,j , 1)
3676 y2 = ycd(i ,j , 1)
3677 x3 = xcd(i2,j2,nh2) + FLOAT(i2-i)
3678 y3 = ycd(i2,j2,nh2) + FLOAT(j2-j)
3679 END IF
3680 END IF
3681 END IF
3683 ! ... test code follows
3684 IF (icl(i,j) == 4 .AND. nc(i,j) == 1 .AND. iloc == 0) THEN
3685 x1 = xcd(i1,j1, 1) + FLOAT(i1-i)
3686 y1 = ycd(i1,j1, 1) + FLOAT(j1-j)
3687 x2 = xcd(i1,j1,nh1) + FLOAT(i1-i)
3688 y2 = ycd(i1,j1,nh1) + FLOAT(j1-j)
3689 x3 = xcd(i2,j2, 1) + FLOAT(i2-i)
3690 y3 = ycd(i2,j2, 1) + FLOAT(j2-j)
3691 END IF
3692 ! ... test code above
3694 xcn(i,j,1) = xcd(i,j,1)
3695 ycn(i,j,1) = ycd(i,j,1)
3696 det = (x1-x2)*(y1-y3) - (x1-x3)*(y1-y2)
3697 aa = .5*(x1*x1 - x2*x2 + y1*y1 - y2*y2)
3698 bb = .5*(x1*x1 - x3*x3 + y1*y1 - y3*y3)
3699 x_0 = (aa*(y1-y3)-bb*(y1-y2)) / (det+SIGN(ep,det))
3700 y_0 = (bb*(x1-x2)-aa*(x1-x3)) / (det+SIGN(ep,det))
3701 rad = SQRT((x2-x_0)**2 + (y2-y_0)**2)
3702 IF (rad > 1. .AND. rad < 1000.) THEN !test
3703 vtsgn = (y3-y1)*(x2-x_0) - (x3-x1)*(y2-y_0)
3704 it1 = INT((vtsgn+ABS(vtsgn)) / (ABS(vtsgn)+ep_sq)+.5) - 1
3705 t1 = FLOAT(it1)
3706 xcn(i,j,1) = xcd(i,j,1) + t1*(x2-x_0)/(rad+ep)
3707 ycn(i,j,1) = ycd(i,j,1) + t1*(y2-y_0)/(rad+ep)
3708 ELSE
3709 rad = SQRT((y3-y1)**2 + (x3-x1)**2)
3710 IF (ABS(rad) < ep) THEN
3711 WRITE (6,*) 'HEY1 START'
3712 WRITE (6,*) 'HEY1 RAD,ILOC',rad,iloc
3713 WRITE (6,*) 'HEY1 I,J,NH0',i,j,nh0
3714 WRITE (6,*) 'HEY1 I1,J1',i1,j1,nh1
3715 WRITE (6,*) 'HEY1 R01,R10,R11',r01,r10,r11
3716 WRITE (6,*) 'HEY1 X1,X2,X3',x1,x2,x3
3717 WRITE (6,*) 'HEY1 Y1,Y2,Y3',y1,y2,y3
3718 WRITE (6,*) 'HEY1 XCD(I)=',(xcd(i,j,it),it=1,nh0)
3719 WRITE (6,*) 'HEY1 YCD(I)=',(ycd(i,j,it),it=1,nh0)
3720 WRITE (6,*) 'HEY1 XCD(I1)=',(xcd(i1,j1,it),it=1,nh1)
3721 WRITE (6,*) 'HEY1 YCD(I1)=',(ycd(i1,j1,it),it=1,nh1)
3722 iflt = 111
3723 CALL fire_error_debug(i,j,iflt, &
3724 time,in1,in2,tign_g, &
3725 nfl,ncod,xcd,ycd,xcn,ycn,icn, &
3726 ixb,iyb,xfg,yfg, &
3727 ifms,ifme, kfms,kfme, jfms,jfme, &
3728 if_st,if_en,jf_st,jf_en)
3729 END IF
3730 xcn(i,j,1) = xcd(i,j,1) + (y3-y1)/(rad+ep)
3731 ycn(i,j,1) = ycd(i,j,1) - (x3-x1)/(rad+ep)
3732 END IF
3734 IF (rad < .1 .AND. rad < radtst) THEN
3735 radhld = rad
3736 radtst = rad
3737 ihld = i
3738 jhld = j
3739 END IF
3741 radmax = MAX(radmax,rad)
3742 radmin = MIN(radmin,rad)
3743 radavg = radavg + rad
3744 radsum = radsum + 1.
3746 x1 = xcd(i ,j , 1)
3747 y1 = ycd(i ,j , 1)
3748 x2 = xcd(i ,j ,nh0)
3749 y2 = ycd(i ,j ,nh0)
3750 x3 = xcd(i2,j2,nh2) + FLOAT(i2-i)
3751 y3 = ycd(i2,j2,nh2) + FLOAT(j2-j)
3752 iloc = 0
3754 IF (icl(i,j) == 4 .AND. nc(i,j) == 1) THEN
3755 IF (icl(i2,j2) == 4 .AND. nc(i2,j2) == 1) THEN
3756 i3 = in2(i2,j2,1)
3757 j3 = in2(i2,j2,2)
3758 nh3 = ncod(i3,j3)
3759 ! IF (nfl(i3,j3) == 1) THEN
3760 IF (nfl(i3,j3) == 1 .AND. icl(i3,j3) /= 4) THEN
3761 iloc = 1
3762 x1 = xcd(i1,j1,1) + FLOAT(i1-i)
3763 y1 = ycd(i1,j1,1) + FLOAT(j1-j)
3764 x2 = xcd(i ,j ,nh0)
3765 y2 = ycd(i ,j ,nh0)
3766 x3 = xcd(i3,j3,nh3) + FLOAT(i3-i)
3767 y3 = ycd(i3,j3,nh3) + FLOAT(j3-j)
3768 END IF
3769 END IF
3770 END IF
3772 ! ... test code follows
3773 IF (icl(i,j) == 4 .AND. nc(i,j) == 1 .AND. iloc == 0) THEN
3774 x1 = xcd(i1,j1,nh1) + FLOAT(i1-i)
3775 y1 = ycd(i1,j1,nh1) + FLOAT(j1-j)
3776 x2 = xcd(i2,j2, 1) + FLOAT(i2-i)
3777 y2 = ycd(i2,j2, 1) + FLOAT(j2-j)
3778 x3 = xcd(i2,j2,nh2) + FLOAT(i2-i)
3779 y3 = ycd(i2,j2,nh2) + FLOAT(j2-j)
3780 END IF
3781 ! ... test code above
3783 xcn(i,j,nh0) = xcd(i,j,nh0)
3784 ycn(i,j,nh0) = ycd(i,j,nh0)
3785 det = (x1-x2)*(y1-y3) - (x1-x3)*(y1-y2)
3786 aa = .5*(x1*x1 - x2*x2 + y1*y1 - y2*y2)
3787 bb = .5*(x1*x1 - x3*x3 + y1*y1 - y3*y3)
3788 x_0 = (aa*(y1-y3) - bb*(y1-y2)) / (det + SIGN(ep,det))
3789 y_0 = (bb*(x1-x2) - aa*(x1-x3)) / (det + SIGN(ep,det))
3790 rad = SQRT((x2-x_0)**2 + (y2-y_0)**2)
3792 IF (rad > 1. .AND. rad < 1000.) THEN !test
3793 vtsgn = (y3-y1)*(x2-x_0) - (x3-x1)*(y2-y_0)
3794 it1 = INT((vtsgn+ABS(vtsgn)) / (ABS(vtsgn)+ep_sq)+.5) - 1
3795 t1 = FLOAT(it1)
3796 xcn(i,j,nh0) = xcd(i,j,nh0) + t1*(x2-x_0)/(rad+ep)
3797 ycn(i,j,nh0) = ycd(i,j,nh0) + t1*(y2-y_0)/(rad+ep)
3798 ELSE
3799 rad = SQRT((y3-y1)**2 + (x3-x1)**2)
3800 IF (abs(rad) < ep) THEN
3801 WRITE (6,*) 'HEY2 START'
3802 WRITE (6,*) 'HEY2 RAD,ILOC',rad,iloc
3803 WRITE (6,*) 'HEY2 I,J,NH0',i,j,nh0
3804 WRITE (6,*) 'HEY2 I2,J2,NH2',i2,j2,nh2
3805 WRITE (6,*) 'HEY2 R02,R20,R22',r02,r20,r22
3806 WRITE (6,*) 'HEY2 X1,X2,X3',x1,x2,x3
3807 WRITE (6,*) 'HEY2 Y1,Y2,Y3',y1,y2,y3
3808 WRITE (6,*) 'HEY2 XCD(I)=',(xcd(i,j,it),it=1,nh0)
3809 WRITE (6,*) 'HEY2 YCD(I)=',(ycd(i,j,it),it=1,nh0)
3810 WRITE (6,*) 'HEY2 XCD(I2)=',(xcd(i2,j2,it),it=1,nh2)
3811 WRITE (6,*) 'HEY2 YCD(I2)=',(ycd(i2,j2,it),it=1,nh2)
3812 iflt = 112
3813 CALL fire_error_debug(i,j,iflt, &
3814 time,in1,in2,tign_g, &
3815 nfl,ncod,xcd,ycd,xcn,ycn,icn, &
3816 ixb,iyb,xfg,yfg, &
3817 ifms,ifme, kfms,kfme, jfms,jfme, &
3818 if_st,if_en,jf_st,jf_en)
3819 END IF
3820 xcn(i,j,nh0) = xcd(i,j,nh0) + (y3-y1)/(rad+ep)
3821 ycn(i,j,nh0) = ycd(i,j,nh0) - (x3-x1)/(rad+ep)
3822 END IF
3823 IF (rad < .1 .AND. rad < radtst) THEN
3824 radhld = rad
3825 radtst = rad
3826 ihld = i
3827 jhld = j
3828 END IF
3830 IF (nh0 == 3) THEN
3831 x1 = xcd(i,j,1)
3832 y1 = ycd(i,j,1)
3833 x3 = xcd(i,j,3)
3834 y3 = ycd(i,j,3)
3835 rad = SQRT((y3-y1)**2 + (x3-x1)**2)
3836 IF (ABS(rad) < ep) THEN
3837 WRITE (6,*) 'HEY3 I,J,RAD,Y1,Y2,Y3,X1,X2,X3', &
3838 i,j,rad,y1,y2,y3,x1,x2,x3
3839 iflt = 113
3840 CALL fire_error_debug(i,j,iflt, &
3841 time,in1,in2,tign_g, &
3842 nfl,ncod,xcd,ycd,xcn,ycn,icn, &
3843 ixb,iyb,xfg,yfg, &
3844 ifms,ifme, kfms,kfme, jfms,jfme, &
3845 if_st,if_en,jf_st,jf_en)
3846 END IF
3847 xcn(i,j,2) = xcd(i,j,2) + (y3-y1)/(rad+ep)
3848 ycn(i,j,2) = ycd(i,j,2) - (x3-x1)/(rad+ep)
3849 END IF
3850 END IF !NFL=1 LOOP
3852 END DO x_cn
3853 END DO y_cn
3855 write(*,*)'in fire_ln: 10'
3856 IF (ABS(radsum) > ep_sq) THEN
3857 radavg = radavg/radsum
3858 PRINT *,'RADMAX MIN AVG SUM',radmax,radmin,radavg,radsum
3859 ELSE
3860 PRINT *,'RADMAX MIN SUM, CANT CALC RADAVG',radmax,radmin,radsum
3861 END IF
3862 write(*,*)'in fire_ln: 11'
3864 RETURN
3866 END SUBROUTINE fire_ln
3868 ! =========================================================================
3870 SUBROUTINE fire_tr(dt,ibeh,nfuel_cat,ncod,nfl,zf,zsf,zs, & ! incoming
3871 sfcu,sfcv,xcd,ycd,bbb,phiwc,betafl,r_0, &
3872 ids,ide, kds,kde, jds,jde, &
3873 ims,ime, kms,kme, jms,jme, &
3874 its,ite, kts,kte, jts,jte, &
3875 ifms,ifme, kfms,kfme, jfms,jfme, &
3876 if_st,if_en,jf_st,jf_en, &
3877 nfrx,nfry, &
3878 xcn,ycn, & ! inout
3879 sprdx,sprdy) ! outgoing
3881 ! --------------------------------------------------------------------
3882 ! this routine advects fire line coordinates after fire_ln call
3883 ! all xcd ycd xcn and ycn points are calculated and used to
3884 ! calculate local velocities and spread rates
3885 ! --------------------------------------------------------------------
3887 USE module_fr_cawfe_fuel
3889 IMPLICIT NONE
3891 ! ------ incoming variables
3893 INTEGER, INTENT(in) :: ids,ide, kds,kde, jds,jde
3894 INTEGER, INTENT(in) :: ims,ime, kms,kme, jms,jme
3895 INTEGER, INTENT(in) :: its,ite, kts,kte, jts,jte
3896 INTEGER, INTENT(in) :: ifms,ifme, kfms,kfme, jfms,jfme
3897 INTEGER, INTENT(in) :: if_st,if_en, jf_st,jf_en
3898 INTEGER, INTENT(in) :: nfrx,nfry
3900 INTEGER, INTENT(in) :: ibeh
3902 INTEGER, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme ) :: nfuel_cat
3903 INTEGER, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme ) :: ncod,nfl
3905 REAL, INTENT(in) :: dt
3907 REAL, INTENT(in), DIMENSION( ims:ime,jms:jme,6 ) :: sfcu,sfcv
3908 REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xcd,ycd
3909 REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme ) :: zf,zsf
3910 REAL, INTENT(in), DIMENSION( ims:ime,jms:jme ) :: zs
3911 REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme ) :: bbb,phiwc,betafl,r_0
3913 ! ------ inout variables
3915 REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xcn,ycn
3917 ! ------ outgoing variables
3919 REAL, INTENT(out), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: sprdx,sprdy
3921 ! ------ local variables
3923 INTEGER :: i,j
3924 INTEGER :: it,itm
3925 INTEGER :: ks,ksp
3926 INTEGER :: ib,jb
3928 REAL :: tirx,tiry
3929 REAL :: tspmax,tspmin
3930 REAL :: epx,epy,epz
3931 REAL :: t1
3932 REAL :: dlx,dly,dl
3933 REAL :: x,y
3934 REAL :: tib,tjb
3935 REAL :: uu,vv
3936 REAL :: zs1,zs2
3937 REAL :: tanphi,speed
3938 REAL :: ss
3939 REAL :: fuel_hgt
3941 REAL, PARAMETER :: dist = 2. ! distance behind fire line in the
3942 ! direction of the normal vector that
3943 ! winds are taken to advect fire.
3944 ! terrain slope taken to be the
3945 ! difference between the elevation at
3946 ! the fire line and the elevation twice
3947 ! this distance from the fire line in
3948 ! the direction of the normal vector.
3950 CHARACTER(LEN=80) :: msg
3952 ! when deriving fireline coordinates we always keep the fire to our left
3954 tirx = 1. / FLOAT(nfrx)
3955 tiry = 1. / FLOAT(nfry)
3957 ! ... SFCU and SFCV are positioned such that vertical index=1 means
3958 ! they are at the surface (2) means one grid point above the surface.
3960 tspmax = 0.0
3961 tspmin = 1000.0
3963 DO j = jf_st,jf_en
3964 DO i = if_st,if_en
3966 ! --- get integer height of fuel
3968 fuel_hgt = 1. + fueldepthm(nfuel_cat(i,j)) / (zf(i,j)-zsf(i,j))
3970 ks = INT( fuel_hgt )
3971 ksp = ks+1 ! test!
3972 epz = fuel_hgt - FLOAT(ks) ! test!
3974 ! --- zero out some debug
3976 DO it = 1,4
3977 sprdx(i,j,it) = 0.0
3978 sprdy(i,j,it) = 0.0
3979 END DO
3981 itm = ncod(i,j)
3983 IF (nfl(i,j).eq.1) THEN !NFL bypass
3985 DO it = 1,itm
3987 ! -- the Don Latham change follows - jury is still out
3989 dlx = (xcn(i,j,it)-xcd(i,j,it)) * dxf
3990 dly = (ycn(i,j,it)-ycd(i,j,it)) * dyf
3992 ! --- find winds at the specified distance behind the fire line.
3993 ! note that ib, jb are atmospheric grid coords. (where
3994 ! zs is defined), not fuel cell grid coords.
3996 t1 = dist / SQRT( dlx**2 + dly**2 )
3997 x = xcd(i,j,it) - (xcn(i,j,it)-xcd(i,j,it))*t1
3998 y = ycd(i,j,it) - (ycn(i,j,it)-ycd(i,j,it))*t1
3999 tib = 1. + (FLOAT(i)-1.5+x)*tirx
4000 tjb = 1. + (FLOAT(j)-1.5+y)*tiry
4001 ib = INT(tib)
4002 jb = INT(tjb)
4003 epx = tib - FLOAT(ib)
4004 epy = tjb - FLOAT(jb)
4006 uu = (1.-epz)*( &
4007 (1.-epy)*((1.-epx)*sfcu(ib ,jb ,ks) &
4008 + epx *sfcu(ib+1,jb ,ks)) &
4009 + epy*((1.-epx)*sfcu(ib ,jb+1,ks) &
4010 + epx *sfcu(ib+1,jb+1,ks))) &
4011 + epz *( &
4012 (1.-epy)*((1.-epx)*sfcu(ib ,jb ,ksp) &
4013 + epx *sfcu(ib+1,jb ,ksp)) &
4014 + epy*((1.-epx)*sfcu(ib ,jb+1,ksp) &
4015 + epx *sfcu(ib+1,jb+1,ksp)))
4017 vv = (1.-epz)*( &
4018 (1.-epy)*((1.-epx)*sfcv(ib ,jb ,ks) &
4019 + epx *sfcv(ib+1,jb ,ks)) &
4020 + epy*((1.-epx)*sfcv(ib ,jb+1,ks) &
4021 + epx *sfcv(ib+1,jb+1,ks))) &
4022 + epz *( &
4023 (1.-epy)*((1.-epx)*sfcv(ib ,jb ,ksp) &
4024 + epx *sfcv(ib+1,jb ,ksp)) &
4025 + epy*((1.-epx)*sfcv(ib ,jb+1,ksp) &
4026 + epx *sfcv(ib+1,jb+1,ksp)))
4028 ! --- find elevation at the fire line for this particle.
4030 t1 = 0.0
4031 x = xcd(i,j,it) - (xcn(i,j,it)-xcd(i,j,it))*t1
4032 y = ycd(i,j,it) - (ycn(i,j,it)-ycd(i,j,it))*t1
4033 tib = 1.5 + (FLOAT(i)-1.5+x)*tirx
4034 tjb = 1.5 + (FLOAT(j)-1.5+y)*tiry
4035 ib = INT(tib)
4036 jb = INT(tjb)
4037 epx = tib - FLOAT(ib)
4038 epy = tjb - FLOAT(jb)
4040 zs1 = (1.-epy)*((1.-epx)*zs(ib,jb ) + epx*zs(ib+1,jb)) &
4041 + epy*((1.-epx)*zs(ib,jb+1) + epx*zs(ib+1,jb+1))
4043 ! --- find elevation at twice the specified distance behind
4044 ! the fire line in the direction of the normal vector
4046 t1 = (2.*dist) / SQRT(dlx**2 + dly**2)
4047 x = xcd(i,j,it) - (xcn(i,j,it)-xcd(i,j,it))*t1
4048 y = ycd(i,j,it) - (ycn(i,j,it)-ycd(i,j,it))*t1
4050 tib = 1.5 + (FLOAT(i)-1.5+x)*tirx
4051 tjb = 1.5 + (FLOAT(j)-1.5+y)*tiry
4052 ib = INT(tib)
4053 jb = INT(tjb)
4054 epx = tib - FLOAT(ib)
4055 epy = tjb - FLOAT(jb)
4057 zs2 = (1.-epy)*((1.-epx)*zs(ib,jb ) + epx*zs(ib+1,jb)) &
4058 + epy*((1.-epx)*zs(ib,jb+1) + epx*zs(ib+1,jb+1))
4060 ! --- calculate tangent of terrain slope in direction of spread.
4062 tanphi = (zs1-zs2) / (2.*dist)
4063 PRINT *,'debug ZS1 ZS2 TANPHI=',zs1,zs2,tanphi
4065 ! --- calculate wind speed in direction of spread.
4067 dlx = (xcn(i,j,it)-xcd(i,j,it))
4068 dly = (ycn(i,j,it)-ycd(i,j,it))
4069 dlx = dlx + SIGN(ep,dlx)
4070 dly = dly + SIGN(ep,dly)
4071 dl = SQRT(dlx**2 + dly**2)
4072 t1 = 1./dl
4074 speed = t1*(uu*dlx + vv*dly)
4076 ! fuelloadm = (1.-bmst) * fgi(nfuel_cat(i,j)) ! fueload w/out moisture
4078 ! --- calculate fire's rate of spread
4080 CALL fire_ros( i,j, & ! send
4081 ifms,ifme, kfms,kfme, jfms,jfme, &
4082 speed,tanphi,ibeh,nfuel_cat, &
4083 bbb,phiwc,betafl,r_0, &
4084 ss) ! recv
4086 ! --- get new non-dimensional distance according to spread rate
4088 dlx = t1 * dlx * ss * dt / dxf
4089 dly = t1 * dly * ss * dt / dyf
4091 ! --- some debug
4093 tspmax = MAX(ss,tspmax)
4094 tspmin = MIN(ss,tspmin)
4095 sprdx(i,j,it) = dxf * dlx / dt
4096 sprdy(i,j,it) = dyf * dly / dt
4098 ! --- update normal vector's locations
4100 xcn(i,j,it) = xcd(i,j,it) + dlx
4101 ycn(i,j,it) = ycd(i,j,it) + dly
4103 END DO
4104 END IF !NFL bypass
4105 END DO
4106 END DO
4108 WRITE(msg,21) tspmax, tspmin
4109 21 FORMAT(1x,'MAX/MIN SPREAD RATE (m/s)=',2(1x,f10.5))
4110 CALL wrf_message( msg )
4112 RETURN
4114 END SUBROUTINE fire_tr
4116 ! =========================================================================
4118 SUBROUTINE fire_ds(ixb,iyb,icn,nfl,ncod,in1,in2, & ! incoming
4119 time,xcn,ycn,xcd,ycd, &
4120 ids,ide, kds,kde, jds,jde, &
4121 ims,ime, kms,kme, jms,jme, &
4122 its,ite, kts,kte, jts,jte, &
4123 ifms,ifme, kfms,kfme, jfms,jfme, &
4124 if_st,if_en,jf_st,jf_en, &
4125 nfrx,nfry, &
4126 xfg,yfg,tign_g) ! inout
4128 ! ---------------------------------------------------------------------
4129 ! This routine assigns quadrilateral grid positions using the
4130 ! new XCN and YCN positions. New cell ignitions are also treated.
4131 !
4132 ! First we calculate XFG,YFG using linear extrapolation. This
4133 ! can result in different values at the same equivalent point
4134 ! for neighboring grids. (Curvature effect). This will be corrected
4135 ! in last loop of this routine.
4136 ! ---------------------------------------------------------------------
4138 IMPLICIT NONE
4140 ! ----- incoming variables
4142 INTEGER, INTENT(in) :: ids,ide, kds,kde, jds,jde
4143 INTEGER, INTENT(in) :: ims,ime, kms,kme, jms,jme
4144 INTEGER, INTENT(in) :: its,ite, kts,kte, jts,jte
4145 INTEGER, INTENT(in) :: ifms,ifme, kfms,kfme, jfms,jfme
4146 INTEGER, INTENT(in) :: if_st,if_en, jf_st,jf_en
4147 INTEGER, INTENT(in) :: nfrx,nfry
4149 INTEGER, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: ixb,iyb,icn
4150 INTEGER, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme ) :: nfl,ncod
4151 INTEGER, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,2 ) :: in1,in2
4153 REAL, INTENT(in) :: time
4155 REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xcn,ycn
4156 REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xcd,ycd
4158 ! ----- inout variables
4160 REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xfg,yfg
4161 REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: tign_g
4163 ! ----- local variables
4165 INTEGER :: i,j
4166 INTEGER :: nct,icls
4167 INTEGER :: i1,i2
4168 INTEGER :: j1,j2
4169 INTEGER :: nh0,nh1,nh2,nht
4170 INTEGER :: ic1,ic2,ic3,ic4
4171 INTEGER :: iod
4172 INTEGER :: is,js
4173 INTEGER :: isen
4174 INTEGER :: iia3,iib3,iic3,iid3,iit
4175 INTEGER :: jja4,jjb4,jjc4,jjd4,jjt
4176 INTEGER :: iflt
4178 INTEGER, DIMENSION( ifms:ifme,jfms:jfme ) :: nc,icl
4180 REAL :: dlx,dly
4181 REAL :: dxx,dyy
4182 REAL :: x1,x2,x3,x4,x5,x6,x7
4183 REAL :: y1,y2,y3,y4,y5,y6,y7
4184 REAL :: xfg_a3,xfg_b3,xfg_c3,xfg_d3
4185 REAL :: yfg_a4,yfg_b4,yfg_c4,yfg_d4
4186 REAL :: xfg_ic3,yfg_ic4
4187 REAL :: tia3,tib3,tic3,tid3
4188 REAL :: tja4,tjb4,tjc4,tjd4
4190 ! when deriving fireline coordinates we always keep the fire to our left
4192 DO j = jf_st,jf_en
4193 DO i = if_st,if_en
4194 nc(i,j) = icn(i,j,1) + icn(i,j,2) + icn(i,j,3) + icn(i,j,4)
4195 icl(i,j) = ixb(i,j,1) + ixb(i,j,2) + ixb(i,j,3) + ixb(i,j,4) + &
4196 iyb(i,j,1) + iyb(i,j,2) + iyb(i,j,3) + iyb(i,j,4)
4197 END DO
4198 END DO
4199 !
4200 yl: DO j = jf_st+1,jf_en-1
4201 xl: DO i = if_st+1,if_en-1
4203 IF (nfl(i,j) == 1) THEN !NFL outer loop
4205 nct = nc(i,j)
4206 icls = icl(i,j)
4207 nh0 = ncod(i,j)
4208 i1 = in1(i,j,1)
4209 j1 = in1(i,j,2)
4210 i2 = in2(i,j,1)
4211 j2 = in2(i,j,2)
4212 nh1 = ncod(i1,j1)
4213 nh2 = ncod(i2,j2)
4214 nht = nh0 + nh1 + nh2
4216 dly = (xcn(i,j,2)-xcn(i,j,1))/ &
4217 (ycn(i,j,2)-ycn(i,j,1)+SIGN(ep,ycn(i,j,2)-ycn(i,j,1)))
4218 dlx = (ycn(i,j,2)-ycn(i,j,1))/ &
4219 (xcn(i,j,2)-xcn(i,j,1)+SIGN(ep,xcn(i,j,2)-xcn(i,j,1)))
4221 IF (nct == 3 .AND. icls == 1) THEN !NCT=3 and ICLS=1 NCOD=2
4223 ic1 = 10 - icn(i,j,1) - 2*icn(i,j,2) - 3*icn(i,j,3) - 4*icn(i,j,4)
4225 IF (ic1 == 1) THEN
4226 IF (ixb(i,j,ic1) == 1) THEN
4227 dxx = xcn(i,j,1) + (ylm(ic1)-ycn(i,j,1))*dly - xfg(i,j,ic1)
4228 dxx = MIN(0.0,dxx)
4229 xfg(i,j,ic1) = xfg(i,j,ic1) + dxx
4230 END IF
4231 IF (ixb(i,j,ic1) == 0) THEN
4232 dyy = ycn(i,j,1) + (xlm(ic1)-xcn(i,j,1))*dlx - yfg(i,j,ic1)
4233 dyy = MIN(0.0,dyy)
4234 yfg(i,j,ic1) = yfg(i,j,ic1) + dyy
4235 END IF
4236 END IF
4238 IF (ic1 == 2) THEN
4239 IF (ixb(i,j,ic1) == 1) THEN
4240 dxx = xcn(i,j,1) + (ylm(ic1)-ycn(i,j,1))*dly - xfg(i,j,ic1)
4241 dxx = MAX(0.0,dxx)
4242 xfg(i,j,ic1) = xfg(i,j,ic1) + dxx
4243 END IF
4244 IF (ixb(i,j,ic1) == 0) THEN
4245 dyy = ycn(i,j,1) + (xlm(ic1)-xcn(i,j,1))*dlx - yfg(i,j,ic1)
4246 dyy = MIN(0.0,dyy)
4247 yfg(i,j,ic1) = yfg(i,j,ic1) + dyy
4248 END IF
4249 END IF
4251 IF (ic1 == 3) THEN
4252 IF (ixb(i,j,ic1) == 1) THEN
4253 dxx = xcn(i,j,1) + (ylm(ic1)-ycn(i,j,1))*dly - xfg(i,j,ic1)
4254 dxx = MIN(0.0,dxx)
4255 xfg(i,j,ic1) = xfg(i,j,ic1) + dxx
4256 END IF
4257 IF (ixb(i,j,ic1) == 0) THEN
4258 dyy = ycn(i,j,1) + (xlm(ic1)-xcn(i,j,1))*dlx - yfg(i,j,ic1)
4259 dyy = MAX(0.0,dyy)
4260 yfg(i,j,ic1) = yfg(i,j,ic1) + dyy
4261 END IF
4262 END IF
4264 IF (ic1 == 4) THEN
4265 IF (ixb(i,j,ic1) == 1) THEN
4266 dxx = xcn(i,j,1) + (ylm(ic1)-ycn(i,j,1))*dly - xfg(i,j,ic1)
4267 dxx = MAX(0.0,dxx)
4268 xfg(i,j,ic1) = xfg(i,j,ic1) + dxx
4269 END IF
4270 IF (ixb(i,j,ic1) == 0) THEN
4271 dyy = ycn(i,j,1) + (xlm(ic1)-xcn(i,j,1))*dlx - yfg(i,j,ic1)
4272 dyy = MAX(0.0,dyy)
4273 yfg(i,j,ic1) = yfg(i,j,ic1) + dyy
4274 END IF
4275 END IF
4277 IF (ABS(xfg(i,j,ic1)+xlm(ic1)) > 1.) xfg(i,j,ic1) = xlm(ic1)
4278 IF (ABS(yfg(i,j,ic1)+ylm(ic1)) > 1.) yfg(i,j,ic1) = ylm(ic1)
4280 END IF !NCT=3 and ICLS=1
4282 IF (nct == 3 .AND. icls == 2) THEN !NCT=3 and ICLS=2 NCOD=3
4283 ic1 = 10 - icn(i,j,1) - 2*icn(i,j,2) - 3*icn(i,j,3) - 4*icn(i,j,4)
4284 yfg(i,j,ic1) = ycn(i,j,2)
4285 xfg(i,j,ic1) = xcn(i,j,2)
4286 IF (ABS(xfg(i,j,ic1)+xlm(ic1)) > 1.) xfg(i,j,ic1) = xlm(ic1)
4287 IF (ABS(yfg(i,j,ic1)+ylm(ic1)) > 1.) yfg(i,j,ic1) = ylm(ic1)
4288 END IF !NCT=3 and ICLS=2
4290 IF (nct == 2 .AND. icls == 2) THEN !NCT=2 ICLS=2 NCOD=2
4292 IF (icn(i,j,1)+icn(i,j,2) == 2) THEN !IT=1 and 2
4293 xfg(i,j,3) = xlm(3)
4294 xfg(i,j,4) = xlm(4)
4295 yfg(i,j,3) = (ycn(i,j,1)+(xlm(3)-xcn(i,j,1))*dlx)
4296 yfg(i,j,4) = (ycn(i,j,1)+(xlm(4)-xcn(i,j,1))*dlx)
4297 IF (ABS(yfg(i,j,3)+ylm(3)) > 1.) yfg(i,j,3) = ylm(3)
4298 IF (ABS(yfg(i,j,4)+ylm(4)) > 1.) yfg(i,j,4) = ylm(4)
4299 END IF !IT=1 and 2
4301 IF (icn(i,j,3)+icn(i,j,4) == 2) THEN !IT=3 and 4
4302 xfg(i,j,1) = xlm(1)
4303 xfg(i,j,2) = xlm(2)
4304 yfg(i,j,1) = (ycn(i,j,1)+(xlm(1)-xcn(i,j,1))*dlx)
4305 yfg(i,j,2) = (ycn(i,j,1)+(xlm(2)-xcn(i,j,1))*dlx)
4306 IF (ABS(yfg(i,j,1)+ylm(1)) > 1.) yfg(i,j,1) = ylm(1)
4307 IF (ABS(yfg(i,j,2)+ylm(2)) > 1.) yfg(i,j,2) = ylm(2)
4308 END IF !IT=3 and 4
4310 IF (icn(i,j,2)+icn(i,j,4) == 2) THEN !IT=2 and 4
4311 yfg(i,j,1) = ylm(1)
4312 yfg(i,j,3) = ylm(3)
4313 xfg(i,j,1) = (xcn(i,j,1)+(ylm(1)-ycn(i,j,1))*dly)
4314 xfg(i,j,3) = (xcn(i,j,1)+(ylm(3)-ycn(i,j,1))*dly)
4315 IF (ABS(xfg(i,j,1)+xlm(1)) > 1.) xfg(i,j,1) = xlm(1)
4316 IF (ABS(xfg(i,j,3)+xlm(3)) > 1.) xfg(i,j,3) = xlm(3)
4317 END IF !IT=2 and 4
4319 IF (icn(i,j,1)+icn(i,j,3) == 2) THEN !IT=1 and 3
4320 yfg(i,j,2) = ylm(2)
4321 yfg(i,j,4) = ylm(4)
4322 xfg(i,j,2) = (xcn(i,j,1)+(ylm(2)-ycn(i,j,1))*dly)
4323 xfg(i,j,4) = (xcn(i,j,1)+(ylm(4)-ycn(i,j,1))*dly)
4324 IF (ABS(xfg(i,j,2)+xlm(2)) > 1.) xfg(i,j,2) = xlm(2)
4325 IF (ABS(xfg(i,j,4)+xlm(4)) > 1.) xfg(i,j,4) = xlm(4)
4326 END IF !IT=1 and 3
4328 END IF !NCT=2 ICLS=2
4330 IF (nct == 1 .AND. icls == 4) THEN !NCT=1 ICLS=4 NCOD=3
4331 ! debug section
4332 ic1 = icn(i,j,1) + 2*icn(i,j,2) + 3*icn(i,j,3) + 4*icn(i,j,4)
4333 ic2 = 5 - ic1
4334 ic3 = ixb(i,j,1)*(1-iyb(i,j,1)) + 2*ixb(i,j,2)*(1-iyb(i,j,2)) + &
4335 3*ixb(i,j,3)*(1-iyb(i,j,3)) + 4*ixb(i,j,4)*(1-iyb(i,j,4))
4336 ic4 = 10 - ic1 - ic2 - ic3
4337 ! WRITE (6,*) 'ic1,ic2,ic3,ic4=',ic1,ic2,ic3,ic4
4338 iod = ic1 - 2*(ic1/2)
4339 is = 1 - 2*iod
4340 js = -1 + 2*(ic1/3)
4341 isen = is*js
4342 ! WRITE (6,*) 'iod,is,js,isen=',iod,is,js,isen
4344 x1 = xcn(i2,j2,2) + float(i2-i)
4345 y1 = ycn(i2,j2,2) + float(j2-j)
4346 x2 = xcn(i2,j2,1) + float(i2-i)
4347 y2 = ycn(i2,j2,1) + float(j2-j)
4348 x3 = xcn(i,j,2+isen)
4349 y3 = ycn(i,j,2+isen)
4350 x4 = xcn(i,j,2)
4351 y4 = ycn(i,j,2)
4352 x5 = xcn(i,j,2-isen)
4353 y5 = ycn(i,j,2-isen)
4354 x6 = xcn(i1,j1,nh1) + FLOAT(i1-i)
4355 y6 = ycn(i1,j1,nh1) + FLOAT(j1-j)
4356 x7 = xcn(i1,j1,nh1-1) + FLOAT(i1-i)
4357 y7 = ycn(i1,j1,nh1-1) + FLOAT(j1-j)
4358 IF (isen == -1) THEN
4359 x1 = xcn(i1,j1,nh1-1) + FLOAT(i1-i)
4360 y1 = ycn(i1,j1,nh1-1) + FLOAT(j1-j)
4361 x2 = xcn(i1,j1,nh1) + FLOAT(i1-i)
4362 y2 = ycn(i1,j1,nh1) + FLOAT(j1-j)
4363 x6 = xcn(i2,j2,1) + FLOAT(i2-i)
4364 y6 = ycn(i2,j2,1) + FLOAT(j2-j)
4365 x7 = xcn(i2,j2,2) + FLOAT(i2-i)
4366 y7 = ycn(i2,j2,2) + FLOAT(j2-j)
4367 ! WRITE (6,*) 'ad: x1,x2,x3,x4,x5,x6,x7=',x1,x2,x3,x4,x5,x6,x7
4368 ! WRITE (6,*) 'ad: y1,y2,y3,y4,y5,y6,y7=',y1,y2,y3,y4,y5,y6,y7
4369 END IF
4371 ! ----- first choice
4372 xfg_a3 = x7 + (ylm(ic3)-y7)*(x4-x7)/(y4-y7+SIGN(ep,y4-y7))
4373 yfg_a4 = y1 + (xlm(ic4)-x1)*(y4-y1)/(x4-x1+SIGN(ep,x4-x1))
4375 ! ----- second choice
4376 xfg_b3 = x7 + (ylm(ic3)-y7)*(x6-x7)/(y6-y7+SIGN(ep,y6-y7))
4377 yfg_b4 = y1 + (xlm(ic4)-x1)*(y2-y1)/(x2-x1+SIGN(ep,x2-x1))
4379 ! ----- third choice
4380 xfg_c3 = x5 + (ylm(ic3)-y5)*(x4-x5)/(y4-y5+SIGN(ep,y4-y5))
4381 yfg_c4 = y3 + (xlm(ic4)-x3)*(y4-y3)/(x4-x3+SIGN(ep,x4-x3))
4383 ! ----- fourth choice
4384 xfg_d3 = x5
4385 yfg_d4 = y3
4387 ! WRITE (6,*) '1st choice xfg_a3, yfg_a4=',xfg_a3, yfg_a4
4388 ! WRITE (6,*) '2nd choice xfg_b3, yfg_b4=',xfg_b3, yfg_b4
4389 ! WRITE (6,*) '3nd choice xfg_c3, yfg_c4=',xfg_c3, yfg_c4
4390 ! WRITE (6,*) '4th choice xfg_d3, yfg_d4=',xfg_d3, yfg_d4
4392 ! ----- test constraints
4393 ! tia3 = ((xfg_a3-xfg(i,j,ic3))*(xlm(ic3)-xlm(ic1)) &
4394 ! + ABS((xfg_a3-xfg(i,j,ic3))*(xlm(ic3)-xlm(ic1)))) !must be positive
4395 ! tib3 = ((xfg_b3-xfg(i,j,ic3))*(xlm(ic3)-xlm(ic1)) &
4396 ! + ABS((xfg_b3-xfg(i,j,ic3))*(xlm(ic3)-xlm(ic1)))) !must be positive
4397 ! tic3 = ((xfg_c3-xfg(i,j,ic3))*(xlm(ic3)-xlm(ic1)) &
4398 ! + ABS((xfg_c3-xfg(i,j,ic3))*(xlm(ic3)-xlm(ic1)))) !must be positive
4399 ! tid3 = ((xfg_d3-xfg(i,j,ic3))*(xlm(ic3)-xlm(ic1)) &
4400 ! + ABS((xfg_d3-xfg(i,j,ic3))*(xlm(ic3)-xlm(ic1)))) !must be positive
4401 !
4402 ! iia3 = INT((tia3+ABS(tia3))/(2.*ABS(tia3)+ep)+.5)
4403 ! iib3 = INT((tib3+ABS(tib3))/(2.*ABS(tib3)+ep)+.5)
4404 ! iic3 = INT((tic3+ABS(tic3))/(2.*ABS(tic3)+ep)+.5)
4405 ! iid3 = INT((tid3+ABS(tid3))/(2.*ABS(tid3)+ep)+.5)
4407 iia3 = 0
4408 iib3 = 0
4409 iic3 = 0
4410 iid3 = 0
4412 IF ( (xfg_a3-xfg(i,j,ic3))*(xlm(ic3)-xlm(ic1)) >= -ep) iia3 = 1
4413 IF ( (xfg_b3-xfg(i,j,ic3))*(xlm(ic3)-xlm(ic1)) >= -ep) iib3 = 1
4414 IF ( (xfg_c3-xfg(i,j,ic3))*(xlm(ic3)-xlm(ic1)) >= -ep) iic3 = 1
4415 IF ( (xfg_d3-xfg(i,j,ic3))*(xlm(ic3)-xlm(ic1)) >= -ep) iid3 = 1
4417 iib3 = (1-iia3)*iib3
4418 iic3 = (1-iia3)*(1-iib3)*iic3
4419 iid3 = (1-iia3)*(1-iib3)*(1-iic3)*iid3
4420 iit = iia3 + iib3 + iic3 + iid3
4422 ! tja4 = ((yfg_a4-yfg(i,j,ic4))*(ylm(ic4)-ylm(ic1)) &
4423 ! + ABS((yfg_a4-yfg(i,j,ic4))*(ylm(ic4)-ylm(ic1)))) !must be positive
4424 ! tjb4 = ((yfg_b4-yfg(i,j,ic4))*(ylm(ic4)-ylm(ic1)) &
4425 ! + ABS((yfg_b4-yfg(i,j,ic4))*(ylm(ic4)-ylm(ic1)))) !must be positive
4426 ! tjc4 = ((yfg_c4-yfg(i,j,ic4))*(ylm(ic4)-ylm(ic1)) &
4427 ! + ABS((yfg_c4-yfg(i,j,ic4))*(ylm(ic4)-ylm(ic1)))) !must be positive
4428 ! tjd4 = ((yfg_d4-yfg(i,j,ic4))*(ylm(ic4)-ylm(ic1)) &
4429 ! + ABS((yfg_d4-yfg(i,j,ic4))*(ylm(ic4)-ylm(ic1)))) !must be positive
4430 ! jja4 = INT((tja4+ABS(tja4))/(2.*ABS(tja4)+ep)+.5)
4431 ! jjb4 = INT((tjb4+ABS(tjb4))/(2.*ABS(tjb4)+ep)+.5)
4432 ! jjc4 = INT((tjc4+ABS(tjc4))/(2.*ABS(tjc4)+ep)+.5)
4433 ! jjd4 = INT((tjd4+ABS(tjd4))/(2.*ABS(tjd4)+ep)+.5)
4435 jja4 = 0
4436 jjb4 = 0
4437 jjc4 = 0
4438 jjd4 = 0
4440 IF ( (yfg_a4-yfg(i,j,ic4))*(ylm(ic4)-ylm(ic1)) >= -ep) jja4 = 1
4441 IF ( (yfg_b4-yfg(i,j,ic4))*(ylm(ic4)-ylm(ic1)) >= -ep) jjb4 = 1
4442 IF ( (yfg_c4-yfg(i,j,ic4))*(ylm(ic4)-ylm(ic1)) >= -ep) jjc4 = 1
4443 IF ( (yfg_d4-yfg(i,j,ic4))*(ylm(ic4)-ylm(ic1)) >= -ep) jjd4 = 1
4445 jjb4 = (1-jja4)*jjb4
4446 jjc4 = (1-jja4)*(1-jjb4)*jjc4
4447 jjd4 = (1-jja4)*(1-jjb4)*(1-jjc4)*jjd4
4448 jjt = jja4 + jjb4 + jjc4 + jjd4
4450 IF (iit*jjt == 0) THEN
4451 iflt = 884
4452 PRINT *,'IC1 2 3 4=',ic1,ic2,ic3,ic4
4453 PRINT *,'XFG_A YFG_A=',xfg_a3,yfg_a4
4454 PRINT *,'XFG_B YFG_B=',xfg_b3,yfg_b4
4455 PRINT *,'XFG_C YFG_C=',xfg_c3,yfg_c4
4456 PRINT *,'XFG_D YFG_D=',xfg_d3,yfg_d4
4457 PRINT *,'TIA3 TJA4=',tia3,tja4
4458 PRINT *,'TIB3 TJB4=',tib3,tjb4
4459 PRINT *,'TIC3 TJC4=',tic3,tjc4
4460 PRINT *,'TID3 TJD4=',tid3,tjd4
4461 PRINT *,'IIA3 JJA4=',iia3,jja4
4462 PRINT *,'IIB3 JJB4=',iib3,jjb4
4463 PRINT *,'IIC3 JJC4=',iic3,jjc4
4464 PRINT *,'IID3 JJD4=',iid3,jjd4
4466 WRITE (6,*) 'debug: iit,jjt=',iit,jjt
4467 WRITE (6,*) 'debug:IIT=IIA3+IIB3+IIC3+IID3',iit,iia3,iib3,iic3,iid3
4468 WRITE (6,*) 'debug:JJT=JJA4+JJB4+JJC4+JJD4',jjt,jja4,jjb4,jjc4,jjd4
4470 CALL fire_error_debug(i,j,iflt, &
4471 time,in1,in2,tign_g, &
4472 nfl,ncod,xcd,ycd,xcn,ycn,icn, &
4473 ixb,iyb,xfg,yfg, &
4474 ifms,ifme, kfms,kfme, jfms,jfme, &
4475 if_st,if_en,jf_st,jf_en)
4477 END IF
4479 xfg_ic3 = (FLOAT(iia3)*xfg_a3 + FLOAT(iib3)*xfg_b3 + &
4480 FLOAT(iic3)*xfg_c3 + FLOAT(iid3)*xfg_d3) &
4481 /(FLOAT(iia3+iib3+iic3+iid3)+ep)
4482 yfg_ic4 = (FLOAT(jja4)*yfg_a4 + FLOAT(jjb4)*yfg_b4 + &
4483 FLOAT(jjc4)*yfg_c4 + FLOAT(jjd4)*yfg_d4) &
4484 /(FLOAT(jja4+jjb4+jjc4+jjd4)+ep)
4486 xfg(i,j,ic3) = xfg_ic3
4487 yfg(i,j,ic3) = ylm(ic3)
4488 xfg(i,j,ic4) = xlm(ic4)
4489 yfg(i,j,ic4) = yfg_ic4
4490 xfg(i,j,ic2) = xcn(i,j,2)
4491 yfg(i,j,ic2) = ycn(i,j,2)
4493 IF (ABS(xfg(i,j,ic3)+xlm(ic3)) > 1.) xfg(i,j,ic3) = xlm(ic3)
4494 IF (ABS(yfg(i,j,ic4)+ylm(ic4)) > 1.) yfg(i,j,ic4) = ylm(ic4)
4495 IF (ABS(xfg(i,j,ic2)+xlm(ic2)) > 1.) xfg(i,j,ic2) = xlm(ic2)
4496 IF (ABS(yfg(i,j,ic2)+ylm(ic2)) > 1.) yfg(i,j,ic2) = ylm(ic2)
4498 IF (ABS(xfg(i,j,ic3)) > .5+ep .OR. ABS(yfg(i,j,ic4)) > .5+ep) THEN
4499 iflt = 885
4500 PRINT *,'IC1 2 3 4=',ic1,ic2,ic3,ic4
4501 PRINT *,'XFG_A YFG_A=',xfg_a3,yfg_a4
4502 PRINT *,'XFG_B YFG_B=',xfg_b3,yfg_b4
4503 PRINT *,'XFG_C YFG_C=',xfg_c3,yfg_c4
4504 PRINT *,'XFG_D YFG_D=',xfg_d3,yfg_d4
4505 PRINT *,'TIA3 TJA4=',tia3,tja4
4506 PRINT *,'TIB3 TJB4=',tib3,tjb4
4507 PRINT *,'TIC3 TJC4=',tic3,tjc4
4508 PRINT *,'TID3 TJD4=',tid3,tjd4
4509 PRINT *,'IIA3 JJA4=',iia3,jja4
4510 PRINT *,'IIB3 JJB4=',iib3,jjb4
4511 PRINT *,'IIC3 JJC4=',iic3,jjc4
4512 PRINT *,'IID3 JJD4=',iid3,jjd4
4514 CALL fire_error_debug(i,j,iflt, &
4515 time,in1,in2,tign_g, &
4516 nfl,ncod,xcd,ycd,xcn,ycn,icn, &
4517 ixb,iyb,xfg,yfg, &
4518 ifms,ifme, kfms,kfme, jfms,jfme, &
4519 if_st,if_en,jf_st,jf_en)
4521 END IF
4523 END IF !NCT=1 ICLS=4
4525 END IF !NFL outer loop
4526 END DO xl
4527 END DO yl
4529 RETURN
4531 END SUBROUTINE fire_ds
4533 ! =========================================================================
4535 SUBROUTINE fire_igs(ixb,iyb,icn,in1,in2,ncod,time, & ! incoming
4536 xcn,ycn,zs,xcd,ycd,sprdx,sprdy, &
4537 ids,ide, kds,kde, jds,jde, &
4538 ims,ime, kms,kme, jms,jme, &
4539 its,ite, kts,kte, jts,jte, &
4540 ifms,ifme, kfms,kfme, jfms,jfme, &
4541 if_st,if_en,jf_st,jf_en, &
4542 nfrx,nfry, &
4543 nfl,tign_g,xfg,yfg) ! inout
4545 ! -------------------------------------------------------------------------
4546 ! This routine treats new ignitions and the initialization of new grids
4547 ! using the XCN and YCN positions. It preserves symmetry and stability by
4548 ! first interogating all ignitors for all cells to be ignited.
4549 !
4550 ! IX is I index of new ignition grid
4551 ! LY is L index of new ignition grid
4552 ! -------------------------------------------------------------------------
4554 IMPLICIT NONE
4556 ! ----- incoming variables
4558 INTEGER, INTENT(in) :: ids,ide, kds,kde, jds,jde
4559 INTEGER, INTENT(in) :: ims,ime, kms,kme, jms,jme
4560 INTEGER, INTENT(in) :: its,ite, kts,kte, jts,jte
4561 INTEGER, INTENT(in) :: ifms,ifme, kfms,kfme, jfms,jfme
4562 INTEGER, INTENT(in) :: if_st,if_en, jf_st,jf_en
4563 INTEGER, INTENT(in) :: nfrx,nfry
4565 INTEGER, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: ixb,iyb,icn
4566 INTEGER, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,2 ) :: in1,in2
4567 INTEGER, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme ) :: ncod
4569 REAL, INTENT(in) :: time
4571 REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xcn,ycn
4572 REAL, INTENT(in), DIMENSION( ims:ime,jms:jme ) :: zs
4573 REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xcd,ycd
4574 REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: sprdx,sprdy
4576 ! ----- inout variables
4578 INTEGER, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: nfl
4580 REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: tign_g
4581 REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xfg,yfg
4583 ! ----- local variables
4585 INTEGER :: i,j
4586 INTEGER :: is,js
4587 INTEGER :: ip,jp
4588 INTEGER :: i1,i2
4589 INTEGER :: j1,j2
4590 INTEGER :: nh0,nh1,nh2
4591 INTEGER :: ix1,ix2,ix3
4592 INTEGER :: iy1,iy2,iy3
4593 INTEGER :: jy1,jy2,jy3
4594 INTEGER :: ixsum,jysum,isum,isumc
4595 INTEGER :: nct,icls
4596 INTEGER :: is12,is34,is13,is24
4597 INTEGER :: ic1,ic2,ic3,ic4
4598 INTEGER :: iod,isen
4599 INTEGER :: ihita,ihitb
4600 INTEGER :: ia4,ja4
4601 INTEGER :: ia6,ja6
4602 INTEGER :: ib1,jb1
4603 INTEGER :: ib3,jb3
4605 INTEGER, DIMENSION( ifms:ifme,jfms:jfme ) :: nc,icl
4606 INTEGER, DIMENSION( ifms:ifme,jfms:jfme,4 ) :: ist
4608 REAL :: dlx,dly
4609 REAL :: xfg_1,yfg_1
4610 REAL :: xfg_2,yfg_2
4611 REAL :: xfg_3,yfg_3
4612 REAL :: xfg_4,yfg_4
4613 REAL :: x1,x2,x3,x4,x5,x6,x7
4614 REAL :: y1,y2,y3,y4,y5,y6,y7
4615 REAL :: xfga,yfga
4616 REAL :: xfgb,yfgb
4617 REAL :: tx,ty
4618 REAL :: txa,tya
4619 REAL :: txb,tyb
4620 REAL :: xfg_ic1,yfg_ic1
4621 REAL :: xfg_a,yfg_a
4622 REAL :: xfg_b,yfg_b
4623 REAL :: xfg_a4,yfg_a4
4624 REAL :: xfg_a6,yfg_a6
4625 REAL :: xfg_b1,yfg_b1
4626 REAL :: xfg_b3,yfg_b3
4627 REAL :: ti1,ti2,ti3,tia4,tia6,tib1,tib3
4628 REAL :: tj1,tj2,tj3,tja4,tja6,tjb1,tjb3
4630 CHARACTER (LEN=256) :: msg
4632 ! ----- when deriving fireline coordinates we always keep the fire to our left
4634 DO j = jf_st+1,jf_en-1
4635 DO i = if_st+1,if_en-1
4636 nc(i,j) = icn(i,j,1) + icn(i,j,2) + icn(i,j,3) + icn(i,j,4)
4637 icl(i,j) = ixb(i,j,1) + ixb(i,j,2) + ixb(i,j,3) + ixb(i,j,4) + &
4638 iyb(i,j,1) + iyb(i,j,2) + iyb(i,j,3) + iyb(i,j,4)
4639 END DO
4640 END DO
4642 ! ----- preprocessing for loop 2
4644 DO j = jf_st+1,jf_en-1
4645 DO i = if_st+1,if_en-1
4647 IF (nfl(i,j) == 1) THEN
4649 i1 = in1(i,j,1)
4650 j1 = in1(i,j,2)
4651 i2 = in2(i,j,1)
4652 j2 = in2(i,j,2)
4653 nh1 = ncod(i1,j1)
4654 nh2 = ncod(i2,j2)
4655 nh0 = ncod(i,j)
4656 ix1 = i + INT(2.*xcn(i,j,1))
4657 ix2 = i + INT(2.*xcn(i,j,2))
4658 ix3 = i + INT(2.*xcn(i,j,nh0))
4659 jy1 = j + INT(2.*ycn(i,j,1))
4660 jy2 = j + INT(2.*ycn(i,j,2))
4661 jy3 = j + INT(2.*ycn(i,j,nh0))
4662 ixsum = ix1 + ix2 + ix3 - 3*i
4663 jysum = jy1 + jy2 + jy3 - 3*j
4664 isum = IABS(ixsum) + IABS(jysum)
4665 nct = nc(i,j)
4666 icls = icl(i,j)
4668 is12 = 0
4669 is34 = 0
4670 is13 = 0
4671 is24 = 0
4672 IF (isum > 0) THEN
4673 IF((nct == 2 .AND. icls == 2) .OR. (nct == 4 .AND. icls == 0)) THEN
4674 IF (icn(i,j,1)+icn(i,j,2) == 2 .AND. jysum > 0 &
4675 .AND. nfl(i,j+1) /= 1 .AND. tign_g(i,j+1) < -10.) is12 = 1
4676 IF (icn(i,j,3)+icn(i,j,4) == 2 .AND. jysum < 0 &
4677 .AND. nfl(i,j-1) /= 1 .AND. tign_g(i,j-1) < -10.) is34 = 1
4678 IF (icn(i,j,1)+icn(i,j,3) == 2 .AND. ixsum > 0 &
4679 .AND. nfl(i+1,j) /= 1 .AND. tign_g(i+1,j) < -10.) is13 = 1
4680 IF (icn(i,j,2)+icn(i,j,4) == 2 .AND. ixsum < 0 &
4681 .AND. nfl(i-1,j) /= 1 .AND. tign_g(i-1,j) < -10.) is24 = 1
4682 END IF
4683 IF (nct == 3 .AND. icls == 1) THEN
4684 IF (icn(i,j,1)+icn(i,j,2) == 2 .AND. &
4685 ixb(i,j,3)+ixb(i,j,4) == 0 .AND. &
4686 jysum > 0 .AND. nfl(i,j+1) /= 1 .AND. &
4687 tign_g(i,j+1) < -10.) is12 = 1
4688 IF (icn(i,j,3)+icn(i,j,4) == 2 .AND. &
4689 ixb(i,j,1)+ixb(i,j,2) == 0 .AND. &
4690 jysum < 0 .AND. nfl(i,j-1) /= 1 .AND. &
4691 tign_g(i,j-1) < -10.) is34 = 1
4692 IF (icn(i,j,1)+icn(i,j,3) == 2 .AND. &
4693 iyb(i,j,2)+iyb(i,j,4) == 0 .AND. &
4694 ixsum > 0 .AND. nfl(i+1,j) /= 1 .AND. &
4695 tign_g(i+1,j) < -10.) is13 = 1
4696 IF (icn(i,j,2)+icn(i,j,4) == 2 .AND. &
4697 iyb(i,j,1)+iyb(i,j,3) == 0 .AND. &
4698 ixsum < 0 .AND. nfl(i-1,j) /= 1 .AND. &
4699 tign_g(i-1,j) < -10.) is24 = 1
4700 END IF
4701 END IF
4703 ist(i,j,1) = is12
4704 ist(i,j,2) = is34
4705 ist(i,j,3) = is13
4706 ist(i,j,4) = is24
4708 END IF !NFL=1 loop
4709 END DO
4710 END DO
4712 DO j = jf_st+1,jf_en-1
4713 DO i = if_st+1,if_en-1
4715 IF (nfl(i,j) == 1) THEN !check cell i,j
4717 is12 = ist(i,j,1)
4718 is34 = ist(i,j,2)
4719 is13 = ist(i,j,3)
4720 is24 = ist(i,j,4)
4722 ! ----- the preprocessing of is12 etc allows overwriting or double ignition
4723 ! -----the checks on nfl give 2/2 ignition dominance.
4725 IF (is12+is34+is13+is24 > 0) THEN !2/2 4/0 and 3/1 ignition
4726 dly = (xcn(i,j,2)-xcn(i,j,1))/ &
4727 (ycn(i,j,2)-ycn(i,j,1) + SIGN(ep,ycn(i,j,2)-ycn(i,j,1)))
4728 dlx = (ycn(i,j,2)-ycn(i,j,1))/ &
4729 (xcn(i,j,2)-xcn(i,j,1) + SIGN(ep,xcn(i,j,2)-ycn(i,j,1)))
4731 IF (is12 == 1) THEN
4732 xfg_4 = xcn(i,j,1) + (ylm(4)-ycn(i,j,1))*dly
4733 yfg_4 = ycn(i,j,1) + (xlm(4)-xcn(i,j,1))*dlx
4734 xfg_3 = xcn(i,j,1) + (ylm(3)-ycn(i,j,1))*dly
4735 yfg_3 = ycn(i,j,1) + (xlm(3)-xcn(i,j,1))*dlx
4737 ! ----- igniting a 1/4
4738 IF (yfg_4 > .5 .AND. yfg_3 < .5 .AND. nfl(i,j+1) /= 1) THEN
4739 nfl(i,j+1) = 1
4740 tign_g(i,j+1) = time
4741 xfg(i,j+1,1) = xfg_4 - 5.*ep
4742 yfg(i,j+1,1) = ylm(1)
4743 xfg(i,j+1,2) = xlm(2)
4744 yfg(i,j+1,2) = ylm(2)
4745 xfg(i,j+1,4) = xlm(4)
4746 yfg(i,j+1,4) = yfg_4 - 1. + 5.*ep
4747 xfg(i,j+1,3) = .5*(xfg(i,j+1,1)+xfg(i,j+1,4))
4748 yfg(i,j+1,3) = .5*(yfg(i,j+1,1)+yfg(i,j+1,4))
4749 END IF
4751 ! ----- igniting a 1/4
4752 IF (yfg_3 > .5 .AND. yfg_4 < .5 .AND. nfl(i,j+1) /= 1) THEN
4753 nfl(i,j+1) = 1
4754 tign_g(i,j+1) = time
4755 xfg(i,j+1,1) = xlm(1)
4756 yfg(i,j+1,1) = ylm(1)
4757 xfg(i,j+1,2) = xfg_3 + 5.*ep
4758 yfg(i,j+1,2) = ylm(2)
4759 xfg(i,j+1,3) = xlm(3)
4760 yfg(i,j+1,3) = yfg_3 - 1. + 5.*ep
4761 xfg(i,j+1,4) = .5*(xfg(i,j+1,2)+xfg(i,j+1,3))
4762 yfg(i,j+1,4) = .5*(yfg(i,j+1,2)+yfg(i,j+1,3))
4763 END IF
4765 IF (yfg_3 > .5 .AND. yfg_4 > .5) THEN ! igniting a 2/2
4766 nfl(i,j+1) = 1
4767 tign_g(i,j+1) = time
4768 xfg(i,j+1,1) = xlm(1)
4769 yfg(i,j+1,1) = ylm(1)
4770 xfg(i,j+1,2) = xlm(2)
4771 yfg(i,j+1,2) = ylm(2)
4772 xfg(i,j+1,3) = xlm(3)
4773 yfg(i,j+1,3) = yfg_3 - 1. + 5.*ep
4774 xfg(i,j+1,4) = xlm(4)
4775 yfg(i,j+1,4) = yfg_4 - 1. + 5.*ep
4776 END IF
4777 END IF
4779 IF (is34 == 1) THEN
4780 xfg_1 = xcn(i,j,1) + (ylm(1)-ycn(i,j,1))*dly
4781 yfg_1 = ycn(i,j,1) + (xlm(1)-xcn(i,j,1))*dlx
4782 xfg_2 = xcn(i,j,1) + (ylm(2)-ycn(i,j,1))*dly
4783 yfg_2 = ycn(i,j,1) + (xlm(2)-xcn(i,j,1))*dlx
4785 ! ----- igniting a 1/4
4786 IF (yfg_1 < -.5 .AND. yfg_2 > -.5 .AND. nfl(i,j-1) /= 1) THEN
4787 nfl(i,j-1) = 1
4788 tign_g(i,j-1) = time
4789 xfg(i,j-1,1) = xlm(1)
4790 yfg(i,j-1,1) = yfg_1 + 1. - 5.*ep
4791 xfg(i,j-1,3) = xlm(3)
4792 yfg(i,j-1,3) = ylm(3)
4793 xfg(i,j-1,4) = xfg_1 + 5.*ep
4794 yfg(i,j-1,4) = ylm(4)
4795 xfg(i,j-1,2) = .5*(xfg(i,j-1,1)+xfg(i,j-1,4))
4796 yfg(i,j-1,2) = .5*(yfg(i,j-1,1)+yfg(i,j-1,4))
4797 END IF
4799 ! ----- igniting a 1/4
4800 IF (yfg_2 < -.5 .AND. yfg_1 > -.5 .AND. nfl(i,j-1) /= 1) THEN
4801 nfl(i,j-1) = 1
4802 tign_g(i,j-1) = time
4803 xfg(i,j-1,2) = xlm(2)
4804 yfg(i,j-1,2) = yfg_2 + 1. - 5.*ep
4805 xfg(i,j-1,3) = xfg_2 - 5.*ep
4806 yfg(i,j-1,3) = ylm(3)
4807 xfg(i,j-1,4) = xlm(4)
4808 yfg(i,j-1,4) = ylm(4)
4809 xfg(i,j-1,1) = .5*(xfg(i,j-1,2)+xfg(i,j-1,3))
4810 yfg(i,j-1,1) = .5*(yfg(i,j-1,2)+yfg(i,j-1,3))
4811 END IF
4813 IF (yfg_2 < -.5 .AND. yfg_1 < -.5) THEN !igniting a 2/2
4814 nfl(i,j-1) = 1
4815 tign_g(i,j-1) = time
4816 xfg(i,j-1,1) = xlm(1)
4817 yfg(i,j-1,1) = yfg_1 + 1. - 5.*ep
4818 xfg(i,j-1,2) = xlm(2)
4819 yfg(i,j-1,2) = yfg_2 + 1. - 5.*ep
4820 xfg(i,j-1,3) = xlm(3)
4821 yfg(i,j-1,3) = ylm(3)
4822 xfg(i,j-1,4) = xlm(4)
4823 yfg(i,j-1,4) = xlm(4)
4824 END IF
4825 END IF
4827 IF (is24 == 1) THEN
4829 xfg_1 = xcn(i,j,1) + (ylm(1)-ycn(i,j,1))*dly
4830 yfg_1 = ycn(i,j,1) + (xlm(1)-xcn(i,j,1))*dlx
4831 xfg_3 = xcn(i,j,1) + (ylm(3)-ycn(i,j,1))*dly
4832 yfg_3 = ycn(i,j,1) + (xlm(3)-xcn(i,j,1))*dlx
4834 ! ----- igniting a 1/4
4835 IF (xfg_1 < -.5 .AND. xfg_3 > -.5 .AND. nfl(i-1,j) /= 1) THEN
4836 nfl(i-1,j) = 1
4837 tign_g(i-1,j) = time
4838 xfg(i-1,j,1) = xfg_1 + 1. - 5.*ep
4839 yfg(i-1,j,1) = ylm(1)
4840 xfg(i-1,j,2) = xlm(2)
4841 yfg(i-1,j,2) = ylm(2)
4842 xfg(i-1,j,4) = xlm(4)
4843 yfg(i-1,j,4) = yfg_1 + 5.*ep
4844 xfg(i-1,j,3) = .5*(xfg(i-1,j,1)+xfg(i-1,j,4))
4845 yfg(i-1,j,3) = .5*(yfg(i-1,j,1)+yfg(i-1,j,4))
4846 END IF
4848 ! ----- igniting a 1/4
4849 IF (xfg_1 > -.5 .AND. xfg_3 < -.5 .AND. nfl(i-1,j) /= 1) THEN
4850 nfl(i-1,j) = 1
4851 tign_g(i-1,j) = time
4852 xfg(i-1,j,3) = xfg_3 + 1. - 5.*ep
4853 yfg(i-1,j,3) = ylm(3)
4854 xfg(i-1,j,4) = xlm(4)
4855 yfg(i-1,j,4) = ylm(4)
4856 xfg(i-1,j,2) = xlm(2)
4857 yfg(i-1,j,2) = yfg_3 - 5.*ep
4858 xfg(i-1,j,1) = .5*(xfg(i-1,j,2)+xfg(i-1,j,3))
4859 yfg(i-1,j,1) = .5*(yfg(i-1,j,2)+yfg(i-1,j,3))
4860 END IF
4862 IF (xfg_1 < -.5 .AND. xfg_3 < -.5) THEN !igniting a 2/2
4863 nfl(i-1,j) = 1
4864 tign_g(i-1,j) = time
4865 xfg(i-1,j,3) = xfg_3+1.-5.*ep
4866 yfg(i-1,j,3) = ylm(3)
4867 xfg(i-1,j,4) = xlm(4)
4868 yfg(i-1,j,4) = ylm(4)
4869 xfg(i-1,j,2) = xlm(2)
4870 yfg(i-1,j,2) = ylm(2)
4871 xfg(i-1,j,1) = xfg_1+1.-5.*ep
4872 yfg(i-1,j,1) = ylm(1)
4873 END IF
4874 END IF
4876 IF (is13 == 1) THEN
4878 xfg_2 = xcn(i,j,1) + (ylm(2)-ycn(i,j,1))*dly
4879 yfg_2 = ycn(i,j,1) + (xlm(2)-xcn(i,j,1))*dlx
4880 xfg_4 = xcn(i,j,1) + (ylm(4)-ycn(i,j,1))*dly
4881 yfg_4 = ycn(i,j,1) + (xlm(4)-xcn(i,j,1))*dlx
4883 ! ----- igniting a 1/4
4884 IF (xfg_2 > .5 .AND. xfg_4 < .5 .AND. nfl(i+1,j) /= 1) THEN
4885 nfl(i+1,j) = 1
4886 tign_g(i+1,j) = time
4887 xfg(i+1,j,1) = xlm(1)
4888 yfg(i+1,j,1) = ylm(1)
4889 xfg(i+1,j,2) = xfg_2 - 1. + 5.*ep
4890 yfg(i+1,j,2) = ylm(2)
4891 xfg(i+1,j,3) = xlm(3)
4892 yfg(i+1,j,3) = yfg_2 + 5.*ep
4893 xfg(i+1,j,4) = .5*(xfg(i+1,j,2)+xfg(i+1,j,3))
4894 yfg(i+1,j,4) = .5*(yfg(i+1,j,2)+yfg(i+1,j,3))
4895 END IF
4897 ! ----- igniting a 1/4
4898 IF (xfg_2 < .5 .AND. xfg_4 > .5 .AND. nfl(i+1,j) /= 1) THEN
4899 nfl(i+1,j) = 1
4900 tign_g(i+1,j) = time
4901 xfg(i+1,j,4) = xfg_4 - 1. + 5.*ep
4902 yfg(i+1,j,4) = ylm(4)
4903 xfg(i+1,j,3) = xlm(3)
4904 yfg(i+1,j,3) = ylm(3)
4905 xfg(i+1,j,1) = xlm(1)
4906 yfg(i+1,j,1) = yfg_4 - 5.*ep
4907 xfg(i+1,j,2) = .5*(xfg(i+1,j,1)+xfg(i+1,j,4))
4908 yfg(i+1,j,2) = .5*(yfg(i+1,j,1)+yfg(i+1,j,4))
4909 END IF
4911 IF (xfg_2 > .5 .AND. xfg_4 > .5) THEN !igniting a 2/2
4912 nfl(i+1,j) = 1
4913 tign_g(i+1,j) = time
4914 xfg(i+1,j,1) = xlm(1)
4915 yfg(i+1,j,1) = ylm(1)
4916 xfg(i+1,j,2) = xfg_2 - 1. + 5.*ep
4917 yfg(i+1,j,2) = ylm(2)
4918 xfg(i+1,j,3) = xlm(3)
4919 yfg(i+1,j,3) = ylm(3)
4920 xfg(i+1,j,4) = xfg_4 - 1. + 5.*ep
4921 yfg(i+1,j,4) = ylm(4)
4922 END IF
4924 END IF
4926 END IF !NCT=2 ICLS=2
4928 END IF !2/2 4/0 and 3/1 ignition
4929 END DO
4930 END DO
4932 !new version of 3/1 and 3/2 diagonal ignitions
4934 DO j = jf_st+1,jf_en-1
4935 DO i = if_st+1,if_en-1
4937 nct = nc(i,j)
4938 icls = icl(i,j)
4940 IF (nfl(i,j) == 1 .AND. nct == 3 .AND. time-tign_g(i,j) > ep) THEN
4942 i1 = in1(i,j,1)
4943 j1 = in1(i,j,2)
4944 i2 = in2(i,j,1)
4945 j2 = in2(i,j,2)
4947 nh1 = ncod(i1,j1)
4948 nh2 = ncod(i2,j2)
4949 nh0 = ncod(i,j)
4951 ic1 = 10 - icn(i,j,1) - 2*icn(i,j,2) - 3*icn(i,j,3) - 4*icn(i,j,4)
4952 ic2 = 5 - ic1
4953 ic3 = ic1 - 1 + 2*(ic1-(ic1/2)*2)
4954 ic4 = 10 - ic1 - ic2 - ic3
4956 x1 = FLOAT(icls-1)*(xcn(i1,j1,nh1-1)+FLOAT(i1-i)) &
4957 + FLOAT(2-icls)*(xcn(i1,j1,nh1-1)+FLOAT(i1-i))
4958 y1 = FLOAT(icls-1)*(ycn(i1,j1,nh1-1)+FLOAT(j1-j)) &
4959 + FLOAT(2-icls)*(ycn(i1,j1,nh1-1)+FLOAT(j1-j))
4960 x2 = FLOAT(icls-1)*xcn(i,j,2) + FLOAT(2-icls)*xcn(i,j,2)
4961 y2 = FLOAT(icls-1)*ycn(i,j,2) + FLOAT(2-icls)*ycn(i,j,2)
4962 x3 = FLOAT(icls-1)*xcn(i,j,2) + FLOAT(2-icls)*xcn(i,j,1)
4963 y3 = FLOAT(icls-1)*ycn(i,j,2) + FLOAT(2-icls)*ycn(i,j,1)
4964 x4 = FLOAT(icls-1)*(xcn(i2,j2,2)+FLOAT(i2-i)) &
4965 + FLOAT(2-icls)*(xcn(i2,j2,2)+FLOAT(i2-i))
4966 y4 = FLOAT(icls-1)*(ycn(i2,j2,2)+FLOAT(j2-j)) &
4967 + FLOAT(2-icls)*(ycn(i2,j2,2)+FLOAT(j2-j))
4969 xfga = x1 + (ylm(ic1)-y1)*(x2-x1)/(y2-y1+SIGN(ep,y2-y1))
4970 xfgb = x3 + (ylm(ic1)-y3)*(x4-x3)/(y4-y3+SIGN(ep,y4-y3))
4971 yfga = y1 + (xlm(ic1)-x1)*(y2-y1)/(x2-x1+SIGN(ep,x2-x1))
4972 yfgb = y3 + (xlm(ic1)-x3)*(y4-y3)/(x4-x3+SIGN(ep,x4-x3))
4974 xfga = xfga + SIGN(ep,xlm(ic1))
4975 xfgb = xfgb + SIGN(ep,xlm(ic1))
4976 yfga = yfga + SIGN(ep,ylm(ic1))
4977 yfgb = yfgb + SIGN(ep,ylm(ic1))
4979 ! ----- txa=0 means no ignition possible by the A line
4980 ! ----- txa=1 means ignition is possible by the A line
4982 txa = (xlm(ic1)-xfga)*(xlm(ic3)-xlm(ic1)) !debug
4983 txb = (xlm(ic1)-xfgb)*(xlm(ic3)-xlm(ic1))
4984 tya = (ylm(ic1)-yfga)*(ylm(ic4)-ylm(ic1))
4985 tyb = (ylm(ic1)-yfgb)*(ylm(ic4)-ylm(ic1))
4987 txa = INT((txa+ABS(txa))/(2.*ABS(txa)+ep)+.5)
4988 txb = INT((txb+ABS(txb))/(2.*ABS(txb)+ep)+.5)
4989 tya = INT((tya+ABS(tya))/(2.*ABS(tya)+ep)+.5)
4990 tyb = INT((tyb+ABS(tyb))/(2.*ABS(tyb)+ep)+.5)
4992 ! ----- we threshold the limit to .5 cell distance
4994 txa = .5 * txa * (1.-SIGN(1.,ABS(xfga-xlm(ic1))-.5)) !debug
4995 txb = .5 * txb * (1.-SIGN(1.,ABS(xfgb-xlm(ic1))-.5))
4996 tya = .5 * tya * (1.-SIGN(1.,ABS(yfga-ylm(ic1))-.5))
4997 tyb = .5 * tyb * (1.-SIGN(1.,ABS(yfgb-ylm(ic1))-.5))
4999 is = 1 - 2 * (ic1-(ic1/2)*2)
5000 js = - 1 + 2 * ((ic1-1)/2)
5002 IF (txa+txb > 1.-ep .AND. tya+tyb > 1.-ep .AND. &
5003 tign_g(i+is,j+js) < -10.) THEN !IGNITION
5005 xfg_ic1 = (txa*xfga+txb*xfgb)/(txa+txb+ep)
5006 yfg_ic1 = (tya*yfga+tyb*yfgb)/(tya+tyb+ep)
5007 nfl(i+is,j+js) = 1
5008 tign_g(i+is,j+js) = time
5009 xfg(i+is,j+js,ic2) = xlm(ic2)
5010 yfg(i+is,j+js,ic2) = ylm(ic2)
5011 xfg(i+is,j+js,ic3) = xlm(ic3)
5012 yfg(i+is,j+js,ic4) = ylm(ic4)
5013 yfg(i+is,j+js,ic3) = yfg_ic1 - FLOAT(js)*(1.-5.*ep) !debug
5014 xfg(i+is,j+js,ic4) = xfg_ic1 - FLOAT(js)*(1.-5.*ep) !debug
5015 xfg(i+is,j+js,ic1) = .5*(xfg(i+is,j+js,ic3)+xfg(i+is,j+js,ic4))
5016 yfg(i+is,j+js,ic1) = .5*(yfg(i+is,j+js,ic3)+yfg(i+is,j+js,ic4))
5018 END IF ! WE HAVE IGNITION
5020 END IF !NFL=1 NCT=3
5021 END DO
5022 END DO
5023 !end new version of 3/1 and 3/2 diagonal ignitions
5025 DO j = jf_st+1,jf_en-1
5026 DO i = if_st+1,if_en-1
5028 nct = nc(i,j)
5029 icls = icl(i,j)
5031 IF (nfl(i,j) == 1 .AND. nct == 1 .AND. icls == 4 .AND. &
5032 tign_g(i,j) > ep) THEN !NCT=1 ICLS=4
5033 ! debug section
5034 tx = MAX(ABS(xcn(i,j,1)),ABS(xcn(i,j,3)))
5035 ty = MAX(ABS(ycn(i,j,1)),ABS(ycn(i,j,3)))
5037 IF (tx > .5 .OR. ty > .5) THEN !1/4 likely
5038 i1 = in1(i,j,1)
5039 j1 = in1(i,j,2)
5040 i2 = in2(i,j,1)
5041 j2 = in2(i,j,2)
5042 nh1 = ncod(i1,j1)
5043 nh2 = ncod(i2,j2)
5044 nh0 = ncod(i,j)
5045 ic1 = icn(i,j,1) + 2*icn(i,j,2) + 3*icn(i,j,3) + 4*icn(i,j,4)
5046 ic2 = 5 - ic1
5047 ic3 = ixb(i,j,1)*(1-iyb(i,j,1)) + 2*ixb(i,j,2)*(1-iyb(i,j,2)) + &
5048 3*ixb(i,j,3)*(1-iyb(i,j,3)) + 4*ixb(i,j,4)*(1-iyb(i,j,4))
5049 ic4 = 10 - ic1 - ic2 - ic3
5050 iod = ic1 - 2*(ic1/2)
5051 is = 1 - 2*iod
5052 js = - 1 + 2*(ic1/3)
5053 isen = is*js
5054 x1 = xcn(i2,j2,2) + FLOAT(i2-i)
5055 y1 = ycn(i2,j2,2) + FLOAT(j2-j)
5056 x2 = xcn(i2,j2,1) + FLOAT(i2-i)
5057 y2 = ycn(i2,j2,1) + FLOAT(j2-j)
5058 x3 = xcn(i,j,2+isen)
5059 y3 = ycn(i,j,2+isen)
5060 x4 = xcn(i,j,2)
5061 y4 = ycn(i,j,2)
5062 x5 = xcn(i,j,2-isen)
5063 y5 = ycn(i,j,2-isen)
5064 x6 = xcn(i1,j1,nh1) + FLOAT(i1-i)
5065 y6 = ycn(i1,j1,nh1) + FLOAT(j1-j)
5066 x7 = xcn(i1,j1,nh1-1) + FLOAT(i1-i)
5067 y7 = ycn(i1,j1,nh1-1) + FLOAT(j1-j)
5068 IF (isen == -1) THEN
5069 x1 = xcn(i1,j1,nh1-1) + FLOAT(i1-i)
5070 y1 = ycn(i1,j1,nh1-1) + FLOAT(j1-j)
5071 x2 = xcn(i1,j1,nh1) + FLOAT(i1-i)
5072 y2 = ycn(i1,j1,nh1) + FLOAT(j1-j)
5073 x6 = xcn(i2,j2,1) + FLOAT(i2-i)
5074 y6 = ycn(i2,j2,1) + FLOAT(j2-j)
5075 x7 = xcn(i2,j2,2) + FLOAT(i2-i)
5076 y7 = ycn(i2,j2,2) + FLOAT(j2-j)
5077 END IF
5078 ihita = 0
5079 ihitb = 0
5080 IF (nfl(i-is,j) /= 1) THEN !NFL(I-IS,J) NE 1
5081 yfg_a4 = y4 + (xlm(ic3)-x4)*(y5-y4)/(x5-x4+SIGN(ep,x5-x4))
5082 tj1 = (yfg_a4-ylm(ic3))*(ylm(ic2)-ylm(ic3))
5083 tj2 = (xlm(ic3)-x5)*(xlm(ic1)-xlm(ic3))
5084 tj3 = .75 - ABS(yfg_a4-ylm(ic3))
5085 tja4 = MIN((tj1+ABS(tj1)),(tj2+ABS(tj2)),(tj3+ABS(tj3)))
5086 ja4 = INT((tja4+ABS(tja4))/(2.*ABS(tja4)+ep)+.5)
5088 xfg_a4 = x4 + (ylm(ic3)-y4)*(x5-x4)/(y5-y4+SIGN(ep,y5-y4))
5089 ti1 = (xlm(ic3)-xfg_a4)*(xlm(ic1)-xlm(ic3))
5090 ti2 = (xlm(ic3)-x5)*(xlm(ic1)-xlm(ic3))
5091 ti3 = .75 - ABS(xfg_a4-xlm(ic3))
5092 tia4 = MIN((ti1+ABS(ti1)),(ti2+ABS(ti2)),(ti3+ABS(ti3)))
5093 ia4 = INT((tia4+ABS(tia4))/(2.*ABS(tia4)+ep)+.5)
5095 xfg_a6 = x6 + (ylm(ic3)-y6)*(x7-x6)/(y7-y6+SIGN(ep,y7-y6))
5096 ti1 = (xfg_a6-xlm(ic3))*(xlm(ic3)-xlm(ic1))
5097 ti2 = (x6-xlm(ic3))*(xlm(ic3)-xlm(ic1))
5098 ti3 = .75 - ABS(xfg_a6-xlm(ic3))
5099 tia6 = MIN((ti1+ABS(ti1)),(ti2+ABS(ti2)),(ti3+ABS(ti3)))
5100 ia6 = INT((tia6+ABS(tia6))/(2.*ABS(tia6)+ep)+.5)
5102 yfg_a6 = y6 + (xlm(ic3)-x6)*(y7-y6)/(x7-x6+SIGN(ep,x7-x6))
5103 tj1 = (yfg_a6-ylm(ic3))*(ylm(ic2)-ylm(ic3))
5104 tj2 = (x6-xlm(ic3))*(xlm(ic3)-xlm(ic1))
5105 tj3 = .75 - ABS(yfg_a6-ylm(ic3))
5106 tja6 = MIN((tj1+ABS(tj1)),(tj2+ABS(tj2)),(tj3+ABS(tj3)))
5107 ja6 = INT((tja6+ABS(tja6))/(2.*ABS(tja6)+ep)+.5)
5109 ! ----- ia6 takes priority over ia4
5110 ! ----- la4 takes priority over la6
5111 ia4 = (1-ia6)*ia4
5112 ja6 = (1-ja4)*ja6
5113 xfg_a = (FLOAT(ia4)*xfg_a4+FLOAT(ia6)*xfg_a6)/(FLOAT(ia4+ia6)+ep)
5114 yfg_a = (FLOAT(ja4)*yfg_a4+FLOAT(ja6)*yfg_a6)/(FLOAT(ja4+ja6)+ep)
5115 IF (ia4+ia6 > 0 .AND. ja4+ja6 > 0) THEN
5116 nfl(i-is,j) = 1
5117 ihita = 1
5118 tign_g(i-is,j) = time
5119 xfg(i-is,j,ic1) = xlm(ic1)
5120 yfg(i-is,j,ic1) = ylm(ic1)
5121 xfg(i-is,j,ic3) = xfg_a + FLOAT(is)*(1.-5.*ep)
5122 yfg(i-is,j,ic3) = ylm(ic3)
5123 xfg(i-is,j,ic4) = xlm(ic4)
5124 yfg(i-is,j,ic4) = yfg_a + SIGN(5.*ep,ylm(ic2)-ylm(ic3))
5125 xfg(i-is,j,ic2) = .5*(xfg(i-is,j,ic3)+xfg(i-is,j,ic4))
5126 yfg(i-is,j,ic2) = .5*(yfg(i-is,j,ic3)+yfg(i-is,j,ic4))
5127 END IF
5128 ! IF (ihita == 1) THEN
5129 IF (ihita == 3) THEN
5130 PRINT *,'debug IHITA results follow'
5131 PRINT *,'debug IC1 2 3 4=',ic1,ic2,ic3,ic4
5132 PRINT *,'debug I J=',i,j
5133 PRINT *,'debug I1 J1=',i1,j1
5134 PRINT *,'debug I2 J2=',i2,j2
5135 PRINT *,'debug IOD IS JS=',iod,is,js
5136 PRINT *,'debug XFG_A4 YFG_A4=',xfg_a4,yfg_a4
5137 PRINT *,'debug IA4 JA4=',ia4,ja4
5138 PRINT *,'debug XFG_A6 YFG_A6=',xfg_a6,yfg_a6
5139 PRINT *,'debug IA6 JA6=',ia6,ja6
5140 PRINT *,'debug X1 X2=',x1,x2
5141 PRINT *,'debug Y1 Y2=',y1,y2
5142 PRINT *,'debug X3 X4 X5=',x3,x4,x5
5143 PRINT *,'debug Y3 Y4 Y5=',y3,y4,y5
5144 PRINT *,'debug X6 X7=',x6,x7
5145 PRINT *,'debug Y6 Y7=',y6,y7
5147 END IF
5148 END IF !NFL(I-IS,J) NE 1
5150 IF (nfl(i,j-js) /= 1) THEN !NFL(I,J-JS) NE 1
5152 yfg_b1 = y1 + (xlm(ic4)-x1)*(y2-y1)/(x2-x1+SIGN(ep,x2-x1))
5153 tj1 = (yfg_b1-ylm(ic4))*(ylm(ic4)-ylm(ic1))
5154 tj2 = (y2-ylm(ic4))*(ylm(ic4)-ylm(ic1))
5155 tj3 = .75 - ABS(yfg_b1-ylm(ic4))
5156 tjb1 = MIN((tj1+ABS(tj1)),(tj2+ABS(tj2)),(tj3+ABS(tj3)))
5157 jb1 = INT((tjb1+ABS(tjb1))/(2.*ABS(tjb1)+ep)+.5)
5159 xfg_b1 = x1 + (ylm(ic4)-y1)*(x2-x1)/(y2-y1+SIGN(ep,y2-y1))
5160 ti1 = (xfg_b1-xlm(ic4))*(xlm(ic2)-xlm(ic4))
5161 ti2 = (y2-ylm(ic4))*(ylm(ic4)-ylm(ic1))
5162 ti3 = .75 - ABS(xfg_b1-xlm(ic4))
5163 tib1 = MIN((ti1+ABS(ti1)),(ti2+ABS(ti2)),(ti3+ABS(ti3)))
5164 ib1 = INT((tib1+ABS(tib1))/(2.*ABS(tib1)+ep)+.5)
5166 xfg_b3 = x3 + (ylm(ic4)-y3)*(x4-x3)/(y4-y3+SIGN(ep,y4-y3))
5167 ti1 = (xfg_b3-xlm(ic4))*(xlm(ic2)-xlm(ic4))
5168 ti2 = (y3-ylm(ic4))*(ylm(ic4)-ylm(ic1))
5169 ti3 = .75 - ABS(xfg_b3-xlm(ic4))
5170 tib3 = MIN((ti1+ABS(ti1)),(ti2+ABS(ti2)),(ti3+ABS(ti3)))
5171 ib3 = INT((tib3+ABS(tib3))/(2.*ABS(tib3)+ep)+.5)
5173 yfg_b3 = y3 + (xlm(ic4)-x3)*(y4-y3)/(x4-x3+SIGN(ep,x4-x3))
5174 tj1 = (yfg_b3-ylm(ic4))*(ylm(ic4)-ylm(ic1))
5175 tj2 = (y3-ylm(ic4))*(ylm(ic4)-ylm(ic1))
5176 tj3 = .75 - ABS(yfg_b3-ylm(ic4))
5177 tjb3 = MIN((tj1+ABS(tj1)),(tj2+ABS(tj2)),(tj3+ABS(tj3)))
5178 jb3 = INT((tjb3+ABS(tjb3))/(2.*ABS(tjb3)+ep)+.5)
5180 ! ----- ib3 takes priority over ib1
5181 ! ----- jb1 takes priority over jb3
5182 ib1 = (1-ib3)*ib1
5183 jb3 = (1-jb1)*jb3
5184 xfg_b = (FLOAT(ib1)*xfg_b1+FLOAT(ib3)*xfg_b3)/(FLOAT(ib1+ib3)+ep)
5185 yfg_b = (FLOAT(jb1)*yfg_b1+FLOAT(jb3)*yfg_b3)/(FLOAT(jb1+jb3)+ep)
5186 IF (ib1+ib3 > 0 .AND. jb1+jb3 > 0) THEN
5187 nfl(i,j-js) = 1
5188 ihitb = 1
5189 tign_g(i,j-js) = time
5190 xfg(i,j-js,ic1) = xlm(ic1)
5191 yfg(i,j-js,ic1) = ylm(ic1)
5192 xfg(i,j-js,ic3) = xfg_b + SIGN(5.*ep,xlm(ic2)-xlm(ic4))
5193 yfg(i,j-js,ic3) = ylm(ic3)
5194 xfg(i,j-js,ic4) = xlm(ic4)
5195 yfg(i,j-js,ic4) = yfg_b + FLOAT(js)*(1.-5.*ep)
5196 xfg(i,j-js,ic2) = .5*(xfg(i,j-js,ic3)+xfg(i,j-js,ic4))
5197 yfg(i,j-js,ic2) = .5*(yfg(i,j-js,ic3)+yfg(i,j-js,ic4))
5198 END IF
5199 ! IF (ihitb == 1) THEN
5200 IF (ihitb == 3) THEN
5201 PRINT *,'debug IHITB results follow'
5202 PRINT *,'debug IC1 2 3 4=',ic1,ic2,ic3,ic4
5203 PRINT *,'debug I J=',i,j
5204 PRINT *,'debug I1 J1=',i1,j1
5205 PRINT *,'debug I2 J2=',i2,j2
5206 PRINT *,'debug IOD IS JS=',iod,is,js
5207 PRINT *,'debug XFG_B1 YFG_B1=',xfg_b1,yfg_b1
5208 PRINT *,'debug XFG_B3 YFG_B3=',xfg_b3,yfg_b3
5209 PRINT *,'debug X1 X2=',x1,x2
5210 PRINT *,'debug Y1 Y2=',y1,y2
5211 PRINT *,'debug X3 X4 X5=',x3,x4,x5
5212 PRINT *,'debug Y3 Y4 Y5=',y3,y4,y5
5213 PRINT *,'debug X6 X7=',x6,x7
5214 PRINT *,'debug Y6 Y7=',y6,y7
5215 END IF
5216 END IF !NFL(I,J-JS) NE 1
5217 END IF !1/4 likely
5218 END IF !NCT=1 ICLS=4
5219 ! debug section
5220 END DO
5221 END DO
5223 ! ----- redundant check for unignited cells - likely missed by diagonal 1/3 or 2/3
5225 DO j = jf_st+1,jf_en-1
5226 DO i = if_st+1,if_en-1
5228 isum = nfl(i+1,j) + nfl(i-1,j) + nfl(i,j+1) + nfl(i,j-1)
5230 IF (tign_g(i,j) < -10. .AND. isum == 2) THEN !unignited cell
5232 ! ----- corner = 1
5234 isumc = icn(i-1,j,2) + icn(i,j-1,3)
5235 isum = iyb(i-1,j,4) + ixb(i,j-1,4)
5236 IF (isumc == 2 .AND. isum >= 1) THEN
5237 PRINT *,'debug CN=1 redund igs hit at I J=',i,j
5238 tign_g(i,j) = time
5239 nfl(i,j) = 1
5240 x1 = xfg(i,j-1,4)
5241 y1 = yfg(i,j-1,4)-1.
5242 x2 = xfg(i-1,j,4)-1.
5243 y2 = yfg(i-1,j,4)
5244 xfg_2 = x1 + (ylm(2)-y1)*(x2-x1)/(y2-y1+SIGN(ep,y2-y1))
5245 yfg_3 = y1 + (xlm(3)-x1)*(y2-y1)/(x2-x1+SIGN(ep,x2-x1))
5246 xfg(i,j,1) = xlm(1)
5247 yfg(i,j,1) = ylm(1)
5248 xfg(i,j,2) = xfg_2
5249 yfg(i,j,2) = ylm(2)
5250 xfg(i,j,3) = xlm(3)
5251 yfg(i,j,3) = yfg_3
5252 xfg(i,j,4) = .5*(xfg(i,j,2)+xfg(i,j,3))
5253 yfg(i,j,4) = .5*(yfg(i,j,2)+yfg(i,j,3))
5254 END IF
5256 ! ----- corner = 2
5258 isumc = icn(i+1,j,1) + icn(i,j-1,4)
5259 isum = iyb(i+1,j,3) + ixb(i,j-1,3)
5260 IF (isumc == 2 .AND. isum >= 1) THEN
5261 PRINT *,'debug CN=2 redund igs hit at I J=',i,j
5262 tign_g(i,j) = time
5263 nfl(i,j) = 1
5264 x1 = xfg(i+1,j,3) + 1.
5265 y1 = yfg(i+1,j,3)
5266 x2 = xfg(i,j-1,3)
5267 y2 = yfg(i,j-1,3) - 1.
5268 xfg_1 = x1 + (ylm(1)-y1)*(x2-x1)/(y2-y1+SIGN(ep,y2-y1))
5269 yfg_4 = y1 + (xlm(4)-x1)*(y2-y1)/(x2-x1+SIGN(ep,x2-x1))
5270 xfg(i,j,2) = xlm(2)
5271 yfg(i,j,2) = ylm(2)
5272 xfg(i,j,1) = xfg_1
5273 yfg(i,j,1) = ylm(1)
5274 xfg(i,j,4) = xlm(4)
5275 yfg(i,j,4) = yfg_4
5276 xfg(i,j,3) = .5*(xfg(i,j,1)+xfg(i,j,4))
5277 yfg(i,j,3) = .5*(yfg(i,j,1)+yfg(i,j,4))
5278 END IF
5280 ! ----- corner = 3
5282 isumc = icn(i-1,j,4) + icn(i,j+1,1)
5283 isum = iyb(i-1,j,2) + ixb(i,j+1,2)
5284 IF (isumc == 2 .AND. isum >= 1) THEN
5285 PRINT *,'debug CN=3 redund igs hit at I J=',i,j
5286 tign_g(i,j) = time
5287 nfl(i,j) = 1
5288 x1 = xfg(i-1,j,2) - 1.
5289 y1 = yfg(i-1,j,2)
5290 x2 = xfg(i,j+1,2)
5291 y2 = yfg(i,j+1,2) + 1.
5292 xfg_4 = x1 + (ylm(4)-y1)*(x2-x1)/(y2-y1+SIGN(ep,y2-y1))
5293 yfg_1 = y1 + (xlm(1)-x1)*(y2-y1)/(x2-x1+SIGN(ep,x2-x1))
5294 xfg(i,j,3) = xlm(3)
5295 yfg(i,j,3) = ylm(3)
5296 xfg(i,j,4) = xfg_4
5297 yfg(i,j,4) = ylm(4)
5298 xfg(i,j,1) = xlm(1)
5299 yfg(i,j,1) = yfg_1
5300 xfg(i,j,2) = .5*(xfg(i,j,1)+xfg(i,j,4))
5301 yfg(i,j,2) = .5*(yfg(i,j,1)+yfg(i,j,4))
5302 END IF
5304 ! ----- corner = 4
5305 isumc = icn(i+1,j,3) + icn(i,j+1,2)
5306 isum = iyb(i+1,j,1) + ixb(i,j+1,1)
5307 IF (isumc == 2 .AND. isum >= 1) THEN
5308 PRINT *,'debug CN=4 redund igs hit at I J=',i,j
5309 tign_g(i,j) = time
5310 nfl(i,j) = 1
5311 x1 = xfg(i,j+1,1)
5312 y1 = yfg(i,j+1,1)+1.
5313 x2 = xfg(i+1,j,1)+1.
5314 y2 = yfg(i+1,j,1)
5315 xfg_3 = x1 + (ylm(3)-y1)*(x2-x1)/(y2-y1+SIGN(ep,y2-y1))
5316 yfg_2 = y1 + (xlm(2)-x1)*(y2-y1)/(x2-x1+SIGN(ep,x2-x1))
5317 xfg(i,j,4) = xlm(4)
5318 yfg(i,j,4) = ylm(4)
5319 xfg(i,j,3) = xfg_3
5320 yfg(i,j,3) = ylm(3)
5321 xfg(i,j,2) = xlm(2)
5322 yfg(i,j,2) = yfg_2
5323 xfg(i,j,1) = .5*(xfg(i,j,2)+xfg(i,j,3))
5324 yfg(i,j,1) = .5*(yfg(i,j,2)+yfg(i,j,3))
5325 END IF
5327 END IF !unignited cell
5328 END DO
5329 END DO
5331 RETURN
5333 END SUBROUTINE fire_igs
5335 ! =========================================================================
5337 SUBROUTINE fire_burn_fcn(i,j, & ! incoming
5338 nfuel_cat,nfl,ncod,in1,in2, &
5339 ixb,iyb,icn,time,area2, &
5340 tign_g,tign_crt, &
5341 xcd,ycd,xcn,ycn,xfg,yfg, &
5342 ids,ide, kds,kde, jds,jde, &
5343 ims,ime, kms,kme, jms,jme, &
5344 its,ite, kts,kte, jts,jte, &
5345 ifms,ifme, kfms,kfme, jfms,jfme, &
5346 if_st,if_en,jf_st,jf_en, &
5347 nfrx,nfry, &
5348 burn_frac) ! outgoing
5350 ! -----------------------------------------------------------------------
5351 ! This subroutine gives a fit to the mass loss curve.
5352 ! It calculates the fraction of mass left in the cell's ignited
5353 ! area at the time given.
5354 ! The function approximates a decreasing exponential with
5355 ! weighting value WEIGHT ranging from 20 (fast burnup) to 1000
5356 ! ( ~40% decrease in mass over 10 min).
5357 ! BURN_FRAC= fraction of fuel mass in cell that has been burned in
5358 ! last timestep.
5359 ! TIGN_CRT(I,L): if fuel cell is not fully ignited, it is negative.
5360 ! If fuel cell fully ignited, it is dimensionless (universal) time
5361 ! TCELL : time since cell ignition (s)
5362 ! TMCRIT : first time since cell ignition that whole cell is burning (s)
5363 ! -----------------------------------------------------------------------
5365 USE module_fr_cawfe_fuel
5367 IMPLICIT NONE
5369 ! ------ incoming variables
5371 INTEGER, INTENT(in) :: ids,ide, kds,kde, jds,jde
5372 INTEGER, INTENT(in) :: ims,ime, kms,kme, jms,jme
5373 INTEGER, INTENT(in) :: its,ite, kts,kte, jts,jte
5374 INTEGER, INTENT(in) :: ifms,ifme, kfms,kfme, jfms,jfme
5375 INTEGER, INTENT(in) :: if_st,if_en, jf_st,jf_en
5376 INTEGER, INTENT(in) :: nfrx,nfry
5378 INTEGER, INTENT(in) :: i,j
5380 INTEGER, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme ) :: nfuel_cat
5381 INTEGER, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme ) :: nfl,ncod
5382 INTEGER, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,2 ) :: in1,in2
5383 INTEGER, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: ixb,iyb,icn
5385 REAL, INTENT(in) :: time
5387 REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme ) :: area2
5388 REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme ) :: tign_g,tign_crt
5389 REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xcd,ycd
5390 REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xcn,ycn
5391 REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xfg,yfg
5393 ! ------ outgoing variables
5395 REAL, INTENT(out) :: burn_frac
5397 ! ------ local variables
5399 INTEGER :: iflt
5401 REAL :: are1
5402 REAL :: tcell
5403 REAL :: burn_fracc
5404 REAL :: tmcrit
5406 ! --------------------------------------------------------------------------
5408 are1 = area2(i,j)
5410 ! ----- CVMGP: returns x1 if x3 >=0, x2 if x3 < 0
5411 tcell = cvmgp( time-tign_g(i,j), 0., tign_g(i,j) )
5413 IF (tign_crt(i,j) < 0.) THEN ! fuel cell not yet fully burning
5415 IF (tcell > ep) THEN
5416 burn_frac = are1 + are1*weight(nfuel_cat(i,j))/tcell &
5417 * (EXP(-tcell/weight(nfuel_cat(i,j)))-1.)
5418 ELSE
5419 burn_frac = 0.
5420 END IF
5422 ELSE !fuel cell is fully burning
5424 tmcrit = tign_crt(i,j) - tign_g(i,j)
5426 IF (tmcrit > ep) THEN
5428 burn_fracc = are1 + are1*weight(nfuel_cat(i,j))/tmcrit &
5429 *(EXP(-tmcrit/weight(nfuel_cat(i,j)))-1.)
5431 burn_frac = burn_fracc + weight(nfuel_cat(i,j))/tmcrit &
5432 *(1.-EXP(-tmcrit/weight(nfuel_cat(i,j)))) &
5433 *(1.-EXP( (tmcrit-tcell)/weight(nfuel_cat(i,j)) ))
5435 ELSE ! fuel cell is ~instantly fully lit (kin test)
5437 burn_frac = 1.-EXP(-tmcrit/weight(nfuel_cat(i,j))) ! test: point burning
5439 IF (tign_crt(i,j) > ep .AND. ABS(time-tign_crt(i,j)) < ep) &
5440 THEN !avoid initialization cases
5442 PRINT 66,tmcrit,burn_frac,i,j,time
5443 66 FORMAT(1X,'Warning 215- TMCRIT BURN_FRAC =',2F5.2, &
5444 ', I J =',2I4,', TIME =',F8.2)
5445 END IF
5446 END IF
5447 !
5448 IF (tmcrit > tcell) THEN
5449 WRITE (6,*) 'STOP 213: BURN_FRAC,ARE1,WEIGHT,TCELL,TMCRIT=', &
5450 i,j,burn_frac,are1,weight(nfuel_cat(i,j)),tcell,tmcrit
5451 iflt = 213
5452 CALL fire_error_debug(i,j,iflt, &
5453 time,in1,in2,tign_g, &
5454 nfl,ncod,xcd,ycd,xcn,ycn,icn, &
5455 ixb,iyb,xfg,yfg, &
5456 ifms,ifme, kfms,kfme, jfms,jfme, &
5457 if_st,if_en,jf_st,jf_en)
5458 END IF
5459 END IF
5461 RETURN
5463 END SUBROUTINE fire_burn_fcn
5465 ! =========================================================================
5467 SUBROUTINE fire_ros( i,j, & ! incoming
5468 ifms,ifme, kfms,kfme, jfms,jfme, &
5469 speed,tanphi,ibeh,nfuel_cat, &
5470 bbb,phiwc,betafl,r_0, &
5471 ros) ! outgoing
5473 !-----------------------------------------------------------------------
5474 ! ... calculates the rate of fire spread with mcarthur formula or behave
5475 ! using fuel type of fuel cell
5476 !
5477 ! m/s = (ft/min) *.3048/60. = (ft/min) * .00508 ! conversion rate
5478 ! ft/min = m/s * 2.2369 * 88. = m/s * 196.850 ! conversion rate
5479 !
5480 !-----------------------------------------------------------------------
5482 USE module_fr_cawfe_fuel
5484 IMPLICIT NONE
5486 ! ------ incoming variables
5488 INTEGER, INTENT(in) :: ifms,ifme, kfms,kfme, jfms,jfme
5489 INTEGER, INTENT(in) :: ibeh
5490 INTEGER, INTENT(in) :: i,j
5492 INTEGER, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme ) :: nfuel_cat
5494 REAL, INTENT(in) :: speed,tanphi
5496 REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme ) :: bbb,phiwc,betafl,r_0
5498 ! ------ in and out going variables
5501 ! ------ outgoing variables
5503 REAL, INTENT(out) :: ros
5505 ! ------ local variables
5507 REAL :: spd_ms,spd_fm
5508 REAL :: phis,phiw,sp_n
5509 CHARACTER(LEN=96) :: msg
5511 ! ------ begin routine
5513 IF (ichap(nfuel_cat(i,j)) == 0) THEN ! not chaparral
5515 IF (ibeh == 1) THEN ! BEHAVE
5517 ! --- if wind is 0 or into fireline, phiw=0, this reduces to backing r.o.s.
5519 spd_ms = .5*(speed + ABS(speed))
5520 spd_ms = MIN(spd_ms,10.) ! max input wind spd is 10 m/s !param
5522 spd_fm = spd_ms * 196.850 ! convert wind spd from m/s to ft/min
5524 ! ----- wind factor : phiw = c * spd_fm**bbb(i,j) * (betafl(i,j)/betaop)**(-e)
5526 phiw = spd_fm**bbb(i,j) * phiwc(i,j) ! wind coef
5528 ! --- slope factor
5530 phis = 0.
5531 IF (tanphi > 0.) THEN
5532 phis = 5.275 *(betafl(i,j))**(-0.3) *tanphi**2 ! slope factor
5533 END IF
5535 ! --- spread rate (m/s)
5537 ros = r_0(i,j) * (1. + phiw + phis) * .00508
5539 WRITE (msg,'(x,a,2i4,5(x,e12.3) )') 'i,j,ros,r0,phiw,phis=', &
5540 i,j,ros,r_0(i,j),phiw,phis
5541 CALL wrf_message( msg )
5543 IF (ros > 1.) WRITE (6,*) 'speed=',speed,' tanphi=',tanphi
5545 ELSE IF (ibeh == 0) THEN !MACARTHUR FORMULA
5547 ros = 0.18 * EXP(0.8424*.5*(speed+ABS(speed)))
5549 END IF
5551 ELSE IF (ichap(nfuel_cat(i,j)) == 1) THEN ! chaparral
5552 ! .... spread rate has no dependency on fuel character, only windspeed.
5553 spd_ms = .5*(speed+ABS(speed))
5554 ros = 1.2974 * spd_ms**1.41 ! spread rate, m/s
5555 ! -- note: backing r.o.s. is 0 for chaparral without setting nozero value below
5556 sp_n =.03333 ! Chaparral backing fire spread rate 0.033 m/s
5557 ros = MAX(ros, sp_n) ! no less than backing r.o.s.
5558 END IF
5560 ! ----------NOTE! Put an 6 m/s cap on max spread rate -----------
5562 ros = MIN(ros, 6.) ! no faster than this cap ! param !
5564 ! IF (spd_ms > 0) THEN
5565 ! WRITE (6,120) i,j,' spd_ms,ros =',spd_ms,ros,' phiw,r0_ms=', &
5566 ! phiw, r_0(i,j)*0.00508
5567 ! END IF
5568 !120 FORMAT (1x,2i3,a,2f10.4,a,2f10.4)
5570 RETURN
5572 END SUBROUTINE fire_ros
5574 ! =========================================================================
5576 SUBROUTINE fire_valid14(i,j,ic1,ic2,ic3,ic4,ita,itb,itc,nc, &
5577 icl,xfg,yfg,ixb,iyb,icn, &
5578 ifms,ifme, kfms,kfme, jfms,jfme)
5580 ! ----- routine checks the validity of fire points
5582 IMPLICIT NONE
5584 ! ----- incoming variables
5586 INTEGER, INTENT(in) :: ifms,ifme, kfms,kfme, jfms,jfme
5587 INTEGER, INTENT(in) :: i,j
5589 ! ----- inout variables
5591 INTEGER, INTENT(inout) :: ic1,ic2,ic3,ic4
5592 INTEGER, INTENT(inout) :: ita,itb,itc
5594 INTEGER, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: ixb,iyb,icn
5595 INTEGER, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: nc,icl
5597 REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xfg,yfg
5599 ! ----- local variables
5601 INTEGER :: iod
5602 INTEGER :: is,js
5604 ! ----- begin routine
5606 ic1 = icn(i,j,1) + 2*icn(i,j,2) + 3*icn(i,j,3) + 4*icn(i,j,4)
5607 ic2 = 5 - ic1
5608 ic3 = ixb(i,j,1)*(1-iyb(i,j,1)) + 2*ixb(i,j,2)*(1-iyb(i,j,2)) + &
5609 3*ixb(i,j,3)*(1-iyb(i,j,3)) + 4*ixb(i,j,4)*(1-iyb(i,j,4))
5610 ic4 = 10 - ic1 - ic2 - ic3
5611 iod = ic1 - 2*(ic1/2)
5612 is = 1 - 2*iod
5613 js = -1 + 2*(ic1/3)
5614 ita = icn(i-is,j,ic1) + icn(i-is,j+js,ic4)
5615 itb = icn(i+is,j-js,ic3) + icn(i,j-js,ic1)
5616 itc = icn(i-is,j,ic4) + icn(i-is,j-js,ic1) + icn(i,j-js,ic3)
5618 IF (ita > 0) then
5619 xfg(i,j,ic3) = xlm(ic3)
5620 yfg(i,j,ic3) = ylm(ic3)
5621 icn(i,j,ic3) = 1
5622 ixb(i,j,ic3) = 0
5623 iyb(i,j,ic3) = 0
5624 xfg(i,j,ic2) = xlm(ic2)
5625 yfg(i,j,ic2) = ylm(ic3) + 5.*ep*(ylm(ic2)-ylm(ic3))
5626 END IF
5628 IF (itb > 0) THEN
5629 xfg(i,j,ic4) = xlm(ic4)
5630 yfg(i,j,ic4) = ylm(ic4)
5631 icn(i,j,ic4) = 1
5632 ixb(i,j,ic4) = 0
5633 iyb(i,j,ic4) = 0
5634 xfg(i,j,ic2) = xlm(ic4) + 5.*ep*(xlm(ic2)-xlm(ic4))
5635 yfg(i,j,ic2) = ylm(ic2)
5636 END IF
5638 IF (itc > 0) THEN
5639 xfg(i,j,ic2) = xlm(ic2)
5640 yfg(i,j,ic2) = ylm(ic2)
5641 icn(i,j,ic2) = 1
5642 ixb(i,j,ic2) = 0
5643 iyb(i,j,ic2) = 0
5644 END IF
5646 ! ??????
5647 IF (ita > 0 .AND. itb > 0 .AND. itc == 0) THEN
5648 ! ----- chose IC2 coordinate positions
5649 END IF
5651 nc(i,j) = icn(i,j,1) + icn(i,j,2) + icn(i,j,3) + icn(i,j,4)
5652 icl(i,j) = ixb(i,j,1) + ixb(i,j,2) + ixb(i,j,3) + ixb(i,j,4) + &
5653 iyb(i,j,1) + iyb(i,j,2) + iyb(i,j,3) + iyb(i,j,4)
5655 RETURN
5657 END SUBROUTINE fire_valid14
5659 ! =========================================================================
5661 SUBROUTINE fire_error_debug(i,j,iflt,time,in1,in2,tign_g, &
5662 nfl,ncod,xcd,ycd,xcn,ycn,icn,ixb,iyb, &
5663 xfg,yfg, &
5664 ifms,ifme, kfms,kfme, jfms,jfme, &
5665 if_st,if_en,jf_st,jf_en)
5667 ! ------- this routine writes debug to stdout and to ncar graphics
5669 USE module_wrf_error
5671 IMPLICIT NONE
5673 ! ------- incoming variables
5675 INTEGER, INTENT(in) :: ifms,ifme, kfms,kfme, jfms,jfme
5676 INTEGER, INTENT(in) :: if_st,if_en, jf_st,jf_en
5678 INTEGER, INTENT(in) :: i,j,iflt
5681 INTEGER, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme ) :: nfl,ncod
5682 INTEGER, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme, 2 ) :: in1,in2
5683 INTEGER, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme, 4 ) :: ixb,iyb,icn
5685 REAL, INTENT(in) :: time
5687 REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme ) :: tign_g
5688 REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme, 4 ) :: xcd,ycd
5689 REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme, 4 ) :: xcn,ycn
5690 REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme, 4 ) :: xfg,yfg
5692 ! ------ local variables
5694 INTEGER, PARAMETER :: ierrf = 6
5695 INTEGER, PARAMETER :: lunit = 2
5696 INTEGER, PARAMETER :: iwkid = 1
5698 INTEGER :: ii,jj,it,ic,ierr,nct,icls,ixn,jyn,i1,j1,iszdm
5699 INTEGER :: idl,jdl,i2,j2,iix,jjy,npd
5701 INTEGER, DIMENSION( ifms:ifme,jfms:jfme ) :: nc,icc
5703 REAL :: txn,tyn,x1,x2,y1,y2,xx1,yy1,xx2,yy2,xx3,yy3,dl,rwidth
5705 CHARACTER (LEN=4) :: flitnu
5706 CHARACTER (LEN=80) :: lhead
5707 CHARACTER (LEN=80) :: cdum
5708 CHARACTER (LEN=21) :: fnmi
5709 CHARACTER (LEN=5) :: iflg
5710 CHARACTER (LEN=256) :: msg
5712 ! ---------- end declarations, begin processing
5714 DO jj = jf_st,jf_en
5715 DO ii = if_st,if_en
5716 nc(ii,jj) = 0
5717 icc(ii,jj) = 0
5718 DO it=1,4
5719 nc(ii,jj) = nc(ii,jj) + icn(ii,jj,it)
5720 icc(ii,jj) = icc(ii,jj) + ixb(ii,jj,it) + iyb(ii,jj,it)
5721 END DO
5722 END DO
5723 END DO
5725 PRINT 11,time,i,j,iflt
5726 11 FORMAT(1x,'ERROR DEBUG AT TIME=',f9.3,' I J=',2i4,' IFLT=',i4)
5728 PRINT 80,i,j,ncod(i,j),(in1(i,j,ic),ic=1,2),(in2(i,j,ic),ic=1,2)
5729 80 FORMAT(1x,'I J NCOD=',3i4/4x,'IN1=',2i4/4x,'IN2=',2i4)
5731 PRINT 84,((time-tign_g(ii,jj),ii=i-1,i+1),jj=j+1,j-1,-1)
5732 84 FORMAT(1x,'TIME-TIGN_G=',3f14.4)
5734 PRINT 85,((nfl(ii,jj),ii=i-1,i+1),jj=j+1,j-1,-1)
5735 85 FORMAT(1x,' NFL =',3i10)
5736 PRINT 135,((nc(ii,jj),ii=i-1,i+1),jj=j+1,j-1,-1)
5737 135 FORMAT(1X,' NC =',3i10)
5738 PRINT 136,((icc(ii,jj),ii=i-1,i+1),jj=j+1,j-1,-1)
5739 136 FORMAT(1X,' ICLS =',3i10)
5741 PRINT 63,(xcd(i,j,it),it=1,4),(ycd(i,j,it),it=1,4)
5742 63 FORMAT(1x,'XCD(I J )=',4f10.7/1x,'YCD(I J =',4f10.7)
5743 PRINT 67,(xcd(i+1,j,it),it=1,4),(ycd(i+1,j,it),it=1,4)
5744 67 FORMAT(1x,'XCD(IP J )=',4f10.7/1x,'YCD(IP J =',4f10.7)
5745 PRINT 68,(xcd(i-1,j,it),it=1,4),(ycd(i-1,j,it),it=1,4)
5746 68 FORMAT(1x,'XCD(IM J )=',4f10.7/1x,'YCD(IM J =',4f10.7)
5747 PRINT 69,(xcd(i,j+1,it),it=1,4),(ycd(i,j+1,it),it=1,4)
5748 69 FORMAT(1x,'XCD(I JP)=',4f10.7/1x,'YCD(I JP=',4f10.7)
5749 PRINT 70,(xcd(i,j-1,it),it=1,4),(ycd(i,j-1,it),it=1,4)
5750 70 FORMAT(1x,'XCD(I JM)=',4f10.7/1x,'YCD(I JM=',4f10.7)
5751 PRINT 71,(xcd(i+1,j+1,it),it=1,4),(ycd(i+1,j+1,it),it=1,4)
5752 71 FORMAT(1x,'XCD(IP JP)=',4f10.7/1x,'YCD(IP JP=',4f10.7)
5753 PRINT 72,(xcd(i-1,j-1,it),it=1,4),(ycd(i-1,j-1,it),it=1,4)
5754 72 FORMAT(1x,'XCD(IM JM)=',4f10.7/1x,'YCD(IM JM=',4f10.7)
5755 PRINT 79,(xcd(i+1,j-1,it),it=1,4),(ycd(i+1,j-1,it),it=1,4)
5756 79 FORMAT(1x,'XCD(IP JM)=',4f10.7/1x,'YCD(IP JM=',4f10.7)
5757 PRINT 83,(xcd(i-1,j+1,it),it=1,4),(ycd(i-1,j+1,it),it=1,4)
5758 83 FORMAT(1x,'XCD(IM JP)=',4f10.7/1x,'YCD(IM JP=',4f10.7)
5760 PRINT 65,(xcn(i,j,it),it=1,4),(ycn(i,j,it),it=1,4)
5761 65 FORMAT(1x,'XCN(I J =',4f10.7/1x,'YCN(I J =',4f10.7)
5762 PRINT 73,(xcn(i+1,j,it),it=1,4),(ycn(i+1,j,it),it=1,4)
5763 73 FORMAT(1x,'XCN(IP J =',4f10.7/1x,'YCN(IP J =',4f10.7)
5764 PRINT 74,(xcn(i-1,j,it),it=1,4),(ycn(i-1,j,it),it=1,4)
5765 74 FORMAT(1x,'XCN(IM J =',4f10.7/1x,'YCN(IM J =',4f10.7)
5766 PRINT 75,(xcn(i,j+1,it),it=1,4),(ycn(i,j+1,it),it=1,4)
5767 75 FORMAT(1x,'XCN(I JP=',4f10.7/1x,'YCN(I JP=',4f10.7)
5768 PRINT 76,(xcn(i,j-1,it),it=1,4),(ycn(i,j-1,it),it=1,4)
5769 76 FORMAT(1x,'XCN(I JM=',4f10.7/1x,'YCN(I JM=',4f10.7)
5770 PRINT 77,(xcn(i+1,j+1,it),it=1,4),(ycn(i+1,j+1,it),it=1,4)
5771 77 FORMAT(1x,'XCN(IP JP=',4f10.7/1x,'YCN(IP JP=',4f10.7)
5772 PRINT 78,(xcn(i-1,j-1,it),it=1,4),(ycn(i-1,j-1,it),it=1,4)
5773 78 FORMAT(1x,'XCN(IM JM=',4f10.7/1x,'YCN(IM JM=',4f10.7)
5774 PRINT 81,(xcn(i+1,j-1,it),it=1,4),(ycn(i+1,j-1,it),it=1,4)
5775 81 FORMAT(1x,'XCN(IP JM=',4f10.7/1x,'YCN(IP JM=',4f10.7)
5776 PRINT 82,(xcn(i-1,j+1,it),it=1,4),(ycn(i-1,j+1,it),it=1,4)
5777 82 FORMAT(1x,'XCN(IM JP=',4f10.7/1x,'YCN(IM JP=',4f10.7)
5779 nct = icn(i,j,1) + icn(i,j,2) + icn(i,j,3) + icn(i,j,4)
5780 icls = ixb(i,j,1) + ixb(i,j,2) + ixb(i,j,3) + ixb(i,j,4) + &
5781 iyb(i,j,1) + iyb(i,j,2) + iyb(i,j,3) + iyb(i,j,4)
5783 PRINT 32,nct,icls,(icn(i,j,it),it=1,4),nfl(i,j)
5784 32 FORMAT(1x,'NCT ICLS=',2i4/5x,'ICN=',4i4/5x,'NFL=',i4)
5786 PRINT 49,i ,j,(xfg(i ,j,it),it=1,4),(yfg(i ,j,it),it=1,4)
5787 PRINT 50,i+1,j,(xfg(i+1,j,it),it=1,4),(yfg(i+1,j,it),it=1,4)
5788 PRINT 51,i-1,j,(xfg(i-1,j,it),it=1,4),(yfg(i-1,j,it),it=1,4)
5789 PRINT 52,i,j+1,(xfg(i,j+1,it),it=1,4),(yfg(i,j+1,it),it=1,4)
5790 PRINT 53,i,j-1,(xfg(i,j-1,it),it=1,4),(yfg(i,j-1,it),it=1,4)
5791 49 FORMAT(1x,'I J =',2i4,' XFG=',4f10.7/16x,' YFG=',4f10.7)
5792 50 FORMAT(1x,'IP J =',2i4,' XFG=',4f10.7/16x,' YFG=',4f10.7)
5793 51 FORMAT(1x,'IM J =',2i4,' XFG=',4f10.7/16x,' YFG=',4f10.7)
5794 52 FORMAT(1x,'I JP =',2i4,' XFG=',4f10.7/16x,' YFG=',4f10.7)
5795 53 FORMAT(1x,'I JM =',2i4,' XFG=',4f10.7/16x,' YFG=',4f10.7)
5797 PRINT 54,i+1,j+1,(xfg(i+1,j+1,it),it=1,4),(yfg(i+1,j+1,it),it=1,4)
5798 PRINT 55,i+1,j-1,(xfg(i+1,j-1,it),it=1,4),(yfg(i+1,j-1,it),it=1,4)
5799 PRINT 56,i-1,j+1,(xfg(i-1,j+1,it),it=1,4),(yfg(i-1,j+1,it),it=1,4)
5800 PRINT 57,i-1,j-1,(xfg(i-1,j-1,it),it=1,4),(yfg(i-1,j-1,it),it=1,4)
5801 54 FORMAT(1x,'IP JP =',2i4,' XFG=',4f10.7/16x,' YFG=',4f10.7)
5802 55 FORMAT(1x,'IP JM =',2i4,' XFG=',4f10.7/16x,' YFG=',4f10.7)
5803 56 FORMAT(1x,'IM JP =',2i4,' XFG=',4f10.7/16x,' YFG=',4f10.7)
5804 57 FORMAT(1x,'IM JM =',2i4,' XFG=',4f10.7/16x,' YFG=',4f10.7)
5806 PRINT 33,(ixb(i,j,it),it=1,4),(iyb(i,j,it),it=1,4)
5807 PRINT 34,(ixb(i+1,j,it),it=1,4),(iyb(i+1,j,it),it=1,4)
5808 PRINT 35,(ixb(i-1,j,it),it=1,4),(iyb(i-1,j,it),it=1,4)
5809 PRINT 36,(ixb(i,j+1,it),it=1,4),(iyb(i,j+1,it),it=1,4)
5810 PRINT 37,(ixb(i,j-1,it),it=1,4),(iyb(i,j-1,it),it=1,4)
5811 33 FORMAT(1x,'IXB(I J )=',4i4/1x,'IYB(I J )=',4i4)
5812 34 FORMAT(1x,'IXB(IP J )=',4i4/1x,'IYB(IP J )=',4i4)
5813 35 FORMAT(1x,'IXB(IM J )=',4i4/1x,'IYB(IM J )=',4i4)
5814 36 FORMAT(1x,'IXB(I JP)=',4i4/1x,'IYB(I JP)=',4i4)
5815 37 FORMAT(1x,'IXB(I JM)=',4I4/1x,'IYB(I JM)=',4i4)
5817 ! ---- EGP commented out printing the winds...
5818 ! ... print winds used to spread fire
5819 ! PRINT 180,i ,j,(ug(i ,j,it),it=1,4),(vg(i ,j,it),it=1,4)
5820 ! PRINT 181,i+1,j,(ug(i+1,j,it),it=1,4),(vg(i+1,j,it),it=1,4)
5821 ! PRINT 182,i-1,j,(ug(i-1,j,it),it=1,4),(vg(i-1,j,it),it=1,4)
5822 ! PRINT 183,i,j+1,(ug(i,j+1,it),it=1,4),(vg(i,j+1,it),it=1,4)
5823 ! PRINT 184,i,j-1,(ug(i,j-1,it),it=1,4),(vg(i,j-1,it),it=1,4)
5824 180 FORMAT(1x,'I J =',2i4,' UG=',4f9.3/16x,' VG=',4f9.3)
5825 181 FORMAT(1x,'IP J =',2i4,' UG=',4f9.3/16x,' VG=',4f9.3)
5826 182 FORMAT(1x,'IM J =',2i4,' UG=',4f9.3/16x,' VG=',4f9.3)
5827 183 FORMAT(1x,'I JP =',2i4,' UG=',4f9.3/16x,' VG=',4f9.3)
5828 184 FORMAT(1x,'I JM =',2i4,' UG=',4f9.3/16x,' VG=',4f9.3)
5830 WRITE (iflg,'(I5.5)') iflt
5831 WRITE (msg,*) 'fire_error_debug: FATAL '//iflg
5832 CALL wrf_error_fatal ( msg )
5834 RETURN
5836 END SUBROUTINE fire_error_debug
5838 ! =========================================================================
5840 REAL FUNCTION cvmgp(a,b,c)
5842 ! ----- returns x1 if x3 >=0
5843 ! or x2 if x3 < 0
5845 REAL, INTENT(in) :: a,b,c
5847 ! ----- begin
5849 IF (c >= 0.) THEN
5850 cvmgp = a
5851 ELSE
5852 cvmgp = b
5853 END IF
5855 END FUNCTION cvmgp
5857 ! =========================================================================
5859 SUBROUTINE fire_emissions(grnhfx,canhfx,dt,dz8w,rho,num_scalars, & ! incoming
5860 ids,ide, kds,kde, jds,jde, &
5861 ims,ime, kms,kme, jms,jme, &
5862 its,ite, kts,kte, jts,jte, &
5863 scalar) ! outgoing
5865 ! -------------------------------------------------------------------------
5866 ! this routine handles the emission of carbonaceous particles assuming
5867 ! a specified percent of the fuel mass to be emitted as smoke.
5868 !
5869 ! this routine will serve as a template for further chemical emissions.
5870 ! -------------------------------------------------------------------------
5872 IMPLICIT NONE
5874 ! --- incoming variables
5876 INTEGER, INTENT(in) :: ids,ide, kds,kde, jds,jde, &
5877 ims,ime, kms,kme, jms,jme, &
5878 its,ite, kts,kte, jts,jte
5880 INTEGER, INTENT(in) :: num_scalars
5882 REAL, INTENT(in) :: dt
5883 REAL, INTENT(in), DIMENSION( ims:ime,jms:jme ) :: grnhfx,canhfx
5884 REAL, INTENT(in), DIMENSION( ims:ime,kms:kme,jms:jme ) :: dz8w
5885 REAL, INTENT(in), DIMENSION( ims:ime,kms:kme,jms:jme ) :: rho
5887 ! --- outgoing variables
5889 REAL, INTENT(out), DIMENSION( ims:ime,jms:jme,1:num_scalars ) :: scalar
5891 ! --- local variables
5893 INTEGER :: i,j,k
5895 REAL :: smoke_fac
5896 REAL :: del_g,del_c
5897 REAL :: density_g,density_c
5898 REAL :: zbox_g,zbox_c
5899 REAL :: tracer_g,tracer_c
5901 ! ---------------------------------------------------------------------
5903 smoke_fac = 0.02 ! 2% of fuel mass becomes smoke
5905 DO j = MAX(jts,jds+1),MIN(jte,jde-1)
5906 DO i = MAX(its,ids+1),MIN(ite,ide-1)
5908 del_g = grnhfx(i,j) * dt / cmbcnst
5909 del_c = canhfx(i,j) * dt / cmbcnst
5911 density_g = rho(i,1,j)
5912 density_c = rho(i,2,j)
5914 zbox_g = dz8w(i,1,j)
5915 zbox_c = dz8w(i,2,j)
5917 ! --- tracer_g/c in kg of tracer per kg of air
5919 tracer_g = smoke_fac * del_g / (zbox_g * density_g)
5920 tracer_c = smoke_fac * del_c / (zbox_c * density_c)
5922 scalar(i,1,j) = scalar(i,1,j) + tracer_g
5923 scalar(i,2,j) = scalar(i,2,j) + tracer_c
5925 END DO
5926 END DO
5928 END SUBROUTINE fire_emissions
5930 ! =========================================================================
5932 SUBROUTINE fire_winds(u,v, & ! incoming
5933 ids,ide, kds,kde, jds,jde, &
5934 ims,ime, kms,kme, jms,jme, &
5935 its,ite, kts,kte, jts,jte, &
5936 u_i,v_i) ! outgoing
5938 ! --- this routine takes u and v from the arakawa c-grid and interpolates
5939 ! them horizontally and upward to the w-level (i.e. to the grid cube corners)
5940 ! as desired by the fire code. note that the final values are two
5941 ! dimensional arrays that are six grid points tall valid at the w-levels
5942 ! and that the exterior single grid point on all four edges of the domain
5943 ! are not filled.
5944 !
5945 ! v(1,2) u(1,2) u(2,2)
5946 ! ----*---- v(1,2) *--------* v(2,2)
5947 ! | | | |
5948 ! u(1,1) * * u(2,1) ===> | |
5949 ! | | | |
5950 ! ^ y ----*---- u(1,1) *--------* u(2,1)
5951 ! | v(1,1) v(1,1) v(2,1)
5952 ! |
5953 ! *----> x and shifted up to w-level
5954 !
5955 IMPLICIT NONE
5957 INTEGER , INTENT(in) :: ids,ide, kds,kde, jds,jde, &
5958 ims,ime, kms,kme, jms,jme, &
5959 its,ite, kts,kte, jts,jte
5961 REAL, INTENT(in), DIMENSION( ims:ime,kms:kme,jms:jme ) :: u,v
5963 REAL, INTENT(out), DIMENSION( ims:ime,jms:jme,6 ) :: u_i,v_i
5965 INTEGER :: i,j,k
5966 INTEGER :: i_st,i_en
5967 INTEGER :: j_st,j_en
5969 ! --- set indicies
5971 i_st = MAX(its,ids+1)
5972 i_en = MIN(ite,ide-1)
5973 j_st = MAX(jts,jds+1)
5974 j_en = MIN(jte,jde-1)
5976 ! --- get velocities
5978 DO k = 1,6
5979 DO j = j_st,j_en
5980 DO i = i_st,i_en
5981 u_i(i,j,k) = .25*( u(i,k,j) + u(i,k,j+1) + u(i,k+1,j) + u(i,k+1,j+1) )
5982 v_i(i,j,k) = .25*( v(i-1,k,j) + v(i,k,j) + v(i-1,k+1,j) + v(i,k+1,j) )
5983 END DO
5984 END DO
5985 END DO
5987 RETURN
5989 END SUBROUTINE fire_winds
5991 ! =========================================================================
5993 SUBROUTINE fire_tendency(grnhfx,grnqfx,canhfx,canqfx, & ! incoming
5994 alfg,alfc,z1can, &
5995 zs,z_at_w,dz8w,mu,rho, &
5996 ids,ide, kds,kde, jds,jde, &
5997 ims,ime, kms,kme, jms,jme, &
5998 its,ite, kts,kte, jts,jte, &
5999 rthfrten,rqvfrten) ! outgoing
6001 ! --- this routine takes fire generated heat and moisture fluxes and
6002 ! calculates their influence on the theta and water vapor
6004 ! --- note that these tendencies are valid at the Arakawa-A location
6006 IMPLICIT NONE
6008 ! --- incoming variables
6010 INTEGER , INTENT(in) :: ids,ide, kds,kde, jds,jde, &
6011 ims,ime, kms,kme, jms,jme, &
6012 its,ite, kts,kte, jts,jte
6014 REAL, INTENT(in), DIMENSION( ims:ime,jms:jme ) :: grnhfx,grnqfx ! W/m^2
6015 REAL, INTENT(in), DIMENSION( ims:ime,jms:jme ) :: canhfx,canqfx ! W/m^2
6016 REAL, INTENT(in), DIMENSION( ims:ime,jms:jme ) :: zs ! topography (m abv sealvl)
6017 REAL, INTENT(in), DIMENSION( ims:ime,jms:jme ) :: mu ! dry air mass (Pa)
6019 REAL, INTENT(in), DIMENSION( ims:ime,kms:kme,jms:jme ) :: z_at_w ! m abv sealvl
6020 REAL, INTENT(in), DIMENSION( ims:ime,kms:kme,jms:jme ) :: dz8w ! dz across w-lvl
6021 REAL, INTENT(in), DIMENSION( ims:ime,kms:kme,jms:jme ) :: rho ! density
6023 REAL, INTENT(in) :: alfg ! extinction depth ground fire heat (m)
6024 REAL, INTENT(in) :: alfc ! extinction depth crown fire heat (m)
6025 REAL, INTENT(in) :: z1can ! height of crown fire heat release (m)
6027 ! --- outgoing variables
6029 REAL, INTENT(out), DIMENSION( ims:ime,kms:kme,jms:jme ) :: &
6030 rthfrten, & ! theta tendency from fire (in mass units)
6031 rqvfrten ! Qv tendency from fire (in mass units)
6032 ! --- local variables
6034 INTEGER :: i,j,k
6035 INTEGER :: i_st,i_en, j_st,j_en, k_st,k_en
6037 REAL :: cp_i
6038 REAL :: rho_i
6039 REAL :: xlv_i
6040 REAL :: z_w,dz
6041 REAL :: fact_g, fact_c
6043 REAL, DIMENSION( ims:ime,kms:kme,jms:jme ) :: hfx,qfx
6045 ! --- set some local constants
6047 cp_i = 1./cp ! inverse of specific heat
6048 xlv_i = 1./xlv ! inverse of latent heat
6050 ! --- set loop indicies : note that
6052 i_st = MAX(its,ids+1)
6053 i_en = MIN(ite,ide-1)
6054 k_st = kts
6055 k_en = MIN(kte,kde-1)
6056 j_st = MAX(jts,jds+1)
6057 j_en = MIN(jte,jde-1)
6059 ! --- distribute fluxes
6061 DO j = j_st,j_en
6062 DO k = k_st,k_en
6063 DO i = i_st,i_en
6065 ! --- set z (in meters above ground)
6067 z_w = z_at_w(i,k,j) - zs(i,j) ! should be zero when k=k_st
6069 ! --- heat flux
6071 fact_g = cp_i * EXP( - alfg * z_w )
6072 IF ( z_w < z1can ) THEN
6073 fact_c = cp_i
6074 ELSE
6075 fact_c = cp_i * EXP( - alfc * (z_w - z1can) )
6076 END IF
6077 hfx(i,k,j) = fact_g * grnhfx(i,j) + fact_c * canhfx(i,j)
6079 ! --- vapor flux
6081 fact_g = xlv_i * EXP( - alfg * z_w )
6082 IF (z_w < z1can) THEN
6083 fact_c = xlv_i
6084 ELSE
6085 fact_c = xlv_i * EXP( - alfc * (z_w - z1can) )
6086 END IF
6087 qfx(i,k,j) = fact_g * grnqfx(i,j) + fact_c * canqfx(i,j)
6089 END DO
6090 END DO
6091 END DO
6093 ! --- add flux divergence to tendencies
6094 !
6095 ! multiply by dry air mass (mu) to eliminate the need to
6096 ! call sr. calculate_phy_tend (in dyn_em/module_em.F)
6098 DO j = j_st,j_en
6099 DO k = k_st,k_en-1
6100 DO i = i_st,i_en
6102 rho_i = 1./rho(i,k,j)
6104 rthfrten(i,k,j) = - mu(i,j) * rho_i * (hfx(i,k+1,j)-hfx(i,k,j)) / dz8w(i,k,j)
6105 rqvfrten(i,k,j) = - mu(i,j) * rho_i * (qfx(i,k+1,j)-qfx(i,k,j)) / dz8w(i,k,j)
6107 END DO
6108 END DO
6109 END DO
6111 RETURN
6113 END SUBROUTINE fire_tendency
6115 ! =========================================================================
6117 END MODULE module_fr_cawfe