program trakmain c c$$$ MAIN PROGRAM DOCUMENTATION BLOCK c c Main Program: GETTRK Track model vortices C PRGMMR: MARCHOK ORG: NP22 DATE: 2002-05-20 c c ABSTRACT: This program tracks the average of the max or min c of several parameters in the vicinity of an input c first guess (lat,lon) position of a vortex in order to give c forecast position estimates for that vortex for a given numerical c model. For the levels 700 & 850 mb, the tracked parameters are: c Relative vorticity (max), wind magnitude (min), and geopotential c height (min). Also tracked is the min in the MSLP. So many c parameters are tracked in order to provide more accurate position c estimates for weaker storms, which often have poorly defined c structures/centers. Currently, the system is set up to be able c to process GRIB input data files from the GFS, MRF, UKMET, GDAS, c ECMWF, NGM, NAM and FNMOC/NAVGEM models. Two 1-line files c are output from this program, both containing the forecast fix c positions that the tracker has obtained. One of these output c files contains the positions at every 12 hours from forecast c hour 0 to the end of the forecast. The other file is in ATCF c format, which is the particular format needed by the Tropical c Prediction Center, and provides the positions at forecast hours c 12, 24, 36, 48 and 72, plus the maximum wind near the storm center c at each of those forecast hours. c c Program history log: c 98-03-16 Marchok - Original operational version. c 98-07-15 Marchok - Added code to calculate radii of gale-, storm-, c and hurricane-force winds in each quadrant. c 99-04-01 Marchok - Added code to be able to read in 4-digit years c off of the TC Vitals records. c Added code, including subroutine is_it_a_storm, c to make a better determination of whether or c not the center that was found at each time is c the center of a storm, and not just a passing c vort max, etc. c 99-06-15 Marchok - Fixed a bug in calcdist that was triggered by a c rounding error sending a number just above 1 c into ACOS to get the distance between 2 c identical points (which, obviously, is 0). c 00-06-20 Marchok - Added GDAS option for vortex relocation work. c Changed nhalf from 3 to 5. Relaxed the c requirements for pthresh and vthresh. c 00-11-30 Marchok - Added ability to handle GFDL and NCEP Ensemble c model data. Extended time range to be able to c handle 5-day capability. Forecast hours are c now input via a namelist (easiest way to account c for NAM, GFS and GFDL having different forecast c lengths at 00/12z and 06/18z). Model ID's are c now input via a namelist (makes it easier, for c example, to run for many different ensemble c members). Added new output, the atcfunix c format, needed for 5-day forecasts. c 01-08-24 Marchok Fixed a bug in rvcal and getgridinfo. When a c grid that was south-->north is flipped in c conv1d2d_real to be north-->south, the scanning c mode flag remains 64 and what we would consider c the max and min latitudes are reversed, so I c added code to correct this in both routines. c 02-05-20 Marchok Weakened the mslp gradient threshold and v850 c threshold in is_it_a_storm to cut down on the c number of dropped storms. c 03-03-18 Marchok Fixed a bug in get_ij_bounds that was allowing c a cos(90) and cos(-90), which then led to a c divide by zero. c 05-08-01 Marchok Updated to allow tracking of ECMWF hi-res, ECMWF c ensemble, CMC hi-res, CMC ensemble, NCEP c ensemble. c 06-11-07 Marchok Updated to locate, and report to the atcfunix c file, the value of the gridpoint minimum value c of mslp. Previously, the barnes-averaged c value had been used. c 08-01-10 Marchok Changed the storm ID for genesis tracking so c that the ID includes info c on storm detection location & time. Added c algorithms for Hart's cyclone phase space. c Added new output fields to the atcfunix c records, actually creating a modified atcfunix c record, to include things such as the mean & c max values of zeta850 & zeta700 centered on c the storm, the speed & direction of storm c translation, and the Hart CPS parameters. c 10-01-07 Marchok - input grib lead time can be hrs or minutes c - added code for warm core check c - added code to detect genesis c - added code to report on sfc wind structure c - added buffer ("grid_buffer") to avoid fixing c center to boundaries on regional grids c - modified rvcal to report missing zeta values c as background coriolis instead of -999, since c the -999 was messing up center-fixing c - added 10-m wind and sfc zeta as center-fixing c parms. c c 10-05-25 Slocum Add verbose feature to code c 0 = Not terminal output, 1 = error messages only c 2 = all output c c 10-05-26 Marchok - added flags and code to check the temporal c consistency of the mslp closed contour and c Vt850 checks for tcgen and midlat cases. c c 13-04-01 Marchok Added code to upgrade the wind radii diagnosid. c Hurricane Sandy exposed an issue with the c tracker for large storms. The code was modified c to use an iterative technique that can c diagnose radii for large storms but still c accurately diagnost radii for small storms. See c subroutine getradii for more details. c c 15-11-01 Marchok Replaced the routine which tracks the wind c minimum at the center of a storm, as that c routine proved troublesome with very hi-res c grids (0.02-deg) from HWRF for very small c storms. This has been replaced with a routine c that looks for "wind circulation difference", c whereby the center for this parm is located at c the spot where the tangential wind circulation c minus the wind magnitude at the candidate c center position is maximized. ALSO: Added in c tracking of thickness as an additional c tracked parm. ALSO: Added a separate verbose c flag for only the GRIB2 read diagnostics, which c can be voluminous. c c 16-09-01 Marchok Added in the ability to read in NetCDF files. c As with GRIB data, the NetCDF data must be on c a lat/lon grid. c c 17-08-31 Marchok Added a logical bitmap capability for NetCDF c files to prevent the accessing of missing data. c Also modified the code to permit more accurate c reporting of the grid point value of the c minimum SLP for reporting to the atcfunix file. c Finally, fixed a bug (reported by JTWC) whereby c radii were being reported for thresholds that c were in exceedance of the tracker-diagnosed c Vmax (e.g., 34-kt radii for a storm with c Vmax = 25 kts). c c Input files: c unit 11 Unblocked GRIB1 file containing model data c unit 12 Text file containing TC Vitals card for current time c unit 31 Unblocked GRIB index file c c Output files: c unit 61 Output file with forecast positions every 12h from c vt=00h to the end of the forecast c unit 62 Output file in ATCF format, with forecast positions c at vt = 12, 24, 36, 48 and 72h, plus wind speeds. c unit 63 Output file with forecast wind radii for 34, 50 and c 64 knot thresholds in each quadrant of each storm. c c Subprograms called: c read_nlists Read input namelists for input date & storm number info c read_tcv_card Read TC vitals file to get initial storm position c getgridinfo Read GRIB file to get basic grid information c tracker Begin main part of tracking algorithm c c Attributes: c Language: Standard Fortran_90 c c$$$ c c------- c c LOCAL: c c ifhours: Integer array holding numerical forecast times for c the input model (99 = no more times available). c These values are read in via a namelist. c Model numbers used: (1) GFS, (2) MRF, (3) UKMET, (4) ECMWF, c (5) NGM, (6) NAM, (7) NAVGEM, (8) GDAS, c (10) NCEP Ensemble, (11) ECMWF Ensemble (13) SREF c Ensemble, (14) NCEP Ensemble (from ensstat mean c fields), (15) CMC, (16) CMC Ensemble, (17) HWRF, c (18) HWRF Ensemble, (19) HWRF-DAS (HDAS), c (20) Ensemble RELOCATION (21) UKMET hi-res (NHC) c (23) FNMOC Ensemble c stormswitch: This switch tells how to handle each storm in c the TCV file: c 1 = process this storm for this forecast hour. c 2 = Storm was requested to be tracked, but either c the storm went off the grid (regional models), c the storm dissipated, or the program was c unable to track it. c 3 = Storm was NOT requested to be tracked at all. c storm: An array of type tcvcard. Each member of storm c contains a separate TC Vitals card. c maxstorm: Maximum number of storms the system is set up to c handle at any 1 time. c slonfg,slatfg: Holds first guess positions for storms. The c very first, first guess position is read from the c TC vitals card. (maxstorm,maxtime) c clon,clat: Holds the coordinates for the center positions for c all storms at all times for all parameters. c (max_#_storms, max_fcst_times, max_#_parms) c USE def_vitals; USE inparms; USE set_max_parms; USE level_parms USE trig_vals; USE atcf; USE trkrparms; USE verbose_output USE netcdf_parms c implicit none c logical(1) file_open integer date_time(8) character (len=10) big_ben(3) character :: ncfile*180,ncfile_has_hour0*1 integer itret,iggret,iicret,igcret,iret,ifhmax,maxstorm,numtcv integer iocret,enable_timing,ncfile_id,ncfile_tmax,irnhret integer, parameter :: lugb=11,lugi=31,lucard=12,lgvcard=14,lout=51 c type (datecard) inp type (trackstuff) trkrinfo type (netcdfstuff) netcdfinfo c -------------------------------------------------------- call date_and_time (big_ben(1),big_ben(2),big_ben(3),date_time) write (6,31) date_time(5),date_time(6),date_time(7) 31 format (1x,'TIMING: beginning ... ',i2.2,':',i2.2,':',i2.2) call w3tagb('GETTRK ',1999,0104,0058,'NP22 ') pi = 4. * atan(1.) ! Both pi and dtr were declared in module dtr = pi/180.0 ! trig_vals, but were not yet defined. ncfile_has_hour0 = 'n' ! Default value; set in read_netcdf_hours c call read_nlists (inp,trkrinfo,netcdfinfo) enable_timing=trkrinfo%enable_timing call read_fhours (ifhmax) call read_tcv_card (lucard,maxstorm,trkrinfo,numtcv,iret) if (iret == 0) then if ( verb .ge. 3 ) then print *,'After read_tcv_card, num vitals = ',numtcv endif else if ( verb .ge. 1 ) then print '(/,a50,i4,/)','!!! ERROR: in read_tcv_card, rc= ',iret endif goto 890 endif call read_gen_vitals (lgvcard,maxstorm,trkrinfo,numtcv,iret) if (iret == 0) then if ( verb .ge. 3 ) then print *,'After read_gen_vitals, total number of vitals (both' & ,' TC and non-TC) now = ',numtcv endif else if ( verb .ge. 1 ) then print '(/,a50,i4,/)','!!! ERROR: in read_gen_vitals, rc= ' & ,iret endif goto 890 endif if (inp%file_seq == 'onebig') then if (trkrinfo%inp_data_type == 'netcdf') then ncfile = netcdfinfo%netcdf_filename print *,' ' print *,'before open_ncfile call, ncfile= ',ncfile call open_ncfile (ncfile,ncfile_id) print *,'after open_ncfile call, ncfile_id= ',ncfile_id call read_netcdf_hours (ncfile,ncfile_id,ncfile_tmax,ifhmax & ,ncfile_has_hour0,netcdfinfo,irnhret) if (irnhret /= 0) then print *,'(/,a32,a5,i4,/)','!!! ERROR: in read_netcdf_hours,' & ,' rc= ',irnhret goto 890 endif else call open_grib_files (inp,lugb,lugi,'dummy','dummy',lout,iret) if (iret /= 0) then print '(/,a50,i4,/)','!!! ERROR: in open_grib_files, rc= ' & ,iret goto 890 endif endif endif call tracker (inp,maxstorm,numtcv,ifhmax,trkrinfo,ncfile & ,ncfile_id,netcdfinfo,ncfile_has_hour0 & ,ncfile_tmax,itret) c 890 continue igcret=0 iicret=0 iocret=0 inquire (unit=lugb, opened=file_open) if (file_open) call baclose(lugb,igcret) inquire (unit=lugi, opened=file_open) if (file_open) call baclose(lugi,iicret) inquire (unit=lout, opened=file_open) if (file_open) call baclose(lout,iocret) if ( verb .ge. 3 ) then print *,'baclose: igcret= ',igcret,' iicret= ',iicret print *,'baclose: iocret= ',iocret endif call w3tage('GETTRK ') c stop end c c--------------------------------------------------------------------- c c--------------------------------------------------------------------- subroutine tracker (inp,maxstorm,numtcv,ifhmax,trkrinfo,ncfile & ,ncfile_id,netcdfinfo,ncfile_has_hour0 & ,ncfile_tmax,itret) c c ABSTRACT: This subroutine is the core of the program. It contains c the main loop for looping through all the forecast hours and all c the storms. Basically, the way it works is that it has an outer c loop that loops on the forecast hour. At the beginning of this c loop, the data are read in for all parameters and levels needed c for tracking. The full regional or global grid is read in. c If vorticity was not read in (some of the centers do not send us c vorticity), then vorticity calculations are done on the whole c grid at both 850 and 700 mb. Then the program goes into the inner c loop, which loops on storm number (program originally set up to c handle a max of 15 storms). For each storm, subroutine c find_maxmin is called for the following parameters: Rel Vort and c geopotential hgt at 700 & 850 mb, and MSLP. Within find_maxmin, c a barnes analysis is performed over the guess position of the c storm to find the max or min value, and then iteratively, the c grid size is cut in half several times and the barnes analysis c rerun to refine the positioning of the max or min location. After c the center positions for these parameters have been obtained, c subroutine get_uv_center is called to get a center fix for the c minimum in the wind field, specifically, a minimum in the c magnitude of the wind speed (vmag). The calculation of the vmag c minimum is done differently than the calculation for the other c parameters; for vmag, the grid near the storm center guess c position is interpolated down to a very fine grid, and then c find_maxmin is called and a barnes analysis is done on that c smaller grid. For vmag, there are no further calls made to barnes c with a smaller grid, since the grid has already been interpolated c down to a smaller grid. Once all of the parameter center fixes c have been made, subroutine fixcenter is called to average these c positions together to get a best guess fix position. Then a check c is done with a call to subroutine is_it_a_storm to make sure that c the center that we have found does indeed resemble a tropical c cyclone. Finally, subroutine get_next_ges is called to make a c guess position for the next forecast time for this storm. c c INPUT: c inp contains input date and model number information c maxstorm maximum # of storms to be handled c numtcv number of storms read off of the tcvitals file c ifhmax max number of analysis & forecast times to be handled c trkrinfo derived type that holds/describes various tracker parms c ncfile if the input data type is netcdf, then this ncfile c variable contains the name of the netcdf file c ncfile_id if the input data type is netcdf, then this ncfile_id c variable contains an integer id assigned to the netcdf c file from the open_ncfile subroutine c ncfile_has_hour0 character flag (y|n) that, if the tracker is c running on NetCDF data, tells if the NetCDF file c actually contains hour0 data or not (some, like the c 2016 version of FV3, do not). c ncfile_tmax integer with max number of time levels in the input c NetCDF file, as read in from the NetCDF file itself in c subroutine read_netcdf_fhours. c c OUTPUT: c itret return code from this subroutine c c LOCAL PARAMETERS: c storm contains the tcvitals for the storms c stormswitch 1,2 or 3 (see more description under Main pgm section) c slonfg first guess array for longitude c slatfg first guess array for latitude c maxtime Max number of forecast times program can track c maxtp Max number of tracked parameters program will track. c Currently (7/2015), this maxtp is 11, and these 11 are c listed just a few lines below. c readflag L Indicates status of read for each of 16 parms: c 1: 850 mb absolute vorticity c 2: 700 mb absolute vorticity c 3: 850 mb u-comp c 4: 850 mb v-comp c 5: 700 mb u-comp c 6: 700 mb v-comp c 7: 850 mb gp hgt c 8: 700 mb gp hgt c 9: MSLP c 10: near-surface u-comp c 11: near-surface v-comp c 12: 500 mb u-comp c 13: 500 mb v-comp c 14: Mean temperature, centered at 400 mb c 15: 500 mb gp hgt c 16: 200 mb gp hgt c 17: Land-Sea Mask (for use in tcgen applications, and c even there, it's optional) c c calcparm L indicates which parms to track and which not to. c Array positions are defined exactly as for clon c and clat, listed next, except that, in general, when c flag 3 is set to a value, flag 4 is set to the same c value as 3, and when flag 5 is set to a value, flag c 6 is set to the same value as 5. This is because c 3 & 4 are for the 850 mb winds, and if either u or c v is missing, we obviously can't calculate the c magnitude of the wind. The same applies for 5 & 6, c which are for the 700 mb winds. And also for reference, c here is a list of all the variables & levels for the c tracked parameters (i.e., the "calcparm" elements): c c 1: 850 mb relative vorticity c 2: 700 mb relative vorticity c 3: 850 mb wind circulation difference c 4: NOT USED c 5: 700 mb wind circulation differenc c 6: NOT USED c 7: 850 mb geopotential height c 8: 700 mb geopotential height c 9: MSLP c 10: 10-m wind circulation difference c 11: 10-m relative vorticity c 12: 500-850 mb thickness (lower level) c 13: 200-500 mb thickness (upper level) c 14: 200-850 mb thickness (deep-layer) c c clon,clat: Holds the coordinates for the center positions for c all storms at all times for all parameters. c (max_#_storms, max_fcst_times, max_#_parms). c For the third position (max_#_parms), here they are: c 1: Relative vorticity at 850 mb c 2: Relative vorticity at 700 mb c 3: Wind circulation difference at 850 mb c 4: NOT CURRENTLY USED c 5: Wind circulation difference at 700 mb c 6: NOT CURRENTLY USED c 7: Geopotential height at 850 mb c 8: Geopotential height at 700 mb c 9: Mean Sea Level Pressure c 10: Wind circulation difference at 10 m c 11: Relative vorticity at 10 m c 12: Lower-level thickness (500-850) c 13: Upper-level thickness (200-500) c 14: Deep-Layer thickness (200-850) c c xmaxwind Contains maximum near-surface wind near the storm c center for each storm at each forecast hour. c stderr Standard deviation of the position "errors" of the c different parameters for each storm at each time. c fixlat,fixlon: Contain the final coordinates for each storm at c each forecast hour. These coordinates are a c weighted average of all the individual parameter c positions (hgt, zeta, mslp, vmag). c cvort_maxmin: Contains the characters 'max' or 'min', and is c used when calling the find_maxmin routine for the c relative vorticity (Look for max in NH, min in SH). c vradius Contains the distance from the storm fix position to c each of the various near-surface wind threshhold c distances in each quadrant. c (3,4) ==> (# of threshholds, # of quadrants) c See subroutine getradii for further details. c wfract_cov Fractional coverage (areal coverage) of winds c exceeding a certain threshold (34, 50, 64 kts) in c each quadrant. c (5,5,3) ==> (# of quadrants + 1, # of distance bins, c # of thresholds). c The "extra" array size for quadrants (5, instead of 4) c is there to hold the total (i.e., "whole disc") c statistics. c See subroutine get_fract_wind_cov for further details c c er_wind Quadrant winds in earth-relative framework c sr_wind Quadrant winds in storm-relative framework c er_vr Quadrant radial winds in earth-relative framework c sr_vr Quadrant radial winds in storm-relative framework c er_vt Quadrant tangential winds in earth-relative framework c sr_vt Quadrant tangential winds in storm-relative framework c c isastorm Character array used in the call to is_it_a_storm, c tells whether the minimum requirement for an MSLP c gradient was met (isastorm(1)), whether for the midlat c and tcgen cases if a closed mslp contour was found c (isastorm(2)), and if a circulation exists at 850 mb c (isastorm(3)). Can have a value of 'Y' (requirement c met), 'N' (requirement not met) or 'U' (requirement c undetermined, due to the fact that no center location c was found for this parameter). c maxmini These 2 arrays contain the i and j indeces for the c maxminj max/min centers that are found using the rough check c in first_ges_ctr and subsequent routines. Only needed c for a midlatitude or a genesis run, NOT needed for a c TC tracker run. c stormct Integer: keeps and increments a running tab of the c number of storms that have been tracked at any time c across all forecast hours. Used only for midlat or c tcgen runs. c gridprs This contains the actual value of the minimum pressure c at a gridpoint. The barnes analysis will return an c area-averaged value of pressure; this variable will c contain the actual minimum value at a gridpoint near c the lat/lon found by the barnes analysis. c closed_mslp_ctr_flag This flag keeps track of the value of the c closed contour flag returned from subroutine c check_closed_contour. c vt850_flag This flag keeps track of the value of the flag for c the 850 mb Vt check. c----- c USE def_vitals; USE inparms; USE tracked_parms; USE error_parms USE set_max_parms; USE level_parms; USE grid_bounds; USE trkrparms USE contours; USE atcf; USE radii; USE trig_vals; USE phase USE gen_vitals; USE structure; USE verbose_output USE waitfor_parms; USE module_waitfor; USE netcdf_parms USE tracking_parm_prefs c implicit none c type (datecard) inp type (trackstuff) trkrinfo type (netcdfstuff) netcdfinfo type (cint_stuff) contour_info c character, allocatable :: closed_mslp_ctr_flag(:,:)*1 character, allocatable :: vt850_flag(:,:)*1 character :: r34_check_okay*1,had_to_try_backup_850_vt_check*1 character :: need_to_expand_r34(4)*1,ncfile_has_hour0*1 character*(*), intent(in) :: ncfile integer :: ncfile_id integer, parameter :: nreadparms=17 real, allocatable :: prstemp(:),iwork(:) integer, parameter :: numdist=14,numquad=4,lout=51 integer, allocatable :: prsindex(:) integer imax,jmax,ifh,ist,irf,jj,istmp,ifhtemp,itret,ivpa integer isiret1,isiret2,isiret3,idum,m,iix,jjx,imode,numtcv integer iha,isa,iua,iva,iza,maxstorm,ivort,ifix,jfix,issret integer imoa,imoca,iksa,isda,ileadtime,leadtime_check integer ioaret,ioaxret,ifgcret,ifmret,igugret,isoiret,icccret integer igrret,igmwret,iorret,ignret,iovret,icbret,igucret,ita integer ifilret,ifret,iaret,isret,iotmret,iwa,iisa,sl_counter integer iicret,igcret,pfcret,igwcret,imbowret,iatret logical(1), allocatable :: valid_pt(:,:) logical(1), allocatable :: masked_outc(:,:),masked_out(:,:) logical(1) readflag(nreadparms),calcparm(maxtp,maxstorm) logical(1) tracking_previously_known_storms logical(1) need_to_flip_lats,need_to_flip_lons logical(1) file_open,first_time_thru_getradii character cvort_maxmin*3,isastorm(3)*1,ccflag*1,gotten_avg_value*1 character cmaxmin*3,get_last_isobar_flag*1,wcore_flag*1 character gfilename*120,ifilename*120,gridmove_status*7 integer vradius(3,4),igridzeta(nlevgrzeta),imeanzeta(nlevgrzeta) integer maxmini(maxstorm),maxminj(maxstorm),pdf_ct_bin(16) integer ifcsthour,stormct,prevstormct,kf,istmspd,istmdir,iggret integer igiret,iuret,jdum,icount,ilonfix,jlatfix,igpret,ifhmax integer ibeg,jbeg,iend,jend,ix1,ix2,n,ilev,npts,icpsa,igzvret integer igfwret,ioiret,igisret,iofwret,iowsret,igwsret,igscret integer pdf_ct_tot,lugb,lugi,iret,icmcf,iccfh,ivt8f integer waitfor_gfile_status,waitfor_ifile_status,ncfile_tmax integer wait_max_ifile_wait,ivr,r34_good_ct,itha,ilma,inctcv integer date_time(8) character (len=10) big_ben(3) real fixlon(maxstorm,maxtime),fixlat(maxstorm,maxtime) real gridprs(maxstorm,maxtime) real wfract_cov(5,5,3) real er_wind(numquad,numdist) real sr_wind(numquad,numdist) real er_vr(numquad,numdist) real er_vt(numquad,numdist) real sr_vr(numquad,numdist) real sr_vt(numquad,numdist) real ike(max_ike_cats) real clon(maxstorm,maxtime,maxtp) real clat(maxstorm,maxtime,maxtp) real xmaxwind(maxstorm,maxtime),xmeanzeta real stderr(maxstorm,maxtime),xval(maxtp),cps_vals(3) real gridpoint_maxmin,dist,distnm,xknots,xmaxspeed real uvgeslon,uvgeslat,xavg,stdv,search_cutoff,re,ri,dx,dy real xinp_fixlat,xinp_fixlon,degrees,plastbar,rlastbar real xinterval_fhr,cc_time_sum_tot,cc_time_sum_yes real rmax,sdp,wdp,paramb,vtl_slope,vtu_slope real xsfclon,xsfclat,cc_time_pct,radmax,r34_dist_thresh real prev_latmax,prev_latmin,prev_lonmax,prev_lonmin real vradius_km,hold_old_contint,tcv_max_wind_ms real tcv_mslp_pa,r34_from_tcv,roci_from_tcv real proci_from_tcv,prs_contint_thresh integer enable_timing,igrct character(pfc_cmd_len) :: pfc_final c prev_latmax = -999.0 prev_latmin = -999.0 prev_lonmax = -999.0 prev_lonmin = -999.0 enable_timing=trkrinfo%enable_timing icmcf = 0 ivt8f = 0 if (trkrinfo%type == 'midlat' .or. trkrinfo%type == 'tcgen') then allocate (closed_mslp_ctr_flag(maxstorm,ifhmax),stat=icmcf) allocate (vt850_flag(maxstorm,ifhmax),stat=ivt8f) ! Initialize flags to 'u', not 'n'. That way, ! when we are evaluating its value back over recent past hours, ! we can distinguish a "no" value from an initialized value of ! 'u' for which a storm hadn't yet been detected. closed_mslp_ctr_flag = 'u' vt850_flag = 'u' endif allocate (prsindex(maxstorm),stat=iisa) allocate (prstemp(maxstorm),stat=iva) allocate (iwork(maxstorm),stat=iwa) if (iisa /= 0 .or. iva /= 0 .or. iwa /= 0 .or. icmcf /= 0 .or. & ivt8f /= 0) then if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in sub tracker allocating prsindex,' print *,'!!! prstemp or iwork array for storms: iisa = ',iisa print *,'!!! iva= ',iva,' iwa= ',iwa,' icmcf= ',icmcf print *,'!!! ivt8f= ',ivt8f endif itret = 94 return endif ike = 0.0 sdp = 0.0 wdp = 0.0 clon = 0.0 clat = 0.0 stderr = stermn ! initialize stderr to 0.1 (error_parms) itret = 0 xmaxwind = 0.0 stormct = 0 ! It is critical to initialize the gridprs array to something ! greater than normal atmospheric pressures (I've chosen 9999.99 ! mb). This is so that in the sort on pressure before stormloop, ! the top of the sorting index array will be filled with pressure ! values from active storms, while those inactive 9999 storms ! will fill the bottom of the sorting index array (prsindex). gridprs = 999999.0 fixlon = -999.0 fixlat = -999.0 if (inp%file_seq == 'multi') then ! Each tau will have a separate file, starting with unit ! number 200 (GRIB data) and 5200 (GRIB index file) and ! incrementing upwards from there for each tau. if (trkrinfo%gribver == 1) then lugb = 200 c lugi = 5200 lugi = 600 ! 3/2017: w3lib on Jet cannot handle unit #'s >999 else lugb = 200 c lugi = 5200 lugi = 600 ! 3/2017: w3lib on Jet cannot handle unit #'s >999 endif else ! All lead times are included in one big file. These values ! for lugb and lugi will remain static for all taus. lugb = 11 lugi = 31 endif ifh = 1 if ( verb .ge. 3 ) then print *,'top of tracker, ifh= ',ifh,' ifhmax= ',ifhmax endif ifhloop: do while (ifh <= ifhmax) if ( verb .ge. 3 ) then print *,' ' print *,'*-------------------------------------------*' write (6,402) ifhours(ifh),ifclockmins(ifh) 402 format (1x,'* New forecast hour: ',i4,':',i2.2) print *,'*-------------------------------------------*' endif if (inp%file_seq == 'multi') then lugb = lugb + 1 lugi = lugi + 1 call get_grib_file_name (ifh,gfilename,ifilename) if (use_waitfor == 'y') then ! First check for existence of grib file.... call waitfor(trim(gfilename),waitfor_gfile_status & ,wait_min_age,wait_min_size,wait_max_wait & ,wait_sleeptime) if (waitfor_gfile_status /= 0) then print *,' ' write(6,405) write(6,406) wait_max_wait,trim(gfilename) 405 format('ERROR: TIMEOUT from waitfor for GRIB file.') 406 format('Waited longer than ',I0,' seconds for "',A,'"') stop 91 endif ! Now check for existence of index file. Use a separate ! max_wait time -- a much shorter one -- since once the ! grib file is there, the index file should appear within ! a matter of seconds. Also, the index file is much ! smaller, so set the wait_min_size accordingly. wait_max_ifile_wait = 180 wait_min_size = 500 call waitfor(trim(ifilename),waitfor_ifile_status & ,wait_min_age,wait_min_size,wait_max_ifile_wait & ,wait_sleeptime) if (waitfor_ifile_status /= 0) then print *,' ' write(6,415) write(6,416) wait_max_ifile_wait,trim(ifilename) 415 format('ERROR: TIMEOUT from waitfor for INDEX file.') 416 format('Waited longer than ',I0,' seconds for "',A,'"') stop 91 endif endif call open_grib_files (inp,lugb,lugi,gfilename,ifilename & ,lout,iret) if (iret /= 0) then print '(/,a50,i4,/)','!!! ERROR: from open_grib_files, rc= ' & ,iret print *,'!!! Files after hour0 are missing, ' & ,'exiting normally' stop 0 endif endif if (trkrinfo%inp_data_type == 'grib') then inquire (unit=lugb, opened=file_open) if (file_open) then print *,'TEST b4 getgridinfo, unit lugb= ',lugb,' is OPEN' else print *,'TEST b4 getgridinfo, unit lugb= ',lugb,' is CLOSED' endif inquire (unit=lugi, opened=file_open) if (file_open) then print *,'TEST b4 getgridinfo, unit lugi= ',lugi,' is OPEN' else print *,'TEST b4 getgridinfo, unit lugi= ',lugi,' is CLOSED' endif endif !-------------------------------------------------------------- ! Within this next IF statement, we deal with writing out atcf ! records for storms for the case in which we have netcdf data, ! but that netcdf data does not have hour0 data (as of Nov 2016, ! this is the case for FV3 data). In this case, we write out ! missing values for the hour0 time, and then we update the ! guess for next lead time by extrapolating data from TC Vitals. ! Note in the IF statement itself, "iftotalmins" is the array ! of *user-requested* lead times, meaning that the user has ! requested to look at hour0, but the ncfile_has_hour0 flag ! indicates the hour0 time is not in the NetCDF data. !-------------------------------------------------------------- if (ifh == 1 .and. iftotalmins(ifh) == 0 .and. & trkrinfo%inp_data_type == 'netcdf' .and. & ncfile_has_hour0 == 'n') then null_netcdf_hour0_storm_loop: do inctcv = 1,numtcv call output_atcfunix (-999.0 & ,-999.0,inp,inctcv & ,0,0.0 & ,0.0,vradius,maxstorm,trkrinfo & ,-99.0,-99.0,-99.0 & ,cps_vals,wcore_flag,ioaxret) imeanzeta = -99 igridzeta = -99 if (trkrinfo%type == 'midlat' .or. & trkrinfo%type == 'tcgen') then call output_atcf_gen (-999.0 & ,-999.0,inp,inctcv & ,0,0.0 & ,0.0,vradius,maxstorm,trkrinfo & ,-99,-99,-999.0,-999.0,-99.0 & ,cps_vals,'u',imeanzeta,igridzeta,ioaxret) endif call output_atcf_sink (-999.0 & ,-999.0,inp,inctcv & ,0,0.0 & ,0.0,vradius,maxstorm,trkrinfo & ,-99,-99,imeanzeta,igridzeta & ,cps_vals,-999.0,-999.0,ioaxret) call output_hfip (-999.0 & ,-999.0,inp,inctcv & ,ifh,0.0 & ,0.0,vradius,-99.0,ioaxret) if (verb .ge. 3) then print *,' ' print *,'++ NOTE: Even though a fix could not be' print *,' made for this storm at 00h, we will ' print *,' use the storm heading info from tc' print *,' vitals to create a guess for the next' print *,' lead time and attempt to track again' print *,' at that time.' print *,' ifh= ',ifh,' ist= ',inctcv write (6,431) storm(inctcv)%tcv_storm_id & ,storm(inctcv)%tcv_storm_name 431 format (1x,' storm_id = ',a4,' storm_name = ',a9) endif call advect_tcvitals_from_hour0 (slonfg,slatfg,maxstorm & ,inctcv,ifh,trkrinfo,iatret) if (iatret /= 0) then fixlon (inctcv,ifh) = -999.0 fixlat (inctcv,ifh) = -999.0 stormswitch(inctcv) = 2 cycle null_netcdf_hour0_storm_loop endif stormswitch(inctcv) = 1 enddo null_netcdf_hour0_storm_loop ifh = ifh + 1 cycle ifhloop endif !-------------------------------------------------------------- ! Make call to getgridinfo in order to get info on the imax, ! jmax, as well as the x- and y-increments, and also to see if ! the grid is correctly oriented for the tracker so that the ! data go north to south and west to east or if we need to flip ! either the lats or the lons. !-------------------------------------------------------------- if (trkrinfo%inp_data_type == 'grib') then call getgridinfo_grib (imax,jmax,ifh,dx,dy,lugb,lugi & ,trkrinfo,need_to_flip_lats,need_to_flip_lons & ,inp,iggret) elseif (trkrinfo%inp_data_type == 'netcdf') then call getgridinfo_netcdf (ncfile_id,imax,jmax,dx,dy & ,trkrinfo,need_to_flip_lats,need_to_flip_lons & ,inp,netcdfinfo,iggret) else print *,' ' print *,'!!! ERROR: trkrinfo%inp_data_type NOT VALID ' print *,'!!! trkrinfo%inp_data_type= ',trkrinfo%inp_data_type print *,'!!! Should have value of grib or netcdf.' print *,'!!! EXITING....' print *,' ' stop 93 endif if (iggret == 0) then if ( verb .ge. 1 ) then print *,'TEST after getgridinfo in sub tracker, ' & ,'iggret= ',iggret endif else if ( verb .ge. 1 ) then print '(/,a50,i4,/)','!!! ERROR: in getgridinfo, rc= ' & ,iggret endif stop 95 endif if (inp%modtyp == 'regional' .and. inp%nesttyp == 'moveable') & then if (glatmax == prev_latmax .and. glatmin == prev_latmin .and. & glonmax == prev_lonmax .and. glonmin == prev_lonmin) then ! The moveable, nested regional grid has not moved since ! the last lead time. This could be an indication that the ! model lost the storm and so the grid has not moved to ! stay with the cyclone center. Set a flag to indicate this. gridmove_status = 'stopped' else gridmove_status = 'moving' endif else gridmove_status = 'notappl' endif prev_latmax = glatmax prev_latmin = glatmin prev_lonmax = glonmax prev_lonmin = glonmin gotten_avg_value = 'n' c First, allocate the working data arrays.... if (allocated(valid_pt)) deallocate (valid_pt) if (allocated(zeta)) deallocate (zeta) if (allocated(u)) deallocate (u) if (allocated(v)) deallocate (v) if (allocated(hgt)) deallocate (hgt) if (allocated(slp)) deallocate (slp) if (allocated(tmean)) deallocate (tmean) if (allocated(cpshgt)) deallocate (cpshgt) if (allocated(thick)) deallocate (thick) if (allocated(lsmask)) deallocate (lsmask) if (allocated(masked_out)) deallocate (masked_out) if (allocated(masked_outc)) deallocate (masked_outc) ! Allocate all of the allocatable arrays.... allocate (valid_pt(imax,jmax),stat=ivpa) allocate (zeta(imax,jmax,nlevzeta),stat=iza) allocate (u(imax,jmax,nlevs),stat=iua) allocate (v(imax,jmax,nlevs),stat=iva) allocate (hgt(imax,jmax,nlevhgt),stat=iha) allocate (slp(imax,jmax),stat=isa) allocate (tmean(imax,jmax),stat=ita) allocate (thick(imax,jmax,nlevthick),stat=itha) allocate (lsmask(imax,jmax),stat=ilma) allocate (masked_out(imax,jmax),stat=imoa) allocate (masked_outc(imax,jmax),stat=imoca) ita=0 icpsa=0 if (phaseflag == 'y') then if (phasescheme == 'cps' .or. phasescheme == 'both') then if (allocated(cpshgt)) deallocate (cpshgt) allocate (cpshgt(imax,jmax,nlevs_cps),stat=icpsa) endif endif if (iza /= 0 .or. iua /= 0 .or. iha /= 0 .or. ivpa /= 0 .or. & iva /= 0 .or. isa /= 0 .or. icpsa /= 0 .or. ita /= 0 .or. & itha /= 0 .or. imoa /= 0 .or. imoca /= 0 .or. ilma /= 0) & then if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in sub tracker allocating arrays.' print *,'!!! iza = ',iza,' iua= ',iua,' iha= ',iha print *,'!!! iva = ',iva,' isa= ',isa,' icpsa= ',icpsa print *,'!!! iksa = ',iksa,' isda= ',isda,' ivpa= ',ivpa print *,'!!! ita = ',ita,' imoa= ',imoa,' imoca= ',imoca print *,'!!! itha = ',itha,' ilma= ',ilma endif itret = 94 return endif masked_out = .false. ! Initialize all pts to false at each hr masked_outc = .false. ! Initialize all pts to false at each hr if ( verb .ge. 3 ) then print *,'in beginning of tracker, imax= ',imax,' jmax= ',jmax endif c Initialize all readflags to NOT FOUND for this forecast time, c then call subroutine to read data for this forecast time. zeta = -9999.0 u = -9999.0 hgt = -9999.0 v = -9999.0 slp = -9999.0 tmean = -9999.0 readflag = .FALSE. if(enable_timing/=0) then call date_and_time (big_ben(1),big_ben(2),big_ben(3),date_time) write (6,31) date_time(5),date_time(6),date_time(7) 31 format (1x,'TIMING: b4 getdata ... ',i2.2,':',i2.2,':',i2.2) endif if (trkrinfo%inp_data_type == 'grib') then call getdata_grib (readflag,valid_pt,imax,jmax & ,ifh,need_to_flip_lats,need_to_flip_lons,inp & ,lugb,lugi,trkrinfo) elseif (trkrinfo%inp_data_type == 'netcdf') then call getdata_netcdf (ncfile_id,readflag,valid_pt,imax,jmax & ,ifh,need_to_flip_lats,need_to_flip_lons & ,ncfile_tmax,netcdfinfo) endif if(enable_timing/=0) then call date_and_time (big_ben(1),big_ben(2),big_ben(3),date_time) write (6,32) date_time(5),date_time(6),date_time(7) 32 format (1x,'TIMING: after getdata ... ',i2.2,':',i2.2,':',i2.2) endif c Count how many parms were successfully read for this fcst time. c Also, for right now, put the value of readflag into all of the c calcparms for parameters 3 through 9. Note that in getdata we c read in 17 parms, but in this next loop we only check the c readflags up to maxtp (= 14 as of 7/2015). That's because c parms 12 & 13 are for 500 mb u & v, which are not used for c tracking, only for calculating the deep layer mean wind for c the next guess, and parm 14 is the 300-500 mb mean temperature, c which is used for determining storm phase. Parms 10 & 11 are c for the near-surface winds, which are used in estimating surface c winds near the storm, and will now also be used as a c parameter for position estimates. Finally, parm 17 is the c land-sea mask, which is not used as a tracking parm. idum = 0 do irf = 1,nreadparms if (readflag(irf)) idum = idum + 1 if (irf > 2 .and. irf < 10) then ! calcparm for parms > 9 is done further below. do jj=1,maxstorm calcparm(irf,jj) = readflag(irf) enddo endif enddo if ( verb .ge. 3 ) then print *,' ' print *,'Of ',nreadparms,' readable parms, you read in ',idum print *,'parms for this fcst hour from the input grib file.' endif c If not enough tracked parms were read in, exit the program.... if (idum == 0) then if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in subroutine tracker' print *,'!!! Not enough tracked parms read in from getdata.' print *,'!!! Check for a problem with the input GRIB file.' print *,'!!! Model identifier = ',inp%model print *,'!!! STOPPING EXECUTION FOR THIS MODEL' endif itret = 99 ifhtemp = ifh do while (ifhtemp <= ifhmax) do istmp=1,maxstorm fixlon (istmp,ifhtemp) = -999.0 fixlat (istmp,ifhtemp) = -999.0 enddo ifhtemp = ifhtemp + 1 enddo cPENG call output_all (fixlon,fixlat,inp,maxstorm,ifhmax,ioaret) cPENG call output_atcf (fixlon,fixlat,inp,xmaxwind,maxstorm,ifhmax cPENG & ,ioaret) if (ifh == 1) then ! Per Jim Gross (1/01), if the tracker ran but was unable ! to get an initial fix (or, in this case, unable to get ! the data needed to run), write out zeroes for the 00h ! fixes to indicate that the tracker ran unsuccessfully, ! but don't write out any subsequent forecast times ! with zeroes.... vradius = 0 cps_vals(1) = -9999.0 cps_vals(2) = -9999.0 cps_vals(3) = -9999.0 wcore_flag = 'u' ! 'u' = initial value of 'undetermined' do istmp = 1,maxstorm if (stormswitch(istmp) /= 3) then ileadtime = nint(fhreal(ifh) * 100.0) ifcsthour = ileadtime / 100 call output_atcfunix (-999.0,-999.0,inp,istmp & ,ifcsthour,0.0,0.0,vradius,maxstorm & ,trkrinfo,-99.0,-99.0,-99.0,cps_vals & ,wcore_flag,ioaxret) call output_hfip (-999.0,-999.0,inp,istmp & ,ifh,0.0,0.0,vradius,-99.0,ioaxret) endif enddo endif return endif c 1: 850 mb relative vorticity c 2: 700 mb relative vorticity c 3: 850 mb wind circulation difference c 4: NOT USED c 5: 700 mb wind circulation differenc c 6: NOT USED c 7: 850 mb geopotential height c 8: 700 mb geopotential height c 9: MSLP c 10: 10-m wind circulation difference c 11: 10-m relative vorticity c 12: 500-850 mb thickness (lower level) c 13: 200-500 mb thickness (upper level) c 14: 200-850 mb thickness (deep-layer) c Check the flags that were read in from the namelist for c determining which parameters the user wants to track. c Here, check for z850, z700 and mslp.... if (user_wants_to_track_gph850 == 'n' .or. & user_wants_to_track_gph850 == 'N') then do jj=1,maxstorm calcparm(7,jj) = .FALSE. enddo endif if (user_wants_to_track_gph700 == 'n' .or. & user_wants_to_track_gph700 == 'N') then do jj=1,maxstorm calcparm(8,jj) = .FALSE. enddo endif if (user_wants_to_track_mslp == 'n' .or. & user_wants_to_track_mslp == 'N') then do jj=1,maxstorm calcparm(9,jj) = .FALSE. enddo endif c Parameters 1 & 2 are abs vorticity at 850 & 700. If the data c files had this parm at 850 & 700 (ECMWF & UKMET do NOT), then c we don't need to re-calculate relative vorticity, we just need c to subtract out the Coriolis component. If the files did not c have vorticity, then we need to calculate relative vorticity. c If we're able to read vorticity or calculate it, then set the c vorticity calcparms to TRUE for all storms for now. vortloop: do ivort=1,2 if (ivort == 1) then if (user_wants_to_track_zeta850 == 'n' .or. & user_wants_to_track_zeta850 == 'N') then do jj=1,maxstorm calcparm(1,jj) = .FALSE. enddo cycle vortloop endif endif if (ivort == 2) then if (user_wants_to_track_zeta700 == 'n' .or. & user_wants_to_track_zeta700 == 'N') then do jj=1,maxstorm calcparm(2,jj) = .FALSE. enddo cycle vortloop endif endif if (readflag(ivort)) then call subtract_cor (imax,jmax,dy,ivort) do jj=1,maxstorm calcparm(ivort,jj) = .TRUE. enddo else if (ivort == 1) then if (readflag(3) .and. readflag(4)) then call rvcal (imax,jmax,dx,dy,ivort,valid_pt) do jj=1,maxstorm calcparm(1,jj) = .TRUE. enddo else do jj=1,maxstorm calcparm(1,jj) = .FALSE. enddo endif else if (readflag(5) .and. readflag(6)) then call rvcal (imax,jmax,dx,dy,ivort,valid_pt) do jj=1,maxstorm calcparm(2,jj) = .TRUE. enddo else do jj=1,maxstorm calcparm(2,jj) = .FALSE. enddo endif endif endif enddo vortloop c Check the flags that were read in from the namelist for c determining which parameters the user wants to track. c Here, check for user preferences for the wind circulation c difference at 850 & 700... if (readflag(3) .and. readflag(4)) then if (user_wants_to_track_wcirc850 == 'n' .or. & user_wants_to_track_wcirc850 == 'N') then do jj=1,maxstorm calcparm(3,jj) = .FALSE. enddo else do jj=1,maxstorm calcparm(3,jj) = .TRUE. enddo endif else do jj=1,maxstorm calcparm(3,jj) = .FALSE. enddo endif if (readflag(5) .and. readflag(6)) then if (user_wants_to_track_wcirc700 == 'n' .or. & user_wants_to_track_wcirc700 == 'N') then do jj=1,maxstorm calcparm(5,jj) = .FALSE. enddo else do jj=1,maxstorm calcparm(5,jj) = .TRUE. enddo endif else do jj=1,maxstorm calcparm(5,jj) = .FALSE. enddo endif c Compute the sfc vorticity if sfc_u and sfc_v have been read in. if (readflag(10) .and. readflag(11)) then if (user_wants_to_track_wcircsfc == 'n' .or. & user_wants_to_track_wcircsfc == 'N') then do jj=1,maxstorm calcparm(10,jj) = .FALSE. enddo else do jj=1,maxstorm calcparm(10,jj) = .TRUE. enddo endif if (user_wants_to_track_zetasfc == 'n' .or. & user_wants_to_track_zetasfc == 'N') then do jj=1,maxstorm calcparm(11,jj) = .FALSE. enddo else ! The 3 in the next call to rvcal is to indicate the 3rd ! level for the zeta array, which is for the surface (or ! 10m) data. call rvcal (imax,jmax,dx,dy,3,valid_pt) do jj=1,maxstorm calcparm(11,jj) = .TRUE. enddo endif else do jj=1,maxstorm calcparm(10,jj) = .FALSE. calcparm(11,jj) = .FALSE. enddo endif c Compute the thicknesses for 200-850, 200-500 and 500-850 mb c if the gp hgt fields have been read in for 200, 500 and 850. if (readflag(7) .and. readflag(15) .and. readflag(16)) then call thickness_calc (imax,jmax,valid_pt) do jj=1,maxstorm if (user_wants_to_track_thick500850 == 'n' .or. & user_wants_to_track_thick500850 == 'N') then calcparm(12,jj) = .FALSE. else calcparm(12,jj) = .TRUE. endif if (user_wants_to_track_thick200500 == 'n' .or. & user_wants_to_track_thick200500 == 'N') then calcparm(13,jj) = .FALSE. else calcparm(13,jj) = .TRUE. endif if (user_wants_to_track_thick200850 == 'n' .or. & user_wants_to_track_thick200850 == 'N') then calcparm(14,jj) = .FALSE. else calcparm(14,jj) = .TRUE. endif enddo else if (verb .ge. 3) then print *,' ' print *,'NOTE: Thickness will not be tracked since at least' print *,'one of the gp height fields was not read in.' print *,' readflag(7) -- 850 mb ---> ',readflag(7) print *,' readflag(15) -- 500 mb ---> ',readflag(15) print *,' readflag(16) -- 200 mb ---> ',readflag(16) print *,' ' endif do jj=1,maxstorm calcparm(12,jj) = .FALSE. calcparm(13,jj) = .FALSE. calcparm(14,jj) = .FALSE. enddo endif c --------------------------------------------------------------- c Now call find_maxmin for the variables zeta, hgt and slp. Only c process those storms for which stormswitch is set to 1. If a c storm is selected to be processed, we still have to check the c calcparm for each parameter, to make sure that the particular c parm exists at that level and is able to be processed. c c The following commented-out data statements are just included c as a reference so you can see the array positioning of the c different parameters and levels that are read in: c c data igparm /41,41,33,34,33,34,7,7,2,33,34,33,34,11,7,7/ c data iglevtyp /100,100,100,100,100,100,100,100,102,sfc,sfc c ,100,100,100,100,100/ c data iglev /850,700,850,850,700,700,850,700,0,sfc,sfc c ,500,500,400,500,200/ c c And also for reference, here are the variables / levels for c the *tracked* parameters (i.e., the "calcparm" elements): c c 1: 850 mb relative vorticity c 2: 700 mb relative vorticity c 3: 850 mb wind circulation difference c 4: NOT USED c 5: 700 mb wind circulation differenc c 6: NOT USED c 7: 850 mb geopotential height c 8: 700 mb geopotential height c 9: MSLP c 10: 10-m wind circulation difference c 11: 10-m relative vorticity c 12: 500-850 mb thickness (lower level) c 13: 200-500 mb thickness (upper level) c 14: 200-850 mb thickness (deep-layer) c c NOTE: For mid-latitude cases, we will track ONLY mslp, which c is why we set all the other calcparms to 'false' just below. if (trkrinfo%type == 'midlat') then do m = 1,maxstorm calcparm(1,m) = .false. calcparm(2,m) = .false. calcparm(3,m) = .false. calcparm(4,m) = .false. calcparm(5,m) = .false. calcparm(6,m) = .false. calcparm(7,m) = .false. calcparm(8,m) = .false. calcparm(10,m) = .false. calcparm(11,m) = .false. calcparm(12,m) = .false. calcparm(13,m) = .false. calcparm(14,m) = .false. enddo endif if (trkrinfo%type == 'midlat' .or. trkrinfo%type == 'tcgen') & then call sort_storms_by_pressure (gridprs,ifh,maxstorm,prsindex & ,issret) if ( (ifh == 1) .or. & (ifh == 2 .and. trkrinfo%inp_data_type == 'netcdf' .and. & ncfile_has_hour0 == 'n') ) then stormct = numtcv endif endif prevstormct = stormct tracking_previously_known_storms = .true. stormloop: do sl_counter = 1,maxstorm cps_vals(1) = -9999.0 cps_vals(2) = -9999.0 cps_vals(3) = -9999.0 wcore_flag = 'u' ! 'u' = initialized value of 'undetermined' if (trkrinfo%type == 'midlat' .or. trkrinfo%type == 'tcgen') & then ist = prsindex(sl_counter) else ist = sl_counter endif if (trkrinfo%type == 'midlat' .or. trkrinfo%type == 'tcgen') & then if (ist == (prevstormct + 1)) then ! For the mid-latitude and tropical cyclogenesis cases, we ! need to scan the mslp field to find new storms. If we ! are at this point inside the if statement in stormloop, ! then that means we have looped through and attempted to ! track all storms that have already been found up to this ! point in the forecast, and we need to scan the field for ! any new storms at this forecast hour. If this is for ! forecast hour = 0, then right off the bat we may be ! scanning the field (if there were no tcvitals records ! read in for this forecast), since ist = 1 and ! (prevstormct + 1) = 0 + 1 = 1. All that the call just ! below to first_ges_center does is return a rough idea ! of the location of new lows; more specific locations are ! obtained through the barnes analysis tracking algorithm ! further below. if (readflag(9)) then if (ifh > 1) then ! We need the use of 2 different masks. One ! (masked_out) is to be used when looking for new lows, ! so that after we find a new low, we mask out the ! surrounding area so we don't find it on a subsequent ! search for this forecast hour. The other ! (masked_outc) is used in the routine to check for a ! closed contour. If checking for a closed contour ! at, say 70W/25N, this and surrounding points may have ! already been masked out in first_ges_center, so "N" ! would misleadingly/incorrectly be returned from ! check_closed_contour, so that is why we need 2 masks. ! But now after the first forecast hour (t=0), the way ! we have this set up is that we track previously known ! storms first, and once we're done with them, we ! search for new storms at that same forecast hour. ! But when looking for new storms, we need to know the ! positions of the previously tracked storms at this ! current forecast hour, so we copy the masked_outc ! array to masked_out in this case.... masked_out = masked_outc endif call first_ges_center (imax,jmax,dx,dy,'mslp',slp & ,'min',trkrinfo,ifh,valid_pt,maxstorm,masked_out & ,stormct,contour_info,maxmini,maxminj,ifgcret) tracking_previously_known_storms = .false. else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: In subroutine tracker, readflag' print *,'!!! for mslp indicates that the mslp data' print *,'!!! is not available for this forecast ' print *,'!!! hour, and it is needed for a "midlat"' print *,'!!! or "tcgen" run of the tracker. ' print *,'!!! We will exit....' print *,'!!! readflag(9) = ',readflag(9) print *,'!!! ifh= ',ifh print *,' ' endif itret = 98 return endif endif endif xval = 0.0 ! initialize entire xval array to 0 isastorm = 'U' ! re-initialize flag for each time, each storm select case (stormswitch(ist)) case (1) vradius = 0 if ( verb .ge. 2 ) then print *,' ---------------------------------------------' print *,' | *** TOP OF STORM LOOP *** ' print *,' | Beginning of storm loop in tracker for' print *,' | Storm number ',ist write (6,418) ifhours(ifh),ifclockmins(ifh) 418 format (1x,' | Forecast hour: ',i4,':',i2.2) print *,' | Storm name = ',storm(ist)%tcv_storm_name print *,' | Storm ID = ',storm(ist)%tcv_storm_id write (6,420) gstorm(ist)%gv_gen_date & ,gstorm(ist)%gv_gen_fhr & ,gstorm(ist)%gv_gen_lat & ,gstorm(ist)%gv_gen_latns,gstorm(ist)%gv_gen_lon & ,gstorm(ist)%gv_gen_lonew,gstorm(ist)%gv_gen_type print *,' ---------------------------------------------' print *,' ' 420 format (' | Gen ID (if available): ',i10.10,'_F',i3.3 & ,'_',i3.3,a1,'_',i4.4,a1,'_',a3) endif c First, make sure storm is within the grid boundaries... call check_bounds (slonfg(ist,ifh),slatfg(ist,ifh),ist,ifh & ,trkrinfo,icbret) if (icbret == 95) then ! Out of regional grid bounds fixlon (ist,ifh) = -999.0 fixlat (ist,ifh) = -999.0 stormswitch(ist) = 2 cycle stormloop endif if (slatfg(ist,ifh) > 0.0) then cvort_maxmin = 'max' else cvort_maxmin = 'min' endif if (calcparm(1,ist)) then if ( verb .ge. 3 ) then print *,' ' print *,' --- --- ---' print *,'Now calling find_maxmin for zeta at 850 mb' endif call find_maxmin (imax,jmax,dx,dy,'zeta' & ,zeta(1,1,1),cvort_maxmin,ist,slonfg(ist,ifh) & ,slatfg(ist,ifh),glon,glat,valid_pt,trkrinfo & ,calcparm(1,ist),clon(ist,ifh,1),clat(ist,ifh,1) & ,xval(1),glatmax,glatmin,glonmax,glonmin & ,inp%modtyp,ifmret) if (ifmret /= 0) then ! Out of regional grid bounds fixlon (ist,ifh) = -999.0 fixlat (ist,ifh) = -999.0 stormswitch(ist) = 2 cycle stormloop endif endif if (calcparm(2,ist)) then if ( verb .ge. 3 ) then print *,' ' print *,' --- --- ---' print *,'Now calling find_maxmin for zeta at 700 mb' endif call find_maxmin (imax,jmax,dx,dy,'zeta' & ,zeta(1,1,2),cvort_maxmin,ist,slonfg(ist,ifh) & ,slatfg(ist,ifh),glon,glat,valid_pt,trkrinfo & ,calcparm(2,ist),clon(ist,ifh,2),clat(ist,ifh,2) & ,xval(2),glatmax,glatmin,glonmax,glonmin & ,inp%modtyp,ifmret) if (ifmret /= 0) then ! Out of regional grid bounds fixlon (ist,ifh) = -999.0 fixlat (ist,ifh) = -999.0 stormswitch(ist) = 2 cycle stormloop endif endif if (calcparm(7,ist)) then if ( verb .ge. 3 ) then print *,' ' print *,' --- --- ---' print *,'Now calling find_maxmin for hgt at 850 mb' endif call find_maxmin (imax,jmax,dx,dy,'hgt' & ,hgt(1,1,1),'min',ist,slonfg(ist,ifh),slatfg(ist,ifh) & ,glon,glat,valid_pt,trkrinfo,calcparm(7,ist) & ,clon(ist,ifh,7),clat(ist,ifh,7),xval(7) & ,glatmax,glatmin,glonmax,glonmin & ,inp%modtyp,ifmret) if (ifmret /= 0) then ! Out of regional grid bounds fixlon (ist,ifh) = -999.0 fixlat (ist,ifh) = -999.0 stormswitch(ist) = 2 cycle stormloop endif endif if (calcparm(8,ist)) then if ( verb .ge. 3 ) then print *,' ' print *,' --- --- ---' print *,'Now calling find_maxmin for hgt at 700 mb' endif call find_maxmin (imax,jmax,dx,dy,'hgt' & ,hgt(1,1,2),'min',ist,slonfg(ist,ifh),slatfg(ist,ifh) & ,glon,glat,valid_pt,trkrinfo,calcparm(8,ist) & ,clon(ist,ifh,8),clat(ist,ifh,8),xval(8) & ,glatmax,glatmin,glonmax,glonmin & ,inp%modtyp,ifmret) if (ifmret /= 0) then ! Out of regional grid bounds fixlon (ist,ifh) = -999.0 fixlat (ist,ifh) = -999.0 stormswitch(ist) = 2 cycle stormloop endif endif if (calcparm(9,ist)) then if ( verb .ge. 3 ) then print *,' ' print *,' --- --- ---' print *,'Now calling find_maxmin for mslp' endif call find_maxmin (imax,jmax,dx,dy,'slp' & ,slp,'min',ist,slonfg(ist,ifh),slatfg(ist,ifh) & ,glon,glat,valid_pt,trkrinfo,calcparm(9,ist) & ,clon(ist,ifh,9),clat(ist,ifh,9),xval(9) & ,glatmax,glatmin,glonmax,glonmin & ,inp%modtyp,ifmret) if (ifmret /= 0) then ! Out of regional grid bounds fixlon (ist,ifh) = -999.0 fixlat (ist,ifh) = -999.0 stormswitch(ist) = 2 cycle stormloop endif endif if (calcparm(11,ist)) then if ( verb .ge. 3 ) then print *,' ' print *,' --- --- ---' print *,'Now calling find_maxmin for sfc zeta' endif call find_maxmin (imax,jmax,dx,dy,'zeta' & ,zeta(1,1,3),cvort_maxmin,ist,slonfg(ist,ifh) & ,slatfg(ist,ifh),glon,glat,valid_pt,trkrinfo & ,calcparm(11,ist),clon(ist,ifh,11),clat(ist,ifh,11) & ,xval(11),glatmax,glatmin,glonmax,glonmin & ,inp%modtyp,ifmret) if (ifmret /= 0) then ! Out of regional grid bounds fixlon (ist,ifh) = -999.0 fixlat (ist,ifh) = -999.0 stormswitch(ist) = 2 cycle stormloop endif endif c The array indices for the 3 different thickness layers are c as follows: c 1: 500-850 c 2: 200-500 c 3: 200-850 if (calcparm(12,ist)) then if ( verb .ge. 3 ) then print *,' ' print *,' --- --- ---' print *,'Now calling find_maxmin for thickness in' print *,'the 500-850 mb layer.' endif call find_maxmin (imax,jmax,dx,dy,'thick' & ,thick(1,1,1),'max',ist,slonfg(ist,ifh),slatfg(ist,ifh) & ,glon,glat,valid_pt,trkrinfo,calcparm(12,ist) & ,clon(ist,ifh,12),clat(ist,ifh,12),xval(12) & ,glatmax,glatmin,glonmax,glonmin & ,inp%modtyp,ifmret) if (ifmret /= 0) then ! Out of regional grid bounds fixlon (ist,ifh) = -999.0 fixlat (ist,ifh) = -999.0 stormswitch(ist) = 2 cycle stormloop endif endif if (calcparm(13,ist)) then if ( verb .ge. 3 ) then print *,' ' print *,' --- --- ---' print *,'Now calling find_maxmin for thickness in' print *,'the 200-500 mb layer.' endif call find_maxmin (imax,jmax,dx,dy,'thick' & ,thick(1,1,2),'max',ist,slonfg(ist,ifh),slatfg(ist,ifh) & ,glon,glat,valid_pt,trkrinfo,calcparm(13,ist) & ,clon(ist,ifh,13),clat(ist,ifh,13),xval(13) & ,glatmax,glatmin,glonmax,glonmin & ,inp%modtyp,ifmret) if (ifmret /= 0) then ! Out of regional grid bounds fixlon (ist,ifh) = -999.0 fixlat (ist,ifh) = -999.0 stormswitch(ist) = 2 cycle stormloop endif endif if (calcparm(14,ist)) then if ( verb .ge. 3 ) then print *,' ' print *,' --- --- ---' print *,'Now calling find_maxmin for thickness in' print *,'the 200-850 mb layer.' endif call find_maxmin (imax,jmax,dx,dy,'thick' & ,thick(1,1,3),'max',ist,slonfg(ist,ifh),slatfg(ist,ifh) & ,glon,glat,valid_pt,trkrinfo,calcparm(14,ist) & ,clon(ist,ifh,14),clat(ist,ifh,14),xval(14) & ,glatmax,glatmin,glonmax,glonmin & ,inp%modtyp,ifmret) if (ifmret /= 0) then ! Out of regional grid bounds fixlon (ist,ifh) = -999.0 fixlat (ist,ifh) = -999.0 stormswitch(ist) = 2 cycle stormloop endif endif c Now get centers for wind circulation at 700 & 850 mb and c at 10m. First, get a modified guess lat/lon position for c wind circulation. Do this because we will be searching c for this wind circulation center over a smaller area and c so it's more crucial to have a better first guess position. c This modified guess position will be an average of the first c guess position for this time and the fix positions for this c time from some of the other parameters. if (slatfg(ist,ifh) >= 0.0) then cmaxmin = 'max' else cmaxmin = 'min' endif if (calcparm(3,ist) .and. calcparm(4,ist)) then call get_uv_guess (slonfg(ist,ifh),slatfg(ist,ifh) & ,clon,clat,calcparm,ist,ifh,maxstorm & ,uvgeslon,uvgeslat,igugret) if (igugret == 0) then if ( verb .ge. 3 ) then print *,' ' print *,' --- --- ---' print *,'Now calling get_wind_circulation for 850 mb ' endif print *,' ' print *,'Before first call to get_wind_circulation, ' print *,' glatmax= ',glatmax print *,' glatmin= ',glatmin print *,' glonmax= ',glonmax print *,' glonmin= ',glonmin print *,' trkrinfo%gridtype= ',trkrinfo%gridtype print *,' inp%modtyp= ',inp%modtyp print *,' cmaxmin= ',cmaxmin print *,' nlev850= ',nlev850 print *,' u(1,1,nlev850)= ',u(1,1,nlev850) print *,' u(imax,jmax,nlev850)= ',u(imax,jmax,nlev850) print *,' imax= ',imax,' jmax= ',jmax print *,' uvgeslon= ',uvgeslon,' uvgeslat= ',uvgeslat print *,' dx= ',dx,' dy= ',dy,' ist= ',ist print *,' calcparm(3,ist)= ',calcparm(3,ist) print *,' clon(ist,ifh,3)= ',clon(ist,ifh,3) print *,' clat(ist,ifh,3)= ',clat(ist,ifh,3) print *,' xval(3)= ',xval(3) if (enable_timing/=0) then call date_and_time (big_ben(1),big_ben(2),big_ben(3) & ,date_time) write (6,141) date_time(5),date_time(6),date_time(7) 141 format (1x,'TIMING: Before GWC 850 ... ',i2.2,':',i2.2 & ,':',i2.2) endif call get_wind_circulation (uvgeslon,uvgeslat,imax,jmax & ,dx,dy,ist,850,valid_pt,calcparm(3,ist) & ,clon(ist,ifh,3),clat(ist,ifh,3),xval(3),trkrinfo & ,inp%modtyp,cmaxmin,igwcret) if (enable_timing/=0) then call date_and_time (big_ben(1),big_ben(2),big_ben(3) & ,date_time) write (6,142) date_time(5),date_time(6),date_time(7) 142 format (1x,'TIMING: After GWC 850 ... ',i2.2,':',i2.2 & ,':',i2.2) endif c call get_uv_center (uvgeslon,uvgeslat,imax,jmax,dx,dy c & ,ist,850,valid_pt,calcparm(3,ist) c & ,clon(ist,ifh,3),clat(ist,ifh,3),xval(3),trkrinfo c & ,igucret) if (igwcret /= 0) then calcparm(3,ist) = .FALSE. calcparm(4,ist) = .FALSE. endif else calcparm(3,ist) = .FALSE. calcparm(4,ist) = .FALSE. clon(ist,ifh,3) = 0.0 clat(ist,ifh,3) = 0.0 endif endif if (calcparm(5,ist).and. calcparm(6,ist)) then call get_uv_guess (slonfg(ist,ifh),slatfg(ist,ifh) & ,clon,clat,calcparm,ist,ifh,maxstorm & ,uvgeslon,uvgeslat,igugret) if (igugret == 0) then if ( verb .ge. 3 ) then print *,' ' print *,' --- --- ---' print *,'Now calling get_wind_circulation for 700 mb ' endif if (enable_timing/=0) then call date_and_time (big_ben(1),big_ben(2),big_ben(3) & ,date_time) write (6,143) date_time(5),date_time(6),date_time(7) 143 format (1x,'TIMING: Before GWC 700 ... ',i2.2,':',i2.2 & ,':',i2.2) endif call get_wind_circulation (uvgeslon,uvgeslat,imax,jmax & ,dx,dy,ist,700,valid_pt,calcparm(5,ist) & ,clon(ist,ifh,5),clat(ist,ifh,5),xval(5),trkrinfo & ,inp%modtyp,cmaxmin,igwcret) if (enable_timing/=0) then call date_and_time (big_ben(1),big_ben(2),big_ben(3) & ,date_time) write (6,144) date_time(5),date_time(6),date_time(7) 144 format (1x,'TIMING: After GWC 700 ... ',i2.2,':',i2.2 & ,':',i2.2) endif c call get_uv_center (uvgeslon,uvgeslat,imax,jmax,dx,dy c & ,ist,700,valid_pt,calcparm(5,ist) c & ,clon(ist,ifh,5),clat(ist,ifh,5),xval(5),trkrinfo c & ,igucret) if (igwcret /= 0) then calcparm(5,ist) = .FALSE. calcparm(6,ist) = .FALSE. endif else calcparm(5,ist) = .FALSE. calcparm(6,ist) = .FALSE. clon(ist,ifh,5) = 0.0 clat(ist,ifh,5) = 0.0 endif endif if (calcparm(10,ist)) then call get_uv_guess (slonfg(ist,ifh),slatfg(ist,ifh) & ,clon,clat,calcparm,ist,ifh,maxstorm & ,uvgeslon,uvgeslat,igugret) if (igugret == 0) then if ( verb .ge. 3 ) then print *,' ' print *,' --- --- ---' print *,'Now calling get_wind_circulation for the' print *,'surface (10m) level' endif ! NOTE: The 1020 in the call here is just a number/code ! to indicate to the subroutine to process sfc winds. if (enable_timing/=0) then call date_and_time (big_ben(1),big_ben(2),big_ben(3) & ,date_time) write (6,145) date_time(5),date_time(6),date_time(7) 145 format (1x,'TIMING: Before GWC Sfc ... ',i2.2,':',i2.2 & ,':',i2.2) endif call get_wind_circulation (uvgeslon,uvgeslat,imax,jmax & ,dx,dy,ist,1020,valid_pt,calcparm(10,ist) & ,clon(ist,ifh,10),clat(ist,ifh,10),xval(10) & ,trkrinfo,inp%modtyp,cmaxmin,igwcret) if (enable_timing/=0) then call date_and_time (big_ben(1),big_ben(2),big_ben(3) & ,date_time) write (6,146) date_time(5),date_time(6),date_time(7) 146 format (1x,'TIMING: After GWC Sfc ... ',i2.2,':',i2.2 & ,':',i2.2) endif c call get_uv_center (uvgeslon,uvgeslat,imax,jmax,dx,dy c & ,ist,1020,valid_pt,calcparm(10,ist) c & ,clon(ist,ifh,10),clat(ist,ifh,10),xval(10) c & ,trkrinfo,igucret) if (igwcret /= 0) then calcparm(10,ist) = .FALSE. endif else calcparm(10,ist) = .FALSE. clon(ist,ifh,10) = 0.0 clat(ist,ifh,10) = 0.0 endif endif c ------------------------------------------------------ c All of the parameter center fixes have been done. Now c average those positions together to get the best guess c fix position. If a center fix is able to be made, then c call subroutine get_max_wind to get the maximum near- c surface wind near the center, and then call get_next_ges c to get a guess position for the next forecast hour. if (stormswitch(ist) == 1) then call fixcenter (clon,clat,ist,ifh,calcparm & ,slonfg(ist,ifh),slatfg(ist,ifh),inp & ,stderr,fixlon,fixlat,xval,maxstorm,ifret) if (ifret == 0) then if ((trkrinfo%type == 'midlat' .or. & trkrinfo%type == 'tcgen') .and. & trkrinfo%gridtype == 'regional')then if (fixlon(ist,ifh) > (trkrinfo%eastbd + 7.0) .or. & fixlon(ist,ifh) < (trkrinfo%westbd - 7.0) .or. & fixlat(ist,ifh) > (trkrinfo%northbd + 7.0) .or. & fixlat(ist,ifh) < (trkrinfo%southbd - 7.0)) then if ( verb .ge. 3 ) then print *,' ' print *,'!!! For a midlat or tcgen case, a fix ' print *,'!!! will NOT be made for this time due' print *,'!!! the storm being more than 7 degrees' print *,'!!! outside the user-specified lat/lon' print *,'!!! bounds for this run. We will stop' print *,'!!! tracking this storm.' print *,'!!! Storm ID = ',storm(ist)%tcv_storm_id print *,'!!! Storm = ' & ,storm(ist)%tcv_storm_name write (6,432) ifhours(ifh),ifclockmins(ifh) 432 format (1x,'!!! Fcst hr = ',i4,':',i2.2) print *,'!!! fixlat= ',fixlat(ist,ifh) print *,'!!! fixlon= ',fixlon(ist,ifh) print *,'!!! User East Bound = ',trkrinfo%eastbd print *,'!!! User West Bound = ',trkrinfo%westbd print *,'!!! User North Bound = ',trkrinfo%northbd print *,'!!! User South Bound = ',trkrinfo%southbd endif fixlon (ist,ifh) = -999.0 fixlat (ist,ifh) = -999.0 stormswitch(ist) = 2 if (ifh == 1) then vradius = 0 ileadtime = nint(fhreal(ifh) * 100.0) ifcsthour = ileadtime / 100 call output_atcfunix (-999.0 & ,-999.0,inp,ist & ,ifcsthour,0.0 & ,0.0,vradius,maxstorm,trkrinfo & ,-99.0,-99.0,-99.0 & ,cps_vals,wcore_flag,ioaxret) imeanzeta = -99 igridzeta = -99 call output_atcf_gen (-999.0 & ,-999.0,inp,ist & ,ifcsthour,0.0 & ,0.0,vradius,maxstorm,trkrinfo & ,-99,-99,-999.0,-999.0,-99.0 & ,cps_vals,'u',imeanzeta,igridzeta,ioaxret) call output_atcf_sink (-999.0 & ,-999.0,inp,ist & ,ifcsthour,0.0 & ,0.0,vradius,maxstorm,trkrinfo & ,-99,-99,imeanzeta,igridzeta & ,cps_vals,-999.0,-999.0,ioaxret) endif cycle stormloop endif endif else fixlon (ist,ifh) = -999.0 fixlat (ist,ifh) = -999.0 stormswitch(ist) = 2 endif c Just because we've found a center doesn't mean there is c actually a storm there. I noticed in the first year that c for some decaying or just weak storms, the tracker would c identify a center to follow, but it may have only been c a weak trough passing by, or something else that's not c our storm. This next subroutine checks to see that the c surface pressure gradient and/or tangential winds at c 850 mb resemble a storm. It is called twice; the first c time for MSLP, the 2nd time for 850 mb winds. We will c apply these storm-checking criteria if either the mslp c or v850 check come back negative. Remember, there c is the possibility that centers could not be found for c 1 or both of these parameters, in which case the isastorm c flag will have a value of 'U', for "undetermined". isiret1 = 0; isiret2 = 0; isiret3 = 0 print *,' ttest, ifret= ',ifret if (ifret == 0) then print *,' ttest, calcparm(9,ist)= ',calcparm(9,ist) if (calcparm(9,ist)) then ! Do a check of the mslp gradient.... print *,' ttest, in IF part: ' print *,' clon(ist,ifh,9)= ',clon(ist,ifh,9) print *,' clat(ist,ifh,9)= ',clat(ist,ifh,9) print *,' xval(9)= ',xval(9) call is_it_a_storm (imax,jmax,dx,dy,'slp',ist & ,valid_pt,clon(ist,ifh,9),clat(ist,ifh,9) & ,xval(9),trkrinfo,isastorm(1),isiret1) else ! Sept 2016: There has been a hole in this logic for ! a while. If a fix can't be made for mslp (e.g., ! maybe the mslp fix was too far away from the ! guess?), then this check isn't performed. We are ! changing this so that the mslp gradient check will ! still be performed, but using the mean fixlat and ! fixlon positions as the center. Still, we first ! need to check to see if mslp was even read in. If ! it wasn't, then we are just out of luck. print *,' ttest, in ELSE part: ' if (trkrinfo%use_backup_mslp_grad_check == 'y' .or. & trkrinfo%use_backup_mslp_grad_check == 'Y') then print *,' ttest ELSE, readflag(9)= ',readflag(9) if (readflag(9)) then print *,'ttest ELSE A, ist= ',ist,' ifh= ',ifh print *,'ttest ELSE A, fixlon(ist,ifh)= ' & ,fixlon(ist,ifh) print *,'ttest ELSE A, fixlat(ist,ifh)= ' & ,fixlat(ist,ifh) call fix_latlon_to_ij (imax,jmax,dx,dy,slp,'min' & ,valid_pt,fixlon(ist,ifh),fixlat(ist,ifh) & ,9999.0,ifix,jfix,gridpoint_maxmin,'tracker' & ,glatmax,glatmin,glonmax,glonmin & ,trkrinfo,ifilret) print *,'ttest ELSE B, ifilret= ',ifilret if (ifilret == 0) then print *,'ttest ELSE B, ifilret= ',ifilret print *,'ttest ELSE B, fixlon(ist,ifh)= ' & ,fixlon(ist,ifh) print *,'ttest ELSE B, fixlat(ist,ifh)= ' & ,fixlat(ist,ifh) call is_it_a_storm (imax,jmax,dx,dy,'slp',ist & ,valid_pt,fixlon(ist,ifh),fixlat(ist,ifh) & ,gridpoint_maxmin,trkrinfo,isastorm(1) & ,isiret1) if (isiret1 == 0) then ! Even though calcparm(9) is FALSE and mslp ! will not be used for center-fixing ! purposes, we need to fill the clat and clon ! arrays just a few lines below so that ! calls to fix_latlon_to_ij below do not ! get screwed up. So, into the clat and clon ! arrays we put the mean fixlat and fixlon ! positions for this lead time. clat(ist,ifh,9) = fixlat(ist,ifh) clon(ist,ifh,9) = fixlon(ist,ifh) xval(9) = gridpoint_maxmin endif endif endif endif endif ! If we have found a valid mslp gradient, then make ! a call to fix_latlon_to_ij to (1) get the actual ! gridpoint value of the mslp (the value previously ! stored in xval(9) is an area-averaged value coming ! from the barnes analysis), and (2) to get the ! (i,j) indices for this gridpoint to be used in the ! call to check_closed_contour below. ! ! NOTE: If a mslp fix was not made, or if the mslp ! "isastorm" flag comes back as no, we make the same ! call to fix_latlon_to_ij, but we use the mean fix ! position as our input to search around, and then ! basically we just find the lowest mslp near that ! mean fix position. There is a check on the value ! of xinp_fixlat and xinp_fixlon to make sure that ! they contain valid values and not just the ! initialized -999 values. if (isiret1 == 0 .and. isastorm(1) == 'Y') then xinp_fixlat = clat(ist,ifh,9) xinp_fixlon = clon(ist,ifh,9) if (verb >= 3) then print *,' ttest at location C IF....' print *,' xinp_fixlat= ',xinp_fixlat print *,' xinp_fixlon= ',xinp_fixlon endif else xinp_fixlat = fixlat(ist,ifh) xinp_fixlon = fixlon(ist,ifh) if (verb >= 3) then print *,' ttest at location C ELSE....' print *,' xinp_fixlat= ',xinp_fixlat print *,' xinp_fixlon= ',xinp_fixlon endif endif if (xinp_fixlat > -99.0 .and. xinp_fixlon > -990.0) & then if (verb >= 3) then print *,' ttest at location D' endif call fix_latlon_to_ij (imax,jmax,dx,dy,slp,'min' & ,valid_pt,xinp_fixlon,xinp_fixlat & ,xval(9),ifix,jfix,gridpoint_maxmin,'tracker' & ,glatmax,glatmin,glonmax,glonmin & ,trkrinfo,ifilret) if (verb >= 3) then print *,' ttest at location E, ifilret= ',ifilret endif if (ifilret == 0) then gridprs(ist,ifh) = gridpoint_maxmin else ! Search went out of regional grid bounds.... fixlon (ist,ifh) = -999.0 fixlat (ist,ifh) = -999.0 stormswitch(ist) = 2 cycle stormloop endif endif print *,' ttest at location F' ! For a "tracker" case, check to see if the user has ! requested to compute and write out the ROCI. If ! so, then we make a call to check_closed_contour, ! being sure to specify 999 as the number of levels ! to check.... if (isiret1 == 0 .and. isastorm(1) == 'Y' .and. & trkrinfo%type == 'tracker') then if (trkrinfo%want_oci) then if ( verb .ge. 3 ) then print *,' ' print *,'Before call to check_closed_contour, ' print *,'ifix= ',ifix,' jfix= ',jfix print *,'longitude= ',xinp_fixlon,'E (' & ,360-xinp_fixlon,'W)' print *,'latitude= ',xinp_fixlat print *,'mean mslp value (xval(9))= ',xval(9) endif if (contour_info%numcont == 0) then contour_info%numcont = maxconts endif if (xval(9) < 1100.0) then ! Pressure units are in mb... prs_contint_thresh = 4.0 elseif (xval(9) >80000.0) then ! Pressure units are in Pa... prs_contint_thresh = 400.0 else if (verb .ge. 3) then print *,' ' print *,'ERROR: Something wrong in subroutine' print *,' tracker. The mslp value' print *,' (xval(9)) is not in range.' print *,' before call to' print *,' check_closed_contour.' print *,' xval(9) = ',xval(9) print *,' EXITING....' print *,' ' stop 95 endif endif if (trkrinfo%contint < prs_contint_thresh) then hold_old_contint = trkrinfo%contint trkrinfo%contint = prs_contint_thresh if ( verb .ge. 3 ) then print *,' ' print *,'Before going into routine to diagnose' print *,'the ROCI for a tracker run, the ' print *,'requested contour interval is being ' print *,'adjusted up (coarser) to avoid having' print *,'the contour check routine break and ' print *,'return an invalid value.' print *,'User-requested contint value (Pa) = ' & ,hold_old_contint print *,'Modified contint value (Pa) = ' & ,trkrinfo%contint endif endif masked_outc = .false. get_last_isobar_flag = 'y' call check_closed_contour (imax,jmax,ifix,jfix,slp & ,valid_pt,masked_outc,ccflag,'min',trkrinfo & ,999,contour_info,get_last_isobar_flag,plastbar & ,rlastbar,icccret) if ( verb .ge. 3 ) then print *,' ' print *,'After call to check_closed_contour, ' print *,'ifix= ',ifix,' jfix= ',jfix print *,'longitude= ',xinp_fixlon,'E (' & ,360-xinp_fixlon,'W)' print *,'latitude= ',xinp_fixlat print *,'mean mslp value (xval(9))= ',xval(9) print *,'gridpoint mslp value= ',slp(ifix,jfix) print *,'ccflag= ',ccflag print *,'prs of last closed isobar = ',plastbar print *,'radius of last closed isobar = ' & ,rlastbar,' nm' print *,' ' endif endif endif ! For the midlat & tcgen cases, do a check to see if ! there is a closed mslp contour. The ifix and jfix ! values passed into check_closed_contour are the ! values for the (i,j) at the gridpoint minimum, ! which was obtained just above from the call to ! fix_latlon_to_ij. ! UPDATE 7/12/2016 tpm: A change was made to fix a ! hole in the logic. Previously, for a genesis run ! (type = midlat or tcgen), if a fix was not made ! for mslp, then the isastorm(1) flag would not be ! 'Y', and so the call to check_closed_contour in ! the following IF statement would not be made, and ! that would prevent the mask from getting updated ! for this particular storm, allowing the same storm ! to be detected when the scan for new storms takes ! place at this lead time (i.e., after all previously- ! known storms from the last lead time have been ! tracked). As a fix, if that isastorm(1) flag is not ! 'Y', then we call a new subroutine which updates the ! mask based on the circulation at 850 mb. if (isastorm(1) == 'Y' .and. isiret1 == 0 .and. & (trkrinfo%type == 'midlat' .or. & trkrinfo%type == 'tcgen')) then if ( verb .ge. 3 ) then print *,' ' print *,'Before call to check_closed_contour, ' print *,'ifix= ',ifix,' jfix= ',jfix print *,'longitude= ',xinp_fixlon,'E (' & ,360-xinp_fixlon,'W)' print *,'latitude= ',xinp_fixlat print *,'mean mslp value (xval(9))= ',xval(9) endif if (contour_info%numcont == 0) then contour_info%numcont = maxconts endif get_last_isobar_flag = 'y' call check_closed_contour (imax,jmax,ifix,jfix,slp & ,valid_pt,masked_outc,ccflag,'min',trkrinfo & ,999,contour_info,get_last_isobar_flag,plastbar & ,rlastbar,icccret) if ( verb .ge. 3 ) then print *,' ' print *,'After call to check_closed_contour, ' print *,'ifix= ',ifix,' jfix= ',jfix print *,'longitude= ',xinp_fixlon,'E (' & ,360-xinp_fixlon,'W)' print *,'latitude= ',xinp_fixlat print *,'mean mslp value (xval(9))= ',xval(9) print *,'gridpoint mslp value= ',slp(ifix,jfix) print *,'ccflag= ',ccflag print *,'prs of last closed isobar = ',plastbar print *,'radius of last closed isobar = ',rlastbar & ,' nm' print *,' ' endif ! This next bit of code adds a second layer of closed ! contour checking. This is to decrease the ! occurrence of interrupted midlat and tcgen tracks, ! which usually happens when the closed contour ! criterion is not met for one time period. So in ! this next code, we check to see if the ccflag was ! 'y' for at least half the time over the last 24h. ! For time periods shorter than 24h (e.g., the storm ! was just detected at 144h and we are now at 156h), ! the threshold is still that for at least half of ! the time the system has been detected as a storm, ! it must have a ccflag value of 'y'. if (ccflag == 'y') then closed_mslp_ctr_flag(ist,ifh) = 'y' else closed_mslp_ctr_flag(ist,ifh) = 'n' if (ifh > 1) then iccfh = ifh cc_time_sum_tot = 0.0 cc_time_sum_yes = 0.0 do while (iccfh > 1 .and. & closed_mslp_ctr_flag(ist,iccfh) /= 'u' .and. & cc_time_sum_tot < 24.0) xinterval_fhr = fhreal(iccfh) - fhreal(iccfh-1) cc_time_sum_tot = cc_time_sum_tot & + xinterval_fhr if (closed_mslp_ctr_flag(ist,iccfh) == 'y') then cc_time_sum_yes = cc_time_sum_yes & + xinterval_fhr endif iccfh = iccfh - 1 enddo if (cc_time_sum_tot > 0.0) then cc_time_pct = cc_time_sum_yes / cc_time_sum_tot else cc_time_pct = 0.0 endif if (cc_time_pct >= 0.50) then ccflag = 'y' if ( verb .ge. 3 ) then print *,' ' print *,'++ NOTE ON CLOSED CONTOUR CHECK: The' print *,' ccflag returned for this hour was' print *,' NO, but a check of recent ccflags' print *,' indicates that more than 50% of ' print *,' the ccflags over the last 24h are' print *,' YES, so we will continue.' print *,' cc_time_pct= ',cc_time_pct print *,' ' endif else ccflag = 'n' if ( verb .ge. 3 ) then print *,' ' print *,'!! NOTE ON CLOSED CONTOUR CHECK: The' print *,'!! ccflag returned for this hour was' print *,' NO, and a check of recent ccflags' print *,' indicates that less than 50% of ' print *,' the ccflags over the last 24h are' print *,' YES, so we will stop tracking.' print *,' cc_time_pct= ',cc_time_pct endif endif endif endif if (ccflag == 'y') then isastorm(2) = 'Y' else if (ccflag == 'n') then isastorm(2) = 'N' endif if ( verb .ge. 3 ) then print *,' ' print *,'*---------------------------------------*' print *,'* After check_closed_contour... *' print *,'*---------------------------------------*' print *,' ' endif else if (isastorm(1) /= 'Y' .and. & calcparm(3,ist) .and. & (trkrinfo%type == 'midlat' .or. & trkrinfo%type == 'tcgen')) then ! The isastorm(1) flag indicates that a mslp gradient ! could not be found at this lead time, so the mask ! cannot be updated using mslp. Instead, ! do a check of the 850 mb wind circulation ! surrounding the 850 wind circulation fix, and then ! set the mask to be TRUE for all points within the ! area where mean cyclonic Vt exceed +1 m/s.... c call check_closed_contour (imax,jmax,ifix,jfix,slp c & ,valid_pt,masked_outc,ccflag,'min',trkrinfo c & ,999,contour_info,get_last_isobar_flag,plastbar c & ,rlastbar,icccret) if ( verb .ge. 3 ) then print *,' ' print *,'Calling mask_based_on_wind_circ at ' & ,ifcsthour endif call mask_based_on_wind_circ (imax,jmax,dx,dy,850 & ,valid_pt,masked_outc,trkrinfo & ,clon(ist,ifh,3),clat(ist,ifh,3),inp%modtyp & ,imbowret) endif ! For tropical cyclones, check the avg 850 mb tangential ! windspeed close to the storm center.... if (trkrinfo%type == 'tcgen' .or. & trkrinfo%type == 'tracker') then had_to_try_backup_850_vt_check = 'n' if (calcparm(3,ist)) then if (verb .ge. 3) then print *,' ' print *,'Checking 850 mb Vt speed using 850 mb ' print *,'wind circulation fix: ' print *,' 850 mb wcirc fix lon= ',clon(ist,ifh,3) print *,' 850 mb wcirc fix lat= ',clat(ist,ifh,3) print *,' Multi-parm fix lon= ',fixlon(ist,ifh) print *,' Multi-parm fix lat= ',fixlat(ist,ifh) print *,' ' endif call is_it_a_storm (imax,jmax,dx,dy,'v850',ist & ,valid_pt,clon(ist,ifh,3),clat(ist,ifh,3) & ,xval(3),trkrinfo,isastorm(3),isiret3) else ! Sept 2016: There has been a hole in this logic for ! a while. If a fix can't be made for 850 mb wind ! circulation (maybe the 850 mb wind circulation fix ! was too far away from the guess?), then this check ! isn't performed. We are changing this so that the ! 850 mb Vt wind speed check will still be ! performed, but using the mean fixlat and fixlon ! positions as the center. Still, we first need to ! check to see if 850 mb u-comp and v-comp were even ! read in. If they weren't, then we are just out ! of luck. had_to_try_backup_850_vt_check = 'y' isiret3 = -99 if (trkrinfo%use_backup_850_vt_check == 'y' .or. & trkrinfo%use_backup_850_vt_check == 'Y') then if (readflag(3) .and. readflag(4)) then if (verb .ge. 3) then print *,' ' print *,'!!! NOTE: 850 mb wcirc fix not ' print *,'available. We are instead ' print *,'checking 850 mb Vt speed using ' print *,'multi-parm fix position: ' print *,' Multi-parm fix lon= ' & ,fixlon(ist,ifh) print *,' Multi-parm fix lat= ' & ,fixlat(ist,ifh) print *,' ' endif call is_it_a_storm (imax,jmax,dx,dy,'v850',ist & ,valid_pt,fixlon(ist,ifh),fixlat(ist,ifh) & ,0.00,trkrinfo,isastorm(3),isiret3) endif endif endif if (calcparm(3,ist) .or. & (had_to_try_backup_850_vt_check == 'y' .and. & isiret3 == 0) ) then if (trkrinfo%type == 'tcgen') then ! This next bit of code adds a second layer of 850 ! mb Vt magnitude checking. This is to decrease ! the occurrence of interrupted tcgen tracks, ! which occasionally happens for weak storms when ! this criterion is not met for one time period. ! So in this next code, we check to see if the ! vt850_flag was 'y' for at least 75% of the time ! over the last 24h. For time periods shorter ! than 24h (e.g., the storm was just detected at ! 144h and we are now at 156h), the threshold is ! still that for at least 75% of the time the ! system has been detected as a storm, it must ! have a vt850_flag value of 'y'. if (isastorm(3) == 'Y') then vt850_flag(ist,ifh) = 'y' else vt850_flag(ist,ifh) = 'n' if (ifh > 1) then iccfh = ifh cc_time_sum_tot = 0.0 cc_time_sum_yes = 0.0 do while (iccfh > 1 .and. & vt850_flag(ist,iccfh) /= 'u' .and. & cc_time_sum_tot < 24.0) xinterval_fhr = fhreal(iccfh) - & fhreal(iccfh-1) cc_time_sum_tot = cc_time_sum_tot & + xinterval_fhr if (vt850_flag(ist,iccfh) == 'y') then cc_time_sum_yes = cc_time_sum_yes & + xinterval_fhr endif iccfh = iccfh - 1 enddo if (cc_time_sum_tot > 0.0) then cc_time_pct = cc_time_sum_yes / & cc_time_sum_tot else cc_time_pct = 0.0 endif if (cc_time_pct >= 0.75) then isastorm(3) = 'Y' if ( verb .ge. 3 ) then print *,' ' print *,'+++ NOTE ON Vt_850 CHECK: The ' print *,' isastorm flag returned for ' print *,' this hour was NO, but a' print *,' check of recent vt850_flags' print *,' indicates that more than 75%' print *,' of the vt850_flags over the' print *,' last 24h are YES, so we will' print *,' continue.' print *,' cc_time_pct= ',cc_time_pct print *,' ' endif else isastorm(3) = 'N' if ( verb .ge. 3 ) then print *,' ' print *,'!!! NOTE ON Vt_850 CHECK: The ' print *,'!!! isastorm flag returned for ' print *,' this hour was NO, and a' print *,' check of recent vt850_flags ' print *,' indicates that less than 75%' print *,' of the vt850_flags over the' print *,' last 24h are YES, so we will' print *,' stop tracking.' print *,' cc_time_pct= ',cc_time_pct endif endif endif endif endif endif endif else if (trkrinfo%type == 'midlat' .or. & trkrinfo%type == 'tcgen') then isastorm(1) = 'N' if ( verb .ge. 3 ) then print *,' ' print *,'!!! For a midlat or tcgen case, a fix ' print *,'!!! could not be made for mslp, ' print *,'!!! therefore we will stop tracking ' print *,'!!! for this storm.' endif else isastorm(1) = 'N' isastorm(3) = 'N' if ( verb .ge. 3 ) then print *,' ' print *,'!!! For a TC tracker case, a fix could' print *,'!!! not be made using any tracked parms,' print *,'!!! therefore we will stop tracking for' print *,'!!! this storm.' endif endif if ( verb .ge. 3 ) then print *,'!!! Storm ID = ',storm(ist)%tcv_storm_id print *,'!!! Storm = ',storm(ist)%tcv_storm_name write (6,432) ifhours(ifh),ifclockmins(ifh) endif fixlon (ist,ifh) = -999.0 fixlat (ist,ifh) = -999.0 stormswitch(ist) = 2 cycle stormloop endif if (isiret1 /= 0 .or. isiret2 /= 0 .or. isiret3 /= 0) & then if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: One of the calls to ' print *,'!!! is_it_a_storm produced an error.' print *,'!!! Chances are this is from a call to ' print *,'!!! get_ij_bounds, meaning we are too close' print *,'!!! to a regional grid boundary to do this ' print *,'!!! analysis. Processing will continue....' print *,'!!! isiret1= ',isiret1,' isiret2= ',isiret2 print *,'!!! isiret3= ',isiret3 endif endif if (isastorm(1) == 'N' .or. isastorm(2) == 'N' .or. & isastorm(3) == 'N') then if ( verb .ge. 3 ) then print *,' ' print *,'!!! At least one of the isastorm flags from' print *,'!!! subroutine is_it_a_storm is "N", so ' print *,'!!! either we were unable to find a good ' print *,'!!! mslp gradient and/or a valid 850 mb ' print *,'!!! circulation for the storm at this time,' print *,'!!! or, for the cases of midlat or tcgen ' print *,'!!! tracking, a closed mslp contour could ' print *,'!!! not be found, thus we will stop tracking' print *,'!!! this storm.' print *,'!!! Storm ID = ',storm(ist)%tcv_storm_id print *,'!!! Storm = ',storm(ist)%tcv_storm_name write (6,432) ifhours(ifh),ifclockmins(ifh) print *,'!!! mslp gradient flag = ',isastorm(1) print *,'!!! closed contour flag = ',isastorm(2) print *,'!!! 850 mb winds flag = ',isastorm(3) print *,' ' endif fixlon (ist,ifh) = -999.0 fixlat (ist,ifh) = -999.0 stormswitch(ist) = 2 endif ! Now do another check for the tracker and tcgen cases. ! If the isastorm flags for mslp gradient and v850 BOTH ! came back positive AND you have been able to locate an ! 850 mb vort center, just do a check to make sure that ! the distance between the 850 vort center and the mslp ! center is not too great. if (trkrinfo%type == 'tracker' .or. & trkrinfo%type == 'tcgen') then if (isastorm(1) == 'Y' .and. isastorm(3) == 'Y' .and. & calcparm(1,ist) .and. stormswitch(ist) == 1) then c if (atcfname == 'GFSO' .and. c & abs(slatfg(ist,ifh)) >= 25.0) then c trkrinfo%max_mslp_850 = 405.0 c else if (atcfname == 'GFSO' .and. c & abs(slatfg(ist,ifh)) < 25.0) then c trkrinfo%max_mslp_850 = 405.0 c else c trkrinfo%max_mslp_850 = 323.0 c endif call calcdist (clon(ist,ifh,9),clat(ist,ifh,9) & ,clon(ist,ifh,1),clat(ist,ifh,1),dist & ,degrees) if (dist > trkrinfo%max_mslp_850) then if ( verb .ge. 3 ) then print *,' ' print *,'!!! In routine tracker, the dist betw' print *,'!!! the mslp center & the 850 zeta ' print *,'!!! center is too great, thus we will' print *,'!!! stop tracking this storm.' print *,'!!! Storm ID = ',storm(ist)%tcv_storm_id print *,'!!! Storm = ' & ,storm(ist)%tcv_storm_name write (6,432) ifhours(ifh),ifclockmins(ifh) print *,'!!! Max dist allowed (km) = ' & ,trkrinfo%max_mslp_850 print *,'!!! Actual distance (km) = ',dist print *,' ' endif fixlon (ist,ifh) = -999.0 fixlat (ist,ifh) = -999.0 stormswitch(ist) = 2 else if ( verb .ge. 3 ) then print *,' ' print *,'Actual distance between the parm centers' print *,'for 850 zeta and mslp is ',dist,' (km)' print *,'Max dist allowed (km) = ' & ,trkrinfo%max_mslp_850 endif endif endif endif ! Do one final check. Check the new fix position and ! the old fix position and calculate the speed that the ! storm would have had to travel to get to this point. ! If that speed exceeds a certain threshold (~60 kt), ! assume you're tracking the wrong thing and quit. ! Obviously, only do this for times > 00h. The check ! in the if statement to see if the previous hour's ! lats and lons were > -999 is for the midlat and ! tcgen cases -- remember, they can have genesis at ! any hour of the forecast, in which case the previous ! forecast hour's lat & lon would be -999. if (ifh > 1 .and. stormswitch(ist) == 1) then if (fixlon(ist,ifh-1) > -999.0 .and. & fixlat(ist,ifh-1) > -999.0 ) then if (trkrinfo%type == 'midlat') then xmaxspeed = maxspeed_ml else xmaxspeed = maxspeed_tc endif call calcdist (fixlon(ist,ifh-1),fixlat(ist,ifh-1) & ,fixlon(ist,ifh),fixlat(ist,ifh),dist & ,degrees) ! convert distance from km to nm and get speed. distnm = dist * 0.539638 xinterval_fhr = fhreal(ifh) - fhreal(ifh-1) xknots = distnm / xinterval_fhr if (xknots > xmaxspeed) then if ( verb .ge. 3 ) then print *,' ' print *,'!!! In routine tracker, calculated spd' print *,'!!! of the storm from the last position' print *,'!!! to the current position is too high,' print *,'!!! so we will stop tracking this storm' print *,'!!! (For fear that we are not actually ' print *,'!!! tracking our storm, but have instead' print *,'!!! locked onto some other feature....)' print *,'!!! Storm ID = ',storm(ist)%tcv_storm_id print *,'!!! Storm = ' & ,storm(ist)%tcv_storm_name write (6,432) ifhours(ifh),ifclockmins(ifh) print *,'!!! Max speed allowed (kt) = ',xmaxspeed print *,'!!! Actual speed (kt) = ',xknots print *,' ' endif fixlon (ist,ifh) = -999.0 fixlat (ist,ifh) = -999.0 stormswitch(ist) = 2 else if ( verb .ge. 3 ) then print *,' ' print *,'The average speed that the storm moved' print *,'at since the previous forecast time is' & ,xknots,' knots.' endif endif endif endif endif c Now get the maximum near-surface wind speed near the storm c center (get_max_wind). Also, call getradii to get the c radii in each storm quadrant of gale-force, storm-force c and hurricane force winds. if (readflag(10) .and. readflag(11) .and. ifret == 0 & .and. stormswitch(ist) == 1) then call get_max_wind (fixlon(ist,ifh),fixlat(ist,ifh) & ,imax,jmax,dx,dy,valid_pt,levsfc & ,xmaxwind(ist,ifh),trkrinfo,rmax,igmwret) c if (igmwret /= 0 .and. gridmove_status == 'stopped') then if (igmwret /= 0) then if ( verb .ge. 3 ) then print *,' ' print *,'!!! Return code from get_max_wind is /= 0. ' print *,'!!! rcc= igmwret= ',igmwret print *,'!!! Also, this is a moveable, regional grid' print *,'!!! and the grid did not change from last' print *,'!!! lead time to current one, so what has' print *,'!!! likely happened is that the storm has ' print *,'!!! moved close to the edge of the nested ' print *,'!!! grid domain, but the nested grid itself' print *,'!!! had stopped moving, probably because it' print *,'!!! dropped or lost the storm.' print *,'!!! ' print *,'!!! TRACKING WILL STOP FOR THIS STORM' print *,'!!! ' endif stormswitch(ist) = 2 cycle stormloop endif ileadtime = nint(fhreal(ifh) * 100.0) ifcsthour = ileadtime / 100 ! For the radii, we encountered a problem with radmax ! being too small. It was set at 650 km. Hurricane ! Sandy exceeded this in the models, so the values ! returned from getradii were close to the default ! radmax value of 650 km (350 nm), instead of higher. ! To fix it, we now use an iterative technique, where ! we start with radmax as a small value (500 km). If ! getradii returns a value for R34 in a quadrant that ! does not exceed 0.97*radmax, then that value is ok. ! If it does exceed 0.97*radmax, then we bump up radmax ! by 50 km and call getradii again, looking to diagnose ! radii only in those quadrants where the ! need_to_expand_r34 flag = 'n'. BTW... note the ! initial IF statement... we will only go into this ! routine if the max wind just diagnosed for this lead ! time is at least 34 kts (17.5 m/s). if (xmaxwind(ist,ifh) >= 17.5) then vradius = 0 first_time_thru_getradii = .true. r34_check_okay = 'n' do ivr = 1,4 need_to_expand_r34(ivr) = 'y' enddo radmax = 500.0 ! Initial radmax, in km igrct = 1 if ( verb .ge. 3 ) then write (6,242) ifcsthour,igrct,xmaxwind(ist,ifh) & ,date_time(5) & ,date_time(6),date_time(7) 242 format (1x,'TIMING: b4 getrad_iter_loop, fhr= ',i5 & ,' igrct= ',i2,' Vmax (m/s)= ',f8.3 & ,' ',i2.2,':',i2.2,':',i2.2) endif getrad_iter_loop: do while & (r34_check_okay == 'n' .and. radmax <= 1050.) call date_and_time (big_ben(1),big_ben(2),big_ben(3) & ,date_time) if ( verb .ge. 3 ) then write (6,244) ifcsthour,igrct,date_time(5) & ,date_time(6),date_time(7) 244 format (1x,'TIMING: after call getradii, fhr= ',i5 & ,' igrct= ',i2,' ',i2.2,':',i2.2,':',i2.2) endif call getradii (fixlon(ist,ifh),fixlat(ist,ifh),imax & ,jmax,dx,dy,valid_pt,storm(ist)%tcv_storm_id & ,ifcsthour,xmaxwind(ist,ifh),vradius & ,trkrinfo,need_to_expand_r34,radmax & ,first_time_thru_getradii,igrct,igrret) if (igrret /= 0) then if (verb >= 3) then print *,' ' print *,'!!! ERROR: Return code from getradii = ' & ,igrret print *,'!!! Searching for radii will not be ' print *,'!!! completed for this lead time and' print *,'!!! all radii values will be set to ' print *,'!!! missing.' print *,' ' exit getrad_iter_loop endif endif call date_and_time (big_ben(1),big_ben(2),big_ben(3) & ,date_time) if ( verb .ge. 3 ) then write (6,245) ifcsthour,igrct,date_time(5) & ,date_time(6),date_time(7) 245 format (1x,'TIMING: after call getradii, fhr= ',i5 & ,' igrct= ',i2,' ',i2.2,':',i2.2,':',i2.2) endif first_time_thru_getradii = .false. igrct = igrct + 1 r34_dist_thresh = 0.97 * radmax r34_good_ct = 0 do ivr = 1,4 vradius_km = float(vradius(1,ivr)) / 0.5396 if (vradius_km < r34_dist_thresh) then r34_good_ct = r34_good_ct + 1 need_to_expand_r34(ivr) = 'n' endif enddo if (r34_good_ct == 4) then r34_check_okay = 'y' endif radmax = radmax + 50.0 enddo getrad_iter_loop if ( verb .ge. 3 ) then write (6,246) ifcsthour,igrct,xmaxwind(ist,ifh) & ,date_time(5) & ,date_time(6),date_time(7) 246 format (1x,'TIMING: after getrad_iter_loop, fhr= ',i5 & ,' igrct= ',i2,' Vmax (m/s)= ',f8.3 & ,' ',i2.2,':',i2.2,':',i2.2) endif endif endif c If the user has requested so, then call a routine to c determine the type of cyclone, using Bob Hart's c cyclone phase space (CPS) algorithms. It is only used c for times after t=0, since for the first check (of the c "parameter B" thickness asymmetry), we need to know c in which direction the storm is moving. Pulling that c storm movement data off of the tcvitals is not reliable c since the model storm may not be moving in the same c direction as the observed storm. However, we could do c an upgrade later where this storm movement data is c pulled from the "genesis vitals", which are derived c from the model forecast data itself, not the obs. if (phaseflag == 'y' .and. stormswitch(ist) == 1) then wcore_flag = 'u' ! 'u' = undetermined call get_phase (imax,jmax,inp,dx,dy,ist,ifh,trkrinfo & ,fixlon,fixlat,valid_pt,maxstorm & ,cps_vals,wcore_flag,igpret) endif if (structflag == 'y' .or. ikeflag == 'y') then call get_sfc_center (fixlon(ist,ifh),fixlat(ist,ifh) & ,clon,clat,ist,ifh,calcparm,xsfclon & ,xsfclat,maxstorm,igscret) endif if (structflag == 'y' .and. stormswitch(ist) == 1) then call get_wind_structure (imax,jmax,inp,dx,dy & ,ist,ifh,fixlon,fixlat,xsfclon,xsfclat & ,valid_pt,er_wind,sr_wind,er_vr,sr_vr & ,er_vt,sr_vt,maxstorm,trkrinfo,igwsret) if (igwsret == 0) then call output_wind_structure (fixlon(ist,ifh) & ,fixlat(ist,ifh),xsfclon,xsfclat,inp,ist & ,ifcsthour,xmaxwind(ist,ifh) & ,gridprs(ist,ifh),er_wind,sr_wind & ,er_vr,sr_vr,er_vt,sr_vt,maxstorm,iowsret) endif endif if (structflag == 'y' .and. stormswitch(ist) == 1) then call get_fract_wind_cov (imax,jmax,inp,dx,dy & ,ist,ifh,fixlon,fixlat,xsfclon,xsfclat & ,valid_pt,calcparm,wfract_cov,pdf_ct_bin & ,pdf_ct_tot,maxstorm,trkrinfo,igfwret) if (igfwret == 0) then call output_fract_wind (fixlon(ist,ifh) & ,fixlat(ist,ifh),xsfclon,xsfclat,inp,ist & ,ifcsthour,xmaxwind(ist,ifh) & ,gridprs(ist,ifh),wfract_cov,'earth' & ,pdf_ct_bin,pdf_ct_tot,maxstorm,iofwret) endif endif if (ikeflag == 'y' .and. stormswitch(ist) == 1) then call get_ike_stats (imax,jmax,inp,dx,dy & ,ist,ifh,fixlon,fixlat,xsfclon,xsfclat & ,valid_pt,calcparm,ike,sdp,wdp,maxstorm & ,trkrinfo,igisret) if (igisret == 0) then call output_ike (fixlon(ist,ifh) & ,fixlat(ist,ifh),xsfclon,xsfclat,inp,ist & ,ifcsthour,xmaxwind(ist,ifh) & ,gridprs(ist,ifh),ike,sdp,wdp,maxstorm & ,ioiret) endif endif c Now print out the current fix position and intensity c (in knots) to standard output. Conversion for m/s to c knots (1.9427) is explained in output_atcf. if ( verb .ge. 3 ) then print *,' ' print *,'After call to fixcenter, fix positions at ' write (6,442) ifhours(ifh),ifclockmins(ifh) 442 format (1x,'forecast hour= ',i4,':',i2.2,' follow:') print *,' ' endif if (ifret == 0 .and. stormswitch(ist) == 1) then if ( verb .ge. 3 ) then write (6,73) storm(ist)%tcv_storm_id,ifhours(ifh) & ,ifclockmins(ifh),fixlon(ist,ifh) & ,360.-fixlon(ist,ifh),fixlat(ist,ifh) & ,int((xmaxwind(ist,ifh)*1.9427) + 0.5) print *,' ' endif ! Only call output routines every atcffreq/100 hours.... ileadtime = nint(fhreal(ifh) * 100.0) leadtime_check = mod(ileadtime,atcffreq) if (leadtime_check == 0) then ifcsthour = ileadtime / 100 call output_atcfunix (fixlon(ist,ifh) & ,fixlat(ist,ifh),inp,ist & ,ifcsthour,xmaxwind(ist,ifh) & ,gridprs(ist,ifh),vradius,maxstorm & ,trkrinfo,plastbar,rlastbar,rmax,cps_vals & ,wcore_flag,ioaxret) ! Get the storm motion vector and the speed of ! motion so that we can output this in the ! "atcf_sink" forecast text file. if (ifh < ifhmax) then call get_next_ges (fixlon,fixlat,ist,ifh & ,imax,jmax,dx,dy,inp%model,valid_pt,readflag & ,maxstorm,istmspd,istmdir,'vitals',trkrinfo & ,ignret) else istmdir = -999 istmspd = -999 ignret = 0 endif if ( verb .ge. 3 ) then write (6,617) istmspd,istmdir,ignret 617 format (1x,'+++ RPT_STORM_MOTION: istmspd= ',i5 & ,' istmdir= ',i5,' rcc= ',i3) endif ! Call a routine to find the mean & max relative ! vorticity near the storm at 850 & 700. These will ! be written out to the "atcf_sink" fcst text file. imeanzeta = -99 igridzeta = -99 call get_zeta_values (fixlon,fixlat,imax,jmax,dx,dy & ,trkrinfo,imeanzeta,igridzeta,readflag & ,valid_pt,ist,ifh,maxstorm,inp,igzvret) if (trkrinfo%type == 'midlat' .or. & trkrinfo%type == 'tcgen') then call output_atcf_gen (fixlon(ist,ifh) & ,fixlat(ist,ifh),inp,ist & ,ifcsthour,xmaxwind(ist,ifh) & ,gridprs(ist,ifh),vradius,maxstorm,trkrinfo & ,istmspd,istmdir,plastbar,rlastbar,rmax & ,cps_vals,wcore_flag,imeanzeta,igridzeta,ioaxret) endif call output_atcf_sink (fixlon(ist,ifh) & ,fixlat(ist,ifh),inp,ist & ,ifcsthour,xmaxwind(ist,ifh) & ,gridprs(ist,ifh),vradius,maxstorm & ,trkrinfo,istmspd,istmdir,imeanzeta & ,igridzeta,cps_vals,plastbar,rlastbar & ,ioaxret) if (inp%model == 12 .and. ifcsthour == 0) then ! Write vitals for GFS ens control analysis call output_tcvitals (fixlon(ist,ifh) & ,fixlat(ist,ifh),inp,ist,iovret) endif endif ! The exception here is for the call to the output_hfip ! routine, which will be called for every lead time ! that is processed.... call output_hfip (fixlon(ist,ifh),fixlat(ist,ifh),inp,ist & ,ifh,xmaxwind(ist,ifh) & ,gridprs(ist,ifh),vradius,rmax,ioaxret) else if ( verb .ge. 3 ) then write (6,452) 'fixpos ',storm(ist)%tcv_storm_id & ,' fhr= ',ifhours(ifh),ifclockmins(ifh) & ,' Fix not made for this forecast hour' 452 format (1x,a7,1x,a4,a6,i4,':',i2.2,a36) print *,' ' print *,'!!! RETURN CODE from fixcenter not equal to 0,' print *,'!!! or output from is_it_a_storm indicated the' print *,'!!! system found was not our storm, or the ' print *,'!!! speed calculated indicated we may have ' print *,'!!! locked onto a different center, thus a fix' print *,'!!! was not made for this storm at this ' print *,'!!! forecast hour.' print *,'!!! mslp gradient check = ',isastorm(1) print *,'!!! mslp closed contour check = ',isastorm(2) print *,'!!! 850 mb winds check = ',isastorm(3) print *,'!!! fixcenter return code = ifret = ',ifret print *,' ' endif if (ifh == 1) then vradius = 0 ileadtime = nint(fhreal(ifh) * 100.0) ifcsthour = ileadtime / 100 c if (inp%model == 1 .or. inp%model == 8 .or. c & inp%model == 22) then cPENG if (inp%model == 1 .or. inp%model == 10 .or. inp%model == 7 & .or. inp%model == 22 .or. inp%model == 16 & .or. inp%model == 15 .or. inp%model == 8) then ! For the vt=00h lead time, if the tracker failed to ! locate a position, we are going to write out an ! atcfunix record that contains the position, ! intensity, mslp and 34-kt wind radii from TC Vitals ! for this storm and initial time. Only do this for ! the GFS or GDAS runs of the tracker. tcv_max_wind_ms = float(storm(ist)%tcv_vmax) tcv_mslp_pa = float(storm(ist)%tcv_pcen) * 100.0 ! Convert tcvitals NE 34-kt wind radius from km to nm r34_from_tcv = float(storm(ist)%tcv_r15ne) if (r34_from_tcv > 0.0) then vradius(1,1) = int( ((r34_from_tcv*0.5396) & / 5.0) + 0.5) * 5 else vradius(1,1) = 0 endif ! Convert tcvitals SE 34-kt wind radius from km to nm r34_from_tcv = float(storm(ist)%tcv_r15se) if (r34_from_tcv > 0.0) then vradius(1,2) = int( ((r34_from_tcv*0.5396) & / 5.0) + 0.5) * 5 else vradius(1,2) = 0 endif ! Convert tcvitals SW 34-kt wind radius from km to nm r34_from_tcv = float(storm(ist)%tcv_r15sw) if (r34_from_tcv > 0.0) then vradius(1,3) = int( ((r34_from_tcv*0.5396) & / 5.0) + 0.5) * 5 else vradius(1,3) = 0 endif ! Convert tcvitals NW 34-kt wind radius from km to nm r34_from_tcv = float(storm(ist)%tcv_r15nw) if (r34_from_tcv > 0.0) then vradius(1,4) = int( ((r34_from_tcv*0.5396) & / 5.0) + 0.5) * 5 else vradius(1,4) = 0 endif ! Convert tcvitals roci from km to nm if (storm(ist)%tcv_penvrad > 0) then roci_from_tcv = float(storm(ist)%tcv_penvrad) rlastbar = roci_from_tcv * 0.5396 else rlastbar = -99.0 endif ! Convert tcvitals pressure at roci from km to nm if (storm(ist)%tcv_penv > 0) then proci_from_tcv = float(storm(ist)%tcv_penv) plastbar = proci_from_tcv * 100.0 else plastbar = -99.0 endif write (6,291) storm(ist)%tcv_storm_id & ,storm(ist)%tcv_storm_name & ,atcfymdh 291 format (1x,'NOTE: TCVITALS_USED_FOR_ATCF_F00 ' & ,' Storm ID: ',a4,' Storm name: ',a9 & ,' YMDH: ',i10) call output_atcfunix (slonfg(ist,ifh) & ,slatfg(ist,ifh),inp,ist & ,ifcsthour,tcv_max_wind_ms & ,tcv_mslp_pa,vradius,maxstorm,trkrinfo & ,plastbar,rlastbar,-99.0 & ,cps_vals,wcore_flag,ioaxret) else ! For all other models, we print out missing ! data values at tau=00h if the tracker was ! unable to find the storm.... call output_atcfunix (-999.0 & ,-999.0,inp,ist & ,ifcsthour,0.0 & ,0.0,vradius,maxstorm,trkrinfo & ,-99.0,-99.0,-99.0 & ,cps_vals,wcore_flag,ioaxret) endif imeanzeta = -99 igridzeta = -99 if (trkrinfo%type == 'midlat' .or. & trkrinfo%type == 'tcgen') then call output_atcf_gen (-999.0 & ,-999.0,inp,ist & ,ifcsthour,0.0 & ,0.0,vradius,maxstorm,trkrinfo & ,-99,-99,-999.0,-999.0,-99.0 & ,cps_vals,'u',imeanzeta,igridzeta,ioaxret) endif call output_atcf_sink (-999.0 & ,-999.0,inp,ist & ,ifcsthour,0.0 & ,0.0,vradius,maxstorm,trkrinfo & ,-99,-99,imeanzeta,igridzeta & ,cps_vals,-999.0,-999.0,ioaxret) call output_hfip (-999.0 & ,-999.0,inp,ist & ,ifh,0.0 & ,0.0,vradius,-99.0,ioaxret) if (trkrinfo%type == 'tracker') then ! Update 11/11: For a 'tracker' run, i.e., one in ! which we know that there is an observed storm in ! the area, we will assume that there was some type ! of problem in the initialization that prevented ! the storm from being found. In this case, even ! though we have written out zeroes for the 00h ! time, we want to at least try tracking again at ! the next lead time. Requested by HWRF folks.... if (verb .ge. 3) then print *,' ' print *,'++ NOTE: Even though a fix could not be' print *,' made for this storm at 00h, we will ' print *,' use the storm heading info from tc' print *,' vitals to create a guess for the next' print *,' lead time and attempt to track again' print *,' at that time.' print *,' ifh= ',ifh,' ist= ',ist write (6,301) storm(ist)%tcv_storm_id & ,storm(ist)%tcv_storm_name 301 format (1x,' storm_id = ',a4,' storm_name = ',a9) endif call get_next_ges (slonfg,slatfg,ist,ifh & ,imax,jmax,dx,dy,inp%model,valid_pt,readflag & ,maxstorm,istmspd,istmdir,'tracker',trkrinfo & ,ignret) if (ignret /= 0) then fixlon (ist,ifh) = -999.0 fixlat (ist,ifh) = -999.0 stormswitch(ist) = 2 cycle stormloop endif stormswitch(ist) = 1 endif endif cycle stormloop endif c Now get first guess for next forecast time's position. c But first, if this is the first time level (ifh=1) and c the user has requested that storm vitals be output (this c is usually only done for model analyses in order to get c an analysis position from one time to the next), we will c write out a storm vitals record for this time level. c Note that we have already gotten the next guess position c info just above for the case of the repeated analysis c data, so we'll just output the genesis vitals record. if (ifh <= ifhmax) then if (ifh == 1 .and. trkrinfo%out_vit == 'y') then call output_gen_vitals (fixlon(ist,ifh) & ,fixlat(ist,ifh),inp,ist,istmspd,istmdir,iovret) endif if (ifh < ifhmax) then call get_next_ges (fixlon,fixlat,ist,ifh & ,imax,jmax,dx,dy,inp%model,valid_pt,readflag & ,maxstorm,istmspd,istmdir,'tracker',trkrinfo & ,ignret) if (ignret /= 0) then if ( verb .ge. 3 ) then print *,' ' print *,'!!! ERROR: Problem getting first guess ' print *,'!!! position for next lead time. Return' print *,'!!! code from call to get_next_ges = ' print *,'!!! ignret = ',ignret print *,'!!! Storm name = ' & ,storm(ist)%tcv_storm_name print *,'!!! Storm ID = ',storm(ist)%tcv_storm_id print *,'!!! TRACKING WILL STOP FOR THIS STORM.' endif fixlon (ist,ifh) = -999.0 fixlat (ist,ifh) = -999.0 stormswitch(ist) = 2 cycle stormloop endif else istmdir = -999 istmspd = -999 endif endif case (2) fixlon (ist,ifh) = -999.0 fixlat (ist,ifh) = -999.0 if ( verb .ge. 3 ) then print *,' ' print *,'!!! Case 2 in tracker for stormswitch' print *,'!!! Storm name = ',storm(ist)%tcv_storm_name print *,'!!! Storm ID = ',storm(ist)%tcv_storm_id endif if (ifh == 1) then vradius = 0 ileadtime = nint(fhreal(ifh) * 100.0) ifcsthour = ileadtime / 100 call output_atcfunix (-999.0 & ,-999.0,inp,ist & ,ifcsthour,0.0 & ,0.0,vradius,maxstorm,trkrinfo & ,-99.0,-99.0,-99.0 & ,cps_vals,wcore_flag,ioaxret) imeanzeta = -99 igridzeta = -99 if (trkrinfo%type == 'midlat' .or. & trkrinfo%type == 'tcgen') then call output_atcf_gen (-999.0 & ,-999.0,inp,ist & ,ifcsthour,0.0 & ,0.0,vradius,maxstorm,trkrinfo & ,-99,-99,-999.0,-999.0,-99.0 & ,cps_vals,'u',imeanzeta,igridzeta,ioaxret) endif call output_atcf_sink (-999.0 & ,-999.0,inp,ist & ,ifcsthour,0.0 & ,0.0,vradius,maxstorm,trkrinfo & ,-99,-99,imeanzeta,igridzeta & ,cps_vals,-999.0,-999.0,ioaxret) call output_hfip (-999.0 & ,-999.0,inp,ist & ,ifh,0.0 & ,0.0,vradius,-99.0,ioaxret) endif case (3) continue c print *,' ' c print *,'!!! Case 3 in tracker for stormswitch' c print *,'!!! Storm name = ',storm(ist)%tcv_storm_name c print *,'!!! Storm ID = ',storm(ist)%tcv_storm_id end select enddo stormloop if (trkrinfo%type == 'midlat' .or. & trkrinfo%type == 'tcgen') then ileadtime = nint(fhreal(ifh) * 100.0) leadtime_check = mod(ileadtime,atcffreq) if (leadtime_check == 0) then ifcsthour = ileadtime / 100 endif if (trkrinfo%inp_data_type == 'grib') then call output_tracker_mask (masked_outc,valid_pt,ifh & ,ifcsthour,imax,jmax,iotmret) endif endif if(use_per_fcst_command=='y') then c User wants us to run a command per forecast time ! Replace %[FHOUR] with forecast hour, %[FMIN] with forecast minute. ! The %[] format is chosen to avoid shell syntax errors if someone ! includes unknown %[] constructs. A stray , for example, ! would generate syntax errors or unexpected results in some ! shells. ! If an unrecognized %[xxx] sequence is used, it will be retained in ! the final command. This allows the underlying command to detect ! the unreplaced %[] and use suitable default values or abort, as ! appropriate. pfc_final=per_fcst_command call argreplace(pfc_final,pfc_cmd_len,'%[FHOUR]', & & ifhours(ifh)) call argreplace(pfc_final,pfc_cmd_len,'%[FMIN]', & & iftotalmins(ifh)) if(verb.ge.2) then print *,' ' print *,'!!! Running per-fcst command' print *,'!!! Unparsed = ',trim(per_fcst_command) print *,'!!! Parsed = ',trim(pfc_final) endif call run_command(trim(pfc_final),pfcret) if(pfcret/=0 .and. verb.ge.1) then print *,' ' print *,'!!! Non-zero exit status from per-fcst command' print *,'!!! Command = ',trim(pfc_final) print *,'!!! Exit status = ',pfcret print *,'!!! Continuing anyway...' elseif(pfcret==0 .and. verb.ge.2) then print *,' ' print *,'!!! Per-fcst command returned success status (0)' endif endif ifh = ifh + 1 if (ifh > ifhmax) exit ifhloop if (inp%file_seq == 'multi') then call baclose(lugb,igcret) call baclose(lugi,iicret) if ( verb .ge. 3 ) then print *,'baclose return code for unit ',lugb,' = igcret = ' & ,igcret print *,'baclose return code for unit ',lugi,' = iicret = ' & ,iicret endif endif enddo ifhloop c cPENG call output_all (fixlon,fixlat,inp,maxstorm,ifhmax,ioaret) cPENG call output_atcf (fixlon,fixlat,inp,xmaxwind,maxstorm,ifhmax cPENG & ,ioaret) c 73 format ('fixpos ',a4,' fhr= ',i4,':',i2.2,' Fix position= ' & ,f7.2,'E (',f6.2,'W)',2x,f7.2,' Max Wind= ',i3,' kts') if (allocated(prstemp)) deallocate (prstemp) if (allocated(prsindex)) deallocate (prsindex) if (allocated(iwork)) deallocate(iwork) if (allocated(zeta)) deallocate (zeta) if (allocated(u)) deallocate (u) if (allocated(v)) deallocate (v) if (allocated(hgt)) deallocate (hgt) if (allocated(slp)) deallocate (slp) if (allocated(tmean)) deallocate (tmean) if (allocated(thick)) deallocate (thick) if (allocated(lsmask)) deallocate (lsmask) if (allocated(masked_out)) deallocate (masked_out) if (allocated(masked_outc)) deallocate (masked_outc) if (allocated(cpshgt)) deallocate (cpshgt) if (allocated(vt850_flag)) deallocate (vt850_flag) if (allocated(closed_mslp_ctr_flag)) & deallocate (closed_mslp_ctr_flag) if (allocated(netcdf_file_time_values)) & deallocate (netcdf_file_time_values) if (allocated(nctotalmins)) & deallocate (nctotalmins) c return end c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine argreplace(arg,n,name,val) ! This subroutine is used to generate the pre-forecast-command ! It will edit the command (argument "arg") and replace string ! name with value val. That is how the per-forecast-command ! has these modifications: ! %[FHOUR] -> replace with -> last forecast hour ! %[FMIN] -> replace with -> last forecast minute implicit none integer, intent(in) :: n character(n), intent(inout) :: arg character(*), intent(in) :: name integer, intent(in) :: val integer found,namelen,i1,i2 character(n) :: out found=index(arg,name) namelen=len(name) i1=found-1 ! last char that is before name i2=found+namelen ! index of last char in name if(found==0) return out=' ' if(found>1 .and. i21) then ! special case: name is at end of string ! hope the value fits... write(out,'(A,I0)') arg(1:i1),val elseif(i2 & ,'... gopen_i_file= ...',a,'...') print *,'gopen_g_file= ',gopen_g_file,'....' print *,'gopen_i_file= ',gopen_i_file,'....' call baopenr (lugb,gopen_g_file,igoret) call baopenr (lugi,gopen_i_file,iioret) inquire (unit=lout, opened=output_file_open) if (output_file_open) then iooret = 0 else fnameo(1:5) = "fort." write(fnameo(6:7),'(I2)') lout call baopenw (lout,fnameo,iooret) endif endif inquire (unit=lugb, opened=file_open) if (file_open) then print *,'TEST open_grib_files, unit lugb= ',lugb & ,' is OPEN' else print *,'TEST open_grib_files, unit lugb= ',lugb & ,' is CLOSED' endif inquire (unit=lugi, opened=file_open) if (file_open) then print *,'TEST open_grib_files, unit lugi= ',lugi & ,' is OPEN' else print *,'TEST open_grib_files, unit lugi= ',lugi & ,' is CLOSED' endif inquire (file=gopen_g_file, opened=file_open4) if (file_open4) then print *,'TEST gname open_grib_files, gfile= ' & ,gopen_g_file,' is OPEN' else print *,'TEST gname open_grib_files, gfile= ' & ,gopen_g_file,' is CLOSED' endif inquire (file=gopen_i_file, opened=file_open5) if (file_open5) then print *,'TEST iname open_grib_files, ifile= ' & ,gopen_i_file,' is OPEN' else print *,'TEST iname open_grib_files, ifile= ' & ,gopen_i_file,' is CLOSED' endif if ( verb .ge. 3 ) then print *,' ' print *,'gettrk baopen: igoret= ',igoret,' iioret= ',iioret & ,' iooret= ',iooret endif if (igoret /= 0 .or. iioret /= 0 .or. iooret /= 0) then if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in sub open_grib_files opening grib file' print *,'!!! or grib index file. baopen return codes:' print *,'!!! grib file return code = igoret = ',igoret print *,'!!! index file return code = iioret = ',iioret print *,'!!! output file return code = iooret = ',iooret endif iret = 113 return endif return end c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine open_ncfile (filename,ncid) c ABSTRACT: This subroutine opens a netcdf file specified by the c input file "ncfile" and returns the netcdf file id that will be c associated with that file. c c INPUT: c ncfile character full-path file netcdf name c c OUTPUT: c ncfile_id integer, netcdf id assigned to the netcdf file implicit none include "netcdf.inc" character*(*), intent(in) :: filename integer, intent(out) :: ncid integer :: status status = nf_open (filename, NF_NOWRITE, ncid) if (status .ne. NF_NOERR) call handle_netcdf_err(status) end subroutine open_ncfile c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine is_it_a_storm (imax,jmax,dx,dy,cparm,ist & ,defined_pt,parmlon,parmlat & ,parmval,trkrinfo,stormcheck,isiret) c ABSTRACT: This subroutine is called after the center of the storm c has been fixed. Its purpose is to determine whether or not c the center that was found is actually a storm, and not just some c passing trough (this has happened in the case of decaying or weak c storms). It's called twice -- once to check for a minimum MSLP c gradient, and once to check for a circulation at 850 mb. The c subroutine input parameter "cparm" determines which parameter to c check for. c c INPUT: c imax Num pts in i direction on input grid c jmax Num pts in j direction on input grid c dx Grid spacing in i-direction on input grid c dy Grid spacing in j-direction on input grid c cparm Char string indicating what parm is to be checked: c slp = mslp, for a check of mslp gradient c v850 = tangential winds at 850 mb c ist integer storm number (internal to the tracker) c defined_pt Logical; bitmap indicating if valid data at that pt. c parmlon Longitude of the max/min value for the input parameter c parmlat Latitude of the max/min value for the input parameter c parmval Data value at parm's max/min point (used for mslp call) c trkrinfo derived type containing grid info on user boundaries c c OUTPUT: c stormcheck Character; set to 'Y' if mslp gradient or 850 mb c tangential winds check okay. c isiret Return code for this subroutine. c USE radii; USE grid_bounds; USE set_max_parms; USE level_parms USE trig_vals; USE tracked_parms; USE atcf; USE trkrparms USE verbose_output implicit none c type (trackstuff) trkrinfo real vt,vtavg,vr,parmlat,parmlon,parmval,dist real pthresh,vthresh,degrees,dx,dy,dell,ri,radinf real pgradient,xmaxpgrad character(*) cparm logical(1) defined_pt(imax,jmax) character*1 stormcheck integer isiret,imax,jmax,ist,npts,ilonfix,jlatfix,igvtret integer ibeg,iend,jbeg,jend,ivt,i,j,iix,jix,bskip,igiret isiret = 0 stormcheck = 'N' dell = (dx+dy)/2. c First define the radius of influence, which depends on the c grid spacing of the model data being used. The ceiling statement c for npts in the first if statement is needed in case the c resolution of the grib files eventually goes very low, down to c say a half degree or less, in order to cover enough points in c the search. if (dell < 1.24) then ! GFS, MRF, NAM, NGM, NAVGEM, GDAS, ! GFDL, NCEP Ensemble & Ensemble ! Relocation, SREF Ensemble ri = ritrk_most if (cparm == 'slp') then radinf = 300.0 else radinf = 225.0 endif npts = ceiling(radinf/(dtk*(dx+dy)/2.)) else if (dell >= 1.24 .and. dell < 2.49) then ! UKMET ri = ritrk_most radinf = 275.0 npts = 2 else ! ECMWF ri = ritrk_coarse radinf = 350.0 npts = 1 endif pthresh = trkrinfo%mslpthresh ! These are read in in vthresh = trkrinfo%v850thresh ! subroutine read_nlists.... call get_ij_bounds (npts,0,ri,imax,jmax,dx,dy & ,glatmax,glatmin,glonmax,glonmin,parmlon,parmlat & ,trkrinfo,ilonfix,jlatfix,ibeg,jbeg,iend,jend,igiret) if ( verb .ge. 3 ) then print *,' ' print *,' After get_ij B, ibeg jbeg = ',ibeg,jbeg print *,' After get_ij B, iend jend = ',iend,jend endif if (igiret /= 0) then if ( verb .ge. 1 ) then print*,' ' print*,'!!! ERROR in is_it_a_storm from call to' print*,'!!! get_ij_bounds, stopping processing for ' print*,'!!! storm number ',ist endif isiret = 92 return endif c If the input cparm is slp, then check to see that the MSLP c gradient in any direction from the MSLP center is at least c 1mb / 200km, or 0.005mb/km. This is based on discussions with c Morris & Bob, who have had good results using a 2mb/200km c requirement. Since their model has a much finer resolution than c all of the models we run the tracker on AND a much better c depiction of the hurricane vortex, we do not use a requirement c as strict as theirs, and so make the requirement only half as c strong as theirs. c c If the input cparm is v850, then check to see that there is c a circulation at 850 mb. We will do this by calculating the c tangential wind of all points within a specified radius of c the 850 minimum wind center, and seeing if there is a net c average tangential wind speed of at least 5 m/s. c c UPDATE APRIL 2000: I've relaxed the thresholds slightly from c 0.005 mb/km to 0.003 mb/km, and the wind threshold from c 5 m/s to 3 m/s. Also, note that a special case for GDAS has c been hardwired in that is weaker (0.002 mb/km and 2 m/s). c That weaker GDAS requirement is for Qingfu's relocation stuff. c c UPDATE JULY 2001: The relaxed requirement put in place in c April 2000 for the GDAS relocation has also been put in place c for the GFS ensemble relocation. ! We will want to speed things up for finer resolution grids. ! We can do this by skipping some of the points in the loop. if ((dx+dy)/2. > 0.20) then bskip = 1 else if ((dx+dy)/2. > 0.10 .and. (dx+dy)/2. <= 0.20) then bskip = 2 else if ((dx+dy)/2. > 0.05 .and. (dx+dy)/2. <= 0.10) then bskip = 3 else if ((dx+dy)/2. > 0.03 .and. (dx+dy)/2. <= 0.05) then bskip = 5 else if ((dx+dy)/2. <= 0.03) then bskip = 10 endif if ( verb .ge. 3 ) then print *,' ' print *,'In is_it_a_storm, ilonfix= ',ilonfix & ,' jlatfix= ',jlatfix print *,'ibeg jbeg iend jend = ',ibeg,jbeg,iend,jend print *,'cparm= ',cparm,' parmlon parmlat = ',parmlon,parmlat print *,'parmval= ',parmval print *,' ' endif vtavg = 0.0 ivt = 0 xmaxpgrad = -999.0 jloop: do jix = jbeg,jend,bskip iloop: do iix = ibeg,iend,bskip i = iix j = jix if (i < 1) then if (trkrinfo%gridtype == 'global') then i = iix + imax else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: i < 1 in subroutine is_it_a_storm' print *,'!!! for a non-global grid. STOPPING....' print *,'!!! i= ',i print *,' ' endif stop 97 endif endif if (i > imax) then if (trkrinfo%gridtype == 'global') then i = iix - imax else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: i > imax in subroutine ' print *,'!!! is_it_a_storm for a non-global grid.' print *,'!!! STOPPING....' print *,'!!! i= ',i,' imax= ',imax print *,' ' endif stop 97 endif endif call calcdist(parmlon,parmlat,glon(i),glat(j),dist,degrees) if (dist > radinf .or. dist == 0.0) cycle if (defined_pt(i,j)) then if (cparm == 'slp') then pgradient = (slp(i,j) - parmval) / dist if (pgradient > xmaxpgrad) xmaxpgrad = pgradient if ( verb .ge. 3 ) then write (6,93) i,j,glon(i),glat(j),dist,slp(i,j),pgradient endif if (pgradient > pthresh) then if ( verb .ge. 3 ) then print *,' ' print *,'In is_it_a_storm, valid pgradient found.' print '(a23,f8.5)',' pgradient threshold = ',pthresh print '(a23,f8.5)',' pgradient found = ',pgradient print *,'mslp center = ',parmlon,parmlat,parmval print *,'pgrad loc = ',glon(i),glat(j),slp(i,j) endif stormcheck = 'Y' exit jloop endif endif if (cparm == 'v850') then call getvrvt (parmlon,parmlat,glon(i),glat(j) & ,u(i,j,nlev850),v(i,j,nlev850),vr,vt,igvtret) if ( verb .ge. 3 ) then write (6,91) i,j,glon(i),glat(j),u(i,j,nlev850) & ,v(i,j,nlev850),vr,vt endif vtavg = vtavg + vt ivt = ivt + 1 endif endif enddo iloop enddo jloop 91 format (1x,'i= ',i4,' j= ',i4,' glon= ',f7.2,' glat= ',f6.2 & ,' u= ',f8.4,' v= ',f8.4,' vr= ',f9.5,' vt= ',f9.5) 93 format (1x,'i= ',i4,' j= ',i4,' glon= ',f7.2,' glat= ',f6.2 & ,' dist= ',f8.2,' slp= ',f10.2,' pgradient= ',f8.5) if (stormcheck /= 'Y' .and. cparm == 'slp') then if ( verb .ge. 3 ) then print *,' ' print *,'!!! In is_it_a_storm, valid pgradient NOT FOUND.' write (6,94) '!!! (Max pgradient less than ',pthresh,' mb/km)' 94 format (1x,a29,5x,f8.5,a7) write (6,95) '!!! Max pgradient (mb/km) found = ',xmaxpgrad 95 format (1x,a34,f8.5) print *,' ' endif endif if (cparm == 'v850') then if (ivt > 0) then vtavg = vtavg / float(ivt) else vtavg = 0.0 endif if (parmlat > 0) then if (vtavg >= vthresh) then stormcheck = 'Y' if ( verb .ge. 3 ) then print *,' ' print *,' In is_it_a_storm, average 850 tangential' & ,' winds are OKAY (>= +',vthresh,' m/s for a NH storm).' print *,' Avg 850 tangential winds = ',vtavg,' m/s' print *,' ' endif else if ( verb .ge. 3 ) then print *,' ' print *,'!!! In is_it_a_storm, average 850 tangential' print *,'!!! winds did NOT exceed +',vthresh & ,' m/s (NH storm).' print *,'!!! Avg 850 tangential winds = ',vtavg,' m/s' print *,' ' endif endif else if (vtavg <= -vthresh) then stormcheck = 'Y' if ( verb .ge. 3 ) then print *,' ' print *,' In is_it_a_storm, average 850 tangential' & ,' winds are OKAY (<= -',vthresh,' m/s for a SH storm).' print *,' Avg 850 tangential winds = ',vtavg,' m/s' print *,' ' endif else if ( verb .ge. 3 ) then print *,' ' print *,'!!! In is_it_a_storm, average 850 tangential' print *,'!!! winds did NOT exceed -',vthresh & ,' m/s (SH storm).' print *,'!!! Avg 850 tangential winds = ',vtavg,' m/s' print *,' ' endif endif endif endif c return end c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine get_phase (imax,jmax,inp,dx,dy,ist,ifh,trkrinfo & ,fixlon,fixlat,valid_pt,maxstorm & ,cps_vals,wcore_flag,igpret) c c ABSTRACT: This subroutine is a driver subroutine for c determining the structure or phase of a cyclone. Initially, we c will just have it use the Hart cyclone phase space (CPS) scheme. USE inparms; USE phase; USE set_max_parms; USE tracked_parms USE def_vitals; USE trkrparms; USE grid_bounds USE verbose_output implicit none type (datecard) inp type (trackstuff) trkrinfo character wcore_flag*1,okay_to_call_cps_routines*1 real fixlon(maxstorm,maxtime),fixlat(maxstorm,maxtime) real cps_vals(3) real dx,dy,paramb,vtl_slope,vtu_slope integer imax,jmax,igpret,igcpret,ist,ifh,maxstorm integer igvpret,igcv1ret,igcv2ret logical(1) valid_pt(imax,jmax) c if ( verb .ge. 3 ) then write (6,*) ' ' write (6,611) write (6,613) write (6,615) write (6,*) ' ' 611 format(1x,'#-----------------------------------------------#') 613 format(1x,'# start of routine to determine cyclone phase...#') 615 format(1x,'#-----------------------------------------------#') endif if (phasescheme == 'cps' .or. phasescheme == 'both') then if (ifh > 1 .or. (ifh == 1 .and. trkrinfo%type == 'tracker')) & then ! This condition that ifh > 1 is so that we *not* do the cps ! stuff for fhour=0 if it's a tcgen or midlat case, since we ! don't know the model storm motion direction for the ! analysis. For a regular case where type = 'tracker', we ! have the observed storm's heading direction from tc vitals, ! so we can use that (even though the model's storm direction ! may differ slightly from the observed storm). This current ! if statement and the ones below carefully check for these ! various instances. okay_to_call_cps_routines = 'n' if (ifh > 1) then if (fixlon(ist,ifh-1) > -990.0 .and. & fixlat(ist,ifh-1) > -990.0) then okay_to_call_cps_routines = 'y' else if (verb >= 3) then print *,' ' print *,' >< CPS diagnostics were requested but will' print *,' >< NOT be performed for this time level ' print *,' >< since the fixlon and fixlat at the ' print *,' >< previous lead time are undefined.' print *,' >< This is likely the first found position' print *,' >< for a genesis (tcgen or midlat) case.' print *,' >< ifh= ',ifh endif endif elseif (ifh == 1 .and. trkrinfo%type == 'tracker') then okay_to_call_cps_routines = 'y' else if (verb >= 3) then print *,' ' print *,' >< CPS diagnostics were requested but will' print *,' >< NOT be performed for this time level.' print *,' >< The likely reason is that ifh=0 and' print *,' >< this is a genesis case, so we do not ' print *,' >< know the storm motion direction.' print *,' >< for a genesis (tcgen or midlat) case.' print *,' >< ifh= ',ifh print *,' >< trkrinfo%type ',trkrinfo%type endif endif if (okay_to_call_cps_routines == 'y') then ! Similarly, these next two conditions (previous lat and ! previous lon > -999) are in there in case we're doing a ! tcgen or midlat case and this is the *first* time level ! within a forecast that the storm has been detected (again, ! we don't yet know the storm heading). call get_cps_paramb (imax,jmax,inp,dx,dy,ist,ifh,trkrinfo & ,fixlon,fixlat,valid_pt,paramb,maxstorm,igcpret) call get_cps_vth (imax,jmax,inp,dx,dy,ist,ifh,trkrinfo & ,fixlon,fixlat,valid_pt,'lower',vtl_slope & ,maxstorm,igcv1ret) call get_cps_vth (imax,jmax,inp,dx,dy,ist,ifh,trkrinfo & ,fixlon,fixlat,valid_pt,'upper',vtu_slope & ,maxstorm,igcv2ret) if ( verb .ge. 3 ) then write (6,*) ' ' write (6,73) storm(ist)%tcv_storm_id,ifhours(ifh) & ,ifclockmins(ifh) & ,paramb,vtl_slope,vtu_slope endif cps_vals(1) = paramb cps_vals(2) = vtl_slope cps_vals(3) = vtu_slope else if ( verb .ge. 3 ) then print *,' ' print *,' >< CPS diagnostics were requested but will NOT' print *,' >< be performed for this time level since we ' print *,' >< are either at the first time level for a ' print *,' >< genesis case (type = midlat or tcgen), or' print *,' >< we are at any time level in which for some' print *,' >< reason the fixlon and fixlat at the' print *,' >< previous time level are not defined.' print *,' >< ifh= ',ifh endif endif else if ( verb .ge. 3 ) then print *,' ' print *,' >< CPS diags were requested but will NOT be' print *,' >< performed for this time level since we are at' print *,' >< time level 1 for a genesis case ' print *,' >< (type = midlat or tcgen) and we cannot' print *,' >< diagnose the model direction of storm' print *,' >< movement. ifh= ',ifh endif endif endif 73 format ('cps_stats: ',a4,' lead time= ',i3,':',i2,' paramb= ' & ,f8.2,' vtl= ',f9.2,' vtu= ',f9.2) if (phasescheme == 'vtt' .or. phasescheme == 'both') then call get_vtt_phase (inp,imax,jmax,dx,dy,ist,ifh,trkrinfo & ,fixlon,fixlat,valid_pt,maxstorm,wcore_flag,igvpret) endif if ( verb .ge. 3 ) then write (6,*) ' ' write (6,631) write (6,633) write (6,635) write (6,*) ' ' 631 format(1x,'#-------------------------------------------------#') 633 format(1x,'# End of routine to determine cyclone phase... #') 635 format(1x,'#-------------------------------------------------#') endif c return end c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine get_cps_paramb (imax,jmax,inp,dx,dy,ist,ifh,trkrinfo & ,fixlon,fixlat,valid_pt,paramb,maxstorm,igcpret) c c ABSTRACT: This subroutine is part of the algorithm for determining c the structure, or phase, of a cyclone. For Hart's cyclone phase c space, this subroutine determines "Parameter B", which determines c the degree of thermal symmetry between the "left" and "right" c hemispheres of a storm, in the layer between 900 and 600 mb. c We evaluate only those points that are within 500 km of the c storm center. USE inparms; USE phase; USE set_max_parms; USE trig_vals USE grid_bounds; USE tracked_parms; USE def_vitals; USE trkrparms USE verbose_output implicit none type (datecard) inp type (trackstuff) trkrinfo real fixlon(maxstorm,maxtime),fixlat(maxstorm,maxtime) real zthicksum(2) real rlonc,rlatc,rlonb,rlatb,xdist,degrees,d,cosarg real st_heading,st_heading_rad,ricps,dx,dy real pt_dir,pt_dir_rad,zthick,hemval,paramb real zthick_right_mean,zthick_left_mean integer imax,jmax,igpret,igcpret,ist,ifh,npts,bskip,i,j integer ilonfix,jlatfix,ibeg,jbeg,iend,jend,igiret integer left_ct,right_ct,hemis,icount,maxstorm,ip logical(1) valid_pt(imax,jmax) c ricps = 500.0 c ----------------------------------------------------------------- c First, determine the angle that the storm took getting from the c last position to the current one. If this is for ifh=1 for a c regular type=tracker case, we will just use the storm direction c as read from the tcvitals card. c ----------------------------------------------------------------- if (ifh == 1) then st_heading = float(storm(ist)%tcv_stdir) else call calcdist(fixlon(ist,ifh),fixlat(ist,ifh) & ,fixlon(ist,ifh-1),fixlat(ist,ifh-1),xdist,degrees) rlonc = (360.-fixlon(ist,ifh)) * dtr rlatc = fixlat(ist,ifh) * dtr rlonb = (360.-fixlon(ist,ifh-1)) * dtr rlatb = fixlat(ist,ifh-1) * dtr d = degrees * dtr if (d == 0.0) then ! Storm is stationary... st_heading = 0.0 else cosarg = (sin(rlatc)-sin(rlatb)*cos(d))/(sin(d)*cos(rlatb)) if (cosarg > 1.0) cosarg = 1 if (cosarg < -1.0) cosarg = -1 if (sin(rlonc-rlonb) < 0.0) then st_heading_rad = acos(cosarg) else st_heading_rad = 2*pi - acos(cosarg) endif st_heading = st_heading_rad / dtr endif endif if ( verb .ge. 3 ) then print *,' ' print *,' In get_cps_paramb, lead time= ',ifhours(ifh),':' & ,ifclockmins(ifh) & ,' ',storm(ist)%tcv_storm_id,' ' & ,storm(ist)%tcv_storm_name print '(a43,f9.3)' & ,' In get_cps_paramb, model storm heading = ' & ,st_heading print *,' ' endif c ----------------------------------------------------------------- c Now call get_ij_bounds to get the boundaries for a smaller c subdomain, or subset of gridpoints, in which to evaluate the c parameter B statistic. We will only include points within c 500 km of the storm center for evaluation. c ----------------------------------------------------------------- npts = ceiling(ricps/(dtk*(dx+dy)/2.)) call get_ij_bounds (npts,0,ricps,imax,jmax,dx,dy & ,glatmax,glatmin,glonmax,glonmin,fixlon(ist,ifh),fixlat(ist,ifh) & ,trkrinfo,ilonfix,jlatfix,ibeg,jbeg,iend,jend,igiret) if (igiret /= 0) then if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in get_cps_paramb from call to' print *,'!!! get_ij_bounds, stopping processing for' print *,'!!! storm number ',ist endif igcpret = 92 return endif c ----------------------------------------------------------------- c Now loop through all of the points of the subdomain. If the c point is further than 500 km from the storm center, discard it. c Otherwise, evaluate the angle from the storm center to this point c to determine the hemisphere of the point, that is, if the point c is to the left or the right of the storm track. c ----------------------------------------------------------------- ! We will want to speed things up for finer resolution grids. ! We can do this by skipping some of the points in the ! loop for the evaluation of parameter B. if ((dx+dy)/2. > 0.20) then bskip = 1 else if ((dx+dy)/2. > 0.10 .and. (dx+dy)/2. <= 0.20) then bskip = 2 else if ((dx+dy)/2. > 0.05 .and. (dx+dy)/2. <= 0.10) then bskip = 3 else if ((dx+dy)/2. > 0.03 .and. (dx+dy)/2. <= 0.05) then bskip = 5 else if ((dx+dy)/2. <= 0.03) then bskip = 10 endif left_ct = 0 right_ct = 0 zthicksum = 0 icount = 0 c print *,'CPS CORE: ibeg= ',ibeg,' iend= ',iend c print *,'CPS CORE: jbeg= ',jbeg,' jend= ',jend jloop: do j=jbeg,jend,bskip iloop: do i=ibeg,iend,bskip icount = icount + 1 c print *,'CPS CORE: ist= ',ist,' ifh= ',ifh,' j= ',j,' i= ',i if (i > imax) then if (trkrinfo%gridtype == 'global') then ip = i - imax ! If wrapping past GM else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: In get_cps_paramb, the ' print *,'!!! user-requested eastern search boundary' print *,'!!! is beyond the eastern bounds of ' print *,'!!! this regional grid. ' print *,'!!! Parameter B will not be computed.' print *,'!!! Subroutine location A....' print *,'!!! ' print *,'!!! imax of regional grid = ',imax print *,'!!! User-requested eastern i = ',i print *,' ' endif paramb = -9999.99 igcpret = 95 return endif else ip = i endif if (i < 1) then if (trkrinfo%gridtype == 'global') then ip = i + imax ! If wrapping past GM else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: i < 1 in subroutine get_cps_paramb' print *,'!!! for a non-global grid.' print *,'!!! Parameter B will not be computed.' print *,'!!! i= ',i print *,' ' endif paramb = -9999.99 igcpret = 95 return endif endif call calcdist (fixlon(ist,ifh),fixlat(ist,ifh),glon(ip) & ,glat(j),xdist,degrees) if (xdist > ricps) cycle iloop if (valid_pt(ip,j)) then continue else if ( verb .ge. 3 ) then print *,' ' print *,'!!! UNDEFINED PT OUTSIDE OF GRID ' print *,'!!! IN GET_CPS_PARAMB....' print *,'!!! i= ',i,' ip= ',ip,' j= ',j print *,'!!! fixlon= ',fixlon(ist,ifh),' fixlat= ' & ,fixlat(ist,ifh) print *,'!!! glon= ',glon(ip),' glat= ',glat(j) print *,'!!! Parameter B will not be computed.' print *,'!!! EXITING GET_CPS_PARAMB....' print *,' ' endif paramb = -9999.99 igcpret = 95 return endif !---------------------------------------------------------- ! Calculate angle from storm center to point, in a 0-360 ! framework, clockwise positive. !---------------------------------------------------------- rlonc = (360.-glon(ip)) * dtr rlatc = glat(j) * dtr rlonb = (360.-fixlon(ist,ifh)) * dtr rlatb = fixlat(ist,ifh) * dtr d = degrees * dtr if (d > 0.) then cosarg = (sin(rlatc)-sin(rlatb)*cos(d))/(sin(d)*cos(rlatb)) if (cosarg > 1.0) cosarg = 1 if (cosarg < -1.0) cosarg = -1 if (sin(rlonc-rlonb) < 0.0) then pt_dir_rad = acos(cosarg) else pt_dir_rad = 2*pi - acos(cosarg) endif else pt_dir_rad = 0.0 endif pt_dir = pt_dir_rad / dtr !------------------------------------------------------------ ! Based on the angle that the point is from the storm center, ! determine if the point is to the left or the right of the ! storm track. !------------------------------------------------------------ if (st_heading >= 180.0) then if ((st_heading - pt_dir) > 0.0 .and. & (st_heading - pt_dir) <= 180) then hemis = 2 left_ct = left_ct + 1 else hemis = 1 right_ct = right_ct + 1 endif else if ((pt_dir - st_heading) > 0.0 .and. & (pt_dir - st_heading) <= 180) then hemis = 1 right_ct = right_ct + 1 else hemis = 2 left_ct = left_ct + 1 endif endif !------------------------------------------------------------ ! Calculate the 600-900 mb thickness at this point and add ! the thickness value to the array for the correct "storm ! hemisphere". !------------------------------------------------------------ zthick = cpshgt(ip,j,7) - cpshgt(ip,j,1) zthicksum(hemis) = zthicksum(hemis) + zthick if ( verb .ge. 3 ) then write (6,51) rlonb/dtr,rlatb/dtr,rlonc/dtr,rlatc/dtr & ,st_heading,pt_dir,hemis,zthick endif enddo iloop enddo jloop 51 format (1x,'stlon stlat = ',2(f6.2,2x),' ptlon ptlat = ' & ,2(f6.2,2x),' sthead= ',f6.2,' ptdir= ',f6.2,' hemis= ' & ,i1,' zthick= ',f7.2) c ------------------------------------------------------------------ c Now calculate parameter B. The hemval parameter = +1 for storms c in the Northern Hemisphere and -1 for Southern Hemisphere storms. c ------------------------------------------------------------------ zthick_right_mean = zthicksum(1) / float(right_ct) zthick_left_mean = zthicksum(2) / float(left_ct) if (fixlat(ist,ifh) < 0.0) then hemval = -1.0 else hemval = 1.0 endif paramb = hemval * (zthick_right_mean - zthick_left_mean) if ( verb .ge. 3 ) then print *,' ' print *,' In get_cps_paramb, lead time= ',ifhours(ifh),':' & ,ifclockmins(ifh) & ,' ',storm(ist)%tcv_storm_id,' ',storm(ist)%tcv_storm_name print *,' right_ct= ',right_ct,' left_ct= ',left_ct print *,' zthicksum(1)= ',zthicksum(1) print *,' zthicksum(2)= ',zthicksum(2) print *,' zthick_right_mean= ',zthick_right_mean print *,' zthick_left_mean= ',zthick_left_mean print *,' hemval= ',hemval print *,' END of get_cps_paramb, paramb= ',paramb endif c return end c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine get_cps_vth (imax,jmax,inp,dx,dy,ist,ifh,trkrinfo & ,fixlon,fixlat,valid_pt,clayer,vth_slope,maxstorm,igcvret) c c ABSTRACT: This subroutine is part of the algorithm for determining c the structure, or phase, of a cyclone. For Hart's cyclone phase c space, this subroutine determines the thermal wind profile for c either the lower troposphere (i.e., between 600 and 900 mb) or the c upper troposphere (i.e., between 300 and 600 mb). We evaluate c only those points that are within 500 km of the storm center. USE inparms; USE phase; USE set_max_parms; USE trig_vals USE grid_bounds; USE tracked_parms; USE def_vitals; USE trkrparms USE verbose_output implicit none type (datecard) inp type (trackstuff) trkrinfo character clayer*5 real tmp1,tmp2,tmp3 real fixlon(maxstorm,maxtime),fixlat(maxstorm,maxtime) real zmax(7),zmin(7),zdiff(7),xlolevs(7),xhilevs(7),plev(7) real dlnp(7),dzdlnp(7),dz(7),lnp(7) real vth_slope,xdist,degrees,d,cosarg real ricps,dx,dy,R2 integer imax,jmax,igpret,igcpret,ist,ifh,npts,bskip,i,j,k,kix integer ilonfix,jlatfix,ibeg,jbeg,iend,jend,igcvret,igiret integer kbeg,kend,maxstorm,ip logical(1) valid_pt(imax,jmax) data xlolevs /900.,850.,800.,750.,700.,650.,600./ data xhilevs /600.,550.,500.,450.,400.,350.,300./ c data xlolevs /90000.,85000.,80000.,75000.,70000.,65000.,60000./ c data xhilevs /60000.,55000.,50000.,45000.,40000.,35000.,30000./ c ricps = 500.0 plev = 0.0 if (clayer == 'lower') then kbeg = 1 kend = 7 plev = xlolevs else kbeg = 7 kend = 13 plev = xhilevs endif c ----------------------------------------------------------------- c First, call get_ij_bounds to get the boundaries for a smaller c subdomain, or subset of gridpoints, in which to evaluate the c parameter B statistic. We will only include points within c 500 km of the storm center for evaluation. c ----------------------------------------------------------------- npts = ceiling(ricps/(dtk*(dx+dy)/2.)) call get_ij_bounds (npts,0,ricps,imax,jmax,dx,dy & ,glatmax,glatmin,glonmax,glonmin,fixlon(ist,ifh),fixlat(ist,ifh) & ,trkrinfo,ilonfix,jlatfix,ibeg,jbeg,iend,jend,igiret) if (igiret /= 0) then if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in get_cps_vtl from call to' print *,'!!! get_ij_bounds, stopping processing for' print *,'!!! storm number ',ist endif igcvret = 92 return endif c ------------------------------------------------------------------ c Now loop through all of the points of the subdomain at each level. c If a point is further than 500 km from the storm center, discard c it. Otherwise, evaluate the gp height at the point to determine c if it is a max or a min for the given level. Store the max and c min height at each level in an array. c ------------------------------------------------------------------ c ! We will want to speed things up for finer resolution grids. c ! We can do this by skipping some of the points in the c ! loop for the evaluation of parameter B. c c if ((dx+dy)/2. > 0.20) then c bskip = 1 c else if ((dx+dy)/2. > 0.10 .and. (dx+dy)/2. <= 0.20) then c bskip = 2 c else if ((dx+dy)/2. <= 0.10) then c bskip = 3 c endif bskip = 1 ! Don't do any skipping for now.... zmax = -9999999.0 zmin = 9999999.0 zdiff = 0.0 lnp = 0.0 levloop: do k = kbeg,kend if (kbeg == 7) then ! processing upper layers (600-300 mb) kix = k - 6 else ! processing lower layers (900-600 mb) kix = k endif lnp(kix) = log(plev(kix)) jloop: do j=jbeg,jend,bskip iloop: do i=ibeg,iend,bskip if (i > imax) then if (trkrinfo%gridtype == 'global') then ip = i - imax ! If wrapping past GM else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: In get_cps_vth, the ' print *,'!!! user-requested eastern search boundary' print *,'!!! is beyond the eastern bounds of ' print *,'!!! this regional grid. ' print *,'!!! Thermal wind parm will not be computed.' print *,'!!! Subroutine location A....' print *,'!!! ' print *,'!!! imax of regional grid = ',imax print *,'!!! User-requested eastern i = ',i print *,' ' endif vth_slope = -9999.99 igcvret = 95 return endif else ip = i endif if (i < 1) then if (trkrinfo%gridtype == 'global') then ip = i + imax else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: i < 1 in subroutine get_cps_vth' print *,'!!! for a non-global grid.' print *,'!!! Thermal wind parm will not be computed.' print *,'!!! i= ',i print *,' ' endif vth_slope = -9999.99 igcvret = 95 return endif endif call calcdist (fixlon(ist,ifh),fixlat(ist,ifh),glon(ip) & ,glat(j),xdist,degrees) if (xdist > ricps) cycle iloop if (valid_pt(ip,j)) then continue else if ( verb .ge. 3 ) then print *,' ' print *,'!!! UNDEFINED PT OUTSIDE OF GRID ' print *,'!!! IN GET_CPS_VTH....' print *,'!!! i= ',i,' ip= ',ip,' j= ',j,' k= ',k & ,' clayer= ',clayer print *,'!!! fixlon= ',fixlon(ist,ifh),' fixlat= ' & ,fixlat(ist,ifh) print *,'!!! glon(ip)= ',glon(ip),' glat= ',glat(j) print *,'!!! Thermal wind parm will not be computed.' print *,'!!! EXITING GET_CPS_VTH....' print *,' ' endif vth_slope = -9999.99 igcvret = 95 return endif tmp1 = zmax(kix) tmp2 = cpshgt(ip,j,k) tmp3 = zmin(kix) zmax(kix) = max(tmp1,tmp2) zmin(kix) = min(tmp3,tmp2) c zmax(kix) = max(zmax(kix),cpshgt(ip,j,k)) c zmin(kix) = min(zmin(kix),cpshgt(ip,j,k)) enddo iloop enddo jloop zdiff(kix) = zmax(kix) - zmin(kix) enddo levloop c ------------------------------------------------------------------ c Now calculate the vertical derivative of the gp height, that is, c d(dz)/d(ln(p)). Here, zdiff is the gp height perturbation at a c given level, calculated in the loop above; dz is the vertical c change in that perturbation from one level to the next. c ------------------------------------------------------------------ dz = 0.0 dlnp = 0.0 dzdlnp = 0.0 do k = 2,7 dz(k) = zdiff(k) - zdiff(k-1) dlnp(k) = log(plev(k)) - log(plev(k-1)) dzdlnp(k) = dz(k) / dlnp(k) enddo c ------------------------------------------------------------------ c Now call a correlation routine to get the slope of a regression c line. The independent variable that we input is dlnp, the change c in log of pressure with height. The dependent variable is c dzdlnp, the vertical change in the height perturbation with c respect to the change in pressure. The slope that is returned c defines whether we've got a cold core or warm core system. c See Hart (MWR, April 2003, Vol 131, pp. 585-616) for more c details, specifically his Fig. 3 and the discussion surrounding. c Note that in the call to calccorr, we are sending only 6 of the c 7 elements of the dlnp and dzdlnp arrays, beginning with the c 2nd element of each. That's because the first array value for c each of those arrays is empty, since in the loop just above, we c start with kbeg+1, not kbeg. c ------------------------------------------------------------------ call calccorr(lnp(2),zdiff(2),6,R2,vth_slope) if ( verb .ge. 3 ) then print *,' ' print *,'++ In get_cps_vth, values for vth follow for ' & ,'lead time= ',ifhours(ifh),':',ifclockmins(ifh),' ' & ,storm(ist)%tcv_storm_id,' ',storm(ist)%tcv_storm_name print *,' ... clayer = ',clayer print *,' ' endif do k = kbeg,kend if (kbeg == 7) then kix = k - 6 else kix = k endif if ( verb .ge. 3 ) then print *,' ' write (6,31) k,plev(kix),zmax(kix),zmin(kix),zdiff(kix) if (kix > 1) then write (6,32) plev(kix),log(plev(kix)) & ,plev(kix-1),log(plev(kix-1)) write (6,33) dz(kix),dlnp(kix),dzdlnp(kix) else write (6,34) endif endif enddo 31 format (1x,' +++ k= ',i2,' press= ',f8.1,' zmax= ',f7.2 & ,' zmin= ',f7.2,' zdiff= ',f7.2) 32 format (1x,' ln(',f7.1,')= ',f9.6,' ln(',f7.1,')= ',f9.6) 33 format (1x,' dz= ',f10.2,' dlnp= ',f13.6,' dzdlnp= ',f12.3) 34 format (1x,' --- First level... no derivatives done...') c return end c C---------------------------------------------------- C C---------------------------------------------------- subroutine calccorr(xdat,ydat,numpts,R2,slope) c c This subroutine is the main driver for a series of c other subroutines below this that will calculate the c correlation between two input arrays, xdat and ydat. c c INPUT: c xdat array of x (independent) data points c ydat array of y (dependent) data points c numpts number of elements in each of xdat and ydat c c OUTPUT: c R2 R-squared, the coefficient of determination c slope Slope of regression line c c xdiff array of points for xdat - xmean c ydiff array of points for ydat - ymean c yestim array of regression-estimated points c yresid array of residuals (ydat(i) - yestim(i)) USE verbose_output implicit none real xdat(numpts),ydat(numpts) real xdiff(numpts),ydiff(numpts) real yestim(numpts),yresid(numpts) real xmean,ymean,slope,yint,R2 integer numpts,i c call getmean(xdat,numpts,xmean) call getmean(ydat,numpts,ymean) c call getdiff(xdat,numpts,xmean,xdiff) call getdiff(ydat,numpts,ymean,ydiff) c call getslope(xdiff,ydiff,numpts,slope) yint = ymean - slope * xmean c call getyestim(xdat,slope,yint,numpts,yestim) call getresid(ydat,yestim,numpts,yresid) c if ( verb .ge. 3 ) then print *,' ' print *,' *--------------------------------------------------* ' print *,' * CPS Thermal wind regression details * ' print *,' *--------------------------------------------------* ' endif call getcorr(yresid,ydiff,numpts,R2) if ( verb .ge. 3 ) then print *,' i ydat xdat ydiff xdiff e' & ,' e2 ydiff2' print *,' ---- ----- ----- ----- ----- ----- ' & ,' ----- -----' do i = 1,numpts write(6,'(2x,i3,2x,f7.2,2x,f7.4,2x,f7.2,2x,f7.4,3(2x,f7.2))') & i,ydat(i),xdat(i),ydiff(i) & ,xdiff(i),yresid(i),yresid(i)*yresid(i) & ,ydiff(i)*ydiff(i) enddo print *,' ---- ----- ----- ----- ----- ----- ' & ,' ----- -----' print *,' ' write (6,'(1x,a13,f9.3,3x,a5,f7.2)') ' means: y: ',ymean & ,' x: ',xmean write (6,*) ' ' write (6,30) 'slope= ',slope,' y-intercept = ',yint 30 format (2x,a7,f10.3,a23,f10.3) if (slope .gt. 0.0) then write(6,40) 'Regression equation: Y = ',yint,' + ',slope else write(6,40) 'Regression equation: Y = ',yint,' - ' & ,abs(slope) endif 40 format (2x,a27,f8.2,a3,f8.2,'X') c print *,' ' write (6,'(1x,a17,f7.4,5x,a7,f7.4)') ' R2(r_squared) = ',R2 & ,' r = ',sqrt(R2) print *,' ' print *,' *--------------------------------------------------* ' print *,' * End of regression details * ' print *,' *--------------------------------------------------* ' endif return end c-------------------------------------------c c c c-------------------------------------------c subroutine getmean(xarr,inum,zmean) c c This subroutine is part of the correlation calculation, c and it simply returns the mean of the input array, xarr. c c INPUT: c xarr input array of data points c inum number of data points in xarr c c OUTPUT: c zmean mean of data values in xarr implicit none real xarr(inum) real xsum,zmean integer i,inum c xsum = 0.0 do i = 1,inum xsum = xsum + xarr(i) enddo c zmean = xsum / float(MAX(inum,1)) c return end c-------------------------------------------c c c c-------------------------------------------c subroutine getdiff(xarr,inum,zmean,zdiff) c c This subroutine is part of the correlation calculation, c and it returns in the array zdiff the difference values c between each member of the input array xarr and the c mean value, zmean. c c INPUT: c xarr input array of data points c inum number of data points in xarr c zmean mean of input array (xarr) c c OUTPUT: c zdiff array containing xarr(i) - zmean implicit none real xarr(inum),zdiff(inum) real zmean integer i,inum c do i = 1,inum zdiff(i) = xarr(i) - zmean enddo c return end c-------------------------------------------c c c c-------------------------------------------c subroutine getslope(xarr,yarr,inum,slope) c c This subroutine is part of the correlation calculation, c and it returns the slope of the regression line. c c INPUT: c xarr input array of xdiffs (x - xmean) c yarr input array of ydiffs (y - ymean) c inum number of points in x & y arrays c c OUTPUT: c slope slope of regression line real xarr(inum),yarr(inum) real slope,sumxy,sumx2 integer i,inum c First sum up the xarr*yarr products.... sumxy = 0.0 do i = 1,inum sumxy = sumxy + xarr(i) * yarr(i) enddo c Now sum up the x-squared terms.... sumx2 = 0.0 do i = 1,inum sumx2 = sumx2 + xarr(i) * xarr(i) enddo c Now get the slope.... slope = sumxy / sumx2 return end c-------------------------------------------c c c c-------------------------------------------c subroutine getyestim(xarr,slope,yint,inum,yestim) c c This subroutine is part of the correlation calculation, c and it calculates all the predicted y-values using the c regression equation that has been calculated. c c INPUT: c xarr array of x data points c slope slope of the calculated regression line c yint y-intercept of the calculated regression line c inum number of input points c c OUTPUT: c yestim array of y pts estimated from regression eqn. implicit none real xarr(inum),yestim(inum) real slope,yint integer i,inum c do i = 1,inum yestim(i) = yint + xarr(i) * slope enddo c return end c-------------------------------------------c c c c-------------------------------------------c subroutine getresid(yarr,yestim,inum,yresid) c c This subroutine is part of the correlation calculation, c and it calculates all the residual values between the c input y data points and the y-estim predicted y values. c c INPUT: c yarr array of y data points c yestim array of y pts estimated from regression eqn. c inum number of input points c c OUTPUT: c yresid array of residuals (ydat(i) - yestim(i)) implicit none real yarr(inum),yestim(inum),yresid(inum) integer i,inum c do i = 1,inum yresid(i) = yarr(i) - yestim(i) enddo c return end c-------------------------------------------c c c c-------------------------------------------c subroutine getcorr(yresid,ydiff,inum,R2) c c This subroutine is part of the correlation calculation, c and it does the actual correlation calculation. c c INPUT: c yresid array of residuals (ydat(i) - yestim(i)) c ydiff array of points for ydat - ymean c inum number of points in the arrays c c OUTPUT: c R2 R-squared, the coefficient of determination USE verbose_output implicit none real yresid(inum),ydiff(inum) real R2,sumyresid,sumydiff integer i,inum c sumyresid = 0.0 sumydiff = 0.0 do i = 1,inum sumyresid = sumyresid + yresid(i) * yresid(i) sumydiff = sumydiff + ydiff(i) * ydiff(i) enddo if ( verb .ge. 3 ) then write (6,*) ' ' write (6,30) 'Sum of y-residuals squared (e2) = ',sumyresid write (6,30) 'Sum of y-diffs squared (ydiff2) = ',sumydiff write (6,*) ' ' 30 format (1x,a35,f15.2) endif if (sumydiff == 0.0) then R2=1.0 else R2 = 1 - sumyresid / sumydiff endif c return end c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine get_vtt_phase (inp,imax,jmax,dx,dy,ist,ifh,trkrinfo & ,fixlon,fixlat,valid_pt,maxstorm,wcore_flag,igvpret) c c ABSTRACT: This subroutine is part of the algorithm for determining c the structure, or phase, of a cyclone. Here, we are only looking c at the mid-to-upper tropospheric warm anomaly at the center of c the storm. The temperature data that we are searching through in c the tmean array should be the 300-500 mb mean temperature data. c The criteria in this algorithm are based loosely on Vitart's c criteria for warm core checking, but the nuts & bolts of the c subroutine use algorithms from this tracker, including the barnes c analysis. First, we locate the warm core with the find_maxmin c routine. Then we use the check_closed_contour routine to see if c there is a closed temperature contour surrounding the warm core. c c INPUT: c inp c imax Num pts in i direction on input grid c jmax Num pts in j direction on input grid c inp contains input date and model number information c dx Grid spacing in i-direction on input grid c dy Grid spacing in j-direction on input grid c ist integer storm number (internal to the tracker) c ifh integer index for lead time c trkrinfo derived type containing grid info on user boundaries c fixlon array containing found fix longitudes c fixlat array containing found fix latitudes c valid_pt Logical; bitmap indicating if valid data at that pt. c maxstorm maximum # of storms to be handled c c OUTPUT: c wcore_flag 'u'=undetermined, 'y'=yes, 'n'=no c igvpret Return code for this subroutine. c c LOCAL: c wcore_mean_val barnes-averaged value of the temperature at the c location where the tracker found the warm core. c wcore_point_max max temperature found at a gridpoint near the c location where the tracker found the warm core using c barnes analysis. USE set_max_parms; USE grid_bounds; USE trkrparms; USE contours USE tracked_parms; USE gen_vitals; USE def_vitals; USE inparms USE phase USE verbose_output implicit none type (trackstuff) trkrinfo,wcore_trkrinfo type (cint_stuff) wcore_contour_info type (datecard) inp character*1 get_last_contour_flag,wcore_flag real fixlon(maxstorm,maxtime),fixlat(maxstorm,maxtime) real dx,dy,wcore_mean_val,wcore_mean_lon,wcore_mean_lat real wcore_point_max,tlastcont,rlastcont,tlastout,rlastout integer imax,jmax,igvpret,ist,ifh,npts,bskip,i,j integer ilonfix,jlatfix,ibeg,jbeg,iend,jend,igiret integer icount,maxstorm,ip,ifmret,ifilret,ifix,jfix,icccret integer num_check_conts logical(1) valid_pt(imax,jmax),compflag,wcore_mask(imax,jmax) logical(1) output_file_open c if ( verb .ge. 3 ) then print *,' ' print *,'*-------------------------------------------------*' print *,'* At top of get_vtt_phase *' write (6,102) ifhours(ifh),ifclockmins(ifh) 102 format (1x,'* Searching for warm core at hour ',i4,':',i2.2) write (6,103) wcore_depth 103 format (1x,'* Warm core depth threshold (wcore_depth) = ',f7.2) print *,'*-------------------------------------------------*' endif c ------------------------------------------------------------ wcore_mask = .false. wcore_mean_lon = -999.0 wcore_mean_lat = -999.0 wcore_trkrinfo = trkrinfo ! set equal to values from trkrinfo... wcore_trkrinfo%contint = wcore_depth ! ...except use the warm ! core contour interval specified by ! the user in the extrkr.sh script. c ------------------------------------------------------------ c First, call find_maxmin to locate the warm core call find_maxmin (imax,jmax,dx,dy,'tmp' & ,tmean,'max',ist,fixlon(ist,ifh),fixlat(ist,ifh) & ,glon,glat,valid_pt,trkrinfo,compflag & ,wcore_mean_lon,wcore_mean_lat,wcore_mean_val & ,glatmax,glatmin,glonmax,glonmin,inp%modtyp,ifmret) if (verb .ge. 3) then print *,' ' print *,'After call to find_maxmin for wcore, ifmret= ',ifmret print *,' wcore_mean_val= ',wcore_mean_val endif c ------------------------------------------------------------ c Once find_maxmin returns a value and a location for the c barnes-averaged value of a warm core, then make a call to c fix_latlon_to_ij to (1) get the actual gridpoint value of the c temperature (the value stored in wcore_mean_val is an c area-averaged value coming from the barnes analysis), and c (2) to get the (i,j) indeces for this gridpoint to be used in c the call to check_closed_contour below. if (wcore_mean_lat > -99.0 .and. wcore_mean_lon > -990.0) then call fix_latlon_to_ij (imax,jmax,dx,dy,tmean,'max' & ,valid_pt,wcore_mean_lon,wcore_mean_lat & ,wcore_mean_val,ifix,jfix,wcore_point_max,'tracker' & ,glatmax,glatmin,glonmax,glonmin & ,trkrinfo,ifilret) if (ifilret == 0) then if ( verb .ge. 3 ) then print *,' ' print *,'+++ Warm core stats: ' write (6,105) storm(ist)%tcv_storm_id & ,gstorm(ist)%gv_gen_date & ,gstorm(ist)%gv_gen_fhr,gstorm(ist)%gv_gen_lat & ,gstorm(ist)%gv_gen_latns,gstorm(ist)%gv_gen_lon & ,gstorm(ist)%gv_gen_lonew,gstorm(ist)%gv_gen_type & ,ifhours(ifh),ifclockmins(ifh) & ,wcore_mean_lon,360.-wcore_mean_lon & ,wcore_mean_lat,wcore_mean_val write (6,106) storm(ist)%tcv_storm_id & ,gstorm(ist)%gv_gen_date & ,gstorm(ist)%gv_gen_fhr,gstorm(ist)%gv_gen_lat & ,gstorm(ist)%gv_gen_latns,gstorm(ist)%gv_gen_lon & ,gstorm(ist)%gv_gen_lonew,gstorm(ist)%gv_gen_type & ,ifhours(ifh),ifclockmins(ifh) & ,ifix,jfix,wcore_point_max endif else ! Search went out of regional grid bounds.... if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR IN get_vtt_phase. The call to ' print *,'!!! fix_latlon_to_ij returned a non-zero return ' print *,'!!! code, which means that the search for the fix' print *,'!!! i and j went out of bounds for a regional ' print *,'!!! grid. This should have been caught in a ' print *,'!!! previous call to find_maxmin for one of the ' print *,'!!! various fix parms. In any event, we will not' print *,'!!! search for a warm core for this storm and ' print *,'!!! lead time.' print *,' ' write (6,115) storm(ist)%tcv_storm_id & ,gstorm(ist)%gv_gen_date & ,gstorm(ist)%gv_gen_fhr,gstorm(ist)%gv_gen_lat & ,gstorm(ist)%gv_gen_latns,gstorm(ist)%gv_gen_lon & ,gstorm(ist)%gv_gen_lonew,gstorm(ist)%gv_gen_type & ,ifhours(ifh),ifclockmins(ifh) & ,'U',-999.99,-9999.99 endif igvpret = 95 wcore_flag = 'u' return endif endif 105 format (1x,' wcore: ',a4,1x,i10.10,'_F',i3.3,'_',i3.3,a1 & ,'_',i4.4,a1,'_',a3,2x,i4,':',i2.2,' mean_lon: ',f7.2,'E' & ,1x,'(',f7.2,'W)',2x,'mean_lat: ',f7.2,2x & ,'wcore_mean_val(K): ',f12.3) 106 format (1x,' wcore: ',a4,1x,i10.10,'_F',i3.3,'_',i3.3,a1 & ,'_',i4.4,a1,'_',a3,2x,i4,':',i2.2,' ifix: ',i5,2x & ,' jfix: ',i5,2x,'wcore_point_max(K): ',f12.3) c ------------------------------------------------------------ c The Vitart scheme specifies that the temperature must decrease c by at least 1.0C in all directions from the warm core center c within a distance of 8 deg. A rigorous check of this criterion c is performed here by utilizing the check_closed_contour routine. c If we have a closed contour in the temperature field c surrounding the warm core (using a 1 deg K interval), that c criterion is satisfied. For diagnostic purposes, we set the c value of num_check_conts to 999 in order to keep searching for c all contours surrounding the warm core, and this allows us to c get an idea of the "depth" or magnitude of the warm core when c the tlastcont and rlastcont values are returned. wcore_contour_info%numcont = maxconts num_check_conts = 999 get_last_contour_flag = 'y' call check_closed_contour (imax,jmax,ifix,jfix,tmean & ,valid_pt,wcore_mask,wcore_flag,'max',wcore_trkrinfo & ,num_check_conts,wcore_contour_info,get_last_contour_flag & ,tlastcont,rlastcont,icccret) if (wcore_flag == 'y') then tlastout = tlastcont rlastout = rlastcont/0.539638 else tlastout = -999.0 rlastout = -9999.0 endif if ( verb .ge. 3 ) then write (6,115) storm(ist)%tcv_storm_id,gstorm(ist)%gv_gen_date & ,gstorm(ist)%gv_gen_fhr,gstorm(ist)%gv_gen_lat & ,gstorm(ist)%gv_gen_latns,gstorm(ist)%gv_gen_lon & ,gstorm(ist)%gv_gen_lonew,gstorm(ist)%gv_gen_type & ,ifhours(ifh),ifclockmins(ifh) & ,wcore_flag,tlastout,rlastout 115 format (1x,' wcore: ',a4,1x,i10.10,'_F',i3.3,'_',i3.3,a1 & ,'_',i4.4,a1,'_',a3,2x,i4,':',i2.2 & ,' wcore_flag= ',a1,2x,' Temp of last contour(K) = ' & ,f7.2,2x,'Radius of last contour(km) = ',f8.2) endif return end c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine get_sfc_center (xmeanlon,xmeanlat,clon & ,clat,ist,ifh,calcparm,xsfclon,xsfclat & ,maxstorm,igscret) c c ABSTRACT: This subroutine computes a modified lat/lon fix position c to use as the input center position for the subroutines that c follow which calculate surface-wind related values. The reason c for this is that since we are concerned with the positioning of c low-level wind features (e.g., rmax), we want the center position c to be based solely on low-level features. We'll use mslp and the c min in the sfc wind speed. If a center fix was unable to be made c at this forecast hour for mslp and low-level winds, then we will c stick with just using the mean position we got using all the other c parameters. c c INPUT: c xmeanlon The mean center longitude computed from all the various c parameter fixes found in array clon c xmeanlat The mean center latitude computed from all the various c parameter fixes found in array clat c clon Center longitudes of tracked parms for this storm & ifh c clat Center latitudes of tracked parms for this storm & ifh c ist Index for storm number c ifh Index for forecast hour c calcparm Logical; Use this parm's location for this storm or not c (if a parameter fix could not be made at this forecast c hour, then calcparm is set to false for this time for c that parameter). c maxstorm Maximum number of storms that can be tracked c c OUTPUT: c xsfclon low-level longitude estimate for this storm & time, c computed ideally from mean of mslp & low-level winds. c xsfclat low-level latitude estimate for this storm & time, c computed ideally from mean of mslp & low-level winds. c igscret Return code from this subroutine USE set_max_parms USE verbose_output implicit none integer ist,ifh,ipct,igscret,maxstorm real clon(maxstorm,maxtime,maxtp) real clat(maxstorm,maxtime,maxtp) real xmeanlon,xmeanlat real xsfclon,xsfclat,xlonsum,xlatsum logical(1) calcparm(maxtp,maxstorm) ipct = 0 xlonsum = 0.0 xlatsum = 0.0 ! Do NOT include MSLP for the surface center at this time. c if (calcparm(9,ist)) then c ipct = ipct + 1 c xlonsum = xlonsum + clon(ist,ifh,9) c xlatsum = xlatsum + clat(ist,ifh,9) c endif if (calcparm(10,ist)) then c ! NOTE: Put double weighting on surface wind center if c ! the tracker was able to find a center for it.... c ipct = ipct + 2 c xlonsum = xlonsum + 2.*clon(ist,ifh,10) c xlatsum = xlatsum + 2.*clat(ist,ifh,10) ! Just use single weighting for the sfc wcirc fix ipct = ipct + 1 xlonsum = xlonsum + clon(ist,ifh,10) xlatsum = xlatsum + clat(ist,ifh,10) endif if (calcparm(11,ist)) then ! This is for the sfc vorticity center.... ipct = ipct + 1 xlonsum = xlonsum + clon(ist,ifh,11) xlatsum = xlatsum + clat(ist,ifh,11) endif if (ipct > 0) then xsfclon = xlonsum / float(ipct) xsfclat = xlatsum / float(ipct) else if ( verb .ge. 3 ) then print *,' ' print *,'!!! In get_fract_wind_cov, CANNOT get modified fix ' print *,'!!! position because the parameter fixes for mslp' print *,'!!! and the sfc winds could not be obtained at this' print *,'!!! forecast hour. ist= ',ist,' ifh= ',ifh print *,'!!! We will use the fixlon and fixlat values for' print *,'!!! this forecast hour.' endif xsfclon = xmeanlon xsfclat = xmeanlat endif if ( verb .ge. 3 ) then print *,' ' print *,'+++ In get_sfc_center, modified fix (mslp + sfc_winds)' print *,'+++ position follows: ' print *,'+++ ' print *,'+++ mslp: lon: ',clon(ist,ifh,9),' lat: ' & ,clat(ist,ifh,9) print *,'+++ sfc_winds: lon: ',clon(ist,ifh,10),' lat: ' & ,clat(ist,ifh,10) print *,'+++ sfc_vorticity: lon: ',clon(ist,ifh,11),' lat: ' & ,clat(ist,ifh,11) print *,'+++ multi-parm mean: lon: ',xmeanlon,' lat: ' & ,xmeanlat print *,'+++ sfc-only mean: lon: ',xsfclon,' lat: ',xsfclat endif return end c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine get_wind_structure (imax,jmax,inp,dx,dy & ,ist,ifh,fixlon,fixlat,xsfclon,xsfclat,valid_pt & ,er_wind,sr_wind,er_vr,sr_vr,er_vt,sr_vt,maxstorm & ,trkrinfo,igwsret) c c ABSTRACT: This subroutine is a driver subroutine for c determining the structure of the low level winds of a cyclone. c The algorithm will search out at specified distances from the c storm center along arcs in each quadrant of the storm, c evaluating the winds every 15 degrees along the arc. In each c arc, start 7.5 degrees in, then make stops at 22.5, 37.5, c 52.5, 67.5, and 82.5 degrees. At each of those points, we c will bilinearly interpolate the winds to the points along those c arcs. Then we compute a quadrant average of the wing magnitude, c as well as the mean Vt and Vr values. This will be done c twice -- First, for an earth-relative coordinate system, and c second, for a storm-relative coordinate system. For the c earth-relative estimates, we will always have 4 earth-relative c quadrants: NE, SE, SW and NW. For the storm-relative estimates, c these mean values of the wind will be computed for the same c relative quadrants (front-right, back-right, back-left, front- c left, but with respect (positive clockwise) to the c direction of storm motion. c c LOCAL: c numdist Number of discrete radii at which the winds will c be evaluated c rdist The radii (km) at which winds will be evaluated c c Arrays: c rdist Radii (km) at which the winds will be evaluated c er_wind: Quadrant winds in earth-relative framework c sr_wind: Quadrant winds in storm-relative framework c er_vr: Quadrant radial winds in earth-relative framework c sr_vr: Quadrant radial winds in storm-relative framework c er_vt: Quadrant tangential winds in earth-relative framework c sr_vt: Quadrant tangential winds in storm-relative framework USE inparms; USE phase; USE set_max_parms; USE tracked_parms USE def_vitals; USE trig_vals; USE trkrparms USE verbose_output implicit none type (datecard) inp type (trackstuff) trkrinfo integer, parameter :: numdist=14,numquad=4,num_qtr_azim=6 integer imax,jmax,igwsret,ist,ifh,iquad,idist,ibiret1,ibiret2 integer igvtret,ipct,maxstorm,iazim,azimuth_ct real fixlon(maxstorm,maxtime),fixlat(maxstorm,maxtime) real rdist(numdist) real er_wind(numquad,numdist) real sr_wind(numquad,numdist) real er_vr(numquad,numdist) real er_vt(numquad,numdist) real sr_vr(numquad,numdist) real sr_vt(numquad,numdist) real dx,dy,bear,targlat,targlon,xintrp_u,xintrp_v,st_heading real d,cosarg,rlonc,rlatc,rlonb,rlatb,st_heading_rad,degrees real temp_bear,xdist,xsfclon,xsfclat,wmag,wmag_sum real vr,vt,vr_sum,vt_sum logical(1) valid_pt(imax,jmax) c data rdist/10.,25.,50.,75.,100.,125.,150.,200.,250.,300.,350. & ,400.,450.,500./ igwsret = 0 er_wind = 0.0 sr_wind = 0.0 er_vr = 0.0 er_vt = 0.0 sr_vr = 0.0 sr_vt = 0.0 c ----------------------------------------------------------------- c Now determine the angle that the storm took getting from the c last position to the current one. If this is the initial time, c use the observed direction of motion from the TC Vitals. This c may not match up with the model storm's initial direction of c motion, but it is all we have available to us in order to get c a heading estimate for the initial time. This storm heading c information will be used for the storm-relative profiles. c ----------------------------------------------------------------- if (ifh == 1) then st_heading = float(storm(ist)%tcv_stdir) else call calcdist(fixlon(ist,ifh),fixlat(ist,ifh) & ,fixlon(ist,ifh-1),fixlat(ist,ifh-1),xdist,degrees) rlonc = (360.-fixlon(ist,ifh)) * dtr rlatc = fixlat(ist,ifh) * dtr rlonb = (360.-fixlon(ist,ifh-1)) * dtr rlatb = fixlat(ist,ifh-1) * dtr d = degrees * dtr cosarg = (sin(rlatc)-sin(rlatb)*cos(d))/(sin(d)*cos(rlatb)) if (cosarg > 1.0) cosarg = 1 if (cosarg < -1.0) cosarg = -1 if (sin(rlonc-rlonb) < 0.0) then st_heading_rad = acos(cosarg) else st_heading_rad = 2*pi - acos(cosarg) endif st_heading = st_heading_rad / dtr if ( verb .ge. 3 ) then print *,' ' print *,' In get_wind_structure, fhr= ',fhreal(ifh) & ,' ',storm(ist)%tcv_storm_id & ,' ',storm(ist)%tcv_storm_name print '(a25,a23,f9.3)',' In get_wind_structure, ' & ,' model storm heading = ',st_heading print *,' ' endif endif c ----------------------------------------------------------------- c Get the profiles for the earth-relative coordinate system. c Start with NE, then SE, SW, and NW. First go through c radiusloop, which goes from one radial distance to the next, c then do the quadloop, which goes through each quadrant, and c then within each quadrant, the qtr_azimloop goes through for c six points along an arc, spaced 15 degrees apart, starting at c 7.5 degrees clockwise from the north. c ----------------------------------------------------------------- if ( verb .ge. 3 ) then print *,' ' print *,' *****************************************************' print *,' Wind Structure: distbear bilin interp starts here.' print *,' *****************************************************' print *,' ' endif radiusloop1: do idist = 1,numdist if ( verb .ge. 3 ) then print *,'-- ER structure idist= ',idist,' rdist= ' & ,rdist(idist) endif quadloop1: do iquad = 1,4 if ( verb .ge. 3 ) then print *,' structure iquad= ',iquad endif wmag_sum = 0.0 vr_sum = 0.0 vt_sum = 0.0 azimuth_ct = 0 ! In each quadrant, run through six points along an ! arc and evaluate the winds. qtr_azimloop1: do iazim = 1,num_qtr_azim bear = ((iquad-1) * 90.) + ((iazim-1) * 15.) + 7.5 if ( verb .ge. 3 ) then print *,' structure iazim= ',iazim & ,' earth-relative bear= ',bear endif call distbear (xsfclat,xsfclon,rdist(idist) & ,bear,targlat,targlon) if ( verb .ge. 3 ) then print *,' ' print '(5(a10,f7.2))',' sfclat= ',xsfclat & ,' sfclon= ',xsfclon & ,' rdist= ',rdist(idist),' targlat= ',targlat & ,' targlon= ',targlon print '(19x,a8,f7.2,35x,a9,f7.2)','sfclon= ',360.-xsfclon & ,'targlon= ',360.-targlon endif ! NOTE: The 1020 in the call here is just a number/code to ! indicate to the subroutine to process sfc winds.... call bilin_int_uneven (targlat,targlon & ,dx,dy,imax,jmax,trkrinfo,1020,'u',xintrp_u,ibiret1) call bilin_int_uneven (targlat,targlon & ,dx,dy,imax,jmax,trkrinfo,1020,'v',xintrp_v,ibiret2) if (ibiret1 == 0 .and. ibiret2 == 0) then wmag = sqrt (xintrp_u**2 + xintrp_v**2) wmag_sum = wmag_sum + wmag call getvrvt (xsfclon,xsfclat,targlon,targlat & ,xintrp_u,xintrp_v,vr & ,vt,igvtret) vr_sum = vr_sum + vr vt_sum = vt_sum + vt azimuth_ct = azimuth_ct + 1 if ( verb .ge. 3 ) then print '(2x,a21,f8.2,a14,f8.2,2(a11,f8.2))' & ,' intrp wind speed= ' & ,wmag,' (in kts)= ',wmag*1.9427 & ,' vr(m/s)= ',vr,' vt(m/s)= ',vt endif endif enddo qtr_azimloop1 if (azimuth_ct > 0) then ! Compute quadrant-azimuthally-averaged winds at ! this distance er_wind(iquad,idist) = wmag_sum / float(azimuth_ct) er_vr(iquad,idist) = vr_sum / float(azimuth_ct) er_vt(iquad,idist) = vt_sum / float(azimuth_ct) else er_wind(iquad,idist) = -999.0 er_vr(iquad,idist) = -999.0 er_vt(iquad,idist) = -999.0 endif enddo quadloop1 enddo radiusloop1 c ----------------------------------------------------------------- c Get the profiles for the storm-relative coordinate system. c Start with the front-right quadrant and go clockwise through c back-right, back-left and front-left. c ----------------------------------------------------------------- radiusloop2: do idist = 1,numdist if ( verb .ge. 3 ) then print *,'-- SR structure idist= ',idist,' rdist= ' & ,rdist(idist) endif quadloop2: do iquad = 1,4 if ( verb .ge. 3 ) then print *,' structure iquad= ',iquad endif wmag_sum = 0.0 vr_sum = 0.0 vt_sum = 0.0 azimuth_ct = 0 qtr_azimloop2: do iazim = 1,num_qtr_azim c temp_bear = st_heading + ((iquad-1) * 90.) + 45. temp_bear = st_heading + ((iquad-1) * 90.) & + ((iazim-1) * 15.) + 7.5 bear = mod(temp_bear,360.) if ( verb .ge. 3 ) then print *,' structure iazim= ',iazim & ,' storm-relative bear= ',bear endif call distbear (xsfclat,xsfclon,rdist(idist) & ,bear,targlat,targlon) ! NOTE: The 1020 in the call here is just a number/code to ! indicate to the subroutine to process sfc winds.... call bilin_int_uneven (targlat,targlon & ,dx,dy,imax,jmax,trkrinfo,1020,'u',xintrp_u,ibiret1) call bilin_int_uneven (targlat,targlon & ,dx,dy,imax,jmax,trkrinfo,1020,'v',xintrp_v,ibiret2) if (ibiret1 == 0 .and. ibiret2 == 0) then wmag = sqrt (xintrp_u**2 + xintrp_v**2) wmag_sum = wmag_sum + wmag call getvrvt (xsfclon,xsfclat,targlon,targlat & ,xintrp_u,xintrp_v,vr & ,vt,igvtret) vr_sum = vr_sum + vr vt_sum = vt_sum + vt azimuth_ct = azimuth_ct + 1 if ( verb .ge. 3 ) then print '(2x,a21,f8.2,a14,f8.2,2(a11,f8.2))' & ,' intrp wind speed= ' & ,wmag,' (in kts)= ',wmag*1.9427 & ,' vr(m/s)= ',vr,' vt(m/s)= ',vt endif endif enddo qtr_azimloop2 if (azimuth_ct > 0) then ! Compute quadrant-azimuthally-averaged winds at ! this distance sr_wind(iquad,idist) = wmag_sum / float(azimuth_ct) sr_vr(iquad,idist) = vr_sum / float(azimuth_ct) sr_vt(iquad,idist) = vt_sum / float(azimuth_ct) else sr_wind(iquad,idist) = -999.0 sr_vr(iquad,idist) = -999.0 sr_vt(iquad,idist) = -999.0 endif enddo quadloop2 enddo radiusloop2 c return end c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine get_fract_wind_cov (imax,jmax,inp,dx,dy & ,ist,ifh,fixlon,fixlat,xsfclon,xsfclat,valid_pt & ,calcparm,wfract_cov,pdf_ct_bin,pdf_ct_tot,maxstorm & ,trkrinfo,igfwret) c c ABSTRACT: This subroutine determines the fractional areal coverage c of winds exceeding various thresholds within specified arcs c (e.g., 200 km, 400 km, etc) in each quadrant of a storm. The bins c that are used go as follows: (1) 0-100; (2) 0-200; (3) 0-300; c (4) 0-400; (5) 0-500. c c LOCAL: c numdist Number of discrete radii at which the winds will c be evaluated c rdist The radii (km) at which winds will be evaluated c c Arrays: c rdist Radii (km) at which the winds will be evaluated USE inparms; USE phase; USE set_max_parms; USE tracked_parms USE def_vitals; USE trig_vals; USE grid_bounds; USE level_parms USE trkrparms USE verbose_output implicit none type (datecard) inp type (trackstuff) trkrinfo integer, parameter :: numdist=14,numquad=4,numbin=5,numthresh=3 real fixlon(maxstorm,maxtime),fixlat(maxstorm,maxtime) real rdist(numdist) real wfract_cov(numquad+1,numbin,numthresh) real area_total_quad_bin(numquad,numbin) real area_exceed_quad_bin(numquad,numbin,numthresh) real xintlon,xintlat real :: windthresh(numthresh) = (/17.5,25.74,32.94/) real dx,dy,bear,targlat,targlon,xintrp_u,xintrp_v,st_heading real d,cosarg,rlonc,rlatc,rlonb,rlatb,st_heading_rad,degrees real temp_bear,xdist,conv_ms_knots,vmagkts real rads,ri,dell,vmag,xarea,grdintincr,xsfclon,xsfclat real sum_exceed_area(numbin,numthresh) real sum_total_area(numbin,numthresh) integer pdf_ct_bin(16) integer imax,jmax,igwsret,ist,ifh,iquad,idist,ibiret1,ibiret2 integer igfwret,ipct,i,j,numinterp,ixoa,ixaa,iq,ib,it,ii integer jlatfix,ilonfix,npts,ibeg,iend,jbeg,jend,ngridint,ni,nj integer itret,igiret,idistbin,ipdfbin,pdf_ct_tot,maxstorm logical(1) calcparm(maxtp,maxstorm) logical(1) valid_pt(imax,jmax) character got_pdf*6 character*2 :: cquad(4) = (/'NE','SE','SW','NW'/) character*5 :: cbin(5) = & (/'0-100','0-200','0-300','0-400','0-500'/) character*2 :: cthresh(3) = (/'34','50','64'/) c igfwret = 0 conv_ms_knots = 1.9427 rads = 500.0 ri = 300.0 dell = (dx+dy)/2. npts = rads/(dtk*dell) wfract_cov = 0.0 area_total_quad_bin = 0.0 area_exceed_quad_bin = 0.0 sum_exceed_area = 0.0 sum_total_area = 0.0 c Call get_ij_bounds in order to get the dimensions for a smaller c subdomain of grid points to search over. call get_ij_bounds (npts,0,ri,imax,jmax,dx,dy & ,glatmax,glatmin,glonmax,glonmin,xsfclon,xsfclat & ,trkrinfo,ilonfix,jlatfix,ibeg,jbeg,iend,jend,igiret) if (igiret /= 0) then if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in get_fract_wind_cov from call to ' print *,'!!! get_ij_bounds, stopping processing for storm' print *,'!!! number ',ist endif igfwret = 92 return endif if (ibeg < 1) then if (trkrinfo%gridtype == 'global') then if ( verb .ge. 3 ) then print *,' ' print *,'!!! NOTE: In get_fract_wind_cov, the ibeg returned' print *,'!!! from get_ij_bounds is < 1, but our gridtype is' print *,'!!! global, so we are going to leave it as is and ' print *,'!!! account for the grid wrapping as we go.' print *,' ' endif else if ( verb .ge. 3 ) then print *,' ' print *,'!!! NOTE: In get_fract_wind_cov, the ibeg returned' print *,'!!! from get_ij_bounds is < 1, and our gridtype is' print *,'!!! NOT global, so we are going to abort the ' print *,'!!! fractional wind coverage processing for' print *,'!!! this time.' print *,' ' endif igfwret = 94 return endif endif if (ibeg > imax .or. jbeg > jmax .or. jbeg < 1 .or. & iend < 1 .or. jend < 1) then if ( verb .ge. 1 ) then print *,' ' print *,'ERROR in get_fract_wind_cov calculating ibeg, iend,' print *,'jbeg or jend. ibeg= ',ibeg,' iend= ',iend print *,' jbeg= ',jbeg,' jend= ',jend print *,' imax= ',imax,' jmax= ',jmax print *,'fractional wind coverage processing will not be ' print *,'performed for this time.' endif igfwret = 94 return endif if (iend > imax) then if (trkrinfo%gridtype == 'global') then if ( verb .ge. 3 ) then print *,' ' print *,'!!! NOTE: In get_fract_wind_cov, the iend returned' print *,'!!! from get_ij_bounds is > imax, but our gridtype' print *,'!!! is global, so we are going to leave it as is ' print *,'!!! and account for the grid wrapping.' print *,' ' endif else if ( verb .ge. 3 ) then print *,' ' print *,'!!! NOTE: In get_fract_wind_cov, the iend returned' print *,'!!! from get_ij_bounds is > imax, and our gridtype' print *,'!!! is NOT global, so we will abort the ' print *,'!!! fractional wind coverage processing for' print *,'!!! this time.' print *,' ' endif igfwret = 94 return endif endif c When evaluating the winds at a gridpoint, keep in mind that each c gridpoint represents area around it. There are 2 special cases c we need to watch out for. The first is for cases in which the c area of a gridpoint straddles across a distance threshold, so c that some of the gridpoint's area is in the "<200" bin, while c some is in the "<100" bin. The other is for the case in which c the area of a gridpoint straddles between 2 adjacent quadrants c (e.g., a gridpoint exactly to the north of the center would have c half its area in the NW quadrant and half in the NE quadrant). c c To properly "partition" and assign gridpoint areas, we need to c interpolate the current grid down to a fine resolution. c c This next if statement determines how many times to interpolate c the input grid to a smaller grid. Here are the guidelines that c will be used, keeping in mind that we want the final grid spacing c to be on the order of between 0.05 and 0.10 degree (finer than c 0.05 deg is superfluous, and coarser than 0.10 deg is too coarse). c c Original grid size (deg) # of interps c ------------------------- ------------ c 0.8 <= g 4 c 0.4 <= g < 0.8 3 c 0.2 <= g < 0.4 2 c 0.1 <= g < 0.2 1 c g < 0.1 0 if ((dx+dy)/2. >= 0.8) then numinterp = 4 else if ((dx+dy)/2. < 0.8 .and. (dx+dy)/2. >= 0.4) then numinterp = 3 else if ((dx+dy)/2. < 0.4 .and. (dx+dy)/2. >= 0.2) then numinterp = 2 else if ((dx+dy)/2. < 0.2 .and. (dx+dy)/2. >= 0.1) then numinterp = 1 else numinterp = 0 endif grdintincr = (dx+dy)/2. do i = 1,numinterp grdintincr = 0.5 * grdintincr enddo c Now loop through the points in this subdomain, determine if any c are within 500 km of the center, and then determine what quadrant c the point is in relative to the center, and then calculate the c fractional area coverage for winds. pdf_ct_tot = 0 pdf_ct_bin = 0 jloop: do j = jbeg,jend iloop: do i = ibeg,iend if (i > imax) then if (trkrinfo%gridtype == 'global') then ii = i - imax ! If wrapping past GM else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: In get_fract_wind_cov, the ' print *,'!!! user-requested eastern search boundary' print *,'!!! is beyond the eastern bounds of ' print *,'!!! this regional grid. We will not ' print *,'!!! perform the fractional wind coverage' print *,'!!! processing for this storm & time.' print *,'!!! ' print *,'!!! imax of regional grid = ',imax print *,'!!! User-requested eastern i = ',i print *,' ' endif igfwret = 94 return endif else ii = i endif if (i < 1) then if (trkrinfo%gridtype == 'global') then ii = i + imax ! If wrapping past GM else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: i < 1 in get_fract_wind_cov' print *,'!!! for a non-global grid. We will not ' print *,'!!! perform the fractional wind coverage' print *,'!!! processing for this storm & time.' print *,'!!! ' print *,'!!! imax of regional grid = ',imax print *,'!!! User-requested eastern i = ',i print *,' ' endif igfwret = 94 return endif endif if (.not. valid_pt(ii,j)) then cycle iloop ! Only an issue for regional grids endif call calcdist (glon(ii),glat(j),xsfclon,xsfclat,xdist,degrees) if (xdist > (rads+(0.75*((dx+dy)/2.)*dtk*cos(glat(j)*dtr)))) & then ! If the distance is greater than "rads" (500 km at initial ! writing) plus another 3/4 of a gridpoint, then cycle. ! The extra 3/4 of a gridpoint is to allow for the case of ! some portion of the area around a gridpoint (whose ! center point > 500 km) being within the 500 km arc... ! although that is only factored in for grids with spacing ! >= 0.1 deg. For smaller grids, where no interpolation is ! done in this subroutine, then the distance to that point ! is considered representative and the point is ignored if ! it is not less than 500 km from the center. cycle iloop else ! First interpolate the area surrounding each grid point to ! get fine resolution of lats & lons for determining how to ! partition the area of a gridpoint among quadrants as well ! as among distance thresholds. vmag = sqrt (u(ii,j,levsfc)**2 + v(ii,j,levsfc)**2) vmagkts = vmag * conv_ms_knots if (numinterp > 0) then grdintincr = ((dx+dy)/2.) / 2**numinterp ! "grid spacing" ! of interpolated grid ngridint = (2**numinterp) / 2 got_pdf = 'notyet' njloop: do nj= ngridint,-ngridint,-1 xintlat = glat(j) + float(nj) * grdintincr niloop: do ni= -ngridint,ngridint xintlon = glon(ii) + float(ni) * grdintincr call calcdist (xintlon,xintlat,xsfclon & ,xsfclat,xdist,degrees) if (xdist <= 350. .and. got_pdf == 'notyet') then ! The got_pdf flag is needed because in these loops ! for niloop & njloop, we are actually looking at ! tiny areas around the same grid point. So we ! want to make sure we only count each gridpoint ! once. ipdfbin = min((int(vmagkts / 10.) + 1),16) pdf_ct_bin(ipdfbin) = pdf_ct_bin(ipdfbin) + 1 pdf_ct_tot = pdf_ct_tot + 1 got_pdf = 'got_it' endif if (xdist < 500.) then ! Compute area of this fraction of a grid box xarea = (grdintincr * 111195) * & (grdintincr * 111195 & * cos(xintlat * dtr)) idistbin = int(xdist / 100.) + 1 ! Go through a loop of the bins. The purpose of ! this is that these "bins" all go from the ! the center out to a specified radius, they are ! NOT 100-km wide bins. So if we are dealing with ! a point at r = 250 km, then that falls in the ! 0-300 km bin, but it also falls in the 0-400 and ! 0-500 km bins as well. So we need to run through ! this binloop multiple times to get the area data ! into multiple bins. Here are the bins & indices: ! 1: 0-100 km ! 2: 0-200 km ! 3: 0-300 km ! 4: 0-400 km ! 5: 0-500 km binloop: do ib = idistbin,numbin if (xintlon >= xsfclon .and. & xintlat >= xsfclat) then ! NE quadrant area_total_quad_bin(1,ib) = & area_total_quad_bin(1,ib) + xarea if (vmag > windthresh(1)) then area_exceed_quad_bin(1,ib,1) = & area_exceed_quad_bin(1,ib,1) + xarea endif if (vmag > windthresh(2)) then area_exceed_quad_bin(1,ib,2) = & area_exceed_quad_bin(1,ib,2) + xarea endif if (vmag > windthresh(3)) then area_exceed_quad_bin(1,ib,3) = & area_exceed_quad_bin(1,ib,3) + xarea endif else if (xintlon >= xsfclon .and. & xintlat < xsfclat) then ! SE quadrant area_total_quad_bin(2,ib) = & area_total_quad_bin(2,ib) + xarea if (vmag > windthresh(1)) then area_exceed_quad_bin(2,ib,1) = & area_exceed_quad_bin(2,ib,1) + xarea endif if (vmag > windthresh(2)) then area_exceed_quad_bin(2,ib,2) = & area_exceed_quad_bin(2,ib,2) + xarea endif if (vmag > windthresh(3)) then area_exceed_quad_bin(2,ib,3) = & area_exceed_quad_bin(2,ib,3) + xarea endif else if (xintlon < xsfclon .and. & xintlat < xsfclat) then ! SW quadrant area_total_quad_bin(3,ib) = & area_total_quad_bin(3,ib) + xarea if (vmag > windthresh(1)) then area_exceed_quad_bin(3,ib,1) = & area_exceed_quad_bin(3,ib,1) + xarea endif if (vmag > windthresh(2)) then area_exceed_quad_bin(3,ib,2) = & area_exceed_quad_bin(3,ib,2) + xarea endif if (vmag > windthresh(3)) then area_exceed_quad_bin(3,ib,3) = & area_exceed_quad_bin(3,ib,3) + xarea endif else if (xintlon < xsfclon .and. & xintlat >= xsfclat) then ! NW quadrant area_total_quad_bin(4,ib) = & area_total_quad_bin(4,ib) + xarea if (vmag > windthresh(1)) then area_exceed_quad_bin(4,ib,1) = & area_exceed_quad_bin(4,ib,1) + xarea endif if (vmag > windthresh(2)) then area_exceed_quad_bin(4,ib,2) = & area_exceed_quad_bin(4,ib,2) + xarea endif if (vmag > windthresh(3)) then area_exceed_quad_bin(4,ib,3) = & area_exceed_quad_bin(4,ib,3) + xarea endif endif enddo binloop endif enddo niloop enddo njloop else ! In this else statement is the case for a grid whose ! resolution is already fine enough that we don't need ! to interpolate any further. For example, we will have ! the H*Wind data on a 0.05 degree grid, so that's already ! fine enough. call calcdist (glon(ii),glat(j),xsfclon,xsfclat & ,xdist,degrees) if (xdist <= 350.) then ipdfbin = min((int(vmagkts / 10.) + 1),16) pdf_ct_bin(ipdfbin) = pdf_ct_bin(ipdfbin) + 1 pdf_ct_tot = pdf_ct_tot + 1 endif if (xdist < 500.) then ! Compute area of this grid box xarea = (dy * 111195) * & (dx * 111195 * cos(glat(j) * dtr)) idistbin = int(xdist / 100.) + 1 ! Why the binloop2? See explanation above in the "if" ! part of this if-then block, where binloop is. binloop2: do ib = idistbin,numbin if (glon(ii) >= xsfclon .and. & glat(j) >= xsfclat) then ! NE quadrant area_total_quad_bin(1,ib) = & area_total_quad_bin(1,ib) + xarea if (vmag > windthresh(1)) then area_exceed_quad_bin(1,ib,1) = & area_exceed_quad_bin(1,ib,1) + xarea endif if (vmag > windthresh(2)) then area_exceed_quad_bin(1,ib,2) = & area_exceed_quad_bin(1,ib,2) + xarea endif if (vmag > windthresh(3)) then area_exceed_quad_bin(1,ib,3) = & area_exceed_quad_bin(1,ib,3) + xarea endif else if (glon(ii) >= xsfclon .and. & glat(j) < xsfclat) then ! SE quadrant area_total_quad_bin(2,ib) = & area_total_quad_bin(2,ib) + xarea if (vmag > windthresh(1)) then area_exceed_quad_bin(2,ib,1) = & area_exceed_quad_bin(2,ib,1) + xarea endif if (vmag > windthresh(2)) then area_exceed_quad_bin(2,ib,2) = & area_exceed_quad_bin(2,ib,2) + xarea endif if (vmag > windthresh(3)) then area_exceed_quad_bin(2,ib,3) = & area_exceed_quad_bin(2,ib,3) + xarea endif else if (glon(ii) < xsfclon .and. & glat(j) < xsfclat) then ! SW quadrant area_total_quad_bin(3,ib) = & area_total_quad_bin(3,ib) + xarea if (vmag > windthresh(1)) then area_exceed_quad_bin(3,ib,1) = & area_exceed_quad_bin(3,ib,1) + xarea endif if (vmag > windthresh(2)) then area_exceed_quad_bin(3,ib,2) = & area_exceed_quad_bin(3,ib,2) + xarea endif if (vmag > windthresh(3)) then area_exceed_quad_bin(3,ib,3) = & area_exceed_quad_bin(3,ib,3) + xarea endif else if (glon(ii) < xsfclon .and. & glat(j) >= xsfclat) then ! NW quadrant area_total_quad_bin(4,ib) = & area_total_quad_bin(4,ib) + xarea if (vmag > windthresh(1)) then area_exceed_quad_bin(4,ib,1) = & area_exceed_quad_bin(4,ib,1) + xarea endif if (vmag > windthresh(2)) then area_exceed_quad_bin(4,ib,2) = & area_exceed_quad_bin(4,ib,2) + xarea endif if (vmag > windthresh(3)) then area_exceed_quad_bin(4,ib,3) = & area_exceed_quad_bin(4,ib,3) + xarea endif endif enddo binloop2 endif endif endif enddo iloop enddo jloop c ------------------------------------------------- c Now compute the fractional wind coverage for all c the different quadrants, bins and thresholds... c ------------------------------------------------- if ( verb .ge. 3 ) then write (6,109) ' ' & ,' ' & ,' ' write (6,109) ' Quadrant Bin Wind_Thresh ' & ,'Fract_coverage (%) Area_exceeded' & ,' Area_total' write (6,109) ' -------- --- ----------- ' & ,'------------------ -------------' & ,' ----------' write (6,109) ' ' & ,' ' & ,' ' do iq = 1,numquad do ib = 1,numbin do it = 1,numthresh wfract_cov(iq,ib,it) = area_exceed_quad_bin(iq,ib,it) / & area_total_quad_bin(iq,ib) write (6,117) cquad(iq),cbin(ib),cthresh(it) & ,wfract_cov(iq,ib,it)*100.0 & ,area_exceed_quad_bin(iq,ib,it) & ,area_total_quad_bin(iq,ib) enddo enddo enddo endif 109 format (1x,a33,a37,a16) 117 format (5x,a2,5x,a5,7x,a2,13x,f6.2,10x,f16.1,2x,f16.1) c ------------------------------------------------- c Now compute the fractional wind coverage for all c the different bins and thresholds, but for the c entire "disc" of the storm, that is, summing all c quadrants together. c ------------------------------------------------- do it = 1,numthresh do ib = 1,numbin do iq = 1,numquad sum_total_area(ib,it) = sum_total_area(ib,it) & + area_total_quad_bin(iq,ib) sum_exceed_area(ib,it) = sum_exceed_area(ib,it) & + area_exceed_quad_bin(iq,ib,it) enddo wfract_cov(5,ib,it) = sum_exceed_area(ib,it) & / sum_total_area(ib,it) enddo enddo if ( verb .ge. 3 ) then do ib = 1,numbin do it = 1,numthresh write (6,117) 'TT',cbin(ib),cthresh(it) & ,wfract_cov(5,ib,it)*100.0 & ,sum_exceed_area(ib,it) & ,sum_total_area(ib,it) enddo enddo endif return end c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine get_ike_stats (imax,jmax,inp,dx,dy,ist,ifh & ,fixlon,fixlat,xsfclon,xsfclat,valid_pt,calcparm & ,ike,sdp,wdp,maxstorm,trkrinfo,igisret) c c ABSTRACT: This subroutine computes the Integrated Kinetic Energy c (IKE) and Storm Surge Damage Potential (SDP) values, based on c Powell (BAMS, 2007). At this time, we are only computing the IKE c values for TS threshold (17.5 m/s) and above. We are not yet c computing wind damage potential (WDP) since, per Mark Powell c (4/2008), he is currently re-formulating an algorithm for it. c c LOCAL: c c Arrays: c c ike Integrated kinetic energy: c ike(1) = IKE_10m/s (storm energy) c ike(2) = IKE_18m/s (IKE_ts, tropical storm) c ike(3) = IKE_33m/s (IKE_h, hurricane) c ike(4) = IKE_25_40 m/s (Not currently computed) c ike(5) = IKE_41_54 m/s (Not currently computed) c ike(6) = IKE_55 m/s (Not currently computed) c c sdp Storm surge damage potential USE inparms; USE phase; USE set_max_parms; USE tracked_parms USE def_vitals; USE trig_vals; USE grid_bounds; USE level_parms USE trkrparms USE verbose_output implicit none type (datecard) inp type (trackstuff) trkrinfo integer, parameter :: numdist=14,numquad=4 integer npts,ipct,igisret,imax,jmax,ist,ifh,ilonfix,jlatfix integer ibeg,jbeg,iend,jend,igiret,i,j,maxstorm,ii real fixlon(maxstorm,maxtime),fixlat(maxstorm,maxtime) real ike(max_ike_cats) real dx,dy,degrees,rads,ri,dell,xdist,vmag,xarea real xsfclon,xsfclat,sdp,wdp logical(1) calcparm(maxtp,maxstorm) logical(1) valid_pt(imax,jmax) c igisret = 0 ike = 0.0 sdp = 0.0 wdp = 0.0 rads = 400.0 ri = 300.0 dell = (dx+dy)/2. npts = rads/(dtk*dell) c Call get_ij_bounds in order to get the dimensions for a smaller c subdomain of grid points to search over. call get_ij_bounds (npts,0,ri,imax,jmax,dx,dy & ,glatmax,glatmin,glonmax,glonmin,xsfclon,xsfclat & ,trkrinfo,ilonfix,jlatfix,ibeg,jbeg,iend,jend,igiret) if (igiret /= 0) then if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in get_ike_stats from call to ' print *,'!!! get_ij_bounds, STOPPING processing for storm ' print *,'!!! number ',ist endif igisret = 92 return endif if (ibeg < 1) then if (trkrinfo%gridtype == 'global') then if ( verb .ge. 3 ) then print *,' ' print *,'!!! NOTE: In get_ike_stats, the ibeg returned' print *,'!!! from get_ij_bounds is < 1, but our gridtype is' print *,'!!! global, so we are going to leave it as is and ' print *,'!!! account for the grid wrapping as we go.' print *,' ' endif else if ( verb .ge. 3 ) then print *,' ' print *,'!!! NOTE: In get_ike_stats, the ibeg returned' print *,'!!! from get_ij_bounds is < 1, and our gridtype is' print *,'!!! NOT global, so we are going to abort the ' print *,'!!! fractional wind coverage processing for' print *,'!!! this time.' print *,' ' endif igisret = 94 return endif endif if (ibeg > imax .or. jbeg > jmax .or. jbeg < 1 .or. & iend < 1 .or. jend < 1) then if ( verb .ge. 1 ) then print *,' ' print *,'ERROR in get_ike_stats calculating ibeg, iend,' print *,'jbeg or jend. ibeg= ',ibeg,' iend= ',iend print *,' jbeg= ',jbeg,' jend= ',jend print *,' imax= ',imax,' jmax= ',jmax print *,'fractional wind coverage processing will not be ' print *,'performed for this time.' endif igisret = 94 return endif if (iend > imax) then if (trkrinfo%gridtype == 'global') then if ( verb .ge. 3 ) then print *,' ' print *,'!!! NOTE: In get_ike_stats, the iend returned' print *,'!!! from get_ij_bounds is > imax, but our gridtype' print *,'!!! is global, so we are going to leave it as is ' print *,'!!! and account for the grid wrapping.' print *,' ' endif else if ( verb .ge. 3 ) then print *,' ' print *,'!!! NOTE: In get_ike_stats, the iend returned' print *,'!!! from get_ij_bounds is > imax, and our gridtype' print *,'!!! is NOT global, so we will abort the ' print *,'!!! fractional wind coverage processing for' print *,'!!! this time.' print *,' ' endif igisret = 94 return endif endif c Search a grid of points near the storm center, evaluate if the c storm is within the "rads" distance threshold. If so, compute c the IKE values for all applicable thresholds (10, 18, 33 m/s). do j = jbeg,jend do i = ibeg,iend if (i > imax) then if (trkrinfo%gridtype == 'global') then ii = i - imax ! If wrapping past GM else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: In get_ike_stats, the ' print *,'!!! user-requested eastern search boundary' print *,'!!! is beyond the eastern bounds of ' print *,'!!! this regional grid. We will not ' print *,'!!! perform the ike stats' print *,'!!! processing for this storm & time.' print *,'!!! ' print *,'!!! imax of regional grid = ',imax print *,'!!! User-requested eastern i = ',i print *,' ' endif igisret = 94 return endif else ii = i endif if (i < 1) then if (trkrinfo%gridtype == 'global') then ii = i + imax ! If wrapping past GM else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: i < 1 in get_ike_stats' print *,'!!! for a non-global grid. We will not ' print *,'!!! perform the ike stats' print *,'!!! processing for this storm & time.' print *,'!!! ' print *,'!!! imax of regional grid = ',imax print *,'!!! User-requested eastern i = ',i print *,' ' endif igisret = 94 return endif endif if (.not. valid_pt(ii,j)) then cycle ! Only an issue for regional grids endif call calcdist (glon(ii),glat(j),xsfclon,xsfclat,xdist,degrees) if (xdist > rads) then cycle else vmag = sqrt(u(ii,j,levsfc)**2 + v(ii,j,levsfc)**2) if (vmag > 10.0) then ! Add gridpoint to IKE_10. Compute area first... xarea = (dy * 111195) * & (dx * 111195 * cos(glat(j) * dtr)) ike(1) = ike(1) + (0.5 * (vmag**2) * xarea) endif if (vmag > 18.0) then ! Add gridpoint to IKE_ts. Area already computed for 10 ike(2) = ike(2) + (0.5 * (vmag**2) * xarea) endif if (vmag > 33.0) then ! Add gridpoint to IKE_h. Area already computed for 10 ike(3) = ike(3) + (0.5 * (vmag**2) * xarea) endif endif enddo enddo ike(1) = ike(1) * 1.e-12 ! Convert from J to TJ ike(2) = ike(2) * 1.e-12 ! Convert from J to TJ ike(3) = ike(3) * 1.e-12 ! Convert from J to TJ c Compute the storm surge damage potential (sdp) if (ike(2) >= 0.0) then sdp = 0.676 + (0.43 * sqrt(ike(2))) & - (0.0176 * ((sqrt(ike(2)) - 6.5)**2) ) else sdp = -99.0 endif c Print out the IKE and SDP statistics... if ( verb .ge. 3 ) then print *,' IKE_10 (storm energy) = ',ike(1) print *,' IKE_TS (tropical storm) = ',ike(2) print *,' IKE_H (hurricane) = ',ike(3) print *,' SDP = ',sdp endif return end c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine distbear (xlatin,xlonin,dist,bear,xlatt,xlont) c c ABSTRACT: Given an origin at latitude, longitude=xlato,xlono, c this subroutine will locate a target point at a distance dist in c km or nautical miles (depends on what you use for "rad_earth..." c below), at bearing bear (degrees clockwise from north). c Returns latitude xlatt and longitude xlont of target point. c c *** NOTE *** c This subroutine was written to handle input lats & lons as this: c All latitudes are in degrees, north positive and south negative. c All longitudes are in degrees, west positive and east negative. c *** **** *** c c However, for the longitudes, the rest of the tracker uses all c 0-360 longitudes. Therefore, we need to convert the input lons c and then once again convert the lons that are returned back to c the calling routine. c c NOTE-- When origin is at north or south pole, bearing is no c longer measured from north. Instead, bearing is measured c clockwise from the longitude opposite that specified in xlono. c Example-- if xlato=90., xlono=80., the opposite longitude is c -100 (100 East), and a target at bearing 30. will lie on the c -70. (70 East) meridian. c c AUTHOR: The core of this subroutine was written by Albion c Taylor, another NOAA employee, in 1981. c USE trig_vals implicit none c real, parameter :: rad_earth_nm = 3440.170 ! radius of earth real, parameter :: rad_earth_km = 6372.797 ! radius of earth real xlato,xlono,dist,bear,xlatt,xlont,xlatin,xlonin real cdist,sdist,clato,slato,clono,slono,cbear,sbear real z,y,x,r,xlattz,xlontz,ddist,dbear,dxlato,dxlono c xlato = xlatin xlono = xlonin cstr print *,' ' cstr print *,'+++ At top of distbear....' cstr print '(a6,f7.2,a3,f7.2,a9,f7.2)','xlon= ',xlono,'E ',360.-xlono cstr & ,'W xlat=',xlato cstr print '(a6,f7.2,a8,f7.2)','dist= ',dist,' bear= ',bear if (xlono > 180.) then ! Longitude input for this subroutine must be positive west xlono = 360. - xlono else ! Longitude input for this subroutine must be negative east xlono = -1. * xlono endif cstr print '(a31,a8,f8.2)','After conversion for distbear, ' cstr & ,' xlono= ',xlono ddist = dist dbear = bear dxlato = xlato dxlono = xlono cdist = cos(ddist/rad_earth_km) sdist = sin(ddist/rad_earth_km) clato = cos(dtr*dxlato) slato = sin(dtr*dxlato) cstr print *,'cdist= ',cdist,' sdist= ',sdist,' clato= ',clato cstr & ,' slato= ',slato clono = cos(dtr*dxlono) slono = sin(dtr*dxlono) cstr print *,'dxlono= ',dxlono,' clono= ',clono cstr & ,' slono= ',slono cbear = cos(dtr*dbear) sbear = sin(dtr*dbear) cstr print *,'cbear= ',cbear,' sbear= ',sbear z=cdist*slato + clato*sdist*cbear y=clato*clono*cdist + sdist*(slono*sbear - slato*clono*cbear) x=clato*slono*cdist - sdist*(clono*sbear + slato*slono*cbear) cstr print *,'z= ',z,' y= ',y,' x= ',x r = sqrt(x**2 + y**2) cstr print *,'r = sqrt(x**2 + y**2) = ',r xlattz = atan2(z,r)/dtr cstr print *,'xlattz = datan2(z,r)/dtr = ',xlattz xlatt = xlattz if (r <= 0.) go to 20 xlontz = atan2(x,y)/dtr cstr print *,'xlontz = atan2(x,y)/dtr = ',xlontz c xlont = xlontz ! Return the target longitude back to the calling routine ! as a 0-360 positive east longitude.... xlont = mod(360.-xlontz,360.) c xlont = mod(360.+xlontz,360.) cstr print *,' ' cstr print *,'At end of distbear....' cstr print '(a6,f7.2,a3,f7.2,a9,f7.2)','xlont= ',xlont,'E ' cstr ,360.-xlont,'W xlatt=',xlatt return 20 xlont=0. c return end c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine bilin_int_uneven (targlat,targlon,dx,dy & ,imax,jmax,trkrinfo,level,cparm,xintrp_val,ibiret) c c ABSTRACT: This subroutine performs a bilinear interpolation to get c a data value at a given lat/lon that may be anywhere within a box c defined by the four surrouding grid points. In the diagram below, c remember that for our grids we are using in the tracker, the c latitude index starts at the north pole and increases southward. c The point "X" indicates the target lat/lon location of the value c for which we are bilinearly interpolating. The values to and ta c below are ratios that determine how geographically close the c target location is to the point of origin (pt.1 (i,j)) in terms c of both longitude (to) and latitude (ta). c c c pt.1 pt.2 c (i,j) (i+1,j) c c c c X c c pt.4 pt.3 c (i,j+1) (i+1,j+1) c USE grid_bounds; USE tracked_parms; USE level_parms USE trkrparms USE verbose_output implicit none type (trackstuff) trkrinfo character cparm*1 real targlat,targlon,xintrp_val,dx,dy real to,ta,d1,d2,d3,d4,z,eastlon integer ie,iw,jn,js,ibiret,imax,jmax,level,nlev ibiret = 0 c -------------------------------------------------------------- c For the latitudes and longitudes surrounding our target c lat/lon location, convert the lat/lon values into i- and c j-indices. c -------------------------------------------------------------- c Find the j-indices for the points just to the north and the c south of targlat.... if (targlat >= 0.0) then ! For a northern hemisphere storm, jn is the j-index for the ! point just to the *NORTH* (poleward) of targlat. jn = int((glatmax - targlat)/dy + 1.) js = jn + 1 else ! For a southern hemisphere storm, js is the j-index for the ! point just to the *SOUTH* (poleward) of targlat. js = ceiling((glatmax - targlat)/dy + 1.) jn = js - 1 endif ! Check to make sure that points are not being requested beyond ! the northern or southern boundaries of the grid. This is most ! likely to happen for a smaller, regional grid. if (jn > jmax .or. js > jmax) then if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: jmax exceeded in subroutine ' print *,'!!! bilin_int_uneven. Returning to calling ' print *,'!!! routine after assigning wind value of -99.' print *,'!!! jn= ',jn,' js= ',js,' jmax= ',jmax print *,' ' endif xintrp_val = -999.0 ibiret = 85 return endif if (jn < 1 .or. js < 1) then if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: jn < 0 or js < 0 in subroutine ' print *,'!!! bilin_int_uneven. Returning to calling ' print *,'!!! routine after assigning wind value of -99.' print *,'!!! jn= ',jn,' js= ',js,' jmax= ',jmax print *,' ' endif xintrp_val = -999.0 ibiret = 85 return endif c Find the i-indices for the points just to the east and the c west of targlon.... ie = int((targlon - glonmin)/dx + 2.) iw = ie - 1 ! Check for GM wrapping. Check ie to see if it is between the ! most eastward gridpoint and the GM (i.e., on a 1-deg global ! grid (360x181), it would be if targlon was between 359.0 (i=360) ! and the GM (i=1, not i=361)). Similarly then, if we adjust ie ! to then be 1, then we have a problem with iw, ! since iw = 1 - 1 = 0. if (ie > imax) then if (trkrinfo%gridtype == 'global') then ie = ie - imax else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: ie > imax in subroutine ' print *,'!!! bilin_int_uneven for a non-global grid. ' print *,'!!! Returning to calling routine after ' print *,'!!! assigning missing wind value of -99.' print *,'!!! ie= ',ie,' imax= ',imax print *,' ' endif xintrp_val = -999.0 ibiret = 85 return endif endif if (iw < 1) then if (trkrinfo%gridtype == 'global') then iw = iw + imax else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: iw < 1 in subroutine bilin_int_uneven' print *,'!!! for a non-global grid. Returning to calling ' print *,'!!! routine after assigning missing wind value ' print *,'!!! of -99. iw= ',iw print *,' ' endif xintrp_val = -999.0 ibiret = 85 return endif endif ctmwc if ( verb .ge. 3 ) then ctmwc print *,' +++ Interpolating winds for cparm= ',cparm ctmwc print '(6x,4(a4,i3))','jn= ',jn,' js= ',js,' iw= ',iw,' ie= ',ie ctmwc endif c ---------------------------------------------------------------- c Calculate the longitude (to) and latitude (ta) location ratios. c Check for GM wrapping, as we can run into a problem here if c interpolating for points that are just west of the GM, since we c would be interpolating using values of longitude just west of c GM (say, glon(iw)=359.5) and the GM (glon(ie) = 0.0). This c makes for an incorrect "to" ratio below, with 0-359.5 in the c denominator. We have to account for this.... c ---------------------------------------------------------------- if (glon(iw) > 300.0 .and. & (glon(ie) < 10. .and. glon(ie) >= 0.)) then eastlon = 360. - glon(ie) else eastlon = glon(ie) endif ctmwc if ( verb .ge. 3 ) then ctmwc print *,'glat(js)= ',glat(js),' glat(jn)= ',glat(jn) ctmwc endif to = (targlon - glon(iw)) / (eastlon - glon(iw)) ta = (targlat - glat(jn)) / (glat(js) - glat(jn)) c -------------------------------------------------------------- c Copy the data values at the 4 known points into simple scalar c variables c -------------------------------------------------------------- select case (level) case (850); nlev = nlev850 ! check module level_parms for case (700); nlev = nlev700 ! the values of these.... case (500); nlev = nlev500 case (1020); nlev = levsfc end select if (cparm == 'u') then d1 = u(iw,jn,nlev) d2 = u(ie,jn,nlev) d3 = u(ie,js,nlev) d4 = u(iw,js,nlev) else if (cparm == 'v') then d1 = v(iw,jn,nlev) d2 = v(ie,jn,nlev) d3 = v(ie,js,nlev) d4 = v(iw,js,nlev) else if (cparm == 'm') then d1 = lsmask(iw,jn) d2 = lsmask(ie,jn) d3 = lsmask(ie,js) d4 = lsmask(iw,js) else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in bilin_int_uneven.' print *,'!!! Input cparm not recognized.' print *,'!!! cparm= ',cparm print *,'!!! EXITING....' endif stop 95 endif z = 1.9427 cstr print '(2x,4(a4,f8.2))',' d1= ',d1*z,' d2= ',d2*z cstr & ,' d3= ',d3*z,' d4= ',d4*z c ------------------------------------------------------------- c Compute the interpolated value c ------------------------------------------------------------- xintrp_val = (1.-to) * (1.-ta) * d1 & + to * (1.-ta) * d2 & + to * ta * d3 & + (1.-to) * ta * d4 cstr print '(2x,2(a11,f8.2))',' xintrp= ',xintrp_val,' (in kts)= ' cstr & ,xintrp_val*z c return end c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine sort_storms_by_pressure (gridprs,ifh,maxstorm,sortindex & ,issret) c c ABSTRACT: This subroutine sorts storms by mslp. It is called by c subroutine tracker just before the loop for "stormloop" is done c for all the storms at a particular forecast hour. It is only c called for the "midlat" and "tcgen" cases. The end result of c this sort is an array (prsindex) that contains the indeces of c the storms, arranged from lowest pressure to highest (and note c that the "undefined" storms have a pressure of 9999.99 mb and c thus get sorted to the bottom of the array). The purpose of c doing this is so that we track the most intense storms first. c Why go to the trouble? Imagine a scenario in which we are c tracking a complex system in which there are 2 low pressure c centers. Let's say that one is becoming dominant and c intensifying, while the other is weakening. Now, let's assume c that the weakening one eventually gets absorbed into the c stronger, more dominant low. Now we only have 1 low, but if in c the tracker stormloop, we first process the data for the c weakening low, we will attribute the track to that storm, and c then when we get to the point in the loop where we are trying c to get the track for the stronger storm, we will (erroneously) c stop the tracking for that storm since the storm center has c already been attributed to the weaker storm. But by using this c subroutine, we will track the stronger storm first, and thus c avoid this problem. c c NOTE: The pressures used in the sort are those obtained at the c previous forecast hour. At forecast hour = 0, just use the c values as they were input to this routine, since they were c found in first_ges_center from strongest to weakest already. c c INPUT: c gridprs real array of storm mslp values c ifh integer index for the current forecast hour c maxstorm max num of storms that can be handled in this run c c OUTPUT: c sortindex contains a sorted array of indeces. The orders c sort routine does NOT rearrange the data. Rather, it c returns this array of sorted indeces which point to c the correct order of data values in the data array. c issret return code from this subroutine c USE set_max_parms USE verbose_output real, allocatable :: iwork(:) real gridprs(maxstorm,maxtime) integer ifh,maxstorm integer sortindex(maxstorm) integer, parameter :: dp = selected_real_kind(12, 60) real (dp), allocatable :: prstemp(:) c allocate (prstemp(maxstorm),stat=iva) allocate (iwork(maxstorm),stat=iwa) if (iva /= 0 .or. iwa /= 0) then if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in sub sort_storms_by_pressure allocating' print *,'!!! prstemp or iwork arrays: ' print *,'!!! iva= ',iva,' iwa= ',iwa endif STOP 94 return endif if (ifh > 1) then c print *,' ' c print *,'--- Before sort, original prs values follow:' c print *,' ' do ist = 1,maxstorm prstemp(ist) = gridprs(ist,ifh-1) c write (6,81) ist,prstemp(ist)/100.0 enddo imode = 2 sortindex = 0 call qsort (prstemp,sortindex,maxstorm) ccccc call orders (imode,iwork,prstemp,sortindex,maxstorm,1,8,1) ccccc call orders_4byte (imode,iwork,prstemp,sortindex,maxstorm,1,8,1) if ( verb .ge. 3 ) then print *,' ' print *,'+++ Pressure-sorted storm list:' print *,' ' do ist = 1,maxstorm if (prstemp(sortindex(ist))/100.0 < 9999.0) then write (6,82) ist,sortindex(ist) & ,prstemp(sortindex(ist))/100.0 endif enddo 81 format (1x,'ist= ',i5,' Original (unsorted) prstemp= ',f7.2) 82 format (1x,'ist= ',i5,' sortindex(ist)= ',i5 & ,' prstemp= ',f7.2) endif else do ist = 1,maxstorm sortindex(ist) = ist enddo endif deallocate (prstemp); deallocate (iwork) c return end c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine getvrvt (centlon,centlat,xlon,xlat & ,udat,vdat,vr,vt,igvtret) c c ABSTRACT: This subroutine takes as input a u-wind and v-wind value c at an input (xlon,xlat) location and returns the tangential and c radial wind components relative to the input center lat/lon c position (centlon,centlat). The only trick to this whole c subroutine is figuring out the angle from the center point to the c data point, and we do this by creating a triangle with the leg c from the center point to the data point being the hypotenuse. c c NOTE: All longitudes must be in positive degrees east (0-360) !!! c c INPUT: c centlon Longitude of center point c centlat Latitude of center point c xlon Longitude of pt at which vr & vt will be computed c xlat Latitude of pt at which vr & vt will be computed c udat u-value of wind at the point (xlon,xlat) c vdat v-value of wind at the point (xlon,xlat) c c OUTPUT: c vr Radial wind component at (xlon,xlat) wrt (centlon,centlat) c vt Tang wind component at (xlon,xlat) wrt (centlon,centlat) c igvtret Return code from this subroutine c USE trig_vals USE verbose_output implicit none real centlon,centlat,xlon,xlat,udat,vdat,vr,vt,degrees,tmpxlon real angle,xlondiff,xlatdiff,opp_dist,hyp_dist,sin_value real cos_value,adj_dist,tmpangle,sin_angle,cos_angle real uvrcomp,vvrcomp,uvtcomp,vvtcomp integer igvtret c call calcdist(centlon,centlat,xlon,xlat,hyp_dist,degrees) c xxxx tmpxlon = xlon if (centlon > 330.0) then if (xlon > 360.0) then tmpxlon = xlon ! All lons will be in the 300+ range, so for ! consistency, we're ok. elseif (xlon < 30.0) then tmpxlon = xlon + 360. ! In this case, the fix center is just ! to the west of the GM with a lon (centlon) ! > 330, while the point being evaluated ! (xlon) is just east of the GM, but with a ! lon (centlon) < 30. Need to adjust here to ! to get the xlon in the 330+ frame of ! reference. endif elseif (centlon >= 0 .and. centlon < 30.0) then if (xlon >= 360.0) then tmpxlon = xlon - 360. elseif (xlon > 330. .and. xlon < 360.) then tmpxlon = 360. - xlon endif elseif (centlon < 0.0) then if (xlon >= 360.0) then tmpxlon = xlon - 360. elseif (xlon > 330. .and. xlon < 360.) then tmpxlon = -1 * (360. - xlon) endif endif xlatdiff = abs(centlat - xlat) xlondiff = abs(centlon - tmpxlon) if (centlon > 355.0) then write (6,91) centlon,tmpxlon,hyp_dist,degrees,xlondiff 91 format (1x,'centlon= ',f8.3,' tmpxlon= ',f8.3,' hyp_dist= ' & ,f10.2,' degrees= ',f10.2,' xlondiff= ',f12.2) endif if (xlondiff == 0 .and. xlatdiff > 0) then if (centlat > xlat) angle = 180 ! pt directly south of ctr if (centlat < xlat) angle = 0 ! pt directly north of ctr else if (xlondiff > 0 .and. xlatdiff == 0) then if (centlon > tmpxlon) angle = 270 ! pt directly west of ctr if (centlon < tmpxlon) angle = 90 ! pt directly east of ctr else ! This next part figures out the angle from the center point ! (centlon,centlat) to the data point (tmpxlon,xlat). It does ! this by setting up a triangle and then using inverse trig ! functions to get the angle. Since this is a kludgy way to ! do it that doesn't account for the curvature of the earth, ! we'll do it 2 ways, using asin and then acos, then take the ! average of those 2 for the angle. hyp_dist, calculated just ! above, is the distance from the center pt to the data pt. opp_dist = xlatdiff/360. * ecircum sin_value = opp_dist / hyp_dist if (sin_value > 1.0) then if ( verb .ge. 3 ) then print *,' ' print *,'!!! In getvrvt, sin_value > 1, setting to 1.' print *,'!!! opp_dist= ',opp_dist,' hyp_dist= ',hyp_dist print *,'!!! sin_value = ',sin_value print *,'!!! centlon= ',centlon,' centlat= ',centlat print *,'!!! tmpxlon= ',tmpxlon,' xlat= ',xlat print *,' ' endif sin_value = 0.99999 endif sin_angle = asin(sin_value) / dtr call calcdist(centlon,centlat,tmpxlon,centlat,adj_dist,degrees) cos_value = adj_dist / hyp_dist if (cos_value > 1.0) then if ( verb .ge. 3 ) then print *,' ' print *,'!!! In getvrvt, cos_value > 1, setting to 1.' print *,'!!! adj_dist= ',adj_dist,' hyp_dist= ',hyp_dist print *,'!!! cos_value = ',cos_value print *,'!!! centlon= ',centlon,' centlat= ',centlat print *,'!!! tmpxlon= ',tmpxlon,' xlat= ',xlat print *,' ' endif cos_value = 0.99999 endif cos_angle = acos(cos_value) / dtr tmpangle = 0.5 * (sin_angle + cos_angle) ! The previous lines of code just calculated an angle between ! 0 and 90. This next if structure adjusts that angle to ! instead be between 0 and 360. if (centlat <= xlat .and. centlon <= tmpxlon) then angle = 90 - tmpangle else if (centlat > xlat .and. centlon <= tmpxlon) then angle = 90 + tmpangle else if (centlat >= xlat .and. centlon >= tmpxlon) then angle = 270 - tmpangle else if (centlat < xlat .and. centlon >= tmpxlon) then angle = 270 + tmpangle endif endif uvrcomp = udat * sin(angle * dtr) vvrcomp = vdat * cos(angle * dtr) vr = uvrcomp + vvrcomp uvtcomp = (-udat) * cos(angle * dtr) vvtcomp = vdat * sin(angle * dtr) vt = uvtcomp + vvtcomp return end c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine output_atcfunix (outlon,outlat,inp,ist & ,ifcsthour,vmaxwind,xminmslp,vradius,maxstorm & ,trkrinfo,plastbar,rlastbar,rmax,cps_vals & ,wcore_flag,ioaxret) c ABSTRACT: This subroutine outputs a 1-line message for a given c storm at an input forecast hour in the new ATCF UNIX format. c Unlike the old atcf DOS format in which you waited until the c whole tracking was over to write the output for all forecast c hours, with this atcfunix format, each time we are calling this c subroutine, it is to only write out 1 record, which will be the c fix info for a particular storm at a given time. Also, even c though we have some data (GFS, NAM) at 6-hour intervals, Jim c Gross informed me that TPC does not need the positions at such c frequency, and keeping the reporting at 12 hour intervals is fine. c c While this new atcfunix format contains much more information than c the old 1-line atcf dos message, for our purposes we will use the c slots for mslp and wind radii. An example set of output records c will look like the following: c c AL, 13, 2000092500, 03, GFSO, 036, 243N, 675W, 42, 995, XX, 34, c NEQ, 242, 163, 124, 208 c AL, 13, 2000092500, 03, GFSO, 036, 243N, 675W, 42, 995, XX, 50, c NEQ, 155, 000, 000, 000 c AL, 13, 2000092500, 03, GFSO, 036, 243N, 675W, 42, 995, XX, 64, c NEQ, 000, 000, 000, 000 c c (NOTE: Each of the above lines beginning with "AL" is output as c a single line of text.) c c Note that in this example, for this 36h forecast hour, there are c 3 entries. This is so that we can include the radii for the c 3 different wind thresholds (34kt, 50kt and 64kt). So the only c thing different in each entry is the wind radii info; all the c other info is identical for each entry. c c This message also contains the intensity estimates (in knots) c for every forecast hours The conversion for m/s to knots is c to multiply m/s by 1.9427 (3.281 ft/m, 1 naut mile/6080 ft, c 3600s/h). c c NOTE: The longitudes that are passed into this subroutine are c given in 0 - 360, increasing eastward. The format for the c atcfunix system requires that the output be 0-180E or c 0-180W, so we must adjust the values, if needed. Also, the c values for southern latitudes must be positive (use 'N' and c 'S' to distinguish Northern/Southern Hemispheres). c c INPUT: c outlon longitude fix position for this storm at this time c which is to be written out to the output file c outlat latitude fix position for this storm at this time c which is to be written out to the output file c inp contains input date and model number information c ist the number storm that we're processing (can be 1-15) c ifcsthr the current forecast hour being output c vmaxwind the max surface wind for this storm at this fcst hour c xminmslp the min mslp for this storm at this fcst hour c vradius Contains the distance from the storm fix position to c each of the various wind threshhold distances in each c quadrant. (3,4) ==> (# of threshholds, # of quadrants) c maxstorm max # of storms that can be handled c plastbar pressure of the outermost closed isobar c rlastbar radius (nm) of the outermost closed isobar c rmax radius of max winds (n mi).... it was already converted c from km to n mi in subroutine get_max_wind c cps_vals real array with the values for the 3 cyclone phase c space parameters: (1) is for Parameter B (thermal c asymmetry); (2) is for lower level (600-900 mb) thermal c wind; (3) is for upper level (300-600 mb) thermal wind. c wcore_flag character for value of 300-500 mb warm core: y, n, or c 'u' for undetermined. c OUTPUT: c ioaxret integer return code from this subroutine c c LOCAL: c intlon integer that holds the value of outlon*10 c intlat integer that holds the value of outlat*10 c storm An array of type tcvcard. Use this for the storm ID c USE def_vitals; USE inparms; USE set_max_parms; USE atcf USE trkrparms; USE phase USE verbose_output type (datecard) inp type (trackstuff) trkrinfo real cps_vals(3) real outlon,outlat,rmax,mslp_outp_adj real vmaxwind,conv_ms_knots,xminmslp,plastbar,rlastbar integer intlon,intlat,irmax,output_fhr,ic,iplastbar,irlastbar integer vradius(3,4),icps_vals(3) character basinid*2,clatns*1,clonew*1,wcore_flag*1 character comma_fill1*48,comma_fill2*31,comma_filler*79 if ( verb .ge. 3 ) then print *,'TTT top of atcfunix, ist= ',ist,' ifh= ',ifcsthour endif if (xminmslp == 999999.0) xminmslp = 0.0 if (xminmslp < 1100.0) then ! Pressure units are in mb... mslp_outp_adj = 1.0 elseif (xminmslp >80000.0) then ! Pressure units are in Pa... mslp_outp_adj = 100.0 else if (verb .ge. 3) then print *,' ' print *,'ERROR: Something wrong in subroutine' print *,' output_atcfunix. The mslp value' print *,' (xminmslp) is not in range.' print *,' xminmslp = ',xminmslp print *,' EXITING....' print *,' ' stop 95 endif endif c First convert all of the lat/lon values from reals into integers. c These integer values must be 10x their real value (eg. 125.4 will c be written out as 1254). Convert the lon values so that they go c from 0-180E or 0-180W, and convert the lat values so that they are c positive and use 'N' or 'S' to differentiate hemispheres. conv_ms_knots = 1.9427 if (outlon < -998.0 .or. outlat < -998.0) then intlon = 0 intlat = 0 clonew = ' ' clatns = ' ' else if (outlon >= 180.0) then intlon = 3600 - int(outlon * 10. + 0.5) clonew = 'W' else intlon = int(outlon * 10. + 0.5) clonew = 'E' endif intlat = int(abs(outlat) * 10. + 0.5) if (outlat < 0.0) then clatns = 'S' else clatns = 'N' endif endif if ( verb .ge. 3 ) then print *,' ' print *,'in output_atcfunix, tcv_storm_id= ' & ,storm(ist)%tcv_storm_id print *,'in output_atcfunix, tcv_storm_id(3:3)= ' & ,storm(ist)%tcv_storm_id(3:3) endif select case (storm(ist)%tcv_storm_id(3:3)) case ('L','l'); basinid = 'AL' case ('E','e'); basinid = 'EP' case ('C','c'); basinid = 'CP' case ('W','w'); basinid = 'WP' case ('O','o'); basinid = 'SC' case ('T','t'); basinid = 'EC' case ('U','u'); basinid = 'AU' case ('P','p'); basinid = 'SP' case ('S','s'); basinid = 'SI' case ('B','b'); basinid = 'BB' !zhang case ('A','a'); basinid = 'NA' case ('A','a'); basinid = 'AA' case ('Q','q'); basinid = 'SL' case default; basinid = 'HC' end select if (atcfname(1:2) == 'SP') then ! Add 3 for SREF to account for the 3-hour off-synoptic ! time offset.... output_fhr = ifcsthour + 3 else output_fhr = ifcsthour endif if (rmax == -99.0) then irmax = -99 else irmax = int(rmax + 0.5) endif if (trkrinfo%want_oci) then if (plastbar > 0.0) then iplastbar = int(plastbar/mslp_outp_adj + 0.5) else iplastbar = -99 endif if (rlastbar > 0.0) then irlastbar = int(rlastbar + 0.5) else irlastbar = -99 endif else iplastbar = -99 irlastbar = -99 endif if ( verb .ge. 3 ) then print *, 'output: rlastbar=',rlastbar,' irlastbar=',irlastbar print *, 'output: plastbar=',plastbar,' iplastbar=',iplastbar endif c Now convert all of the cyclone phase space parameter values from c real to integer. do ic = 1,3 if (cps_vals(ic) > -9999.0) then if (cps_vals(ic) >= 0.0) then icps_vals(ic) = int(cps_vals(ic)*10. + 0.5) else icps_vals(ic) = int(cps_vals(ic)*10. - 0.5) endif else icps_vals(ic) = -9999 endif enddo if (wcore_flag == 'y'.or. wcore_flag == 'Y') then wcore_flag = 'Y' elseif (wcore_flag == 'n' .or. wcore_flag == 'N') then wcore_flag = 'N' elseif (wcore_flag == 'u' .or. wcore_flag == 'U') then wcore_flag = 'U' else wcore_flag = 'U' endif comma_fill1 = ', 0, 0, , 0, , 0, 0, ,' comma_fill2 = ' , , , 0, 0, 0, 0' comma_filler = comma_fill1//comma_fill2 if (trkrinfo%type == 'midlat' .or. trkrinfo%type == 'tcgen') then if (stcvtype(ist) == 'FOF') then ! If this is a TC vitals-described storm (i.e., one that is ! numbered by JTWC or NHC), then leave the basinid as is. ! Otherwise, we want to use the "basinid" location as a ! label to identify what type of run this is. if (trkrinfo%type == 'midlat') basinid = 'ML' if (trkrinfo%type == 'tcgen') basinid = 'TG' endif write (64,91) basinid,adjustr(storm(ist)%tcv_storm_id) & ,atcfymdh & ,adjustr(atcfname),output_fhr,intlat,clatns,intlon,clonew & ,int((vmaxwind*conv_ms_knots) + 0.5) & ,int(xminmslp/mslp_outp_adj + 0.5) & ,'XX, 34, NEQ' & ,vradius(1,1),vradius(1,2),vradius(1,3),vradius(1,4) & ,iplastbar,irlastbar,irmax,0,0,stcvtype(ist) if (vradius(2,1) > 0 .or. vradius(2,2) > 0 .or. & vradius(2,3) > 0 .or. vradius(2,4) > 0) then write (64,91) basinid,adjustr(storm(ist)%tcv_storm_id) & ,atcfymdh & ,adjustr(atcfname),output_fhr,intlat,clatns,intlon,clonew & ,int((vmaxwind*conv_ms_knots) + 0.5) & ,int(xminmslp/mslp_outp_adj + 0.5) & ,'XX, 50, NEQ' & ,vradius(2,1),vradius(2,2),vradius(2,3),vradius(2,4) & ,iplastbar,irlastbar,irmax,0,0,stcvtype(ist) endif if (vradius(3,1) > 0 .or. vradius(3,2) > 0 .or. & vradius(3,3) > 0 .or. vradius(3,4) > 0) then write (64,91) basinid,adjustr(storm(ist)%tcv_storm_id) & ,atcfymdh & ,adjustr(atcfname),output_fhr,intlat,clatns,intlon,clonew & ,int((vmaxwind*conv_ms_knots) + 0.5) & ,int(xminmslp/mslp_outp_adj + 0.5) & ,'XX, 64, NEQ' & ,vradius(3,1),vradius(3,2),vradius(3,3),vradius(3,4) & ,iplastbar,irlastbar,irmax,0,0,stcvtype(ist) endif else write (64,81) basinid,storm(ist)%tcv_storm_id(1:2) & ,atcfymdh & ,adjustr(atcfname),output_fhr,intlat,clatns,intlon,clonew & ,int((vmaxwind*conv_ms_knots) + 0.5) & ,int(xminmslp/mslp_outp_adj + 0.5) & ,'XX, 34, NEQ' & ,vradius(1,1),vradius(1,2),vradius(1,3),vradius(1,4) & ,iplastbar,irlastbar,irmax,comma_filler,icps_vals(1) & ,icps_vals(2),icps_vals(3),wcore_flag,int(wcore_depth*10) if (vradius(2,1) > 0 .or. vradius(2,2) > 0 .or. & vradius(2,3) > 0 .or. vradius(2,4) > 0) then write (64,81) basinid,storm(ist)%tcv_storm_id(1:2) & ,atcfymdh & ,adjustr(atcfname),output_fhr,intlat,clatns,intlon,clonew & ,int((vmaxwind*conv_ms_knots) + 0.5) & ,int(xminmslp/mslp_outp_adj + 0.5) & ,'XX, 50, NEQ' & ,vradius(2,1),vradius(2,2),vradius(2,3),vradius(2,4) & ,iplastbar,irlastbar,irmax,comma_filler,icps_vals(1) & ,icps_vals(2),icps_vals(3),wcore_flag,int(wcore_depth*10) endif if (vradius(3,1) > 0 .or. vradius(3,2) > 0 .or. & vradius(3,3) > 0 .or. vradius(3,4) > 0) then write (64,81) basinid,storm(ist)%tcv_storm_id(1:2) & ,atcfymdh & ,adjustr(atcfname),output_fhr,intlat,clatns,intlon,clonew & ,int((vmaxwind*conv_ms_knots) + 0.5) & ,int(xminmslp/mslp_outp_adj + 0.5) & ,'XX, 64, NEQ' & ,vradius(3,1),vradius(3,2),vradius(3,3),vradius(3,4) & ,iplastbar,irlastbar,irmax,comma_filler,icps_vals(1) & ,icps_vals(2),icps_vals(3),wcore_flag,int(wcore_depth*10) endif endif if ( verb .ge. 3 ) then print *,'rmax= ',rmax,' irmax= ',irmax endif 81 format (a2,', ',a2,', ',i10.10,', 03, ',a4,', ',i3.3,', ',i3,a1 & ,', ',i4,a1,', ',i3,', ',i4,', ',a12,4(', ',i4.4) & ,2(', ',i4),', ',i3,a79,', THERMO PARAMS' & ,3(', ',i7),', ',a1,', ',i2,', DT, -999') 91 format (a2,', ',a4,', ',i10.10,', 03, ',a4,', ',i3.3,', ',i3,a1 & ,', ',i4,a1,', ',i3,', ',i4,', ',a12,4(', ',i4.4) & ,2(', ',i4),', ',i3,2(', ',i3),', ',a3) c bug fix for IBM: flush the output stream so it actually writes flush(64) return end c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine output_all (fixlon,fixlat,inp,maxstorm,ifhmax,ioaret) c c ABSTRACT: This subroutine outputs a 1-line message for each c storm. This message contains the model identifier, the forecast c initial date, and the positions for 0, 12, 24, 36, 48, 60 and 72 c hours. In the case of the regional models (NGM, Eta), which c only go out to 48h, zeroes are included for forecast hours c 60 and 72. c c NOTE: The longitudes that are passed into this subroutine are c given in 0 - 360, increasing eastward. The output of this c subroutine is used by Steve Lord for plotting purposes, and his c plotting routines need the longitudes in 0 - 360, increasing c westward. Thus, a necessary adjustment is made. c USE def_vitals; USE inparms; USE set_max_parms; USE atcf USE tracked_parms c type (datecard) inp c real fixlon(maxstorm,maxtime),fixlat(maxstorm,maxtime) integer modelnum(maxmodel) integer intlon(maxtime),intlat(maxtime) character modelchar(maxmodel)*4 c First convert all of the lat/lon values from reals into integers. c These integer values must be 10x their real value (eg. 125.4 will c be written out as 1254). Convert the lon values so that they go c from 0 - 360, increasing westward. print *,'top of output_all' stormloop: do ist = 1,maxstorm if (stormswitch(ist) == 3) cycle stormloop intlon = 0; intlat = 0 ifhloop: do ifh = 1,maxtime if (ifh <= ifhmax) then if (ifhours(ifh) == 99) then intlon(ifh) = 0 intlat(ifh) = 0 cycle ifhloop endif else intlon(ifh) = 0 intlat(ifh) = 0 cycle ifhloop endif if (fixlon(ist,ifh) < -998.0 .or. fixlat(ist,ifh) < -998.0) & then intlon(ifh) = 0 intlat(ifh) = 0 else intlon(ifh) = 3600 - int(fixlon(ist,ifh) * 10. + 0.5) intlat(ifh) = int(abs(fixlat(ist,ifh)) * 10. + 0.5) if (fixlat(ist,ifh) < 0.0) then intlat(ifh) = intlat(ifh) * (-1) endif endif enddo ifhloop print *,'before select case, atcfname= ' select case (atcfname(1:3)) case ('SEC','SEN','SEP','SKC','SKN','SKP','SRC','SRN','SRP') write (61,81) atcfnum,atcfname & ,inp%byy,inp%bmm,inp%bdd,inp%bhh,intlat(1),intlon(1) & ,intlat(5),intlon(5),intlat(9),intlon(9),intlat(13) & ,intlon(13),intlat(17),intlon(17),intlat(21),intlon(21) & ,0,0,storm(ist)%tcv_storm_id case ('AVN','NGM','ETA','GFD','AP0','AN0','AP1','AN1','AC0' & ,'AMM','CMC','HWR') write (61,81) atcfnum,atcfname & ,inp%byy,inp%bmm,inp%bdd,inp%bhh,intlat(1),intlon(1) & ,intlat(3),intlon(3),intlat(5),intlon(5),intlat(7) & ,intlon(7),intlat(9),intlon(9),intlat(11),intlon(11) & ,intlat(13),intlon(13),storm(ist)%tcv_storm_id case ('MRF','UKX','NGX','EP0','EP1','EP2','EN0','EN1','EN2' & ,'CP0','CN0','CC0','EC0','EMX') ! MRF, UKMET, NAVGEM, ECMWF Ensemble write (61,81) atcfnum,atcfname & ,inp%byy,inp%bmm,inp%bdd,inp%bhh,intlat(1),intlon(1) & ,intlat(2),intlon(2),intlat(3),intlon(3),intlat(4) & ,intlon(4),intlat(5),intlon(5),intlat(6),intlon(6) & ,intlat(7),intlon(7),storm(ist)%tcv_storm_id case ('GDA','HDA') ! GDAS, HDAS write (61,81) atcfnum,atcfname & ,inp%byy,inp%bmm,inp%bdd,inp%bhh,intlat(1),intlon(1) & ,intlat(2),intlon(2),intlat(3),intlon(3) & ,intlat(4),intlon(4),0,0,0,0,0,0 & ,storm(ist)%tcv_storm_id case ('WP0','WP1','WN0','WN1','XP0','XP1','XN0','XN1' & ,'YP0','YP1','YN0','YN1','ZP0','ZP1','ZN0','ZN1') ! Ensemble RELOCATION ONLY write (61,81) atcfnum,atcfname & ,inp%byy,inp%bmm,inp%bdd,inp%bhh,intlat(1),intlon(1) & ,intlat(2),intlon(2),0,0,0,0,0,0,0,0,0,0 & ,storm(ist)%tcv_storm_id case default c print *,'!!! ERROR in subroutine output_all. ' c print *,'!!! Model name is not identified.' c print *,'!!! Model name = ',atcfname c print *,'!!! ist = ',ist,' Model number = ',atcfnum print *,' ' print *,'!!! Model name is not identified: ',atcfname write (61,81) atcfnum,atcfname & ,inp%byy,inp%bmm,inp%bdd,inp%bhh,intlat(1),intlon(1) & ,intlat(2),intlon(2),intlat(3),intlon(3) & ,intlat(4),intlon(4),0,0,0,0,0,0 & ,storm(ist)%tcv_storm_id end select enddo stormloop 81 format (i2,a4,4i2.2,14i4,1x,a3) c return end c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine output_atcf (fixlon,fixlat,inp,xmaxwind,maxstorm & ,ifhmax,ioaret) c c ABSTRACT: This subroutine outputs a 1-line message for each storm c in ATCF format. This message contains the model identifier, the c forecast initial date, and the positions for 12, 24, 36, 48 c and 72 hours. This message also contains the intensity c estimates (in knots) for those same hours. The conversion for c m/s to knots is to multiply m/s by 1.9427 (3.281 ft/m, c 1 naut mile/6080 ft, 3600s/h). c c NOTE: The longitudes that are passed into this subroutine are c given in 0 - 360, increasing eastward. The output of this c subroutine is used by the atcf system at TPC for plotting c purposes, and the atcf plotting routines need the longitudes in c 0 - 360, increasing westward. Thus, a necessary adjustment is c made. c USE def_vitals; USE inparms; USE set_max_parms; USE atcf USE tracked_parms c type (datecard) inp c real fixlon(maxstorm,maxtime),fixlat(maxstorm,maxtime) real xmaxwind(maxstorm,maxtime) real conv_ms_knots integer modelnum(maxmodel) integer intlon(maxtime),intlat(maxtime) character modelchar(maxmodel)*4,basinid*4 c First convert all of the lat/lon values from reals into integers. c These integer values must be 10x their real value (eg. 125.4 will c be written out as 1254). Convert the lon values so that they go c from 0 - 360, increasing westward. conv_ms_knots = 1.9427 stormloop: do ist = 1,maxstorm if (stormswitch(ist) == 3) cycle stormloop intlon = 0; intlat = 0 ifhloop: do ifh = 1,maxtime if (ifh <= ifhmax) then if (ifhours(ifh) == 99) then intlon(ifh) = 0 intlat(ifh) = 0 cycle ifhloop endif else intlon(ifh) = 0 intlat(ifh) = 0 cycle ifhloop endif if (fixlon(ist,ifh) < -998.0 .or. fixlat(ist,ifh) < -998.0) & then intlon(ifh) = 0 intlat(ifh) = 0 else intlon(ifh) = 3600 - int(fixlon(ist,ifh) * 10. + 0.5) intlat(ifh) = int(abs(fixlat(ist,ifh)) * 10. + 0.5) if (fixlat(ist,ifh) < 0.0) then intlat(ifh) = intlat(ifh) * (-1) endif endif enddo ifhloop basinid = ' ' select case (storm(ist)%tcv_storm_id(3:3)) case ('L','l'); basinid(1:2) = 'AL' case ('E','e'); basinid(1:2) = 'EP' case ('C','c'); basinid(1:2) = 'CP' case ('W','w'); basinid(1:2) = 'WP' case ('O','o'); basinid(1:2) = 'SC' case ('T','t'); basinid(1:2) = 'EC' case ('U','u'); basinid(1:2) = 'AU' case ('P','p'); basinid(1:2) = 'SP' case ('S','s'); basinid(1:2) = 'SI' case ('B','b'); basinid(1:2) = 'BB' cPENG case ('A','a'); basinid(1:2) = 'NA' case ('A','a'); basinid(1:2) = 'AA' case default; basinid(1:2) = '**' end select basinid(3:4) = storm(ist)%tcv_storm_id(1:2) select case (atcfname(1:3)) case ('SEC','SEN','SEP','SKC','SKN','SKP','SRC','SRN','SRP') write (62,82) atcfnum,atcfname & ,inp%byy,inp%bmm,inp%bdd,inp%bhh,intlat(5),intlon(5) & ,intlat(9),intlon(9),intlat(13),intlon(13),intlat(17) & ,intlon(17),0,0 & ,int((xmaxwind(ist,5)*conv_ms_knots) + 0.5) & ,int((xmaxwind(ist,9)*conv_ms_knots) + 0.5) & ,int((xmaxwind(ist,13)*conv_ms_knots) + 0.5) & ,int((xmaxwind(ist,17)*conv_ms_knots) + 0.5) & ,0 & ,basinid,inp%byy case ('AVN','NGM','ETA','GFD','AP0','AN0','AP1','AN1','AC0' & ,'AMM','CMC','HWR') write (62,82) atcfnum,atcfname & ,inp%byy,inp%bmm,inp%bdd,inp%bhh,intlat(3),intlon(3) & ,intlat(5),intlon(5),intlat(7),intlon(7),intlat(9) & ,intlon(9),intlat(13),intlon(13) & ,int((xmaxwind(ist,3)*conv_ms_knots) + 0.5) & ,int((xmaxwind(ist,5)*conv_ms_knots) + 0.5) & ,int((xmaxwind(ist,7)*conv_ms_knots) + 0.5) & ,int((xmaxwind(ist,9)*conv_ms_knots) + 0.5) & ,int((xmaxwind(ist,13)*conv_ms_knots) + 0.5) & ,basinid,inp%byy case ('MRF','UKX','NGX','EP0','EP1','EP2','EN0','EN1','EN2' & ,'CP0','CN0','CC0','EC0','EMX') ! MRF, UKMET, NAVGEM, ECMWF Ensemble, ECMWF hi-res write (62,82) atcfnum,atcfname & ,inp%byy,inp%bmm,inp%bdd,inp%bhh,intlat(2),intlon(2) & ,intlat(3),intlon(3),intlat(4),intlon(4),intlat(5) & ,intlon(5),intlat(7),intlon(7) & ,int((xmaxwind(ist,2)*conv_ms_knots) + 0.5) & ,int((xmaxwind(ist,3)*conv_ms_knots) + 0.5) & ,int((xmaxwind(ist,4)*conv_ms_knots) + 0.5) & ,int((xmaxwind(ist,5)*conv_ms_knots) + 0.5) & ,int((xmaxwind(ist,7)*conv_ms_knots) + 0.5) & ,basinid,inp%byy case ('GDA','HDA') ! GDAS, HDAS write (62,82) atcfnum,atcfname & ,inp%byy,inp%bmm,inp%bdd,inp%bhh & ,intlon(1),intlat(1),intlat(2),intlon(2) & ,intlat(3),intlon(3),intlat(4),intlon(4) & ,0,0 & ,int((xmaxwind(ist,2)*conv_ms_knots) + 0.5) & ,int((xmaxwind(ist,3)*conv_ms_knots) + 0.5) & ,int((xmaxwind(ist,4)*conv_ms_knots) + 0.5) & ,0,0,basinid,inp%byy case ('WP0','WP1','WN0','WN1','XP0','XP1','XN0','XN1' & ,'YP0','YP1','YN0','YN1','ZP0','ZP1','ZN0','ZN1') ! Ensemble RELOCATION ONLY write (62,82) atcfnum,atcfname & ,inp%byy,inp%bmm,inp%bdd,inp%bhh & ,intlon(1),intlat(1),intlat(2),intlon(2) & ,0,0,0,0 & ,0,0 & ,int((xmaxwind(ist,2)*conv_ms_knots) + 0.5) & ,int((xmaxwind(ist,3)*conv_ms_knots) + 0.5) & ,int((xmaxwind(ist,4)*conv_ms_knots) + 0.5) & ,0,0,basinid,inp%byy case default c print *,'!!! ERROR in subroutine output_atcf. ' c print *,'!!! Model name is not identified.' c print *,'!!! Model name = ',atcfname c print *,'!!! ist = ',ist,' Model number = ',atcfnum print *,' ' write (62,82) atcfnum,atcfname & ,inp%byy,inp%bmm,inp%bdd,inp%bhh,intlat(3),intlon(3) & ,intlat(5),intlon(5),intlat(7),intlon(7),intlat(9) & ,intlon(9),intlat(13),intlon(13) & ,int((xmaxwind(ist,3)*conv_ms_knots) + 0.5) & ,int((xmaxwind(ist,5)*conv_ms_knots) + 0.5) & ,int((xmaxwind(ist,7)*conv_ms_knots) + 0.5) & ,int((xmaxwind(ist,9)*conv_ms_knots) + 0.5) & ,int((xmaxwind(ist,13)*conv_ms_knots) + 0.5) & ,basinid,inp%byy end select enddo stormloop 82 format (i2,a4,4i2.2,10i4,5i3,1x,a4,i2.2) c return end c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine output_hfip (outlon,outlat,inp,ist & ,ifh,vmaxwind,xminmslp,vradius,rmax,ioaxret) c ABSTRACT: This subroutine outputs a 1-line message for a given c storm at an input forecast hour in a modified ATCF UNIX format. c The modification is to allow for sub-hourly output. That is, c instead of just integer output hours, we can have output at c 10, 15 or 20 past an hour. This necessitates a change in the c "forecast hour" placeholder in the ATCF format. Instead of it c being an I3, we'll make it an I5, with something like a lead time c of 36.25h being rounded and truncated to 03625 for output. c c An example set of output records using the standard atcf format c looks like the following: c c AL, 13, 2000092500, 03, AVNO, 036, 243N, 675W, 42, 995, XX, 34, c NEQ, 242, 163, 124, 208 c AL, 13, 2000092500, 03, AVNO, 036, 243N, 675W, 42, 995, XX, 50, c NEQ, 155, 000, 000, 000 c AL, 13, 2000092500, 03, AVNO, 036, 243N, 675W, 42, 995, XX, 64, c NEQ, 000, 000, 000, 000 c c An example set of modified output records will look like the c following, for the case of a lead time of 36:15 (36.25): c c AL, 13, 2000092500, 03, AVNO, 03625, 243N, 675W, 42, 995, XX, 34, c NEQ, 242, 163, 124, 208 c AL, 13, 2000092500, 03, AVNO, 03625, 243N, 675W, 42, 995, XX, 50, c NEQ, 155, 000, 000, 000 c AL, 13, 2000092500, 03, AVNO, 03625, 243N, 675W, 42, 995, XX, 64, c NEQ, 000, 000, 000, 000 c c (NOTE: Each of the above lines beginning with "AL" is output as c a single line of text.) c c Note that in this example, for this 36h forecast hour, there are c 3 entries. This is so that we can include the radii for the c 3 different wind thresholds (34kt, 50kt and 64kt). So the only c thing different in each entry is the wind radii info; all the c other info is identical for each entry. c c This message also contains the intensity estimates (in knots) c for every forecast hours The conversion for m/s to knots is c to multiply m/s by 1.9427 (3.281 ft/m, 1 naut mile/6080 ft, c 3600s/h). c c NOTE: The longitudes that are passed into this subroutine are c given in 0 - 360, increasing eastward. The format for the c atcfunix system requires that the output be 0-180E or c 0-180W, so we must adjust the values, if needed. Also, the c values for southern latitudes must be positive (use 'N' and c 'S' to distinguish Northern/Southern Hemispheres). c c INPUT: c storm An array of type tcvcard. Use this for the storm ID c outlon longitude fix position for this storm at this time c which is to be written out to the output file c outlat latitude fix position for this storm at this time c which is to be written out to the output file c inp contains input date and model number information c ist the number storm that we're processing (can be 1-15) c ifh index for the lead time array c vmaxwind the max surface wind for this storm at this fcst hour c xminmslp the min mslp for this storm at this fcst hour c vradius Contains the distance from the storm fix position to c each of the various wind threshhold distances in each c quadrant. (3,4) ==> (# of threshholds, # of quadrants) c rmax Radius of max winds (n mi).... it was already converted c from km to n mi in subroutine get_max_wind c c OUTPUT: c ioaxret integer return code from this subroutine c c LOCAL: c intlon integer that holds the value of outlon*10 c intlat integer that holds the value of outlat*10 c USE def_vitals; USE inparms; USE set_max_parms; USE atcf USE tracked_parms USE verbose_output type (datecard) inp real outlon,outlat,mslp_outp_adj real vmaxwind,conv_ms_knots,xminmslp,rmax integer intlon,intlat,output_fhr,irmax,ileadtime integer vradius(3,4) character basinid*2,clatns*1,clonew*1 c First convert all of the lat/lon values from reals into integers. c These integer values must be 10x their real value (eg. 125.4 will c be written out as 1254). Convert the lon values so that they go c from 0-180E or 0-180W, and convert the lat values so that they are c positive and use 'N' or 'S' to differentiate hemispheres. if (xminmslp == 999999.0) xminmslp = 0.0 if (xminmslp < 1100.0) then ! Pressure units are in mb... mslp_outp_adj = 1.0 elseif (xminmslp >80000.0) then ! Pressure units are in Pa... mslp_outp_adj = 100.0 else if (verb .ge. 3) then print *,' ' print *,'ERROR: Something wrong in subroutine' print *,' output_hfip. The mslp value' print *,' (xminmslp) is not in range.' print *,' xminmslp = ',xminmslp print *,' EXITING....' print *,' ' stop 95 endif endif conv_ms_knots = 1.9427 if (outlon < -998.0 .or. outlat < -998.0) then intlon = 0 intlat = 0 clonew = ' ' clatns = ' ' else if (outlon >= 180.0) then intlon = 3600 - int(outlon * 10. + 0.5) clonew = 'W' else intlon = int(outlon * 10. + 0.5) clonew = 'E' endif intlat = int(abs(outlat) * 10. + 0.5) if (outlat < 0.0) then clatns = 'S' else clatns = 'N' endif endif select case (storm(ist)%tcv_storm_id(3:3)) case ('L','l'); basinid = 'AL' case ('E','e'); basinid = 'EP' case ('C','c'); basinid = 'CP' case ('W','w'); basinid = 'WP' case ('O','o'); basinid = 'SC' case ('T','t'); basinid = 'EC' case ('U','u'); basinid = 'AU' case ('P','p'); basinid = 'SP' case ('S','s'); basinid = 'SI' case ('B','b'); basinid = 'BB' case ('A','a'); basinid = 'AA' case ('Q','q'); basinid = 'SL' case default; basinid = '**' end select ! ST: ifcsthour does not exist, so output_fhr is always ! filled with invalid data here. However, output_fhr is ! never used, so it is safe to remove. if (atcfname(1:2) == 'SP') then ! Add 3 for SREF to account for the 3-hour off-synoptic ! time offset.... ! output_fhr = ifcsthour + 3 ileadtime = nint((fhreal(ifh) + 3.0) * 100.0) else ! output_fhr = ifcsthour ileadtime = nint(fhreal(ifh) * 100.0) endif if (rmax == -99.0) then irmax = -99 else irmax = int(rmax + 0.5) endif write (69,81) basinid,storm(ist)%tcv_storm_id(1:2) & ,atcfymdh & ,adjustr(atcfname),ileadtime,intlat,clatns,intlon,clonew & ,int((vmaxwind*conv_ms_knots) + 0.5) & ,int(xminmslp/mslp_outp_adj + 0.5) & ,'XX, 34, NEQ' & ,vradius(1,1),vradius(1,2),vradius(1,3),vradius(1,4),irmax if (vradius(2,1) > 0 .or. vradius(2,2) > 0 .or. & vradius(2,3) > 0 .or. vradius(2,4) > 0) then write (69,81) basinid,storm(ist)%tcv_storm_id(1:2) & ,atcfymdh & ,adjustr(atcfname),ileadtime,intlat,clatns,intlon,clonew & ,int((vmaxwind*conv_ms_knots) + 0.5) & ,int(xminmslp/mslp_outp_adj + 0.5) & ,'XX, 50, NEQ' & ,vradius(2,1),vradius(2,2),vradius(2,3),vradius(2,4),irmax endif if (vradius(3,1) > 0 .or. vradius(3,2) > 0 .or. & vradius(3,3) > 0 .or. vradius(3,4) > 0) then write (69,81) basinid,storm(ist)%tcv_storm_id(1:2) & ,atcfymdh & ,adjustr(atcfname),ileadtime,intlat,clatns,intlon,clonew & ,int((vmaxwind*conv_ms_knots) + 0.5) & ,int(xminmslp/mslp_outp_adj + 0.5) & ,'XX, 64, NEQ' & ,vradius(3,1),vradius(3,2),vradius(3,3),vradius(3,4),irmax endif 81 format (a2,', ',a2,', ',i10.10,', 03, ',a4,', ',i5.5,', ',i3,a1 & ,', ',i4,a1,', ',i3,', ',i4,', ',a12,4(', ',i4.4) & ,', 0, 0, ',i3) c c bug fix for IBM: flush the output stream so it actually writes flush(69) return end c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine output_fract_wind (outlon,outlat,xsfclon,xsfclat & ,inp,ist,ifcsthour,vmaxwind,xminmslp,wfract_cov & ,wfract_type,pdf_ct_bin,pdf_ct_tot,maxstorm,iofwret) c c ABSTRACT: This subroutine outputs a 1-line message for a given c storm at an input forecast hour. This message contains the c values for the fractional areal coverage of various wind c thresholds. In addition, this subroutine also writes out c records to a file containing data on the PDF of wind magnitudes c within r=350 km. c c This format will mimic the current atcfunix format with the c difference coming late in the record, where the various wind radii c will be replaced with areal coverage thresholds. c c AL, 13, 2000092500, 03, AVNO, 036, 243N, 675W, 42, 995, XX, c 000, 100, 34, NEE, 981, 857, 629, 810 c AL, 13, 2000092500, 03, AVNO, 036, 243N, 675W, 42, 995, XX, c 000, 100, 50, NEE, 874, 732, 319, 610 c AL, 13, 2000092500, 03, AVNO, 036, 243N, 675W, 42, 995, XX, c 000, 100, 64, NEE, 454, 327, 99, 270 c AL, 13, 2000092500, 03, AVNO, 036, 243N, 675W, 42, 995, XX, c 000, 100, 34, AAE, 721, 721, 721, 721 c AL, 13, 2000092500, 03, AVNO, 036, 243N, 675W, 42, 995, XX, c 000, 100, 50, AAE, 465, 465, 465, 465 c AL, 13, 2000092500, 03, AVNO, 036, 243N, 675W, 42, 995, XX, c 000, 100, 64, AAE, 298, 298, 298, 298 c c (NOTE: Each of the above lines beginning with "AL" is output as c a single line of text.) c c Note that in this example, for this 36h forecast hour, there are c 3 entries. This is so that we can include the pctgs for the c 3 different wind thresholds (34kt, 50kt and 64kt). So the only c thing different in each entry is the wind pctg info; all the c other info is identical for each entry. c c Listed after the "XX" in each record is the radius from which c the coverage is valid (000 km in this case); Next is the radius c at which the coverage stops (100 km in this case). Next is the c wind threshold (34, 50, 64). Next is an identifier for which c quadrant the coverage starts in (first 2 characters are NE, SE, c SW, NW); the last character indicates if the coverages are c computed in the quadrants as earth-relative ("E") or c storm-motion relative ("R"). The ones listed there as "AAE" c are for the full disc (i.e., 4-quadrant average), earth-relative. c Next are the wind coverage percentages, listed as percentage * 10 c (e.g., 981 = 98.1%). c c This message also contains the intensity estimates (in knots) c for every forecast hours The conversion for m/s to knots is c to multiply m/s by 1.9427 (3.281 ft/m, 1 naut mile/6080 ft, c 3600s/h). c c NOTE: The longitudes that are passed into this subroutine are c given in 0 - 360, increasing eastward. The format for the c atcfunix system requires that the output be 0-180E or c 0-180W, so we must adjust the values, if needed. Also, the c values for southern latitudes must be positive (use 'N' and c 'S' to distinguish Northern/Southern Hemispheres). c c INPUT: c outlon longitude fix position for this storm at this time c which is to be written out to the output file c outlat latitude fix position for this storm at this time c which is to be written out to the output file c xsfclon low-level longitude estimate for this storm & time, c computed ideally from mean of mslp & low-level winds. c xsfclat low-level latitude estimate for this storm & time, c computed ideally from mean of mslp & low-level winds. c inp contains input date and model number information c ist the number storm that we're processing (can be 1-15) c ifcsthr the current forecast hour being output c vmaxwind the max surface wind for this storm at this fcst hour c xminmslp the min mslp for this storm at this fcst hour c wfract_cov percent areal coverage for various wind thresholds c wfract_type 'earth' or 'storm' relative analysis c pdf_ct_bin array for pdf of wind magnitudes within r=350 km c pdf_ct_tot total count of pdf points for r < 350 km c c OUTPUT: c ioaxret integer return code from this subroutine c c LOCAL: c intlon integer that holds the value of outlon*10 c intlat integer that holds the value of outlat*10 c USE def_vitals; USE inparms; USE set_max_parms; USE atcf USE verbose_output type (datecard) inp c integer, parameter :: numdist=14,numquad=4,numbin=5,numthresh=3 real outlon,outlat,pdfval real wfract_cov(numquad+1,numbin,numthresh) real vmaxwind,conv_ms_knots,xminmslp,xsfclon,xsfclat integer :: windthresh(numthresh) = (/34,50,64/) integer pdf_ct_bin(16) integer intlon,intlat,output_fhr,intlon100,intlat100,pdf_ct_tot integer maxstorm character basinid*2,clatns*1,clonew*1,wfract_type*5,wt*1,cquad*2 c First convert all of the lat/lon values from reals into integers. c These integer values must be 10x their real value (eg. 125.4 will c be written out as 1254). Convert the lon values so that they go c from 0-180E or 0-180W, and convert the lat values so that they are c positive and use 'N' or 'S' to differentiate hemispheres. conv_ms_knots = 1.9427 if (outlon < -998.0 .or. outlat < -998.0) then intlon = 0 intlat = 0 intlon100 = 0 intlat100 = 0 clonew = ' ' clatns = ' ' else if (outlon >= 180.0) then intlon = 3600 - int(outlon * 10. + 0.5) intlon100 = 36000 - int(outlon * 100. + 0.5) clonew = 'W' else intlon = int(outlon * 10. + 0.5) intlon100 = int(outlon * 100. + 0.5) clonew = 'E' endif intlat = int(abs(outlat) * 10. + 0.5) intlat100 = int(abs(outlat) * 100. + 0.5) if (outlat < 0.0) then clatns = 'S' else clatns = 'N' endif endif select case (storm(ist)%tcv_storm_id(3:3)) case ('L','l'); basinid = 'AL' case ('E','e'); basinid = 'EP' case ('C','c'); basinid = 'CP' case ('W','w'); basinid = 'WP' case ('O','o'); basinid = 'SC' case ('T','t'); basinid = 'EC' case ('U','u'); basinid = 'AU' case ('P','p'); basinid = 'SP' case ('S','s'); basinid = 'SI' case ('B','b'); basinid = 'BB' case ('A','a'); basinid = 'AA' case ('Q','q'); basinid = 'SL' case default; basinid = '**' end select if (atcfname(1:2) == 'SP') then ! Add 3 for SREF to account for the 3-hour off-synoptic ! time offset.... output_fhr = ifcsthour + 3 else output_fhr = ifcsthour endif if (wfract_type == 'earth') then wt = 'E' else if (wfract_type == 'storm') then wt = 'R' else wt = 'X' endif do ib = 1,numbin do it = 1,numthresh write (73,81) basinid,storm(ist)%tcv_storm_id(1:2) & ,atcfymdh & ,adjustr(atcfname),output_fhr,intlat,clatns,intlon,clonew & ,int((vmaxwind*conv_ms_knots) + 0.5) & ,int(xminmslp/100.0 + 0.5) & ,', XX, ',0,ib*100,windthresh(it),'NE',wt & ,int((1000.*wfract_cov(1,ib,it))+0.5) & ,int((1000.*wfract_cov(2,ib,it))+0.5) & ,int((1000.*wfract_cov(3,ib,it))+0.5) & ,int((1000.*wfract_cov(4,ib,it))+0.5) & ,intlat100,clatns,intlon100,clonew enddo enddo do ib = 1,numbin do it = 1,numthresh write (73,81) basinid,storm(ist)%tcv_storm_id(1:2) & ,atcfymdh & ,adjustr(atcfname),output_fhr,intlat,clatns,intlon,clonew & ,int((vmaxwind*conv_ms_knots) + 0.5) & ,int(xminmslp/100.0 + 0.5) & ,', XX, ',0,ib*100,windthresh(it),'AA',wt & ,int((1000.*wfract_cov(5,ib,it))+0.5) & ,int((1000.*wfract_cov(5,ib,it))+0.5) & ,int((1000.*wfract_cov(5,ib,it))+0.5) & ,int((1000.*wfract_cov(5,ib,it))+0.5) & ,intlat100,clatns,intlon100,clonew enddo enddo 81 format (a2,', ',a2,', ',i10.10,', 03, ',a4,', ',i3.3,', ',i3,a1 & ,', ',i4,a1,', ',i3,', ',i4,', ',a6,i3.3,', ',i3.3,', ' & ,i3,', ',a2,a1,4(', ',i4),', ',i4,a1,', ',i5,a1) c -------------------------------------------------- c Now compute and write out the pdf values for the c wind magnitude.... c -------------------------------------------------- do ip = 1,16 pdfval = float(pdf_ct_bin(ip)) / float(pdf_ct_tot) write (76,85) atcfymdh,basinid,storm(ist)%tcv_storm_id(1:2) & ,output_fhr,10*(ip-1),10*ip,pdf_ct_bin(ip) & ,pdf_ct_tot,pdfval enddo 85 format (1x,i10.10,3x,a2,a2,3x,i3,3x,i3.3,'_',i3.3,3x,i7,2x,i7 & ,2x,f6.3) c c bug fix for IBM: flush the output stream so it actually writes flush(73) return end c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine output_wind_structure (outlon,outlat,xsfclon & ,xsfclat,inp,ist,ifcsthour,vmaxwind,xminmslp,er_wind & ,sr_wind,er_vr,sr_vr,er_vt,sr_vt,maxstorm,iofwret) c c ABSTRACT: This subroutine outputs a 1-line message for a given c storm at an input forecast hour. This message contains the c values of the winds at specified distances along 45-degree c radials in each storm quadrant. These are output c twice -- First, for an earth-relative coordinate system, and c second, for a storm-relative coordinate system. For the c earth-relative estimates, we will always have 4 radials: NE, SE, c SW and NW (45,135,225,315). For the storm-relative estimates, c these radials will be computed at the same relative angles (i.e., c 45,135,225,315), but with respect (positive clockwise) to the c direction of storm motion. For example, for a storm moving with c a heading of 280, the wind structure is evaluated at these c radials: 325 (front-right; 45 deg CW from heading), 55 (back- c right; 135 deg CW from heading), 145 (back-left; 225 deg CW from c heading), 235 (front-left; 315 deg CW from heading). c c LOCAL: c numdist Number of discrete radii at which the winds will c be evaluated c c c This format will mimic the current atcfunix format with the c difference coming late in the record, where the various wind radii c will be replaced with wind values at the 13 specified distances c (10, 25, 50, 75, 100, 150, 200, 250, 300, 350, 400, 450, 500 km) c c AL, 13, 2000092500, 03, AVNO, 036, 243N, 675W, 42, 995, XX, c 71, NEE, 1137, 1221, 854, 655, etc., ... out to 500 km c AL, 13, 2000092500, 03, AVNO, 036, 243N, 675W, 42, 995, XX, c 71, SEE, 947, 982, 474, 396, etc., ... out to 500 km c AL, 13, 2000092500, 03, AVNO, 036, 243N, 675W, 42, 995, XX, c 71, SWE, 645, 683, 328, 277, etc., ... out to 500 km c AL, 13, 2000092500, 03, AVNO, 036, 243N, 675W, 42, 995, XX, c 71, NWE, 725, 753, 619, 429, etc., ... out to 500 km c AL, 13, 2000092500, 03, AVNO, 036, 243N, 675W, 42, 995, XX, c 72, FRR, 1134, 1224, 852, 654, etc., ... out to 500 km c AL, 13, 2000092500, 03, AVNO, 036, 243N, 675W, 42, 995, XX, c 72, BRR, 944, 984, 472, 393, etc., ... out to 500 km c AL, 13, 2000092500, 03, AVNO, 036, 243N, 675W, 42, 995, XX, c 72, BLR, 649, 686, 321, 272, etc., ... out to 500 km c AL, 13, 2000092500, 03, AVNO, 036, 243N, 675W, 42, 995, XX, c 72, FLR, 729, 756, 613, 421, etc., ... out to 500 km c c NOTE: Each of the above lines beginning with "AL" is output as c a single line of text. c NOTE: These winds are in m/s coming into this routine and will c be converted to knots*10 for output (e.g., 1221 = 122.1 kts) c c The "71" ID indicates earth-relative winds, the "72" ID indicates c storm-relative winds. Here are the other IDs that will be used: c 81: Tangential winds, earth-relative (m/s) c 82: Tangential winds, storm-relative (m/s) c 91: Radial winds, earth-relative (m/s) c 92: Radial winds, storm-relative (m/s) c c Note that in this example, for this 36h forecast hour, there are c 8 entries. This is so that we can include the wind values for c the 4 different quadrants, for both the earth relative analyses c (NEE, SEE, SWE, NWE) and the storm-relative analyses (FRR, BRR, c BLR, FLR). c c This message also contains the intensity estimates (in knots) c for every forecast hours The conversion for m/s to knots is c to multiply m/s by 1.9427 (3.281 ft/m, 1 naut mile/6080 ft, c 3600s/h). c c NOTE: The longitudes that are passed into this subroutine are c given in 0 - 360, increasing eastward. The format for the c atcfunix system requires that the output be 0-180E or c 0-180W, so we must adjust the values, if needed. Also, the c values for southern latitudes must be positive (use 'N' and c 'S' to distinguish Northern/Southern Hemispheres). c c INPUT: c outlon longitude fix position for this storm at this time c which is to be written out to the output file c outlat latitude fix position for this storm at this time c which is to be written out to the output file c inp contains input date and model number information c ist the number storm that we're processing (can be 1-15) c ifcsthr the current forecast hour being output c vmaxwind the max surface wind for this storm at this fcst hour c xminmslp the min mslp for this storm at this fcst hour c er_wind Quadrant winds in earth-relative framework c sr_wind Quadrant winds in storm-relative framework c er_vr Quadrant radial winds in earth-relative framework c sr_vr Quadrant radial winds in storm-relative framework c er_vt Quadrant tangential winds in earth-relative framework c sr_vt Quadrant tangential winds in storm-relative framework c c OUTPUT: c ioaxret integer return code from this subroutine c c LOCAL: c intlon integer that holds the value of outlon*10 c intlat integer that holds the value of outlat*10 c USE def_vitals; USE inparms; USE set_max_parms; USE atcf USE verbose_output type (datecard) inp integer, parameter :: numdist=14,numquad=4,numbin=5,numthresh=3 integer ioutwind(numdist) real fixlon(maxstorm,maxtime),fixlat(maxstorm,maxtime) real er_wind(numquad,numdist) real sr_wind(numquad,numdist) real er_vr(numquad,numdist) real er_vt(numquad,numdist) real sr_vr(numquad,numdist) real sr_vt(numquad,numdist) real outlon,outlat real vmaxwind,conv_ms_knots,xminmslp,xsfclon,xsfclat integer intlon,intlat,output_fhr,id,intlon100,intlat100,ir character basinid*2,clatns*1,clonew*1,wfract_type*5,wt*1 character*2 :: cquad(4) = (/'NE','SE','SW','NW'/) character*2 :: crel(4) = (/'FR','BR','BL','FL'/) c First convert all of the lat/lon values from reals into integers. c These integer values must be 10x their real value (eg. 125.4 will c be written out as 1254). Convert the lon values so that they go c from 0-180E or 0-180W, and convert the lat values so that they are c positive and use 'N' or 'S' to differentiate hemispheres. conv_ms_knots = 1.9427 if (outlon < -998.0 .or. outlat < -998.0) then intlon = 0 intlat = 0 intlon100 = 0 intlat100 = 0 clonew = ' ' clatns = ' ' else if (outlon >= 180.0) then intlon = 3600 - int(outlon * 10. + 0.5) intlon100 = 36000 - int(outlon * 100. + 0.5) clonew = 'W' else intlon = int(outlon * 10. + 0.5) intlon100 = int(outlon * 100. + 0.5) clonew = 'E' endif intlat = int(abs(outlat) * 10. + 0.5) intlat100 = int(abs(outlat) * 100. + 0.5) if (outlat < 0.0) then clatns = 'S' else clatns = 'N' endif endif select case (storm(ist)%tcv_storm_id(3:3)) case ('L','l'); basinid = 'AL' case ('E','e'); basinid = 'EP' case ('C','c'); basinid = 'CP' case ('W','w'); basinid = 'WP' case ('O','o'); basinid = 'SC' case ('T','t'); basinid = 'EC' case ('U','u'); basinid = 'AU' case ('P','p'); basinid = 'SP' case ('S','s'); basinid = 'SI' case ('B','b'); basinid = 'BB' case ('A','a'); basinid = 'AA' case ('Q','q'); basinid = 'SL' case default; basinid = '**' end select if (atcfname(1:2) == 'SP') then ! Add 3 for SREF to account for the 3-hour off-synoptic ! time offset.... output_fhr = ifcsthour + 3 else output_fhr = ifcsthour endif c Total wind (converted to knots*10), earth relative.... do iq = 1,numquad do ir = 1,numdist if (er_wind(iq,ir) < -998.0) then ioutwind(ir) = -999 else ioutwind(ir) = int((er_wind(iq,ir)*conv_ms_knots*10)+0.5) endif enddo write (72,81) basinid,storm(ist)%tcv_storm_id(1:2) & ,atcfymdh & ,adjustr(atcfname),output_fhr,intlat,clatns,intlon,clonew & ,int((vmaxwind*conv_ms_knots) + 0.5) & ,int(xminmslp/100.0 + 0.5) & ,', XX, 71, ',cquad(iq),'E' & ,(ioutwind(it),it=1,numdist) & ,intlat100,clatns,intlon100,clonew enddo c Total wind (converted to knots*10), storm relative.... do iq = 1,numquad do ir = 1,numdist if (sr_wind(iq,ir) < -998.0) then ioutwind(ir) = -999 else ioutwind(ir) = int((sr_wind(iq,ir)*conv_ms_knots*10)+0.5) endif enddo write (72,81) basinid,storm(ist)%tcv_storm_id(1:2) & ,atcfymdh & ,adjustr(atcfname),output_fhr,intlat,clatns,intlon,clonew & ,int((vmaxwind*conv_ms_knots) + 0.5) & ,int(xminmslp/100.0 + 0.5) & ,', XX, 72, ',crel(iq),'R' & ,(ioutwind(it),it=1,numdist) & ,intlat100,clatns,intlon100,clonew enddo c Tangential wind (m/s * 10), earth relative.... do iq = 1,numquad do ir = 1,numdist if (er_vt(iq,ir) < -998.0) then ioutwind(ir) = -999 else ioutwind(ir) = int((er_vt(iq,ir)*conv_ms_knots*10)+0.5) endif enddo write (72,81) basinid,storm(ist)%tcv_storm_id(1:2) & ,atcfymdh & ,adjustr(atcfname),output_fhr,intlat,clatns,intlon,clonew & ,int((vmaxwind*conv_ms_knots) + 0.5) & ,int(xminmslp/100.0 + 0.5) & ,', XX, 81, ',cquad(iq),'E' & ,(ioutwind(it),it=1,numdist) & ,intlat100,clatns,intlon100,clonew enddo c Tangential wind (m/s * 10), storm relative.... do iq = 1,numquad do ir = 1,numdist if (sr_vt(iq,ir) < -998.0) then ioutwind(ir) = -999 else ioutwind(ir) = int((sr_vt(iq,ir)*conv_ms_knots*10)+0.5) endif enddo write (72,81) basinid,storm(ist)%tcv_storm_id(1:2) & ,atcfymdh & ,adjustr(atcfname),output_fhr,intlat,clatns,intlon,clonew & ,int((vmaxwind*conv_ms_knots) + 0.5) & ,int(xminmslp/100.0 + 0.5) & ,', XX, 82, ',crel(iq),'R' & ,(ioutwind(it),it=1,numdist) & ,intlat100,clatns,intlon100,clonew enddo c Radial wind (m/s * 10), earth relative.... do iq = 1,numquad do ir = 1,numdist if (er_vr(iq,ir) < -998.0) then ioutwind(ir) = -999 else ioutwind(ir) = int((er_vr(iq,ir)*conv_ms_knots*10)+0.5) endif enddo write (72,81) basinid,storm(ist)%tcv_storm_id(1:2) & ,atcfymdh & ,adjustr(atcfname),output_fhr,intlat,clatns,intlon,clonew & ,int((vmaxwind*conv_ms_knots) + 0.5) & ,int(xminmslp/100.0 + 0.5) & ,', XX, 91, ',cquad(iq),'E' & ,(ioutwind(it),it=1,numdist) & ,intlat100,clatns,intlon100,clonew enddo c Radial wind (m/s * 10), storm relative.... do iq = 1,numquad do ir = 1,numdist if (sr_vr(iq,ir) < -998.0) then ioutwind(ir) = -999 else ioutwind(ir) = int((sr_vr(iq,ir)*conv_ms_knots*10)+0.5) endif enddo write (72,81) basinid,storm(ist)%tcv_storm_id(1:2) & ,atcfymdh & ,adjustr(atcfname),output_fhr,intlat,clatns,intlon,clonew & ,int((vmaxwind*conv_ms_knots) + 0.5) & ,int(xminmslp/100.0 + 0.5) & ,', XX, 92, ',crel(iq),'R' & ,(ioutwind(it),it=1,numdist) & ,intlat100,clatns,intlon100,clonew enddo c 81 format (a2,', ',a2,', ',i10.10,', 03, ',a4,', ',i3.3,', ',i3,a1 & ,', ',i4,a1,', ',i3,', ',i4,a10,a2,a1,14(', ',i4) & ,', ',i4,a1,', ',i5,a1) c bug fix for IBM: flush the output stream so it actually writes flush(72) return end c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine output_ike (outlon,outlat,xsfclon,xsfclat,inp,ist & ,ifcsthour,vmaxwind,xminmslp,ike,sdp,wdp,maxstorm & ,ioiret) c c ABSTRACT: This subroutine outputs a 1-line message for a given c storm at an input forecast hour. This message contains the values c for the Integrated Kinetic Energy (IKE) and Storm Surge Damage c Potential (SDP), based on Powell (BAMS, 2007). At this time, we c are only computing the IKE values for TS threshold (17.5 m/s) and c above. We are not yet computing wind damage potential (WDP) c since, per Mark Powell (4/2008), he is currently re-formulating c an algorithm for it. c c LOCAL: c c Arrays: c c ike Integrated kinetic energy: c ike(1) = IKE_10m/s (storm energy) c ike(2) = IKE_18m/s (IKE_ts, tropical storm) c ike(3) = IKE_33m/s (IKE_h, hurricane) c ike(4) = IKE_25_40 m/s (Not currently computed) c ike(5) = IKE_41_54 m/s (Not currently computed) c ike(6) = IKE_55 m/s (Not currently computed) c c c The format used will mimic the current atcfunix format with the c difference coming late in the record, where the various wind radii c will be replaced with WDP, SDP and IKE values: c c AL, 13, 2000092500, 03, AVNO, 036, 243N, 675W, 42, 995, XX, 91, c IKE, 340, 560, 212, 174, 42, 93, 12, 0 c c Where the places are identified as follows: c c AL, 13, 2000092500, 03, AVNO, 036, 243N, 675W, 42, 995, XX, 91, c IKE, WDP, SDP, I10, ITS, IH ,I2540,I4154, I55 c c (NOTE: Each of the above lines beginning with "AL" is output as c a single line of text.) c c Values for WDP and SDP are multiplied by 10 in this routine c before being written out. c c This message also contains the intensity estimates (in knots) c for every forecast hour. The conversion for m/s to knots is c to multiply m/s by 1.9427 (3.281 ft/m, 1 naut mile/6080 ft, c 3600s/h). c c NOTE: The longitudes that are passed into this subroutine are c given in 0 - 360, increasing eastward. The format for the c atcfunix system requires that the output be 0-180E or c 0-180W, so we must adjust the values, if needed. Also, the c values for southern latitudes must be positive (use 'N' and c 'S' to distinguish Northern/Southern Hemispheres). c c INPUT: c storm An array of type tcvcard. Use this for the storm ID c outlon longitude fix position for this storm at this time c which is to be written out to the output file c outlat latitude fix position for this storm at this time c which is to be written out to the output file c xsfclon low-level longitude estimate for this storm & time, c computed ideally from mean of mslp & low-level winds. c xsfclat low-level latitude estimate for this storm & time, c computed ideally from mean of mslp & low-level winds. c inp contains input date and model number information c ist the number storm that we're processing (can be 1-15) c ifcsthr the current forecast hour being output c vmaxwind the max surface wind for this storm at this fcst hour c xminmslp the min mslp for this storm at this fcst hour c ike integrated kinetic energy, in units of TJ c sdp storm surge damage potential c wdp wind damage potential c c OUTPUT: c ioaxret integer return code from this subroutine c c LOCAL: c intlon integer that holds the value of outlon*10 c intlat integer that holds the value of outlat*10 c USE def_vitals; USE inparms; USE set_max_parms; USE atcf USE verbose_output type (datecard) inp c integer, parameter :: numdist=14,numquad=4,numbin=5,numthresh=3 real outlon,outlat,sdp,wdp real ike(max_ike_cats) real vmaxwind,conv_ms_knots,xminmslp,xsfclon,xsfclat integer intlon,intlat,output_fhr,intlon100,intlat100,maxstorm character basinid*2,clatns*1,clonew*1,wfract_type*5,wt*1,cquad*2 c First convert all of the lat/lon values from reals into integers. c These integer values must be 10x their real value (eg. 125.4 will c be written out as 1254). Convert the lon values so that they go c from 0-180E or 0-180W, and convert the lat values so that they are c positive and use 'N' or 'S' to differentiate hemispheres. conv_ms_knots = 1.9427 if (outlon < -998.0 .or. outlat < -998.0) then intlon = 0 intlat = 0 intlon100 = 0 intlat100 = 0 clonew = ' ' clatns = ' ' else if (outlon >= 180.0) then intlon = 3600 - int(outlon * 10. + 0.5) intlon100 = 36000 - int(outlon * 100. + 0.5) clonew = 'W' else intlon = int(outlon * 10. + 0.5) intlon100 = int(outlon * 100. + 0.5) clonew = 'E' endif intlat = int(abs(outlat) * 10. + 0.5) intlat100 = int(abs(outlat) * 100. + 0.5) if (outlat < 0.0) then clatns = 'S' else clatns = 'N' endif endif select case (storm(ist)%tcv_storm_id(3:3)) case ('L','l'); basinid = 'AL' case ('E','e'); basinid = 'EP' case ('C','c'); basinid = 'CP' case ('W','w'); basinid = 'WP' case ('O','o'); basinid = 'SC' case ('T','t'); basinid = 'EC' case ('U','u'); basinid = 'AU' case ('P','p'); basinid = 'SP' case ('S','s'); basinid = 'SI' case ('B','b'); basinid = 'BB' case ('A','a'); basinid = 'AA' case ('Q','q'); basinid = 'SL' case default; basinid = '**' end select if (atcfname(1:2) == 'SP') then ! Add 3 for SREF to account for the 3-hour off-synoptic ! time offset.... output_fhr = ifcsthour + 3 else output_fhr = ifcsthour endif write (74,81) basinid,storm(ist)%tcv_storm_id(1:2) & ,atcfymdh & ,adjustr(atcfname),output_fhr,intlat,clatns,intlon,clonew & ,int((vmaxwind*conv_ms_knots) + 0.5) & ,int(xminmslp/100.0 + 0.5) & ,', XX, 91, IKE',int((wdp*10)+0.5),int((sdp*10)+0.5) & ,int(ike(1)+0.5),int(ike(2)+0.5),int(ike(3)+0.5) & ,int(ike(4)+0.5),int(ike(5)+0.5),int(ike(6)+0.5) & ,intlat100,clatns,intlon100,clonew c 81 format (a2,', ',a2,', ',i10.10,', 03, ',a4,', ',i3.3,', ',i3,a1 & ,', ',i4,a1,', ',i3,', ',i4,a14,8(',',i5) & ,', ',i4,a1,', ',i5,a1) c bug fix for IBM: flush the output stream so it actually writes flush(74) return end c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine output_phase (outlon,outlat,inp,ist & ,ifcsthour,vmaxwind,xminmslp,paramb,vtl_slope & ,vtu_slope,ioiret) c c ABSTRACT: This subroutine outputs a 1-line message for a given c storm at an input forecast hour. This message contains the values c for the three parameters that comprise Bob Hart's cyclone phase c space (CPS). These parameters are his "parameter B", which c assesses the left-right thermal asymmetry, and the upper c troposphere (300-600 mb) and lower troposphere (900-600 mb) c thermal wind values. c c LOCAL: c c Arrays: c c The format used will mimic the current atcfunix format with the c difference coming late in the record, where the various wind radii c will be replaced with paramb, vtl_slope and vtu_slope values: c c AL, 13, 2000092500, 03, AVNO, 036, 243N, 675W, 42, 995, XX, 95, c CPS, 340, 560, 212 c c Where the places are identified as follows: c c AL, 13, 2000092500, 03, AVNO, 036, 243N, 675W, 42, 995, XX, 95, c CPS, B, VTL, VTU c c (NOTE: Each of the above lines beginning with "AL" is output as c a single line of text.) c c This message also contains the intensity estimates (in knots) c for every forecast hour. The conversion for m/s to knots is c to multiply m/s by 1.9427 (3.281 ft/m, 1 naut mile/6080 ft, c 3600s/h). c c NOTE: The longitudes that are passed into this subroutine are c given in 0 - 360, increasing eastward. The format for the c atcfunix system requires that the output be 0-180E or c 0-180W, so we must adjust the values, if needed. Also, the c values for southern latitudes must be positive (use 'N' and c 'S' to distinguish Northern/Southern Hemispheres). c c INPUT: c storm An array of type tcvcard. Use this for the storm ID c outlon longitude fix position for this storm at this time c which is to be written out to the output file c outlat latitude fix position for this storm at this time c which is to be written out to the output file c inp contains input date and model number information c ist the number storm that we're processing (can be 1-15) c ifcsthr the current forecast hour being output c vmaxwind the max surface wind for this storm at this fcst hour c xminmslp the min mslp for this storm at this fcst hour c paramb thermal asymmetry c vtl_slope thermal wind value for lower troposphere (900-600 mb) c vtu_slope thermal wind value for upper troposphere (600-300 mb) c c OUTPUT: c ioiret integer return code from this subroutine c c LOCAL: c intlon integer that holds the value of outlon*10 c intlat integer that holds the value of outlat*10 c USE def_vitals; USE inparms; USE set_max_parms; USE atcf USE verbose_output type (datecard) inp real outlon,outlat,paramb,vtl_slope,vtu_slope real vmaxwind,conv_ms_knots,xminmslp integer intlon,intlat,output_fhr character basinid*2,clatns*1,clonew*1 c First convert all of the lat/lon values from reals into integers. c These integer values must be 10x their real value (eg. 125.4 will c be written out as 1254). Convert the lon values so that they go c from 0-180E or 0-180W, and convert the lat values so that they are c positive and use 'N' or 'S' to differentiate hemispheres. conv_ms_knots = 1.9427 if (outlon < -998.0 .or. outlat < -998.0) then intlon = 0 intlat = 0 clonew = ' ' clatns = ' ' else if (outlon >= 180.0) then intlon = 3600 - int(outlon * 10. + 0.5) clonew = 'W' else intlon = int(outlon * 10. + 0.5) clonew = 'E' endif intlat = int(abs(outlat) * 10. + 0.5) if (outlat < 0.0) then clatns = 'S' else clatns = 'N' endif endif select case (storm(ist)%tcv_storm_id(3:3)) case ('L','l'); basinid = 'AL' case ('E','e'); basinid = 'EP' case ('C','c'); basinid = 'CP' case ('W','w'); basinid = 'WP' case ('O','o'); basinid = 'SC' case ('T','t'); basinid = 'EC' case ('U','u'); basinid = 'AU' case ('P','p'); basinid = 'SP' case ('S','s'); basinid = 'SI' case ('B','b'); basinid = 'BB' case ('A','a'); basinid = 'AA' case ('Q','q'); basinid = 'SL' case default; basinid = '**' end select if (atcfname(1:2) == 'SP') then ! Add 3 for SREF to account for the 3-hour off-synoptic ! time offset.... output_fhr = ifcsthour + 3 else output_fhr = ifcsthour endif write (71,81) basinid,storm(ist)%tcv_storm_id(1:2) & ,atcfymdh & ,adjustr(atcfname),output_fhr,intlat,clatns,intlon,clonew & ,int((vmaxwind*conv_ms_knots) + 0.5) & ,int(xminmslp/100.0 + 0.5) & ,', XX, 95, CPS',int(paramb+0.5),int(vtl_slope+0.5) & ,int(vtu_slope+0.5) c 81 format (a2,', ',a2,', ',i10.10,', 03, ',a4,', ',i3.3,', ',i3,a1 & ,', ',i4,a1,', ',i3,', ',i4,', ',a14,3(',',i6)) c bug fix for IBM: flush the output stream so it actually writes flush(71) return end c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine output_atcf_gen (outlon,outlat,inp,ist & ,ifcsthour,vmaxwind,xminmslp,vradius,maxstorm & ,trkrinfo,istmspd,istmdir,plastbar,rlastbar,rmax & ,cps_vals,wcore_flag,imeanzeta,igridzeta,ioaxret) c ABSTRACT: This subroutine outputs a 1-line message for a given c storm at an input forecast hour in a modified atcfunix format. c The reason that it's called "modified" is that the format is c slightly different from the standard TPC-accepted atcfunix c format that they use for TCs. Specifically, the first part that c identifies the storm is different. Here's an example of the c TPC standard atcfunix format: c c AL, 13, 2000092500, 03, GFSO, 036, 243N, 675W, 42, 995, XX, 34, c NEQ, 242, 163, 124, 208 c AL, 13, 2000092500, 03, GFSO, 036, 243N, 675W, 42, 995, XX, 50, c NEQ, 155, 000, 000, 000 c AL, 13, 2000092500, 03, GFSO, 036, 243N, 675W, 42, 995, XX, 64, c NEQ, 000, 000, 000, 000 c c (NOTE: Each of the above lines beginning with "AL" is output as c a single line of text.... they're just broken up into 2 c lines here for readability.) c c Here's an example of the modified output format for the same c storm. Note that the lat/lon identifier in the new storm id at c the beginning of the record is different from that shown later c in the record. The reason is that the lat/lon identifier will c be the one that is pulled from the tcvitals or gen_vitals c record: c c 2000092500_230N_0658W_13L, 2000092500, 03, GFSO, 036, 243N, 675W, c 42, 995, XX, 34, NEQ, 242, 163, 124, 208 c 2000092500_230N_0658W_13L, 2000092500, 03, GFSO, 036, 243N, 675W, c 42, 995, XX, 50, NEQ, 155, 000, 000, 000 c 2000092500_230N_0658W_13L, 2000092500, 03, GFSO, 036, 243N, 675W, c 42, 995, XX, 64, NEQ, 000, 000, 000, 000 c c c Note that in this example, for this 36h forecast hour, there are c 3 entries. This is so that we can include the radii for the c 3 different wind thresholds (34kt, 50kt and 64kt). So the only c thing different in each entry is the wind radii info; all the c other info is identical for each entry. c c This message also contains the intensity estimates (in knots) c for every forecast hours The conversion for m/s to knots is c to multiply m/s by 1.9427 (3.281 ft/m, 1 naut mile/6080 ft, c 3600s/h). c c NOTE: The longitudes that are passed into this subroutine are c given in 0 - 360, increasing eastward. The format for the c atcfunix system requires that the output be 0-180E or c 0-180W, so we must adjust the values, if needed. Also, the c values for southern latitudes must be positive (use 'N' and c 'S' to distinguish Northern/Southern Hemispheres). c c INPUT: c outlon longitude fix position for this storm at this time c which is to be written out to the output file c outlat latitude fix position for this storm at this time c which is to be written out to the output file c inp contains input date and model number information c ist the number storm that we're processing (can be 1-15) c ifcsthr the current forecast hour being output c vmaxwind the max surface wind for this storm at this fcst hour c xminmslp the min mslp for this storm at this fcst hour c vradius Contains the distance from the storm fix position to c each of the various wind threshhold distances in each c quadrant. (3,4) ==> (# of threshholds, # of quadrants) c maxstorm max # of storms that can be handled c istmspd storm translation speed c istmdir direction of storm movement c plastbar pressure of last closed isobar c rlastbar radius of last closed isobar c rmax radius of max winds c cps_vals Hart's cyclone phase space values: (1) is for parameter c B (thickness asymmetry), (2) and (3) are for thermal c wind values. c wcore_flag 'u'=undetermined, 'y'=yes, 'n'=no c imeanzeta array with values of mean 850 & 700 zeta c igridzeta array with values of max (gridpoint) 850 & 700 zeta c c OUTPUT: c ioaxret integer return code from this subroutine c c LOCAL: c intlon integer that holds the value of outlon*10 c intlat integer that holds the value of outlat*10 c storm An array of type tcvcard. Use this for the storm ID c USE def_vitals; USE inparms; USE set_max_parms; USE atcf USE trkrparms; USE gen_vitals; USE level_parms USE verbose_output type (gencard) gstm type (datecard) inp type (trackstuff) trkrinfo c real outlon,outlat,plastbar,rlastbar,rmax real vmaxwind,conv_ms_knots,xminmslp,mslp_outp_adj real cps_vals(3) integer intlon,intlat,istmspd,istmdir,iplastbar,irlastbar,irmax integer ivtl,ivtu,iparamb,output_fhr integer vradius(3,4) integer imeanzeta(nlevgrzeta),igridzeta(nlevgrzeta) character basinid*2,clatns*1,clonew*1,wcore_flag*1 if ( verb .ge. 3) then print *,'+++ Top of output_atcf_gen, ist= ',ist,' ifh= ' & ,ifcsthour endif if (xminmslp == 999999.0) xminmslp = 0.0 if (xminmslp < 1100.0) then ! Pressure units are in mb... mslp_outp_adj = 1.0 elseif (xminmslp >80000.0) then ! Pressure units are in Pa... mslp_outp_adj = 100.0 else if (verb .ge. 3) then print *,' ' print *,'ERROR: Something wrong in subroutine' print *,' output_atcf_gen. The mslp value' print *,' (xminmslp) is not in range.' print *,' xminmslp = ',xminmslp print *,' EXITING....' print *,' ' stop 95 endif endif c First convert all of the lat/lon values from reals into integers. c These integer values must be 10x their real value (eg. 125.4 will c be written out as 1254). Convert the lon values so that they go c from 0-180E or 0-180W, and convert the lat values so that they are c positive and use 'N' or 'S' to differentiate hemispheres. conv_ms_knots = 1.9427 if (outlon < -998.0 .or. outlat < -998.0) then intlon = 0 intlat = 0 clonew = ' ' clatns = ' ' else if (outlon >= 180.0) then intlon = 3600 - int(outlon * 10. + 0.5) clonew = 'W' else intlon = int(outlon * 10. + 0.5) clonew = 'E' endif intlat = int(abs(outlat) * 10. + 0.5) if (outlat < 0.0) then clatns = 'S' else clatns = 'N' endif endif c Unlike the regular atcfunix output, in which we output a record c at forecast time = 00h even if the storm cannot be found, here c we don't want to do that. So check the lat & lon positions and c exit this subroutine now if they're both zero. if (intlat == 0 .and. intlon == 0) then if ( verb .ge. 3 ) then print *,' ' print *,'+++ Currently inside output_atcf_gen. The reported' print *,'+++ longitude and latitude are both zero, so that ' print *,'+++ means that the tracker could not get a fix ' print *,'+++ for this storm at this hour. Therefore, we will' print *,'+++ NOT write out an atcf_gen record for this' print *,'+++ storm & forecast hour.' print *,'+++ ' print *,'+++ ist= ',ist print *,'+++ gstorm= ',gstorm(ist) print *,' ' endif return endif c Initially, set all "gstm" components equal to the input "gstorm" c components for this storm, then we will change the specific c components that we need to. gstm = gstorm(ist) c If the "gv_gen_date" for this storm does not equal 99999, c then that means that a vitals was read in for this storm in c subroutine read_gen_vitals, so be sure to use the genesis c date, genesis latitude and genesis longitude for the storm c identifier at the beginning of the modified atcfunix record. if (gstm%gv_gen_date /= 99999) then continue ! Just use the info off the genesis vitals record else ! This storm was found on the fly during ! this run and there was no previous vitals record for ! this system. The information that will be used to ! identify the genesis location is the same exact info ! as the tracker-found position for this time. gstm%gv_gen_date = inp%bcc * 100000000 & + inp%byy * 1000000 & + inp%bmm * 10000 & + inp%bdd * 100 & + inp%bhh gstm%gv_gen_fhr = ifcsthour gstm%gv_gen_lat = intlat gstm%gv_gen_latns = clatns gstm%gv_gen_lon = intlon gstm%gv_gen_lonew = clonew gstm%gv_gen_type = 'FOF' endif if (plastbar > -990.0) then iplastbar = int(plastbar/mslp_outp_adj + 0.5) else iplastbar = -999 endif if (rlastbar > -990.0) then irlastbar = int(rlastbar + 0.5) else irlastbar = -999 endif if (rmax > -90.0) then irmax = int(rmax + 0.5) else irmax = -99 endif if (cps_vals(1) > -9999.0) then if (cps_vals(1) >= 0.0) then iparamb = int(cps_vals(1)*10 + 0.5) else iparamb = int(cps_vals(1)*10 - 0.5) endif else iparamb = -999 endif if (cps_vals(2) > -9999.0) then if (cps_vals(2) >= 0.0) then ivtl = int(cps_vals(2)*10 + 0.5) else ivtl = int(cps_vals(2)*10 - 0.5) endif else ivtl = -9999 endif if (cps_vals(3) > -9999.0) then if (cps_vals(3) >= 0.0) then ivtu = int(cps_vals(3)*10 + 0.5) else ivtu = int(cps_vals(3)*10 - 0.5) endif else ivtu = -9999 endif select case (storm(ist)%tcv_storm_id(3:3)) case ('L','l'); basinid = 'AL' case ('E','e'); basinid = 'EP' case ('C','c'); basinid = 'CP' case ('W','w'); basinid = 'WP' case ('O','o'); basinid = 'SC' case ('T','t'); basinid = 'EC' case ('U','u'); basinid = 'AU' case ('P','p'); basinid = 'SP' case ('S','s'); basinid = 'SI' case ('B','b'); basinid = 'BB' case ('A','a'); basinid = 'AA' case ('Q','q'); basinid = 'SL' case default; basinid = 'HC' end select if (atcfname(1:2) == 'SP') then ! Add 3 for SREF to account for the 3-hour off-synoptic ! time offset.... output_fhr = ifcsthour + 3 else output_fhr = ifcsthour endif if (stcvtype(ist) == 'FOF') then ! If this is a TC vitals-described storm (i.e., one that is ! numbered by JTWC or NHC), then leave the basinid as is. ! Otherwise, we want to use the "basinid" location as a ! label to identify what type of run this is. if (trkrinfo%type == 'midlat') basinid = 'ML' if (trkrinfo%type == 'tcgen') basinid = 'TG' endif write (66,87) basinid,adjustr(storm(ist)%tcv_storm_id) & ,gstm%gv_gen_date,gstm%gv_gen_fhr,gstm%gv_gen_lat & ,gstm%gv_gen_latns,gstm%gv_gen_lon & ,gstm%gv_gen_lonew,gstm%gv_gen_type & ,atcfymdh & ,adjustr(atcfname),output_fhr,intlat,clatns,intlon,clonew & ,int((vmaxwind*conv_ms_knots) + 0.5) & ,int(xminmslp/mslp_outp_adj + 0.5) & ,'XX, 34, NEQ' & ,vradius(1,1),vradius(1,2),vradius(1,3),vradius(1,4) & ,iplastbar,irlastbar,irmax,iparamb,ivtl,ivtu,wcore_flag & ,istmdir,istmspd & ,imeanzeta(1),igridzeta(1),imeanzeta(2),igridzeta(2) if (vradius(2,1) > 0 .or. vradius(2,2) > 0 .or. & vradius(2,3) > 0 .or. vradius(2,4) > 0) then write (66,87) basinid,adjustr(storm(ist)%tcv_storm_id) & ,gstm%gv_gen_date,gstm%gv_gen_fhr,gstm%gv_gen_lat & ,gstm%gv_gen_latns,gstm%gv_gen_lon & ,gstm%gv_gen_lonew,gstm%gv_gen_type & ,atcfymdh & ,adjustr(atcfname),output_fhr,intlat,clatns,intlon,clonew & ,int((vmaxwind*conv_ms_knots) + 0.5) & ,int(xminmslp/mslp_outp_adj + 0.5) & ,'XX, 50, NEQ' & ,vradius(2,1),vradius(2,2),vradius(2,3),vradius(2,4) & ,iplastbar,irlastbar,irmax,iparamb,ivtl,ivtu,wcore_flag & ,istmdir,istmspd & ,imeanzeta(1),igridzeta(1),imeanzeta(2),igridzeta(2) endif if (vradius(3,1) > 0 .or. vradius(3,2) > 0 .or. & vradius(3,3) > 0 .or. vradius(3,4) > 0) then write (66,87) basinid,adjustr(storm(ist)%tcv_storm_id) & ,gstm%gv_gen_date,gstm%gv_gen_fhr,gstm%gv_gen_lat & ,gstm%gv_gen_latns,gstm%gv_gen_lon & ,gstm%gv_gen_lonew,gstm%gv_gen_type & ,atcfymdh & ,adjustr(atcfname),output_fhr,intlat,clatns,intlon,clonew & ,int((vmaxwind*conv_ms_knots) + 0.5) & ,int(xminmslp/mslp_outp_adj + 0.5) & ,'XX, 64, NEQ' & ,vradius(3,1),vradius(3,2),vradius(3,3),vradius(3,4) & ,iplastbar,irlastbar,irmax,iparamb,ivtl,ivtu,wcore_flag & ,istmdir,istmspd & ,imeanzeta(1),igridzeta(1),imeanzeta(2),igridzeta(2) endif 87 format (a2,', ',a4,', ',i10.10,'_F',i3.3,'_',i3.3,a1,'_',i4.4,a1 & ,'_',a3,', ',i10.10,', 03, ',a4,', ',i3.3,', ',i3,a1 & ,', ',i4,a1,', ',i3,', ',i4,', ',a12,4(', ',i4.4) & ,', ',3(i4,', '),3(i6,', '),a1,2(', ',i4),4(', ',i4)) c bug fix for IBM: flush the output stream so it actually writes flush(66) return end c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine output_atcf_sink (outlon,outlat,inp,ist & ,ifcsthour,vmaxwind,xminmslp,vradius,maxstorm & ,trkrinfo,istmspd,istmdir,imeanzeta,igridzeta & ,cps_vals,plastbar,rlastbar,ioaxret) c ABSTRACT: This subroutine outputs a 1-line message for a given c storm at an input forecast hour in a modified atcfunix format. c The "sink" in the subroutine name indicates that this output c contains the whole kitchen sink of forecast storm info. c The reason that it's called "modified" is that the format is c slightly different from the standard TPC-accepted atcfunix c format that they use for TCs. Specifically, the first part that c identifies the storm is different, and the part after the radii c data is different. Here's an example of the TPC standard c atcfunix format: c c AL, 13, 2000092500, 03, GFSO, 036, 243N, 675W, 42, 995, XX, 34, c NEQ, 242, 163, 124, 208 c AL, 13, 2000092500, 03, GFSO, 036, 243N, 675W, 42, 995, XX, 50, c NEQ, 155, 000, 000, 000 c AL, 13, 2000092500, 03, GFSO, 036, 243N, 675W, 42, 995, XX, 64, c NEQ, 000, 000, 000, 000 c c (NOTE: Each of the above lines beginning with "AL" is output as c a single line of text.... they're just broken up into 2 c lines here for readability.) c c Here's an example of the modified output format for the same c storm. Note that the lat/lon identifier in the new storm id at c the beginning of the record is different from that shown later c in the record. The reason is that the lat/lon identifier will c indicate the lat/lon at which the storm was *first* found in c the model. The position may be either found within this run c of the tracker, or that position may have been pulled from the c tcvitals or gen_vitals record: c c 2000092500_F000_206N_0623W_13L, 2000092500, 03, GFSO, 036 c , 243N, 675W, 42, 995, XX, 34, NEQ, 242, 163, 124, 208 c , PLAS, RLAS, RMX, DIR, SPD, B, VTU, VTL c , Z8MN, Z8MX, Z7MN, Z7MX c c As noted above, there is extra info at the end, after the c "34, NEQ, 242, 163, 124, 208" radii info. Here is a key c to indicate what these items are: c c PLAS: Pressure (mb) of last closed isobar c RLAS: Radius of the last closed isobar in nm, 0 - 9999 nm. c RMX: Radius of max winds, 0 - 999 nm. c DIR: Direction of storm motion. c SPD: Speed of storm motion (m/s * 10). c B: Hart's CPS "Parameter B" thickness asymmetry value (m). c VTL: Hart's CPS thermal wind (Lower, 900-600) value. c VTU: Hart's CPS thermal wind (Upper, 600-300) value. c Z8MN: Mean value of 850 mb zeta surrounding storm. c Z8MX: Max value of 850 mb zeta near storm. c Z7MN: Mean value of 700 mb zeta surrounding storm. c Z7MX: Max value of 700 mb zeta near storm. c c This message also contains the intensity estimates (in knots) c for every forecast hour. The conversion for m/s to knots is c to multiply m/s by 1.9427 (3.281 ft/m, 1 naut mile/6080 ft, c 3600s/h). c c NOTE: The longitudes that are passed into this subroutine are c given in 0 - 360, increasing eastward. The format for the c atcfunix system requires that the output be 0-180E or c 0-180W, so we must adjust the values, if needed. Also, the c values for southern latitudes must be positive (use 'N' and c 'S' to distinguish Northern/Southern Hemispheres). c c INPUT: c outlon longitude fix position for this storm at this time c which is to be written out to the output file c outlat latitude fix position for this storm at this time c which is to be written out to the output file c inp contains input date and model number information c ist the number storm that we're processing (can be 1-15) c ifcsthr the current forecast hour being output c vmaxwind the max surface wind for this storm at this fcst hour c xminmslp the min mslp for this storm at this fcst hour c vradius Contains the distance from the storm fix position to c each of the various wind threshhold distances in each c quadrant. (3,4) ==> (# of threshholds, # of quadrants) c maxstorm max # of storms that can be handled c istmspd speed of storm translation c istmdir direction of storm motion c cps_vals Hart's cyclone phase space values: (1) is for parameter c B (thickness asymmetry), (2) and (3) are for thermal c wind values. c imeanzeta array with values of mean 850 & 700 zeta c igridzeta array with values of max (gridpoint) 850 & 700 zeta c plastbar pressure of last closed isobar (pa) c rlastbar radius of last closed isobar (nm) c c OUTPUT: c ioaxret integer return code from this subroutine c c LOCAL: c intlon integer that holds the value of outlon*10 c intlat integer that holds the value of outlat*10 c storm An array of type tcvcard. Use this for the storm ID c USE def_vitals; USE inparms; USE set_max_parms; USE atcf USE trkrparms; USE gen_vitals USE verbose_output type (gencard) gstm type (datecard) inp type (trackstuff) trkrinfo c real cps_vals(3) real outlon,outlat,mslp_outp_adj real vmaxwind,conv_ms_knots,xminmslp,plastbar,rlastbar integer intlon,intlat,istmspd,istmdir,iplastbar,irlastbar integer iparamb,ivtl,ivtu,output_fhr integer vradius(3,4) integer imeanzeta(2),igridzeta(2) character basinid*2,clatns*1,clonew*1 if ( verb .ge. 3 ) then print *,'+++ Top of output_atcf_sink, ist= ',ist,' ifh= ' & ,ifcsthour endif if (xminmslp == 999999.0) xminmslp = 0.0 if (xminmslp < 1100.0) then ! Pressure units are in mb... mslp_outp_adj = 1.0 elseif (xminmslp >80000.0) then ! Pressure units are in Pa... mslp_outp_adj = 100.0 else if (verb .ge. 3) then print *,' ' print *,'ERROR: Something wrong in subroutine' print *,' output_atcf_gen. The mslp value' print *,' (xminmslp) is not in range.' print *,' xminmslp = ',xminmslp print *,' EXITING....' print *,' ' stop 95 endif endif c First convert all of the lat/lon values from reals into integers. c These integer values must be 10x their real value (eg. 125.4 will c be written out as 1254). Convert the lon values so that they go c from 0-180E or 0-180W, and convert the lat values so that they are c positive and use 'N' or 'S' to differentiate hemispheres. conv_ms_knots = 1.9427 if (outlon < -998.0 .or. outlat < -998.0) then intlon = 0 intlat = 0 clonew = ' ' clatns = ' ' else if (outlon >= 180.0) then intlon = 3600 - int(outlon * 10. + 0.5) clonew = 'W' else intlon = int(outlon * 10. + 0.5) clonew = 'E' endif intlat = int(abs(outlat) * 10. + 0.5) if (outlat < 0.0) then clatns = 'S' else clatns = 'N' endif endif select case (storm(ist)%tcv_storm_id(3:3)) case ('L','l'); basinid = 'AL' case ('E','e'); basinid = 'EP' case ('C','c'); basinid = 'CP' case ('W','w'); basinid = 'WP' case ('O','o'); basinid = 'SC' case ('T','t'); basinid = 'EC' case ('U','u'); basinid = 'AU' case ('P','p'); basinid = 'SP' case ('S','s'); basinid = 'SI' case ('B','b'); basinid = 'BB' case ('A','a'); basinid = 'AA' case ('Q','q'); basinid = 'SL' case default; basinid = 'HC' end select if (trkrinfo%type == 'midlat' .or. trkrinfo%type == 'tcgen') then if (stcvtype(ist) == 'FOF') then ! If this is a TC vitals-described storm (i.e., one that is ! numbered by JTWC or NHC), then leave the basinid as is. ! Otherwise, we want to use the "basinid" location as a ! label to identify what type of run this is. if (trkrinfo%type == 'midlat') basinid = 'ML' if (trkrinfo%type == 'tcgen') basinid = 'TG' endif endif c Unlike the regular atcfunix output, in which we output a record c at forecast time = 00h even if the storm cannot be found, here c we don't want to do that. So check the lat & lon positions and c exit this subroutine now if they're both zero. if (intlat == 0 .and. intlon == 0) then if ( verb .ge. 3 ) then print *,' ' print *,'+++ Currently inside output_atcf_gen. The reported' print *,'+++ longitude and latitude are both zero, so that ' print *,'+++ means that the tracker could not get a fix ' print *,'+++ for this storm at this hour. Therefore, we will' print *,'+++ NOT write out an atcf_gen record for this' print *,'+++ storm & forecast hour.' print *,'+++ ' print *,'+++ ist= ',ist print *,'+++ gstorm= ',gstorm(ist) print *,' ' endif return endif c Initially, set all "gstm" components equal to the input "gstorm" c components for this storm, then we will change the specific c components that we need to. gstm = gstorm(ist) c If the "gv_gen_date" for this storm does not equal 99999, c then that means that a vitals was read in for this storm in c subroutine read_gen_vitals, so be sure to use the genesis c date, genesis latitude and genesis longitude for the storm c identifier at the beginning of the modified atcfunix record. if (gstm%gv_gen_date /= 99999) then continue ! Just use the info off the genesis vitals record else ! This storm was found on the fly during ! this run and there was no previous vitals record for ! this system. The information that will be used to ! identify the genesis location is the same exact info ! as the tracker-found position for this time. gstm%gv_gen_date = inp%bcc * 100000000 & + inp%byy * 1000000 & + inp%bmm * 10000 & + inp%bdd * 100 & + inp%bhh gstm%gv_gen_fhr = ifcsthour gstm%gv_gen_lat = intlat gstm%gv_gen_latns = clatns gstm%gv_gen_lon = intlon gstm%gv_gen_lonew = clonew gstm%gv_gen_type = 'FOF' ! Transfer all this local "gstm" data back into the ! saved "gstorm" array for use in subsequent fcst hrs... gstorm(ist) = gstm endif if (plastbar > -990.0) then iplastbar = int(plastbar/mslp_outp_adj + 0.5) else iplastbar = -999 endif if (rlastbar > -990.0) then irlastbar = int(rlastbar + 0.5) else irlastbar = -999 endif if (cps_vals(1) > -9999.0) then if (cps_vals(1) >= 0.0) then iparamb = int(cps_vals(1)*10 + 0.5) else iparamb = int(cps_vals(1)*10 - 0.5) endif else iparamb = -999 endif if (cps_vals(2) > -9999.0) then if (cps_vals(2) >= 0.0) then ivtl = int(cps_vals(2)*10 + 0.5) else ivtl = int(cps_vals(2)*10 - 0.5) endif else ivtl = -9999 endif if (cps_vals(3) > -9999.0) then if (cps_vals(3) >= 0.0) then ivtu = int(cps_vals(3)*10 + 0.5) else ivtu = int(cps_vals(3)*10 - 0.5) endif else ivtu = -9999 endif if (atcfname(1:2) == 'SP') then ! Add 3 for SREF to account for the 3-hour off-synoptic ! time offset.... output_fhr = ifcsthour + 3 else output_fhr = ifcsthour endif write (68,87) basinid,storm(ist)%tcv_storm_id & ,gstm%gv_gen_date,gstm%gv_gen_fhr,gstm%gv_gen_lat & ,gstm%gv_gen_latns,gstm%gv_gen_lon & ,gstm%gv_gen_lonew,gstm%gv_gen_type & ,atcfymdh & ,adjustr(atcfname),output_fhr,intlat,clatns,intlon,clonew & ,int((vmaxwind*conv_ms_knots) + 0.5) & ,int(xminmslp/mslp_outp_adj + 0.5) & ,'XX, 34, NEQ' & ,vradius(1,1),vradius(1,2),vradius(1,3),vradius(1,4) & ,iplastbar,irlastbar,-99,istmdir,istmspd & ,iparamb,ivtl,ivtu & ,imeanzeta(1),igridzeta(1),imeanzeta(2),igridzeta(2) & ,storm(ist)%tcv_storm_name if (vradius(2,1) > 0 .or. vradius(2,2) > 0 .or. & vradius(2,3) > 0 .or. vradius(2,4) > 0) then write (68,87) basinid,storm(ist)%tcv_storm_id & ,gstm%gv_gen_date,gstm%gv_gen_fhr,gstm%gv_gen_lat & ,gstm%gv_gen_latns,gstm%gv_gen_lon & ,gstm%gv_gen_lonew,gstm%gv_gen_type & ,atcfymdh & ,adjustr(atcfname),output_fhr,intlat,clatns,intlon,clonew & ,int((vmaxwind*conv_ms_knots) + 0.5) & ,int(xminmslp/mslp_outp_adj + 0.5) & ,'XX, 50, NEQ' & ,vradius(2,1),vradius(2,2),vradius(2,3),vradius(2,4) & ,iplastbar,irlastbar,-99,istmdir,istmspd & ,iparamb,ivtl,ivtu & ,imeanzeta(1),igridzeta(1),imeanzeta(2),igridzeta(2) & ,storm(ist)%tcv_storm_name endif if (vradius(3,1) > 0 .or. vradius(3,2) > 0 .or. & vradius(3,3) > 0 .or. vradius(3,4) > 0) then write (68,87) basinid,storm(ist)%tcv_storm_id & ,gstm%gv_gen_date,gstm%gv_gen_fhr,gstm%gv_gen_lat & ,gstm%gv_gen_latns,gstm%gv_gen_lon & ,gstm%gv_gen_lonew,gstm%gv_gen_type & ,atcfymdh & ,adjustr(atcfname),output_fhr,intlat,clatns,intlon,clonew & ,int((vmaxwind*conv_ms_knots) + 0.5) & ,int(xminmslp/mslp_outp_adj + 0.5) & ,'XX, 64, NEQ' & ,vradius(3,1),vradius(3,2),vradius(3,3),vradius(3,4) & ,iplastbar,irlastbar,-99,istmdir,istmspd & ,iparamb,ivtl,ivtu & ,imeanzeta(1),igridzeta(1),imeanzeta(2),igridzeta(2) & ,storm(ist)%tcv_storm_name endif c 87 format (i10.10,'_',i3.3,a1,'_',i4.4,a1,'_',a3,', ',5i2.2 c & ,', 03, ',a4,', ',i3.3,', ',i3,a1 c & ,', ',i4,a1,', ',i3,', ',i4,', ',a12,4(', ',i4.4)) c 87 format (a2,', ',a4,', ',i10.10,'_F',i3.3,'_',i3.3,a1,'_',i4.4,a1 c & ,'_',a3,', ',i10.10,', 03, ',a4,', ',i3.3,', ',i3,a1 c & ,', ',i4,a1,', ',i3,', ',i4,', ',a12,4(', ',i4.4) c & ,', ',2(i4,', '),4(i3,', '),2(i5,', '),4(i4,', '),a9) 87 format (a2,', ',a4,', ',i10.10,'_F',i3.3,'_',i3.3,a1,'_',i4.4,a1 & ,'_',a3,', ',i10.10,', 03, ',a4,', ',i3.3,', ',i3,a1 & ,', ',i4,a1,', ',i3,', ',i4,', ',a12,4(', ',i4.4) & ,', ',2(i4,', '),i3,', ',2(i4,', '),3(i6,', '),4(i6,', ') & ,a9) c write (68,87) gstm%gv_gen_date,gstm%gv_gen_lat c & ,gstm%gv_gen_latns,gstm%gv_gen_lon c & ,gstm%gv_gen_lonew,gstm%gv_gen_type c & ,inp%bcc,inp%byy,inp%bmm,inp%bdd,inp%bhh c & ,adjustr(atcfname),ifcsthour,intlat,clatns,intlon,clonew c & ,int((vmaxwind*conv_ms_knots) + 0.5) c & ,int(xminmslp/100.0 + 0.5) c & ,'XX, 34, NEQ' c & ,istmspd,istmdir,imeanzeta(1),igridzeta(1) c & ,imeanzeta(2),igridzeta(2) c c 87 format (i10.10,'_',i3.3,a1,'_',i4.4,a1,'_',a3,', ',5i2.2 c & ,', 03, ',a4,', ',i3.3,', ',i3,a1 c & ,', ',i4,a1,', ',i3,', ',i4,', ',a12,6(', ',i4)) c bug fix for IBM: flush the output stream so it actually writes flush(68) return end c c--------------------------------------------------------------------- c c--------------------------------------------------------------------- subroutine output_tcvitals (xlon,xlat,inp,ist,iovret) c c ABSTRACT: This subroutine outputs a tcvitals record. The c lat/lon location is given by the xlon and xlat that are c input to this subroutine. c c INPUT: c xlon longitude of storm position to be output c xlat latitude of storm position to be output c inp contains input date and model number information c ist the number storm that we're processing (can be 1-15) c c OUTPUT: c iovret return code from this subroutine c c OTHER: c storm contains the tcvitals info (from module def_vitals) c USE def_vitals; USE inparms; USE set_max_parms USE verbose_output type (tcvcard) stm type (datecard) inp real xlon,xlat c iovret = 0 c Initially, set all "stm" components equal to the input "storm" c components for this storm, then we will change the specific c components that we need to. stm = storm(ist) stm%tcv_center = 'AEAR' stm%tcv_lat = int(abs(xlat) * 10. + 0.5) if (xlat < 0.0) then stm%tcv_latns = 'S' else stm%tcv_latns = 'N' endif if (xlon >= 180.) then stm%tcv_lon = 3600 - int(xlon * 10. + 0.5) stm%tcv_lonew = 'W' else stm%tcv_lon = int(xlon * 10. + 0.5) stm%tcv_lonew = 'E' endif if ( verb .ge. 3 ) then write (6,*) ' ' write (6,21) stm endif write (65,21) stm 21 format (a4,1x,a3,1x,a9,1x,i8.8,1x,i4.4,1x,i3,a1,1x,i4,a1,1x & ,i3,1x,i3,3(1x,i4),1x,i2,1x,i3,1x,4(i4,1x),a1) c c bug fix for IBM: flush the output stream so it actually writes flush(65) return end c--------------------------------------------------------------------- c c--------------------------------------------------------------------- subroutine output_gen_vitals (xlon,xlat,inp,ist,istmspd,istmdir & ,iovret) c c ABSTRACT: This subroutine outputs a modified vitals record. c The lat/lon location is given by the xlon and xlat that are c input to this subroutine. c c The reason that these are referred to as modified tcvitals is c that the format is different from standard TC vitals format. c The storm identifier is different than that for a standard c tcvitals. The storm identifier contains the date/time that c the storm was first identified, and the lat/lon position at c which it was first identified. c c EXAMPLE: The following is a standard TC Vitals record, split c up over 3 lines: c c NHC 01L ALBERTO 20060614 1200 343N 0807W 035 093 1004 1012 c 0278 15 222 -999 -999 -999 -999 M -999 -999 -999 -999 72 c 520N 410W -999 -999 -999 -999 c c EXAMPLE: The following is the format for the "genesis" vitals, c split over 3 lines, for the same system: c c 2006061000_F000_210N_0853W_01L 20060614 1200 343N 0807W 035 093 c 1004 1012 0278 15 222 -999 -999 -999 -999 M -999 -999 c -999 -999 72 520N 410W -999 -999 -999 -999 c c EXAMPLE: If the vitals record is for a non-officially numbered c system (i.e., any system that's not a TC being tracked c by NHC or JTWC), then the storm number is replaced c by the characters "FOF", for "Found On the Fly" by c the tracker. c c 2006071500_F000_150N_0681W_FOF 20060718 1200 185N 0792W 035 093 c 1004 1012 0278 15 222 -999 -999 -999 -999 M -999 -999 c -999 -999 72 520N 410W -999 -999 -999 -999 c c c INPUT: c xlon longitude of storm position to be output c xlat latitude of storm position to be output c inp contains input date and model number information c ist the number storm that we're processing (can be 1-15) c c OUTPUT: c iovret return code from this subroutine c c OTHER: c storm contains the tcvitals info (from module def_vitals) c USE def_vitals; USE gen_vitals; USE inparms; USE set_max_parms USE verbose_output implicit none type (gencard) gstm type (datecard) inp real xlon,xlat integer ist,iovret,istmspd,istmdir c iovret = 0 c Initially, set all "stm" components equal to the input "gstorm" c components for this storm, then we will change the specific c components that we need to. gstm = gstorm(ist) c If the "gv_gen_date" for this storm does not equal 99999, c then that means that a vitals was read in for this storm in c subroutine read_gen_vitals, so be sure to use the genesis c date, genesis latitude and genesis longitude for the storm c identifier at the beginning of the vitals record. if (gstm%gv_gen_date /= 99999) then if (gstm%gv_gen_type /= 'FOF') then ! If this is not a 'FOF' storm (found on the fly storm), then ! it must be a TC vitals storm, or a tropical cyclone, and we ! don't want to create a vitals record for a tropical cyclone, ! since we will rely on reading them from the TC Vitals ! database instead. return endif else ! This storm is new in this forecast/analysis and was found on ! the fly in the first time level for this run and there was no ! previous vitals record for this system gstm%gv_gen_date = inp%bcc * 100000000 & + inp%byy * 1000000 & + inp%bmm * 10000 & + inp%bdd * 100 & + inp%bhh gstm%gv_gen_fhr = 0 gstm%gv_gen_lat = int(abs(xlat) * 10. + 0.5) if (xlat < 0.0) then gstm%gv_gen_latns = 'S' else gstm%gv_gen_latns = 'N' endif if (xlon >= 180.) then gstm%gv_gen_lon = 3600 - int(xlon * 10. + 0.5) gstm%gv_gen_lonew = 'W' else gstm%gv_gen_lon = int(xlon * 10. + 0.5) gstm%gv_gen_lonew = 'E' endif gstm%gv_gen_type = 'FOF' ! Transfer all this local "gstm" data back into the ! saved "gstorm" array for use in subsequent fcst hrs... gstorm(ist) = gstm endif gstm%gv_obs_ymd = inp%bcc * 1000000 & + inp%byy * 10000 & + inp%bmm * 100 & + inp%bdd gstm%gv_obs_hhmm = inp%bhh * 100 gstm%gv_obs_lat = int(abs(xlat) * 10. + 0.5) if (xlat < 0.0) then gstm%gv_obs_latns = 'S' else gstm%gv_obs_latns = 'N' endif if (xlon >= 180.) then gstm%gv_obs_lon = 3600 - int(xlon * 10. + 0.5) gstm%gv_obs_lonew = 'W' else gstm%gv_obs_lon = int(xlon * 10. + 0.5) gstm%gv_obs_lonew = 'E' endif gstm%gv_stdir = istmdir gstm%gv_stspd = istmspd gstm%gv_depth = 'U' if ( verb .ge. 3 ) then write (6,*) ' ' write (6,21) gstm endif write (67,21) gstm 21 format (i10,'_F',i3.3,'_',i3.3,a1,'_',i4.4,a1,'_',a3,1x,i8,1x & ,i4.4,1x,i3.3,a1,1x,i4.4,a1,1x,i3,1x,i3,3(1x,i4),1x,i2,1x & ,i3,4(1x,i4),1x,a1) c c bug fix for IBM: flush the output stream so it actually writes flush(67) return end c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine output_tracker_mask (masked_outc,lb,ifh,ifcsthour & ,imax,jmax,iotmret) c c ABSTRACT: This subroutine outputs a GRIB record that contains the c "mask" used to mask out areas surrounding low pressure centers c that have been found during the search at each forecast hour. This c mask is written out purely for diagnostic purposes. The GRIB c identifier given to the mask in the pds is 850 mb height (you can c make it anything you want). This is only done for the "midlat" c and "tcgen" cases, since the runs for those cases use a mask while c the regular "tracker" run (that is, the run which strictly tracks c only those storms in the TC vitals file) does not. c c INPUT: c masked_outc logical array containing mask c ifh integer counter for current forecast hour c ifcsthour integer current forecast hour c imax num points is i-direction of input grid c jmax num points is j-direction of input grid c c OUTPUT: c iotmret return code from this subroutine implicit none c integer ifh,imax,jmax,iotmret,kf,igoret,iix,jjx,ipret integer ifcsthour integer kpds(200),kgds(200) logical(1) masked_outc(imax,jmax),lb(imax,jmax) real xmask(imax,jmax) c if (ifh == 1) then call baopenw (77,"fort.77",igoret) print *,'baopenw: igoret= ',igoret if (igoret /= 0) then print *,' ' print *,'!!! ERROR in sub output_tracker_mask opening' print *,'!!! **OUTPUT** grib files. baopenw return codes:' print *,'!!! grib file 1 return code = igoret = ',igoret STOP 95 return endif endif xmask = 0.0 do jjx = 1,jmax do iix = 1,imax if (masked_outc(iix,jjx)) then xmask(iix,jjx) = 1.0 else xmask(iix,jjx) = 0.0 endif enddo enddo kf = imax * jmax c kpds(5) = 7 c kpds(6) = 100 c kpds(7) = 850 c kpds(22) = 0 kpds(1) = 7 ; kpds(2) = 80 kpds(3) = 255 ; kpds(4) = 192 kpds(5) = 7 ; kpds(6) = 100 kpds(7) = 850 ; kpds(8) = 99 kpds(9) = 7 ; kpds(10) = 20 kpds(11) = 12 ; kpds(12) = 0 kpds(13) = 1 ; kpds(14) = ifcsthour kpds(15) = 0 ; kpds(16) = 10 kpds(17) = 0 ; kpds(18) = 1 kpds(19) = 2 ; kpds(20) = 0 kpds(21) = 20 ; kpds(22) = 0 kpds(23) = 0 ; kpds(24) = 0 kpds(25) = 0 kgds(1) = 0 ; kgds(2) = imax kgds(3) = jmax ; kgds(4) = -90000 kgds(5) = 0 ; kgds(6) = 128 kgds(7) = 90000 ; kgds(8) = 359750 kgds(9) = 250 ; kgds(10) = 250 kgds(11) = 64 ; kgds(12) = 0 kgds(13) = 0 ; kgds(14) = 0 kgds(15) = 0 ; kgds(16) = 0 kgds(17) = 0 ; kgds(18) = 0 kgds(19) = 0 ; kgds(20) = 255 write(*,980) kpds(1),kpds(2) write(*,981) kpds(3),kpds(4) write(*,982) kpds(5),kpds(6) write(*,983) kpds(7),kpds(8) write(*,984) kpds(9),kpds(10) write(*,985) kpds(11),kpds(12) write(*,986) kpds(13),kpds(14) write(*,987) kpds(15),kpds(16) write(*,988) kpds(17),kpds(18) write(*,989) kpds(19),kpds(20) write(*,990) kpds(21),kpds(22) write(*,991) kpds(23),kpds(24) write(*,992) kpds(25) write(*,880) kgds(1),kgds(2) write(*,881) kgds(3),kgds(4) write(*,882) kgds(5),kgds(6) write(*,883) kgds(7),kgds(8) write(*,884) kgds(9),kgds(10) write(*,885) kgds(11),kgds(12) write(*,886) kgds(13),kgds(14) write(*,887) kgds(15),kgds(16) write(*,888) kgds(17),kgds(18) write(*,889) kgds(19),kgds(20) write(*,890) kgds(21),kgds(22) c 980 format('tmow kpds(1) = ',i7,' kpds(2) = ',i7) 981 format('tmow kpds(3) = ',i7,' kpds(4) = ',i7) 982 format('tmow kpds(5) = ',i7,' kpds(6) = ',i7) 983 format('tmow kpds(7) = ',i7,' kpds(8) = ',i7) 984 format('tmow kpds(9) = ',i7,' kpds(10) = ',i7) 985 format('tmow kpds(11) = ',i7,' kpds(12) = ',i7) 986 format('tmow kpds(13) = ',i7,' kpds(14) = ',i7) 987 format('tmow kpds(15) = ',i7,' kpds(16) = ',i7) 988 format('tmow kpds(17) = ',i7,' kpds(18) = ',i7) 989 format('tmow kpds(19) = ',i7,' kpds(20) = ',i7) 990 format('tmow kpds(21) = ',i7,' kpds(22) = ',i7) 991 format('tmow kpds(23) = ',i7,' kpds(24) = ',i7) 992 format('tmow kpds(25) = ',i7) 880 format('tmow kgds(1) = ',i7,' kgds(2) = ',i7) 881 format('tmow kgds(3) = ',i7,' kgds(4) = ',i7) 882 format('tmow kgds(5) = ',i7,' kgds(6) = ',i7) 883 format('tmow kgds(7) = ',i7,' kgds(8) = ',i7) 884 format('tmow kgds(9) = ',i7,' kgds(10) = ',i7) 885 format('tmow kgds(11) = ',i7,' kgds(12) = ',i7) 886 format('tmow kgds(13) = ',i7,' kgds(14) = ',i7) 887 format('tmow kgds(15) = ',i7,' kgds(16) = ',i7) 888 format('tmow kgds(17) = ',i7,' kgds(18) = ',i7) 889 format('tmow kgds(19) = ',i7,' kgds(20) = ',i7) 890 format('tmow kgds(20) = ',i7,' kgds(22) = ',i7) c print *,'just before call to putgb, kf= ',kf call putgb (77,kf,kpds,kgds,lb,xmask,ipret) print *,'just after call to putgb, kf= ',kf if (ipret == 0) then print *,' ' print *,'+++ IPRET = 0 after call to putgb' print *,' ' else print *,' ' print *,'!!!!!! ERROR: IPRET NE 0 AFTER CALL TO PUTGB !!!' print *,' ' endif c c bug fix for IBM: flush the output stream so it actually writes flush(6) return end c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine get_next_ges (fixlon,fixlat,ist,ifh,imax,jmax & ,dx,dy,modelid,valid_pt,readflag,maxstorm,istmspd & ,istmdir,ctype,trkrinfo,ignret) c c ABSTRACT: This subroutine calculates a guess position for the next c forecast time. It does this by using two different c methods and averaging the results from those two. The c first method is a simple linear extrapolation made by c basically drawing a line from the previous position c through the current fix position and assuming straight c line motion. The second method is to do a barnes c smoothing of u & v in the vicinity of the storm at 850, c 700 & 500 mb to get an average environmental wind c vector at each level, and then move the storm according c to the vector at each level. Then a weighted average is c taken of all these positions from methods 1 & 2 to get c the consensus for the guess position. NOTE: For a c regional model and a storm that is relatively close to c the model boundary, there is a strong possibility that c the barnes analysis subroutine will fail due to trying c to access grid points beyond the model's lateral c boundary. In this case, the redlm & ridlm are halved c and barnes is called again. If it still fails, then c just use the result from method 1 as a default. c c INPUT: c fixlon Array with longitudes of fix positions c fixlat Array with latitudes of fix positions c ist Storm number currently being processed c ifh Forecast hour currently being processed c imax Max number of pts in x-direction for this grid c jmax Max number of pts in y-direction for this grid c dx grid-spacing of the model in the i-direction c dy grid-spacing of the model in the j-direction c modelid Integer indicating what model's data is being processed c valid_pt Logical; bitmap indicating if valid data at that pt. c readflag Logical; Tells whether or not a variable was read in c for this model c maxstorm Max # of storms that can be handled in this run c ctype character that lets subroutine know if this is a search c for the next position for the purposes of tc vitals or c for general tracking. In the case of vitals, eventually c in the barnes subroutine we are more lax and allow the c routine to keep searching even if we are close to the c grid boundary. In a general tracking search, if we hit c the grid boundary even just once, we exit. c trkrinfo derived type detailing user-specified grid info c c OUTPUT: c istmspd The speed that the storm would have to move to get from c the current position to the next guess position c istmdir The direction in which the storm would have to move to c get from the current position to the next guess position c c LOCAL: c dt Number of seconds between successive forecast times c for this particular model. c dtkm Distance in meters of 1 degree latitude c icutmax Max number of times to cut the ridlm and redlm in half, c for use in calling barnes. If you're using a regional c model and on the first call to barnes you try to access c a point that's outside the model grid boundary, we'll c call barnes again, but not before cutting the redlm and c ridlm in half. icutmax says how many times to allow c this cutting in half before giving up and just going c with the extrapolation method. At first writing, we'll c set icutmax to 2, so that it will allow the ridlm to c get down to 500 km (originally 2000 km) and the redlm c to 125 km (originally 500 km). c *** NOTE: After testing the system, it was found that if c we cut these radii, the u and v values that are c calculated from barnes are too strongly influenced by c the near-storm environment and, especially for asymmetric c systems, resulted in u and v values being much too strong. c As such, we will not allow these values to be cut, and if c we hit the boundaries in barnes, we'll just use the c extrapolation method, which has seemed to work just fine. c c OTHER: (slonfg, slatfg & storm defined in module def_vitals) c slonfg Array containing first guess longitude positions c slatfg Array containing first guess latitude positions c storm Contains tcvitals information c USE radii; USE def_vitals; USE set_max_parms; USE grid_bounds USE tracked_parms; USE level_parms; USE trig_vals; USE trkrparms USE gen_vitals USE verbose_output implicit none type (trackstuff) trkrinfo integer icutmax,istmspd,istmdir,bskip,ileadtime,ifcsthour integer ifh,ist,npts,ilonfix,jlatfix,ibeg,jbeg,iend,jend integer igiret,ignret,icut,iuret,ivret,ibarnct,n,ix1,ix2 integer icount,imax,jmax,modelid,maxstorm real fixlon(maxstorm,maxtime),fixlat(maxstorm,maxtime) real dist,distm,xincr,yincr,stmspd,stmdir,atan,arct,degrees real barneswt,extrapwt,dtkm,dt,ucomp,vcomp,xdist,ydist,ydeg real extraplat,avglat,cosfac,xdeg,extraplon,ylatdegmove_last real xlondegmove_last,xnumh_last,ylatdegmove_last_perhour real xlondegmove_last_perhour,xnumh_next,yoldavglat real yoldcosfac,xdistmove_last,xdistmove_last_perhour real ynewavglat,ynewcosfac,xdegnew,dx,dy,re,ri,ubar,vbar real wgttot,uavg,vavg,reold,riold,barnlat,barnlon,wt_total real tmp_fix_lon_curr,tmp_fix_lon_prev character*1 :: in_grid, extrap_flag, barnes_flag character(*) ctype logical(1) valid_pt(imax,jmax),readflag(14) c in_grid = 'n' extrap_flag = 'y' ileadtime = nint(fhreal(ifh) * 100.0) ifcsthour = ileadtime / 100 c c For updating the first guess, if Method 1 and Method 2 are both c able to be done, give the following weights to the 2 methods. c data barneswt /0.50/, extrapwt /0.50/ c c ------------------------------- c METHOD 1: LINEAR EXTRAPOLATION c ------------------------------- c First, just do a simple linear extrapolation from the previous c fix position through the current fix position. If it's the c first time (vt=0), then use the storm motion vector and storm c speed information from the TC Vitals card. c dtkm = dtk * 1000. dt = (fhreal(ifh+1) - fhreal(ifh)) * 3600.0 c if (ifh == 1) then if (storm(ist)%tcv_stdir == -99 .or. & storm(ist)%tcv_stspd == -99) then if ( verb .ge. 3 ) then print *,' ' print *,'!!! IN GET_NEXT_GES, at fcst hour = 0, either ' print *,'!!! storm motion or storm speed = -99 on TCV card.' print *,'!!! ist= ',ist,' ifh= ',ifh print *,'!!! Storm name = ',storm(ist)%tcv_storm_name print *,'!!! Storm ID = ',storm(ist)%tcv_storm_id print *,'!!! storm motion vector= ',storm(ist)%tcv_stdir print *,'!!! storm motion speed= ',storm(ist)%tcv_stspd print *,'!!! CANNOT USE LINEAR EXTRAP TO GET NEXT GUESS !!!' endif extrap_flag = 'n' else ucomp = sin(float(storm(ist)%tcv_stdir) * dtr) * & float(storm(ist)%tcv_stspd)/10.0 vcomp = cos(float(storm(ist)%tcv_stdir) * dtr) * & float(storm(ist)%tcv_stspd)/10.0 xdist = ucomp * dt ydist = vcomp * dt ydeg = ydist / dtkm extraplat = fixlat(ist,ifh) + ydeg avglat = 0.5 * (extraplat + fixlat(ist,ifh)) if (avglat > 89.5) avglat = 89.0 if (avglat < -89.5) avglat = -89.0 cosfac = cos(avglat * dtr) xdeg = xdist / (dtkm*cosfac) extraplon = fixlon(ist,ifh) + xdeg endif else c Do a simple linear extrapolation of the current motion of the c storm. Follow a line from the fix position from the last fix c through the current fix and extrapolate out. To figure out the c new latitude, just see how many deg lat the storm moved since c last time and add it to the current fix latitude. To calculate c the new fix longitude, though, we need to see how many deg lon c the storm moved since the last time, convert that to the c distance (km) the storm travelled in the x-direction (at an c average latitude between the current and previous latitudes), c and then add that distance on to the current longitude and c convert that distance to the num of degrees the storm has c travelled in the x-direction (at an average latitude between c the current and next(extrap) latitudes). c c UPDATE Feb 2009: To account for the possibility of using c irregularly spaced forecast hours (e.g., 6,10,10.5,...etc), c I had to modify this linear extrapolation. print *,' ' print *,'xxxx get_next_ges, prev fix lon= ',fixlon(ist,ifh-1) print *,'xxxx get_next_ges, curr fix lon= ',fixlon(ist,ifh) print *,' ' if (fixlat(ist,ifh-1) > -900.0 .and. & fixlon(ist,ifh-1) > -900.0) then ylatdegmove_last = fixlat(ist,ifh) - fixlat(ist,ifh-1) tmp_fix_lon_curr = fixlon(ist,ifh) tmp_fix_lon_prev = fixlon(ist,ifh-1) if (tmp_fix_lon_prev < 0.0 .and. tmp_fix_lon_prev > -25.0) & then ! previous lon position is within 25 deg west of the GM ! and is listed in negative degrees. if (tmp_fix_lon_curr < 0.0 .and. tmp_fix_lon_curr > -25.0) & then if (verb .ge. 3) then print *,' ' print *,'+++ GM WRAP ALERT 1 in get_next_ges.' print *,'+++ In get_next_ges, lon for previous and ' print *,' current time are both negative. All ok!' print *,' tmp_fix_lon_prev= ',tmp_fix_lon_prev print *,' tmp_fix_lon_curr= ',tmp_fix_lon_curr endif elseif (tmp_fix_lon_curr > 0.0 .and. & tmp_fix_lon_curr < 25.0) then if (verb .ge. 3) then print *,' ' print *,'+++ GM WRAP ALERT 2 in get_next_ges.' print *,'+++ In get_next_ges, lon for previous time' print *,' is negative, while lon for current time' print *,' is positive, but within 0-25 deg East.' print *,' All ok!' endif endif elseif (tmp_fix_lon_prev > 335.0 .and. & tmp_fix_lon_prev <= 360.0) then ! previous lon position is within 25 deg west of the GM ! and is listed in positive degrees. if (tmp_fix_lon_curr > 335.0 .and. & tmp_fix_lon_curr <= 360.0) then if (verb .ge. 3) then print *,' ' print *,'+++ GM WRAP ALERT 3 in get_next_ges.' print *,'+++ In get_next_ges, lon for previous and ' print *,' current time are both positive. All ok!' print *,' tmp_fix_lon_prev= ',tmp_fix_lon_prev print *,' tmp_fix_lon_curr= ',tmp_fix_lon_curr endif elseif (tmp_fix_lon_curr > 0.0 .and. & tmp_fix_lon_curr <= 25.0) then tmp_fix_lon_curr = tmp_fix_lon_curr + 360.0 if (verb .ge. 3) then print *,' ' print *,'+++ GM WRAP ALERT 4 in get_next_ges.' print *,'+++ In get_next_ges, lon for previous ' print *,' time is between 335 & 360, while lon' print *,' for current time is east of the GM and' print *,' is between 0 & 25. Current tmp_lon' print *,' has been adjusted to be > 360 for the' print *,' purpose of computation.' print *,' tmp_fix_lon_prev= ',tmp_fix_lon_prev print *,' tmp_fix_lon_curr= ',tmp_fix_lon_curr endif elseif (tmp_fix_lon_curr < 0.0 .and. & tmp_fix_lon_curr >= -25.0) then tmp_fix_lon_curr = tmp_fix_lon_curr + 360.0 if (verb .ge. 3) then print *,' ' print *,'+++ GM WRAP ALERT 5 in get_next_ges.' print *,'+++ In get_next_ges, lon for previous ' print *,' time is between 335 & 360, while lon' print *,' for current time is west of the GM and' print *,' is between 0 & -25. Current tmp_lon' print *,' has been adjusted to be positive and ' print *,' > 360 for the purpose of computation.' print *,' tmp_fix_lon_prev= ',tmp_fix_lon_prev print *,' tmp_fix_lon_curr= ',tmp_fix_lon_curr endif elseif (tmp_fix_lon_curr < -335.0 .and. & tmp_fix_lon_curr >= -360.0) then tmp_fix_lon_curr = 720.0 - tmp_fix_lon_curr if (verb .ge. 3) then print *,' ' print *,'+++ GM WRAP ALERT 6 in get_next_ges.' print *,'+++ In get_next_ges, lon for previous ' print *,' time is between 335 & 360, while lon' print *,' for current time is east of the GM and' print *,' is between -335 & -360. Current tmp_lon' print *,' has been adjusted to be positive and ' print *,' > 360 for the purpose of computation.' print *,' tmp_fix_lon_prev= ',tmp_fix_lon_prev print *,' tmp_fix_lon_curr= ',tmp_fix_lon_curr endif endif endif xlondegmove_last = tmp_fix_lon_curr - tmp_fix_lon_prev xnumh_last = fhreal(ifh) - fhreal(ifh-1) ylatdegmove_last_perhour = ylatdegmove_last / xnumh_last xlondegmove_last_perhour = xlondegmove_last / xnumh_last xnumh_next = fhreal(ifh+1) - fhreal(ifh) extraplat = fixlat(ist,ifh) & + (ylatdegmove_last_perhour * xnumh_next) yoldavglat = 0.5 * (fixlat(ist,ifh) + fixlat(ist,ifh-1)) yoldcosfac = cos (dtr * yoldavglat) xdistmove_last = xlondegmove_last * dtk * yoldcosfac xdistmove_last_perhour = xdistmove_last / xnumh_last ynewavglat = 0.5 * (extraplat + fixlat(ist,ifh)) ynewcosfac = cos(dtr * ynewavglat) xdegnew = (xdistmove_last_perhour * xnumh_next) & / (dtk * ynewcosfac) extraplon = tmp_fix_lon_curr + xdegnew else if ( verb .ge. 3 ) then print *,' ' write(6,92) '!!! IN GET_NEXT_GES, at fcst hour = ' & ,ifhours(ifh),ifclockmins(ifh) print *,'!!! the lon and lat positions for the previous' print *,'!!! forecast hour are -999, meaning that this is a' print *,'!!! new storm, so we cannot use the extrap method.' print *,'!!! Storm name = ',storm(ist)%tcv_storm_name print *,'!!! Storm ID = ',storm(ist)%tcv_storm_id print *,'!!! CANNOT USE LINEAR EXTRAP TO GET NEXT GUESS !!!' endif 92 format (1x,a36,i4,':',i2.2) extrap_flag = 'n' endif endif c ------------------------------- c METHOD 2: Barnes analysis c ------------------------------- c Do a barnes analysis on the u & v components of the wind near the c storm to get an average u & v, then advect the storm according to c the average wind vector obtained. The call to get_ij_bounds is c needed in order to restrict the number of grid points that are c searched in the barnes subroutine. See Abstract from this c subroutine for further details. npts = ceiling(ridlm/(dtk*((dx+dy)/2))) call get_ij_bounds (npts,0,ridlm,imax,jmax,dx,dy & ,glatmax,glatmin,glonmax,glonmin,fixlon(ist,ifh),fixlat(ist,ifh) & ,trkrinfo,ilonfix,jlatfix,ibeg,jbeg,iend,jend,igiret) if (igiret /= 0) then if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in get_next_ges from call to ' print *,'!!! get_ij_bounds, STOPPING processing for ' print *,'!!! storm number ',ist endif ignret = 92 return endif if (verb >= 3) then print *,' ' print *,' +++ In get_next_ges after call to get_ij_bounds,' print *,' getting bounds for the barnes analysis...' print *,' glatmax= ',glatmax,' glatmin= ',glatmin print *,' glonmax= ',glonmax,' glonmin= ',glonmin print *,' fixlon= ',fixlon(ist,ifh),' fixlat= ' & ,fixlat(ist,ifh) print *,' ilonfix= ',ilonfix,' jlatfix= ',jlatfix print *,' ibeg= ',ibeg,' iend= ',iend print *,' jbeg= ',jbeg,' jend= ',jend endif c For the barnes analysis, we will want to speed things up for c finer resolution grids. We can do this by skipping some of c the points in the barnes analysis. if ((dx+dy)/2 > 0.20) then bskip = 1 else if ((dx+dy)/2 > 0.10 .and. (dx+dy)/2 <= 0.20) then bskip = 2 else if ((dx+dy)/2 > 0.05 .and. (dx+dy)/2 <= 0.10) then bskip = 3 else if ((dx+dy)/2 > 0.03 .and. (dx+dy)/2 <= 0.05) then bskip = 5 else if ((dx+dy)/2 <= 0.03) then bskip = 10 endif c Calculate average wind at each level (currently: 850, 700 & 500) re = redlm ri = ridlm icut = 0 if (trkrinfo%type == 'midlat') then icutmax = 2 else icutmax = 1 endif radmaxloop: do while (icut <= icutmax .and. in_grid == 'n') ubar = 0.0; vbar = 0.0 iuret = 0; ivret = 0 wgttot = 0.0 ibarnct = 0 barnes_flag = 'n' levelloop: do n=1,nlevg select case (n) case (1); ix1=3; ix2=4 ! For 850 mb readflags case (2); ix1=5; ix2=6 ! For 700 mb readflags case (3); ix1=12; ix2=13 ! For 500 mb readflags end select if (readflag(ix1) .and. readflag(ix2)) then call barnes (fixlon(ist,ifh),fixlat(ist,ifh),glon,glat & ,imax,jmax,ibeg,jbeg,iend,jend,u(1,1,n),valid_pt & ,bskip,re,ri,uavg,icount,ctype,trkrinfo,iuret) call barnes (fixlon(ist,ifh),fixlat(ist,ifh),glon,glat & ,imax,jmax,ibeg,jbeg,iend,jend,v(1,1,n),valid_pt & ,bskip,re,ri,vavg,icount,ctype,trkrinfo,ivret) if (iuret /= 0 .or. ivret /= 0) then c ...barnes probably tried to access a pt outside the grid c domain. So, reduce by half the distance from the center c of the farthest pt that barnes tries to access, exit this c loop, and try it again with the smaller re and ri. iuret = 96; ivret = 96 reold = re riold = ri re = 0.5 * re ri = 0.5 * ri if ( verb .ge. 3 ) then print *,' ' print *,'NOTE: While attempting to use the barnes ' print *,'method to update the first guess, the ' print *,'algorithm tried to access a grid point that ' print *,'does not have valid data, meaning that too ' print *,'large a radius is being searched. So, the 2 ' print *,'radii, re and ri, are being halved and, if the' print *,'value of icutmax > 0, the algorithm will be ' print *,'run again. Otherwise, if icutmax = 0, only ' print *,'the extrapolation method will be used.' print *,'iuret= ',iuret,' ivret= ',ivret,' icut= ',icut print *,'Old re = ',reold,' New re = ',re print *,'Old ri = ',riold,' New ri = ',ri endif exit levelloop else ubar = ubar + wgts(n) * uavg vbar = vbar + wgts(n) * vavg wgttot = wgttot + wgts(n) ibarnct = ibarnct + 1 if (verb >= 3) then print *,' ' print *,' --- In get_next_ges, ix1= ',ix1,' ix2= ',ix2 print *,' uavg= ',uavg,' vavg= ',vavg print *,' ubar= ',ubar,' vbar= ',vbar print *,' n= ',n,' wgts(n)= ',wgts(n),' wgttot= ' & ,wgttot print *,' ibarnct= ',ibarnct print *,' ' print *,' ' endif endif endif enddo levelloop if (ibarnct > 0 .and. wgttot > 0.0) then barnes_flag = 'y' in_grid = 'y' ubar = ubar / wgttot vbar = vbar / wgttot barnlat = fixlat(ist,ifh) + (vbar * dt)/dtkm cosfac = cos (dtr * 0.5 * (fixlat(ist,ifh) + barnlat)) barnlon = fixlon(ist,ifh) + (ubar * dt)/(dtkm * cosfac) if (verb >= 3) then print *,' ' print *,' --- In get_next_ges, mean stats follow: ' print *,' ubar= ',ubar,' vbar= ',vbar print *,' wgttot= ',wgttot print *,' fixlon= ',fixlon(ist,ifh),' fixlat= ' & ,fixlat(ist,ifh) print *,' barnlon= ',barnlon,' barnlat= ',barnlat print *,' dt= ',dt,' dtkm= ',dtkm,' cosfac= ',cosfac endif c This next if statement says that if we've had to reduce the c size of the barnes analysis domain twice already, then we've c only done the analysis on a much smaller area, and this c doesn't give us as good a picture of the average winds in the c area of the storm, so reduce the emphasis we place on the c barnes method. if (icut >= 2) barneswt = barneswt / 2. else barnes_flag = 'n' endif icut = icut + 1 enddo radmaxloop c --------------------- c Average the results c --------------------- c Now do a weighted average of the positions obtained from the c linear extrapolation and the barnes analysis methods. if (extrap_flag == 'y' .and. barnes_flag == 'y') then wt_total = barneswt + extrapwt slatfg(ist,ifh+1) = (barneswt * barnlat + extrapwt * extraplat) & / wt_total ! Note that in any of these statements just below, in order for ! any of these to be > 360, the original fixlon must be close ! to 360, i.e., in the far eastern part of the grid, as opposed ! to being in the far western part (e.g., 0-2 deg East or so). ! Conversely, for any of these to be < 0, the original fixlon ! must be close to 0, i.e., in the far *western* part of the ! grid. c yyyy if (fixlon(ist,ifh) > 330.0) then ! In this part of the IF, we will make sure that the two ! guess lons (barnlon and extraplon) are consistent as ! both being 330+, to be consistent with the fixlon for ! this time. if (extraplon > 330. .and. barnlon > 330.) then continue ! All lons will be in the 300+ range, so for ! consistency, we're ok. elseif (extraplon > 330. .and. & (barnlon >= 0.0 .and. barnlon < 30.)) then ! extraplon > 330, but barnlon is in the 0-30 range, so ! we need to convert the barnlon value to be 360+ barnlon = barnlon + 360. elseif (extraplon > 330. .and. barnlon < 0.) then ! extraplon > 330, but barnlon is < 0, so ! we need to convert the barnlon value to be positive... barnlon = barnlon + 360. elseif (barnlon > 330. .and. & (extraplon >= 0.0 .and. extraplon < 30.)) then ! barnlon > 330, but extraplon is in the 0-30 range, so ! we need to convert the extraplon value to be 360+ extraplon = extraplon + 360. elseif (barnlon > 330. .and. extraplon < 0.) then ! barnlon > 330, but extraplon is < 0, so ! we need to convert the extraplon value to be positive... extraplon = extraplon + 360. endif elseif (fixlon(ist,ifh) >= 0. and. fixlon(ist,ifh) < 30.0) then ! In this part of the ELSEIF, we will make sure that the two ! guess lons (barnlon and extraplon) are consistent as ! both being in the reference of >360 since that is what the ! code below this is expecting with the computation of ! slonfg for the next lead time. if ((extraplon >= 0. .and. extraplon < 60.) .and. & (barnlon >= 0. .and. barnlon < 60.)) then extraplon = extraplon + 360. barnlon = barnlon + 360. elseif ((extraplon < 0. .and. extraplon > -60.) .and. & (barnlon < 0. .and. barnlon > -60.)) then ! convert extraplon and barnlon to be positive extraplon = extraplon + 360. barnlon = barnlon + 360. elseif ((extraplon >= 0. .and. extraplon < 60.) .and. & barnlon < 0.) then extraplon = extraplon + 360. barnlon = barnlon + 360. elseif ((barnlon >= 0. .and. barnlon < 60.) .and. & extraplon < 0.) then extraplon = extraplon + 360. elseif ((barnlon >= 0. .and. barnlon < 60.) .and. & extraplon > 330.) then barnlon = barnlon + 360. elseif (barnlon >= 330. .and. extraplon < 60.) then extraplon = extraplon + 360. elseif (extraplon >= 330. .and. barnlon < 60.) then barnlon = barnlon + 360. elseif ((extraplon >= 0. .and. extraplon < 60.) .and. & barnlon > 330.) then extraplon = extraplon + 360. endif else continue ! extraplon and barnlon do not need to be modified ! since there should be no way that a storm ! currently east of 30E and west of 30W could make ! it to the Greenwich Mer in one forecast interval endif print *,' ' print *,'+++ In get_next_ges, before averaging the 2 methods, ' print *,' Raw (no conversion for GM wrap) barnlon= ' & ,barnlon print *,' Raw (no conversion for GM wrap) extraplon= ' & ,extraplon slonfg(ist,ifh+1) = (barneswt * barnlon + extrapwt * extraplon) & / wt_total if (slonfg(ist,ifh+1) > 360.) then ! If we've GM-wrapped past 360, adjust it to be 0-360... slonfg(ist,ifh+1) = slonfg(ist,ifh+1) - 360. endif if ( verb .ge. 3 ) then write (6,*) ' ' if (barnlon >= 360.) then write (6,41) barnlon-360.,720.-barnlon,barnlat elseif (barnlon >= 0. .and. barnlon < 360.) then write (6,41) barnlon,360.-barnlon,barnlat elseif (barnlon < 0.) then write (6,41) barnlon+360.,-1.*barnlon,barnlat endif if (extraplon >= 360.) then write (6,43) extraplon-360.,720.-extraplon,barnlat elseif (extraplon >= 0. .and. extraplon < 360.) then write (6,43) extraplon,360.-extraplon,barnlat elseif (extraplon < 0.) then write (6,43) extraplon+360.,-1.*extraplon,barnlat endif endif ignret = 0 else if (extrap_flag == 'y' .and. barnes_flag == 'n') then if ( verb .ge. 3 ) then print *,' ' print *,'!!! NOTE: In get_next_ges, barnes method was not ' print *,'!!! done for updating the first guess for this ' print *,'!!! storm. Only the linear extrapolation method ' print *,'!!! was used.' print *,'!!! ist= ',ist,' ifh= ',ifh print *,'!!! Storm Name = ',storm(ist)%tcv_storm_name print *,'!!! Storm ID = ',storm(ist)%tcv_storm_id endif slatfg(ist,ifh+1) = extraplat if (extraplon > 360.) then if (trkrinfo%gridtype == 'global') then slonfg(ist,ifh+1) = extraplon - 360. else if ( verb .ge. 1 ) then print *,'!!! ERROR in get_next_ges, extraplon >360' print *,'!!! for non-global grid. We only' print *,'!!! do GM wrapping for global grids.' endif ignret = 95 return endif elseif (extraplon < 0.) then if (trkrinfo%gridtype == 'global') then slonfg(ist,ifh+1) = extraplon + 360. else if ( verb .ge. 1 ) then print *,'!!! ERROR in get_next_ges, extraplon < 0' print *,'!!! for non-global grid. We only' print *,'!!! do GM wrapping for global grids.' endif ignret = 95 return endif else slonfg(ist,ifh+1) = extraplon endif if ( verb .ge. 3 ) then write (6,*) ' ' write (6,41) 0.0,0.0,0.0 if (extraplon >= 360.) then write (6,43) extraplon-360.,720.-extraplon,barnlat elseif (extraplon >= 0. .and. extraplon < 360.) then write (6,43) extraplon,360.-extraplon,barnlat elseif (extraplon < 0.) then write (6,43) extraplon+360.,-1.*extraplon,barnlat endif endif ignret = 0 else if (extrap_flag == 'n' .and. barnes_flag == 'y') then slatfg(ist,ifh+1) = barnlat if (barnlon > 360.) then if (trkrinfo%gridtype == 'global') then slonfg(ist,ifh+1) = barnlon - 360. else if ( verb .ge. 1 ) then print *,'!!! ERROR in get_next_ges, barnlon >360' print *,'!!! for non-global grid. We only' print *,'!!! do GM wrapping for global grids.' endif ignret = 95 return endif elseif (barnlon < 0.) then if (trkrinfo%gridtype == 'global') then slonfg(ist,ifh+1) = barnlon + 360. else if ( verb .ge. 1 ) then print *,'!!! ERROR in get_next_ges, barnlon < 0' print *,'!!! for non-global grid. We only' print *,'!!! do GM wrapping for global grids.' endif ignret = 95 return endif else slonfg(ist,ifh+1) = barnlon endif if ( verb .ge. 3 ) then write (6,*) ' ' write (6,41) 360.-barnlon,barnlat if (barnlon >= 360.) then write (6,41) barnlon-360.,720.-barnlon,barnlat elseif (barnlon >= 0. .and. barnlon < 360.) then write (6,41) barnlon,360.-barnlon,barnlat elseif (barnlon < 0.) then write (6,41) barnlon+360.,-1.*barnlon,barnlat endif write (6,43) 0.0,0.0,0.0 endif ignret = 0 else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in get_next_ges, new position guess not' print *,'!!! made. Could not get guess using either barnes' print *,'!!! method or extrapolation method.' print *,'!!! extrap_flag = ',extrap_flag print *,'!!! barnes_flag = ',barnes_flag print *,'!!! Storm number = ',ist,' ifh = ',ifh print *,'!!! Storm Name = ',storm(ist)%tcv_storm_name print *,'!!! Storm ID = ',storm(ist)%tcv_storm_id write (6,41) 0.0,0.0,0.0 write (6,43) 0.0,0.0,0.0 endif ignret = 95 endif if ( verb .ge. 3 ) then print *,' ' print *,'-------------------------------------------------- ' print *,'| Current fix & updated fix positions |' print *,'-------------------------------------------------- ' print *,'| In get_next_ges, current fcst hour = ',fhreal(ifh) print *,'| current storm number = ',ist print *,'| Return code from get_next_ges = ',ignret print *,'| Storm Name = ',storm(ist)%tcv_storm_name print *,'| Storm ID = ',storm(ist)%tcv_storm_id write (6,420) gstorm(ist)%gv_gen_date,gstorm(ist)%gv_gen_fhr & ,gstorm(ist)%gv_gen_lat & ,gstorm(ist)%gv_gen_latns,gstorm(ist)%gv_gen_lon & ,gstorm(ist)%gv_gen_lonew,gstorm(ist)%gv_gen_type write (6,21) fixlat(ist,ifh) write (6,23) 360.-fixlon(ist,ifh),fixlon(ist,ifh) write (6,25) slatfg(ist,ifh+1) write (6,27) 360.-slonfg(ist,ifh+1),slonfg(ist,ifh+1) print *,'-------------------------------------------------' print *,' ' endif 420 format (' | Gen ID (if available): ',i10.10,'_F',i3.3,'_' & ,i3.3,a1,'_',i4.4,a1,'_',a3) 21 format (' | Current fix lat is ',f7.2) 23 format (' | Current fix lon is ',f7.2,'W (',f7.2,'E)') 25 format (' | Updated guess lat for next fcst hour is ',f7.2) 27 format (' | Updated guess lon for next fcst hour is ',f7.2 & ,'W (',f7.2,'E)') c 41 format (' --- barnlon= ',f7.2,'W barnlat= ',f7.2) c 43 format (' --- extraplon= ',f7.2,'W extraplat= ',f7.2) 41 format (' --- barnlon= ',f7.2,'E (',f7.2 & ,'W) barnlat= ',f7.2) 43 format (' --- extraplon= ',f7.2,'E (',f7.2 & ,'W) extraplat= ',f7.2) c Now calculate the speed that the storm would have to move at in c order to make it to the next forecast position. We will use c this information in writing out the "gen_vitals" record, if this c is requested. call calcdist (fixlon(ist,ifh),fixlat(ist,ifh) & ,slonfg(ist,ifh+1),slatfg(ist,ifh+1),dist,degrees) ! convert distance from km to meters, then get speed in m/s. distm = dist * 1000. stmspd = distm / dt istmspd = int ((stmspd * 10) + 0.5) xincr = slonfg(ist,ifh+1) - fixlon(ist,ifh) yincr = slatfg(ist,ifh+1) - fixlat(ist,ifh) if ( verb .ge. 3 ) then print *,'iocheck, dist= ',dist,' distm= ',distm print *,'iocheck, stmspd= ',stmspd,' istmspd= ',istmspd print *,'iocheck, xincr= ',xincr,' yincr= ',yincr endif if (xincr < 0.0 .and. slonfg(ist,ifh+1) < 30.0 .and. & fixlon(ist,ifh) > 300.0) then ! This means we have a storm moving east across the GM, and ! so we are subtracting, for example, something like ! 0.5 - 359.5, so redo xincr, but add 360 to slonfg first... xincr = (slonfg(ist,ifh+1) + 360.0) - fixlon(ist,ifh) else if (xincr > 300.0) then ! This means we have a storm moving west across the GM, and ! so we are subtracting, for example, something like ! 359.5 - 0.5, so redo xincr, but add 360 to fixlon first... xincr = slonfg(ist,ifh+1) - (fixlon(ist,ifh) + 360.0) endif if (xincr == 0.0) then if (yincr == 0.0) then stmdir = 0.0 else if (yincr > 0) then stmdir = 360.0 else if (yincr < 0) then stmdir = 180.0 endif else if (xincr > 0.0) then if (yincr == 0.0) then stmdir = 90.0 else arct = atan(yincr/xincr) stmdir = 90. - arct / dtr endif else if (xincr < 0.0) then if (yincr == 0.0) then stmdir = 270.0 else arct = atan(yincr/xincr) stmdir = 270. - arct / dtr endif endif istmdir = int (stmdir + 0.5) if (istmdir > 360) then istmdir = 360 else if (istmdir < 0) then istmdir = 0 endif if ( verb .ge. 3 ) then print *,'iocheck, stmdir= ',stmdir,' istmdir= ',istmdir endif return end c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine advect_tcvitals_from_hour0 (fixlon,fixlat,maxstorm & ,inctcv,ifh,trkrinfo,iatret) c c ABSTRACT: This subroutine calculates a guess position for the next c forecast time. As of 11/2016, it is called only for the case in c which we've got NetCDF data and no hour0 data, and so we want to c simply take the TC Vitals data and advect the current position to c a position at the next lead time. We can't use the code in c subroutine get_next_ges because there are certain allocatable c arrays in that subroutine that need to have been allocated first, c and at this point prior to the first lead time in hour0, they c haven't been allocated. c c INPUT: c inctcv Index for storm number currently being processed c ifh Forecast hour currently being processed c trkrinfo derived type detailing user-specified grid info c c OUTPUT: c iatret Return code from this subroutine c USE def_vitals; USE trkrparms; USE tracked_parms USE verbose_output; USE trig_vals; USE set_max_parms USE gen_vitals type (trackstuff) trkrinfo integer iatret,inctcv real fixlon(maxstorm,maxtime),fixlat(maxstorm,maxtime) real dist,distm,xincr,yincr,stmspd,stmdir,atan,arct,degrees real ucomp,vcomp,xdist,ydist,ydeg,dt,extraplat real cosfac real dtkm c in_grid = 'n' extrap_flag = 'y' ileadtime = nint(fhreal(ifh) * 100.0) ifcsthour = ileadtime / 100 c c ------------------------------------------------------------------ c Using the storm motion vector and storm translation speed as read c from the TC Vitals card, do a simple linear extrapolation from the c current observed (TC Vitals) position and advect the storm to a c position at the next lead time. c ------------------------------------------------------------------ iatret = 0 dtkm = dtk * 1000. dt = (fhreal(ifh+1) - fhreal(ifh)) * 3600.0 c if (ifh == 1) then if (storm(inctcv)%tcv_stdir == -99 .or. & storm(inctcv)%tcv_stspd == -99) then if ( verb .ge. 3 ) then print *,' ' print *,'!!! In advect_tcvitals_from_hour0, at fcst hour= 0' print *,'!!! either storm motion or storm speed = -99 on ' print *,'!!! TCV card, ist= inctcv= ',inctcv,' ifh= ',ifh print *,'!!! Storm name = ',storm(inctcv)%tcv_storm_name print *,'!!! Storm ID = ',storm(inctcv)%tcv_storm_id print *,'!!! storm motion vector= ',storm(inctcv)%tcv_stdir print *,'!!! storm motion speed= ',storm(inctcv)%tcv_stspd print *,'... CANNOT USE LINEAR EXTRAP TO GET NEXT GUESS ...' print *,' ' print *,'... Instead, we will simply use the current ' print *,'... observed position from TC Vitals and hope that' print *,'... it is close enough at the next lead time for ' print *,'... the tracker to be able to still track it.' print *,' ' endif extraplat = slatfg(inctcv,ifh) extraplon = slonfg(inctcv,ifh) else ucomp = sin(float(storm(inctcv)%tcv_stdir) * dtr) * & float(storm(inctcv)%tcv_stspd)/10.0 vcomp = cos(float(storm(inctcv)%tcv_stdir) * dtr) * & float(storm(inctcv)%tcv_stspd)/10.0 xdist = ucomp * dt ydist = vcomp * dt ydeg = ydist / dtkm extraplat = fixlat(inctcv,ifh) + ydeg cosfac = cos(extraplat * dtr) xdeg = xdist / (dtkm*cosfac) extraplon = fixlon(inctcv,ifh) + xdeg endif else print *,' ' print *,'!!! ERROR: In advect_tcvitals_from_hour0, the value of' print *,' ifh is > 1, and this routine should only be called' print *,' if ifh=1 (i.e., for hour0). STOPPING....' print *,' ' stop 95 endif slatfg(inctcv,ifh+1) = extraplat if (extraplon > 360.) then if (trkrinfo%gridtype == 'global') then slonfg(inctcv,ifh+1) = extraplon - 360. else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in advect_tcvitals_from_hour0,' print *,'!!! extraplon >360 for non-global grid. We only' print *,'!!! do GM wrapping for global grids.' endif iatret = 95 return endif elseif (extraplon < 0.) then if (trkrinfo%gridtype == 'global') then slonfg(inctcv,ifh+1) = extraplon + 360. else if ( verb .ge. 1 ) then print *,'!!! ERROR in advect_tcvitals_from_hour0,' print *,'!!! extraplon < 0 for non-global grid. We only' print *,'!!! do GM wrapping for global grids.' endif iatret = 95 return endif else slonfg(inctcv,ifh+1) = extraplon endif if ( verb .ge. 3 ) then print *,' ' print *,'-------------------------------------------------- ' print *,'| In advect_tcvitals_from_hour0, info on the ' print *,'| positions for the current and next lead times ' print *,'| follow: ' print *,'-------------------------------------------------- ' print *,'| current fcst hour = ',fhreal(ifh) print *,'| current storm number = ',inctcv print *,'| Return code from advect_tcvitals_from_hour0= ',iatret print *,'| Storm Name = ',storm(inctcv)%tcv_storm_name print *,'| Storm ID = ',storm(inctcv)%tcv_storm_id write (6,420) gstorm(inctcv)%gv_gen_date & ,gstorm(inctcv)%gv_gen_fhr & ,gstorm(inctcv)%gv_gen_lat & ,gstorm(inctcv)%gv_gen_latns,gstorm(inctcv)%gv_gen_lon & ,gstorm(inctcv)%gv_gen_lonew,gstorm(inctcv)%gv_gen_type write (6,21) fixlat(inctcv,ifh) write (6,23) 360.-fixlon(inctcv,ifh),fixlon(inctcv,ifh) write (6,25) slatfg(inctcv,ifh+1) write (6,27) 360.-slonfg(inctcv,ifh+1),slonfg(inctcv,ifh+1) print *,'-------------------------------------------------' print *,' ' endif 420 format (' | Gen ID (if available): ',i10.10,'_F',i3.3,'_' & ,i3.3,a1,'_',i4.4,a1,'_',a3) 21 format (' | Current TC Vitals lat is ',f7.2) 23 format (' | Current TC Vitals lon is ',f7.2,'W (',f7.2,'E)') 25 format (' | Updated guess lat for next fcst hour is ',f7.2) 27 format (' | Updated guess lon for next fcst hour is ',f7.2 & ,'W (',f7.2,'E)') return end c c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine getradii (xcenlon,xcenlat,imax,jmax,dx,dy,valid_pt & ,cstormid,ifcsthr,vmaxwind,vradius,trkrinfo & ,need_to_expand_r34,radmax & ,first_time_thru_getradii,igrct,igrret) c c ABSTRACT: This subroutine looks through the wind data near an c input storm center (fixlon,fixlat) and gets the radii of various c surface winds in each of the 4 storm quadrants (NE,NW,SE,SW). c The wind thresholds that are sought are gale force (34kt|17.5m/s), c storm force (50kt|25.7m/s), and hurricane force (64kt|32.9m/s). c This subroutine calls the Cray subroutine orders, which is a c Cray-optimized sort routine. c c UPDATE (AUG 2001): The Cray subroutine orders was ported to the c SP by NCEP personnel. On the SP version, some changes were c apparently made so that the size of the arrays for calling c arguments 2, 3 and 4 (iwork, dtemp and isortix in my calling c routine) must be the same. This was not the case on the Crays, c and this was causing the tracker to crash for cases far north c on fine grids (GFDL 1/3 grid). c c UPDATE (AUG 2012): The call to the Cray subroutine orders was c replaced with a call to qsort, which uses a quicksort sorting c algorithm. While this is not the fastest sorting routine out c there, we don't do a lot of sorting here, and qsort is simple c and it is portable. c c UPDATE (April 2013): For the radii, we encountered a problem with c radmax being too small. It was set at 650 km. Hurricane Sandy c exceeded this in the models, so the values returned from getradii c were close to the default radmax value of 650 km (350 nm), instead c of much higher as they should have been. To fix it, we now use an c iterative technique, where we start with radmax as a small value c (450 km). If getradii returns a value for R34 in a quadrant that c does not exceed 0.97*radmax, then that value is ok. If it does c exceed 0.97*radmax, then we bump up radmax by 50 km and call c getradii again, looking to diagnose radii only in those quadrants c where the need_to_expand_r34 flag = 'n'. c c INPUT: c c xcenlon fix longitude of storm center for current forecast hour c xcenlat fix latitude of storm center for current forecast hour c imax max i dimension of model grid c jmax max j dimension of model grid c dx grid spacing in i-direction of model grid c dy grid spacing in j-direction of model grid c valid_pt logical bitmap for valid data at a grid point c cstormid 3-character storm ATCF ID (e.g., 03L, 11E, etc) c ifcsthr integer value for current forecast hour c trkrinfo derived type containing various info on the storm c need_to_expand_r34 1-character array that specifies which of the c 4 quadrants still need to be expanded on this time c through getradii in order to get an R34 value that is c not right at the outermost boundary. c vmaxwind max wind (in m/s) that was reported from the c get_max_wind subroutine c radmax input max radius (km) that will be used for this c iteration of getradii. c first_time_thru_getradii logical flag. It is used so that any c checking for 50- or 64-kt radii is only done on the c first time through getradii. Only the checking for c 34-kt radii is done on multiple iterations. c igrct integer that indicates what iteration of getradii this c call is. c c OUTPUT: c c igrret return code from this subroutine c vradius Contains the distance from the storm fix position to c each of the various wind threshhold distances in each c quadrant. (3,4) ==> (# of threshholds, # of quadrants) c c LOCAL: c c radmax the maximum radius to look for winds for the various c thresholds. c quadinfo This array contains the magnitude of the near-surface c winds and the distance from the gridpoint to the fix c position for each point in each quadrant that is within c the maximum allowed radius, radmax. quadinfo is c allocated within this subroutine, and is allocated as c (quadrant, num_pts_in_quadrant, data_type), where c data_type is either windspeed(1) or distance(2) from c storm center to grid point. c quadmax This array contains the max surface wind in each c quadrant, plus the location of it and the distance from c the storm center. This information is critical to c identifying when this subroutine is malfunctioning. USE grid_bounds; USE tracked_parms; USE trig_vals; USE level_parms USE trkrparms USE verbose_output c type (trackstuff) trkrinfo c logical(1) valid_pt(imax,jmax) logical(1) first_time_thru_getradii c dimension iwork(257) real, allocatable :: quadinfo(:,:,:),iwork(:) real quadmax(4,4) real exactdistnm,exactdistkm,radmax,degrees,cosarg real rlonb,rlonc,rlatb,rlatc,vmaxwind real pt_heading_rad,pt_heading,d integer, allocatable :: isortix(:) integer iwindix,ipoint,ifcsthr,igrct integer quadct(4),vradius(3,4) integer, parameter :: dp = selected_real_kind(12, 60) real (dp), allocatable :: dtemp(:) real :: windthresh(3) = (/17.5,25.7,32.9/) character cstormid*3 character :: need_to_expand_r34(4)*1 if ( verb .ge. 3 ) then print *,' ' print *,' *************************************************** ' print *,' AT BEGINNING OF GETRADII, input radmax= ',radmax print *,' *************************************************** ' print *,' ' print *,'xcenlon= ',xcenlon,' xcenlat= ',xcenlat print *,'imax= ',imax,' jmax= ',jmax,' dx= ',dx,' dy= ',dy endif igrret = 0 c ----------------------------------------------------------- c PART 1: Define the maximum radius for which you'll search c for the wind values, and then get the beginning and ending c i and j points for that sub-region to search. Define this c maximum radius (radmax) in terms of km. c ----------------------------------------------------------- c radmax = 650.0 ! This value is in units of km. With April 2013 c ! update, this is now defined in calling routine c Roughly fix xcenlat to the grid point just poleward of xcenlat, c and fix xcenlon to the grid point just EASTward of xcenlon. if (xcenlat >= 0.0) then jlatfix = int((glatmax - xcenlat)/dy + 1.) else jlatfix = ceiling((glatmax - xcenlat)/dy + 1.) endif ilonfix = int((xcenlon - glonmin)/dx + 2.) if (ilonfix > imax) then if (trkrinfo%gridtype == 'global') then ilonfix = ilonfix - imax ! If wrapping past GM else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: In getradii, the ' print *,'!!! user-requested eastern boundary' print *,'!!! is beyond the eastern bounds of ' print *,'!!! this regional grid. ' print *,'!!! ' print *,'!!! imax of regional grid = ',imax print *,'!!! eastern ilonfix = ',ilonfix print *,'!!! ' print *,'!!! Radii will not be computed for this time.' print *,' ' endif idta=0; iisa=0; iwa=0; iqa=0 if (allocated(dtemp)) deallocate (dtemp,stat=idta) if (allocated(isortix)) deallocate (isortix,stat=iisa) if (allocated(iwork)) deallocate (iwork,stat=iwa) if (allocated(quadinfo)) deallocate (quadinfo,stat=iqa) if (iqa /= 0 .or. iwa /= 0 .or. idta /= 0 .or. iisa /= 0) then print *,' ' print *,'!!! ERROR in getradii deallocating arrays.' print *,'!!! iqa= ',iqa,' idta= ',idta print *,'!!! iisa= ',iisa,' iwa= ',iwa print *,'!!! EXITING at GR-A....' stop 98 endif igrret = 99 return endif endif if (ilonfix < 1) then if (trkrinfo%gridtype == 'global') then ilonfix = ilonfix + imax else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: ilonfix < 1 in subroutine getradii' print *,'!!! for a non-global grid.' print *,'!!! ilonfix= ',ilonfix print *,'!!! ' print *,'!!! Radii will not be computed for this time.' print *,' ' endif idta=0; iisa=0; iwa=0; iqa=0 if (allocated(dtemp)) deallocate (dtemp,stat=idta) if (allocated(isortix)) deallocate (isortix,stat=iisa) if (allocated(iwork)) deallocate (iwork,stat=iwa) if (allocated(quadinfo)) deallocate (quadinfo,stat=iqa) if (iqa /= 0 .or. iwa /= 0 .or. idta /= 0 .or. iisa /= 0) then print *,' ' print *,'!!! ERROR in getradii deallocating arrays.' print *,'!!! iqa= ',iqa,' idta= ',idta print *,'!!! iisa= ',iisa,' iwa= ',iwa print *,'!!! EXITING at GR-B....' stop 98 endif igrret = 99 return endif endif c Calculate number of grid points to have surrounding the storm so c that we are sure radmax is within those points. cosfac = cos (xcenlat * dtr) numipts = ceiling((radmax/(dtk*dx))/cosfac) numjpts = ceiling(radmax/(dtk*dy)) jbeg = jlatfix - numjpts jend = jlatfix + numjpts + 1 ibeg = ilonfix - (numipts + 1) iend = ilonfix + numipts if (ibeg < 1) then if (trkrinfo%gridtype == 'global') then continue ! If wrapping past GM, there is code below in this ! getradii routine that can modify the indices ! appropriately. So... do nothing here. else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: In getradii, the ' print *,'!!! user-requested western boundary' print *,'!!! is beyond the western bounds of ' print *,'!!! this regional grid. ' print *,'!!! ' print *,'!!! imax of regional grid = ',imax print *,'!!! ilonfix = ',ilonfix,' ibeg= ',ibeg print *,'!!! ' print *,'!!! Radii will not be computed for this time.' print *,' ' endif idta=0; iisa=0; iwa=0; iqa=0 if (allocated(dtemp)) deallocate (dtemp,stat=idta) if (allocated(isortix)) deallocate (isortix,stat=iisa) if (allocated(iwork)) deallocate (iwork,stat=iwa) if (allocated(quadinfo)) deallocate (quadinfo,stat=iqa) if (iqa /= 0 .or. iwa /= 0 .or. idta /= 0 .or. iisa /= 0) then print *,' ' print *,'!!! ERROR in getradii deallocating arrays.' print *,'!!! iqa= ',iqa,' idta= ',idta print *,'!!! iisa= ',iisa,' iwa= ',iwa print *,'!!! EXITING at GR-C...' stop 98 endif igrret = 99 return endif endif if (jbeg < 1) jbeg = 1 if (jbeg > jmax .or. jbeg < 1 .or. jend < 1) then if ( verb .ge. 1 ) then print *,' ' print *,'ERROR in getradii calculating jbeg or jend.' print *,'jbeg= ',jbeg,' jend= ',jend print *,'Wind radii will not be calculated for this time.' endif idta=0; iisa=0; iwa=0; iqa=0 if (allocated(dtemp)) deallocate (dtemp,stat=idta) if (allocated(isortix)) deallocate (isortix,stat=iisa) if (allocated(iwork)) deallocate (iwork,stat=iwa) if (allocated(quadinfo)) deallocate (quadinfo,stat=iqa) if (iqa /= 0 .or. iwa /= 0 .or. idta /= 0 .or. iisa /= 0) then print *,' ' print *,'!!! ERROR in getradii deallocating arrays.' print *,'!!! iqa= ',iqa,' idta= ',idta print *,'!!! iisa= ',iisa,' iwa= ',iwa print *,'!!! EXITING at GR-D....' stop 98 endif igrret = 99 return endif if (iend > imax) then if (trkrinfo%gridtype == 'global') then continue ! If wrapping past GM, there is code below in this ! getradii routine that can modify the indices ! appropriately. So... do nothing here. else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: In getradii, the ' print *,'!!! user-requested eastern boundary' print *,'!!! is beyond the eastern bounds of ' print *,'!!! this regional grid. ' print *,'!!! ' print *,'!!! imax of regional grid = ',imax print *,'!!! ilonfix = ',ilonfix,' iend= ',iend print *,'!!! ' print *,'!!! Radii will not be computed for this time.' print *,' ' endif idta=0; iisa=0; iwa=0; iqa=0 if (allocated(dtemp)) deallocate (dtemp,stat=idta) if (allocated(isortix)) deallocate (isortix,stat=iisa) if (allocated(iwork)) deallocate (iwork,stat=iwa) if (allocated(quadinfo)) deallocate (quadinfo,stat=iqa) if (iqa /= 0 .or. iwa /= 0 .or. idta /= 0 .or. iisa /= 0) then print *,' ' print *,'!!! ERROR in getradii deallocating arrays.' print *,'!!! iqa= ',iqa,' idta= ',idta print *,'!!! iisa= ',iisa,' iwa= ',iwa print *,'!!! EXITING at GR-E....' stop 98 endif igrret = 99 return endif endif if (jend > jmax) jend = jmax if ( verb .ge. 3 ) then print *,' ' print *,'In getradii, ibeg= ',ibeg,' iend= ',iend print *,' jbeg= ',jbeg,' jend= ',jend print *,' ilonfix= ',ilonfix,' jlatfix= ',jlatfix endif c ----------------------------------------------------------- c PART 2: Within the area of grid points defined by jbeg, c jend, ibeg and iend, (1) calculate all the wind speeds at c each grid point, (2) calculate all of the distances from c each grid point to the storm center, (3) assign each grid c point to one of the 4 quadrants (NE,NW,SE,SW), (4) in each c quadrant, sort the points, based on windspeed. c ----------------------------------------------------------- jnum = jend - jbeg + 1 inum = iend - ibeg + 1 c numalloc = ((jnum * inum) / 2) + inum/2 + jnum/2 numalloc = jnum * inum + inum/2 + jnum/2 if ( verb .ge. 3 ) then print *,'in getradii, numalloc= ',numalloc,' radmax= ',radmax endif if (allocated(quadinfo)) deallocate (quadinfo,stat=iqa) allocate (quadinfo(4,numalloc,2),stat=iqa) if (iqa /= 0) then if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in sub getradii allocating quadinfo array.' print *,'!!! iqa = ',iqa endif idta=0; iisa=0; iwa=0; iqa=0 if (allocated(dtemp)) deallocate (dtemp,stat=idta) if (allocated(isortix)) deallocate (isortix,stat=iisa) if (allocated(iwork)) deallocate (iwork,stat=iwa) if (allocated(quadinfo)) deallocate (quadinfo,stat=iqa) if (iqa /= 0 .or. iwa /= 0 .or. idta /= 0 .or. iisa /= 0) then print *,' ' print *,'!!! ERROR in getradii deallocating arrays.' print *,'!!! iqa= ',iqa,' idta= ',idta print *,'!!! iisa= ',iisa,' iwa= ',iwa print *,'!!! EXITING at GR-F....' stop 98 endif igrret = 94 return endif quadct = 0 c Calculate the distances and wind speeds at each grid point. If c the distance is < radmax, include that wind info in the c appropriate quadinfo array location for that quadrant. quadmax = 0.0 jloop: do j=jbeg,jend iloop: do i=ibeg,iend ip = i if (i > imax) then if (trkrinfo%gridtype == 'global') then ip = i - imax ! If wrapping past GM else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: In getradii, the ' print *,'!!! user-requested point ' print *,'!!! is beyond the eastern bounds of ' print *,'!!! this regional grid. ' print *,'!!! At location B in subroutine.' print *,'!!! ' print *,'!!! imax of regional grid = ',imax print *,'!!! eastern point in question = ',i print *,'!!! ' print *,'!!! Radii will not be computed for this time' print *,' ' endif idta=0; iisa=0; iwa=0; iqa=0 if (allocated(dtemp)) deallocate (dtemp,stat=idta) if (allocated(isortix)) deallocate (isortix,stat=iisa) if (allocated(iwork)) deallocate (iwork,stat=iwa) if (allocated(quadinfo)) deallocate (quadinfo,stat=iqa) if (iqa /= 0 .or. iwa /= 0 .or. idta /= 0 .or. iisa /= 0) & then print *,' ' print *,'!!! ERROR in getradii deallocating arrays.' print *,'!!! iqa= ',iqa,' idta= ',idta print *,'!!! iisa= ',iisa,' iwa= ',iwa print *,'!!! EXITING at GR-G...' stop 98 endif igrret = 99 return endif endif if (i < 1) then if (trkrinfo%gridtype == 'global') then ip = i + imax else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: i < 1 in sub getradii' print *,'!!! for a non-global grid. i= ',i print *,'!!! At location C in subroutine.' print *,'!!! ' print *,'!!! Radii will not be computed for this time' print *,' ' endif idta=0; iisa=0; iwa=0; iqa=0 if (allocated(dtemp)) deallocate (dtemp,stat=idta) if (allocated(isortix)) deallocate (isortix,stat=iisa) if (allocated(iwork)) deallocate (iwork,stat=iwa) if (allocated(quadinfo)) deallocate (quadinfo,stat=iqa) if (iqa /= 0 .or. iwa /= 0 .or. idta /= 0 .or. iisa /= 0) & then print *,' ' print *,'!!! ERROR in getradii deallocating arrays.' print *,'!!! iqa= ',iqa,' idta= ',idta print *,'!!! iisa= ',iisa,' iwa= ',iwa print *,'!!! EXITING at GR-H....' stop 98 endif igrret = 99 return endif endif call calcdist (xcenlon,xcenlat,glon(ip),glat(j),dist,degrees) if (dist > radmax) cycle iloop if (valid_pt(ip,j)) then vmag = sqrt (u(ip,j,levsfc)**2 + v(ip,j,levsfc)**2) cc print *,'i= ',i,' j= ',j,' dist= ',dist,' vmag= ',vmag ! Calculate the angle from the center point to this point ! and then assign this point to the appropriate quadrant bin rlonc = (360.-glon(ip)) * dtr rlatc = glat(j) * dtr rlonb = (360.-xcenlon) * dtr rlatb = xcenlat * dtr d = degrees * dtr c write (6,59) 360.-xcenlon,xcenlat,360.-glon(ip),glat c c write (6,61) d/dtr,rlatc/dtr,360.-(rlonc/dtr),rlatb/dtr c & ,360.-(rlonb/dtr),sin(rlatc),sin(rlatb),cos(d) c & ,sin(d),cos(rlatb) c c c 59 format (1x,'+++ gr, xcenlon= ',f8.3,'W xcenlat= ' c & ,f8.3,' glon= ',f8.3,'W glat= ',f8.3) c c 61 format (1x,'+++ gr, d rlatc rlonc rlatb rlonb= ',5f9.4 c & ,' sin(rlatc)= ',f8.6,' sin(rlatb)= ',f8.6 c & ,' cos(d)= ',f8.6,' sin(d)= ',f8.6 c & ,' cos(rlatb)= ',f8.6) if (d == 0.0) then pt_heading = 0.0 else cosarg = (sin(rlatc)-sin(rlatb)*cos(d)) / & (sin(d)*cos(rlatb)) if (cosarg > 1.0) cosarg = 1 if (cosarg < -1.0) cosarg = -1 if (sin(rlonc-rlonb) < 0.0) then pt_heading_rad = acos(cosarg) else pt_heading_rad = 2*pi - acos(cosarg) endif pt_heading = pt_heading_rad / dtr endif if (pt_heading >= 0.0 .and. pt_heading < 90.) then ! NE quadrant iq = 1 else if (pt_heading >= 90.0 .and. pt_heading < 180.) then ! SE quadrant iq = 2 else if (pt_heading >= 180.0 .and. pt_heading < 270.) then ! SW quadrant iq = 3 else if (pt_heading >= 270.0 .and. pt_heading <= 360.) then ! NW quadrant iq = 4 endif c write (6,73) xcenlat,360.-xcenlon,j,i,ip,glat(j) c & ,360.-glon(ip),pt_heading,iq 73 format (1x,'+++ getradii clat clon: ',f6.2,' ',f7.2,'W',3i4 & ,' plat plon: ',f6.2,' ',f7.2,'W Dir: ',f7.2 & ,' Quad: ',i2) quadct(iq) = quadct(iq) + 1 quadinfo(iq,quadct(iq),1) = vmag quadinfo(iq,quadct(iq),2) = dist if (vmag > quadmax(iq,4)) then quadmax(iq,1) = glon(ip) quadmax(iq,2) = glat(j) quadmax(iq,3) = dist quadmax(iq,4) = vmag endif endif enddo iloop enddo jloop if ( verb .ge. 3 ) then print *,' ' print *,'After loop, quadct(1)= ',quadct(1),' quadct(2)= ' & ,quadct(2) print *,' quadct(3)= ',quadct(3),' quadct(4)= ' & ,quadct(4) print *,' ' write (6,110) cstormid,ifcsthr,'NE',quadmax(1,1),quadmax(1,2) & ,quadmax(1,3)*0.539638,quadmax(1,4)*1.9427 write (6,110) cstormid,ifcsthr,'SE',quadmax(2,1),quadmax(2,2) & ,quadmax(2,3)*0.539638,quadmax(2,4)*1.9427 write (6,110) cstormid,ifcsthr,'SW',quadmax(3,1),quadmax(3,2) & ,quadmax(3,3)*0.539638,quadmax(3,4)*1.9427 write (6,110) cstormid,ifcsthr,'NW',quadmax(4,1),quadmax(4,2) & ,quadmax(4,3)*0.539638,quadmax(4,4)*1.9427 print *,' ' 110 format (' quadmax: ',a3,1x,i3.3,1x,a2,1x,' lon: ',f6.2,'E',1x & ,' lat: ',f6.2,' radius: ',f7.2,' nm',2x,' vmag: ' & ,f6.2,' kts') endif c Now go through each quadrant and put the wind speed distance info c into a temporary array (dtemp), sort that array, and then scan c through that array to find the various thresholds. quadrantloop: do k=1,4 if (need_to_expand_r34(k) == 'y') then print *,'---> R34 search underway for quadrant ',k & ,' radmax= ',radmax continue else print *,'+ R34 okay for quadrant ',k,'... skipping...' cycle quadrantloop endif if (allocated(isortix)) deallocate (isortix) if (allocated(dtemp)) deallocate (dtemp) if (allocated(iwork)) deallocate (iwork) allocate (isortix(quadct(k)),stat=iisa) allocate (dtemp(quadct(k)),stat=idta) allocate (iwork(quadct(k)),stat=iwa) if (iisa /= 0 .or. idta /= 0 .or. iwa /= 0) then if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in getradii allocating isortix, dtemp' print *,'!!! or iwork array for quadrant= ',k print *,'!!! iisa = ',iisa,' idta= ',idta,' iwa= ',iwa endif idta=0; iisa=0; iwa=0; iqa=0 if (allocated(dtemp)) deallocate (dtemp,stat=idta) if (allocated(isortix)) deallocate (isortix,stat=iisa) if (allocated(iwork)) deallocate (iwork,stat=iwa) if (allocated(quadinfo)) deallocate (quadinfo,stat=iqa) if (iqa /= 0 .or. iwa /= 0 .or. idta /= 0 .or. iisa /= 0) & then print *,' ' print *,'!!! ERROR in getradii deallocating arrays.' print *,'!!! iqa= ',iqa,' idta= ',idta print *,'!!! iisa= ',iisa,' iwa= ',iwa print *,'!!! EXITING at GR-I....' stop 98 endif itret = 94 return endif c ------------------- do m=1,quadct(k) dtemp(m) = quadinfo(k,m,2) enddo imode = 2 isortix = 0 call qsort (dtemp,isortix,quadct(k)) ccccc call orders (imode,iwork,dtemp,isortix,quadct(k),1,8,1) cccc call orders_4byte (imode,iwork,dtemp,isortix cccc & ,quadct(k),1,8,1) if ( verb .ge. 3 ) then print *,' ' c ************************************************************** c--- mf 20100609 c CAUSE OF SEG FAULT!!!!!!!! -- not sure still an issue if dtemp c properly allocated c !print *,' dtemp(isortix(1)) = ',dtemp(isortix(1)) print *,' dtemp(isortix(quadct(k)))= ' & ,dtemp(isortix(quadct(k))) print *,' isortix(1) = ',isortix(1) print *,' isortix(quadct(k)) = ',isortix(quadct(k)) endif c ! Uncomment these next lines to see a listing in the output of c ! all wind values & distances in this quadrant less than radmax c do iqq = 1,quadct(k) c print *,' iqq= ',iqq,' vmag= ',quadinfo(k,isortix(iqq),1) c & ,' dist= ',quadinfo(k,isortix(iqq),2) c enddo c ------------------- if (quadct(k) < 2) then ! not enough members in array if ( verb .ge. 3 ) then print *,' ' print *,'!!! IN GETRADII, NOT ENOUGH MEMBERS IN ARRAY FOR' print *,'!!! QUADRANT #',k,' .... # members = quadct(k)= ' & ,quadct(k) print *,'!!! SETTING ALL VRADII = 0 for quadrant = ',k endif vradius(1,k) = 0 vradius(2,k) = 0 vradius(3,k) = 0 cycle quadrantloop endif c Within this quadrant, go through the sorted array of wind c magnitudes and compare those wind values against the set c wind thresholds to get the wind radii. The array has c been sorted by distance from the storm center in order of c closest (ipoint=1) to farthest (ipoint=quadct(k)). We c analyze these wind values by starting at the farthest c point and moving inward until we hit a point that has a c wind value of at least 34-knot winds (17.5 m/s). When c we find that point, we interpolate between that point and c the next farthest out point to get the distance that would c be for the exact 17.5 m/s value. We then continue searching c through the wind values down closer to the storm center to c see if we can find values for the 50- and 64-knot winds. iwindix = 1 ipoint = quadct(k) + 1 c print *,'drp: quad= ',k,' quadct= ',quadct(k) threshloop: do while (iwindix <= 3 .and. ipoint > 1) if (iwindix > 1) then if (first_time_thru_getradii) then ! We are only doing the wind radii for 50 and 64 kts on ! the first time through subroutine getradii (we only ! need to do the multiple call iterations for 34 kts). ! ! Make sure vmax for this lead time exceeds the radii ! threshold being diagnosed. The check below avoids, ! for example, reporting 50-kt wind radii when the max ! wind diagnosed was only 44 kts. This can happen since ! the radius for searching for radii is larger than the ! radius for searching for the max wind. if (vmaxwind >= windthresh(iwindix)) then if (verb >= 3) then c print *,' ' c print *,' +++ vmaxwind of ',vmaxwind,' m/s exceeds' c print *,' +++ threshold of ',windthresh(iwindix) c print *,' +++ (m/s), so radii checking will continue' c print *,' +++ for this threshold.' c print *,' +++ igrct= ',igrct,' ipoint= ',ipoint c & ,' iwindix= ',iwindix continue endif continue else if (verb >= 3) then print *,' ' print *,' --- vmaxwind of ',vmaxwind,' m/s does NOT' print *,' - - exceed threshold of ' & ,windthresh(iwindix) print *,' - - (m/s), so radii checking will NOT be ' print *,' - - performed for this threshold.' endif iwindix = iwindix + 1 cycle threshloop endif else iwindix = iwindix + 1 cycle threshloop endif endif ipoint = ipoint - 1 if (quadinfo(k,isortix(ipoint),1) < windthresh(iwindix)) then cycle threshloop else if (ipoint == quadct(k)) then if ( verb .ge. 3 ) then print *,' ' print *,'!!! NOTE: In getradii, a max wind radius was' print *,'!!! found at the maximum radius checked, so ' print *,'!!! you may want to make sure that you are' print *,'!!! checking at a far enough distance from ' print *,'!!! the fix position, that is, you may want to' print *,'!!! increase the value of radmax in subroutine' print *,'!!! getradii. Currently, radmax (km) = ',radmax print *,'!!! iwindix = ',iwindix,' quadrant= ',k endif vradius(iwindix,k) = int( ((quadinfo(k,isortix(ipoint),2) & * 0.5396) / 5.0) + 0.5) * 5 else c Interpolate between the 2 closest distances to each wind c threshold to get "exact" distance to that wind threshold c radius, convert from km to nm, and then round to the c nearest 5 nm (since TPC uses this precision). c 7/23/98 UPDATE: Jim Gross has asked that values not be c rounded to the nearest 5 nm, but rather only to the c nearest 1 nm. exactdistkm = quadinfo(k,isortix(ipoint),2) + & ( (quadinfo(k,isortix(ipoint),1) - windthresh(iwindix)) / & (quadinfo(k,isortix(ipoint),1) - & quadinfo(k,isortix(ipoint+1),1)) * & ( (quadinfo(k,isortix(ipoint+1),2) - & quadinfo(k,isortix(ipoint),2)) ) ) exactdistnm = exactdistkm * 0.5396 ! Convert km to nm vradius(iwindix,k) = int(exactdistnm + 0.5) cc vradius(iwindix,k) = int( (exactdistnm / 5.0) + 0.5) * 5 if ( verb .ge. 3 ) then print *,'iwindix= ',iwindix,' exactdistnm = ' & ,exactdistnm print *,'vradius(iwindix,k) =',vradius(iwindix,k) endif endif c The possibility exists, especially for coarse output c grids, that there could be a jump over more than 1 wind- c thresh category when going from 1 grid point to the next, so c we need to account for this. For example, if 1 point has c vmag = 15 m/s and the next point closer in has vmag = 28 c m/s, then between those 2 points you have the thresholds c for gale force AND storm force winds, so to be safe, we c actually need to add 1 to ipoint and re-check the current c point, if the wind value at that point is found to be c greater than a wind threshold value (which it has if you've c gotten to this point in threshloop). ipoint = ipoint + 1 iwindix = iwindix + 1 endif enddo threshloop if (allocated(dtemp)) deallocate (dtemp,stat=idta) if (allocated(isortix)) deallocate (isortix,stat=iisa) if (allocated(iwork)) deallocate (iwork,stat=iwa) if (idta /= 0 .or. iisa /= 0 .or. iwa /= 0) then if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in getradii deallocating isortix or' print *,'!!! dtemp or work for quadrant= ',k print *,'!!! idta= ',idta,' iisa= ',iisa,' iwa= ',iwa endif idta=0; iisa=0; iwa=0; iqa=0 if (allocated(dtemp)) deallocate (dtemp,stat=idta) if (allocated(isortix)) deallocate (isortix,stat=iisa) if (allocated(iwork)) deallocate (iwork,stat=iwa) if (allocated(quadinfo)) deallocate (quadinfo,stat=iqa) if (iqa /= 0 .or. iwa /= 0 .or. idta /= 0 .or. iisa /= 0) & then print *,' ' print *,'!!! ERROR in getradii deallocating arrays.' print *,'!!! iqa= ',iqa,' idta= ',idta print *,'!!! iisa= ',iisa,' iwa= ',iwa print *,'!!! EXITING at GR-J....' stop 98 endif itret = 94 return endif enddo quadrantloop if (allocated(quadinfo)) deallocate (quadinfo,stat=iqa) if (iqa /= 0) then if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in getradii deallocating quadinfo array.' print *,'!!! iqa= ',iqa endif idta=0; iisa=0; iwa=0; iqa=0 if (allocated(dtemp)) deallocate (dtemp,stat=idta) if (allocated(isortix)) deallocate (isortix,stat=iisa) if (allocated(iwork)) deallocate (iwork,stat=iwa) if (allocated(quadinfo)) deallocate (quadinfo,stat=iqa) if (iqa /= 0 .or. iwa /= 0 .or. idta /= 0 .or. iisa /= 0) & then print *,' ' print *,'!!! ERROR in getradii deallocating arrays.' print *,'!!! iqa= ',iqa,' idta= ',idta print *,'!!! iisa= ',iisa,' iwa= ',iwa print *,'!!! EXITING at GR-K....' stop 98 endif itret = 94 return endif c return end c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine get_max_wind (xcenlon,xcenlat,imax,jmax,dx,dy & ,valid_pt,levsfc,vmax,trkrinfo,rmax,igmwret) c c ABSTRACT: This subroutine looks for the maximum near-surface wind c near the storm center. This subroutine is only concerned with the c value of the max wind, NOT where it's located radially with c respect to the center. The value that's returned in vmax is the c max wind speed in m/s, which are the units the data are stored in. c However, when the max wind values are output in output_atcf, they c will be converted from m/s to knots. c c INPUT: c c xcenlon fix longitude of storm center for current forecast hour c xcenlat fix latitude of storm center for current forecast hour c imax max i dimension of model grid c jmax max j dimension of model grid c dx grid spacing in i-direction of model grid c dy grid spacing in j-direction of model grid c valid_pt logical bitmap for valid data at a grid point c levsfc integer holding the value of the array member that holds c the near-surface winds in the u and v arrays (at orig c writing, it's = 4). c c OUTPUT: c c vmax value of maximum near-surface wind near the storm ctr c rmax radius of max winds c igmwret return code from this subroutine c c LOCAL: c c radmaxwind the maximum radius to look for a max wind near the c storm center. You have to allow this to be bigger for c model grids with coarse resolution (ECMWF 2.5 degree). USE grid_bounds; USE tracked_parms; USE trig_vals; USE trkrparms USE verbose_output type (trackstuff) trkrinfo real radmaxwind,degrees,dx,dy,rmax logical(1) valid_pt(imax,jmax) c igmwret = 0 rmax = -99.0 if ((dx+dy)/2. <= 1.25) then if ((dx+dy)/2. <= 0.25) then radmaxwind = 300.0 else radmaxwind = 300.0 endif else radmaxwind = 500.0 endif c Roughly fix xcenlat to the grid point just poleward of xcenlat, c and fix xcenlon to the grid point just EASTward of xcenlon. if (xcenlat >= 0.0) then jlatfix = int((glatmax - xcenlat)/dy + 1.) else jlatfix = ceiling((glatmax - xcenlat)/dy + 1.) endif ilonfix = int((xcenlon - glonmin)/dx + 2.) if (ilonfix > imax) then if (trkrinfo%gridtype == 'global') then ilonfix = ilonfix - imax ! If wrapping past GM else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: In get_max_wind, the ' print *,'!!! user-requested eastern boundary' print *,'!!! is beyond the eastern bounds of ' print *,'!!! this regional grid. ' print *,'!!! ' print *,'!!! imax of regional grid = ',imax print *,'!!! eastern ilonfix = ',ilonfix print *,'!!! ' print *,'!!! Value of vmax will be set to 0 for this time.' print *,' ' endif igmwret = 99 return endif endif if (ilonfix < 1) then if (trkrinfo%gridtype == 'global') then ilonfix = ilonfix + imax else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: ilonfix < 1 in subroutine get_max_wind' print *,'!!! for a non-global grid.' print *,'!!! ilonfix= ',ilonfix print *,'!!! ' print *,'!!! Value of vmax will be set to 0 for this time.' print *,' ' endif igmwret = 99 return endif endif c Calculate number of grid points to have surrounding the storm so c that we are sure radmaxwind is within those points. cosfac = cos (xcenlat * dtr) numipts = ceiling((radmaxwind/(dtk*dx))/cosfac) numjpts = ceiling(radmaxwind/(dtk*dy)) jbeg = jlatfix - numjpts jend = jlatfix + numjpts + 1 ibeg = ilonfix - (numipts + 1) iend = ilonfix + numipts if (jbeg > jmax .or. jbeg < 1 .or. jend < 1) then if ( verb .ge. 1 ) then print *,' ' print *,'ERROR in get_max_wind calculating jbeg or jend.' print *,'jbeg= ',jbeg,' jend= ',jend print *,'Value of vmax will be set to 0 for this time.' endif vmax = 0.0 igmwret = 99 return endif if (jend > jmax) jend = jmax if ( verb .ge. 3 ) then print *,' ' print *,'In get_max_wind, ibeg= ',ibeg,' iend= ',iend print *,' jbeg= ',jbeg,' jend= ',jend print *,' ilonfix= ',ilonfix,' jlatfix= ',jlatfix endif vmax = 0.0 do j=jbeg,jend do i=ibeg,iend ip = i if (i > imax) then if (trkrinfo%gridtype == 'global') then ip = i - imax ! If wrapping past GM else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: In get_max_wind, the ' print *,'!!! user-requested point ' print *,'!!! is beyond the eastern bounds of ' print *,'!!! this regional grid. ' print *,'!!! At location B in subroutine.' print *,'!!! ' print *,'!!! imax of regional grid = ',imax print *,'!!! eastern point = ',i print *,'!!! ' print *,'!!! Value of vmax will be set to 0 for ' print *,'!!! this time.' print *,' ' endif igmwret = 99 return endif endif if (i < 1) then if (trkrinfo%gridtype == 'global') then ip = i + imax else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: i < 1 in sub get_max_wind' print *,'!!! for a non-global grid.' print *,'!!! ilonfix= ',ilonfix print *,'!!! At location C in subroutine.' print *,'!!! ' print *,'!!! Value of vmax will be set to 0 for ' print *,'!!! this time' print *,' ' endif igmwret = 99 return endif endif call calcdist (xcenlon,xcenlat,glon(ip),glat(j),dist,degrees) if (dist > radmaxwind) cycle if (valid_pt(ip,j)) then vmag = sqrt (u(ip,j,levsfc)**2 + v(ip,j,levsfc)**2) if (vmag > vmax) then vmax = vmag rmax = dist * 0.539638 ! convert from km to nm endif endif enddo enddo if ( verb .ge. 3 ) then print *,'At end of get_max_wind, vmax= ',vmax,' rmax= ',rmax endif return end c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine fixcenter (clon,clat,ist,ifh,calcparm,geslon,geslat & ,inp,stderr,fixlon,fixlat,xvalues,maxstorm,ifret) c c ABSTRACT: This subroutine loops through the different parameters c for the input storm number (ist) and calculates the c center position of the storm by taking an average of c the center positions obtained for those parameters. c First we check to see which parameters are within a c max error range (errmax), and we discard those that are c not within that range. Of the remaining parms, we get c a mean position, and then we re-calculate the position c by giving more weight to those estimates that are closer c to this mean first-guess position estimate. c c INPUT: c clon Center longitudes of tracked parms for this storm & ifh c clat Center latitudes of tracked parms for this storm & ifh c ist Storm number c ifh Index for forecast hour c calcparm Logical; Use this parm's location for this storm or not c geslon Initial guess longitude for this storm at this fcst hour c geslat Initial guess latitude for this storm at this fcst hour c inp contains the input date and model number information c xvalues The actual max or min data values for each parameter c maxstorm max # of storms to be handled in this run c c INPUT/OUTPUT: c stderr Standard deviation of the position "error" of the parms c relative to the guess storm position. As long as the c distance of a parm center to the guess center is <= c errpmax, it is included in the std dev calculation. c c OUTPUT: c fixlon Best approximation of storm center's longitude c fixlat Best approximation of storm center's latitude c ifret Return code from this subroutine c c LOCAL: c storm Contains tcvitals info for the storms (def_vitals) c trkerr_avg Sum/avg of the track errors for all parms for this c fcst hour, regardless of whether or not the error was c > errmax. It's used for getting the std deviation of c the position error for this forecast time, to be used c as part of the errmax calculation for the next fcst c time. c iclose Number of parameters whose position estimates are c found to be within a distance errmax of the guess pos c wtpos The weight given to each position estimate. It's c based on the distance from the average position. c errdist The "error" of the parameter center position relative c to the storm's guess position. c avgerr Average "error" of the parameter center positions c relative to the storm's guess position. c use4next Logical; If a parm center has been calculated but its c distance from the guess position is > errmax, we don't c use this center in calculating the new guess position, c however we will use this position in calculating the c standard deviation of the current time's guess c positions, to be used in calculating the new errmax c for the next forecast time. So in this subroutine, c calcparm may be set to FALSE if errdist > errmax, but c use4next will not be set to FALSE (Actually, it is c only set to FALSE if errdist > errpmax, which is c defined in error_parms and is roughly 600km). c stderr_close Standard deviation of position errors for parms that c have center estimates that are within a distance c errmax of the guess position. c clon_fguess These are the first-guess mean position estimates, c clat_fguess which are the means of the position estimates that c are within a distance errmax. These first-guess mean c positions will be refined by giving more weight to c individual parameter estimates that are closer to c this first-guess mean position. c dist_from_mean Contains the "error" distance of each parameter c from the first-guess mean position (clon_fguess, c clat_fguess). NOTE: If a parameter is not within c a distance errmax of the guess position for this c time (geslon,geslat), then there will be NO c dist_from_mean calculated for that parm. c USE error_parms; USE set_max_parms; USE inparms; USE def_vitals USE atcf; USE gen_vitals; USE tracked_parms USE verbose_output type (datecard) inp real clon(maxstorm,maxtime,maxtp),temp_clon(maxtp) real clat(maxstorm,maxtime,maxtp),temp_clat(maxtp) real fixlon(maxstorm,maxtime),fixlat(maxstorm,maxtime) real trkerr(maxtp),errdist(maxtp),xvalues(maxtp) real stderr(maxstorm,maxtime),devia(maxtp),wtpos(maxtp) real dist_from_mean(maxtp) real degrees,errtmp integer gt345_ct,lt15_ct logical(1) calcparm(maxtp,maxstorm),use4next(maxtp) character charparm(maxtp)*8,charmaxmin(maxtp)*8 c data charparm /'zeta 850','zeta 700','circ 850','NOT USED' & ,'circ 700','NOT USED',' gph 850',' gph 700',' MSLP' & ,'circ sfc','zeta sfc',' thk 5-8',' thk 2-5',' thk 2-8'/ data charmaxmin /' Max ',' Max ',' Min ','NOT USED' & ,' Min ','NOT USED',' Min ',' Min ',' Min ' & ,' Min ',' Max ',' Max ',' Max ',' Max '/ c ifret=0 c c We need to judge whether each parameter position is reasonable, c so we'll check to make sure that the dist from each parameter's c estimate to the guess position is less than a maximum allowable c error. If it's the first forecast time, use the initial error max c (defined as errinit in error_parms) as errmax. Otherwise, the c max error criterion is that the distance error must not exceed 3 c times the previous forecast time's standard deviation (after a c small growth factor has been applied). c UPDATE 3/5/98: During testing, it was found that just using the c previous time's stdev made errmax too "jumpy" (i.e., at vt=48h, c errmax could = 380, and then at vt=54h, errmax could jump down c to 190, so we've changed it so that it uses an average of the c stdev's from the 3 previous forecast times to maintain some c continuity between successive forecast times). c if (ifh == 1) then if (atcfname == 'GFSO' .or. atcfname == 'MRFO' .or. & atcfname == 'GDAS' .or. atcfname == 'GFDT' .or. & atcfname(1:3) == 'AP0' .or. atcfname(1:3) == 'AN0' .or. & atcfname(1:3) == 'AP1' .or. atcfname(1:3) == 'AN1' .or. & atcfname(1:3) == 'AC0' .or. atcfname == 'AEAR' ) then errmax = err_gfs_init errinit = err_gfs_init else if (atcfname == 'EMX ' .or. atcfname == 'FV3 ') then errmax = err_ecm_max errinit = err_ecm_max else errmax = err_reg_init errinit = err_reg_init endif else if (atcfname == 'GFSO' .or. atcfname == 'MRFO' .or. & atcfname == 'GDAS' .or. atcfname == 'GFDT' .or. & atcfname(1:3) == 'AP0' .or. atcfname(1:3) == 'AN0' .or. & atcfname(1:3) == 'AP1' .or. atcfname(1:3) == 'AN1' .or. & atcfname(1:3) == 'AC0' .or. atcfname == 'AEAR') then errinit = err_gfs_init else if (atcfname == 'EMX ' .or. atcfname == 'FV3 ') then errinit = err_ecm_max else errinit = err_reg_max endif if (ifh >= 4) then xavg_stderr = (stderr(ist,ifh-3) + stderr(ist,ifh-2) & + stderr(ist,ifh-1)) / 3.0 else if (ifh == 3) then xavg_stderr = (stderr(ist,ifh-2) + stderr(ist,ifh-1)) / 2.0 else if (ifh == 2) then xavg_stderr = stderr(ist,ifh-1) endif c The following errmax statement was replaced by the ensuing 4 c lines due to a compiler bug on some other platforms: c errmax = amin1(amax1(3.0*xavg_stderr*errpgro,errinit) c & ,errpmax) errtmp = 3.0*xavg_stderr*errpgro errmax = max(errtmp,errinit) errtmp = errpmax errmax = min(errmax,errtmp) endif if ( verb .ge. 3 ) then print *,' ' if (ifh > 1) then print '(a42,f8.2,a15,f8.2)' & ,' At beg of fixcenter, stderr(ist,ifh-1) = ' & ,stderr(ist,ifh-1),' xavg_stderr= ',xavg_stderr else print '(a45,a18)' & ,' At beg of fixcenter, stderr(ist,ifh-1) = N/A' & ,' xavg_stderr= N/A' endif print *,'At beg of fixcenter, errpgro = ',errpgro print *,'At beg of fixcenter, errinit = ',errinit print *,'At beg of fixcenter, errpmax = ',errpmax print *,'At beg of fixcenter, ifh= ',ifh,' errmax= ',errmax endif trkerr_avg = 0.0 iclose = 0; itot4next = 0 clonsum = 0.0; clatsum = 0.0 errdist = 0.0 use4next = .FALSE. gt345_ct = 0 lt15_ct = 0 c For each parm, check to see if the estimated center is within c distance errmax of the guess center. If it's within errmax, c then use that parm for locating the center. If it's NOT c within errmax, but IS within errpmax, then we still use this c in calculating the standard deviation of the parameters for c helping to determine the errmax for the next forecast hour. c OLD NOTE: For calculating the std dev to be used for the next c OLD forecast hour, do NOT use vmag 850, vmag 700 or vmag sfc, since c OLD those parms are always guaranteed to be within a short range of c OLD the guess, due to the nature of the algorithm (see subroutine c OLD get_uv_center for further details on that). do ip=1,maxtp if (ip == 4 .or. ip == 6) then ! Parms 4 & 6 not defined. calcparm(ip,ist) = .FALSE. cycle endif if (calcparm(ip,ist)) then call calcdist (geslon,geslat,clon(ist,ifh,ip) & ,clat(ist,ifh,ip),dist,degrees) errdist(ip) = dist if (dist <= errpmax) then use4next(ip) = .TRUE. trkerr_avg = trkerr_avg + dist itot4next = itot4next + 1 endif if (dist <= errmax) then iclose = iclose + 1 if (clon(ist,ifh,ip) > 345.) then gt345_ct = gt345_ct + 1 endif if (clon(ist,ifh,ip) < 15.) then lt15_ct = lt15_ct + 1 endif clonsum = clonsum + clon(ist,ifh,ip) clatsum = clatsum + clat(ist,ifh,ip) else calcparm(ip,ist) = .FALSE. endif endif enddo if (iclose > 0) then if (gt345_ct > 0 .and. lt15_ct > 0) then ! We have some parms left of the GM and some to the right, ! so we will add (360*lt15_ct) to the sum of the lons (clonsum) clon_fguess = (clonsum + (360.*float(lt15_ct)))/ iclose else clon_fguess = clonsum / float(iclose) endif if (clon_fguess >= 360.0) then clon_fguess = clon_fguess - 360. endif clat_fguess = clatsum / float(iclose) endif c Print out a table listing of the locations of the fixes for c the individual parameters. if ( verb .ge. 3 ) then print *,' ' print *,'--------------------------------------------------' write (6,95) 'Individual fixes follow..., fhr= ',ifhours(ifh) & ,ifclockmins(ifh),' ',storm(ist)%tcv_storm_id,' ' & ,storm(ist)%tcv_storm_name write (6,97) gstorm(ist)%gv_gen_date,gstorm(ist)%gv_gen_fhr & ,gstorm(ist)%gv_gen_lat & ,gstorm(ist)%gv_gen_latns,gstorm(ist)%gv_gen_lon & ,gstorm(ist)%gv_gen_lonew,gstorm(ist)%gv_gen_type print *,'Model name = ',atcfname print *,'Values of -99.99 indicate that a fix was unable to be' print *,'made for that paramater. Parameters 4 & 6 are not' print *,'used. Vorticity data values are scaled by 1e5.' print *,'Circulation data values are scaled by 1e-6.' print *,'errdist is the distance that the position estimate is' print *,'from the guess position for this time. MSLP value ' print *,'here may differ from that in the atcfunix file since ' print *,'the one here is that derived from the area-averaged ' print *,'barnes analysis, while that in the atcfunix file is ' print *,'from a specific gridpoint.' write (6,21) geslon,360.-geslon,geslat write (6,*) ' ' write (6,23) write (6,25) endif if (geslat > 0.0) then charmaxmin(1) = ' Max ' charmaxmin(2) = ' Max ' charmaxmin(3) = ' Max ' charmaxmin(5) = ' Max ' charmaxmin(10) = ' Max ' charmaxmin(11) = ' Max ' else charmaxmin(1) = ' Min ' charmaxmin(2) = ' Min ' charmaxmin(3) = ' Min ' charmaxmin(5) = ' Min ' charmaxmin(10) = ' Min ' charmaxmin(11) = ' Min ' endif do ip=1,maxtp if (ip == 1 .or. ip == 2 .or. ip == 11) then ! This IF block allows vorticity values to be ! written out and scaled up by 1e5 ... if (clon(ist,ifh,ip) < 0.001 .and. & clon(ist,ifh,ip) > -0.001) then if ( verb .ge. 3 ) then write (6,27) ip,charparm(ip),charmaxmin(ip),0.0 & ,0.0,clat(ist,ifh,ip),xvalues(ip)*1e5 & ,calcparm(ip,ist),errdist(ip) endif else if ( verb .ge. 3 ) then write (6,27) ip,charparm(ip),charmaxmin(ip) & ,clon(ist,ifh,ip),360.-clon(ist,ifh,ip) & ,clat(ist,ifh,ip),xvalues(ip)*1e5 & ,calcparm(ip,ist),errdist(ip) endif endif elseif (ip == 3 .or. ip == 5 .or. ip == 10) then ! This IF block allows circulation values to be ! written out and scaled down by 1e-6 ... if (clon(ist,ifh,ip) < 0.001 .and. & clon(ist,ifh,ip) > -0.001) then if ( verb .ge. 3 ) then write (6,27) ip,charparm(ip),charmaxmin(ip),0.0 & ,0.0,clat(ist,ifh,ip),xvalues(ip)*1e-6 & ,calcparm(ip,ist),errdist(ip) endif else if ( verb .ge. 3 ) then write (6,27) ip,charparm(ip),charmaxmin(ip) & ,clon(ist,ifh,ip),360.-clon(ist,ifh,ip) & ,clat(ist,ifh,ip),xvalues(ip)*1e-6 & ,calcparm(ip,ist),errdist(ip) endif endif else if (clon(ist,ifh,ip) < 0.001 .and. & clon(ist,ifh,ip) > -0.001) then if ( verb .ge. 3 ) then write (6,27) ip,charparm(ip),charmaxmin(ip),0.0 & ,0.0,clat(ist,ifh,ip),xvalues(ip) & ,calcparm(ip,ist),errdist(ip) endif else if ( verb .ge. 3 ) then write (6,27) ip,charparm(ip),charmaxmin(ip) & ,clon(ist,ifh,ip),360.-clon(ist,ifh,ip) & ,clat(ist,ifh,ip),xvalues(ip) & ,calcparm(ip,ist),errdist(ip) endif endif endif enddo 21 format (' Guess location for this time: ',f7.2,'E (',f6.2,'W)' & ,2x,f7.2) 23 format (' parm# parm Max/Min Lon_fix(E) Lon_fix(W)' & ,' Lat_fix Max/Min_value calcparm errdist(km)') 25 format (' ----- ---- ------- ---------- ----------' & ,' ------- ------------- -------- ----------') 27 format (2x,i2,4x,a8,2x,a8,3x,f7.2,5x,f7.2,4x,f7.2,7x,f9.2 & ,6x,L2,7x,f7.2) 95 format (1x,a33,1x,i4,':',i2.2,a2,a4,a1,a9) 97 format (' Gen ID (if available): ',i10.10,'_F',i3.3,'_',i3.3,a1 & ,'_',i4.4,a1,'_',a3) c If number of parameter centers close enough (iclose) > 0, then c calculate the center by taking an average of all the parameter c center positions that are within distance errmax from the guess c position (geslon,geslat). Get a first-guess mean position, and c then re-calculate the position estimate by giving more weight c to those positions that are closer to the first-guess mean c position. dist_from_mean = 0.0 if (iclose > 0) then c Get distances from first-guess mean position.... do ip=1,maxtp if (calcparm(ip,ist)) then call calcdist (clon_fguess,clat_fguess,clon(ist,ifh,ip) & ,clat(ist,ifh,ip),dist,degrees) dist_from_mean(ip) = dist endif enddo c Get the mean distance of each parameter estimate from c the first-guess mean position call avgcalc (dist_from_mean,maxtp,calcparm(1,ist) & ,xmn_dist_from_mean,iaret) if (iaret == 0) then call stdevcalc (dist_from_mean,maxtp,calcparm(1,ist) & ,xmn_dist_from_mean,stderr_close,isret) if ( verb .ge. 3 ) then print *,' ' print *,'After stdevcalc, xmn_dist_from_mean= ' & ,xmn_dist_from_mean,' stderr_close= ' & ,stderr_close,' isret= ',isret endif endif if (iaret /= 0 .or. isret /= 0) then if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR IN FIXCENTER -- Error occurred in either' print *,'!!! avgcalc or stdevcalc. Storm number = ',ist print *,'!!! RCC from avgcalc = ',iaret print *,'!!! RCC from stdevcalc = ',isret print *,'!!! Center fix will NOT be made, and processing' print *,'!!! for this storm is ending. The probable cause' print *,'!!! is that no calcparms were valid for this storm' print *,'!!! at this forecast hour.' endif fixlon(ist,ifh) = -999.0 fixlat(ist,ifh) = -999.0 ifret = 95 return endif if (calcparm(1,ist) .or. calcparm(2,ist) .or. calcparm(7,ist) & .or. calcparm(8,ist) .or. calcparm(9,ist) & .or. calcparm(11,ist) .or. calcparm(3,ist) & .or. calcparm(10,ist) .or. calcparm(5,ist) & .or. calcparm(12,ist) .or. calcparm(13,ist) & .or. calcparm(14,ist)) then continue else if ( verb .ge. 3 ) then print *,' ' print *,'!!! In fixcenter, STOPPING PROCESSING for this' print *,'!!! storm. The reason is that none of the fix' print *,'!!! locations for parms z850, z700, zeta 850,' print *,'!!! zeta 700, MSLP, wcirc_850, wcirc_700, ' print *,'!!! wcirc_sfc, sfc zeta or the various levels ' print *,'!!! of thicknesses were within a ' print *,'!!! reasonable distance of the guess location.' print *,'!!! ist= ',ist,' ifh= ',ifh write (6,102) ifhours(ifh),ifclockmins(ifh) 102 format (1x,'!!! Forecast hour: ',i4,':',i2.2) endif fixlon(ist,ifh) = -999.0 fixlat(ist,ifh) = -999.0 ifret = 95 return endif c Now re-calculate the mean position by giving more weight c to those position estimates that are closer to the first c guess mean position. Note that if stderr_close < 5.0, we c force it to be 5.0; we do this to avoid getting very c large numbers for devia values, which could make the c weights (wtpos) equal to 0. This occurred during testing c when only 2 parameters were valid, and so, of course, the c standard deviation from the mean of those 2 parameters c was close to 0, which gave devia values around 6000, and c then wtpos values of 0, leading to a divide by 0 crash c later on in subroutine wtavrg. kprm=0 if (stderr_close > 0.0) then if (stderr_close < 5.0) then if ( verb .ge. 3 ) then print *,' ' print *,'NOTE: Since stderr_close had a value less than' print *,'5, stderr_close has been forced to be equal' print *,'to 5 in order to avoid dividing by zero later' print *,'on in subroutine wtavrg.' endif stderr_close = 5.0 endif do ip=1,maxtp if (calcparm(ip,ist)) then kprm = kprm + 1 devia(kprm) = dist_from_mean(ip) / stderr_close wtpos(kprm) = exp(-devia(kprm)/3.) temp_clon(kprm) = clon(ist,ifh,ip) temp_clat(kprm) = clat(ist,ifh,ip) if ( verb .ge. 3 ) then write (6,113) ip,kprm,dist_from_mean(ip),devia(kprm) & ,wtpos(kprm),temp_clon(kprm) & ,360.-temp_clon(kprm),temp_clat(kprm) endif endif enddo 113 format (1x,'ip= ',i2,' kprm= ',i2,' dist_from_mean= ',f7.3 & ,' devia= ',f7.3,' wtpos= ',f8.5,2x,3(2x,f7.2)) else c c This next if statement is for the case in which only 1 c parameter is valid, for which the stderr_close will = 0 c (obviously), but as long as we have 1 valid parameter, c continue processing, and set the weight for that parm = 1. c The else portion is for the case in which stderr_close c = 0 with NO parms being close. c if (iclose == 1) then do ip=1,maxtp if (calcparm(ip,ist)) then kprm = kprm + 1 wtpos(kprm) = 1 temp_clon(kprm) = clon(ist,ifh,ip) temp_clat(kprm) = clat(ist,ifh,ip) endif enddo else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR IN FIXCENTER, stderr_close not > 0' print *,'!!! stderr_close = ',stderr_close print *,'!!! The probable cause is that no calcparms were' print *,'!!! valid for this storm at this forecast hour.' endif fixlon(ist,ifh) = -999.0 fixlat(ist,ifh) = -999.0 ifret = 95 return endif endif c if (kprm > 0) then call wtavrg_lon (temp_clon,wtpos,kprm,fixlon(ist,ifh),iwtret1) call wtavrg (temp_clat,wtpos,kprm,fixlat(ist,ifh),iwtret2) if (iwtret1 == 0 .and. iwtret2 == 0) then if (verb .ge. 3) then print *,' ' write (6,173) storm(ist)%tcv_storm_id,ifhours(ifh) & ,ifclockmins(ifh),fixlon(ist,ifh) & ,360.-fixlon(ist,ifh),fixlat(ist,ifh) 173 format ('At end of fixcenter: ',a4,' fhr= ',i4,':',i2.2 & ,' Fix position= ',f7.2,'E (',f6.2,'W)',2x,f7.2) print *,' ' endif else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR IN FIXCENTER in call to wtavrg.' print *,'!!! Return Codes from wtavrg calls follow: ' print *,'!!! RCC from wtavrg for long fix: ',iwtret1 print *,'!!! RCC from wtavrg for lat fix: ',iwtret2 print *,'!!! This means a divide by zero would have ' print *,'!!! been attempted, which means that the ' print *,'!!! weights in wtpos are not > 0. Check in' print *,'!!! subroutine fixcenter where devia values' print *,'!!! are calculated to see if something is ' print *,'!!! wrong there. Values of wtpos array follow:' print *,'!!! ',wtpos print *,'!!! ist= ',ist,' ifh= ',ifh,' iclose= ',iclose print *,'!!! errmax= ',errmax,' kprm= ',kprm print *,' ' endif fixlon(ist,ifh) = -999.0 fixlat(ist,ifh) = -999.0 ifret = 95 return endif else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR IN FIXCENTER, kprm NOT > 0' print *,'!!! This means that, for whatever reason, the ' print *,'!!! calcparm logical flag was set to .FALSE. for' print *,'!!! all of the parameters. Thus, a center' print *,'!!! position could not be obtained for this storm' print *,'!!! ist= ',ist,' ifh= ',ifh,' iclose= ',iclose print *,'!!! errmax= ',errmax,' kprm= ',kprm endif fixlon(ist,ifh) = -999.0 fixlat(ist,ifh) = -999.0 ifret = 95 return endif else if ( verb .ge. 3 ) then print *,' ' print *,'!!! NOTE: IN FIXCENTER, No storms are within errmax ' print *,'!!! OR the calcparm logical flag was set to .FALSE. ' print *,'!!! all of the parameters. Thus, a center' print *,'!!! position could not be obtained for this storm' print *,'!!! ist= ',ist,' ifh= ',ifh,' iclose= ',iclose print *,'!!! errmax= ',errmax endif fixlon(ist,ifh) = -999.0 fixlat(ist,ifh) = -999.0 ifret = 95 return endif c Now calculate the average error of all the parms that are within c a radius errpmax (defined in error_parms, ~600km), and the std c dev of those errors. This standard deviation will be used in c calculating the maximum allowable error for the next forecast c time. if (itot4next > 0 .and. ifret /= 95) then trkerr_avg = trkerr_avg / float(itot4next) call stdevcalc (errdist,maxtp,use4next,trkerr_avg & ,stderr(ist,ifh),isret) if (isret /= 0) then if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in FIXCENTER calculating std deviation ' print *,'!!! for use in next forecast hours errmax.' print *,'!!! ist= ',ist,' ifh= ',ifh,' itot4next= ' & ,itot4next endif ifret = 95 endif endif c return end c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine avgcalc (xdat,kmax,valid,xavg,iaret) c c ABSTRACT: This subroutine just calculates a straight average of c the parameters in the input array (xdat). The logical array c (valid) indicates whether or not to include a particular array c member or not in the calculation. USE verbose_output real xdat(kmax) logical(1) valid(kmax) c iaret = 0 c xsum = 0.0 ict = 0 do i=1,kmax if (valid(i)) then xsum = xsum + xdat(i) ict = ict + 1 endif enddo c if (ict > 0) then xavg = xsum / float(ict) else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in avgcalc, ict NOT > 0' endif xavg = xdat(1) iaret = 95 endif c return end c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine wtavrg (xdat,wt,kmax,xwtavg,iwtret) c c ABSTRACT: This subroutine calculates a weighted average of the c parameters in the input array (xdat) using the input weights c in the input array (wt). It is used to calculate the center lat c and lon fix positions. c USE verbose_output real xdat(kmax),wt(kmax) c iwtret = 0 c xwtavg = 0.0 wtot = 0.0 do i=1,kmax xwtavg = xwtavg + xdat(i)*wt(i) wtot = wtot + wt(i) enddo c if (wtot > 0.0) then xwtavg = xwtavg / wtot else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in wtavrg, wtot NOT > 0' endif iwtret = 95 endif c return end c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine wtavrg_lon (xlon,wt,kmax,xwtavg,iwtret) c c ABSTRACT: This subroutine calculates a weighted average of the c parameters in the input array (xlon) using the input weights c in the input array (wt). This subroutine is specifically used c to find the center lon fix positions. It contains code to c account for wrapping around the Greenwich Meridian. c USE verbose_output real xlon(kmax),wt(kmax) integer gt345_ct,lt15_ct c iwtret = 0 gt345_ct = 0 lt15_ct = 0 c First check to see if we have lons that are both to the left c and the right of the greenwich meridian do i = 1,kmax if (xlon(i) > 345.) then gt345_ct = gt345_ct + 1 endif if (xlon(i) < 15.) then lt15_ct = lt15_ct + 1 endif enddo if (gt345_ct > 0 .and. lt15_ct > 0) then ! We have some lons that are in the 300's (west of the GM), and ! some that are in the 0's (east of the GM). We need to ! standardize these if we want to get a meaningful average. do i = 1,kmax if (xlon(i) < 15.) then xlon(i) = xlon(i) + 360.0 endif enddo endif xwtavg = 0.0 wtot = 0.0 do i=1,kmax xwtavg = xwtavg + xlon(i)*wt(i) wtot = wtot + wt(i) enddo c if (wtot > 0.0) then xwtavg = xwtavg / wtot else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in wtavrg_lon, wtot NOT > 0' endif iwtret = 95 endif if (xwtavg >= 360.0) then xwtavg = xwtavg - 360.0 endif c return end c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine stdevcalc (xdat,kmax,valid,xavg,stdx,isret) USE verbose_output real xdat(kmax) logical(1) valid(kmax) isret = 0 stdx = 0.0 ict = 0 do i=1,kmax if (valid(i)) then stdx = stdx + (xdat(i) - xavg)**2 ict = ict + 1 endif enddo if (ict > 0) then stdx = sqrt(stdx/float(ict)) if (stdx == 0.0) then c This can happen if you have just 2 points; The mean position c will be exactly in the middle of the 2 points and so the c standard deviation around that mean point will be 0. And c since the calling routine will quit if the returned standard c deviation is 0, we must force it to be 1 so the program c continues running. Theoretically, it could also happen with c 3 or more points, but the likelihood of the distances working c out to exactly equidistant for 3 points is not that good. stdx = 1.0 endif else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in stdevcalc, ict NOT > 0' endif isret = 95 endif c return end c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine get_wind_circulation (uvgeslon,uvgeslat,imax,jmax & ,dx,dy & ,ist,level,valid_pt,cflag & ,ctlon,ctlat,fxval,trkrinfo & ,cmodel_type,maxmin,igwcret) c c ABSTRACT: This subroutine calculates the center fix position for c the wind circulation near the storm center. This center fix is c done differently than for the other parms. With this fix, c we limit the area that is searched. This subroutine is not c called until center fixes have been made for the 5 other parms c (z850, z700, zeta850, zeta700, mslp). Once those fixes have been c made, a modified first guess is made of the average of the c original guess position for this lead time and the 5 other parm c fixes that have already been made for this lead time. That c modified guess position is passed into this subroutine as uvgeslon c and uvgeslat, and that's where the searching for the wind c circulation is centered. c c This subroutine works by converting the winds to Vt and Vr at c each grid point evaluated, relative to each candidate center point c that is being evaluated at the time in the loop. We then compute c the circulation at each of 24 azimuths surrounding the storm c center, where circulation = Vt * (length of a 1/24 arc, in meters) c This process is repeated for 7 successive radii and the results c are summed up over all radii, approximating a solid disk c circulation. The point at which the circulation is maximized c (NHEM) or minimized (SHEM) is the center of circulation. c c grid_maxlat northernmost latitude on the input grid being sent to c this routine. This grid may be a subset of the original c full grid from the original dataset. c grid_minlat southernmost latitude on the input grid being sent to c this routine. This grid may be a subset of the original c full grid from the original dataset. c grid_maxlon easternmost longitude on the input grid being sent to c this routine. This grid may be a subset of the original c full grid from the original dataset. c grid_minlon westernmost longitude on the input grid being sent to c this routine. This grid may be a subset of the original c full grid from the original dataset. c cmodel_type character, 'global' or 'regional' c USE radii; USE grid_bounds; USE tracked_parms; USE trig_vals USE level_parms; USE trkrparms USE verbose_output implicit none type (trackstuff) trkrinfo integer date_time(8) character (len=10) big_ben(3) character(*) cmodel_type,maxmin integer, parameter :: numdist=7,numazim=24 integer imax,jmax,ist,level,igwcret,icvpret,idist,iazim real rdist(numdist),vr(numazim,numdist),vt(numazim,numdist) real vt_mean(numdist),circul_band(numdist) real grid_maxlat,grid_minlat,grid_maxlon,grid_minlon real rads,ri,uvgeslon,uvgeslat,dx,dy,ctlon,ctlat,fxval real temp_grid_minlon,temp_guesslon,rlatt,rlont,bear real targlon,targlat,xintrp_u,xintrp_v,vt_azim_sum,degrees real circ_diff,circ_diff_sum,hemisphere,wind_mag_ctr,dist real xmin_circ_diff_mean,xmax_circ_diff_mean,tlon,tlat real dell,fmax,fmin,grid_buffer,circ_diff_mean real circumference,arclength real circul_disk,xmax_circul_disk,xmin_circul_disk integer ibiret1,ibiret2,igvtret,azimuth_ct,igiret,npts integer igibret integer circ_diff_ct,ir,nhalf,bskip1,bskip2,iskip,nlev integer ilonfix,jlatfix,ibeg,iend,jbeg,jend,i,j,k,iix,jix logical(1) cflag, valid_pt(imax,jmax) c---------------- c print *,' ' print *,'top of get_wind_circulation, ' print *,' glatmax= ',glatmax print *,' glatmin= ',glatmin print *,' glonmax= ',glonmax print *,' glonmin= ',glonmin print *,' trkrinfo%gridtype= ',trkrinfo%gridtype print *,' cmodel_type= ',cmodel_type print *,' maxmin= ',maxmin print *,' imax= ',imax,' jmax= ',jmax print *,' uvgeslon= ',uvgeslon,' uvgeslat= ',uvgeslat print *,' dx= ',dx,' dy= ',dy,' ist= ',ist print *,' cflag= ',cflag print *,' ctlon= ',ctlon,' ctlat= ',ctlat print *,' fxval= ',fxval print *,' igwcret= ',igwcret igwcret = 0 grid_maxlat = glatmax grid_minlat = glatmin grid_maxlon = glonmax grid_minlon = glonmin rads = rads_wind_circ ri = ri_wind_circ if ( verb .ge. 3 ) then print *,' ' print *,'At beg of get_wind_circulation, rads= ',rads & ,' ri= ',ri,' dx= ',dx,' dy= ',dy endif dell = (dx+dy)/2. npts = rads/(dtk*dell) fmax = -1.0e+15; fmin = 1.0e+15 ctlon = 0.0; ctlat = 0.0 c Distances checked and the radial intervals are a function of c the grid resolution.... if (dell > 0.50) then rdist(1) = 50. rdist(2) = 85. rdist(3) = 120. rdist(4) = 155. rdist(5) = 190. rdist(6) = 225. rdist(7) = 260. else rdist(1) = 35. rdist(2) = 65. rdist(3) = 95. rdist(4) = 125. rdist(5) = 155. rdist(6) = 185. rdist(7) = 215. endif select case (level) case (850); nlev = nlev850 ! check module level_parms for case (700); nlev = nlev700 ! the values of these.... case (500); nlev = nlev500 case (1020); nlev = levsfc end select print *,' in get_wind_circulation, nlev= ',nlev if (uvgeslat >= 0.0) then hemisphere = 1.0 else hemisphere = -1.0 endif call get_ij_bounds (npts,0,ri,imax,jmax,dx,dy & ,grid_maxlat,grid_minlat,grid_maxlon,grid_minlon & ,uvgeslon,uvgeslat & ,trkrinfo,ilonfix,jlatfix,ibeg,jbeg,iend,jend & ,igibret) if (grid_minlon > 330. .and. grid_maxlon < 30.) then ! Our grid is straddling over the GM. This can happen either ! with a global grid or with a regional grid. How can it happen ! for a global grid? Well, for the case in which this routine ! is called from subroutine get_uv_center, where a smaller ! subgrid of data is passed in, and that smaller subgrid may ! straddle the GM. Anyway, we need a workaround. ! This workaround will put the minimum longitude ! in terms of a negative number, e.g., as opposed to being say, ! 354, it will be -6. You can then leave the grid_maxlon as is. temp_grid_minlon = grid_minlon - 360. if (uvgeslon > 330.) then ! If our grid is straddling the GM and we have adjusted the ! grid_minlon to be a negative number, then we also need to ! check on the guesslon and adjust it if it is also to west ! of the GM. temp_guesslon = uvgeslon - 360. else temp_guesslon = uvgeslon endif else temp_grid_minlon = grid_minlon temp_guesslon = uvgeslon endif if (cmodel_type == 'regional') then grid_buffer = 0.30 else grid_buffer = 0.0 endif c For the wind circulation analysis, we will want to speed things c up for finer resolution grids. We can do this by skipping some c of the points in the wind circulation analysis. if (dell > 0.20) then bskip1 = 1 bskip2 = 1 else if (dell > 0.10 .and. dell <= 0.20) then bskip1 = 3 bskip2 = 2 else if (dell > 0.05 .and. dell <= 0.10) then bskip1 = 5 bskip2 = 3 else if (dell > 0.03 .and. dell <= 0.05) then bskip1 = 8 bskip2 = 3 else if (dell <= 0.03) then bskip1 = 10 bskip2 = 4 endif c bskip1 = 1 c bskip2 = 1 jix = 0 c xmin_circ_diff_mean = 9999.0 c xmax_circ_diff_mean = -9999.0 xmin_circul_disk = 9999.0 xmax_circul_disk = -9999.0 if (verb .ge. 3) then print *,' ' print *,'In get_wind_circulation, prior to first loop, ' print *,' npts= ',npts,' dell= ',dell,' rads= ',rads print *,' ' endif jloop1: do j=-npts,npts,bskip1 jix = jix + 1 rlatt = uvgeslat + dell*float(j) iix = 0 iloop1: do i=-npts,npts,bskip1 iix = iix + 1 rlont = temp_guesslon + dell*float(i) c If any points in the search grid would extend beyond the grid c boundaries, then check and see if this is global grid. If it c is, and the extension occurred in the i-direction, then adjust c the longitude to allow for grid wrapping. If it is a regional c grid, then just cycle the iloop. In previous versions of the c tracker, we would exit with an error message, but doing it c this way allows us to continue tracking some systems that may c be close to the grid boundary. Also, remember to factor in c the grid_buffer discussed in the doc block above for this c subroutine. if (rlont >= (grid_maxlon + dx - grid_buffer)) then if (trkrinfo%gridtype == 'global') then rlont = rlont - 360. ! We just GM-wrapped for the full, ! regular, global grid else cycle iloop1 endif endif if (rlont < (temp_grid_minlon + grid_buffer)) then if (trkrinfo%gridtype == 'global') then rlont = rlont + 360. ! We just GM-wrapped for the full, ! regular, global grid else cycle iloop1 endif endif if (rlatt > (grid_maxlat - grid_buffer) .or. & rlatt < (grid_minlat + grid_buffer)) then cycle iloop1 endif c Make sure that the point being investigated here as a c potential center has valid data at that point. That is, for c some hires regional grids that have been rotated/converted c from a non-latlon grid to a latlon grid, there can be c locations within the (i,j) space that do not have valid data c at them. It makes no sense to consider a point such as this c as a potential center. c There is another simpler case here that we are watching out c for. This is simply the case, again for model data where we c only have the innermost nest. Depending on what we choose c for the variable "rads" above, with the way that "npts" is c defined for these iloops and jloops that we're in, we may be c searching over points that are simply well off the grid. c Therefore, it is critical to run through this c check_valid_point subroutine to make sure that we're not c going to inadvertantly be performing an analysis at one of c these "off-grid" points. So.... if the return code from c check_valid_point comes back non-zero, simply cycle iloop c and go to the next point. call check_valid_point (imax,jmax,dx,dy,u(1,1,nlev),maxmin & ,valid_pt,rlont,rlatt,grid_maxlat,grid_minlat,grid_maxlon & ,temp_grid_minlon,trkrinfo,icvpret) if (icvpret /= 0) then if ( verb .ge. 1 ) then print *,'!!! NOT A VALID PT from call in ' print *,'!!! get_wind_circulation: icvpret= ',icvpret endif cycle iloop1 endif call calcdist(rlont,rlatt,temp_guesslon,uvgeslat,dist,degrees) if (dist .gt. rads) cycle iloop1 c Now go through each radius, starting from inner and working c to outer, and at each one, go around through all of the 24 c discrete azimuths, starting at 7.5 and adding 15 degrees c clockwise each time, all the way up through 352.5. vt_mean = 0.0 vt = 0.0 vr = 0.0 circul_band = 0.0 circul_disk = 0.0 radiusloop1: do idist = 1,numdist azimuth_ct = 0 vt_azim_sum = 0.0 ! Compute the length of a 1/numazim arc at this radius, and ! be sure to multiply by 1000 to convert from km to m for ! use in computing the circulation.... circumference = 2 * pi * rdist(idist) * 1000.0 arclength = circumference / float(numazim) azimloop1: do iazim = 1,numazim bear = ((iazim-1) * 15.) + 7.5 call distbear (rlatt,rlont,rdist(idist) & ,bear,targlat,targlon) ctmwc if ( verb .ge. 3 ) then ctmwc print *,' ' ctmwc print '(5(a11,f7.2))',' ctr lat= ',rlatt ctmwc & ,' ctr lon= ',rlont ctmwc & ,' rdist= ',rdist(idist),' targlat= ',targlat ctmwc & ,' targlon= ',targlon ctmwc print '(19x,a10,f7.2,35x,a9,f7.2)',' ctr lon= ' ctmwc & ,360.-rlont ctmwc & ,'targlon= ',360.-targlon ctmwc endif ! These calls to bilin_int_uneven pass a variable "level" ! that contains the vertical level to pull the wind data ! from, either 850, 700 or surface (which will be ! indicated by a value/code of 1020). call bilin_int_uneven (targlat,targlon & ,dx,dy,imax,jmax,trkrinfo,level,'u',xintrp_u,ibiret1) call bilin_int_uneven (targlat,targlon & ,dx,dy,imax,jmax,trkrinfo,level,'v',xintrp_v,ibiret2) if (ibiret1 == 0 .and. ibiret2 == 0) then call getvrvt (rlont,rlatt,targlon,targlat & ,xintrp_u,xintrp_v,vr(iazim,idist) & ,vt(iazim,idist),igvtret) azimuth_ct = azimuth_ct + 1 circul_band(idist) = circul_band(idist) & + (vt(iazim,idist) * arclength) c vt_azim_sum = vt_azim_sum + vt(iazim,idist) else if (ibiret1 == 85 .or. ibiret2 == 85) then vr(iazim,idist) = -999.0 vt(iazim,idist) = -999.0 else igwcret = 95 return endif enddo azimloop1 if (azimuth_ct > 0) then ! Add the value for the circulation in this radial ! band (circul_band(idist)) to the "solid disk" ! circulation total. Also, ! Compute azimuthally-averaged Vt at this distance circul_disk = circul_disk + circul_band(idist) vt_mean(idist) = vt_azim_sum / float(azimuth_ct) else c vt_mean(idist) = -999.0 print *,' ' endif enddo radiusloop1 if (uvgeslat > 0.0) then if (circul_disk > xmax_circul_disk) then xmax_circul_disk = circul_disk ctlon = rlont ctlat = rlatt endif else if (circul_disk < xmin_circul_disk) then xmin_circul_disk = circul_disk ctlon = rlont ctlat = rlatt endif endif CC--> This section was commented out in Feb 2018 due to finding a cc bug/flaw in the whole "circulation difference" concept, and cc it has now been replaced throughout this subroutine with cc more robust circulation computation logic. cc cc Now get the wind magnitude at the candidate center of cc circulation (i.e., the one that we just used for cc computing all of the Vr and Vt in the previous azimloop1 cc and radiusloop1). c c call bilin_int_uneven (rlatt,rlont c & ,dx,dy,imax,jmax,trkrinfo,level,'u',xintrp_u,ibiret1) c call bilin_int_uneven (rlatt,rlont c & ,dx,dy,imax,jmax,trkrinfo,level,'v',xintrp_v,ibiret2) c if (ibiret1 == 0 .and. ibiret2 == 0) then c wind_mag_ctr = sqrt (xintrp_u**2 + xintrp_v**2) c else c if ( verb .ge. 3 ) then c print *,' ' c print *,'!!! NOTE: bilint_uneven failed for center' c print *,'!!! wind mag in get_wind_circulation.' c print *,'!!! rlont= ',rlont,' rlatt= ',rlatt c print *,'!!! ' c endif c endif c cc print *,' ' cc print *,'1st run, wind_mag_ctr= ',wind_mag_ctr c c circ_diff_ct = 0 c circ_diff_sum = 0.0 c do ir = 1,numdist cc print *,'1st run, ir= ',ir,' vtmean(ir)= ',vt_mean(ir) c if (vt_mean(ir) > -998.0) then c circ_diff = vt_mean(ir) - (hemisphere * wind_mag_ctr) c circ_diff_ct = circ_diff_ct + 1 c circ_diff_sum = circ_diff_sum + circ_diff c endif c enddo c c print *,'1st run, circ_diff_ct= ',circ_diff_ct c c if (circ_diff_ct > 0) then c c circ_diff_mean = circ_diff_sum / float(circ_diff_ct) c cc print *,'1st run, circ_diff_sum= ',circ_diff_sum cc & ,' circ_diff_mean= ',circ_diff_mean c c if (uvgeslat > 0) then c if (circ_diff_mean > xmax_circ_diff_mean) then c xmax_circ_diff_mean = circ_diff_mean c ctlon = rlont c ctlat = rlatt c endif c else c if (circ_diff_mean < xmin_circ_diff_mean) then c xmin_circ_diff_mean = circ_diff_mean c ctlon = rlont c ctlat = rlatt c endif c endif c endif c cc print *,'1st run, xmax_circ_diff_mean= ' cc & ,xmax_circ_diff_mean c c if (uvgeslat > 0) then c if (circ_diff_mean > xmax_circ_diff_mean) then c xmax_circ_diff_mean = circ_diff_mean c ctlon = rlont c ctlat = rlatt c endif c else c if (circ_diff_mean < xmin_circ_diff_mean) then c xmin_circ_diff_mean = circ_diff_mean c ctlon = rlont c ctlat = rlatt c endif c endif enddo iloop1 enddo jloop1 if (uvgeslat >= 0.0) then write (6,61) 360.-ctlon,ctlat,xmax_circul_disk else write (6,63) 360.-ctlon,ctlat,xmin_circul_disk endif 61 format (' After first run, Wind Circulation (NHEM) ctlon= ',f8.3 & ,'W ctlat= ',f8.3,' xmax_circul_disk = ',f15.1) 63 format (' After first run, Wind Circulation (SHEM) ctlon= ',f8.3 & ,'W ctlat= ',f8.3,' xmin_circul_disk = ',f15.1) c If nhalf is specified as 0, then don't go through any more c iterations of this routine, just exit with the value that we c already got the first time through the loop, above. if (dell > 0.50) then nhalf = 4 else if (dell > 0.20 .and. dell <= 0.50) then nhalf = 3 else if (dell > 0.10 .and. dell <= 0.20) then nhalf = 2 else if (dell > 0.05 .and. dell <= 0.10) then nhalf = 1 else if (dell <= 0.05) then c nhalf = 0 nhalf = 1 c if ( verb .ge. 3 ) then c print *,' ' c print *,'In get_wind_circulation, dell is < 0.05 deg, so ' c print *,'nhalf is set to 0 and only the first iteration of' c print *,'the search loop is done.' c print *,' dell= ',dell,' nhalf= ',nhalf c endif endif if (nhalf < 1) then if (uvgeslat > 0.0) then fxval = xmax_circul_disk else fxval = xmin_circul_disk endif return endif c If on our first pass through, we were dealing with a regional grid c that straddled the GM, then it becomes (for now) too much of a c coding hassle to deal with in the rest of this routine (i.e., in c all the nhalf iterations), so we will just go with the first run c through for the center fix and exit the routine. if (grid_minlon > 330. .and. grid_maxlon < 30.) then if (uvgeslat > 0.0) then fxval = xmax_circul_disk else fxval = xmin_circul_disk endif return endif c --------------------------------------------------------------- c --------------------------------------------------------------- c Halve the grid spacing to refine the location and value of the c max/min value, but restrict the area of the new search grid. c npts = npts/2 npts = max(npts,1) c ------------------------------------------------------------- c First, recalculate the i and j beginning and ending points to c be used in the barnes analysis subroutine. Only do this once c for this grid-refinement (even though the grid is redefined c nhalf times in this subroutine), but make sure to have the c possible search grid be big enough to allow the possibility of c the grid shifting way right or way left each time through the c loop (get_ij_bounds takes care of this). Cut the value of c rads in half (only do this once) so that any points beyond c rads/2 are not considered as potential centers. rads = 0.5 * rads call get_ij_bounds (npts,nhalf,ri,imax,jmax,dx,dy & ,grid_maxlat,grid_minlat,grid_maxlon,grid_minlon & ,ctlon,ctlat,trkrinfo & ,ilonfix,jlatfix,ibeg,jbeg,iend,jend,igibret) if (igibret /= 0) then if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in get_wind_circulation from call to ' print *,'!!! get_ij_bounds just before nhalf loop. ' print *,'!!! Stopping processing for storm number ',ist endif igwcret = 92 return endif c -------------------------------------------------------------- c Now do the actual searching for the max/min value kloop: do k = 1,nhalf call date_and_time (big_ben(1),big_ben(2),big_ben(3) & ,date_time) if ( verb .ge. 3 ) then write (6,32) k,date_time(5),date_time(6),date_time(7) 32 format (1x,'TIMING: get_wind_circ kloop, k= ',i2,' ' & ,i2.2,':',i2.2,':',i2.2) endif dell = 0.5*dell tlon = ctlon tlat = ctlat c xmin_circ_diff_mean = 9999.0 c xmax_circ_diff_mean = -9999.0 xmin_circul_disk = 9999.0 xmax_circul_disk = -9999.0 iskip = bskip2 if ( verb .ge. 3 ) then print *,' ' print *,'get_wind_circ nhalf loop, k= ',k write (6,161) tlon,360.-tlon,tlat print *,'ilonfix= ',ilonfix,' jlatfix= ',jlatfix & ,' npts= ',npts print *,'ibeg= ',ibeg,' jbeg= ',jbeg,' imax= ',imax print *,'iend= ',iend,' jend= ',jend,' jmax= ',jmax print *,'nhalf= ',nhalf,' iskip= ',iskip,' rads= ',rads endif if (verb .ge. 3) then print *,' ' print *,'In get_wind_circulation, prior to loop k= ',k print *,' npts= ',npts,' dell= ',dell,' rads= ',rads print *,' ' endif jloop2: do j=-npts,npts,iskip rlatt = tlat + dell*float(j) iloop2: do i=-npts,npts,iskip rlont = tlon + dell*float(i) if (rlont >= (grid_maxlon + dx - grid_buffer)) then if (trkrinfo%gridtype == 'global') then rlont = rlont - 360. else cycle iloop2 endif endif if (rlont < (grid_minlon + grid_buffer)) then if (trkrinfo%gridtype == 'global') then rlont = rlont + 360. else cycle iloop2 endif endif if (rlatt > (grid_maxlat - grid_buffer) .or. & rlatt < (grid_minlat + grid_buffer) .or. & rlont >= (grid_maxlon + dx - grid_buffer) .or. & rlont < (grid_minlon + grid_buffer)) then cycle iloop2 endif c Again, check and make sure that the lat/lon point in c question here has valid data (see the explanation further c up in this subroutine inside iloop). call check_valid_point (imax,jmax,dx,dy,u(1,1,nlev),maxmin & ,valid_pt,rlont,rlatt,grid_maxlat,grid_minlat & ,grid_maxlon,grid_minlon,trkrinfo,icvpret) if (icvpret /= 0) then cycle iloop2 endif call calcdist(rlont,rlatt,temp_guesslon,uvgeslat,dist & ,degrees) if (dist .gt. rads) cycle iloop2 c Now go through each radius, starting from inner and working c to outer, and at each one, go around through all of the 24 c discrete azimuths, starting at 7.5 and adding 15 degrees c clockwise each time, all the way up through 352.5. vt_mean = 0.0 vt = 0.0 vr = 0.0 circul_band = 0.0 circul_disk = 0.0 radiusloop2: do idist = 1,numdist azimuth_ct = 0 vt_azim_sum = 0.0 ! Compute the length of a 1/numazim arc at this radius, and ! be sure to multiply by 1000 to convert from km to m for ! use in computing the circulation.... circumference = 2 * pi * rdist(idist) * 1000.0 arclength = circumference / float(numazim) azimloop2: do iazim = 1,numazim bear = ((iazim-1) * 15.) + 7.5 call distbear (rlatt,rlont,rdist(idist) & ,bear,targlat,targlon) ctmwc if ( verb .ge. 3 ) then ctmwc print *,' ' ctmwc print '(5(a11,f7.2))',' ctr lat= ',rlatt ctmwc & ,' ctr lon= ',rlont ctmwc & ,' rdist= ',rdist(idist),' targlat= ',targlat ctmwc & ,' targlon= ',targlon ctmwc print '(19x,a10,f7.2,35x,a9,f7.2)',' ctr lon= ' ctmwc & ,360.-rlont ctmwc & ,'targlon= ',360.-targlon ctmwc endif call bilin_int_uneven (targlat,targlon & ,dx,dy,imax,jmax,trkrinfo,level,'u',xintrp_u,ibiret1) call bilin_int_uneven (targlat,targlon & ,dx,dy,imax,jmax,trkrinfo,level,'v',xintrp_v,ibiret2) if (ibiret1 == 0 .and. ibiret2 == 0) then call getvrvt (rlont,rlatt,targlon,targlat & ,xintrp_u,xintrp_v,vr(iazim,idist) & ,vt(iazim,idist),igvtret) azimuth_ct = azimuth_ct + 1 circul_band(idist) = circul_band(idist) & + (vt(iazim,idist) * arclength) c vt_azim_sum = vt_azim_sum + vt(iazim,idist) else if (ibiret1 == 85 .or. ibiret2 == 85) then vr(iazim,idist) = -999.0 vt(iazim,idist) = -999.0 else igwcret = 95 return endif enddo azimloop2 if (azimuth_ct > 0) then ! Add the value for the circulation in this radial ! band (circul_band(idist)) to the "solid disk" ! circulation total. Also, ! Compute azimuthally-averaged Vt at this distance circul_disk = circul_disk + circul_band(idist) vt_mean(idist) = vt_azim_sum / float(azimuth_ct) else c vt_mean(idist) = -999.0 print *,' ' endif enddo radiusloop2 if (uvgeslat > 0.0) then if (circul_disk > xmax_circul_disk) then xmax_circul_disk = circul_disk ctlon = rlont ctlat = rlatt endif else if (circul_disk < xmin_circul_disk) then xmin_circul_disk = circul_disk ctlon = rlont ctlat = rlatt endif endif CC--> This section was commented out in Feb 2018 due to finding a cc bug/flaw in the whole "circulation difference" concept, and cc it has now been replaced throughout this subroutine with cc more robust circulation computation logic. cc cc Now get the wind magnitude at the candidate center of cc circulation (i.e., the one that we just used for cc computing all of the Vr and Vt in the previous azimloop2 cc and radiusloop2). c c call bilin_int_uneven (rlatt,rlont c & ,dx,dy,imax,jmax,trkrinfo,level,'u',xintrp_u,ibiret1) c call bilin_int_uneven (rlatt,rlont c & ,dx,dy,imax,jmax,trkrinfo,level,'v',xintrp_v,ibiret2) c if (ibiret1 == 0 .and. ibiret2 == 0) then c wind_mag_ctr = sqrt (xintrp_u**2 + xintrp_v**2) c else c if ( verb .ge. 3 ) then c print *,' ' c print *,'!!! NOTE: bilint_uneven failed for center' c print *,'!!! wind mag in get_wind_circulation.' c print *,'!!! rlont= ',rlont,' rlatt= ',rlatt c print *,'!!! ' c endif c endif c cc print *,'kloop k= ',k,' wind_mag_ctr= ',wind_mag_ctr c c circ_diff_ct = 0 c circ_diff_sum = 0.0 c do ir = 1,numdist cc print *,'kloop k= ',k,' vtmean(ir)= ',vt_mean(ir) c if (vt_mean(ir) > -998.0) then c circ_diff = vt_mean(ir) - (hemisphere * wind_mag_ctr) c circ_diff_ct = circ_diff_ct + 1 c circ_diff_sum = circ_diff_sum + circ_diff c endif c enddo c cc print *,'kloop k= ',k,' circ_diff_ct= ',circ_diff_ct c c if (circ_diff_ct > 0) then c c circ_diff_mean = circ_diff_sum / float(circ_diff_ct) c cc print *,'kloop k=',k,' circ_diff_sum= ',circ_diff_sum cc & ,' circ_diff_mean= ',circ_diff_mean c c if (uvgeslat > 0.0) then c if (circ_diff_mean > xmax_circ_diff_mean) then c xmax_circ_diff_mean = circ_diff_mean c ctlon = rlont c ctlat = rlatt c endif c else c if (circ_diff_mean < xmin_circ_diff_mean) then c xmin_circ_diff_mean = circ_diff_mean c ctlon = rlont c ctlat = rlatt c endif c endif c endif c cc print *,'kloop k= ',k,' xmax_circ_diff_mean= ' cc & ,xmax_circ_diff_mean enddo iloop2 enddo jloop2 if ( verb .ge. 3 ) then if (uvgeslat >= 0.0) then print *,'---> xmax_circul_disk= ',xmax_circul_disk write (6,71) k,360.-ctlon,ctlat,xmax_circul_disk else print *,'---> xmin_circul_disk= ',xmin_circul_disk write (6,73) k,360.-ctlon,ctlat,xmin_circul_disk endif endif enddo kloop 71 format (' nhalf get_wind_circ, k= ',i2,' ctlon= ',f8.3,'W ' & ,' ctlat= ',f8.3,' Wind Circulation (NHEM: Max) = ' & ,f15.1) 73 format (' nhalf get_wind_circ, k= ',i2,' ctlon= ',f8.3,'W ' & ,' ctlat= ',f8.3,' Wind Circulation (SHEM: Min) = ' & ,f15.1) 161 format (' guesslon= ',f8.3,'E (',f8.3,'W) guesslat= ',f8.3) if (uvgeslat > 0.0) then fxval = xmax_circul_disk else fxval = xmin_circul_disk endif c return end c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine get_uv_center (uvgeslon,uvgeslat,imax,jmax,dx,dy & ,ist,level,valid_pt,cflag & ,ctlon,ctlat,xval,trkrinfo,igucret) c c ABSTRACT: This subroutine calculates the center fix position for c the minimum in the wind speed near the storm center. This center c fix is done differently than for the other parms. With this fix, c we severely limit the area that is searched, because we do not c want to confuse a wind minimum out on the periphery of a storm c with the center wind minimum. Therefore, this subroutine is not c called until center fixes have been made for the 5 other parms c (z850, z700, zeta850, zeta700, mslp). Once those fixes have been c made, a modified first guess is made of the average of the guess c position for this time and the 5 other parm fixes. That modified c guess position is passed into this subroutine as uvgeslon and c uvgeslat, and that's where the searching for the wind minimum c is done. To get the wind minimum, the u and v data are first c interpolated down to a fine grid (see details below for exact c figures), and then a single-pass barnes analysis is done on that c fine grid. The reason that we first interpolate the data (which c is different from how we do the other parms) is that if we just c use the original grid resolution, we may not be able to c accurately pick out a minimum in the wind field at the center. c USE radii; USE grid_bounds; USE tracked_parms; USE trig_vals USE level_parms; USE trkrparms USE verbose_output type (trackstuff) trkrinfo real, allocatable :: uold(:,:),vold(:,:),unew(:,:),vnew(:,:) real, allocatable :: rlonold(:),rlatold(:),rlonnew(:),rlatnew(:) real, allocatable :: vmag(:,:) real :: dx,dy real :: grid_maxlat,grid_minlat,grid_maxlon,grid_minlon character*1 :: gotlat logical(1) cflag, valid_pt(imax,jmax) logical(1), allocatable :: lbi(:,:) c gotlat = 'n' c c ----------------------------------------------------------------- c INTERPOLATE INPUT GRID TO SMALLER GRID c ----------------------------------------------------------------- c c Get beginning and ending j points (on the input grid) for a c smaller array that surrounds the storm. It is this smaller array c that we will interpolate to a finer grid. c c Calculate number of pts to either side of this j to search c npts = ceiling(rads_vmag/(dtk*((dx+dy)/2.))) c call get_ij_bounds (npts,0,ritrk_vmag,imax,jmax,dx,dy & ,glatmax,glatmin,glonmax,glonmin,uvgeslon,uvgeslat & ,trkrinfo,ilonfix,jlatfix,ibeg,jbeg,iend,jend,igiret) if ( verb .ge. 3 ) then print *,' ' print *,' After get_ij D, ibeg jbeg = ',ibeg,jbeg print *,' After get_ij D, iend jend = ',iend,jend endif if (igiret /= 0) then if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in get_uv_center from call to ' print *,'!!! get_ij_bounds, stopping processing for ' print *,'!!! storm number ',ist endif igucret = 92 return endif if (ibeg < 1) then if (trkrinfo%gridtype == 'global') then if ( verb .ge. 3 ) then print *,' ' print *,'!!! NOTE: In get_uv_center, the ibeg returned from' print *,'!!! get_ij_bounds is < 1, but our gridtype is ' print *,'!!! global, so we are going to leave it as is and ' print *,'!!! account for the grid wrapping.' print *,' ' endif else if ( verb .ge. 3 ) then print *,' ' print *,'!!! NOTE: In get_uv_center, the ibeg returned from' print *,'!!! get_ij_bounds is < 1, and our gridtype is NOT' print *,'!!! global, so we are going to redefine ibeg to 1.' print *,' ' endif ibeg = 1 endif endif if (jbeg < 1) jbeg = 1 if (ibeg > imax .or. jbeg > jmax .or. jbeg < 1 .or. & iend < 1 .or. jend < 1) then if ( verb .ge. 1 ) then print *,' ' print *,'ERROR in get_uv_center calculating ibeg, iend, jbeg' print *,'or jend. ibeg= ',ibeg,' iend= ',iend,' jbeg= ',jbeg print *,'jend= ',jend print *,'uv center will not be calculated for this time.' endif igrret = 99 return endif if (iend > imax) then if (trkrinfo%gridtype == 'global') then if ( verb .ge. 3 ) then print *,' ' print *,'!!! NOTE: In get_uv_center, the iend returned from' print *,'!!! get_ij_bounds is > imax, but our gridtype is ' print *,'!!! global, so we are going to leave it as is and' print *,'!!! account for the grid wrapping.' print *,' ' endif else if ( verb .ge. 3 ) then print *,' ' print *,'!!! NOTE: In get_uv_center, the iend returned from' print *,'!!! get_ij_bounds is > imax, and our gridtype is' print *,'!!! NOT global, so we will redefine iend to imax.' print *,' ' endif iend = imax endif endif if (jend > jmax) jend = jmax if ( verb .ge. 3 ) then print *,' ' print *,'In get_uv_center, ibeg= ',ibeg,' iend= ',iend print *,' jbeg= ',jbeg,' jend= ',jend print *,' ilonfix= ',ilonfix,' jlatfix= ',jlatfix endif c select case (level) case (850); nlev = nlev850 ! check module level_parms for case (700); nlev = nlev700 ! the values of these.... case (500); nlev = nlev500 case (1020); nlev = levsfc end select c This next if statement determines how many times to interpolate c the input grid to a smaller grid. Here are the grid sizes for c some of the typical grids that will be used: c c Original grid size # of interps Final grid size c -------------------- ------------ --------------------- c 1.00 deg (111.19 km) 3 0.125 deg (13.9 km) c 1.25 deg (138.99 km) 3 0.156 deg (17.4 km) c 2.50 deg (277.99 km) 4 0.156 deg (17.4 km) if ((dx+dy)/2. > 1.2) then numinterp = 4 else if ((dx+dy)/2. > 0.50 .and. (dx+dy)/2. <= 1.2) then numinterp = 3 else if ((dx+dy)/2. > 0.25 .and. (dx+dy)/2. <= 0.50) then numinterp = 2 else if ((dx+dy)/2. > 0.10 .and. (dx+dy)/2. <= 0.25) then numinterp = 1 else if ((dx+dy)/2. <= 0.10) then numinterp = 0 endif dell = (dx+dy)/2. imxold = iend - ibeg + 1 jmxold = jend - jbeg + 1 c -------------------------------------------------------------- c Before interpolating, make sure that all the original c points have valid data. If they don't then exit the c subroutine. NOTE: This is NOT checking to see if ALL the pts c on the complete & full input grid have valid data; it only c checks those points that are within the box returned from c get_ij_bounds. do i=ibeg,iend if (i > imax) then if (trkrinfo%gridtype == 'global') then ip = i - imax ! If wrapping past GM else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: In get_uv_center, the ' print *,'!!! user-requested eastern search boundary' print *,'!!! is beyond the eastern bounds of ' print *,'!!! this regional grid. ' print *,'!!! PROCESSING WILL STOP. ' print *,'!!! Subroutine location A....' print *,'!!! ' print *,'!!! imax of regional grid = ',imax print *,'!!! User-requested eastern i = ',i print *,' ' endif stop 94 endif else ip = i endif if (i < 1) then if (trkrinfo%gridtype == 'global') then ip = i + imax ! If wrapping past GM else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: i < 1 in subroutine get_uv_center' print *,'!!! for a non-global grid. STOPPING....' print *,'!!! i= ',i print *,' ' endif stop 97 endif endif do j=jbeg,jend if (.not. valid_pt(ip,j)) goto 975 enddo enddo c ------------------------------------ c Now begin the interpolation process allocate (uold(imxold,jmxold),stat=iuo) allocate (vold(imxold,jmxold),stat=ivo) allocate (rlonold(imxold),stat=iloo) allocate (rlatold(jmxold),stat=ilao) if (iuo /= 0 .or. ivo /= 0 .or. iloo /= 0 .or. ilao /= 0) goto 970 do intnum = 1,numinterp if (intnum == 1) then do i=ibeg,iend ik = i if (i < 1) then if (trkrinfo%gridtype == 'global') then ik = i + imax !GM wrapping else if ( verb .ge. 1 ) then print *,'!!! ERROR in get_uv_center, i < 1' print *,'!!! for a non-global grid at AA.' print *,'!!! i = ',i endif igucret = 92 return endif endif if (i > imax) then if (trkrinfo%gridtype == 'global') then ik = i - imax !GM wrapping else if ( verb .ge. 1 ) then print *,'!!! ERROR in get_uv_center, i > imax' print *,'!!! for a non-global grid at AA.' print *,'!!! i = ',i,' imax= ',imax endif igucret = 92 return endif endif rlonold(i-ibeg+1) = glon(ik) do j=jbeg,jend uold(i-ibeg+1,j-jbeg+1) = u(ik,j,nlev) vold(i-ibeg+1,j-jbeg+1) = v(ik,j,nlev) if (gotlat == 'n') then rlatold(j-jbeg+1) = glat(j) endif enddo gotlat = 'y' ! Only need to fill rlatold once enddo else deallocate (uold); deallocate (vold) deallocate (rlonold); deallocate (rlatold) allocate (uold(imxnew,jmxnew),stat=iuo) allocate (vold(imxnew,jmxnew),stat=ivo) allocate (rlonold(imxnew),stat=iloo) allocate (rlatold(jmxnew),stat=ilao) if (iuo /= 0 .or. ivo /= 0 .or. & iloo /= 0 .or. ilao /= 0) goto 970 gotlat = 'n' do i=1,imxnew rlonold(i) = rlonnew(i) do j=1,jmxnew uold(i,j) = unew(i,j) vold(i,j) = vnew(i,j) if (gotlat == 'n') then rlatold(j) = rlatnew(j) endif enddo gotlat = 'y' enddo imxold = imxnew jmxold = jmxnew deallocate (unew); deallocate (vnew) deallocate (rlonnew); deallocate (rlatnew) endif dell = 0.5 * dell imxnew = 2 * imxold - 1 jmxnew = 2 * jmxold - 1 allocate (unew(imxnew,jmxnew),stat=iuo) allocate (vnew(imxnew,jmxnew),stat=ivo) allocate (rlonnew(imxnew),stat=iloo) allocate (rlatnew(jmxnew),stat=ilao) if (iuo /= 0 .or. ivo /= 0 .or. & iloo /= 0 .or. ilao /= 0) goto 971 call bilin_int_even (imxold,jmxold,uold & ,imxnew,jmxnew,unew,ibiret) call bilin_int_even (imxold,jmxold,vold & ,imxnew,jmxnew,vnew,ibiret) c call lin_int (imxold,imxnew,rlonold,rlonnew,iliret) call lin_int_lon (imxold,imxnew,rlonold,rlonnew,iliret) call lin_int (jmxold,jmxnew,rlatold,rlatnew,iliret) chk_lonspc_old = rlonold(imxold) - rlonold(imxold - 1) chk_latspc_old = rlatold(jmxold) - rlatold(jmxold - 1) chk_lonspc_new = rlonnew(imxnew) - rlonnew(imxnew - 1) chk_latspc_new = rlatnew(jmxnew) - rlatnew(jmxnew - 1) grid_maxlat = rlatnew(1) grid_minlat = rlatnew(jmxnew) grid_minlon = rlonnew(1) grid_maxlon = rlonnew(imxnew) if ( verb .ge. 3 ) then print *,' ' print *,'In get_uv_center, intnum= ',intnum print *,'imxold= ',imxold,' imxnew= ',imxnew print *,'jmxold= ',jmxold,' jmxnew= ',jmxnew print *,'Grid boundaries of modified uv grid: ' print *,'grid_maxlat= ',grid_maxlat,' grid_minlat= ' & ,grid_minlat print *,'grid_maxlon= ',grid_maxlon,' grid_minlon= ' & ,grid_minlon endif enddo c ------------------ deallocate (uold); deallocate (vold) deallocate (rlonold); deallocate(rlatold) if (numinterp == 0) then ! No interpolations were done for this fine mesh grid, but we ! need to fill some of these arrays and define variables for ! subsequent subroutine calls just below here that require ! the variables imxnew, jmxnew, and the arrays unew and vnew. if (iend > imax) then if (trkrinfo%gridtype == 'global') then continue else if ( verb .ge. 1 ) then print *,' ' print *,'ERROR in get_uv_center: Should not have gotten' print *,'to this point in get_uv_center for a regional ' print *,'grid; iend should not > imax here !!!' endif igucret = 99 return endif endif if (ibeg < 1) then if (trkrinfo%gridtype == 'global') then continue else if ( verb .ge. 1 ) then print *,' ' print *,'ERROR in get_uv_center: Should not have gotten' print *,'to this point in get_uv_center for a regional' print *,'grid; ibeg should not < 1 here !!!' endif igucret = 99 return endif endif imxnew = iend - ibeg + 1 jmxnew = jend - jbeg + 1 allocate (unew(imxnew,jmxnew),stat=iuo) allocate (vnew(imxnew,jmxnew),stat=ivo) allocate (rlonnew(imxnew),stat=iloo) allocate (rlatnew(jmxnew),stat=ilao) if (iuo /= 0 .or. ivo /= 0 .or. & iloo /= 0 .or. ilao /= 0) goto 971 gotlat = 'n' do i=ibeg,iend ip = i if (i > imax) then ! This HAS to be a global, wrapping grid, or else the if ! statement a few lines up would have caught this already. ip = i - imax ! Wrapping past GM endif if (i < 1) then ! This HAS to be a global, wrapping grid, or else the if ! statement a few lines up would have caught this already. ip = i + imax ! Wrapping past GM endif rlonnew(i-ibeg+1) = glon(ip) do j=jbeg,jend unew(i-ibeg+1,j-jbeg+1) = u(i,j,nlev) vnew(i-ibeg+1,j-jbeg+1) = v(i,j,nlev) if (gotlat == 'n') then rlatnew(j-jbeg+1) = glat(j) endif enddo gotlat = 'y' ! Only need to fill rlatnew once enddo endif grid_maxlat = rlatnew(1) grid_minlat = rlatnew(jmxnew) grid_minlon = rlonnew(1) grid_maxlon = rlonnew(imxnew) if ( verb .ge. 3 ) then print *,'Grid boundaries of modified uv grid in get_uv_center:' print *,'grid_maxlat= ',grid_maxlat,' grid_minlat= ',grid_minlat print *,'grid_maxlon= ',grid_maxlon,' grid_minlon= ',grid_minlon endif allocate (vmag(imxnew,jmxnew),stat=ivm) allocate (lbi(imxnew,jmxnew),stat=ilb) if (ivm /= 0 .or. ilb /= 0) goto 972 call calc_vmag (unew,vnew,imxnew,jmxnew,vmag,icvret) deallocate (unew); deallocate (vnew) lbi = .TRUE. if ( verb .ge. 3 ) then print *,' ' print *,'Before call to find_maxmin, imxnew= ',imxnew & ,'jmxnew= ',jmxnew,' ist= ',ist write (6,171) dell,uvgeslon,360.-uvgeslon,uvgeslat 171 format (' dell= ',f7.3,' uvgeslon= ',f8.3,'E (',f8.3,'W)' & ,' uvgeslat= ',f8.3) endif c Note that in the next call, I pass the 'global' argument to c find_maxmin. This defines what type of grid it is, so that the c proper grid_buffer can be chosen. This grid_buffer is designed c to avoid having a center be chosen too close to the grid c boundary. However, in the case of vmag here, we are only using c a small subgrid, and we want to make sure we use *all* points c in that subgrid for searching, and that will occur if we set that c calling argument to 'global' as opposed to 'regional'. call find_maxmin (imxnew,jmxnew,dell,dell,'vmag' & ,vmag,'min',ist,uvgeslon,uvgeslat,rlonnew,rlatnew,lbi & ,trkrinfo,cflag,ctlon,ctlat,xval,grid_maxlat,grid_minlat & ,grid_maxlon,grid_minlon,'global',ifmret) deallocate (vmag); deallocate (lbi) deallocate (rlonnew); deallocate (rlatnew) c if (ifmret == 0) then goto 995 else igucret = ifmret if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in get_uv_center in call to find_maxmin' print *,'!!! storm num = ',ist,' igucret = ',igucret endif goto 998 endif c 970 continue if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR ALLOCATING either uold, vold,' print *,'!!! rlonold or rlatold in get_uv_center' print *,'!!! Storm number = ',ist print *,'!!! intnum= ',intnum print *,'!!! imxnew= ',imxnew,' jmxnew= ',jmxnew print *,'!!! imxold= ',imxold,' jmxold= ',jmxold print *,'!!! iuo= ',iuo,' ivo= ',ivo print *,'!!! iloo= ',iloo,' ilao= ',ilao endif igucret = 97 goto 998 971 continue if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR ALLOCATING either unew, vnew,' print *,'!!! rlonnew or rlatnew in get_uv_center' print *,'!!! Storm number = ',ist print *,'!!! intnum= ',intnum print *,'!!! imxnew= ',imxnew,' jmxnew= ',jmxnew print *,'!!! imxold= ',imxold,' jmxold= ',jmxold print *,'!!! iuo= ',iuo,' ivo= ',ivo print *,'!!! iloo= ',iloo,' ilao= ',ilao endif igucret = 97 goto 998 972 continue if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR ALLOCATING either vmag or lbi in ' print *,'!!! subroutine get_uv_center' print *,'!!! Storm number = ',ist print *,'!!! imxnew= ',imxnew,' jmxnew= ',jmxnew print *,'!!! ivm= ',ivm,' ilb= ',ilb endif igucret = 97 goto 998 975 continue if ( verb .ge. 1 ) then print *,' ' print *,'!!! Inside get_uv_center, at least one of the points' print *,'!!! is not a valid data point. This point may be ' print *,'!!! outside the valid data bounds of a regional grid' print *,'!!! i= ',i,' j= ',j print *,'!!! Storm number = ',ist endif igucret = 98 goto 998 c 995 continue igucret = 0 c 998 continue return end c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine get_uv_guess (guesslon,guesslat,clon,clat & ,calcparm,ist,ifh,maxstorm & ,uvgeslon,uvgeslat,igugret) c c ABSTRACT: The purpose of this subroutine is to get a modified c first guess lat/lon position before searching for the c minimum in the wind field. The reason for doing this is c to better refine the guess and avoid picking up a wind c wind minimum far away from the center. So, use the c first guess position (and give it strong weighting), and c then also use the fix positions for the current time c (give the vorticity centers stronger weighting as well), c and then take the average of these positions. c c INPUT: c guesslon guess longitude for this forecast time c guesslat guess latitude for this forecast time c clon array with center longitude fixes for the various parms c clat array with center latitude fixes for the various parms c calcparm logical; tells whether or not a parm has a valid fix c at this forecast hour c ist index for current storm c ifh index for current forecast hour c maxstorm max # of storms that can be handled c c OUTPUT: c uvgeslon contains modified guess longitude position at which to c look for the wind minimum c uvgeslat contains modified guess latitude position at which to c look for the wind minimum c igugret return code for this subroutine (0=normal) c---- c USE set_max_parms; USE level_parms; USE error_parms USE verbose_output logical(1) calcparm(maxtp,maxstorm) real clon(maxstorm,maxtime,maxtp) real clat(maxstorm,maxtime,maxtp) real uvgeslon, uvgeslat real guesslon,guesslat,degrees integer gt345_ct,lt15_ct sumlon = 0.0 sumlat = 0.0 ict = 0 gt345_ct = 0 lt15_ct = 0 c NOTE: We need to be careful in this routine when averaging c the longitudes together, in case we cross the greenwich c meridian, because then we may be averaging 345+ lons with c lons that are less than 15, giving incorrect results. c Therefore, check for this, and if it occurs, add 360 onto c any of the <15 lons (add it twice for those lons being c counted twice (guesslon and the vorticity centers)). c Weight the uv guess position by counting the storm's guess c position twice. sumlon = sumlon + 2.*guesslon sumlat = sumlat + 2.*guesslat ict = ict + 2 if (guesslon > 345.) then gt345_ct = gt345_ct + 1 endif if (guesslon < 15.) then lt15_ct = lt15_ct + 2 ! Yes, 2 is correct.... endif do ip = 1,maxtp if ((ip > 2 .and. ip < 7) .or. ip == 10) then cycle ! because 3-6 are for 850 & 700 u & v and 10 is ! for surface wind magnitude. else if (calcparm(ip,ist)) then call calcdist (guesslon,guesslat,clon(ist,ifh,ip) & ,clat(ist,ifh,ip),dist,degrees) if (dist < uverrmax) then c c Give the vorticity centers 2x weighting as well c if (ip == 1 .or. ip == 2 .or. ip == 11) then sumlon = sumlon + 2.*clon(ist,ifh,ip) sumlat = sumlat + 2.*clat(ist,ifh,ip) ict = ict + 2 if (clon(ist,ifh,ip) > 345.) then gt345_ct = gt345_ct + 1 endif if (clon(ist,ifh,ip) < 15.) then lt15_ct = lt15_ct + 2 ! Yes, 2 is correct... endif else sumlon = sumlon + clon(ist,ifh,ip) sumlat = sumlat + clat(ist,ifh,ip) ict = ict + 1 if (clon(ist,ifh,ip) > 345.) then gt345_ct = gt345_ct + 1 endif if (clon(ist,ifh,ip) < 15.) then lt15_ct = lt15_ct + 1 ! Only 1 for non-zeta parms endif endif endif endif endif enddo c if (ict > 0) then if (gt345_ct > 0 .and. lt15_ct > 0) then ! We have some parms left of the GM and some to the right, ! so we will add (360*lt15_ct) to the sum of the lons (sumlon) uvgeslon = (sumlon + (360.*float(lt15_ct)))/ ict else uvgeslon = sumlon / ict endif if (uvgeslon >= 360.0) then uvgeslon = uvgeslon - 360. endif uvgeslat = sumlat / ict igugret = 0 else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in get_uv_guess, ict not > 0, ict= ',ict print *,'!!! vmag center will not be calculated for this' print *,'!!! storm -- at least not at this level' print *,'!!! Storm number = ',ist endif igugret = 91 endif c return end c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine calc_vmag (xu,xv,imx,jmx,wspeed,icvret) c c ABSTRACT: This subroutine calculates the magnitude of the wind c speed for an array of points, given real u and real v arrays. c real xu(imx,jmx),xv(imx,jmx),wspeed(imx,jmx) c do i=1,imx do j=1,jmx wspeed(i,j) = sqrt( xu(i,j)*xu(i,j) + xv(i,j)*xv(i,j) ) enddo enddo c return end c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine bilin_int_even (imxold,jmxold,xold & ,imxnew,jmxnew,xnew,ibiret) c c ABSTRACT: This subroutine does a bilinear interpolation on a c grid of evenly spaced data. Do NOT attempt to use this subroutine c with data that are not evenly spaced or you will get unpredictable c results. c real xold(imxold,jmxold), xnew(imxnew,jmxnew) c c c --------------------------------------------------------------------- c Latitude ----> | c | c L O e O e O e O e O | O: original point from input array c o | c n e 1 2 1 2 1 2 1 e | 1: interpolated, primary inter. pt c g | c i O 2 O 2 O 2 O 2 O | e: interpolated edge point c t | c u e 1 2 1 2 1 2 1 e | 2: interpolated, secondary inter. pt c d | c e O 2 O 2 O 2 O 2 O | Interpolations are done in the order c | as indicated above; First, the input c | e 1 2 1 2 1 2 1 e | 'O' pts are placed onto the new, c | | larger grid. From that, the '1' pts c | O 2 O 2 O 2 O 2 O | can be interpolated. Next, the edge c | | (e) pts are interpolated using an c v e 1 2 1 2 1 2 1 e | interpolation of two 'O' pts and one c | '1' pt. Finally, the '2' pts are c O e O e O e O e O | done using the 2 surrounding '0' and c | '1' pts. Bilinear interpolation is c | made incredibly easier by the fact c | that the grid is evenly spaced. c --------------------------------------------------------------------- c NOTE: Remember that the arrays that are read in are indexed as c (lon,lat), so that in the diagram above, pt (1,1) is at the upper c left and pt (imax,jmax) is at the lower right, and each column is c a new latitude and each row is a new longitude. c c ----------------------------------------------------------------- c Put original (O) values from input array into new, expanded array c ----------------------------------------------------------------- c do i=1,imxold do j=1,jmxold xnew(2*i-1,2*j-1) = xold(i,j) enddo enddo c c ---------------------------------------------- c Interpolate to get primary interior (1) points c ---------------------------------------------- c do i=1,imxold-1 do j=1,jmxold-1 xnew(2*i,2*j) = 0.25 * (xnew(2*i-1,2*j-1) + xnew(2*i+1,2*j-1) & + xnew(2*i+1,2*j+1) + xnew(2*i-1,2*j+1)) enddo enddo c c --------------------------- c Interpolate edge (e) points c --------------------------- c c ... Northernmost 'e' points ... c j=1 do i=1,imxold-1 xnew(2*i,j) = 0.3333 * (xnew(2*i-1,j) + xnew(2*i+1,j) & + xnew(2*i,2)) enddo c c ... Southernmost 'e' points ... c j = 2*jmxold - 1 do i=1,imxold-1 xnew(2*i,j) = 0.3333 * (xnew(2*i-1,j) + xnew(2*i+1,j) & + xnew(2*i,j-1)) enddo c c ... Westernmost 'e' points ... c i=1 do j=1,jmxold-1 xnew(i,2*j) = 0.3333 * (xnew(i,2*j-1) + xnew(i,2*j+1) & + xnew(2,2*j)) enddo c c ... Easternmost 'e' points ... c i = 2*imxold - 1 do j=1,jmxold-1 xnew(i,2*j) = 0.3333 * (xnew(i,2*j-1) + xnew(i,2*j+1) & + xnew(i-1,2*j)) enddo c c ------------------------------------------------ c Interpolate to get secondary interior (2) points c ------------------------------------------------ c do j=2,2*jmxold-2 istep = mod(j+1,2) do i=istep+2,2*imxold-2,2 xnew(i,j) = 0.25 * (xnew(i-1,j) + xnew(i,j-1) + xnew(i+1,j) & + xnew(i,j+1)) enddo enddo c return end c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine lin_int (ioldmax,inewmax,xold,xnew,iliret) c c ABSTRACT: This subroutine linearly interpolates evenly spaced c data from one grid to another. c real xold(ioldmax), xnew(inewmax) c c First just copy points from old grid onto new, larger grid c do i=1,ioldmax xnew(2*i-1) = xold(i) enddo c c Now interpolate to get the in-between points c do i=1,ioldmax-1 xnew(2*i) = 0.5 * (xnew(2*i-1) + xnew(2*i+1)) enddo c return end c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine lin_int_lon (ioldmax,inewmax,xold,xnew,iliret) c c ABSTRACT: This subroutine linearly interpolates evenly spaced c data from one grid to another. This particular c routine is specifically used for interpolating c longitudes, and it factors in the possibility of c interpolating across the greenwich meridian. c real xold(ioldmax), xnew(inewmax) c c First just copy points from old grid onto new, larger grid c do i=1,ioldmax xnew(2*i-1) = xold(i) enddo c c Now interpolate to get the in-between points, and make the c necessary adjustment when interpolating a longitude between, c for example, 359.5 and 0.0. c do i=1,ioldmax-1 if (xnew(2*i-1) > 350. .and. xnew(2*i+1) < 10.) then xnew(2*i) = 0.5 * (xnew(2*i-1) + (360. + xnew(2*i+1))) else xnew(2*i) = 0.5 * (xnew(2*i-1) + xnew(2*i+1)) endif enddo c return end c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine get_zeta_values (fixlon,fixlat,imax,jmax,dx,dy & ,trkrinfo,imeanzeta,igridzeta,readflag & ,valid_pt,ist,ifh,maxstorm,inp,igzvret) c c ABSTRACT: This subroutine finds the maximum and mean zeta values c at 850 & 700 mb, near a storm center. It is called from c subroutine tracker, and its purpose is to report these values c that will then be written out to a special, modified version of c the atcfunix file. USE tracked_parms; USE radii; USE trig_vals; USE set_max_parms USE trkrparms; USE level_parms; USE grid_bounds; USE inparms USE verbose_output implicit none type (trackstuff) trkrinfo type (datecard) inp logical(1) readflag(14),valid_pt(imax,jmax),compflag character cmaxmin*3,cvort_maxmin*3 real fixlon(maxstorm,maxtime),fixlat(maxstorm,maxtime) real gridpoint_maxmin,xmeanzeta,dx,dy,re,ri,parmlon,parmlat integer igridzeta(nlevgrzeta),imeanzeta(nlevgrzeta) integer n,ix1,ix2,ilev,npts,imax,jmax,igzvret,ilonfix,jlatfix integer idum,jdum,ibeg,jbeg,iend,jend,igiret,icount,iuret integer ifilret,ist,ifh,ifmret,maxstorm c First, call get_ij_bounds in order to get the (i,j) coordinates c of the (fixlon,fixlat) position that we need to search around. c These (i,j) coordinates are returned as ilonfix and jlatfix. npts = imax * jmax call get_ij_bounds (npts,0,ridlm,imax,jmax & ,dx,dy,glatmax,glatmin,glonmax,glonmin & ,fixlon(ist,ifh),fixlat(ist,ifh),trkrinfo & ,ilonfix,jlatfix,ibeg,jbeg,iend,jend,igiret) if (ilonfix > imax) then if (trkrinfo%gridtype == 'global') then ilonfix = ilonfix - imax ! If wrapping past GM else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: In get_zeta_values, the ' print *,'!!! user-requested eastern boundary' print *,'!!! is beyond the eastern bounds of ' print *,'!!! this regional grid. ' print *,'!!! ' print *,'!!! imax of regional grid = ',imax print *,'!!! eastern ilonfix = ',ilonfix print *,'!!! ' print *,' ' endif igzvret = 99 return endif endif if (ilonfix < 1) then if (trkrinfo%gridtype == 'global') then ilonfix = ilonfix + imax else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: ilonfix < 1 in subroutine' print *,'!!! get_zeta_values for a non-global grid.' print *,'!!! ilonfix= ',ilonfix print *,'!!! ' print *,' ' endif igzvret = 99 return endif endif if ( verb .ge. 3 ) then write (6,*) ' ' write (6,601) write (6,603) write (6,605) write (6,607) write (6,609) write (6,*) ' ' write (6,613) ist,ifh write (6,615) fixlon(ist,ifh),360.-fixlon(ist,ifh) & ,fixlat(ist,ifh) write (6,617) ilonfix,jlatfix endif 601 format(1x,'#---------------------------------------------------#') 603 format(1x,'# Entering loop to determine the mean and gridpoint #') 605 format(1x,'# max zeta values at 850 and 700 mb for the purpose #') 607 format(1x,'# of reporting them on the modified atcfunix file. #') 609 format(1x,'#---------------------------------------------------#') 613 format(1x,'--- In get_zeta_values, ist= ',i3,' ifh= ',i3) 615 format(1x,' Fix location for this time: ',f7.2,'E (',f6.2,'W)' & ,2x,f7.2) 617 format(1x,' ilonfix= ',i4,' jlatfix= ',i4) report_zeta_loop: do n=1,2 gridpoint_maxmin = -99.0 xmeanzeta = -99.0 compflag = .true. select case (n) case (1); ilev=850 ! For 850 mb case (2); ilev=700 ! For 700 mb end select if (zeta(ilonfix,jlatfix,n) > -9990.0) then ! ------------------------------------------- ! We have valid zeta data for this level, so ! we first call barnes now to get the mean zeta ! surrounding our found center position. ! ------------------------------------------- if (fixlat(ist,ifh) > 0.0) then cvort_maxmin = 'max' else cvort_maxmin = 'min' endif call find_maxmin (imax,jmax,dx,dy,'zeta' & ,zeta(1,1,n),cvort_maxmin,ist,fixlon(ist,ifh) & ,fixlat(ist,ifh),glon,glat,valid_pt,trkrinfo & ,compflag,parmlon,parmlat,xmeanzeta & ,glatmax,glatmin,glonmax,glonmin,inp%modtyp,ifmret) if (ifmret == 0) then ! Out of regional grid bounds imeanzeta(n) = int ((xmeanzeta * 1e6) + 0.5) else imeanzeta(n) = -99 igridzeta(n) = -99 if ( verb .ge. 3 ) then write (6,*) ' ' write (6,519) write (6,520) write (6,521) endif 519 format (1x,' The call to find_maxmin in get_zeta_values') 520 format (1x,' returned a nonzero return code. The search') 521 format (1x,' for zeta values will not be done.') exit report_zeta_loop ! If out of grid bounds at 850, ! then will also be out at 700... endif else imeanzeta(n) = -99 igridzeta(n) = -99 exit report_zeta_loop endif if ( verb .ge. 3 ) then write (6,621) n,ilev,xmeanzeta,imeanzeta(n) 621 format (1x,'+++ RPT_MEAN_ZETA: n= ',i2,' lev= ',i4 & ,' xmeanzeta= ',f9.6,' imeanzeta (*1e6)= ',i8) write (6,*) ' --- mean zeta raw = ',xmeanzeta endif ! ----------------------------------------------- ! Call fix_latlon_to_ij to get the nearest actual ! raw (grid) zeta data value, not the mean value. ! ----------------------------------------------- call fix_latlon_to_ij (imax,jmax,dx,dy & ,zeta(1,1,n),cvort_maxmin,valid_pt,fixlon(ist,ifh) & ,fixlat(ist,ifh),xmeanzeta,idum,jdum & ,gridpoint_maxmin,'tracker' & ,glatmax,glatmin,glonmax,glonmin & ,trkrinfo,ifilret) if (ifilret == 0) then igridzeta(n) = int ((gridpoint_maxmin * 1e6) + 0.5) else igridzeta(n) = -99 endif if ( verb .ge. 3 ) then write (6,623) n,ilev,gridpoint_maxmin,igridzeta(n),ifilret 623 format (1x,'+++ RPT_GRID_ZETA: n= ',i2,' lev= ',i4 & ,' grid zeta= ',f9.6,' igrid zeta (*1e6)= ',i8 & ,' ifilret= ',i3) write (6,*) ' --- grid zeta raw= ',gridpoint_maxmin endif enddo report_zeta_loop if ( verb .ge. 3 ) then write (6,*) ' ' write (6,631) write (6,633) write (6,635) write (6,*) ' ' endif 631 format(1x,'#---------------------------------------------------#') 633 format(1x,'# End of loop to get 850 & 700 zeta for atcf file. #') 635 format(1x,'#---------------------------------------------------#') return end c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine find_maxmin (imax,jmax,dx,dy,cparm,fxy,maxmin,ist & ,guesslon,guesslat,rlonv,rlatv,valid_pt,trkrinfo & ,compflag,ctlon,ctlat,xval,grid_maxlat,grid_minlat & ,grid_maxlon,grid_minlon,cmodel_type,ifmret) c c This routine finds the location (clon,clat) of and value of the c the max or min of fxy in the vicinity of slon,slat. The value of c the input flag maxmin determines whether to look for a max or a c min value. The max/min is determined by finding the point which c gives the max/min value of a single point barnes analysis of fxy c with e-folding radius re (km) and influence radius ri (km). The c initial search is restricted to a radius rads around the point c (slon,slat) on a grid with lon,lat spacing dx and dy. The location c is refined by reducing the spacing of the search grid by a factor c of two, nhalf times. c c INPUT: c imax Num pts in i direction on input grid c jmax Num pts in j direction on input grid c dx Grid spacing in i-direction on input grid c dy Grid spacing in j-direction on input grid c cparm Char string indicating what parm is being passed in c fxy Real array of data values c maxmin Char string indicating whether to search for a max or min c ist Number of the storm being processed c guesslon Guess longitude of the storm c guesslat Guess latitude of the storm c rlonv Array containing longitude values of input grid points c rlatv Array containing latitude values of input grid points c valid_pt Logical bitmap masking non-valid grid points. This is a c concern for the regional models, which are interpolated c from Lam-Conf or NPS grids onto lat/lon grids, leaving c grid points around the edges which have no valid data. c trkrinfo derived type detailing user-specified grid info c grid_maxlat northernmost latitude on the input grid being sent to c this routine. This grid may be a subset of the original c full grid from the original dataset. c grid_minlat southernmost latitude on the input grid being sent to c this routine. This grid may be a subset of the original c full grid from the original dataset. c grid_maxlon easternmost longitude on the input grid being sent to c this routine. This grid may be a subset of the original c full grid from the original dataset. c grid_minlon westernmost longitude on the input grid being sent to c this routine. This grid may be a subset of the original c full grid from the original dataset. c cmodel_type character, 'global' or 'regional' c c INPUT/OUTPUT: c compflag Logical; continue processing this storm or not (would be c set to FALSE if, for example, the guess position is c outside the domain of a regional grid) c c OUTPUT: c ctlon Center longitude of storm found for this parameter c ctlat Center latitude of storm found for this parameter c xval Max or Min value found at the (ctlon,ctlat) c ifmret Return code from this subroutine c c UPDATE DEC 2009: For the HFIP HRH testing, it was found that c due to the very limited domain size of some of the models, the c barnes scheme was allowing points close to the grid boundaries c to erroneously be selected as the center point. We add in a c buffer (grid_buffer) here to prevent this from occurring. USE radii; USE grid_bounds; USE set_max_parms; USE level_parms USE trig_vals; USE trkrparms USE verbose_output implicit none c type (trackstuff) trkrinfo character(*) maxmin,cparm,cmodel_type logical(1) compflag, valid_pt(imax,jmax) real fxy(imax,jmax),rlonv(imax),rlatv(jmax) real ctlon,ctlat,degrees,dx,dy,guesslon,guesslat,xval real rads,re,ri,dell,fmax,fmin,rlatt,rlont,dist,ftemp,ritmp real vmag_latmax,vmag_latmin,vmag_lonmax,vmag_lonmin,retmp real tlon,tlat,grid_buffer,temp_grid_minlon,temp_guesslon real grid_maxlat,grid_minlat,grid_maxlon,grid_minlon integer imax,jmax,ist,bskip1,bskip2,iskip,ifmret,npts,maxvgrid integer ibeg,iend,jbeg,jend,ilonfix,jlatfix,igiret,icount,iret integer ibct,ibarnes_loopct,i,j,k,iix,jix,jvlatfix,ivlonfix integer nhalf,icvpret integer date_time(8) character (len=10) big_ben(3) c ifmret = 0 nhalf = 5 c c ----------------------------------------------------------- c Set initial parms for use in find_maxmin. c Different radii used for V magnitude than for other parms, c see discussion in module radii for more details. c if (cparm == 'vmag') then c NOTE: The maxvgrid variable determines what size grid to send c to subroutine barnes. e.g., maxvgrid = 8 means send an c 8x8 grid; maxvgrid = 12 means send a 12x12 grid. For c ultra-fine mesh grids (finer than 0.04 deg, or 1/25 deg), c we expand to 12 in order to sample a few more points c around each grid point. if ((dx+dy)/2. > 0.04) then maxvgrid = 8 else maxvgrid = 12 endif rads = rads_vmag; re = retrk_vmag; ri = ritrk_vmag re = (float(maxvgrid)/4) * ((dx+dy)/2. * dtk) ! Basically, this c sets re equal to half the distance from the gridpoint c in question to the farthest point that will be c sampled when the (maxvgrid x maxvgrid) grid is passed c on to subroutine barnes. Thus, just ignore the c parameter retrk_vmag, and use this instead. else if ((dx+dy)/2. < 1.26 .and. (dx+dy)/2. >= 0.40) then rads = rads_most; re = retrk_most; ri = ritrk_most else if ((dx+dy)/2. < 0.40 .and. (dx+dy)/2. >= 0.10) then rads = rads_fine; re = retrk_most; ri = ritrk_most else if ((dx+dy)/2. < 0.10) then rads = rads_hres; re = retrk_hres; ri = ritrk_most else rads = rads_coarse; re = retrk_coarse; ri = ritrk_coarse endif if ( verb .ge. 3 ) then print *,' ' print *,'At beg of find_maxmin, rads= ',rads,' re= ',re & ,' ri= ',ri,' cparm= ',cparm,' dx= ',dx,' dy= ',dy endif dell = (dx+dy)/2. npts = rads/(dtk*dell) fmax = -1.0e+12; fmin = 1.0e+12 ctlon = 0.0; ctlat = 0.0 if (npts == 0) npts = 1 c For the barnes analysis, we will want to speed things up for c finer resolution grids. We can do this by skipping some of c the points in the barnes analysis. if (dell > 0.20) then bskip1 = 2 bskip2 = 1 else if (dell > 0.10 .and. dell <= 0.20) then bskip1 = 4 bskip2 = 2 else if (dell > 0.05 .and. dell <= 0.10) then bskip1 = 6 bskip2 = 3 else if (dell > 0.03 .and. dell <= 0.05) then bskip1 = 10 bskip2 = 5 else if (dell <= 0.03) then bskip1 = 15 bskip2 = 5 endif if (cparm == 'vmag') then bskip1 = 1 bskip2 = 1 endif c If input parm is vmag, we've already done the minimizing by c interpolating to the fine mesh grid, so we'll simply send the c bounds that were input to this subroutine to barnes c as boundaries for the array to search. For all other parms, c however, no minimizing has been done yet, so we need to call c get_ij_bounds to set the boundaries for a much smaller grid that c surrounds the storm (as opposed to having subroutine barnes c search the entire global grid). if (cparm == 'vmag') then if ( verb .ge. 3 ) then print *,'In find_maxmin, jmax= ',jmax,' imax= ',imax endif ibeg=1; jbeg=1; iend=imax; jend=jmax vmag_latmax = rlatv(1) ! N-most lat of vmag subgrid vmag_latmin = rlatv(jmax) ! S-most lat of vmag subgrid vmag_lonmin = rlonv(1) ! W-most lon of vmag subgrid vmag_lonmax = rlonv(imax) ! E-most lon of vmag subgrid if ( verb .ge. 3 ) then write (6,44) vmag_latmax,vmag_lonmin,360.-vmag_lonmin & ,imax,jmax write (6,46) vmag_latmin,vmag_lonmax,360.-vmag_lonmax endif 44 format (' vmag_latmax= ',f8.3,' vmag_lonmin= ',f8.3 & ,'E (',f8.3,'W) imax= ',i4,' jmax= ',i4) 46 format (' vmag_latmin= ',f8.3,' vmag_lonmax= ',f8.3 & ,'E (',f8.3,'W)') if (vmag_lonmin > 330. .and. vmag_lonmax < 30.) then if ( verb .ge. 3 ) then print *,' ' print *,'!!! WARNING: For a case of find_maxmin, our vmag' print *,'!!! subgrid is straddling the GM. The code should' print *,'!!! be able to handle this, but if strange errors' print *,'!!! are occurring, check into the code either here' print *,'!!! in find_maxmin or get_uv_ctr.' print *,' ' endif endif npts = ceiling(rads/(dtk*dell)) else call get_ij_bounds (npts,0,ri,imax,jmax,dx,dy & ,grid_maxlat,grid_minlat,grid_maxlon,grid_minlon & ,guesslon,guesslat & ,trkrinfo,ilonfix,jlatfix,ibeg,jbeg,iend,jend,igiret) if (igiret /= 0) then if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in find_maxmin from call to ' print *,'!!! get_ij_bounds, stopping processing for' print *,'!!! storm number ',ist endif ifmret = 92 return endif endif c c --------------------------------------------------------------- c if ( verb .ge. 3 ) then print *,' ' write (6,39) guesslon,360.-guesslon,guesslat 39 format (' guesslon= ',f8.3,'E (',f8.3,'W) guesslat= ',f8.3) if (cparm == 'vmag') then print *,'ilonfix= (unused) jlatfix= (unused)' & ,' npts= ',npts print *,'ilonfix and jlatfix are meaningless for computing' print *,'vmag, so ignore the large values you see for them.' else print *,'ilonfix= ',ilonfix,' jlatfix= ',jlatfix & ,' npts= ',npts endif print *,'ibeg= ',ibeg,' jbeg= ',jbeg,' imax= ',imax print *,'iend= ',iend,' jend= ',jend,' jmax= ',jmax endif call date_and_time (big_ben(1),big_ben(2),big_ben(3) & ,date_time) if ( verb .ge. 3 ) then write (6,31) date_time(5),date_time(6),date_time(7) 31 format (1x,'TIMING: find_maxmin 1 ',i2.2,':',i2.2,':',i2.2) endif ibct=0 ibarnes_loopct = 0 if (grid_minlon > 330. .and. grid_maxlon < 30.) then ! Our grid is straddling over the GM. This can happen either ! with a global grid or with a regional grid. How can it happen ! for a global grid? Well, for the case in which this routine ! is called from subroutine get_uv_center, where a smaller ! subgrid of data is passed in, and that smaller subgrid may ! straddle the GM. Anyway, we need a workaround. ! This workaround will put the minimum longitude ! in terms of a negative number, e.g., as opposed to being say, ! 354, it will be -6. You can then leave the grid_maxlon as is. temp_grid_minlon = grid_minlon - 360. if (guesslon > 330.) then ! If our grid is straddling the GM and we have adjusted the ! grid_minlon to be a negative number, then we also need to ! check on the guesslon and adjust it if it is also to west ! of the GM. temp_guesslon = guesslon - 360. else temp_guesslon = guesslon endif else temp_grid_minlon = grid_minlon temp_guesslon = guesslon endif jix = 0 if (cmodel_type == 'regional') then grid_buffer = 0.30 else grid_buffer = 0.0 endif jloop: do j=-npts,npts,bskip1 jix = jix + 1 rlatt = guesslat + dell*float(j) iix = 0 c vlat(jix) = rlatt iloop: do i=-npts,npts,bskip1 iix = iix + 1 rlont = temp_guesslon + dell*float(i) c if (cparm == 'vmag') then c print *,' ' c print '(a16,i6,a4,i6,2(a8,f8.3),a12,f8.3)' c & ,'in find_max, i= ',i c & ,' j= ',j,' rlatt= ',rlatt,' rlont= ',rlont c & ,' 360-rlont= ',360.-rlont c endif c If any points in the search grid would extend beyond the grid c boundaries, then check and see if this is global grid. If it c is, and the extension occurred in the i-direction, then adjust c the longitude to allow for grid wrapping. If it is a regional c grid, then just cycle the iloop. In previous versions of the c tracker, we would exit with an error message, but doing it c this way allows us to continue tracking some systems that may c be close to the grid boundary. Also, remember to factor in c the grid_buffer discussed in the doc block above for this c subroutine. if (rlont >= (grid_maxlon + dx - grid_buffer)) then if (trkrinfo%gridtype == 'global') then if (cparm == 'vmag') then cycle iloop ! We are off the small vmag subgrid else rlont = rlont - 360. ! We just GM-wrapped for the full, ! regular, global grid endif else cycle iloop endif endif if (rlont < (temp_grid_minlon + grid_buffer)) then if (trkrinfo%gridtype == 'global') then if (cparm == 'vmag') then cycle iloop ! We are off the small vmag subgrid else rlont = rlont + 360. ! We just GM-wrapped for the full, ! regular, global grid endif else cycle iloop endif endif if (rlatt > (grid_maxlat - grid_buffer) .or. & rlatt < (grid_minlat + grid_buffer)) then cycle iloop endif c Make sure that the point being investigated here as a c potential center has valid data at that point. That is, for c some hires regional grids that have been rotated/converted c from a non-latlon grid to a latlon grid, there can be c locations within the (i,j) space that do not have valid data c at them. It makes no sense to consider a point such as this c as a potential center. c There is another simpler case here that we are watching out c for. This is simply the case, again for model data where we c only have the innermost nest. Depending on what we choose c for the variable "rads" above, with the way that "npts" is c defined for these iloops and jloops that we're in, we may be c searching over points that are simply well off the grid. c Therefore, it is critical to run through this c check_valid_point subroutine to make sure that we're not c going to inadvertantly be performing an analysis at one of c these "off-grid" points. So.... if the return code from c check_valid_point comes back non-zero, simply cycle iloop c and go to the next point. call check_valid_point (imax,jmax,dx,dy,fxy,maxmin,valid_pt & ,rlont,rlatt,grid_maxlat,grid_minlat,grid_maxlon & ,temp_grid_minlon,trkrinfo,icvpret) if (icvpret /= 0) then if ( verb .ge. 1 ) then print *,'!!! NOT A VALID PT: icvpret= ',icvpret endif cycle iloop endif call calcdist(rlont,rlatt,temp_guesslon,guesslat,dist,degrees) if (dist .gt. rads) cycle iloop if (cparm == 'vmag') then c This next bit of code gets the ij coordinates for an 8x8 c box around the current point under consideration. These ij c coordinates are sent to barnes so that barnes only loops c 64 times, as opposed to nearly 10,000 if the whole 97x97 c array were sent. So, fix rlatt to the grid point just c northward of rlatt and fix rlont to the grid point just c eastward of rlont. Note that this makes for a modified c barnes analysis in that we're sort of specifying ahead of c time exactly which grid points will be included and we'll c be excluding some points that would be near the periphery c of each (rlont,rlatt)'s range, but as long as we're consis- c tent and do it this way for each point, it's well worth the c trade-off in cpu time. Parameter maxvgrid determines what c size array to send to barnes (maxvgrid=8 means 8x8) jvlatfix = int((vmag_latmax - rlatt)/dy + 1.) ivlonfix = int((rlont - temp_grid_minlon)/dx + 2.) c ivlonfix = int((rlont - vmag_lonmin)/dx + 2.) ibeg = ivlonfix - (maxvgrid/2) iend = ivlonfix + (maxvgrid/2 - 1) jbeg = jvlatfix - (maxvgrid/2 - 1) jend = jvlatfix + (maxvgrid/2) if (ibeg < 1 .or. jbeg < 1 .or. & iend > imax .or. jend > jmax) then ! DO NOT quit if we find a boundary outside the grid ! bounds. Rather, just set the J violating bound(s) to ! the min or max limit, and for I bounds, allow the ! program to continue down to subsequent code below, ! provided it's a global grid. c print *,'!!! ' c print *,'!!! Before vmag adjustments, boundaries are: ' c print *,'!!! rlont= ',rlont,' rlatt= ',rlatt,' dx= ',dx c print *,'!!! temp_grid_minlon= ',temp_grid_minlon c print *,'!!! vmag_latmax= ',vmag_latmax c print *,'!!! ivlonfix = ',ivlonfix,' jvlatfix = ',jvlatfix c print *,'!!! ibeg= ',ibeg,' iend= ',iend,' imax= ',imax c print *,'!!! jbeg= ',jbeg,' jend= ',jend,' jmax= ',jmax if (ibeg < 1) then if (trkrinfo%gridtype == 'global') then continue ! If wrapping past GM, there is code below ! in this find_maxmin routine that can ! modify the indices appropriately. So... ! do nothing here. else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: In find_maxmin, the ' print *,'!!! user-requested western boundary' print *,'!!! is beyond the western bounds of ' print *,'!!! the vmag subgrid for this regional ' print *,'!!! grid. ' print *,'!!! ' print *,'!!! imax of regional grid = ',imax print *,'!!! ivlonfix = ',ivlonfix,' ibeg= ',ibeg print *,'!!! ' print *,'!!! Vmag will not be computed for' print *,'!!! this time.' print *,' ' endif ifmret = 99 return endif endif if (iend > imax) then if (trkrinfo%gridtype == 'global') then continue ! If wrapping past GM, there is code below ! in this find_maxmin routine that can ! modify the indices appropriately. So... ! do nothing here. else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: In find_maxmin, the ' print *,'!!! user-requested eastern boundary' print *,'!!! is beyond the eastern bounds of ' print *,'!!! the vmag subgrid for this regional ' print *,'!!! grid. ' print *,'!!! ' print *,'!!! imax of regional grid = ',imax print *,'!!! ivlonfix = ',ivlonfix,' iend= ',iend print *,'!!! ' print *,'!!! Vmag will not be computed for ' print *,'!!! this time.' print *,' ' endif ifmret = 99 return endif endif if (jbeg < 1) jbeg = 1 if (jend > jmax) jend = jmax if ( verb .ge. 3 ) then print *,'!!! ' print *,'!!! *AFTER* vmag adjustments, boundaries are: ' print *,'!!! ibeg= ',ibeg,' iend= ',iend,' imax= ',imax print *,'!!! jbeg= ',jbeg,' jend= ',jend,' jmax= ',jmax endif endif endif if (cparm == 'vmag') then ri = re * 3 c print '(a36,f10.4,a6,f10.4)' c & ,' + before call to vmag barnes, re= ',re,' ri= ',ri endif ibct = ibct + 1 call barnes(rlont,rlatt,rlonv,rlatv,imax,jmax,ibeg,jbeg & ,iend,jend,fxy,valid_pt,bskip1,re,ri,ftemp,icount,'tracker' & ,trkrinfo,iret) ibarnes_loopct = ibarnes_loopct + icount if (iret /= 0) then if ( verb .ge. 1 ) then print *,' ' print *,'!!! Non-zero RCC from barnes...' print *,'!!! Exiting find_maxmin' endif compflag = .FALSE. ifmret = iret return endif if (maxmin == 'max') then if (ftemp > fmax) then fmax = ftemp ctlon = rlont ctlat = rlatt endif else if (ftemp < fmin) then fmin = ftemp ctlon = rlont ctlat = rlatt endif endif enddo iloop enddo jloop if ( verb .ge. 3 ) then print *,' ' print *,'After 1st findmax loop, # calls to barnes = ',ibct print *,'Total # of barnes loop iterations = ',ibarnes_loopct endif c 55 format ('i= ',i3,' j= ',i3,' rln= ',f7.3,' rlt= ',f7.3 & ,' barnval= ',f11.5) 56 format ('k= ',i3,' i= ',i3,' j= ',i3,' rln= ',f7.3,' rlt= ' & ,f7.3,' barnval= ',f11.5) if (ctlon < 0.) then ! We have grid-wrapped to find the ctlon, which was found to be ! < 0, so for reporting purposes and for the start of the next ! loop, set ctlon to positive degress east. ctlon = ctlon + 360. endif if (cparm == 'zeta') then if ( verb .ge. 3 ) then print *,'!!! Zeta check, fmax= ',fmax,' fmin= ',fmin write (6,61) 360.-ctlon,ctlat,fmax*100000.,fmin*100000. endif else if ( verb .ge. 3 ) then write (6,63) 360.-ctlon,ctlat,fmax,fmin endif endif 61 format (' After first run, ctlon= ',f8.3,'W ctlat= ',f8.3 & ,' fmax (x10e5) = ',e16.3,' fmin (x10e5) = ',e16.3) 63 format (' After first run, ctlon= ',f8.3,'W ctlat= ',f8.3 & ,' fmax = ',e16.3,' fmin = ',e16.3) 111 format (i2,' rlont= ',f7.2,'W rlatt= ',f7.2,' zeta= ',f13.8) c Through interpolation, the grid for vmag has already been c minimized considerably, we don't need to go through the 2nd part c of this subroutine, which halves the grid spacing. if (nhalf < 1 .or. cparm == 'vmag') then if (maxmin == 'max') then xval = fmax else xval = fmin endif return endif c If on our first pass through, we were dealing with a regional grid c that straddled the GM, then it becomes (for now) too much of a c coding hassle to deal with in the rest of this routine (i.e., in c all the nhalf iterations), so we will just go with the first run c through for the center fix and exit the routine. if (grid_minlon > 330. .and. grid_maxlon < 30.) then if (maxmin == 'max') then xval = fmax else xval = fmin endif return endif c ------------------------------------------------------------- c If the grid spacing is c fine enough (I've chosen 0.2-deg as a min threshold), there is c no need to halve the grid more than 3 times, as halving a c 0.2-deg grid 3 times gives a resolution of 0.025-deg (2.7 km), c or a max error in the position estimate of 2.7/2 = 1.35 km. if ((dx+dy)/2. <= 0.2) then if ((dx+dy)/2. <= 0.05) then nhalf = 1 else nhalf = 2 endif endif c --------------------------------------------------------------- c --------------------------------------------------------------- c Halve the grid spacing to refine the location and value of the c max/min value, but restrict the area of the new search grid. ctpm npts = 3 npts = npts/2 npts = max(npts,1) c ------------------------------------------------------------- c First, recalculate the i and j beginning and ending points to c be used in the barnes analysis subroutine. Only c do this once for this grid-refinement (even though the grid is c redefined 3 times in this subroutine), but make sure to have the c possible search grid be big enough to allow the possibility of c the grid shifting way right or way left each time through the c loop (get_ij_bounds takes care of this). call get_ij_bounds (npts,nhalf,ri,imax,jmax,dx,dy & ,grid_maxlat,grid_minlat,grid_maxlon,grid_minlon & ,ctlon,ctlat,trkrinfo & ,ilonfix,jlatfix,ibeg,jbeg,iend,jend,igiret) if (igiret /= 0) then if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in find_maxmin from call to get_ij_bounds' print *,'!!! just before nhalf loop. Stopping processing' print *,'!!! for storm number ',ist endif ifmret = 92 return endif c -------------------------------------------------------------- c Now do the actual searching for the max/min value if ( verb .ge. 3 ) then print *,' ' endif if ((dx+dy)/2. <= 1.25 .and. ri >= 300 .and. re >= 150) then retmp = re ritmp = ri re = re * 0.5 ri = ri * 0.5 if ( verb .ge. 3 ) then print *,'After first pass through barnes, re has been reduced' print *,'from ',retmp,' to ',re,', and ri has been reduced ' print *,'from ',ritmp,' to ',ri endif else if ( verb .ge. 3 ) then print *,'After first pass through barnes, re and ri have NOT ' print *,'been changed. re = ',re,' ri = ',ri endif endif ibct=0 ibarnes_loopct = 0 do k=1,nhalf call date_and_time (big_ben(1),big_ben(2),big_ben(3) & ,date_time) if ( verb .ge. 3 ) then write (6,32) k,date_time(5),date_time(6),date_time(7) 32 format (1x,'TIMING: find_maxmin kloop, k= ',i2,' ',i2.2,':' & ,i2.2,':',i2.2) endif dell = 0.5*dell tlon = ctlon tlat = ctlat fmax = -1.0e+15; fmin = 1.0e+15 iskip = bskip2 if ( verb .ge. 3 ) then print *,' ' print *,'find_maxmin nhalf loop, cparm= ',cparm,' k= ',k write (6,161) tlon,360.-tlon,tlat print *,'ilonfix= ',ilonfix,' jlatfix= ',jlatfix & ,' npts= ',npts print *,'ibeg= ',ibeg,' jbeg= ',jbeg,' imax= ',imax print *,'iend= ',iend,' jend= ',jend,' jmax= ',jmax print *,'nhalf= ',nhalf,' iskip= ',iskip endif jloop2: do j=-npts,npts,iskip rlatt = tlat + dell*float(j) iloop2: do i=-npts,npts,iskip rlont = tlon + dell*float(i) if (rlont >= (grid_maxlon + dx - grid_buffer)) then if (trkrinfo%gridtype == 'global') then rlont = rlont - 360. else cycle iloop2 endif endif if (rlont < (grid_minlon + grid_buffer)) then if (trkrinfo%gridtype == 'global') then rlont = rlont + 360. else cycle iloop2 endif endif if (rlatt > (grid_maxlat - grid_buffer) .or. & rlatt < (grid_minlat + grid_buffer) .or. & rlont >= (grid_maxlon + dx - grid_buffer) .or. & rlont < (grid_minlon + grid_buffer)) then cycle iloop2 endif c Again, check and make sure that the lat/lon point in c question here has valid data (see the explanation further c up in this subroutine inside iloop). call check_valid_point (imax,jmax,dx,dy,fxy,maxmin,valid_pt & ,rlont,rlatt,grid_maxlat,grid_minlat,grid_maxlon & ,grid_minlon,trkrinfo,icvpret) if (icvpret /= 0) then cycle iloop2 endif ibct = ibct + 1 call barnes(rlont,rlatt,rlonv,rlatv,imax,jmax,ibeg,jbeg & ,iend,jend,fxy,valid_pt,iskip,re,ri,ftemp,icount,'tracker' & ,trkrinfo,iret) ibarnes_loopct = ibarnes_loopct + icount if (iret /= 0) then if ( verb .ge. 1 ) then print *,' ' print *,'!!! Non-zero RCC from barnes, k= ',k print *,'!!! Exiting find_maxmin' endif compflag = .FALSE. ifmret = iret return endif if (maxmin == 'max') then if (ftemp > fmax) then fmax = ftemp ctlon = rlont ctlat = rlatt endif else if (ftemp < fmin) then fmin = ftemp ctlon = rlont ctlat = rlatt endif endif enddo iloop2 enddo jloop2 if ( verb .ge. 3 ) then if (cparm == 'zeta') then write (6,71) k,360.-ctlon,ctlat,fmax*100000.,fmin*100000. else write (6,73) k,360.-ctlon,ctlat,fmax,fmin endif endif enddo 71 format (' nhalf findmax, k= ',i2,' ctlon= ',f8.3,'W ctlat= ' & ,f8.3,' fmax (x10e5) = ',e16.3,' fmin (x10e5) = ',e16.3) 73 format (' nhalf findmax, k= ',i2,' ctlon= ',f8.3,'W ctlat= ' & ,f8.3,' fmax = ',e16.3,' fmin = ',e16.3) 161 format (' guesslon= ',f8.3,'E (',f8.3,'W) guesslat= ',f8.3) if ( verb .ge. 3 ) then print *,' ' print *,'ppp after 2nd findmax loop, # calls to barnes = ' & ,ibct print *,'ppp Total # of barnes loop iterations = ' & ,ibarnes_loopct endif if (maxmin == 'max') then xval = fmax else xval = fmin endif c return end c c---------------------------------------------------------------------- c c---------------------------------------------------------------------- subroutine barnes(flon,flat,rlon,rlat,iimax,jjmax,iibeg,jjbeg & ,iiend,jjend,fxy,defined_pt,bskip,re,ri,favg,icount,ctype & ,trkrinfo,iret) c c ABSTRACT: This routine performs a single-pass barnes anaylsis c of fxy at the point (flon,flat). The e-folding radius (km) c and influence radius (km) are re and ri, respectively. c c NOTE: The input grid that is searched in this subroutine is most c likely NOT the model's full, original grid. Instead, a smaller c subgrid of the original grid is searched. The upper left and c lower right grid point indices are passed into this subroutine c (iibeg, jjbeg, iiend, jjend) for this subgrid. These indices are c determined in the subroutine get_ij_bounds, and the purpose of c doing it this way is to limit the number of points for which the c subroutine has to calculate distances (for a global 1 deg grid, c the number of loop iterations is reduced from 65160 to somewhere c around 600). c c NOTE: This subroutine will immediately exit with a non-zero c return code if it tries to access a grid point that does not have c valid data. This would happen in the case of a regional grid, if c you try to access a point near the edge of the grid (remember that c because of the interpolation for the regional grids, there will be c areas around the edges that have no valid data). c c INPUT: c flon Lon value for center point about which barnes anl is done c flat Lat value for center point about which barnes anl is done c rlon Array of lon values for each grid point c rlat Array of lat values for each grid point c iimax Max number of pts in x-direction on input grid c jjmax Max number of pts in y-direction on input grid c iibeg i index for grid point to start barnes anlysis (upp left) c jjbeg j index for grid point to start barnes anlysis (upp left) c iiend i index for last grid point in barnes anlysis (low right) c jjend j index for last grid point in barnes anlysis (low right) c fxy Real array of data on which to perform barnes analysis c defined_pt Logical; bitmap array used for regional grids c bskip integer to indicate number of grid points to skip during c a barnes loop, in order to speed processing c re input e-folding radius for barnes analysis c ri input influence radius for searching for min/max c ctype character that lets subroutine know if this is a search c for the next position for the purposes of tc vitals or c for general tracking. In the case of vitals, in c this barnes subroutine we are more lax and allow the c routine to keep searching even if we are close to the c grid boundary. In a general tracking search, if we hit c the grid boundary even just once, we exit. c trkrinfo derived type detailing user-specified grid info c c OUTPUT: c favg Average value about the point (flon,flat) c iret Return code from this subroutine c USE trkrparms USE verbose_output type (trackstuff) trkrinfo real fxy(iimax,jjmax), rlon(iimax), rlat(jjmax) real degrees integer bskip logical(1) defined_pt(iimax,jjmax) character(*) ctype c -------------------------- res = re*re wts = 0.0 favg = 0.0 icount = 0 do jix=jjbeg,jjend,bskip do iix=iibeg,iiend,bskip i = iix j = jix if (i < 1) then if (trkrinfo%gridtype == 'global') then i = iix + iimax else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: i < 1 in subroutine barnes for' print *,'!!! a non-global grid. STOPPING....' print *,'!!! i= ',i print *,' ' endif stop 97 endif endif if (i > iimax) then if (trkrinfo%gridtype == 'global') then i = iix - iimax else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: i > imax in subroutine barnes for' print *,'!!! a non-global grid. STOPPING....' print *,'!!! i= ',i,' imax= ',iimax print *,' ' endif stop 97 endif endif icount = icount + 1 call calcdist(flon,flat,rlon(i),rlat(j),dist,degrees) if (dist .gt. ri) cycle if (defined_pt(i,j)) then if (fxy(i,j) >-999.01 .and. fxy(i,j) <-998.99) then ! This is a patch. Even though this (i,j) is a valid ! point, its zeta value has been set to -999 because a ! neighboring point in subroutine rvcal was found ! to be out of the grid boundaries. cycle endif wt = exp(-1.0*dist*dist/res) wts = wts + wt favg = favg + wt*fxy(i,j) else if (ctype == 'vitals') then continue else carw print *,' ' carw print *,'!!! UNDEFINED PT OUTSIDE OF GRID IN BARNES....' carw print *,'!!! i= ',i,' j= ',j carw print *,'!!! flon= ',flon,' flat= ',flat carw print *,'!!! rlon= ',rlon(i),' rlat= ',rlat(j) carw print *,'!!! re= ',re,' ri= ',ri carw print *,'!!! EXITING BARNES....' carw print *,' ' carw iret = 95 carw return endif endif enddo enddo if (wts > 1.0E-5) then favg = favg/wts else favg = 0.0 endif iret = 0 c return end c c---------------------------------------------------------------------- c c---------------------------------------------------------------------- subroutine get_ij_bounds (npts,nhalf,ri,imax,jmax,dx,dy & ,rglatmax,rglatmin,rglonmax,rglonmin,geslon,geslat & ,trkrinfo,ilonfix,jlatfix,ibeg,jbeg,iend,jend,igiret) c c ----------------------------------------------------------- c ABSTRACT: This subroutine figures out, based on ri, dx and dy and c the guess latitude and longitude positions, the farthest reaching c grid points that are searchable by an analysis subroutine. The c purpose is to return indices for a subgrid that is much smaller c than the original, full grid. This smaller subgrid can then be c passed to a subsequent analysis or interpolation subroutine, and c work can be done on this smaller array. This can help save time, c especially in the barnes analysis subroutine, as work will only c be done on, say, a 20 x 20 array (400 pts) instead of on a c 360 x 181 array (65160 pts). It's crucial, however, to make sure c that the ibeg, jbeg, iend and jend are extended far enough out to c fully encompass any search that would be done. Below is a c diagram showing the different grids.... c c Full Global or Regional Model Grid (Grid F) -----------> c ---------------------------------------------------------------- c | | (ibeg,jbeg) | c | | x = ij position that the | (Grid R) | c | | geslat/geslon is fixed to. ._______________. | c | | | | | c | | Even though only the points | (Grid B) | | c | | within Grid B will be checked | . . . . k | | c v | later on for a max/min (in the | . . . . . | | c | case of a subsequent call to | . . x . e | | c | find_maxmin), the barnes anal- | . . . . . | | c | ysis will include all pts sur- | . . . . . | | c | rounding these Grid B points | | | c | that are within a radius of ri. ._______________. | c | So in the case of pt. k, that ri | c | radius may extend all the way to the Grid R | | c | boundary, thus we need to include those (iend,jend) | c | points within our ibeg-jbeg-iend-jend bounds. | c | | c ---------------------------------------------------------------- c c Remember that the grids we deal with start north and increase c south, so the northernmost latitude on the input grid will have c a j index of 1. c c INPUT: c npts Num pts from x to edge of max/min search grid (Grid B) c (i.e., You define the size of Grid B by the value of c npts that you pass into this subroutine). c nhalf Number of times the grid spacing will be halved c ri Radius of influence (for use in barnes analysis) c imax Number of points in x-direction on original grid c jmax Number of points in y-direction on original grid c dx Input grid spacing in i-direction on original grid c dy Input grid spacing in j-direction on original grid c rglatmax Value of northern-most latitude on original grid c rglatmin Value of southern-most latitude on original grid c rglonmax Value of eastern-most longitude on original grid c rglonmin Value of western-most longitude on original grid c geslat Value of latitude of guess position of storm c geslon Value of longitude of guess position of storm c c OUTPUT: c ilonfix i index on full, input grid that storm is fixed to c jlatfix j index on full, input grid that storm is fixed to c ibeg i index for top left of sub-array (Grid R) of input grid c iend i index for bot right of sub-array (Grid R) of input grid c jbeg j index for top left of sub-array (Grid R) of input grid c jend j index for bot right of sub-array (Grid R) of input grid c igiret Return code from this subroutine c USE trig_vals; USE trkrparms USE verbose_output type (trackstuff) trkrinfo real tmpangle c igiret = 0 c c -------------------------------------- c GET BEGINNING AND ENDING J POINTS.... c c (1) Calculate number of searchable, max/min pts, that is, the pts c from x to the edge of Grid B. c (2) Calculate number of pts beyond the last search point in Grid c B, but are within the bounds of Grid R and thus can be c included in the barnes analysis. c (3) Add (1) and (2) to get the max number of pts to subtract/add c to x to get jbeg and jend. if ( verb .ge. 3 ) then print *,' ' print *,'Beginning of get_ij_bounds...' print *,' geslat= ',geslat,' geslon= ',geslon print *,' ' endif c If nhalf > 0: This occurs in the case of a call from fmax, when c the grid spacing is halved nhalf times. In this case, we have to c do extra work to figure out the maximum possible grid point. For c this case: c jhlatpts = # of grid pts to last possible search pt (from x to c edge of Grid B in above diagram), plus a cushion. c jripts = # of searchable grid points within radius ri of last c possible search pt (num pts between edge of Grid B c and edge of Grid R in above diagram), plus a cushion c jbmaxlatpts = # of pts (in j direction) from x to the edge of c Grid R to include in this subgrid. c c If nhalf = 0: In this case, the grid spacing will not be reduced, c so the number of pts in j direction from x to the edge of Grid c B will be the input parameter npts, and just multiply it by 2, c and add 2 for a cushion to get jmaxlatpts. Typically, this sub c is called from find_maxmin, and in that sub, the first time that c this sub is called, nhalf will = 0. Then, after a first-shot c center is found, the grid spacing will be cut in order to rerun c barnes on a smaller grid, and that's when nhalf will be sent c here as 3. c if (nhalf > 0) then rdeg = 0.0 do i = 1,nhalf rdeg = rdeg + float(npts) * (1./(float(i)*2)) * (dx+dy)/2 enddo jhlatpts = ceiling(rdeg/dy) + 1 jripts = ceiling((ri + 1.)/(dtk*dx)) + 1 jbmaxlatpts = jhlatpts + jripts else jbmaxlatpts = npts * 2 + 2 endif c c c Roughly fix geslat to the grid point just poleward of geslat. c if ( verb .ge. 3 ) then print *,' ' print *,' +++ Near top of get_ij_bounds, ' print *,' +++ geslat= ',geslat,' geslon= ',geslon print *,' +++ rglatmax= ',rglatmax,' rglatmin= ',rglatmin print *,' +++ rglonmax= ',rglonmax,' rglonmin= ',rglonmin print *,' +++ imax= ',imax,' jmax= ',jmax print *,' +++ dx= ',dx,' dy= ',dy,' nhalf= ',nhalf print *,' +++ npts= ',npts if(nhalf>0) then print *,' +++ jhlatpts= ',jhlatpts,' jripts= ',jripts else print *,' +++ nhalf<=0 so jhlatpts and jripts unused' endif print *,' +++ jbmaxlatpts= ',jbmaxlatpts endif if (geslat >= 0.0) then jlatfix = int((rglatmax - geslat)/dy + 1.) else jlatfix = ceiling((rglatmax - geslat)/dy + 1.) endif if ( verb .ge. 3 ) then print *,' +++ jlatfix= ',jlatfix endif jbeg = jlatfix - jbmaxlatpts jend = jlatfix + jbmaxlatpts if (jbeg > jmax ) then if ( verb .ge. 1 ) then print *,'!!! ERROR in get_ij_bounds, jbeg > jmax' print *,'!!! jbeg = ',jbeg,' jmax= ',jmax endif igiret = igiret + 1 return endif if (jend < 1) then if ( verb .ge. 1 ) then print *,'!!! ERROR in get_ij_bounds, jend < 1, jend = ',jend endif igiret = igiret + 1 return endif if (jbeg < 1) jbeg = 1 if (jend > jmax) jend = jmax if ( verb .ge. 3 ) then print *,' +++ jbeg= ',jbeg,' jend= ',jend endif ! If using a global grid, avoid using the pole points, or else ! you'll get a cosfac = 0 and then a divide by zero!!! if (jend == jmax .and. rglatmin == -90.0) then jend = jmax - 2 endif if (jbeg == 1 .and. rglatmax == 90.0) then jbeg = 3 endif c ----------------------------------------- c NOW GET BEGINNING AND ENDING I POINTS.... c c Using the map factor (cos lat), figure out, based on ri, the c max distance beyond the last search point in x-direction (in c degrees) that could be searched at this guess latitude (geslat) c (i.e., in the diagram above, the max num pts from pt. e eastward c to the edge of Grid R). Calculate how many grid points that is, c add 2 to it for a cushion, & add the number of points (npts) c within the defined search grid (Grid B) to get ibmaxlonpts. c c April, 2007: A min statement was put on the calculation to c derive dlon, since with that cosine in there, the values of c of dlon could get pretty ridiculous as you approach the poles. c Also, the cosine factor (cosfac) used to be computed at the c most poleward latitude possible given the jend here. For c similar concerns with cosines near the poles, I've scrapped c this to instead compute the cosine factor at the input c guess latitude. - tpm cosfac = cos (geslat * dtr) tmpangle = cosfac * dtk dlon = min((ri /tmpangle ),20.0) c dlon = min((ri / (cosfac * dtk)),20.0) c if (nhalf > 0) then ihlonpts = ceiling(rdeg/dx) + 1 ibmaxlonpts = ihlonpts + ceiling(dlon/dx) + 2 else ibmaxlonpts = npts + ceiling(dlon/dx) + 2 endif if ( verb .ge. 3 ) then if(nhalf>0) then print *,' +++ rdeg= ',rdeg,' ri= ',ri,' cosfac= ',cosfac print *,' +++ dtr= ',dtr,' dtk= ',dtk,' dlon= ',dlon else print*,' +++ nhalf<=0 so rdeg,ri,cosfac,dtr,dtk,dlon unused' endif print *,' +++ ibmaxlonpts= ',ibmaxlonpts,' dx= ',dx,' dy= ',dy endif c Roughly fix geslon to the grid point just EASTward of geslon. ilonfix = int((geslon - rglonmin)/dx + 2.) ibeg = ilonfix - ibmaxlonpts iend = ilonfix + ibmaxlonpts if ( verb .ge. 3 ) then print *,' +++ (orig) ilonfix= ',ilonfix print *,' +++ (orig) ibeg= ',ibeg,' iend= ',iend print *,' +++ ' endif if (ibeg > imax) then if (trkrinfo%gridtype == 'global') then if ( verb .ge. 1 ) then print *,'+++ NOTE: in get_ij_bounds, ibeg > imax' print *,'+++ for a global grid; GM wrapping expected from' print *,'+++ calling routine. ibeg = ',ibeg,' imax= ',imax endif else if ( verb .ge. 1 ) then print *,'!!! ERROR in get_ij_bounds, ibeg > imax' print *,'!!! for a non-global grid' print *,'!!! ibeg = ',ibeg,' imax= ',imax endif igiret = igiret + 1 return endif endif if (iend > imax) then if (trkrinfo%gridtype == 'global') then if ( verb .ge. 3 ) then print *,'+++ NOTE: in get_ij_bounds, iend > imax' print *,'+++ for a global grid; GM wrapping expected from' print *,'+++ calling routine. iend = ',iend,' imax= ',imax endif else ! For a regional grid, just set iend to be imax iend = imax endif endif if (ibeg < 1) then if (trkrinfo%gridtype == 'global') then if ( verb .ge. 3 ) then print *,'+++ NOTE: in get_ij_bounds, ibeg < 1' print *,'+++ for a global grid; GM wrapping expected from' print *,'+++ calling routine. ibeg = ',ibeg,' imax= ',imax endif else ! For a regional grid, just set ibeg to be 1 ibeg = 1 endif endif if (iend < 1) then if (trkrinfo%gridtype == 'global') then if ( verb .ge. 3 ) then print *,'+++ NOTE: in get_ij_bounds, iend < 1' print *,'+++ for a global grid; GM wrapping expected from' print *,'+++ calling routine. iend = ',iend,' imax= ',imax endif else if ( verb .ge. 3 ) then print *,'!!! ERROR in get_ij_bounds, iend < 1' print *,'!!! for a non-global grid' print *,'!!! iend = ',iend,' imax= ',imax endif igiret = igiret + 1 return endif endif c return end c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine check_bounds (guesslon,guesslat,ist,ifh,trkrinfo & ,icbret) c c ABSTRACT: This subroutine checks to make sure that the requested c storm is in fact within the model's grid boundaries; c this is only a concern for the regional models. c USE def_vitals; USE grid_bounds; USE set_max_parms USE trkrparms USE verbose_output type (trackstuff) trkrinfo if (trkrinfo%gridtype == 'regional') then if (guesslon > glonmax .or. guesslon < glonmin .or. & guesslat > glatmax .or. guesslat < glatmin) then if ( verb .ge. 3 ) then print *,' ' print *,'!!! IN check_bounds, Storm is outside of grid' print *,'!!! Storm ID = ',storm(ist)%tcv_storm_id print *,'!!! Storm Name = ',storm(ist)%tcv_storm_name print *,'!!! ist= ',ist,' ifh= ',ifh print *,'!!! guess storm lon= ',guesslon print *,'!!! guess storm lat= ',guesslat endif icbret = 95 goto 125 else icbret = 0 endif endif ! We have encountered problems with global grids where we ! continue tracking almost the whole way to the pole. While ! that's nice to do that, it creates problems for array ! indices, especially in subroutine getradii. So we will cut ! our losses and eliminate tracking of storms within ! 5 degrees of the pole for global grids. if ((trkrinfo%type == 'midlat' .or. & trkrinfo%type == 'tcgen') .and. & trkrinfo%gridtype == 'global')then if (guesslat > 85.0 .or. guesslat < -85.0) then if ( verb .ge. 3 ) then print *,' ' print *,'!!! IN check_bounds, Storm is too close to the' print *,'!!! N or S Pole for global tracking.' print *,'!!! STOPPING TRACKING FOR THIS STORM DUE TO POLE' print *,'!!! Storm ID = ',storm(ist)%tcv_storm_id print *,'!!! Storm Name = ',storm(ist)%tcv_storm_name print *,'!!! ist= ',ist,' ifh= ',ifh print *,'!!! guess storm lon= ',guesslon print *,'!!! guess storm lat= ',guesslat endif icbret = 95 else icbret = 0 endif endif 125 continue c return end c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine calcdist(rlonb,rlatb,rlonc,rlatc,xdist,degrees) c c ABSTRACT: This subroutine computes the distance between two c lat/lon points by using spherical coordinates to c calculate the great circle distance between the points. c Figure out the angle (a) between pt.B and pt.C, c N. Pole then figure out how much of a % of a great c x circle distance that angle represents. c / \ c b/ \ cos(a) = (cos b)(cos c) + (sin b)(sin c)(cos A) c / \ c pt./<--A-->\c NOTE: The latitude arguments passed to the c B / \ subr are the actual lat vals, but in c \ the calculation we use 90-lat. c a \ c \pt. NOTE: You may get strange results if you: c C (1) use positive values for SH lats AND c you try computing distances across the c equator, or (2) use lon values of 0 to c -180 for WH lons AND you try computing c distances across the 180E meridian. c c NOTE: In the diagram above, (a) is the angle between pt. B and c pt. C (with pt. x as the vertex), and (A) is the difference in c longitude (in degrees, absolute value) between pt. B and pt. C. c c !!! NOTE !!! -- THE PARAMETER ecircum IS DEFINED (AS OF THE c ORIGINAL WRITING OF THIS SYSTEM) IN KM, NOT M, SO BE AWARE THAT c THE DISTANCE RETURNED FROM THIS SUBROUTINE IS ALSO IN KM. c USE trig_vals real degrees c if (rlatb < 0.0 .or. rlatc < 0.0) then pole = -90. else pole = 90. endif c distlatb = (pole - rlatb) * dtr distlatc = (pole - rlatc) * dtr difflon = abs( (rlonb - rlonc)*dtr ) c cosanga = ( cos(distlatb) * cos(distlatc) + & sin(distlatb) * sin(distlatc) * cos(difflon)) c This next check of cosanga is needed since I have had ACOS crash c when calculating the distance between 2 identical points (should c = 0), but the input for ACOS was just slightly over 1 c (e.g., 1.00000000007), due to (I'm guessing) rounding errors. if (cosanga > 1.0) then cosanga = 1.0 endif cPENG added bug fixed on 04/28/2016-------------------------- if (cosanga < -1.0) then cosanga = -1.0 endif cPENG added on 04/28/2016-------------------------- degrees = acos(cosanga) / dtr circ_fract = degrees / 360. xdist = circ_fract * ecircum c c NOTE: whether this subroutine returns the value of the distance c in km or m depends on the scale of the parameter ecircum. c At the original writing of this subroutine (7/97), ecircum c was given in km. c return end c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine subtract_cor (imax,jmax,dy,level) c c ABSTRACT: This subroutine subtracts out the coriolis parameter c from the vorticity values. It is needed because at the original c writing of this system, all of the forecast centers who included c vorticity included only absolute vorticity. c USE tracked_parms; USE trig_vals; USE grid_bounds implicit none integer :: i,j,imax,jmax,level real :: dy,coriolis,rlat c do j=1,jmax rlat = glatmax - ((j-1) * dy) coriolis = 2. * omega * sin(rlat*dtr) do i=1,imax zeta(i,j,level) = zeta(i,j,level) - coriolis enddo enddo c return end c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine get_grib_file_name (ifh,gfilename,ifilename) c ABSTRACT: This subroutine uses various input regarding the model c and forecast hour and generates the name of the input grib file c for this particular forecast hour. Remember that the lead time c is in minutes and that 5 spaces must be reserved for the lead c time (e.g., f00360). File name should be something that looks c like either, e.g., "gfdl.6thdeg.katrina12l.2005082818.f00720", c or "gfdl.6thdeg.2005082818.f00720" (the part in there with the c storm name & ID is optional). The grib index file name should c be exactly the same as the grib data file itself, but with the c character string ".ix" added onto the end of the name. c c NOTE: Array iftotalmins is brought in via module tracked_parms. c C INPUT: c ifh integer array index for current lead time c c OUTPUT: c gfilename GRIB file name c ifilename GRIB index file name USE gfilename_info; USE tracked_parms; USE atcf USE verbose_output implicit none character(*) gfilename,ifilename character cfmin*5,cymdh*10 integer ifh,nlen1,nlen2,nlen3,nlen4,nlen5 c Convert integer minutes to 5-position character, with c leading zeroes, and convert 10-digit integer date into c 10-position character. Then trim the various input variables c and combine all into the file name. write (cfmin,'(i5.5)') iftotalmins(ifh) write (cymdh,'(i10.10)') atcfymdh nlen1 = len_trim(gmodname) gfilename = trim(gmodname(1:nlen1)) nlen2 = len_trim(rundescr) gfilename = trim(gfilename(1:nlen1))//'.'//trim(rundescr(1:nlen2)) nlen3 = len_trim(atcfdescr) nlen4 = len_trim(gfilename) c If an extension to the name with the ATCF or storm name descriptor c was included, then add it to the name now. Otherwise, just add c the starting date and the lead time in minutes. if (nlen3 > 0) then gfilename = trim(gfilename(1:nlen4))//'.' & //trim(atcfdescr(1:nlen3))//'.'//cymdh//'.f'//cfmin else gfilename = trim(gfilename(1:nlen4))//'.'//cymdh//'.f'//cfmin endif c Create the name for the grib index file, which is just the name of c the grib file, with "ix" added to the end of it. nlen5 = len_trim(gfilename) ifilename = trim(gfilename(1:nlen5))//'.ix' if ( verb .ge. 3 ) then write (6,*) ' ' write (6,72) 'gfilename',gfilename write (6,72) 'ifilename',ifilename endif 72 format (1x,'In get_grib_file_name, file name for ',a9 & ,' is ',a120) c return end c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine getdata_grib (readflag,valid_pt,imax,jmax & ,ifh,need_to_flip_lats,need_to_flip_lons,inp & ,lugb,lugi,trkrinfo) c c ABSTRACT: This subroutine reads the input GRIB file for the c tracked parameters. It then calls subroutines to convert the c data from a 1-d array into a 2-d array if the read was successful. c c There are up to 9 fields that are read in that will be used to c locate the storm position. There are an additional 4 variables c (500 mb u- and v-components and 10 m u- and v- components) that c will not be used for tracking, but only for helping to estimate c the next first guess position (500 mb winds) and for estimating c the max near-surface wind speeds in the vicinity of the storm c (10 m winds). c c Fields read in are listed here. Numbers indicate positioning in c the readflag logical array: c c 1. 850 mb absolute vorticity c 2. 700 mb absolute vorticity c 3. 850 mb u-component c 4. 850 mb v-component c 5. 700 mb u-component c 6. 700 mb v-component c 7. 850 mb geopotential height c 8. 700 mb geopotential height c 9. MSLP c 10. 10-m u-component c 11. 10-m v-component c 12. 500 mb u-component c 13. 500 mb v-component c 14. 300-500 mb mean temperature (I jerry-rigged this by storing c the data as being at the 401 mb level.) c 15. 500 mb geopotential height c 16. 200 mb geopotential height c 17. Land-Sea mask -- This is for tcgen applications only, and c even there, it's optional. c c INPUT: c imax integer number of pts in i-direction on grid c jmax integer number of pts in j-direction on grid c ifh integer index for forecast hour c need_to_flip_lats logical flag read in from getgridinfo that c indicates if data needs flipped north to south c need_to_flip_lons logical flag read in from getgridinfo that c indicates if data needs flipped east to west c inp of a derived type, contains user-input info c lugb integer unit number of input grib file c lugi integer unit number of input grib index file c trkrinfo derived type that contains info on the type of c tracker run that we are performing. c c OUTPUT: c readflag logical array, indicates if a parm was read in c valid_pt logical array, indicates for each (i,j) if there is c valid data at the point (used for regional grids) USE tracked_parms; USE level_parms; USE inparms; USE phase USE verbose_output; USE params; USE grib_mod; USE trkrparms implicit none c type (trackstuff) trkrinfo type (datecard) inp type (gribfield) :: gfld,prevfld,holdgfld c integer, parameter :: jf=40000000 integer, parameter :: nreadparms=17 real, allocatable :: f(:) real :: dmin,dmax,firstval,lastval logical(1), allocatable :: lb(:) logical(1) valid_pt(imax,jmax),readflag(nreadparms) logical(1) :: need_to_flip_lats,need_to_flip_lons logical(1) file_open logical :: unpack=.true. logical :: open_grb=.false. character*1 :: lbrdflag character*8 :: chparm(nreadparms) CHARACTER(len=8) :: pabbrev character (len=10) big_ben(3) integer date_time(8) integer,dimension(200) :: jids,jpdt,jgdt integer :: listsec1(13), enable_timing integer, intent(in) :: imax,jmax integer igparm(nreadparms),iglev(nreadparms) integer iglevtyp(nreadparms) integer ig2_parm_cat(nreadparms),ig2_parm_num(nreadparms) integer ig2_lev_val(nreadparms),ig2_lev_typ(nreadparms) cPENG 04/18/2018 for CMC Det. and CMC ensemble data integer ig2_lev_11_cmc(nreadparms),ig2_lev_val_cmc(nreadparms) integer ig2_lev_11_cmcd(nreadparms),ig2_lev_val_cmcd(nreadparms) integer cpsig2_parm_cat(nlevs_cps),cpsig2_parm_num(nlevs_cps) c integer cpsig2_lev_typ(nlevs_cps),cpsig2_lev_val(nlevs_cps) cPENG------- integer cpsig2_lev_10(nlevs_cps) integer cpsig2_lev_11(nlevs_cps),cpsig2_lev_12(nlevs_cps) integer ec_igparm(nreadparms),ec_iglev(nreadparms) integer ec_iglevtyp(nreadparms) integer cpsgparm(nlevs_cps),cpsglev(nlevs_cps) integer cpsglevtyp(nlevs_cps) integer ec_cpsgparm(nlevs_cps) integer jpds(200),jgds(200),kpds(200),kgds(200) integer igvret,ifa,ila,ip,ifh,i,j,k,kj,iret,kf,lugb,lugi integer jskp,jdisc,np integer jpdtn,jgdtn,npoints,icount,ipack,krec integer pdt_4p0_vert_level,pdt_4p0_vtime integer :: listsec0(2)=(/0,2/) integer :: igds(5)=(/0,0,0,0,0/),previgds(5) integer :: idrstmpl(200) integer :: currlen=1000000 c lbrdflag = 'n' enable_timing=trkrinfo%enable_timing c The following data statements contain the parameters that will be c used to search the grib files. The first 9 parameters will all be c used to locate the storm position. The last 4 parameters (500 mb c u- and v-components and 10 m u- and v- components) will not be c used for tracking, but only for helping to estimate the next first c guess position (500 mb winds) and for estimating the max near- c surface wind speeds in the vicinity of the storm (10 m winds). c c ** NOTE: iglevtyp(12 & 13) and iglev(12 & 13) are initialized to c 0 just to satisfy the IBM xlf compiler, which barks about c there being too few initial values in the list when I c only had 11 values there -- even though the real c initialization for these variables is done just about c 10 lines below. c c ** NOTE: The new ECMWF hi-res data uses the ECMWF GRIB parameter c ID table, which has different values than the NCEP c table. Therefore, we needed to add the variables and c data values for ec_igparm, ec_iglevtyp and ec_iglev. c c July 2007: Read statements added for GP height for cyclone c phase space (CPS) algorithm. c data igparm /41,41,33,34,33,34,7,7,1,33,34,33,34,11,7,7,81/ data igparm /41,41,33,34,33,34,7,7,2,33,34,33,34,11,7,7,81/ data iglevtyp /100,100,100,100,100,100,100,100,102,0,0,100,100 & ,100,100,100,1/ data iglev /850,700,850,850,700,700,850,700,0,0,0,500,500,401 & ,500,200,0/ data cpsgparm /13*7/ data ec_cpsgparm /13*156/ data cpsglevtyp /13*100/ data cpsglev /900,850,800,750,700,650,600,550,500,450,400 & ,350,300/ data ec_igparm /999,999,131,132,131,132,156,156,151,165,166 & ,131,132,130,156,156,999/ data ec_iglevtyp /100,100,100,100,100,100,100,100,1,0,0,100,100 & ,100,100,100,999/ data ec_iglev /850,700,850,850,700,700,850,700,0,0,0,500,500 & ,401,500,200,999/ data chparm /'absv','absv','ugrid','vgrid','ugrid','vgrid' & ,'gphgt','gphgt','mslp','ugrid','vgrid','ugrid' & ,'vgrid','temp','gphgt','gphgt','lmask'/ data ig2_parm_cat /2,2,2,2,2,2,3,3,3,2,2,2,2,0,3,3,2/ data ig2_parm_num /10,10,2,3,2,3,5,5,1,2,3,2,3,0,5,5,8/ data ig2_lev_typ /100,100,100,100,100,100,100,100,101,103,103 & ,100,100,100,100,100,-9999/ data ig2_lev_val /850,700,850,850,700,700,850,700,0,10,10,500,500 & ,401,500,200,-9999/ cPENG 04/18/2018 for CMC Det. and CMC ensemble data data ig2_lev_11_cmc /-3,-4,-3,-3,-4,-4,-3,-4,0,0,0,-4,-4,0 & ,-4,-4,0/ data ig2_lev_val_cmc/85,7,85,85,7,7,85,7,0,10,10,5,5,40100 & ,5,2,-9999/ data ig2_lev_11_cmcd /-3,-4,-3,-3,-4,-4,-3,-4,0,0,0,-4,-4,0 & ,-4,-4,0/ data ig2_lev_val_cmcd /85,7,85,85,7,7,85,7,0,10,10,5,5,40100 & ,5,2,-9999/ data cpsig2_parm_cat /13*3/ data cpsig2_parm_num /13*5/ c data cpsig2_lev_typ /13*100/ c data cpsig2_lev_val /900,850,800,750,700,650,600,550,500,450,400 c & ,350,300/ cPENG---------------------------------- data cpsig2_lev_10 /13*100/ data cpsig2_lev_11 /13*0/ data cpsig2_lev_12 /90000,85000,80000,75000,70000,65000 & ,60000,55000,50000,45000,40000 & ,35000,30000/ c Model numbers used: (1) AVN, (2) MRF, (3) UKMET, (4) ECMWF, c (5) NGM, (6) Early Eta, (7) NAVGEM, (8) GDAS, c (10) NCEP Ensemble, (11) ECMWF Ensemble, c (13) SREF Ensemble, c (14) NCEP Ensemble (from ensstat mean fields), c (15) CMC, (16) CMC Ensemble, (17) HWRF, c (18) HWRF Ensemble, (19) HWRF-DAS (HDAS), c (20) NCEP Ensemble RELOCATION c (21) UKMET hi-res (from NHC) c (23) FNMOC Ensemble c (24) HWRF Basin-scale if (trkrinfo%gribver == 2) then c For GRIB2, we will check to see if the MSLP being searched for c is the standard MSLP (MSLP parm ID = 1) or if it is the c so-called "Eta" or "Membrane" MSLP reduction that is included c in the output for some models (like GFS and GDAS). Note that c for 10m winds, with GRIB2, so far with all of the GRIB2 model c data we've seen to this point, they all have the same IDs for c 10m winds for all models, so no need to break out by model c like we do for GRIB v1 in the else portion of this if statement. ig2_parm_num(9) = trkrinfo%g2_mslp_parm_id ! 1 = standard MSLP ! reduction, 192 = "Eta" or "Membrane" ! reduction used in GFS, GDAS and others. if ( verb .ge. 3 ) then print *,' ' print *,'Before GRIB2 read, MSLP ID = ig2_parm_num(9) = ' & ,ig2_parm_num(9) endif else c For GRIB1, do the same check as done just above in the IF part c of this IF statement, but note that we need to also check to c see what the GRIB1 parm IDs are for the sfc wind level type c and value. Most models list the level type as 105 (which means c height above the ground) and then a level value of 10. But c ECMWF and UKMET use a level type of 1 (which means ground or c water surface) and a level value of 0. igparm(9) = trkrinfo%g1_mslp_parm_id ! 102 = standard MSLP ! reduction, 130 = "Eta" or "Membrane" ! reduction used in GFS, GDAS and others. iglevtyp(10) = trkrinfo%g1_sfcwind_lev_typ ! 105 for most iglevtyp(11) = trkrinfo%g1_sfcwind_lev_typ ! 105 for most iglev(10) = trkrinfo%g1_sfcwind_lev_val ! 10 for most iglev(11) = trkrinfo%g1_sfcwind_lev_val ! 10 for most ec_iglevtyp(10) = trkrinfo%g1_sfcwind_lev_typ ! = 1 for ECMWF ec_iglevtyp(11) = trkrinfo%g1_sfcwind_lev_typ ! = 1 for ECMWF ec_iglev(10) = trkrinfo%g1_sfcwind_lev_val ! = 0 for ECMWF ec_iglev(11) = trkrinfo%g1_sfcwind_lev_val ! = 0 for ECMWF if ( verb .ge. 3 ) then print *,' ' print *,'Before GRIB1 read, MSLP ID = igparm(9) = ' & ,igparm(9) print *,'Before GRIB1 read, non-ECMWF sfcwind lev type = ' & ,iglevtyp(10) print *,'Before GRIB1 read, non-ECMWF sfcwind lev value = ' & ,iglev(10) print *,'Before GRIB1 read, ECMWF sfcwind lev type = ' & ,ec_iglevtyp(10) print *,'Before GRIB1 read, ECMWF sfcwind lev value = ' & ,ec_iglev(10) endif endif if ( verb .ge. 3 ) then print *,' ' print *,'NOTE: Program is now in subroutine getdata. A return' print *,'code (iret) not equal to zero indicates that ' print *,'subroutine getgb was unable to find the requested ' print *,'parameter. This could be simply because the parm is ' print *,'not included in the grib file (this is likely for ' print *,'ECMWF data, as they limit what they send us), or it ' print *,'could indicate a problem with the grib index file.' endif if (allocated(f)) deallocate(f) if (allocated(lb)) deallocate(lb) allocate (f(imax*jmax),stat=ifa) allocate (lb(imax*jmax),stat=ila) if (ifa /= 0 .or. ila /= 0) then print *,' ' print *,'!!! ERROR in getdata allocating f or lb array.' print *,'!!! ifa = ',ifa,' ila= ',ila print *,'!!! STOPPING EXECUTION' STOP 91 endif if (trkrinfo%gribver == 2) then ! Reading from a GRIB v2 file.... grib2_standard_parm_read_loop: do ip = 1,nreadparms if (ip == 17) then if (trkrinfo%use_land_mask == 'y' .or. & trkrinfo%use_land_mask == 'Y') then continue else if (verb .ge. 3) then print *,' ' print *,'The use_land_mask flag has not been set to ' print *,'y or Y, so we will not try to read it in... ' print *,' ' cycle grib2_standard_parm_read_loop endif endif endif ! ! --- Initialize Variables --- ! gfld%idsect => NULL() gfld%local => NULL() gfld%list_opt => NULL() gfld%igdtmpl => NULL() gfld%ipdtmpl => NULL() gfld%coord_list => NULL() gfld%idrtmpl => NULL() gfld%bmap => NULL() gfld%fld => NULL() if (ip == 17) then jdisc=1 ! hydrological products. At this point, used only ! for the land-sea mask. else jdisc=0 ! meteorological products endif jids=-9999 jpdtn=trkrinfo%g2_jpdtn ! 0 = analysis or forecast; ! 1 = ens fcst jgdtn=0 ! lat/lon grid jgdt=-9999 jpdt=-9999 npoints=0 icount=0 jskp=0 c Search for input parameter by production template 4.0. This c tave program is used primarily for temperature, but still we c will leave that as a variable and not-hard wire it in case we c choose to average something else in the future. ! We are looking for Temperature or GP Height here. This ! block of code, or even the smaller subset block of code that ! contains the JPDT(1) and JPDT(2) assignments, can of course ! be modified if this program is to be used for interpolating ! other variables.... ! Set defaults for JPDT, then override in array ! assignments below... JPDT(1:15)=(/-9999,-9999,-9999,-9999,-9999,-9999,-9999,-9999 & ,-9999,-9999,-9999,-9999,-9999,-9999,-9999/) JPDT(1) = ig2_parm_cat(ip) JPDT(2) = ig2_parm_num(ip) if (inp%lt_units == 'minutes') then JPDT(8) = 0 JPDT(9) = iftotalmins(ifh) else JPDT(8) = 1 JPDT(9) = ifhours(ifh) endif JPDT(10) = ig2_lev_typ(ip) cPENG 04/18/2018 CMC Det. and CMC ensemble data if (inp%model == 16 ) then JPDT(11) = ig2_lev_11_cmc(ip) JPDT(12) = ig2_lev_val_cmc(ip) elseif (inp%model == 15 ) then JPDT(11) = ig2_lev_11_cmcd(ip) JPDT(12) = ig2_lev_val_cmcd(ip) else JPDT(11) = 0 if (JPDT(10) == 100) then ! isobaric surface JPDT(12) = ig2_lev_val(ip) * 100 ! GRIB2 levels are in Pa else JPDT(12) = ig2_lev_val(ip) ! This is going to be either mslp & ! or 10m winds. endif endif if ( verb_g2 .ge. 1 ) then print *,'before getgb2 call, value of unpack = ',unpack endif inquire (unit=lugb, opened=file_open) if (file_open) then if (verb .ge. 3) then print *,'TEST b4 getgb2 getdata, unit lugb= ',lugb & ,' is OPEN' endif else if (verb .ge. 3) then print *,'TEST b4 getgb2 getdata, unit lugb= ',lugb & ,' is CLOSED' endif endif inquire (unit=lugi, opened=file_open) if (file_open) then if (verb .ge. 3) then print *,'TEST b4 getgb2 getdata, unit lugi= ',lugi & ,' is OPEN' endif else if (verb .ge. 3) then print *,'TEST b4 getgb2 getdata, unit lugi= ',lugi & ,' is CLOSED' endif endif if(enable_timing/=0) then call date_and_time (big_ben(1),big_ben(2),big_ben(3) & ,date_time) write (6,531) date_time(5),date_time(6),date_time(7) 531 format (1x,'TIMING: before getgb2-1',i2.2,':',i2.2,':',i2.2) endif call getgb2(lugb,lugi,jskp,jdisc,jids,jpdtn,jpdt,jgdtn,jgdt & ,unpack,krec,gfld,iret) if(enable_timing/=0) then call date_and_time (big_ben(1),big_ben(2),big_ben(3) & ,date_time) write (6,532) date_time(5),date_time(6),date_time(7) 532 format (1x,'TIMING: after getgb2-1',i2.2,':',i2.2,':',i2.2) endif if ( verb .ge. 3 ) then print *,'iret from getgb2 in getdata = ',iret endif if (verb_g2 .ge. 1) then print *,'after getgb2 call, value of unpacked = ' & ,gfld%unpacked print *,'after getgb2 call, gfld%ngrdpts = ',gfld%ngrdpts print *,'after getgb2 call, gfld%ibmap = ',gfld%ibmap endif if ( iret == 0) then if ( verb .ge. 3 ) then print *,'+++ Good Read: getgb2 found parm: ',chparm(ip) print *,'+++ at level = ',ig2_lev_val(ip) if (inp%lt_units == 'minutes') then print *,'+++ Forecast time = ',iftotalmins(ifh) & ,' minutes' else print *,'+++ Forecast time = ',ifhours(ifh) & ,' hours' endif endif c Determine packing information from GRIB2 file c The default packing is 40 JPEG 2000 ipack = 40 if (verb_g2 .ge. 1) then print *,' gfld%idrtnum = ', gfld%idrtnum endif ! Set DRT info ( packing info ) if ( gfld%idrtnum.eq.0 ) then ! Simple packing ipack = 0 elseif ( gfld%idrtnum.eq.2 ) then ! Complex packing ipack = 2 elseif ( gfld%idrtnum.eq.3 ) then ! Complex & spatial & ! packing ipack = 31 elseif ( gfld%idrtnum.eq.40.or.gfld%idrtnum.eq.15 ) then ! JPEG 2000 packing ipack = 40 elseif ( gfld%idrtnum.eq.41 ) then ! PNG packing ipack = 41 endif if ( verb_g2 .ge. 1 ) then print *,'After check of idrtnum, ipack= ',ipack print *,'Number of gridpts= gfld%ngrdpts= ',gfld%ngrdpts print *,'Number of elements= gfld%igdtlen= ',gfld%igdtlen print *,'GDT num= gfld%igdtnum= ',gfld%igdtnum endif kf = gfld%ngrdpts ! Number of gridpoints returned from read do np = 1,kf f(np) = gfld%fld(np) if (gfld%ibmap == 0) then lb(np) = gfld%bmap(np) else lb(np) = .true. endif enddo readflag(ip) = .TRUE. call bitmapchk(kf,lb,f,dmin,dmax) c Convert logical bitmap to 2-d array (only need to do this c once since using same model for all variables). if (lbrdflag .eq. 'n') then call conv1d2d_logic (imax,jmax,lb,valid_pt & ,need_to_flip_lats) lbrdflag = 'y' endif firstval=gfld%fld(1) lastval=gfld%fld(kf) if (verb_g2 .ge. 1) then print *,' ' print *,' SECTION 0: discipl= ',gfld%discipline & ,' gribver= ',gfld%version print *,' ' print *,' SECTION 1: ' do j = 1,gfld%idsectlen print *,' sect1, j= ',j,' gfld%idsect(j)= ' & ,gfld%idsect(j) enddo if ( associated(gfld%local).AND.gfld%locallen.gt.0) then print *,' ' print *,' SECTION 2: ',gfld%locallen,' bytes' else print *,' ' print *,' SECTION 2 DOES NOT EXIST IN THIS RECORD' endif print *,' ' print *,' SECTION 3: griddef= ',gfld%griddef print *,' ngrdpts= ',gfld%ngrdpts print *,' numoct_opt= ',gfld%numoct_opt print *,' interp_opt= ',gfld%interp_opt print *,' igdtnum= ',gfld%igdtnum print *,' igdtlen= ',gfld%igdtlen print *,' ' print '(a17,i3,a2)',' GRID TEMPLATE 3.',gfld%igdtnum,': ' do j=1,gfld%igdtlen print *,' j= ',j,' gfld%igdtmpl(j)= ',gfld%igdtmpl(j) enddo c Get parameter abbrev for record that was retrieved print *,' ' print *,' PDT num (gfld%ipdtnum) = ',gfld%ipdtnum print *,' ' print '(a20,i3,a2)',' PRODUCT TEMPLATE 4.',gfld%ipdtnum & ,': ' do j=1,gfld%ipdtlen print *,' sect 4 j= ',j,' gfld%ipdtmpl(j)= ' & ,gfld%ipdtmpl(j) enddo endif pdt_4p0_vtime = gfld%ipdtmpl(9) pdt_4p0_vert_level = gfld%ipdtmpl(12) pabbrev=param_get_abbrev(gfld%discipline,gfld%ipdtmpl(1) & ,gfld%ipdtmpl(2)) if (verb .ge. 3) then print *,' ' write (6,131) 131 format (' rec# param level byy bmm bdd bhh ' & ,'fhr npts firstval lastval minval ' & ,' maxval') print '(i5,3x,a8,2x,6i5,2x,i8,4g12.4)' & ,krec,pabbrev,pdt_4p0_vert_level,gfld%idsect(6) & ,gfld%idsect(7),gfld%idsect(8),gfld%idsect(9) & ,pdt_4p0_vtime,gfld%ngrdpts,firstval,lastval,dmin,dmax cPENG & ,krec,pabbrev,pdt_4p0_vert_level/100,gfld%idsect(6) endif select case (chparm(ip)) case ('absv') if (jpdt(12) == 85000 .or. jpdt(12) == 85) then call conv1d2d_real (imax,jmax,f,zeta(1,1,1) & ,need_to_flip_lats) else call conv1d2d_real (imax,jmax,f,zeta(1,1,2) & ,need_to_flip_lats) endif case ('ugrid') if (jpdt(12) == 85000 .or. jpdt(12) == 85) then call conv1d2d_real (imax,jmax,f,u(1,1,1) & ,need_to_flip_lats) else if (jpdt(12) == 70000 .or. jpdt(12) == 7) then call conv1d2d_real (imax,jmax,f,u(1,1,2) & ,need_to_flip_lats) else if (jpdt(12) == 50000 .or. jpdt(12) == 5) then call conv1d2d_real (imax,jmax,f,u(1,1,3) & ,need_to_flip_lats) else ! Near-surface data call conv1d2d_real (imax,jmax,f,u(1,1,4) & ,need_to_flip_lats) endif case ('vgrid') if (jpdt(12) == 85000 .or. jpdt(12) == 85) then call conv1d2d_real (imax,jmax,f,v(1,1,1) & ,need_to_flip_lats) else if (jpdt(12) == 70000 .or. jpdt(12) == 7) then call conv1d2d_real (imax,jmax,f,v(1,1,2) & ,need_to_flip_lats) else if (jpdt(12) == 50000 .or. jpdt(12) == 5) then call conv1d2d_real (imax,jmax,f,v(1,1,3) & ,need_to_flip_lats) else ! Near-surface data call conv1d2d_real (imax,jmax,f,v(1,1,4) & ,need_to_flip_lats) endif case ('gphgt') if (jpdt(12) == 85000 .or. jpdt(12) == 85) then call conv1d2d_real (imax,jmax,f,hgt(1,1,1) & ,need_to_flip_lats) else if (jpdt(12) == 70000 .or. jpdt(12) == 7) then call conv1d2d_real (imax,jmax,f,hgt(1,1,2) & ,need_to_flip_lats) else if (jpdt(12) == 50000 .or. jpdt(12) == 5) then call conv1d2d_real (imax,jmax,f,hgt(1,1,3) & ,need_to_flip_lats) else if (jpdt(12) == 20000 .or. jpdt(12) == 2) then call conv1d2d_real (imax,jmax,f,hgt(1,1,4) & ,need_to_flip_lats) endif case ('mslp') call conv1d2d_real (imax,jmax,f,slp & ,need_to_flip_lats) case ('temp') call conv1d2d_real (imax,jmax,f,tmean & ,need_to_flip_lats) case ('lmask') call conv1d2d_real (imax,jmax,f,lsmask & ,need_to_flip_lats) case default if ( verb .ge. 1 ) then print *,'!!! ERROR: BAD CHPARM IN GETDATA = ',chparm(ip) endif end select else if ( verb .ge. 3 ) then print *,'!!! NOTE: getgb2 could not find parm: ' & ,chparm(ip) print *,'!!! at level = ',ig2_lev_val(ip) if (inp%lt_units == 'minutes') then print *,'!!! Forecast time = ',iftotalmins(ifh) & ,' minutes' else print *,'!!! Forecast time = ',ifhours(ifh) & ,' hours' endif endif endif enddo grib2_standard_parm_read_loop c *------------------------------------------------------------* c If we are attempting to determine the cyclone structure, c then read in data now that will allow us to do that. c This is the GRIB2 reading section. c *------------------------------------------------------------* if (phaseflag == 'y') then if (phasescheme == 'cps' .or. phasescheme == 'both') then ! Read in GP Height levels for cyclone phase space... grib2_cps_parm_lev_loop: do ip = 1,nlevs_cps ! ! --- Initialize Variables --- ! gfld%idsect => NULL() gfld%local => NULL() gfld%list_opt => NULL() gfld%igdtmpl => NULL() gfld%ipdtmpl => NULL() gfld%coord_list => NULL() gfld%idrtmpl => NULL() gfld%bmap => NULL() gfld%fld => NULL() jdisc=0 jids=-9999 jpdtn=trkrinfo%g2_jpdtn ! 0 = analysis or forecast; ! 1 = ens fcst jgdtn=0 jgdt=-9999 jpdt=-9999 npoints=0 icount=0 jskp=0 jpds = -1 jgds = -1 j=0 ! Set defaults for JPDT, then override in array ! assignments below... JPDT(1:15)=(/-9999,-9999,-9999,-9999,-9999,-9999,-9999 & ,-9999,-9999,-9999,-9999,-9999,-9999,-9999,-9999/) JPDT(1) = cpsig2_parm_cat(ip) JPDT(2) = cpsig2_parm_num(ip) if (inp%lt_units == 'minutes') then JPDT(8) = 0 JPDT(9) = iftotalmins(ifh) else JPDT(8) = 1 JPDT(9) = ifhours(ifh) endif c JPDT(10) = cpsig2_lev_typ(ip) JPDT(10) = cpsig2_lev_10(ip) cPENG-------------------------------------------- if (inp%model == 1 .or. inp%model == 10 .or. inp%model == 7 & .or. inp%model == 22 .or. inp%model == 16 & .or. inp%model == 15 .or. inp%model == 8) then JPDT(11) = cpsig2_lev_11(ip) JPDT(12) = cpsig2_lev_12(ip) endif c if (JPDT(10) == 100) then ! isobaric surface c JPDT(12) = cpsig2_lev_val(ip) * 100 ! GRIB2 levels c ! are in Pa c else c if (verb .ge. 3) then c print *,' ' c print *,'ERROR in getdata: JPDT(10) array value' c print *,'should only be 100 in this CPS section' c print *,'for GRIB2 data.' c endif c endif if(enable_timing/=0) then call date_and_time (big_ben(1),big_ben(2),big_ben(3) & ,date_time) write (6,731) date_time(5),date_time(6),date_time(7) 731 format (1x,'TIMING: before getgb2-2',i2.2,':',i2.2,':' & ,i2.2) endif call getgb2(lugb,lugi,jskp,jdisc,jids,jpdtn,jpdt,jgdtn & ,jgdt,unpack,krec,gfld,iret) if(enable_timing/=0) then call date_and_time (big_ben(1),big_ben(2),big_ben(3) & ,date_time) write (6,732) date_time(5),date_time(6),date_time(7) 732 format (1x,'TIMING: after getgb2-2',i2.2,':',i2.2,':' & ,i2.2) endif if ( verb .ge. 3 ) then print *,'iret from getgb2 (PHASE) in getdata = ',iret endif if (verb_g2 .ge. 1) then print *,'after getgb2 call(PHASE),' & ,' value of unpacked = ',gfld%unpacked print *,'after getgb2 (PHASE) call, gfld%ngrdpts = ' & ,gfld%ngrdpts print *,'after getgb2 (PHASE) call, gfld%ibmap = ' & ,gfld%ibmap endif if (verb .ge. 3) then print *,' ' if (inp%lt_units == 'minutes') then print *,'After getgb2 (PHASE) call, j= ',j & ,' ifmins= ',iftotalmins(ifh),' parm # (ip) = ' & ,ip,' iret= ',iret else print *,'After getgb2 (PHASE) call, j= ',j & ,' ifhours= ',ifhours(ifh),' parm # (ip) = ' & ,ip,' iret= ',iret endif endif if (iret == 0) then c Determine packing information from GRIB2 file. c The default packing is 40 JPEG 2000 ipack = 40 if (verb_g2 .ge. 1) then print *,' gfld%idrtnum = ', gfld%idrtnum endif ! Set DRT info ( packing info ) if ( gfld%idrtnum.eq.0 ) then ! Simple packing ipack = 0 elseif ( gfld%idrtnum.eq.2 ) then ! Complex packing ipack = 2 elseif ( gfld%idrtnum.eq.3 ) then ! Complex & spatial & ! packing ipack = 31 elseif ( gfld%idrtnum.eq.40.or.gfld%idrtnum.eq.15 ) & then ! JPEG 2000 packing ipack = 40 elseif ( gfld%idrtnum.eq.41 ) then ! PNG packing ipack = 41 endif if ( verb_g2 .ge. 1 ) then print *,'After check of idrtnum, ipack= ',ipack print *,'Number of gridpts= gfld%ngrdpts= ' & ,gfld%ngrdpts print *,'Number of elements= gfld%igdtlen= ' & ,gfld%igdtlen print *,'GDT num= gfld%igdtnum= ',gfld%igdtnum endif kf = gfld%ngrdpts ! Number of gridpoints returned ! from read do np = 1,kf f(np) = gfld%fld(np) if (gfld%ibmap == 0) then lb(np) = gfld%bmap(np) else lb(np) = .true. endif enddo call bitmapchk(kf,lb,f,dmin,dmax) c Convert logical bitmap to 2-d array (only need to do c this once since using same model for all variables). if (lbrdflag .eq. 'n') then call conv1d2d_logic (imax,jmax,lb,valid_pt & ,need_to_flip_lats) lbrdflag = 'y' endif firstval=gfld%fld(1) lastval=gfld%fld(kf) if (verb_g2 .ge. 1) then print *,' ' print *,' SECTION 0: discipl= ',gfld%discipline & ,' gribver= ',gfld%version print *,' ' print *,' SECTION 1: ' do j = 1,gfld%idsectlen print *,' sect1, j= ',j,' gfld%idsect(j)= ' & ,gfld%idsect(j) enddo if ( associated(gfld%local).AND.gfld%locallen.gt.0) & then print *,' ' print *,' SECTION 2: ',gfld%locallen,' bytes' else print *,' ' print *,' SECTION 2 DOES NOT EXIST IN THIS RECORD' endif print *,' ' print *,' SECTION 3: griddef= ',gfld%griddef print *,' ngrdpts= ',gfld%ngrdpts print *,' numoct_opt= ',gfld%numoct_opt print *,' interp_opt= ',gfld%interp_opt print *,' igdtnum= ',gfld%igdtnum print *,' igdtlen= ',gfld%igdtlen print *,' ' print '(a17,i3,a2)',' GRID TEMPLATE 3.' & ,gfld%igdtnum,': ' do j=1,gfld%igdtlen print *,' j= ',j,' gfld%igdtmpl(j)= ' & ,gfld%igdtmpl(j) enddo c Get parameter abbrev for record that was retrieved print *,' ' print *,' PDT num (gfld%ipdtnum) = ' & ,gfld%ipdtnum print *,' ' print '(a20,i3,a2)',' PRODUCT TEMPLATE 4.' & ,gfld%ipdtnum & ,': ' do j=1,gfld%ipdtlen print *,' sect 4 j= ',j,' gfld%ipdtmpl(j)= ' & ,gfld%ipdtmpl(j) enddo endif pdt_4p0_vtime = gfld%ipdtmpl(9) pdt_4p0_vert_level = gfld%ipdtmpl(12) pabbrev=param_get_abbrev(gfld%discipline & ,gfld%ipdtmpl(1),gfld%ipdtmpl(2)) if (verb .ge. 3) then print *,' ' write (6,231) 231 format (' rec# param level byy bmm bdd ' & ,'bhh ' & ,'fhr npts firstval lastval minval ' & ,' maxval') print '(i5,3x,a8,2x,6i5,2x,i8,4g12.4)' & ,krec,pabbrev,pdt_4p0_vert_level,gfld%idsect(6) & ,gfld%idsect(7),gfld%idsect(8),gfld%idsect(9) & ,pdt_4p0_vtime,gfld%ngrdpts,firstval,lastval,dmin & ,dmax cPENG & ,krec,pabbrev,pdt_4p0_vert_level/100,gfld%idsect(6) endif c Convert data to 2-d array call conv1d2d_real (imax,jmax,f,cpshgt(1,1,ip) & ,need_to_flip_lats) endif enddo grib2_cps_parm_lev_loop endif endif else !---------------------------------- ! Reading from a GRIB v1 file.... !---------------------------------- grib1_read_loop: do ip = 1,nreadparms jpds = -1 jgds = -1 j=0 if (inp%model == 4) then ! ECMWF hi-res data uses ECMWF table print *,' ' print *,'WARNING: From the namelist, inp%model is set to a' print *,' value of 4, which is for ECMWF, so in routine' print *,' getdata_grib, the input jpds(5,6,7) parms are' print *,' going to have values that are specific for' print *,' ECMWF GRIB1 data.' print *,' ' jpds(5) = ec_igparm(ip) jpds(6) = ec_iglevtyp(ip) jpds(7) = ec_iglev(ip) else ! All other models use NCEP-standard GRIB table jpds(5) = igparm(ip) jpds(6) = iglevtyp(ip) jpds(7) = iglev(ip) endif print *,' ' print *,' --- Before getgb, jpds(5)= ',jpds(5) print *,' --- , jpds(6)= ',jpds(6) print *,' --- , jpds(7)= ',jpds(7) if (jpds(5) == 999) then cycle endif if (inp%lt_units == 'minutes') then jpds(14) = iftotalmins(ifh) else jpds(14) = ifhours(ifh) endif if(enable_timing/=0) then call date_and_time (big_ben(1),big_ben(2),big_ben(3) & ,date_time) write (6,831) date_time(5),date_time(6),date_time(7) 831 format (1x,'TIMING: before getgb-1',i2.2,':',i2.2,':',i2.2) endif call getgb (lugb,lugi,jf,j,jpds,jgds, & kf,k,kpds,kgds,lb,f,iret) if (enable_timing /= 0) then call date_and_time (big_ben(1),big_ben(2),big_ben(3) & ,date_time) write (6,832) date_time(5),date_time(6),date_time(7) 832 format (1x,'TIMING: after getgb-1',i2.2,':',i2.2,':',i2.2) endif if ( verb .ge. 3 ) then print *,' ' if (inp%lt_units == 'minutes') then print *,'After getgb call, j= ',j,' k= ',k & ,' iftotalmins= ' & ,iftotalmins(ifh),' parm # (ip) = ',ip,' iret= ',iret else print *,'After getgb call, j= ',j,' k= ',k,' ifhours= ' & ,ifhours(ifh),' parm # (ip) = ',ip,' iret= ',iret endif endif if (iret == 0) then if ( verb .ge. 3 ) then print *,'+++ Good Read: getgb found parm: ',chparm(ip) print *,'+++ at level = ',jpds(7) if (inp%lt_units == 'minutes') then print *,'+++ Forecast time = ',iftotalmins(ifh) & ,' minutes' else print *,'+++ Forecast time = ',ifhours(ifh) & ,' hours' endif endif readflag(ip) = .TRUE. call bitmapchk(kf,lb,f,dmin,dmax) if ( verb .ge. 3 ) then if (inp%lt_units == 'minutes') then write (6,29) else write (6,31) endif 29 format (' rec# parm# levt lev byy bmm bdd bhh fmin' & ,' npts minval maxval') 31 format (' rec# parm# levt lev byy bmm bdd bhh fhr ' & ,' npts minval maxval') print '(i4,2x,8i5,i8,2g12.4)', & k,(kpds(i),i=5,11),kpds(14),kf,dmin,dmax endif c Convert logical bitmap to 2-d array (only need to do this c once since using same model for all variables). if (lbrdflag .eq. 'n') then call conv1d2d_logic (imax,jmax,lb,valid_pt & ,need_to_flip_lats) lbrdflag = 'y' endif select case (chparm(ip)) case ('absv') if (jpds(7) == 850) then call conv1d2d_real (imax,jmax,f,zeta(1,1,1) & ,need_to_flip_lats) else call conv1d2d_real (imax,jmax,f,zeta(1,1,2) & ,need_to_flip_lats) endif case ('ugrid') if (jpds(7) == 850) then call conv1d2d_real (imax,jmax,f,u(1,1,1) & ,need_to_flip_lats) else if (jpds(7) == 700) then call conv1d2d_real (imax,jmax,f,u(1,1,2) & ,need_to_flip_lats) else if (jpds(7) == 500) then call conv1d2d_real (imax,jmax,f,u(1,1,3) & ,need_to_flip_lats) else ! Near-surface data call conv1d2d_real (imax,jmax,f,u(1,1,4) & ,need_to_flip_lats) endif case ('vgrid') if (jpds(7) == 850) then call conv1d2d_real (imax,jmax,f,v(1,1,1) & ,need_to_flip_lats) else if (jpds(7) == 700) then call conv1d2d_real (imax,jmax,f,v(1,1,2) & ,need_to_flip_lats) else if (jpds(7) == 500) then call conv1d2d_real (imax,jmax,f,v(1,1,3) & ,need_to_flip_lats) else ! Near-surface data call conv1d2d_real (imax,jmax,f,v(1,1,4) & ,need_to_flip_lats) endif case ('gphgt') if (jpds(7) == 850) then call conv1d2d_real (imax,jmax,f,hgt(1,1,1) & ,need_to_flip_lats) else if (jpds(7) == 700) then call conv1d2d_real (imax,jmax,f,hgt(1,1,2) & ,need_to_flip_lats) else if (jpds(7) == 500) then call conv1d2d_real (imax,jmax,f,hgt(1,1,3) & ,need_to_flip_lats) else if (jpds(7) == 200) then call conv1d2d_real (imax,jmax,f,hgt(1,1,4) & ,need_to_flip_lats) endif case ('mslp') call conv1d2d_real (imax,jmax,f,slp & ,need_to_flip_lats) case ('temp') call conv1d2d_real (imax,jmax,f,tmean & ,need_to_flip_lats) case ('lmask') call conv1d2d_real (imax,jmax,f,lsmask & ,need_to_flip_lats) case default if ( verb .ge. 1 ) then print *,'!!! ERROR: BAD CHPARM IN GETDATA = ',chparm(ip) endif end select else if ( verb .ge. 3 ) then print *,'!!! NOTE: getgb could not find parm: ',chparm(ip) print *,'!!! at level = ',jpds(7) if (inp%lt_units == 'minutes') then print *,'!!! Forecast time = ',iftotalmins(ifh) & ,' minutes' else print *,'!!! Forecast time = ',ifhours(ifh) & ,' hours' endif endif endif enddo grib1_read_loop c *------------------------------------------------------------* c If we are attempting to determine the cyclone structure, c then read in data now that will allow us to do that. c *------------------------------------------------------------* if (phaseflag == 'y') then if (phasescheme == 'cps' .or. phasescheme == 'both') then ! Read in GP Height levels for cyclone phase space... cps_grib1_lev_loop: do ip = 1,nlevs_cps jpds = -1 jgds = -1 j=0 if (inp%model == 4) then ! Use different grib parm id for ECMWF GP height jpds(5) = ec_cpsgparm(ip) else jpds(5) = cpsgparm(ip) endif jpds(6) = cpsglevtyp(ip) jpds(7) = cpsglev(ip) if (inp%lt_units == 'minutes') then jpds(14) = iftotalmins(ifh) else jpds(14) = ifhours(ifh) endif if(enable_timing/=0) then call date_and_time (big_ben(1),big_ben(2),big_ben(3) & ,date_time) write (6,841) date_time(5),date_time(6),date_time(7) 841 format (1x,'TIMING: before getgb-2',i2.2,':',i2.2 & ,':',i2.2) endif call getgb (lugb,lugi,jf,j,jpds,jgds, & kf,k,kpds,kgds,lb,f,iret) if(enable_timing/=0) then call date_and_time (big_ben(1),big_ben(2),big_ben(3) & ,date_time) write (6,842) date_time(5),date_time(6),date_time(7) 842 format (1x,'TIMING: after getgb-2',i2.2,':',i2.2 & ,':',i2.2) endif if ( verb .ge. 3 ) then print *,' ' if (inp%lt_units == 'minutes') then print *,'After getgb (PHASE) call, j= ',j,' k= ',k & ,' ifmins= ',iftotalmins(ifh),' parm # (ip) = ' & ,ip,' iret= ',iret else print *,'After getgb (PHASE) call, j= ',j,' k= ',k & ,' ifhours= ',ifhours(ifh),' parm # (ip) = ' & ,ip,' iret= ',iret endif endif if (iret == 0) then call bitmapchk(kf,lb,f,dmin,dmax) if ( verb .ge. 3 ) then if (inp%lt_units == 'minutes') then write (6,39) else write (6,41) endif 39 format (' rec# parm# levt lev byy bmm bdd bhh ' & ,'fmin npts minval maxval') 41 format (' rec# parm# levt lev byy bmm bdd bhh ' & ,'fhr npts minval maxval') print '(i4,2x,8i5,i8,2g12.4)', & k,(kpds(i),i=5,11),kpds(14),kf,dmin,dmax endif c Convert data to 2-d array call conv1d2d_real (imax,jmax,f,cpshgt(1,1,ip) & ,need_to_flip_lats) endif enddo cps_grib1_lev_loop endif endif endif c deallocate (f) deallocate (lb) c return end c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine getdata_netcdf (ncfile_id,readflag,valid_pt,imax,jmax & ,ifh,need_to_flip_lats,need_to_flip_lons & ,ncfile_tmax,netcdfinfo) c c ABSTRACT: This subroutine reads the input NetCDF file for the c tracked parameters for one lead time. c c There are up to 9 fields that are read in that will be used to c locate the storm position. There are an additional 4 variables c (500 mb u- and v-components and 10 m u- and v- components) that c will not be used for tracking, but only for helping to estimate c the next first guess position (500 mb winds) and for estimating c the max near-surface wind speeds in the vicinity of the storm c (10 m winds). c c Fields read in are listed here. Numbers indicate positioning in c the readflag logical array: c c 1. 850 mb absolute vorticity c 2. 700 mb absolute vorticity c 3. 850 mb u-component c 4. 850 mb v-component c 5. 700 mb u-component c 6. 700 mb v-component c 7. 850 mb geopotential height c 8. 700 mb geopotential height c 9. MSLP c 10. 10-m u-component c 11. 10-m v-component c 12. 500 mb u-component c 13. 500 mb v-component c 14. 300-500 mb mean temperature c 15. 500 mb geopotential height c 16. 200 mb geopotential height c 17. Land-Sea mask -- This is for tcgen applications only, and c even there, it's optional. c c If the user has requested to check the cyclone phase space for c this run (phaseflag set to 'y' and phasescheme set to 'cps'), c then we need to have gp height data for 900-300 mb at every 50 c mb. Some of those levels for gp height data were already read c in with the read of the initial 17 parameters, but we will be c sure to read in the others, if requested. c c INPUT: c ncfile_id integer ID associated with the NetCDF file c imax integer number of pts in i-direction on grid c jmax integer number of pts in j-direction on grid c ifh integer index for forecast hour c need_to_flip_lats logical flag read in from getgridinfo that c indicates if data needs flipped north to south c need_to_flip_lons logical flag read in from getgridinfo that c indicates if data needs flipped east to west c ncfile_tmax integer with max number of time levels in the input c NetCDF file, as read in from the NetCDF file c itself in subroutine read_netcdf_fhours. c c OUTPUT: c readflag logical array, indicates if a parm was read in c valid_pt logical array, indicates for each (i,j) if there is c valid data at the point (used for regional grids) USE tracked_parms; USE level_parms; USE inparms; USE phase USE netcdf_parms; USE verbose_output implicit none c type (netcdfstuff) netcdfinfo integer, parameter :: nreadparms=17,nreadparms_cps=13 real, allocatable :: f(:) real :: dmin,dmax,xmissing_value,xfill_value logical(1) valid_pt(imax,jmax),readflag(nreadparms) logical(1) :: need_to_flip_lats,need_to_flip_lons character*1 :: lbrdflag,match_check character*30 :: chparm(nreadparms) character*30 :: chparm_cps(nreadparms_cps) integer, intent(in) :: ncfile_id,imax,jmax integer :: igvret,ifa,ip,ifh,i,j,k,m,n,ncfile_tmax,nf_get_att_real integer :: nf_get_att_double,nf_inq_attlen,imvlen,ifvlen integer :: usertime,ncix,missing_val_length,nf_status integer :: nf_inq_varid,varid c lbrdflag = 'n' cnc data cpsgparm /13*7/ cnc data cpsglevtyp /13*100/ cnc data cpsglev /900,850,800,750,700,650,600,550,500,450,400 cnc & ,350,300/ c data chparm /'vort850','vort700' c & ,'u850','v850','u700','v700' c & ,'h850','h700','slp','u_ref','v_ref' c & ,'u500','v500','tm'/ c Load the names of the NetCDF variables for the standard c variables into the chparm array... chparm(1) = netcdfinfo%rv850name chparm(2) = netcdfinfo%rv700name chparm(3) = netcdfinfo%u850name chparm(4) = netcdfinfo%v850name chparm(5) = netcdfinfo%u700name chparm(6) = netcdfinfo%v700name chparm(7) = netcdfinfo%z850name chparm(8) = netcdfinfo%z700name chparm(9) = netcdfinfo%mslpname chparm(10) = netcdfinfo%usfcname chparm(11) = netcdfinfo%vsfcname chparm(12) = netcdfinfo%u500name chparm(13) = netcdfinfo%v500name chparm(14) = netcdfinfo%tmean_300_500_name chparm(15) = netcdfinfo%z500name chparm(16) = netcdfinfo%z200name chparm(17) = netcdfinfo%lmaskname if (verb .ge. 3) then print *,' ' print *,'NOTE: Program is now in subroutine getdata_netcdf.' endif if (allocated(f)) deallocate(f) allocate (f(imax*jmax),stat=ifa) if (ifa /= 0) then print *,' ' print *,'!!! ERROR in getdata_netcdf allocating f data array.' print *,'!!! ifa = ',ifa print *,'!!! STOPPING EXECUTION' STOP 91 endif !--------------------------------------------------------------- ! First go through the list of user-requested lead times that ! were read in from subroutine read_fhours and try to match up ! the lead times that were read in with the lead times that ! we read in directly from the NetCDF file. Get the index from ! the NetCDF file for that lead time and use that in the call to ! the read routine (get_var3_tlev_double). !--------------------------------------------------------------- usertime = iftotalmins(ifh) match_check = 'n' find_index_loop: do m = 1,ncfile_tmax if (usertime == nctotalmins(m)) then ncix = m if (verb .ge. 1) then print *,'+++ Time match in getdata_netcdf for usertime= ' & ,usertime,' netcdf file index= ncix= ',ncix endif match_check = 'y' exit find_index_loop endif enddo find_index_loop if (match_check == 'n') then print *,' ' print *,'!!! ERROR in getdata_netcdf: ' print *,' For a NetCDF file, the user has ' print *,' requested to process a lead time, and that lead' print *,' time does not exist in the NetCDF list of time' print *,' values. ' print *,' ifh= ',ifh print *,' usertime= iftotalmins(ifh)= ',iftotalmins(ifh) print *,' STOPPING....' stop 99 endif !--------------------------------------------------------------- ! Now go through the read loop for the list of parameters !--------------------------------------------------------------- netcdf_standard_parm_read_loop: do ip = 1,nreadparms if (chparm(ip) == 'X' .or. chparm(ip) == 'x') then if (verb .ge. 3) then print *,' ' print *,'!!! NetCDF read NOT requested for parm # ',ip endif cycle netcdf_standard_parm_read_loop else if (verb .ge. 3) then print *,' ' print *,'+++ NetCDF read requested for parm # ',ip & ,' ... parm= ',chparm(ip) endif endif ! Note that I am sending a 1-d array, "f", to the netcdf read ! routine. While that routine returns a 2-d array (which we ! want), depending on the model & grid, we may need to flip the ! grid in the north-south direction. I already have a routine ! for converting data from a 1-d to a 2-d array, and it has ! the functionality for flipping a grid, so I programmed it as ! getting a 1-d array from the netcdf read routine and send that ! 1-d array to conv1d2d_real. call get_var3_tlev_double (ncfile_id,chparm(ip),imax,jmax,ncix & ,f,igvret) if (verb .ge. 3) then print *,' ' print *,'After read, parm= ',chparm(ip),' ifh= ',ifh & ,' lead time index= ',ltix(ifh),' parm# (ip) = ',ip & ,' ncix= ',ncix,' igvret= ',igvret endif if (igvret == 0) then c call bitmapchk(kf,lb,f,dmin,dmax) readflag(ip) = .TRUE. dmin = minval(f) dmax = maxval(f) ! Need to get the value of the "missing_value" attribute for ! this variable from the list of attributes in the NetCDF ! file. Only do this for the first lead time, since the ! value of the "missing_value" obviously will not change ! with lead time. c nf_status = nf_inq_attlen (ncfile_id,varid,"missing_value" c & ,imvlen) c nf_status = nf_inq_attlen (ncfile_id,varid,"_FillValue" c & ,ifvlen) ! These next two nf function calls retrieve the value of the ! "missing_value" attribute from the list of attributes for ! the given variable being read in. This is needed in order ! to know if a non-valid point is being accessed, as for a ! regional grid, like the nested fvGFS. In GRIB1/GRIB2 files, ! such regions would be bitmapped out, but in a NetCDF file, ! no such bitmap exists, so we have to check for missing ! values. In case it's a moving grid, we need to do this ! for every lead time, since the "map of missing values" ! will shift with lead time. Once we have those missing ! values, we can loop through them and fill the valid_pt ! logical array so that, in the end, we will have the same ! logical bitmap for masking out missing data that we have ! with GRIB1/GRIB2 data. nf_status = nf_inq_varid (ncfile_id,chparm(ip),varid) print *,'nf_status from nf_inq_varid call = ',nf_status nf_status = nf_get_att_real (ncfile_id,varid,"missing_value" & ,xmissing_value) print *,'nf_status from nf_get_att_real call = ',nf_status c nf_status = nf_get_att_real (ncfile_id,varid,"_FillValue" c & ,xfill_value) c nf_status = nf90_inquire_attribute (ncfile_id,chparm(ip) c & ,"missing_value",len=imvlen) c nf_status = nf90_inquire_attribute (ncfile_id,chparm(ip) c & ,"_FillValue",len=ifvlen) c c nf_status = nf90_get_att (ncfile_id,chparm(ip) c & ,"missing_value",xmissing_value) c nf_status = nf90_get_att (ncfile_id,chparm(ip) c & ,"_FillValue",xfill_value) if (verb .ge. 3) then write (6,31) 31 format ('parmread lead time parm# parm_id ' & ,23x,'minval maxval') write (6,33) ifhours(ifh),ifclockmins(ifh),ip,chparm(ip) & ,dmin,dmax 33 format (' ',i3,':',i2.2,14x,i3,10x,a30,1x,2g12.4) write (6,35) chparm(ip),xmissing_value 35 format (' --- ',a30,' missing value = ',g12.4) endif ! This call to conv1d2d_logic_netcdf creates ! a logical bitmap, so that in case we have ! regional (non-global) data and an irregular grid (e.g., ! the FV3 nested grid), we can mask out grid points that ! have missing values as their data values. There is not ! actually a native logical bitmap in NetCDF, so we will ! create one by examining the real data values and masking ! out grid points that have missing values. if (lbrdflag .eq. 'n') then call conv1d2d_logic_netcdf (imax,jmax,f,valid_pt & ,xmissing_value,need_to_flip_lats) lbrdflag = 'y' endif if (ip == 1) then ! 850 mb absolute vorticity call conv1d2d_real (imax,jmax,f,zeta(1,1,1) & ,need_to_flip_lats) else if (ip == 2) then ! 700 mb absolute vorticity call conv1d2d_real (imax,jmax,f,zeta(1,1,2) & ,need_to_flip_lats) else if (ip == 3) then ! 850 mb u-comp call conv1d2d_real (imax,jmax,f,u(1,1,1) & ,need_to_flip_lats) else if (ip == 4) then ! 850 mb v-comp call conv1d2d_real (imax,jmax,f,v(1,1,1) & ,need_to_flip_lats) else if (ip == 5) then ! 700 mb u-comp call conv1d2d_real (imax,jmax,f,u(1,1,2) & ,need_to_flip_lats) else if (ip == 6) then ! 700 mb v-comp call conv1d2d_real (imax,jmax,f,v(1,1,2) & ,need_to_flip_lats) else if (ip == 7) then ! 850 mb gp height call conv1d2d_real (imax,jmax,f,hgt(1,1,1) & ,need_to_flip_lats) else if (ip == 8) then ! 700 mb gp height call conv1d2d_real (imax,jmax,f,hgt(1,1,2) & ,need_to_flip_lats) else if (ip == 9) then ! MSLP call conv1d2d_real (imax,jmax,f,slp & ,need_to_flip_lats) else if (ip == 10) then ! Near-sfc (10m) u-comp call conv1d2d_real (imax,jmax,f,u(1,1,4) & ,need_to_flip_lats) else if (ip == 11) then ! Near-sfc (10m) v-comp call conv1d2d_real (imax,jmax,f,v(1,1,4) & ,need_to_flip_lats) else if (ip == 12) then ! 500 mb u-comp call conv1d2d_real (imax,jmax,f,u(1,1,3) & ,need_to_flip_lats) else if (ip == 13) then ! 500 mb v-comp call conv1d2d_real (imax,jmax,f,v(1,1,3) & ,need_to_flip_lats) else if (ip == 14) then ! 300-500 mb mean Temp call conv1d2d_real (imax,jmax,f,tmean & ,need_to_flip_lats) else if (ip == 15) then ! 500 mb height call conv1d2d_real (imax,jmax,f,hgt(1,1,3) & ,need_to_flip_lats) else if (ip == 16) then ! 200 mb height call conv1d2d_real (imax,jmax,f,hgt(1,1,4) & ,need_to_flip_lats) else if (ip == 17) then ! Land-sea mask call conv1d2d_real (imax,jmax,f,lsmask & ,need_to_flip_lats) else print *,'!!! NOTE: Parm not recognized. ' print *,'!!! ip is > 17.... ip= ',ip print *,'!!! Forecast time level = ',ifh endif endif enddo netcdf_standard_parm_read_loop c *--------------------------------------------------------------* c If we are attempting to determine the cyclone structure using c Hart's cyclone phase space, then read in data now that will c allow us to do that. If we are instead just using the c mid-level (300-500 mb) mean temperature to do that with a c simple warm-core check, then that mean temperature field was c already read in above in the read loop for the standard c variables. The variables needed here for CPS are pretty c straightforward: gp height every 50 mb from 300 to 900 mb. c keep in mind that we have already read in a few of these c gp height records for selected levels above. c *--------------------------------------------------------------* if (phaseflag == 'y') then if (phasescheme == 'cps' .or. phasescheme == 'both') then chparm_cps(1) = netcdfinfo%z900name chparm_cps(2) = netcdfinfo%z850name chparm_cps(3) = netcdfinfo%z800name chparm_cps(4) = netcdfinfo%z750name chparm_cps(5) = netcdfinfo%z700name chparm_cps(6) = netcdfinfo%z650name chparm_cps(7) = netcdfinfo%z600name chparm_cps(8) = netcdfinfo%z550name chparm_cps(9) = netcdfinfo%z500name chparm_cps(10) = netcdfinfo%z450name chparm_cps(11) = netcdfinfo%z400name chparm_cps(12) = netcdfinfo%z350name chparm_cps(13) = netcdfinfo%z300name ! Read in GP Height levels for cyclone phase space... if (verb .ge. 3) then print *,' ' print *,'--- Reads for CPS parms follow...' print *,' ' endif netcdf_cps_parm_read_loop: do ip = 1,nreadparms_cps if (chparm_cps(ip) == 'X' .or. chparm_cps(ip) == 'x') then if (verb .ge. 3) then print *,'!!! ERROR: NetCDF read NOT requested for' print *,'!!! CPS parm # ',ip print *,'!!! You must have an error in your namelist.' print *,'!!! You have requested to do cyclone phase' print *,'!!! checking, so you need to include the ' print *,'!!! NetCDF names for ALL requested gp height' print *,'!!! variables from 900 to 300 mb, every 50 ' print *,'!!! mb,in the namelist.' print *,'!!! phaseflag is being set to NO (n), and ' print *,'!!! phase-checking will NOT take place.' print *,'!!! If you want to run again and just do ' print *,'!!! phase-checking with a simple warm-core' print *,'!!! check, then in the namelist set phaseflag' print *,'!!! to y and set phasescheme to vtt.' phaseflag = 'n' endif exit netcdf_cps_parm_read_loop else if (verb .ge. 3) then print *,'+++ NetCDF read requested for cps parm # ',ip & ,' ... parm= ',chparm_cps(ip) endif endif ! As above, we send a 1-d array, "f", to the netcdf read ! routine. While that routine returns a 2-d array (which ! we want), depending on the model & grid, we may need to ! flip the grid in the north-south direction. I already ! have a routine for converting data from a 1-d to a 2-d ! array, and it has the functionality for flipping a grid, ! so I programmed it as getting a 1-d array from the netcdf ! read routine and send that 1-d array to conv1d2d_real. call get_var3_tlev_double (ncfile_id,chparm_cps(ip),imax & ,jmax,ncix,f,igvret) if (verb .ge. 3) then print *,' ' print *,'After read, parm= ',chparm_cps(ip),' ifh= ',ifh & ,' lead time index= ',ltix(ifh),' parm# (ip) = ',ip & ,' ncix= ',ncix,' igvret= ',igvret endif if (igvret == 0) then c call bitmapchk(kf,lb,f,dmin,dmax) readflag(ip) = .TRUE. dmin = minval(f) dmax = maxval(f) c nf_status = nf_get_att_double (ncfile_id,chparm(ip) c & ,"missing_value",xmissing_value) c nf_status = nf_get_att_double (ncfile_id,chparm(ip) c & ,"_FillValue",xfill_value) nf_status = nf_inq_varid (ncfile_id,chparm_cps(ip),varid) nf_status = nf_get_att_real (ncfile_id,varid & ,"missing_value",xmissing_value) if (verb .ge. 3) then write (6,231) 231 format ('parmread lead time parm# parm_id ' & ,23x,'minval maxval') write (6,233) ifhours(ifh),ifclockmins(ifh),ip & ,chparm_cps(ip),dmin,dmax 233 format (' ',i3,':',i2.2,14x,i3,10x,a30,1x,2g12.4) write (6,235) chparm_cps(ip),xmissing_value 235 format (' --- ',a30,' missing value = ',g12.4) endif call conv1d2d_real (imax,jmax,f,cpshgt(1,1,ip) & ,need_to_flip_lats) endif enddo netcdf_cps_parm_read_loop endif endif return end c c------------------------------------------------------------------ c c------------------------------------------------------------------ subroutine get_ncdim1 (ncid,var1_name,nmax) c c ABSTRACT: This routine queries a netcdf file to get the c value of a requested file dimension (e.g., imax, jmax) c implicit none include "netcdf.inc" integer, intent(in) :: ncid character*(*), intent(in) :: var1_name integer, intent(out) :: nmax integer :: status, var1id status = nf_inq_dimid (ncid,var1_name,var1id) if (status .ne. NF_NOERR) call handle_netcdf_err(status) status = nf_inq_dimlen (ncid,var1id,nmax) if (status .ne. NF_NOERR) call handle_netcdf_err(status) end subroutine get_ncdim1 c c------------------------------------------------------------------ c c------------------------------------------------------------------ subroutine get_var1_double (ncid,var1_name,nmax,var1) c c ABSTRACT: This routine reads a netcdf file in order to return c a 1-dimensional array of data. implicit none include "netcdf.inc" integer, intent(in):: ncid character*(*), intent(in):: var1_name integer, intent(in):: nmax real, intent(out):: var1(nmax) integer :: status, var1id status = nf_inq_varid (ncid,var1_name,var1id) if (status .ne. NF_NOERR) call handle_netcdf_err(status) ! write(*,*) 'Got var1id', var1id status = nf_get_var_real (ncid,var1id,var1) if (status .ne. NF_NOERR) call handle_netcdf_err(status) end subroutine get_var1_double c c--------------------------------------------------------- c c--------------------------------------------------------- subroutine get_var3_tlev_double (ncid,var3_name,imax,jmax,ncix & ,var3,igvret) c c ABSTRACT: This routine reads a netcdf file and returns a c 2-dimensional synoptic variable at a particular lead time. c The lead time is specified by the ltix array, which is c included in module tracked_parms and defined in subroutine c read_fhours. c c PARAMETERS c c INPUT: c ncid integer that contains the NetCDF file ID c var3_name character name of NetCDF input file c imax integer x-dimension of input data c jmax integer y-dimension of input data c ncix integer index of time level for where this time level c actually is inside the NetCDF data. Do NOT confuse this c with the index of where this forecast hour is in the c user's list of input forecast hours, as they may be c different. For example, the user may request times that c are every 6 hours, but the NetCDF file might have times c that are every hour, so the indices for those two arrays c will be different. Be sure to use the one (ncix) that c indicates where the data actually starts in the c NetCDF file. c c OUTPUT: c var3 real array with real values returned from NetCDF read c igvret integer return code from this routine USE tracked_parms; USE verbose_output; USE netcdf_parms implicit none include "netcdf.inc" c integer, intent(in) :: ncid,ncix character*(*), intent(in) :: var3_name integer, intent(in) :: imax,jmax real, intent(out) :: var3(imax,jmax) integer :: istart(3),ilength(3) integer :: status,var3id,igvret if (verb .ge. 3) then print *,' ' print *,'In get_var3_tlev_double, ncix= ',ncix print *,' nctotalmins(ncix)= ',nctotalmins(ncix) endif istart(1) = 1 istart(2) = 1 istart(3) = ncix ilength(1) = imax ilength(2) = jmax ilength(3) = 1 igvret = 0 status = nf_inq_varid (ncid,var3_name,var3id) if (status /= NF_NOERR) then print *,' ' print *,'NOTE: Could not find variable ',var3_name,' at time' & ,' index ncix= ',ncix & ,' nctotalmins(ncix)= ',nctotalmins(ncix) igvret = 92 return endif status = nf_get_vara_real (ncid,var3id,istart,ilength,var3) if (status .ne. NF_NOERR) call handle_netcdf_err(status) end subroutine get_var3_tlev_double c c---------------------------------------------------------------------- c c---------------------------------------------------------------------- subroutine handle_netcdf_err (status) c c ABSTRACT: This subroutine is an error handling routine for NetCDF- c related functions. implicit none include "netcdf.inc" integer status c if (status /= nf_noerr) then print *,' ' print *,'Tracker NetCDF error: ' print *, nf_strerror(status) stop 'Stopped' endif end subroutine handle_netcdf_err c c------------------------------------------------------------------- c c------------------------------------------------------------------- subroutine bitmapchk (n,ld,d,dmin,dmax) c c This subroutine checks the bitmap for non-existent data values. c Since the data from the regional models have been interpolated c from either a polar stereographic or lambert conformal grid c onto a lat/lon grid, there will be some gridpoints around the c edges of this lat/lon grid that have no data; these grid c points have been bitmapped out by Mark Iredell's interpolater. c To provide another means of checking for invalid data points c later in the program, set these bitmapped data values to a c value of -999.0. The min and max of this array are also c returned if a user wants to check for reasonable values. c logical(1) ld dimension ld(n),d(n) c dmin=1.E15 dmax=-1.E15 c do i=1,n if (ld(i)) then dmin=min(dmin,d(i)) dmax=max(dmax,d(i)) else d(i) = -999.0 endif enddo c return end c c------------------------------------------------------------------ c c------------------------------------------------------------------ subroutine conv1d2d_logic (imax,jmax,lb1d,lb2d,need_to_flip_lats) c c ABSTRACT: This subroutine converts a 1-dimensional input c array of logical data (lb1d) into a 2-dimensional output c array (dimension imax,jmax) of logical data (lb2d). c c This subroutine was updated in 6/2000 to add the scanning mode c flag (iscanflag) as an input. This is in order to handle grids c that are flipped. Most grids -- NCEP, UKMET, ECMWF -- have c point (1,1) as the uppermost left point on the grid, and the c data goes from north to south. Some grids -- GFDL and the new c NAVGEM grid -- are flipped; their point (1,1) is the lowermost c left point, and their data goes from south to north. So if c the scanning mode flag indicates northward scanning data c (bit 2 in the flag is turned on), we catch it in this c subroutine and flip the data ourselves for our own arrays, c since this whole program is structured around the data going c from north to south. As of the writing of this, only the c first 3 bits of the scanning flag are used, which is why we c can use the mod statement in the code below. c c UPDATE 8/2009: I removed the scanning mode flag, since that is c GRIB-specific. The north-south determination is now handled with c the logical flag need_to_flip_lats. c c PARAMETERS: c c INPUT: c imax Number of gridpoints in i direction in input box c jmax Number of gridpoints in j direction in input box c lb1d 1-d array containing logical bitmap values c iscanflag This is kgds(11), an integer value in the GDS, c which holds the scanning mode for the data values c c OUTPUT: c lb2d 2-d array containing logical bitmap values c logical(1) lb1d(imax*jmax),lb2d(imax,jmax) logical(1) :: need_to_flip_lats integer :: ilat,ilatix,ilon,imax,jmax c if (need_to_flip_lats) then ! Input data is south to north; flip the data while ! converting to 2-d grid.... do ilat=1,jmax ilatix = jmax - ilat + 1 do ilon=1,imax lb2d(ilon,ilatix) = lb1d(ilon+(ilat-1)*imax) enddo enddo else ! Input data is north to south. Just convert the ! data onto a 2-d grid, do not flip it.... do ilat=1,jmax do ilon=1,imax lb2d(ilon,ilat) = lb1d(ilon+(ilat-1)*imax) enddo enddo endif c return end c c------------------------------------------------------------------ c c------------------------------------------------------------------ subroutine conv1d2d_logic_netcdf (imax,jmax,dat1d,lb2d & ,xmissing_val,need_to_flip_lats) c c ABSTRACT: The purpose of this routine is to create a 2-d logical c bitmap to be used for masking out regions with missing data, c such as for a regional grid with irregular boundaries (such as c we've seen for the regional / nested FV3). This bitmap will c have the same functionality as a GRIB1/GRIB2 bitmap. The trick c is that NetCDF does not have a logical bitmap within its c definition, so we need to make one. We do this by reading in c the "missing_value" attribute for any variable, then here we c scan through all the data values retrieved from the NetCDF read, c and then for all grid points with missing values we set the c valid_pt flag to .false. c c Note the use of the need_to_flip_lats flag. This is in order to c handle grids that are flipped. Most grids -- NCEP, UKMET, ECMWF c -- have point (1,1) as the uppermost left point on the grid, and c the data goes from north to south. Some grids -- GFDL and the c new NAVGEM grid -- are flipped; their point (1,1) is the lowermost c left point, and their data goes from south to north. So if c the need_to_flip_lats flag was set to TRUE in getgridinfo, meaning c that we have northward scanning data, we catch it in this c subroutine and flip the data ourselves for our own arrays, c since this whole program is structured around the data going c from north to south. c c PARAMETERS: c c INPUT: c imax Number of gridpoints in i direction in input box c jmax Number of gridpoints in j direction in input box c dat1d 1-d array containing floating point data values c xmissing_val real value of missing value for the given variable c that was read in for the calling routine c need_to_flip_lats logical flag, set in getgridinfo, that c indicates if data is correctly N-to-S, or if it is c S-to-N and needs to be flipped. c c OUTPUT: c lb2d 2-d array containing logical bitmap values c USE verbose_output implicit none logical(1) lb2d(imax,jmax) logical(1) need_to_flip_lats integer ilat,ilatix,ilon,imax,jmax,tct,fct,mct real dat1d(imax*jmax) real xmissing_val c tct = 0 fct = 0 mct = 0 if (verb >= 3) then print *,' ' print *,'TOP of conv1d2d_logic_netcdf, xmissing_val= ' & ,xmissing_val print *,' ' endif c if (need_to_flip_lats) then ! Input data is south to north; flip the data while ! converting to 2-d grid.... do ilat=1,jmax ilatix = jmax - ilat + 1 do ilon=1,imax if (dat1d(ilon+(ilat-1)*imax) == xmissing_val) then lb2d(ilon,ilatix) = .false. c print *,'LBSF FLIP: ilon= ',ilon,' ilatix= ',ilatix c fct = fct + 1 else lb2d(ilon,ilatix) = .true. c tct = tct + 1 endif enddo enddo else ! Input data is north to south. Just convert the ! data onto a 2-d grid, do not flip it.... do ilat=1,jmax do ilon=1,imax if (dat1d(ilon+(ilat-1)*imax) == xmissing_val) then c print *,'LBSF no-flip: ilon= ',ilon,' ilat= ',ilat lb2d(ilon,ilat) = .false. c fct = fct + 1 else lb2d(ilon,ilat) = .true. c tct = tct + 1 endif enddo enddo endif c print *,' ' c print *,' LB STATS: tct= ',tct,' fct= ',fct,' mct= ',mct c return end c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine conv1d2d_real (imax,jmax,dat1d,dat2d,need_to_flip_lats) c c ABSTRACT: This subroutine converts a 1-dimensional input c array of real data (dat1d) into a 2-dimensional output c array (dimension imax,jmax) of real data (dat2d). c c This subroutine was updated in 6/2000 to add the scanning mode c flag (iscanflag) as an input. This is in order to handle grids c that are flipped. Most grids -- NCEP, UKMET, ECMWF -- have c point (1,1) as the uppermost left point on the grid, and the c data goes from north to south. Some grids -- GFDL and the new c NAVGEM grid -- are flipped; their point (1,1) is the lowermost c left point, and their data goes from south to north. So if c the scanning mode flag indicates northward scanning data c (bit 2 in the flag is turned on), we catch it in this c subroutine and flip the data ourselves for our own arrays, c since this whole program is structured around the data going c from north to south. As of the writing of this, only the c first 3 bits of the scanning flag are used, which is why we c can use the mod statement in the code below. c c UPDATE 8/2009: I removed the scanning mode flag, since that is c GRIB-specific. The north-south determination is now handled with c the logical flag need_to_flip_lats. c c INPUT: c imax Number of gridpoints in i direction in input box c jmax Number of gridpoints in j direction in input box c dat1d 1-d real array of data c need_to_flip_lats logical flag, set in getgridinfo, that c indicates if data is correctly N-to-S, or if it is c S-to-N and needs to be flipped. c c OUTPUT: c dat2d 2-d real array of data c logical(1) :: need_to_flip_lats real dat1d(imax*jmax),dat2d(imax,jmax) c if (need_to_flip_lats) then ! Input data is south to north; flip the data while ! converting to 2-d grid.... do ilat=1,jmax ilatix = jmax - ilat + 1 do ilon=1,imax dat2d(ilon,ilatix) = dat1d(ilon+(ilat-1)*imax) enddo enddo else ! Input data is north to south. Just convert the ! data onto a 2-d grid, do not flip it.... do ilat=1,jmax do ilon=1,imax dat2d(ilon,ilat) = dat1d(ilon+(ilat-1)*imax) enddo enddo endif c return end c c--------------------------------------------------------------------- c c--------------------------------------------------------------------- subroutine read_nlists (inp,trkrinfo,netcdfinfo) c c ABSTRACT: This subroutine simply reads in the namelists that are c created in the shell script. Namelist datein contains the c starting date information, plus the model identifier. Namelist c stswitch contains the flags for processing for each storm. c USE inparms; USE set_max_parms; USE atcf; USE trkrparms; USE phase USE structure; USE gfilename_info USE verbose_output; USE waitfor_parms; USE netcdf_parms USE tracking_parm_prefs implicit none integer ifh type (datecard) inp type (trackstuff) trkrinfo type (netcdfstuff) netcdfinfo c namelist/datein/inp namelist/atcfinfo/atcfnum,atcfname,atcfymdh,atcffreq namelist/trackerinfo/trkrinfo namelist/phaseinfo/phaseflag,phasescheme,wcore_depth namelist/structinfo/structflag,ikeflag namelist/fnameinfo/gmodname,rundescr,atcfdescr namelist/verbose/verb,verb_g2 namelist/waitinfo/use_waitfor,wait_min_age,wait_min_size & ,wait_max_wait,wait_sleeptime & ,use_per_fcst_command,per_fcst_command namelist/netcdflist/netcdfinfo namelist/parmpreflist/user_wants_to_track_zeta850 & ,user_wants_to_track_zeta700,user_wants_to_track_wcirc850 & ,user_wants_to_track_wcirc700,user_wants_to_track_gph850 & ,user_wants_to_track_gph700,user_wants_to_track_mslp & ,user_wants_to_track_wcircsfc,user_wants_to_track_zetasfc & ,user_wants_to_track_thick500850 & ,user_wants_to_track_thick200500 & ,user_wants_to_track_thick200850 c Set namelist default values: use_per_fcst_command='t' per_fcst_command=' ' atcffreq=600 trkrinfo%enable_timing=1 trkrinfo%want_oci=.false. trkrinfo%gribver=1 ! Set to GRIB1 as default, can be set to ! something else in the namelist input. read (5,NML=datein,END=801) 801 continue read (5,NML=atcfinfo,END=807) 807 continue print *,'just before trackerinfo read namelist' read (5,NML=trackerinfo,END=809) 809 continue print *,'just after trackerinfo read namelist' read (5,NML=phaseinfo,END=811) 811 continue read (5,NML=structinfo,END=815) 815 continue read (5,NML=fnameinfo,END=817) 817 continue read (5,NML=waitinfo,END=821) 821 continue read (5,NML=netcdflist,END=823) 823 continue read (5,NML=parmpreflist,END=825) 825 continue read (5,NML=verbose,END=819,ERR=833) 819 continue goto 837 833 continue verb = 1 837 continue print *,'in read_nlists, verb= ',verb if ( verb .ge. 0 ) then print *,' ' print *,'After datein namelist in trak.f, namelist ' & ,'parms follow:' print *,'Forecast initial year = byy = ',inp%byy print *,'Forecast initial month = bmm = ',inp%bmm print *,'Forecast initial day = bdd = ',inp%bdd print *,'Forecast initial hour = bhh = ',inp%bhh print *,'Forecast model identifier = model= ',inp%model print *,'Forecast model type = modtyp= ',inp%modtyp print *,'Forecast model data lead time units= lt_units= ' & ,inp%lt_units print *,'Forecast model data sequencing setup= file_seq= ' & ,inp%file_seq print *,'Forecast model nest type = ',inp%nesttyp c print *,' ' print *,'Values read in from atcfinfo namelist: ' write (6,89) atcfnum,atcfname write (6,90) atcfymdh write (6,92) atcffreq 89 format ('ATCF ID = ',i2,' ATCF Name = ',a4) 90 format ('ATCF date (initial date on output atcf records) = ' & ,i10) 92 format ('ATCF output frequency (in hours*100) = atcffreq = ',i6) c print *,' ' print *,'Values read in from trackerinfo namelist follow: ' write (6,101) ' western boundary = westbd = ',trkrinfo%westbd write (6,101) ' eastern boundary = eastbd = ',trkrinfo%eastbd write (6,101) ' northern boundary = northbd = ',trkrinfo%northbd write (6,101) ' southern boundary = southbd = ',trkrinfo%southbd write (6,102) ' tracker type = ',trkrinfo%type write (6,103) ' mslp threshold = mslpthresh = ' & ,trkrinfo%mslpthresh write (6,120) ' Flag for using backup mslp gradient check= ' & ,'use_backup_mslp_grad_check = ' & ,trkrinfo%use_backup_mslp_grad_check write (6,103) ' v850 threshold = v850thresh = ' & ,trkrinfo%v850thresh write (6,122) ' Flag for using backup 850 mb Vt check= ' & ,'use_backup_850_vt_check = ' & ,trkrinfo%use_backup_850_vt_check write (6,123) ' Max allowable distance between the ' & ,'tracker-found fixes for mslp and 850 zeta = ' & ,trkrinfo%max_mslp_850 write (6,104) ' model grid type = ',trkrinfo%gridtype write (6,101) ' Contour interval to be used = ',trkrinfo%contint write (6,106) ' Flag for whether or not roci will be computed' & ,' and written out for tracker-type case = ' & ,trkrinfo%want_oci write (6,105) ' Flag for whether or not vitals will be written ' & ,'out = ',trkrinfo%out_vit write (6,109) ' Flag for whether or not a land mask will be ' & ,'used for tcgen candidate low filtering = ' & ,trkrinfo%use_land_mask write (6,110) ' Flag for input data type (grib or netcdf) = ' & ,trkrinfo%inp_data_type write (6,107) ' Flag for which GRIB version (1 or 2) the input' & ,' data will be in = ',trkrinfo%gribver write (6,108) ' Flag for input GRIB2 JPDTN (0 or 1) = ' & ,trkrinfo%g2_jpdtn write (6,112) ' Flag for input GRIB2 MSLP ID (1 or 192) = ' & ,trkrinfo%g2_mslp_parm_id write (6,114) ' Flag for input GRIB1 MSLP ID (102 or 130) = ' & ,trkrinfo%g1_mslp_parm_id write (6,116) ' Flag for input GRIB1 sfcwind level type ' & ,'(PDS Octet 10... should be 1 or 105) = ' & ,trkrinfo%g1_sfcwind_lev_typ write (6,118) ' Flag for input GRIB1 sfcwind level value ' & ,'(PDS Octets 11 & 12... usually 0 or 10) = ' & ,trkrinfo%g1_sfcwind_lev_val 101 format (a31,f7.2) 102 format (a16,a7) 103 format (a31,f7.4) 104 format (a19,a8) 106 format (a46,a41,L1) 105 format (a48,a6,a1) 109 format (a45,a41,a1) 110 format (a45,a6) 107 format (a47,a19,i1) 108 format (a39,i2) 112 format (a43,i4) 114 format (a45,i4) 116 format (a41,a39,i4) 118 format (a42,a43,i4) 120 format (a44,a29,a1) 122 format (a40,a26,a1) 123 format (a36,a44,f7.1) print *,' ' print *,' ' print *,'Values read in from netcdflist namelist: ' print *,' ' write (6,300) netcdfinfo%num_netcdf_vars ! Total *possible* ! number of input NetCDF variables, ! including those that are included ! in the input file and those that ! are not. write (6,370) netcdfinfo%netcdf_filename ! full path filename write (6,301) write (6,302) netcdfinfo%rv850name ! 850 mb rel vort write (6,304) netcdfinfo%rv700name ! 700 mb rel vort write (6,306) netcdfinfo%u850name ! 850 mb u-comp write (6,308) netcdfinfo%v850name ! 850 mb v-comp write (6,310) netcdfinfo%u700name ! 700 mb u-comp write (6,312) netcdfinfo%v700name ! 700 mb v-comp write (6,314) netcdfinfo%z850name ! 850 mb gp height write (6,316) netcdfinfo%z700name ! 700 mb gp height write (6,318) netcdfinfo%mslpname ! mslp write (6,320) netcdfinfo%usfcname ! near-sfc u-comp write (6,322) netcdfinfo%vsfcname ! near-sfc v-comp write (6,324) netcdfinfo%u500name ! 500 mb u-comp write (6,326) netcdfinfo%v500name ! 500 mb v-comp write (6,328) netcdfinfo%tmean_300_500_name !Mean T @ 300-500 mb write (6,330) netcdfinfo%z500name ! 500 mb gp height write (6,332) netcdfinfo%z200name ! 200 mb gp height write (6,334) netcdfinfo%lmaskname ! Land mask write (6,336) netcdfinfo%z900name ! 900 mb gp height write (6,338) netcdfinfo%z800name ! 800 mb gp height write (6,340) netcdfinfo%z750name ! 750 mb gp height write (6,342) netcdfinfo%z650name ! 650 mb gp height write (6,344) netcdfinfo%z600name ! 600 mb gp height write (6,346) netcdfinfo%z550name ! 550 mb gp height write (6,348) netcdfinfo%z450name ! 450 mb gp height write (6,350) netcdfinfo%z400name ! 400 mb gp height write (6,352) netcdfinfo%z350name ! 350 mb gp height write (6,354) netcdfinfo%z300name ! 300 mb gp height write (6,355) netcdfinfo%time_name ! Name of time variable ! (usually it is "time") write (6,356) netcdfinfo%lon_name ! longitudes write (6,358) netcdfinfo%lat_name ! latitudes write (6,359) netcdfinfo%time_units ! This will be either "days" ! or "hours". If it's "hours", ! then all the time data values ! are for hours since the initial ! time. Same thing for "days", ! however if it is "days", then ! know that a value of 0.25 will ! be the same as a 6-hour lead ! time. 300 format ('Total *possible* number of input NetCDF variables,' & ,/,' including those that are included in the input' & ,/,' NetCDF file and those that are not = ',i4) 370 format ('Input NetCDF filename = ',a180) 301 format (' ',/ & ,'List of NetCDF variables follows. A value of X ',/ & ,'indicates the variable is not included in the ',/ & ,'input file and no attempt will be made to read in ',/ & ,'that variable: ',/,' ') 302 format ('NetCDF variable name for 850 mb vort = ',a30) 304 format ('NetCDF variable name for 700 mb vort = ',a30) 306 format ('NetCDF variable name for 850 mb u-comp = ',a30) 308 format ('NetCDF variable name for 850 mb v-comp = ',a30) 310 format ('NetCDF variable name for 700 mb u-comp = ',a30) 312 format ('NetCDF variable name for 700 mb v-comp = ',a30) 314 format ('NetCDF variable name for 850 mb gp height = ',a30) 316 format ('NetCDF variable name for 700 mb gp height = ',a30) 318 format ('NetCDF variable name for MSLP = ',a30) 320 format ('NetCDF variable name for near-sfc u-comp = ',a30) 322 format ('NetCDF variable name for near-sfc v-comp = ',a30) 324 format ('NetCDF variable name for 500 mb u-comp = ',a30) 326 format ('NetCDF variable name for 500 mb v-comp = ',a30) 328 format ('NetCDF variable name for 300-500 mb Mean T = ',a30) 330 format ('NetCDF variable name for 500 mb gp height = ',a30) 332 format ('NetCDF variable name for 200 mb gp height = ',a30) 334 format ('NetCDF variable name for land-sea mask = ',a30) 336 format ('NetCDF variable name for 900 mb gp height = ',a30) 338 format ('NetCDF variable name for 800 mb gp height = ',a30) 340 format ('NetCDF variable name for 750 mb gp height = ',a30) 342 format ('NetCDF variable name for 650 mb gp height = ',a30) 344 format ('NetCDF variable name for 600 mb gp height = ',a30) 346 format ('NetCDF variable name for 550 mb gp height = ',a30) 348 format ('NetCDF variable name for 450 mb gp height = ',a30) 350 format ('NetCDF variable name for 400 mb gp height = ',a30) 352 format ('NetCDF variable name for 350 mb gp height = ',a30) 354 format ('NetCDF variable name for 300 mb gp height = ',a30) 355 format ('NetCDF variable name for time = ',a30) 356 format ('NetCDF variable name for longitudes = ',a30) 358 format ('NetCDF variable name for latitudes = ',a30) 359 format ('NetCDF time value (hours|days) = ',a30) print *,' ' print *,' ' print *,'Values read in from parmpreflist namelist: ' print *,' ' write (6,402) user_wants_to_track_zeta850 write (6,404) user_wants_to_track_zeta700 write (6,406) user_wants_to_track_wcirc850 write (6,408) user_wants_to_track_wcirc700 write (6,410) user_wants_to_track_gph850 write (6,412) user_wants_to_track_gph700 write (6,414) user_wants_to_track_mslp write (6,416) user_wants_to_track_wcircsfc write (6,418) user_wants_to_track_zetasfc write (6,420) user_wants_to_track_thick500850 write (6,422) user_wants_to_track_thick200500 write (6,424) user_wants_to_track_thick200850 402 format ('user_wants_to_track_zeta850= ',a2) 404 format ('user_wants_to_track_zeta700= ',a2) 406 format ('user_wants_to_track_wcirc850= ',a2) 408 format ('user_wants_to_track_wcirc700= ',a2) 410 format ('user_wants_to_track_gph850= ',a2) 412 format ('user_wants_to_track_gph700= ',a2) 414 format ('user_wants_to_track_mslp= ',a2) 416 format ('user_wants_to_track_wcircsfc= ',a2) 418 format ('user_wants_to_track_zetasfc= ',a2) 420 format ('user_wants_to_track_thick500850= ',a2) 422 format ('user_wants_to_track_thick200500= ',a2) 424 format ('user_wants_to_track_thick200850= ',a2) print *,' ' print *,'Values read in from phaseinfo namelist: ' write (6,211) phaseflag,phasescheme write (6,212) wcore_depth 211 format ('Storm phase flag = ',a1,' Phase scheme = ',a4) 212 format ('Storm phase, warm core depth (wcore_depth) = ',f7.2) print *,' ' print *,'Values read in from structinfo namelist: ' write (6,93) structflag write (6,95) ikeflag 93 format ('Structure flag = ',a1) 95 format ('IKE flag = ',a1) print *,' ' print *,'Values read in for grib file name from fnameinfo' & ,' namelist: ' write (6,131) gmodname write (6,133) rundescr write (6,135) atcfdescr 131 format ('Model name description = gmodname = ',a4) 133 format ('Forecast run description = rundescr = ',a40) 135 format ('Optional ATCF / Storm name description = atcfdescr = ' & ,a40) print *,' ' print *,'Value read in for verbose output for most output:' write (6,141) verb 141 format ('Value read in for verbose flag = verb = ',i2) print *,' ' print *,'Value read in for verbose output for grib2 output:' write (6,142) verb_g2 142 format ('Value read in for GRIB2 verbose flag = verb_g2 = ',i2) print *,' ' print *,'Values read in from waitinfo namelist:' write (6,151) use_waitfor write (6,152) wait_min_age write (6,153) wait_min_size write (6,154) wait_max_wait write (6,155) wait_sleeptime if(len_trim(per_fcst_command)>0) then write (6,156) trim(per_fcst_command) else c No command specified, so disable the feature use_per_fcst_command='n' endif 151 format ('Flag for input file waiting = use_waitfor = ',a1) 152 format ('min age (time in seconds since last mod) = ' & ,'wait_min_age = ',i8) 153 format ('min file size in bytes = wait_min_size = ',i12) 154 format ('max number of seconds to wait for each file = ' & ,'wait_max_wait = ',i6) 155 format ('number of seconds to sleep between checks = ' & ,'wait_sleeptime = ',i6) 156 format ('command to run after every forecast time = "',A,'"') c if (use_waitfor == 'y') then if (inp%file_seq == 'multi') then continue else print *,' ' print *,'!!! ERROR: The use_waitfor flag is set to "y".' print *,' This requires that the inp%file_seq flag be' print *,' set to "multi", but you have specified ' print *,' something else. ' print *,' inp%file_seq = ',inp%file_seq print *,' STOPPING....' print *,' ' STOP 95 endif endif c endif return end c--------------------------------------------------------------------- c c--------------------------------------------------------------------- subroutine read_fhours (ifhmax) c c ABSTRACT: This subroutine reads in a text file that contains the c forecast times that will be read in. The format of the file is c in "MMMMM", i.e., minutes, for example, for a forecast going out c to 120h, the file would look like this: c c For reference, here c are the times that c match up with the c minutes on the left: c c 1 0 0:00 c 2 240 4:00 c 3 270 4:30 c 4 300 5:00 c 5 330 5:30 c 6 360 6:00 c 7 600 10:00 c 8 630 10:30 c 9 660 11:00 c 10 690 11:30 c 11 720 12:00 c 12 960 16:00 c 13 990 16:30 c . . . c . . . c . . . c 87 7200 120:00 c c Note that we are now allowing for sub-hourly time intervals. c USE tracked_parms USE verbose_output implicit none c integer, parameter :: iunit_fh=15 integer itmphrs(750),itmpmins(750),input_mins(750),itmpltix(750) integer ifhmax,inphr,inpmin,ict,i,ifa,ifma,icma,ira,inpltix,ila real xminfract itmphrs = -99 itmpmins = -99 if (allocated(ifhours)) deallocate (ifhours) if (allocated(iftotalmins)) deallocate (iftotalmins) if (allocated(ifclockmins)) deallocate (ifclockmins) if (allocated(fhreal)) deallocate (fhreal) if (allocated(ltix)) deallocate (ltix) ict = 0 do while (.true.) if ( verb .ge. 3 ) then print *,'Top of while loop in read_fhours' endif read (iunit_fh,85,end=130) inpltix,inpmin write (6,85) inpltix,inpmin if (inpmin >= 0 .and. inpmin < 150000) then ict = ict + 1 itmpltix(ict) = inpltix itmphrs(ict) = inpmin / 60 itmpmins(ict) = mod(inpmin,60) input_mins(ict) = inpmin else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: Input minutes not between 0 and 150000' print *,'!!! inpmin= ',inpmin print *,'!!! STOPPING EXECUTION' endif STOP 91 endif if ( verb .ge. 3 ) then print *,'readloop, ict= ',ict,' inpmin= ',inpmin endif enddo 130 continue ifhmax = ict 85 format (i4,1x,i5) if ( verb .ge. 3 ) then print *,' ' endif allocate (ifhours(ifhmax),stat=ifa) allocate (iftotalmins(ifhmax),stat=ifma) allocate (ifclockmins(ifhmax),stat=icma) allocate (fhreal(ifhmax),stat=ira) allocate (ltix(ifhmax),stat=ila) if (ifa /= 0 .or. ifma /= 0 .or. icma /= 0 .or. ira /= 0 .or. & ila /= 0) then if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in read_fhours allocating either ifhours,' print *,'!!! iftotalmins, ifclockmins or fhreal.' print *,'!!! ifa = ',ifa,' ifma= ',ifma,' ira= ',ira print *,'!!! icma= ',icma,' ila= ',ila print *,'!!! STOPPING EXECUTION' endif STOP 91 endif do i = 1,ifhmax ltix(i) = itmpltix(i) xminfract = float(itmpmins(i)) / 60. fhreal(i) = float(itmphrs(i)) + xminfract ifhours(i) = itmphrs(i) ifclockmins(i) = itmpmins(i) iftotalmins(i) = input_mins(i) if (i > 1) then if (fhreal(i) > fhreal(i-1)) then continue else if ( verb .ge. 3 ) then print *,' ' print *,'!!! ERROR: In read_fhours, the time read in ' print *,'!!! is not greater than the previous time.' print *,'!!! i= ',i print *,'!!! fhreal(i)= ',fhreal(i) print *,'!!! fhreal(i-1)= ',fhreal(i-1) print *,'!!! STOPPING EXECUTION' endif STOP 91 endif endif if ( verb .ge. 3 ) then write (6,87) i,ltix(i),iftotalmins(i),fhreal(i),ifhours(i) & ,ifclockmins(i) endif enddo 87 format (1x,'i= ',i3,' input lead time index= ',i4,' minutes= ' & ,i5,' real_lead_time= ',f6.2,' clock_lead_time= ',i3,':' & ,i2) c return end c c--------------------------------------------------------------------- c c--------------------------------------------------------------------- subroutine read_tcv_card1 (lucard,maxstorm,trkrinfo,numtcv,iret) c c ABSTRACT: This subroutine reads in the updated TC Vitals file c for the current time and prints out those cards (storms) c that have been selected to be processed. It also c takes the initial positions from the tcv card for each c storm and puts them into the slonfg & slatfg arrays. c Note that this routine is reading in vitals in the c standard format for TCs only. Any genesis vitals are c read in in subroutine read_gen_vitals. c c INPUT: c lucard integer unit number for tcvitals card c trkrinfo derived type that contains info on the type of c tracker run that we are performing. c c OUTPUT: c maxstorm max # of storms to be handled for this case c numtcv number of storms read off of the input tcvitals file c iret return code from this subroutine c c OTHER: c stormswitch 1,2 or 3 (see more description under Main pgm section) c slonfg first guess array for longitude c slatfg first guess array for latitude c storm contains the tcvitals info c (storm, stormswitch, slonfg and slatfg are allocatable and are c defined in module def_vitals) USE def_vitals; USE set_max_parms; USE trkrparms USE verbose_output implicit none logical(1) :: vit_file_exists type (tcvcard) tmpstorm(maxstorm_tc) type (trackstuff) trkrinfo integer isa,issa,ioa,iaa,ita,iret,ict,maxstorm integer i,ii,lucard,numtcv c------ ! Check to see if the TC Vitals file exists. If so, then open it ! using the unit specified in lucard. inquire (file="tcvit_rsmc_storms.txt",exist=vit_file_exists) if (vit_file_exists) then if ( verb .ge. 3 ) then print *,' ' print *,'+++ TC Vitals file for existing, RSMC-numbered' & ,' storms exists and will be opened with ' & ,' unit= lucard= ',lucard endif open (unit=lucard,file="tcvit_rsmc_storms.txt",status='old' & ,err=887) if ( verb .ge. 3 ) then print *,' ' print *,'+++ TC vitals file tcvit_rsmc_storms.txt has ' print *,' been opened with unit= lucard= ',lucard endif else if (trkrinfo%type == 'tracker') then if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in read_tcv_card. The fortran inquire' print *,'!!! statement indicates that the tcvitals file for' print *,'!!! already-existing, RSMC-numbered storms does ' print *,'!!! NOT exist. This TC Vitals file is needed for' print *,'!!! a tracker case. Check to see that the ' print *,'!!! TC Vitals file exists in this directory and' print *,'!!! is named tcvit_rsmc_storms.txt' print *,'!!! STOPPING....' print *,'!!! ' iret=99 return endif else if ( verb .ge. 1 ) then print *,' ' print *,'!!! NOTE: In read_tcv_card, the fortran inquire' print *,'!!! statement indicates that the tcvitals file for' print *,'!!! already-existing, RSMC-numbered storms does ' print *,'!!! NOT exist. While this TC Vitals file is ' print *,'!!! needed for tracker cases, you are running' print *,'!!! either a midlat or tcgen case here, and so ' print *,'!!! that file is not needed... although you can ' print *,'!!! run with using tc vitals for those genesis' print *,'!!! cases if you want to. You may want to check' print *,'!!! and make sure this is what you intend. If ' print *,'!!! you do want to use it, the TC Vitals file ' print *,'!!! should be in this directory and it should be' print *,'!!! named tcvit_rsmc_storms.txt' print *,'!!! ' endif endif endif ii=1 if (vit_file_exists) then do while (.true. .and. ii <= maxstorm_tc) read (lucard,21,END=801,ERR=891) tmpstorm(ii) ii = ii + 1 enddo 21 format (a4,1x,a3,1x,a9,1x,i8,1x,i4,1x,i3,a1,1x,i4,a1,1x,i3,1x & ,i3,3(1x,i4),1x,i2,1x,i3,1x,4(i4,1x),a1) 801 continue endif numtcv = ii - 1 if (trkrinfo%type == 'midlat' .or. trkrinfo%type == 'tcgen') then ! For the mid-latitude or tc genesis cases, the max number ! of storms (maxstorm) allowed to be tracked throughout a ! forecast is defined in module set_max_parms. if ( verb .ge. 3 ) then print *,' ' print *,'In read_tcv_card, tracker type of "midlat" or ' print *,'"tcgen" indicates that this run of the tracker is' print *,'for a midlat or a tcgen case....' endif maxstorm = maxstorm_mg allocate (stormswitch(maxstorm),stat=isa) allocate (storm(maxstorm),stat=issa) allocate (slonfg(maxstorm,maxtime),stat=ioa) allocate (slatfg(maxstorm,maxtime),stat=iaa) allocate (stcvtype(maxstorm),stat=ita) if (isa /= 0 .or. ioa /= 0 .or. iaa /= 0 .or. issa /= 0 .or. & ita /= 0) then if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in read_tcv_card allocating stormswitch,' print *,'!!! slonfg, storm, slatfg or stcvtype arrays. ' print *,'!!! isa = ',isa,' ioa= ',ioa,' iaa= ',iaa,' issa= ' print *,'!!! ',issa,' ita= ',ita endif iret = 97 return endif slonfg = 0.0; slatfg = 0.0 stcvtype = 'FOF' ! Found On the Fly by tracker (not on tcvitals) stormswitch = 3 ! Initialize whole array to case of '3' if (numtcv > 0) then if ( verb .ge. 3 ) then print *,' ' print *,'Following are the already-existing storms that' print *,'were read in from the tc vitals file: ' print *,' ' endif ict = 0 do i=1,numtcv stormswitch(i) = 1 storm(i) = tmpstorm(i) ict = ict + 1 if ( verb .ge. 3 ) then write (*,31) storm(i) endif if (storm(i)%tcv_lonew == 'W') then slonfg(i,1) = 360. - float(storm(i)%tcv_lon)/10.0 else slonfg(i,1) = float(storm(i)%tcv_lon)/10.0 endif if (storm(i)%tcv_latns == 'S') then slatfg(i,1) = -1. * float(storm(i)%tcv_lat)/10.0 else slatfg(i,1) = float(storm(i)%tcv_lat)/10.0 endif stcvtype(i) = 'TCV' ! Storm listed on tcvitals c if (trkrinfo%type == 'midlat') then c storm(i)%tcv_center = 'MIDL' c else if (trkrinfo%type == 'tcgen') then c storm(i)%tcv_center = 'TCG ' c endif c write (storm(i)%tcv_storm_id,'(i4.4)') i c write (storm(i)%tcv_storm_name,'(i4.4)') i enddo endif iret=0 return else ! For the tracker cases, the max number of storms (maxstorm) ! allowed to be tracked throughout a forecast is defined by ! the number of vitals read in above. maxstorm = numtcv if (maxstorm > 0) then continue else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in read_tcv_card, num storms to be ' print *,'!!! processed is not greater than 0 for a tracker' print *,'!!! case. Check to see that the TC Vitals file' print *,'!!! has been created and exists in the working' print *,'!!! directory. That TC vitals file should be' print *,'!!! named tcvit_rsmc_storms.txt' print *,'!!! STOPPING...' print *,'!!! ' iret=99 return endif endif allocate (stormswitch(maxstorm),stat=isa) allocate (storm(maxstorm),stat=issa) allocate (slonfg(maxstorm,maxtime),stat=ioa) allocate (slatfg(maxstorm,maxtime),stat=iaa) allocate (stcvtype(maxstorm),stat=ita) if (isa /= 0 .or. ioa /= 0 .or. iaa /= 0 .or. issa /= 0 .or. & ita /= 0) then if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in read_tcv_card allocating stormswitch,' print *,'!!! slonfg, storm, slatfg or stcvtype arrays. ' print *,'!!! isa = ',isa,' ioa= ',ioa,' iaa= ',iaa,' issa= ' print *,'!!! ',issa,' ita= ',ita endif iret = 97 return endif if ( verb .ge. 3 ) then print *,' ' print *,'Following are the storms to be processed: ' print *,' ' endif slonfg = 0.0; slatfg = 0.0 stcvtype = ' ' ! Not needed for regular tracker run.... ict=0 do i=1,maxstorm stormswitch(i) = 1 storm(i) = tmpstorm(i) ict = ict + 1 if ( verb .ge. 3 ) then write (*,31) storm(i) endif if (storm(i)%tcv_lonew == 'W') then slonfg(i,1) = 360. - float(storm(i)%tcv_lon)/10.0 else slonfg(i,1) = float(storm(i)%tcv_lon)/10.0 endif if (storm(i)%tcv_latns == 'S') then slatfg(i,1) = -1. * float(storm(i)%tcv_lat)/10.0 else slatfg(i,1) = float(storm(i)%tcv_lat)/10.0 endif enddo if (ict.gt.0) then iret = 0 return else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in read_tcv_card, num storms to be ' print *,'!!! processed is not greater than 0 for a tracker' print *,'!!! case. Check to see that the TC Vitals file' print *,'!!! has been created and exists in the working' print *,'!!! directory. That TC vitals file should be' print *,'!!! named tcvit_rsmc_storms.txt' print *,'!!! Stopping....' print *,' ' endif iret = 99 return endif endif 31 format (a4,1x,a3,1x,a9,1x,i8.8,1x,i4.4,1x,i3,a1,1x,i4,a1,1x & ,i3,1x,i3,3(1x,i4),1x,i2,1x,i3,1x,4(i4,1x),a1) 887 continue if ( verb .ge. 1 ) then print *,'!!! ERROR in read_tcv_card opening rsmc TC vitals' print *,'!!! file named tcvit_rsmc_storms.txt. A file with' print *,'!!! that name needs to be in your working directory.' print *,'!!! It should contain the input TC vitals for ' print *,'!!! already-existing storms that have rsmc-issued' print *,'!!! storm IDs.' endif iret = 97 return 891 continue if ( verb .ge. 1 ) then print *,'!!! ERROR in read_tcv_card reading unit ',lucard endif iret = 98 c return end c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine read_gen_vitals1(lgvcard,maxstorm,trkrinfo,numtcv,iret) c c ABSTRACT: This subroutine reads in a modified TC Vitals file c for the current time and prints out those cards (storms) that c have been selected to be processed. It also takes the initial c positions from the tcv card for each storm and puts them into c the slonfg & slatfg arrays. c c The reason that these are referred to as modified tcvitals is c that the format is different from standard TC vitals format. c These vitals are created by a previous run of this tracker c executable, and the storm identifier is different than that c for a standard tcvitals. The storm c identifier contains the date/time that the storm was first c identified, and the lat/lon position at which it was first c identified. c c EXAMPLE: The following is a standard TC Vitals record, split c up over 3 lines: c c NHC 01L ALBERTO 20060614 1200 343N 0807W 035 093 1004 1012 c 0278 15 222 -999 -999 -999 -999 M -999 -999 -999 -999 72 c 520N 410W -999 -999 -999 -999 c c EXAMPLE: The following is the format for the "genesis" vitals, c split over 3 lines, for the same system: c c 2006061000_F000_210N_0853W_01L 20060614 1200 343N 0807W 035 093 c 1004 1012 0278 15 222 -999 -999 -999 -999 M -999 -999 c -999 -999 72 520N 410W -999 -999 -999 -999 c c EXAMPLE: If the vitals record is for a non-officially numbered c system (i.e., any system that's not a TC being tracked c by NHC or JTWC), then the storm number is replaced c by the characters "FOF", for "Found On the Fly" by c the tracker. c c 2006071500_F000_150N_0681W_FOF 20060718 1200 185N 0792W 035 093 c 1004 1012 0278 15 222 -999 -999 -999 -999 M -999 -999 c -999 -999 72 520N 410W -999 -999 -999 -999 c c NOTE: The "F000" in there at character positions 12-15 are to c indicate the forecast hour within that forecast cycle c that the storm was first detected. For a vitals record, c this is always going to be 000 for fhr=0h, and really, c it's not even needed. However, I'm keeping it in there c in order to keep the storm ID format exactly the same c as the output_atcf_sink forecast track record, which c does have a use for that "FXXX" identifier in the c output. c c INPUT: c lgvcard integer unit number for tcgen-tcvitals card c c OUTPUT: c maxstorm max # of storms to be handled for this case c iret return code from this subroutine c c INPUT/OUTPUT: c numtcv As an input, this variable contains the number of c *tropical* cyclone vitals (i.e., regular tcvitals) that c were read off of the input tcvitals file in subroutine c read_tcv_card. This variable will be incremented for c each "modified" vitals record that is read in this c subroutine, and so as output, this variable will c contain the combined total of tcvitals and modified c vitals records. c c OTHER: c stormswitch 1,2 or 3 (see more description under Main pgm section) c slonfg first guess array for longitude c slatfg first guess array for latitude c storm contains the tcvitals info c (storm, stormswitch, slonfg and slatfg are allocatable and are c defined in module def_vitals) c USE def_vitals; USE set_max_parms; USE trkrparms; USE gen_vitals USE verbose_output implicit none type (gencard) tmpstorm(maxstorm_mg) type (trackstuff) trkrinfo logical(1) :: vit_file_exists integer iret,maxstorm integer i,ii,lgvcard,numtcv,num_mod_vit,vitix,iga c------ ! Check to see if the genesis TC Vitals file exists. If so, then ! open it using the unit specified in lgvcard. inquire (file="tcvit_genesis_storms.txt",exist=vit_file_exists) if (vit_file_exists) then if ( verb .ge. 3 ) then print *,' ' print *,'+++ TC Vitals file for genesis' & ,' storms exists and will be opened with ' & ,' unit= lgvcard= ',lgvcard endif open (unit=lgvcard,file="tcvit_genesis_storms.txt",status='old' & ,err=887) if ( verb .ge. 3 ) then print *,' ' print *,'+++ TC vitals file tcvit_genesis_storms.txt has ' print *,' been opened with unit= lgvcard= ',lgvcard endif endif ! Read in all of the "genesis vitals" into a temp array. The ! index for the first array member is one past the number of ! tc vitals that were read in in subroutine read_tcv_card. ii = numtcv + 1 if (vit_file_exists) then do while (.true. .and. ii <= maxstorm_mg) read (lgvcard,24,END=801,ERR=891) tmpstorm(ii) ii = ii + 1 enddo 24 format (i10,2x,i3,1x,i3,a1,1x,i4,a1,1x,a3,1x,i8,1x,i4,1x,i3,a1 & ,1x,i4,a1,1x,i3,1x,i3,3(1x,i4),1x,i2,1x,i3,1x,4(i4,1x),a1) 801 continue endif num_mod_vit = ii - numtcv - 1 allocate (gstorm(maxstorm_mg),stat=iga) if (iga /= 0) then if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in read_gen_vitals allocating gstorm array' print *,'!!! iga = ',iga endif iret = 97 return endif ! Initialize all "genesis dates" to 99999. Any new genesis ! vitals that are read in below will bring in real dates, and ! then we can test the date in output_gen_vitals to know if a ! storm was already defined or not at the beginning of this ! executable or if it was a new storm that was found. do i = 1,maxstorm_mg gstorm(i)%gv_gen_date = 99999 enddo ! If there are any TC vitals (i.e., officially named TCs ! that are being numbered/tracked by either NHC or JTWC), then ! we want to take the important information from those vitals ! and put that into genesis vitals. This will enable us to ! output *all* of these systems in the "gen_vitals" or ! "gstorm" format. The one difference here is that for the ! genesis date, we use the starting date of this forecast, not ! the time that the storm first formed. Also, set the genesis ! forecast hour (gv_gen_fhr) to be 0 for TCs that have a ! TC vitals record. if (numtcv > 0) then do i = 1,numtcv gstorm(i)%gv_gen_date = storm(i)%tcv_ymd * 100 + & storm(i)%tcv_hhmm / 100 gstorm(i)%gv_gen_fhr = 0 gstorm(i)%gv_gen_lat = storm(i)%tcv_lat gstorm(i)%gv_gen_latns = storm(i)%tcv_latns gstorm(i)%gv_gen_lon = storm(i)%tcv_lon gstorm(i)%gv_gen_lonew = storm(i)%tcv_lonew gstorm(i)%gv_gen_type = storm(i)%tcv_storm_id gstorm(i)%gv_obs_ymd = storm(i)%tcv_ymd gstorm(i)%gv_obs_hhmm = storm(i)%tcv_hhmm gstorm(i)%gv_obs_lat = storm(i)%tcv_lat gstorm(i)%gv_obs_latns = storm(i)%tcv_latns gstorm(i)%gv_obs_lon = storm(i)%tcv_lon gstorm(i)%gv_obs_lonew = storm(i)%tcv_lonew if ( verb .ge. 3 ) then write (*,34) gstorm(i) endif enddo endif if (num_mod_vit > 0) then if ( verb .ge. 3 ) then print *,' ' print *,'Following are the vitals for storms that were' print *,'read in from the modified (genesis) tc vitals file: ' print *,' ' endif do i=1,num_mod_vit vitix = i + numtcv stormswitch(vitix) = 1 ! On the following line we are filling the array gstorm, ! which is new in this subroutine. Note, however, that we ! are not necessarily starting it at 1, but at the point in ! the array after any TC Vitals may have been read in. gstorm(vitix) = tmpstorm(vitix) if ( verb .ge. 3 ) then write (*,34) gstorm(vitix) endif ! For the sake of consistency (and sanity!!), we need to also ! use the same "storm" array as was used in read_tcv_card, ! since this "storm" array is used often throughout the rest ! of this executable. write (storm(vitix)%tcv_storm_id,'(i4.4)') vitix write (storm(vitix)%tcv_storm_name,'(i4.4)') vitix storm(vitix)%tcv_ymd = gstorm(vitix)%gv_obs_ymd storm(vitix)%tcv_hhmm = gstorm(vitix)%gv_obs_hhmm storm(vitix)%tcv_lat = gstorm(vitix)%gv_obs_lat storm(vitix)%tcv_latns = gstorm(vitix)%gv_obs_latns storm(vitix)%tcv_lon = gstorm(vitix)%gv_obs_lon storm(vitix)%tcv_lonew = gstorm(vitix)%gv_obs_lonew storm(vitix)%tcv_stdir = gstorm(vitix)%gv_stdir storm(vitix)%tcv_stspd = gstorm(vitix)%gv_stspd if (trkrinfo%type == 'midlat') then storm(vitix)%tcv_center = 'MIDL' else if (trkrinfo%type == 'tcgen') then storm(vitix)%tcv_center = 'TCG ' endif if (gstorm(vitix)%gv_obs_lonew == 'W') then slonfg(vitix,1) = 360. - float(gstorm(vitix)%gv_obs_lon) & / 10.0 else slonfg(vitix,1) = float(gstorm(vitix)%gv_obs_lon)/10.0 endif if (gstorm(vitix)%gv_obs_latns == 'S') then slatfg(vitix,1) = -1. * float(gstorm(vitix)%gv_obs_lat)/10.0 else slatfg(vitix,1) = float(gstorm(vitix)%gv_obs_lat)/10.0 endif stcvtype(vitix) = 'FOF' ! Storm "Found On the Fly" by tracker enddo endif 34 format (i10,1x,'F',i3.3,1x,i3.3,a1,1x,i4.4,a1,1x,a3,1x,i8,1x,i4.4 & ,1x,i3.3,a1,1x,i4.4,a1,1x,i3,1x,i3,3(1x,i4),1x,i2,1x,i3,1x & ,4(i4,1x),a1) c Update the total number of vitals that have been read in numtcv = numtcv + num_mod_vit goto 895 c 887 continue if ( verb .ge. 1 ) then print *,'!!! ERROR in read_gen_vitals opening genesis vitals' print *,'!!! file named tcvit_genesis_storms.txt' endif iret = 97 return 891 continue if ( verb .ge. 1 ) then print *,'!!! ERROR in read_gen_vitals reading unit ',lgvcard endif iret = 98 895 continue c return end c c--------------------------------------------------------------------- c c--------------------------------------------------------------------- subroutine getgridinfo_grib (imax,jmax,ifh,dx,dy,lugb,lugi & ,trkrinfo,need_to_flip_lats,need_to_flip_lons & ,inp,iggret) c c ABSTRACT: The purpose of this subroutine is just to get the max c values of i and j and the dx and dy grid spacing intervals for the c grid to be used in the rest of the program. So just read the c grib file to get the lon and lat data. Also, get the info for c the data grid's boundaries. This boundary information will be c used later in the tracking algorithm, and is accessed via Module c grid_bounds. c USE grid_bounds; USE trkrparms; USE tracked_parms; USE inparms USE verbose_output; USE params; USE grib_mod implicit none type (trackstuff) trkrinfo type (datecard) inp type(gribfield) :: gfld,prevfld,holdgfld logical(1) :: need_to_flip_lats,need_to_flip_lons logical(1), allocatable :: lb(:) logical :: unpack=.true. logical :: open_grb=.false. CHARACTER(len=8) :: pabbrev integer,dimension(200) :: jids,jpdt,jgdt integer, parameter :: jf=40000000 integer :: listsec1(13) integer pdt_4p0_vert_level,pdt_4p0_vtime real xhold,xlondiff,xlatdiff,temp,firstval,lastval real, allocatable :: f(:) real, allocatable :: tmplon(:),tmplat(:) real, intent(out) :: dx,dy integer jpds(200),jgds(200),igetpds(200),igetgds(200) integer, intent(in) :: ifh integer, intent(out) :: imax,jmax integer iia,ija,ila,midi,midj,i,j,iix,jix,ifa,iret integer iscanflag,iggret,kf,k,lugb,lugi,jskp,jdisc integer jpdtn,jgdtn,npoints,icount,ipack,krec integer :: listsec0(2)=(/0,2/) integer :: igds(5)=(/0,0,0,0,0/),previgds(5) integer :: idrstmpl(200) integer :: currlen=1000000 iggret = 0 allocate (lb(jf),stat=ila); allocate (f(jf),stat=ifa) if (ila /= 0 .or. ifa /= 0) then if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in getgridinfo allocating either lb or f' print *,'!!! ila = ',ila,' ifa= ',ifa endif iggret = 97 return endif if (trkrinfo%gribver == 2) then ! Search for a record from a GRIB2 file ! ! --- Initialize Variables --- ! gfld%idsect => NULL() gfld%local => NULL() gfld%list_opt => NULL() gfld%igdtmpl => NULL() gfld%ipdtmpl => NULL() gfld%coord_list => NULL() gfld%idrtmpl => NULL() gfld%bmap => NULL() gfld%fld => NULL() jdisc=0 ! meteorological products jids=-9999 jpdtn=trkrinfo%g2_jpdtn ! 0 = analysis or forecast; 1 = ens fcst jgdtn=0 ! lat/lon grid jgdt=-9999 jpdt=-9999 npoints=0 icount=0 jskp=0 c Search for Temperature or GP Height by production template.... JPDT(1:15)=(/-9999,-9999,-9999,-9999,-9999,-9999,-9999 & ,-9999,-9999,-9999,-9999,-9999,-9999,-9999,-9999/) ! Request a record on a lat/lon grid. jgdtn = 0 ! Request a record at the current forecast lead time. if (inp%lt_units == 'minutes') then jpdt(8) = 0 jpdt(9) = iftotalmins(ifh) else jpdt(8) = 1 jpdt(9) = ifhours(ifh) endif if (verb >= 3) then print *,'before getgb2 call, lugb= ',lugb,' lugi= ',lugi endif call getgb2(lugb,lugi,jskp,jdisc,jids,jpdtn,jpdt,jgdtn,jgdt & ,unpack,krec,gfld,iret) if ( iret.ne.0) then print *,' ' print *,' ERROR: getgb2 error in getgridinfo = ',iret print *,' FATAL ERROR: cannot proceed without info ' print *,' from getgridinfo. STOPPING....' stop 95 endif c Determine packing information from GRIB2 file c The default packing is 40 JPEG 2000 ipack = 40 if ( verb_g2 .ge. 1 ) then print *,' ' print *,' -- BEGIN getgridinfo diagnostics for GRIB2 file ---' print *,' -- at ifh= ',ifh print *,' ' print *,' gfld%idrtnum = ', gfld%idrtnum endif ! Set DRT info ( packing info ) if ( gfld%idrtnum.eq.0 ) then ! Simple packing ipack = 0 elseif ( gfld%idrtnum.eq.2 ) then ! Complex packing ipack = 2 elseif ( gfld%idrtnum.eq.3 ) then ! Complex & spatial packing ipack = 31 elseif ( gfld%idrtnum.eq.40.or.gfld%idrtnum.eq.15 ) then ! JPEG 2000 packing ipack = 40 elseif ( gfld%idrtnum.eq.41 ) then ! PNG packing ipack = 41 endif if ( verb_g2 .ge. 1 ) then print *,'After check of idrtnum, ipack= ',ipack print *,'Number of gridpts= gfld%ngrdpts= ',gfld%ngrdpts print *,'Number of elements= gfld%igdtlen= ',gfld%igdtlen print *,'PDT num= gfld%ipdtnum= ',gfld%ipdtnum print *,'GDT num= gfld%igdtnum= ',gfld%igdtnum endif imax = gfld%igdtmpl(8) jmax = gfld%igdtmpl(9) dx = float(gfld%igdtmpl(17))/1.e6 dy = float(gfld%igdtmpl(17))/1.e6 kf = gfld%ngrdpts holdgfld = gfld if (verb_g2 .ge. 1) then print *,' ' print *,' SECTION 0: discipl= ',gfld%discipline & ,' gribver= ',gfld%version print *,' ' print *,' SECTION 1: ' do j = 1,gfld%idsectlen print *,' sect1, j= ',j,' gfld%idsect(j)= ' & ,gfld%idsect(j) enddo if ( associated(gfld%local).AND.gfld%locallen.gt.0) then print *,' ' print *,' SECTION 2: ',gfld%locallen,' bytes' else print *,' ' print *,' SECTION 2 DOES NOT EXIST IN THIS RECORD' endif print *,' ' print *,' SECTION 3: griddef= ',gfld%griddef print *,' ngrdpts= ',gfld%ngrdpts print *,' numoct_opt= ',gfld%numoct_opt print *,' interp_opt= ',gfld%interp_opt print *,' igdtnum= ',gfld%igdtnum print *,' igdtlen= ',gfld%igdtlen print *,' ' print '(a17,i3,a2)',' GRID TEMPLATE 3.',gfld%igdtnum,': ' do j=1,gfld%igdtlen print *,' j= ',j,' gfld%igdtmpl(j)= ',gfld%igdtmpl(j) enddo c Get parameter abbrev for record that was retrieved print *,' ' print *,' PDT num (gfld%ipdtnum) = ',gfld%ipdtnum print *,' ' print '(a20,i3,a2)',' PRODUCT TEMPLATE 4.',gfld%ipdtnum,': ' do j=1,gfld%ipdtlen print *,' sect 4 j= ',j,' gfld%ipdtmpl(j)= ' & ,gfld%ipdtmpl(j) enddo endif pdt_4p0_vtime = gfld%ipdtmpl(9) pdt_4p0_vert_level = gfld%ipdtmpl(12) pabbrev=param_get_abbrev(gfld%discipline,gfld%ipdtmpl(1) & ,gfld%ipdtmpl(2)) firstval=gfld%fld(1) lastval=gfld%fld(kf) if (verb .ge. 3) then print *,' ' write (6,131) 131 format (' rec# param level byy bmm bdd bhh ' & ,'fhr npts firstval lastval') print '(i5,3x,a8,2x,6i5,2x,i8,4g12.4)' & ,krec,pabbrev,pdt_4p0_vert_level,gfld%idsect(6) & ,gfld%idsect(7),gfld%idsect(8),gfld%idsect(9) & ,pdt_4p0_vtime,gfld%ngrdpts,firstval,lastval cPENG & ,krec,pabbrev,pdt_4p0_vert_level/100,gfld%idsect(6) endif if (verb_g2 .ge. 1) then print *,' ' print *,' -- END getgridinfo diagnostics for GRIB2 file ---' print *,' -- at ifh= ',ifh print *,' ' print *,' ' print *,' ' endif need_to_flip_lons = .false. iscanflag = gfld%igdtmpl(19) if (mod(iscanflag,128) >= 64) then ! Input data is south to north... glatmin = float(gfld%igdtmpl(12))/1.e6 glatmax = float(gfld%igdtmpl(15))/1.e6 need_to_flip_lats = .true. else ! Input data is north to south... glatmin = float(gfld%igdtmpl(15))/1.e6 glatmax = float(gfld%igdtmpl(12))/1.e6 need_to_flip_lats = .false. endif glonmin = float(gfld%igdtmpl(13))/1.e6 glonmax = float(gfld%igdtmpl(16))/1.e6 if (verb .ge. 3) then print *,'In getgridinfo: glatmin= ',glatmin print *,' glatmax= ',glatmax print *,' glonmin= ',glonmin print *,' glonmax= ',glonmax endif else !------------------------------------------ ! Search for a record from a GRIB1 file !------------------------------------------ jpds = -1 jgds = -1 jgds(1) = 0 ! Request a record that's on a lat/lon grid if ( verb .ge. 3 ) then print *,'before getgb in getgridinfo, ifh= ',ifh write (6,402) ifhours(ifh),ifclockmins(ifh) 402 format (1x,'* Forecast hour: ',i4,':',i2.2) print *,' ifhours(ifh)= ',ifhours(ifh) print *,' iftotalmins(ifh)= ',iftotalmins(ifh) endif ! Request a record at the current forecast lead time. if (inp%lt_units == 'minutes') then jpds(14) = iftotalmins(ifh) else jpds(14) = ifhours(ifh) endif j=0 c jpds(14) = 0 ! test c write(*,980) jpds(1),jpds(2) write(*,981) jpds(3),jpds(4) write(*,982) jpds(5),jpds(6) write(*,983) jpds(7),jpds(8) write(*,984) jpds(9),jpds(10) write(*,985) jpds(11),jpds(12) write(*,986) jpds(13),jpds(14) write(*,987) jpds(15),jpds(16) write(*,988) jpds(17),jpds(18) write(*,989) jpds(19),jpds(20) write(*,990) jpds(21),jpds(22) write(*,991) jpds(23),jpds(24) write(*,992) jpds(25) write(*,880) jgds(1),jgds(2) write(*,881) jgds(3),jgds(4) write(*,882) jgds(5),jgds(6) write(*,883) jgds(7),jgds(8) write(*,884) jgds(9),jgds(10) write(*,885) jgds(11),jgds(12) write(*,886) jgds(13),jgds(14) write(*,887) jgds(15),jgds(16) write(*,888) jgds(17),jgds(18) write(*,889) jgds(19),jgds(20) write(*,890) jgds(21),jgds(22) 980 format(' jpds(1) = ',i7,' jpds(2) = ',i7) 981 format(' jpds(3) = ',i7,' jpds(4) = ',i7) 982 format(' jpds(5) = ',i7,' jpds(6) = ',i7) 983 format(' jpds(7) = ',i7,' jpds(8) = ',i7) 984 format(' jpds(9) = ',i7,' jpds(10) = ',i7) 985 format(' jpds(11) = ',i7,' jpds(12) = ',i7) 986 format(' jpds(13) = ',i7,' jpds(14) = ',i7) 987 format(' jpds(15) = ',i7,' jpds(16) = ',i7) 988 format(' jpds(17) = ',i7,' jpds(18) = ',i7) 989 format(' jpds(19) = ',i7,' jpds(20) = ',i7) 990 format(' jpds(21) = ',i7,' jpds(22) = ',i7) 991 format(' jpds(23) = ',i7,' jpds(24) = ',i7) 992 format(' jpds(25) = ',i7) 880 format(' jgds(1) = ',i7,' jgds(2) = ',i7) 881 format(' jgds(3) = ',i7,' jgds(4) = ',i7) 882 format(' jgds(5) = ',i7,' jgds(6) = ',i7) 883 format(' jgds(7) = ',i7,' jgds(8) = ',i7) 884 format(' jgds(9) = ',i7,' jgds(10) = ',i7) 885 format(' jgds(11) = ',i7,' jgds(12) = ',i7) 886 format(' jgds(13) = ',i7,' jgds(14) = ',i7) 887 format(' jgds(15) = ',i7,' jgds(16) = ',i7) 888 format(' jgds(17) = ',i7,' jgds(18) = ',i7) 889 format(' jgds(19) = ',i7,' jgds(20) = ',i7) 890 format(' jgds(20) = ',i7,' jgds(22) = ',i7) print *,'lugb= ',lugb,' lugi= ',lugi print *,'before ggi getgb jpds(14) = ',jpds(14) print *,'before ggi getgb jgds(1) = ',jgds(1) call getgb(lugb,lugi,jf,j,jpds,jgds, & kf,k,igetpds,igetgds,lb,f,iret) if (iret.ne.0) then if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in getgridinfo calling getgb' print *,'!!! Return code from getgb = iret = ',iret endif iggret = iret else iggret=0 imax = igetgds(2) jmax = igetgds(3) dx = float(igetgds(9))/1000. dy = float(igetgds(10))/1000. endif c write(*,780) igetpds(1),igetpds(2) c write(*,781) igetpds(3),igetpds(4) c write(*,782) igetpds(5),igetpds(6) c write(*,783) igetpds(7),igetpds(8) c write(*,784) igetpds(9),igetpds(10) c write(*,785) igetpds(11),igetpds(12) c write(*,786) igetpds(13),igetpds(14) c write(*,787) igetpds(15),igetpds(16) c write(*,788) igetpds(17),igetpds(18) c write(*,789) igetpds(19),igetpds(20) c write(*,790) igetpds(21),igetpds(22) c write(*,791) igetpds(23),igetpds(24) c write(*,792) igetpds(25) c write(*,680) igetgds(1),igetgds(2) c write(*,681) igetgds(3),igetgds(4) c write(*,682) igetgds(5),igetgds(6) c write(*,683) igetgds(7),igetgds(8) c write(*,684) igetgds(9),igetgds(10) c write(*,685) igetgds(11),igetgds(12) c write(*,686) igetgds(13),igetgds(14) c write(*,687) igetgds(15),igetgds(16) c write(*,688) igetgds(17),igetgds(18) c write(*,689) igetgds(19),igetgds(20) c write(*,690) igetgds(21),igetgds(22) c c 780 format(' kpds(1) = ',i7,' kpds(2) = ',i7) c 781 format(' kpds(3) = ',i7,' kpds(4) = ',i7) c 782 format(' kpds(5) = ',i7,' kpds(6) = ',i7) c 783 format(' kpds(7) = ',i7,' kpds(8) = ',i7) c 784 format(' kpds(9) = ',i7,' kpds(10) = ',i7) c 785 format(' kpds(11) = ',i7,' kpds(12) = ',i7) c 786 format(' kpds(13) = ',i7,' kpds(14) = ',i7) c 787 format(' kpds(15) = ',i7,' kpds(16) = ',i7) c 788 format(' kpds(17) = ',i7,' kpds(18) = ',i7) c 789 format(' kpds(19) = ',i7,' kpds(20) = ',i7) c 790 format(' kpds(21) = ',i7,' kpds(22) = ',i7) c 791 format(' kpds(23) = ',i7,' kpds(24) = ',i7) c 792 format(' kpds(25) = ',i7) c 680 format(' kgds(1) = ',i7,' kgds(2) = ',i7) c 681 format(' kgds(3) = ',i7,' kgds(4) = ',i7) c 682 format(' kgds(5) = ',i7,' kgds(6) = ',i7) c 683 format(' kgds(7) = ',i7,' kgds(8) = ',i7) c 684 format(' kgds(9) = ',i7,' kgds(10) = ',i7) c 685 format(' kgds(11) = ',i7,' kgds(12) = ',i7) c 686 format(' kgds(13) = ',i7,' kgds(14) = ',i7) c 687 format(' kgds(15) = ',i7,' kgds(16) = ',i7) c 688 format(' kgds(17) = ',i7,' kgds(18) = ',i7) c 689 format(' kgds(19) = ',i7,' kgds(20) = ',i7) c 690 format(' kgds(20) = ',i7,' kgds(22) = ',i7) if ( verb .ge. 3 ) then print *,' ' print *,'In getgridinfo, grid dimensions follow:' print *,'imax= ',imax,' jmax= ',jmax print *,' dx= ',dx,' dy= ',dy endif c ---------------------------------------------------------------- c Get boundaries of the data grid. NOTE: gds(4) is referred to in c GRIB documenatation as the "Latitude of origin", which might c imply "minimum Latitude". However, for the grids that we'll be c using in this program, the "Latitude of origin" will be listed c under gds(4) as the northernmost point (eg., in MRF, c gds(4) = 90), so for this program, use gds(4) as your max lat, c and gds(7) as your min lat. However, in case NCEP, UKMET or c ECMWF change their convention and begin flipping their grids, a c check is made to make sure that the max lat is not less than the c min lat. c c BUGFIX (August, 2001): It is possible to have an input grid c which goes from south to north (such as NAVGEM). In this case, c we flip the data in subroutine conv1d2d_real. However, the max c and min latitudes listed in the GRIB GDS will be confused, so we c need to check the value of the GRIB scanning mode flag here. need_to_flip_lons = .false. iscanflag = igetgds(11) if (mod(iscanflag,128) >= 64) then ! Input data is south to north... glatmin = float(igetgds(4))/1000. glatmax = float(igetgds(7))/1000. need_to_flip_lats = .true. else ! Input data is north to south... glatmin = float(igetgds(7))/1000. glatmax = float(igetgds(4))/1000. need_to_flip_lats = .false. endif glonmin = float(igetgds(5))/1000. glonmax = float(igetgds(8))/1000. endif c After this point in this subroutine, nothing is GRIB1 / GRIB2 c specific, so it does not need to be within the if/then c statement above that differentiated between GRIB / GRIB2. c17Jul2014 if (glonmin < 0.0) glonmin = 360. - abs(glonmin) c17Jul2014 if (glonmax < 0.0) glonmax = 360. - abs(glonmax) if (glonmin >= 0.0 .and. glonmax >= 0.0) then if (glonmin > glonmax) then if (verb .ge. 3) then print *,' ' print *,'ERROR: Badly notated longitude boundaries in ' print *,' GRIB PDS, because the min longitude ' print *,' (glonmin) is greater than the max ' print *,' longitude (glonmax) where both longitudes' print *,' are greater than 0.' print *,' glonmin= ',glonmin print *,' glonmax= ',glonmax print *,' !!! STOPPING....' stop 98 endif endif elseif (glonmin < 0.0 .and. glonmax >= 0.0) then ! An example of this is the MPAS data, which starts and ends ! at the dateline and is specified as glonmin=-179.875, ! glonmax=179.875. Convert to be positive and go from ! 180.125 to 539.875. if (verb .ge. 3) then print *,' ' print *,'NOTE: glonmin is < 0, glonmax > 0, so glonmin' print *,' will be converted to be > 0 and 360 will' print *,' be added to glonmax.' print *,' BEFORE CONVERSION: ' print *,' glonmin= ',glonmin print *,' glonmax= ',glonmax endif glonmin = 360. - abs(glonmin) glonmax = 360. + abs(glonmax) if (verb .ge. 3) then print *,' AFTER CONVERSION: ' print *,' glonmin= ',glonmin print *,' glonmax= ',glonmax endif elseif (glonmin < 0.0 .and. glonmax < 0.0) then ! Examples of this are GFDL and HWRF. In this case, make ! both glonmin and glonmax positive. if (verb .ge. 3) then print *,' ' print *,'NOTE: glonmin is < 0 and glonmax < 0, so both' print *,' will be converted to be > 0.' print *,' BEFORE CONVERSION: ' print *,' glonmin= ',glonmin print *,' glonmax= ',glonmax endif glonmin = 360. - abs(glonmin) glonmax = 360. - abs(glonmax) if (verb .ge. 3) then print *,' AFTER CONVERSION: ' print *,' glonmin= ',glonmin print *,' glonmax= ',glonmax endif elseif (glonmin >= 0.0 .and. glonmax < 0.0) then ! An example of this is the GFS data, which goes from ! glonmin=0.0 to glonmax=-0.5. Convert it here to go ! from glonmin=0.0 to glonmax=359.5 if (verb .ge. 3) then print *,' ' print *,'NOTE: glonmin is >= 0 and glonmax < 0, so' print *,' glonmax will be converted to be > 0.' print *,' BEFORE CONVERSION: ' print *,' glonmin= ',glonmin print *,' glonmax= ',glonmax endif glonmax = 360. - abs(glonmax) if (verb .ge. 3) then print *,' AFTER CONVERSION: ' print *,' glonmin= ',glonmin print *,' glonmax= ',glonmax endif endif c17Jul2014 if (glonmin < 0.0) then c17Jul2014 glonmin = 360. - abs(glonmin) c17Jul2014 if (glonmax <= 0.0) then c17Jul2014 glonmax = 360. - abs(glonmax) c17Jul2014 else c17Jul2014 glonmax = 360 + abs(glonmax) c17Jul2014 endif c17Jul2014 endif if (glatmax < glatmin) then temp = glatmax glatmax = glatmin glatmin = temp endif if (glonmin > 200.0 .and. glonmin <= 360.) then if (glonmax < 50.) then ! Likely GM-wrapping in current record glonmax = glonmax + 360. endif endif c if ( verb .ge. 3 ) then print *,' ' print *,'Data Grid Lat/Lon boundaries follow:' write (6,81) glatmin,glonmin 81 format (' Min Lat: ',f8.3,' Min Lon: ',f8.3) write (6,83) glatmax,glonmax 83 format (' Max Lat: ',f8.3,' Max Lon: ',f8.3) print *,' ' print *,'NOTE: For regional grids, valid data points might' print *,'NOT extend all the way to the gds-defined grid ' print *,'boundary, due to the fact that data have been ' print *,'interpolated from a NPS or Lamb-Conf grid onto a ' print *,'lat/lon grid. This program checks the logical ' print *,'bitmap for valid data points, but just keep this in' print *,'mind if trying to debug errors that occur near the' print *,'grid boundaries for regional models.' endif c ---------------------------------------------------------------- c Fill glat and glon with the lat & lon values for the grid. This c info will be used in subroutine barnes if (allocated(glat)) deallocate(glat) if (allocated(glon)) deallocate(glon) allocate (glat(jmax),stat=ija) allocate (glon(imax),stat=iia) if (ija /= 0 .or. iia /= 0) then if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in getgridinfo allocating glon or glat' print *,'!!! ija = ',ija,' iia= ',iia endif if (allocated(lb)) deallocate (lb,stat=ila) if (allocated(f)) deallocate (f,stat=ifa) if (ila /= 0 .or. ifa /= 0) then print *,' ' print *,'!!! ERROR in getgridinfo deallocating arrays.' print *,'!!! ila= ',ila,' ifa= ',ifa print *,'!!! EXITING....' stop 98 endif iggret = 96 return endif do j=1,jmax glat(j) = glatmax - (j-1)*dy enddo do i=1,imax glon(i) = glonmin + (i-1)*dx enddo if (allocated(lb)) deallocate (lb,stat=ila) if (allocated(f)) deallocate (f,stat=ifa) if (ila /= 0 .or. ifa /= 0) then print *,' ' print *,'!!! ERROR in getgridinfo deallocating arrays.' print *,'!!! ila= ',ila,' ifa= ',ifa print *,'!!! EXITING....' stop 98 endif c -------------------------------------------------------------- c Finally, check to see if the requested boundary limits that c the user input are contained within this grid (for example, c someone running this tracker on a regional grid may have c forgotten to change the input grid bounds from a global grid c run). Modify the user-input bounds as needed. c c NOTE: Only check these bounds for a genesis run on a regional c grid, whether that be a 'midlat' or a 'tcgen' run. if (trkrinfo%gridtype == 'regional' .and. & trkrinfo%type /= 'tracker') then if (trkrinfo%eastbd > glonmax) then xhold = trkrinfo%eastbd trkrinfo%eastbd = glonmax - 5.0 if ( verb .ge. 3 ) then write (6,90) write (6,91) write (6,92) write (6,93) write (6,94) write (6,95) write (6,96) write (6,97) 'EASTERN LONGITUDE' write (6,98) xhold write (6,99) trkrinfo%eastbd write (6,91) endif endif if (trkrinfo%westbd < glonmin) then xhold = trkrinfo%westbd trkrinfo%westbd = glonmin + 5.0 if ( verb .ge. 3 ) then write (6,90) write (6,91) write (6,92) write (6,93) write (6,94) write (6,95) write (6,96) write (6,97) 'WESTERN LONGITUDE' write (6,98) xhold write (6,99) trkrinfo%westbd write (6,91) endif endif if (trkrinfo%northbd > glatmax) then xhold = trkrinfo%northbd trkrinfo%northbd = glatmax - 5.0 if ( verb .ge. 3 ) then write (6,90) write (6,91) write (6,92) write (6,93) write (6,94) write (6,95) write (6,96) write (6,97) 'NORTHERN LATITUDE' write (6,98) xhold write (6,99) trkrinfo%northbd write (6,91) endif endif if (trkrinfo%southbd < glatmin) then xhold = trkrinfo%southbd trkrinfo%southbd = glatmin + 5.0 if ( verb .ge. 3 ) then write (6,90) write (6,91) write (6,92) write (6,93) write (6,94) write (6,95) write (6,96) write (6,97) 'SOUTHERN LATITUDE' write (6,98) xhold write (6,99) trkrinfo%southbd write (6,91) endif endif endif 90 format (///) 91 format (' *********************************************') 92 format (' WARNING: A USER-REQUESTED BOUNDARY IS BEYOND') 93 format (' THE BOUNDARY OF THE DATA, AS DEFINED IN THE ') 94 format (' GRIB FILE. THE USER BOUNDARY WILL BE MODIFIED') 95 format (' TO MATCH THE BOUNDARY OF THE DATA FILE.') 96 format (' ') 97 format (' USER-INPUT BOUNDARY AT FAULT: ',A20) 98 format (' USER-INPUT BOUNDARY VALUE: ',f8.2) 99 format (' NEW BOUNDARY VALUE: ',f8.2) c return end c c--------------------------------------------------------------------- c c--------------------------------------------------------------------- subroutine getgridinfo_netcdf (ncfile_id,imax,jmax,dx,dy & ,trkrinfo,need_to_flip_lats,need_to_flip_lons & ,inp,netcdfinfo,iggret) c c ABSTRACT: The purpose of this subroutine is just to get the max c values of i and j and the dx and dy grid spacing intervals for the c grid to be used in the rest of the program. So just query the c netcdf file to get the lon and lat data. Also, get the info for c the data grid's boundaries. This boundary information will be c used later in the tracking algorithm, and is accessed via Module c grid_bounds. c USE grid_bounds; USE trkrparms; USE inparms USE verbose_output; USE netcdf_parms implicit none c type (trackstuff) trkrinfo type (netcdfstuff) netcdfinfo type (datecard) inp logical(1) :: need_to_flip_lats,need_to_flip_lons real xhold,xlondiff,xlatdiff real, allocatable :: tmplon(:),tmplat(:) real, intent(out) :: dx,dy integer iscanflag,iggret integer, intent(in) :: ncfile_id integer, intent(out) :: imax,jmax integer :: iia,ija,midi,midj,i,j,iix,jix c iggret = 0 call get_ncdim1(ncfile_id,netcdfinfo%lon_name,imax) call get_ncdim1(ncfile_id,netcdfinfo%lat_name,jmax) if (allocated(tmplon)) deallocate (tmplon) if (allocated(tmplat)) deallocate (tmplat) allocate (tmplon(imax),stat=iia) allocate (tmplat(jmax),stat=ija) if (iia /= 0 .or. ija /= 0) then print *,' ' print *,'!!! ERROR in sub getgridinfo_netcdf allocating arrays.' print *,'!!! iia = ',iia,' ija= ',ija iggret = 94 return endif if (verb .ge. 1) then print *,'in getgridinfo_netcdf, ncfile_id= ',ncfile_id endif call get_var1_double (ncfile_id,netcdfinfo%lon_name,imax,tmplon) call get_var1_double (ncfile_id,netcdfinfo%lat_name,jmax,tmplat) c Compute the dx and dy by picking values out of the middle of c the lat and lon arrays.... midi = imax/2 midj = jmax/2 dx = abs(tmplon(midi) - tmplon(midi-1)) dy = abs(tmplat(midj) - tmplat(midj-1)) if (verb .ge. 1) then print *,' ' print *,'In getgridinfo, grid dimensions follow:' print *,'imax= ',imax,' jmax= ',jmax print *,'dx= ',dx,' dy= ',dy print *,' ' write (6,112) midi,dx write (6,113) midj,dy 112 format(1x,' DX: midi= ',i4,' dx= ',f8.4) 113 format(1x,' DY: midj= ',i4,' dy= ',f8.4) endif c ------------------------------------------------------------------ c Get boundaries of the data grid. Note that it is possible to have c an input grid which goes from south to north (in fact, it appears c that many NetCDF files are constructed this way). Keep in mind, c however, that the tracker has been written such that point (1,1) c should be the upper-leftmost point on the grid, while point c (imax,jmax) should be the lower-rightmost point. If we check and c find that we're dealing with data that instead starts from the c south and increases northward, we flip the data in subroutine c conv1d2d_real. Similarly here, we make sure to test so that when c we are done in this routine, glatmax refers to the northernmost c latitude and glatmin the southernmost latitude. if (tmplon(imax) > tmplon(1)) then glonmin = tmplon(1) glonmax = tmplon(imax) else glonmin = tmplon(imax) glonmax = tmplon(1) endif if (tmplat(1) > tmplon(jmax)) then glatmax = tmplat(1) glatmin = tmplat(jmax) else glatmax = tmplat(jmax) glatmin = tmplat(1) endif print *,' ' print *,'Data Grid Lat/Lon boundaries follow:' write (6,81) glatmin,glonmin 81 format (' Min Lat: ',f8.3,' Min Lon: ',f8.3) write (6,83) glatmax,glonmax 83 format (' Max Lat: ',f8.3,' Max Lon: ',f8.3) c ---------------------------------------------------------------- c Fill glat and glon with the lat & lon values for the grid. This c info will be used in subroutine barnes if (allocated(glon)) deallocate (glon) if (allocated(glat)) deallocate (glat) allocate (glat(jmax),stat=ija) allocate (glon(imax),stat=iia) if (ija /= 0 .or. iia /= 0) then print *,' ' print *,'!!! ERROR in getgridinfo allocating glon or glat' print *,'!!! ija = ',ija,' iia= ',iia iggret = 96 return endif ! If the lat or lon grids are flipped (i.e., the lats increase ! from south to north, or the lons increase westward), then we ! will need to flip both the data arrays as well as the arrays ! that are holding the values of the lats and lons.... need_to_flip_lats = .false. need_to_flip_lons = .false. if (tmplat(1) > tmplon(jmax)) then do j=1,jmax glat(j) = tmplat(j) enddo else do j=1,jmax jix = jmax - j + 1 glat(jix) = tmplat(j) enddo need_to_flip_lats = .true. endif if (tmplon(imax) > tmplon(1)) then do i=1,imax glon(i) = tmplon(i) enddo else do i=1,imax iix = imax - i + 1 glon(iix) = tmplon(i) enddo need_to_flip_lons = .true. endif c do i = 1,imax c print *,'i= ',i,' glon(i)= ',glon(i) c enddo c do j = 1,jmax c print *,'j= ',j,' glat(j)= ',glat(j) c enddo c --------------------------------------------------------------- c Finally, check to see if the requested boundary limits that c the user input are contained within this grid (for example, c someone running this tracker on a regional grid may have forgotten c to change the input grid bounds from a global grid run). Modify c the user-input bounds as needed. c c NOTE: Only check these bounds for a genesis run on a regional c grid, whether that be a 'midlat' or a 'tcgen' run. if (trkrinfo%gridtype == 'regional' .and. & trkrinfo%type /= 'tracker') then if (trkrinfo%eastbd > glonmax) then xhold = trkrinfo%eastbd trkrinfo%eastbd = glonmax - 5.0 write (6,90) write (6,91) write (6,92) write (6,93) write (6,94) write (6,95) write (6,96) write (6,97) 'EASTERN LONGITUDE' write (6,98) xhold write (6,99) trkrinfo%eastbd write (6,91) endif if (trkrinfo%westbd < glonmin) then xhold = trkrinfo%westbd trkrinfo%westbd = glonmin + 5.0 write (6,90) write (6,91) write (6,92) write (6,93) write (6,94) write (6,95) write (6,96) write (6,97) 'WESTERN LONGITUDE' write (6,98) xhold write (6,99) trkrinfo%westbd write (6,91) endif if (trkrinfo%northbd > glatmax) then xhold = trkrinfo%northbd trkrinfo%northbd = glatmax - 5.0 write (6,90) write (6,91) write (6,92) write (6,93) write (6,94) write (6,95) write (6,96) write (6,97) 'NORTHERN LATITUDE' write (6,98) xhold write (6,99) trkrinfo%northbd write (6,91) endif if (trkrinfo%southbd < glatmin) then xhold = trkrinfo%southbd trkrinfo%southbd = glatmin + 5.0 write (6,90) write (6,91) write (6,92) write (6,93) write (6,94) write (6,95) write (6,96) write (6,97) 'SOUTHERN LATITUDE' write (6,98) xhold write (6,99) trkrinfo%southbd write (6,91) endif endif 90 format (///) 91 format (' *********************************************') 92 format (' WARNING: A USER-REQUESTED BOUNDARY IS BEYOND') 93 format (' THE BOUNDARY OF THE DATA, AS DEFINED IN THE ') 94 format (' GRIB FILE. THE USER BOUNDARY WILL BE MODIFIED') 95 format (' TO MATCH THE BOUNDARY OF THE DATA FILE.') 96 format (' ') 97 format (' USER-INPUT BOUNDARY AT FAULT: ',A20) 98 format (' USER-INPUT BOUNDARY VALUE: ',f8.2) 99 format (' NEW BOUNDARY VALUE: ',f8.2) c return end c c--------------------------------------------------------------------- c c--------------------------------------------------------------------- subroutine read_netcdf_hours (ncfile,ncfile_id,ncfile_tmax,ifhmax & ,ncfile_has_hour0,netcdfinfo,irnhret) c c ABSTRACT: The purpose of this subroutine is to read the "time" c dimension and "time data" from the NetCDF file so that we know c how many time levels there are and what those time levels are. c One reason for doing this is that some models, like the GFDL c FV3, do not output hour 0 data, so we need to check this first c before running through the tracking processing for the various c hours. We will take the list of hours read in here directly from c the NetCDF file and compare that against the *requested* list of c forecast hours that the user has entered. The user might not be c aware that there is no hour 0 data for a given model. We compare c these two lists of forecast hours and then write a message if c there is a lead time that is not in the NetCDF file. c c INPUT: c ncfile character name of NetCDF file c ncfile_id integer id associated with NetCDF file after open c ifhmax integer max number of lead times that the user has c requested on the input lead times data file. This c value was set in subroutine read_fhours. c netcdfinfo variable of user-defined type netcdfstuff (from c module netcdf_parms). c c OUTPUT: c ncfile_tmax integer max number of lead times that are in the c NetCDF file, as read in from this subroutine c ncfile_has_hour0 character flag (y|n) that tells whether or not c the input NetCDF data file actually has an hour0 c record in it or not. c USE netcdf_parms; USE tracked_parms; USE verbose_output implicit none c type (netcdfstuff) netcdfinfo character :: ncfile*180,ncfile_has_hour0*1,match_check*1 integer, intent(in) :: ncfile_id integer, intent(out) :: ncfile_tmax integer :: infta,k,m,n,ifhmax,irnhret,usertime c irnhret = 0 ncfile_has_hour0 = 'n' !----------------------------------------------------------- ! First read the NetCDF file to get the number of time levels, ! which will be returned in "ncfile_tmax".... !----------------------------------------------------------- print *,' ' print *,'in read_netcdf_hours...' print *,'ncfile_id= ',ncfile_id print *,'netcdfinfo%time_name= ',netcdfinfo%time_name print *,'ncfile_tmax= ',ncfile_tmax call get_ncdim1(ncfile_id,netcdfinfo%time_name,ncfile_tmax) if (verb .ge. 1) then print *,'in getgridinfo_netcdf, ncfile_id= ',ncfile_id print *,'Num netcdf time levs= ncfile_tmax= ',ncfile_tmax endif if (allocated(netcdf_file_time_values)) then deallocate (netcdf_file_time_values) endif allocate (netcdf_file_time_values(ncfile_tmax),stat=infta) if (infta /= 0) then print *,' ' print *,'!!! ERROR in sub read_netcdf_hours allocating' print *,'!!! netcdf_file_time_values array. infta = ',infta irnhret = 94 return endif !----------------------------------------------------------- ! Now read in the actual time values that are stored in the ! NetCDF file.... !----------------------------------------------------------- call get_var1_double (ncfile_id,netcdfinfo%time_name,ncfile_tmax & ,netcdf_file_time_values) if (verb .ge. 1) then do k = 1,ncfile_tmax print *,'k= ',k,' netcdf_file_time_values(k)= ' & ,netcdf_file_time_values(k) enddo endif !------------------------------------------------------------ ! Now convert the NetCDF time values into minutes in order to ! be able to compare with the user-requested list of lead ! times. Remember that the NetCDF lead times will be listed ! either as hours or as fractions of days. !------------------------------------------------------------ if (allocated(nctotalmins)) then deallocate (nctotalmins) endif allocate (nctotalmins(ncfile_tmax),stat=infta) if (infta /= 0) then print *,' ' print *,'!!! ERROR in sub read_netcdf_hours allocating ' print *,'!!! nctotalmins array. infta = ',infta irnhret = 94 return endif do k = 1,ncfile_tmax if (netcdfinfo%time_units == 'hours') then nctotalmins(k) = int(netcdf_file_time_values(k)) * 60 elseif (netcdfinfo%time_units == 'days') then nctotalmins(k) = int(netcdf_file_time_values(k) * 60. * 24.) else print *,' ' print *,'!!! ERROR: In read_netcdf_hours, the value of' print *,' netcdfinfo%time_units is neither hours nor days.' print *,' netcdfinfo%time_units= ',netcdfinfo%time_units print *,' STOPPING....' print *,' ' stop 99 endif if (verb .ge. 1) then write (6,71) k,netcdf_file_time_values(k),nctotalmins(k) endif enddo 71 format (1x,i5,' netcdf_file_time_values(k)= ',f8.4 & ,' nctotalmins(k)= ',i10) !------------------------------------------------------------ ! Now go through the list of user-requested lead times that ! were read in from subroutine read_fhours and try to match ! the two lists up. The big one to watch out for is whether ! or not the NetCDF file actually has an hour 0 lead time. !------------------------------------------------------------ userloop: do n = 1,ifhmax usertime = iftotalmins(n) match_check = 'n' netcdfloop: do m = 1,ncfile_tmax if (usertime == nctotalmins(m)) then if (verb .ge. 1) then print *,'+++ Time match for usertime= ',usertime endif match_check = 'y' endif enddo netcdfloop if (match_check == 'n') then if (usertime == 0) then print *,' ' print *,'Warning: For a NetCDF file, the user has requested' print *,'to read in an hour 0 file, however a scan of the' print *,'time data values in the NetCDF file indicates' print *,'that there is no hour 0 data in this file. ' print *,'We will substitute either missing values or ' print *,'the values from the TC Vitals data in the ' print *,'hour 0 record and then start searching at the ' print *,'next lead time.' ncfile_has_hour0 = 'n' else print *,' ' print *,'!!! ERROR: For a NetCDF file, the user has' print *,' requested to process a particular lead time that' print *,' does not exist in the NetCDF list of time ' print *,' values.' print *,' n= ',n print *,' usertime= iftotalmins(n)= ',iftotalmins(n) print *,' STOPPING....' stop 99 endif elseif (match_check == 'y') then if (usertime == 0) then if (verb .ge. 1) then print *,' ' print *,'+++ For the input NetCDF file, an hour0 data ' print *,' record exists in the data file.' endif ncfile_has_hour0 = 'y' endif endif enddo userloop c return end c c c--------------------------------------------------------------------- c c--------------------------------------------------------------------- subroutine check_valid_point (imax,jmax,dx,dy,fxy,cmaxmin & ,valid_pt,rlont,rlatt,grid_maxlat,grid_minlat,grid_maxlon & ,grid_minlon,trkrinfo,icvpret) c c ABSTRACT: This subroutine checks to see if the input lat/lon c point is associated with four surrounding (i,j) locations that c have valid data. The writing of this routine was prompted by the c HFIP project in February, 2009. Some of their high resolution c data for their inner nests contained grids that had been rotated c from native map projections to regular lat/lon grids, but that c rotation left "empty" spots on the lat/lon grid where there is c no data. Then when searching in find_maxmin, we were running c barnes iterations from these lat/lon locations where there was c no data, which would give artificially low values at those c lat/lon locations (because the barnes scheme would only include c points that were relatively far away where there was valid data). c So in this routine, we call subroutine fix_latlon_to_ij in order c to get the nearest (i,j) coordinates, and then we check all of c these points to make sure that valid data exist. c c INPUT: c imax Num pts in i-direction on grid c jmax Num pts in j-direction on grid c dx grid spacing in i-direction c dy grid spacing in j-direction c fxy real array of input data values c cmaxmin character that tells if searching for max or min c valid_pt Logical; bitmap indicating if valid data at that pt c rlatt,rlont input lat/lon about which we will check the c surrounding (i,j) locations for valid data. c grid_maxlat northernmost latitude on the input grid being sent to c this routine. This grid may be a subset of the original c full grid from the original dataset. c grid_minlat southernmost latitude on the input grid being sent to c this routine. This grid may be a subset of the original c full grid from the original dataset. c grid_maxlon easternmost longitude on the input grid being sent to c this routine. This grid may be a subset of the original c full grid from the original dataset. c grid_minlon westernmost longitude on the input grid being sent to c this routine. This grid may be a subset of the original c full grid from the original dataset. c trkrinfo derived type containing grid info on user boundaries c c OUTPUT: c icvpret return code from this routine. A value of 0 means that c all is okay and the input point is surrounded by valid c data. USE trkrparms implicit none c type (trackstuff) trkrinfo integer imax,jmax,ifix,jfix integer ifilret,icvpret character(*) cmaxmin logical(1) valid_pt(imax,jmax) real fxy(imax,jmax) real rlont,rlatt,xdum,gridpoint_maxmin real dx,dy,grid_maxlat,grid_minlat,grid_maxlon,grid_minlon c call fix_latlon_to_ij (imax,jmax,dx,dy,fxy,cmaxmin & ,valid_pt,rlont,rlatt & ,xdum,ifix,jfix,gridpoint_maxmin,'checker' & ,grid_maxlat,grid_minlat,grid_maxlon,grid_minlon & ,trkrinfo,ifilret) if (ifilret /= 0) then icvpret = 99 return endif if (valid_pt(ifix,jfix)) then icvpret = 0 else icvpret = 99 endif c return end c c--------------------------------------------------------------------- c c--------------------------------------------------------------------- subroutine fix_latlon_to_ij (imax,jmax,dx,dy,fxy,cmaxmin & ,valid_pt,parmlon,parmlat,xdataval & ,ifix,jfix,gridpoint_maxmin,ccall & ,grid_maxlat,grid_minlat,grid_maxlon,grid_minlon & ,trkrinfo,ifilret) c c ABSTRACT: This subroutine takes an input lat/lon position and c assigns it to a nearby (i,j) gridpoint. If this is being used c before the call to check_closed_contour after the barnes analysis c to see if we have a storm or not, then the lat/lon position that c is input into this subroutine is one which was obtained from a c barnes analysis, so it is essentially an area-weighted average c of nearby points. What we need to do in this subroutine is find c the actual nearby gridpoint which does have the actual raw max or c min value. Then we return the (i,j) coordinates of that point as c well as that raw data value at that point. c c INPUT: c imax Num pts in i-direction on grid c jmax Num pts in j-direction on grid c dx grid spacing of the data grid in i-direction c dy grid spacing of the data grid in j-direction c fxy real array of input data values c cmaxmin character that tells if searching for max or min c valid_pt Logical; bitmap indicating if valid data at that pt c parmlon lon at which input parameter center was found, or the lon c for the mean storm center fix (check calling routine) c parmlat lat at which input parameter center was found, or the lat c for the mean storm center fix (check calling routine) c xdataval barnes-obtained value of parameter at (parmlon,parmlat) c ccall character that tells if this call is part of a tracker c fix routine or just from the check_valid_point routine c ('tracker' or 'checker') c grid_maxlat northernmost latitude on the input grid being sent to c this routine. This grid may be a subset of the original c full grid from the original dataset, or it may be the c original grid itself. c grid_minlat southernmost latitude on the input grid being sent to c this routine. This grid may be a subset of the original c full grid from the original dataset, or it may be the c original grid itself. c grid_maxlon easternmost longitude on the input grid being sent to c this routine. This grid may be a subset of the original c full grid from the original dataset, or it may be the c original grid itself. c grid_minlon westernmost longitude on the input grid being sent to c this routine. This grid may be a subset of the original c full grid from the original dataset, or it may be the c original grid itself. c trkrinfo derived type containing grid info on user boundaries c c OUTPUT: c ifix i-index for gridpoint to which the max or min is assigned c jfix j-index for gridpoint to which the max or min is assigned c gridpoint_maxmin value of fxy at (ifix,jfix). This will be c different from the input value xdataval, which came from c the barnes averaging. This is the raw value at the c gridpoint. USE grid_bounds; USE trkrparms USE verbose_output implicit none c type (trackstuff) trkrinfo integer imax,jmax,istart,iend,jstart,jend,ifix,jfix integer ipfix,jpfix,i,j,ifilret,iix,jix,grfact character(*) cmaxmin,ccall logical(1) valid_pt(imax,jmax) real fxy(imax,jmax) real parmlon,parmlat,xdataval,gridpoint_maxmin real xplon,yplat,dmin,dmax,dx,dy,grdspc real grid_maxlat,grid_minlat,grid_maxlon,grid_minlon ifilret = 0 c print *,' ' c print *,'-------------------------------------------- ' c print *,'Top of fix_latlon_to_ij, call type = ',ccall c print *,'parmlon= ',parmlon,' parmlat= ',parmlat c print *,'max lon = ',grid_maxlon,' max lat = ',grid_maxlat c print *,'min lon = ',grid_minlon,' min lat = ',grid_minlat c Fix parmlat to the *nearest* j-point (i.e., round it....) if (parmlat >= 0.0) then ! N. Hemisphere jpfix = int((grid_maxlat - parmlat)/dy + 1.0 + 0.5) else ! S. Hemisphere jpfix = ceiling((grid_maxlat - parmlat)/dy + 1.0 - 0.5) endif c Fix parmlon to the *nearest* i-point (i.e., round it....) ipfix = int((parmlon - grid_minlon)/dx + 1.0 + 0.5) c Calculate the longitude and latitude of these ipfix and c jpfix points.... xplon = grid_minlon + (ipfix-1)*dx yplat = grid_maxlat - (jpfix-1)*dy c We want to do a simple search in the very few points around c this (ipfix,jpfix) point to find the raw max or min data c value. First we need to set up a 4x4 box to search: c c o o o o c c c o a b o c + c c o c d o c c c o o o o c c In the above diagram, if "+" is the lat/lon location of our c barnes-found point (i.e., the input (parmlon,parmlat)), and c a-b-c-d is the square of points surrounding "+", we only want c to look out 1 layer of points further. So first we need to c know, for each case we're looking at, if "+" got assigned to c a or b or c or d. By the way, if the parmlon falls directly c on a gridpoint in either the i or j direction, we will only c look at the 2 gridpoints on either side of that point, as c opposed to having 4 points set up as in the box above. c c UPDATE (4-Feb-2011): For fine resolution grids, it is c possible to have the gridpoint max/min be more than 1 or 2 grid c points away from the barnes-averaged max. So allow for this c here, with a check of grdspc ((dx+dy)/2) below and the c addition of the "grfact" multiplier for fine resolution grids. c print *,'ipfix= ',ipfix,' xplon= ',xplon c print *,'jpfix= ',jpfix,' yplat= ',yplat grdspc = (dx+dy)*0.5 if (grdspc <= 0.025) then grfact = 20 else if (grdspc > 0.025 .and. grdspc <= 0.05) then grfact = 12 else if (grdspc > 0.05 .and. grdspc <= 0.10) then grfact = 6 else if (grdspc > 0.10 .and. grdspc <= 0.20) then grfact = 3 else if (grdspc > 0.20 .and. grdspc <= 0.30) then grfact = 2 else grfact = 1 endif if (xplon < parmlon) then !(ipfix is at either a or c) istart = ipfix - (1*grfact) iend = ipfix + (2*grfact) else if (xplon > parmlon) then !(ipfix is at either b or d) istart = ipfix - (2*grfact) iend = ipfix + (1*grfact) else if (xplon == parmlon) then !(parmlon is exactly ipfix) istart = ipfix - (1*grfact) iend = ipfix + (1*grfact) endif if (yplat < parmlat) then !(jpfix is at either c or d) jstart = jpfix - (2*grfact) jend = jpfix + (1*grfact) else if (yplat > parmlat) then !(jpfix is at either a or b) jstart = jpfix - (1*grfact) jend = jpfix + (2*grfact) else if (yplat == parmlat) then !(parmlat is exactly jpfix) jstart = jpfix - (1*grfact) jend = jpfix + (1*grfact) endif c print *,'istart= ',istart,' iend= ',iend c print *,'jstart= ',jstart,' jend= ',jend c print *,' ' c Make sure the edges of our box are within the grid bounds... if (jstart > jmax ) then if ( verb .ge. 1 ) then print *,'!!! ERROR in fix_latlon_to_ij, jstart > jmax' print *,'!!! ',ccall,' jstart = ',jstart,' jmax= ',jmax endif ifilret = 99 return endif if (jend < 1) then if ( verb .ge. 1 ) then print *,'!!! ERROR in fix_latlon_to_ij, ',ccall & ,' jend < 1, jend = ',jend endif ifilret = 99 return endif if (jstart < 1) jstart = 1 if (jend > jmax) jend = jmax if (istart > imax ) then if (trkrinfo%gridtype == 'global') then continue ! GM wrapping will be handled in loop below... else if ( verb .ge. 1 ) then print *,'!!! ERROR in fix_latlon_to_ij, istart > imax' print *,'!!! istart = ',istart,' imax= ',imax endif ifilret = 99 return endif endif if (iend < 1) then if (trkrinfo%gridtype == 'global') then continue ! GM wrapping will be handled in loop below... else if ( verb .ge. 1 ) then print *,'!!! ERROR in fix_latlon_to_ij, iend < 1, iend = ' & ,iend,' call type = ',ccall endif ifilret = 99 return endif endif if (iend > imax) then if (trkrinfo%gridtype == 'global') then continue ! GM wrapping will be handled in loop below... else iend = imax ! For a regional grid, just cut it off endif endif if (istart < 1) then if (trkrinfo%gridtype == 'global') then continue ! GM wrapping will be handled in loop below... else istart = 1 ! For a regional grid, just cut it off endif endif c Now look for the max or min value.... dmax = -9.99e12 dmin = 9.99e12 ifix = ipfix jfix = jpfix do iix = istart,iend do jix = jstart,jend i = iix j = jix if (i < 1) then i = iix + imax !GM wrapping endif if (i > imax) then i = iix - imax !GM wrapping endif if (valid_pt(i,j)) then continue else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: In fix_latlon_to_ij, we tried to ' print *,'!!! access an invalid data point.' print *,'!!! ',ccall,' i= ',i,' j= ',j print *,'!!! ipfix= ',ipfix,' jpfix= ',jpfix print *,'!!! parmlon= ',parmlon,' parmlat= ',parmlat print *,' ' endif ifilret = 98 return endif if (cmaxmin == 'min') then if (fxy(i,j) < dmin) then dmin = fxy(i,j) ifix = i jfix = j endif else if (fxy(i,j) > dmax) then dmax = fxy(i,j) ifix = i jfix = j endif endif enddo enddo if (cmaxmin == 'min') then gridpoint_maxmin = dmin else gridpoint_maxmin = dmax endif c print *,' End of fix_latlon_to_ij, gridpoint_maxmin = ' c & ,gridpoint_maxmin c return end c c--------------------------------------------------------------------- c c--------------------------------------------------------------------- subroutine rvcal (imax,jmax,dlon,dlat,z,vp) c c ABSTRACT: This routine calculates the relative vorticity (zeta) c from u,v on an evenly-spaced lat/lon grid. Centered finite c differences are used on the interior points and one-sided c differences are used on the boundaries. c c NOTE: There are 3 critical arrays in this subroutine, the first c being zeta and the 2nd and 3rd being u and v. There is a c critical difference in the array indexing for the levels. For c zeta, the array is dimensioned with levels from 1 to 3, with c 1 = 850, 2 = 700, 3 = sfc. However, there is an extra level c for the winds, such that the level dimension goes 1 = 850, c 2 = 700, 3 = 500, 4 = sfc. So we need to adjust for that in c this routine. c c LOCAL VARIABLES: c USE tracked_parms; USE trig_vals; USE grid_bounds USE verbose_output implicit none dimension cosfac(jmax),tanfac(jmax) real tmpzeta(imax,jmax) real xlondiff,xlatdiff,dlon,dlat,dfix real dlat_edge,dlat_inter,dlon_edge,dlon_inter real rlat(jmax),cosfac,tanfac integer z,iscanflag,nlat,nlon,i,j,imax,jmax,w integer ii,jj logical(1) vp(imax,jmax) c -------------------------- c Figure out what level of data we have and what the array c indices should be. if (z == 1) then ! z = 1 for 850 mb zeta, w = 1 for 850 mb winds w = 1 else if (z == 2) then ! z = 2 for 700 mb zeta, w = 2 for 700 mb winds w = 2 else if (z == 3) then ! z = 3 for sfc zeta, w = 4 for sfc (10m) winds w = 4 endif c Calculate grid increments for interior and edge points. c IMPORTANT: If dtk is defined in module trig_vals in km, then c we need to multiply by 1000 here to get meters. If it's defined c as meters, just let it be. Since the wind values are given in c meters, that's why we need the dlon values to be in meters. if (dtk < 750.) then ! chances are, dtk was defined as km dfix = 1000.0 else ! dtk was already defined as meters dfix = 1.0 endif dlon_edge = dtk * dfix * dlon ! Di dist over 1 grid pt dlat_edge = dtk * dfix * dlat ! Dj dist over 1 grid pt dlon_inter = dtk * dfix * 2.0 * dlon ! Di dist over 2 grid pts dlat_inter = dtk * dfix * 2.0 * dlat ! Dj dist over 2 grid pts c Calculate required trig functions. These are functions of c latitude. Remember that the grid must go from north to south. c This north-to-south requirement has c already been checked in subroutine getgridinfo. If necessary, c any flipping of the latitudes was done there, and flipping of c the data, again if necessary, was done in subroutine getdata. do j=2,jmax-1 rlat(j) = glatmax - ((j-1) * dlat) cosfac(j) = cos(dtr*rlat(j)) tanfac(j) = (tan(dtr*rlat(j)))/erad enddo c Set trig factors at end points to closest interior point c to avoid a singularity if the domain includes the poles, c which it will for the global grids (MRF, GDAS, GFS, UKMET,NCE) cosfac(1) = cosfac(2) tanfac(1) = tanfac(2) cosfac(jmax) = cosfac(jmax-1) tanfac(jmax) = tanfac(jmax-1) c NOTE: These next bits of vorticity calculation code assume that c the input grid is oriented so that point (1,1) is the upper c left-most (NW) and point (imax,jmax) is the lower right- c most point. Any other grids will probably crash the c program due to array out of bounds errors. c NOTE: Before each calculation is done, the logical array is c checked to make sure that all the data points in this c calculation have valid data (ie., that the points are not c outside a regional model's boundaries). c c !!! IMPORTANT NOTE: While testing this, I uncovered a bug, which was c that I had the "j+1" and "j-1" reversed. Just from a physical c understanding, the du/dy term at a point is calculated by taking c the u value north of the point minus the u value south of the c point. Intuitively, this is u(j+1) - u(j-1). However, we have c designed this program to have the northernmost point as c the beginning of the grid (i.e., for the global grids, j=1 at 90N, c and j increases southward). Thus, if you would do u(j+1) - c u(j-1), you would actually be taking the u value south of the c point minus the u value north of the point, EXACTLY THE OPPOSITE c OF WHAT YOU WANT. Therefore, the vorticity calculations have c been changed so that we now have u(j-1) - u(j+1). c c UPDATE FEB 2009: With limited domain grids that have missing c data on them (such as you would have for a grid that has been c converted from a non-lat/lon grid to a lat/lon grid), we were c running into problems below with the setting of zeta values to c a missing value of -999. In place of this, the easiest thing to c do is to simply assign a value of the background coriolis value c to that point. No, this is not correct, but it is the easiest c workaround for this right now. Setting it to zero would be too c far off. Setting it to the coriolis component has a net effect c of not having much impact on the barnes scheme result. c c --------------- c Interior points c --------------- if ( verb .ge. 3 ) then print *,'Just before inter rvcalc, dlon_inter = ',dlon_inter & ,' dlat_inter = ',dlat_inter endif do j=2,jmax-1 do i=2,imax-1 c if (vp(i,j) .and. vp(i+1,j) .and. vp(i-1,j) .and. & vp(i,j+1) .and. vp(i,j-1)) then c zeta(i,j,z)= (v(i+1,j,w) - v(i-1,j,w))/(dlon_inter * cosfac(j)) & - (u(i,j-1,w) - u(i,j+1,w))/(dlat_inter) & + tanfac(j)*u(i,j,w) else c zeta(i,j,z)= -999. zeta(i,j,z) = 2. * omega * sin(rlat(j)*dtr) endif c enddo enddo c c ----------------------------- c Bottom (Southernmost) points c ----------------------------- c j=jmax do i=2,imax-1 c if (vp(i,j) .and. vp(i+1,j) .and. vp(i-1,j) .and. & vp(i,j-1)) then c zeta(i,j,z)= (v(i+1,j,w) - v(i-1,j,w))/(dlon_inter * cosfac(j)) & - (u(i,j-1,w) - u(i,j,w))/(dlat_edge) & + tanfac(j)*u(i,j,w) else c zeta(i,j,z)= -999. zeta(i,j,z) = 2. * omega * sin(rlat(j)*dtr) endif c enddo c c -------------------------- c Top (Northernmost) points c -------------------------- c j=1 do i=2,imax-1 c if (vp(i,j) .and. vp(i+1,j) .and. vp(i-1,j) .and. & vp(i,j+1)) then c zeta(i,j,z)= (v(i+1,j,w) - v(i-1,j,w))/(dlon_inter * cosfac(j)) & - (u(i,j,w) - u(i,j+1,w))/(dlat_edge) & + tanfac(j)*u(i,j,w) else c zeta(i,j,z)= -999. zeta(i,j,z) = 2. * omega * sin(rlat(j)*dtr) endif c enddo c c ------------------------------- c Left edge (Westernmost) points c ------------------------------- c i=1 do j=2,jmax-1 c if (vp(i,j) .and. vp(i+1,j) .and. vp(i,j+1) .and. & vp(i,j-1)) then c zeta(i,j,z) = (v(i+1,j,w) - v(i,j,w))/(dlon_edge * cosfac(j)) & - (u(i,j-1,w) - u(i,j+1,w))/(dlat_inter) & + tanfac(j)*u(i,j,w) else c zeta(i,j,z)= -999. zeta(i,j,z) = 2. * omega * sin(rlat(j)*dtr) endif c enddo c c -------------------------------- c Right edge (Easternmost) points c -------------------------------- c i=imax do j=2,jmax-1 c if (vp(i,j) .and. vp(i-1,j) .and. vp(i,j+1) .and. & vp(i,j-1)) then c zeta(i,j,z) = (v(i,j,w) - v(i-1,j,w))/(dlon_edge * cosfac(j)) & - (u(i,j-1,w) - u(i,j+1,w))/(dlat_inter) & + tanfac(j)*u(i,j,w) else c zeta(i,j,z)= -999. zeta(i,j,z) = 2. * omega * sin(rlat(j)*dtr) endif c enddo c c --------- c SW corner c --------- i=1 j=jmax if (vp(i,j) .and. vp(i+1,j) .and. vp(i,j-1) ) then c zeta(i,j,z) = (v(i+1,j,w)-v(i,j,w))/(dlon_edge * cosfac(j)) & - (u(i,j-1,w)-u(i,j,w))/(dlat_edge) & + tanfac(j)*u(i,j,w) else c zeta(i,j,z)= -999. zeta(i,j,z) = 2. * omega * sin(rlat(j)*dtr) endif c c --------- c NW corner c --------- i=1 j=1 if (vp(i,j) .and. vp(i+1,j) .and. vp(i,j+1) ) then c zeta(i,j,z) = (v(i+1,j,w) - v(i,j,w))/(dlon_edge * cosfac(j)) & - (u(i,j,w) - u(i,j+1,w))/(dlat_edge) & + tanfac(j)*u(i,j,w) else c zeta(i,j,z)= -999. zeta(i,j,z) = 2. * omega * sin(rlat(j)*dtr) endif c c --------- c NE corner c --------- i=imax j=1 if (vp(i,j) .and. vp(i-1,j) .and. vp(i,j+1) ) then c zeta(i,j,z) = (v(i,j,w) - v(i-1,j,w))/(dlon_edge * cosfac(j)) & - (u(i,j,w) - u(i,j+1,w))/(dlat_edge) & + tanfac(j)*u(i,j,w) else c zeta(i,j,z)= -999. zeta(i,j,z) = 2. * omega * sin(rlat(j)*dtr) endif c c --------- c SE corner c --------- i=imax j=jmax if (vp(i,j) .and. vp(i-1,j) .and. vp(i,j-1) ) then c zeta(i,j,z) = (v(i,j,w)-v(i-1,j,w))/(dlon_edge * cosfac(j)) & - (u(i,j-1,w)-u(i,j,w))/(dlat_edge) & + tanfac(j)*u(i,j,w) else c zeta(i,j,z)= -999. zeta(i,j,z) = 2. * omega * sin(rlat(j)*dtr) endif c do ii=1,imax do jj=1,jmax tmpzeta(ii,jj) = zeta(ii,jj,z) * 1.e5 enddo enddo return end c c--------------------------------------------------------------------- c c--------------------------------------------------------------------- subroutine thickness_calc (imax,jmax,vp) c c ABSTRACT: This routine calculates the thicknesses for three c different layers: 200-500, 500-850 and 200-850 mb. c c LOCAL VARIABLES: c USE tracked_parms; USE verbose_output implicit none integer i,j,layer,upper,lower,imax,jmax logical(1) vp(imax,jmax) c -------------------------- c The array indices for the 3 different thickness layers are c as follows: c 1: 500-850 c 2: 200-500 c 3: 200-850 c c The array indices for the levels for the 4 different GP height c arrays (as assigned in subroutine getdata) are as follows: c 1: 850 mb c 2: 700 mb c 3: 500 mb c 4: 200 mb do layer = 1,3 select case (layer) case (1); upper=3; lower=1; case (2); upper=4; lower=3; case (3); upper=4; lower=1; end select do j = 1,jmax do i = 1,imax if (vp(i,j)) then thick(i,j,layer) = hgt(i,j,upper) - hgt(i,j,lower) else thick(i,j,layer) = -999.0 endif enddo enddo enddo c return end c c--------------------------------------------------------------------- c c--------------------------------------------------------------------- subroutine first_ges_center (imax,jmax,dx,dy,cparm,fxy & ,cmaxmin,trkrinfo,ifh,valid_pt,maxstorm,masked_out & ,stormct,contour_info,maxmini,maxminj,ifgcret) c c ABSTRACT: This subroutine scans an array and picks out areas of c max or min, then loads those center positions into the first- c guess lat & lon arrays to be used by subroutine tracker for c locating the very specific low center positions. c c INPUT: c imax Number of gridpoints in i direction in input grid c jmax Number of gridpoints in j direction in input grid c dx Grid spacing in i-direction for the input grid c dy Grid spacing in j-direction for the input grid c cparm Char string indicating what parm is being passed in c fxy Real array of data values c finf Logical. Field of influence. Dimension same as fxy c cmaxmin Char string to indicate if search is for a max or a min c trkrinfo Derived type that holds/describes various tracker parms, c including the contour interval to be used c ifh Index for the forecast hour c valid_pt Logical bitmap masking non-valid grid points. This is a c concern for the regional models, which are interpolated c from Lam-Conf or NPS grids onto lat/lon grids, leaving c grid points around the edges which have no valid data. c maxstorm max # of storms that can be handled in this run c c INPUT/OUTPUT: c masked_out Logical. T = data point is already accounted for, under c the influence of another nearby max or min center, c F = data point is available to be scanned by this c subroutine for max or min centers. c stormct Integer: keeps and increments a running tab of the number c of storms that have been tracked at any time across all c forecast hours c contour_info Type cint_stuff from module contours. Contains c contour information c c OUTPUT: c maxmini Integer array containing i-indeces of max/min locations c maxminj Integer array containing j-indeces of max/min locations c ifgcret return code from this subroutine c c OTHER: c storm Contains the tcvitals for the storms (module def_vitals) USE trkrparms; USE grid_bounds; USE set_max_parms; USE def_vitals USE contours; USE tracked_parms USE verbose_output implicit none type (trackstuff) trkrinfo type (cint_stuff) contour_info integer i,j,n,isstart,ifamret,ibeg,jbeg,iend,jend integer ifh,maxstorm,imax,jmax,itemp,ifgcret integer stormct,oldstormct,mm logical(1) valid_pt(imax,jmax),masked_out(imax,jmax) character(*) cparm,cmaxmin integer maxmini(maxstorm),maxminj(maxstorm) real fxy(imax,jmax) real dmax,dmin,dx,dy,dbuffer,tmp if ( verb .ge. 3 ) then print *,' ' print *,'*-------------------------------------------------*' print *,'* At top of first_ges_center *' write (6,102) ifhours(ifh),ifclockmins(ifh) 102 format (1x,'* Searching for new lows at hour ',i4,':',i2.2) print *,'*-------------------------------------------------*' endif c First check the user-supplied grid boundaries to see if we will c scan the entire array or just a portion of it. if (trkrinfo%northbd < -998.0 .or. trkrinfo%southbd < -998.0 .or. & trkrinfo%westbd < -998.0 .or. trkrinfo%eastbd < -998.0) then ! User did not specify a subgrid, so scan the whole domain ibeg = 1 iend = imax jbeg = 1 jend = jmax else c if (trkrinfo%westbd > 360.0 .or. trkrinfo%eastbd < 0.0 .or. c & trkrinfo%westbd < 0.0 .or. if (trkrinfo%westbd > 360.0 .or. & trkrinfo%northbd > 90.0 .or. trkrinfo%northbd <-90.0 .or. & trkrinfo%southbd > 90.0 .or. trkrinfo%southbd <-90.0 .or. & trkrinfo%westbd >= trkrinfo%eastbd .or. & trkrinfo%southbd >= trkrinfo%northbd) then if (trkrinfo%westbd > trkrinfo%eastbd) then if (trkrinfo%westbd < 360.0 .and. & trkrinfo%eastbd >= 0.0)then ! In this special case, the user has specified that the ! western boundary be to the west of the Greenwich ! meridian and the eastern boundary be to the east of it. if ( verb .ge. 3 ) then print *,' ' print *,'++ NOTE: The user supplied grid lon boundaries' print *,'++ span across the Greenwich meridian.' print *,'++ ' print *,'++ Western boundary: ',trkrinfo%westbd print *,'++ Eastern boundary: ',trkrinfo%eastbd print *,'++ Northern boundary: ',trkrinfo%northbd print *,'++ Southern boundary: ',trkrinfo%southbd print *,' ' endif ! Calculate the beginning and ending i and j points for ! this case of spanning the Greenwich meridian. The ! beginning and ending j points are, obviously, the same ! as for the regular case below in the else. The ! i-beginning point will also be the same as for the ! regular case. However, the i-ending point will be ! modified for the meridian wrap; it will be > imax. jbeg = int(((glatmax + dy - trkrinfo%northbd) & / dy) + 0.5) jend = int(((glatmax + dy - trkrinfo%southbd) & / dy) + 0.5) ibeg = int(((trkrinfo%westbd - glonmin + dx) & / dx) + 0.5) c iend = int(((trkrinfo%eastbd - glonmin + dx) c & / dx) + 0.5) iend = int(((trkrinfo%eastbd - glonmin + dx) & / dx) + 0.5) + imax goto 377 endif endif if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: Error in first_ges_center. There is a' print *,'!!! problem with the user-supplied grid ' print *,'!!! boundaries. Please check them and ' print *,'!!! resubmit the program.' print *,'!!!' print *,'!!! Western boundary: ',trkrinfo%westbd print *,'!!! Eastern boundary: ',trkrinfo%eastbd print *,'!!! Northern boundary: ',trkrinfo%northbd print *,'!!! Southern boundary: ',trkrinfo%southbd print *,' ' endif ifgcret = 91 return 377 continue else ! Calculate the beginning and ending i and j points.... jbeg = int(((glatmax + dy - trkrinfo%northbd) / dy) & + 0.5) jend = int(((glatmax + dy - trkrinfo%southbd) / dy) & + 0.5) ibeg = int(((trkrinfo%westbd - glonmin + dx) / dx) & + 0.5) iend = int(((trkrinfo%eastbd - glonmin + dx) / dx) & + 0.5) endif endif c Scan the requested portion of the grid and pick out the max and c min data values, figure out what the max and min contour levels c will be, and fill an array with the values of the various c intermediate, incremental contour levels. if (trkrinfo%contint <= 0) then if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: Error in first_ges_center. For a midlat' print *,'!!! or tcgen run of the tracker, the contour' print *,'!!! interval supplied by the user is not ' print *,'!!! greater than 0.' print *,'!!! ' print *,'!!! User-supplied contint = ',trkrinfo%contint print *,' ' endif ifgcret = 91 return endif dmin = 9.99e20 dmax = -9.99e20 do j = jbeg,jend do i = ibeg,iend if (i > imax) then itemp = i - imax ! If wrapping past GM else itemp = i endif if (valid_pt(itemp,j)) then if (fxy(itemp,j) < dmin) dmin = fxy(itemp,j) if (fxy(itemp,j) > dmax) dmax = fxy(itemp,j) endif enddo enddo if ( verb .ge. 3 ) then print *,' ' print *,'*--------------------------------------------*' print *,'In first_ges_center, dmin= ',dmin,' dmax= ',dmax endif c We want to allow for storms moving out of the sub-region, c in which case we might hit slightly lower or higher c contours than were found in the sub-region, so allow for c an extra buffer and modify dmin and dmax.... dbuffer = (dmax - dmin) / 2.0 dmax = dmax + dbuffer dmin = dmin - dbuffer if ( verb .ge. 3 ) then print *,'after adjustment, dmin= ',dmin,' dmax= ',dmax endif c Next 2 lines changed for compiler compatibility on c other platforms.... c contour_info%xmaxcont = dmax - amod(dmax,trkrinfo%contint) c contour_info%xmincont = dmin - amod(dmin,trkrinfo%contint) tmp = trkrinfo%contint contour_info%xmaxcont = dmax - mod(dmax,tmp) contour_info%xmincont = dmin - mod(dmin,tmp) if ( verb .ge. 3 ) then print *,'A1 contour_info%xmaxcont= ',contour_info%xmaxcont print *,'A1 contour_info%xmincont= ',contour_info%xmincont endif if (contour_info%xmincont > contour_info%xmaxcont) then contour_info%xmincont = contour_info%xmaxcont endif c if (dmin > contour_info%xmincont) then c contour_info%xmincont=contour_info%xmincont + trkrinfo%contint c endif c if (dmax < contour_info%xmaxcont) then c contour_info%xmaxcont=contour_info%xmaxcont - trkrinfo%contint c endif if ( verb .ge. 3 ) then print *,'A2 contour_info%xmaxcont= ',contour_info%xmaxcont print *,'A2 contour_info%xmincont= ',contour_info%xmincont print *,'maxconts= ',maxconts endif c NOTE: In the loop below, the contour_info%contvals array is now c (5/2003) no longer used in subsequent subroutines. But we still c need to figure out the value of the contvals as we iterate the c loop so we can know when we've surpassed dmax and can stop c incrementing contour_info%numcont, which we do need in subsequent c subroutines. contour_info%numcont = 0 do n = 1,maxconts contour_info%numcont = contour_info%numcont + 1 contour_info%contvals(n) = contour_info%xmincont + & float(n-1)*trkrinfo%contint c print *,'n= ',n,' contour_info%contvals(n)= ' c & ,contour_info%contvals(n) if (contour_info%contvals(n) >= dmax) exit enddo oldstormct = stormct call find_all_maxmins (imax,jmax,ibeg,iend,jbeg,jend,fxy & ,valid_pt,masked_out,contour_info,dx,dy & ,trkrinfo,cmaxmin,maxstorm,stormct,maxmini & ,maxminj,ifamret) if (stormct > 0) then continue else if ( verb .ge. 3 ) then print *,' ' print *,' ' print *,'!!! ************************************************' print *,'!!! ' print *,'!!! NOTE: In first_ges_center, the value of stormct' print *,'!!! returned from find_all_maxmins is not greater' print *,'!!! than 0. This means there are no new centers' print *,'!!! to track, which is not likely. Perhaps you are' print *,'!!! searching over too small of an area??' print *,'!!! ' print *,'!!! ************************************************' print *,' ' endif endif print *,'ifh= ',ifh,' oldstormct= ',oldstormct print *, ' stormct= ',stormct do mm = 1,300 print *,'mm= ',mm,' maxmini(mm)= ',maxmini(mm) & ,' maxminj(mm)= ',maxminj(mm) enddo if (stormct > oldstormct .and. stormct > 0) then isstart = oldstormct + 1 if ( verb .ge. 3 ) then write (6,*) ' ' write (6,*) 'New search: ' write (6,*) 'Possible new max/min locations at ifh= ',ifh write (6,*) '--------------------------------------------' endif do n = isstart,stormct if (trkrinfo%type == 'midlat') then storm(n)%tcv_center = 'MIDL' else if (trkrinfo%type == 'tcgen') then storm(n)%tcv_center = 'TCG ' endif slonfg(n,ifh) = glonmin + (maxmini(n)-1)*dx slatfg(n,ifh) = glatmax - (maxminj(n)-1)*dy storm(n)%tcv_stspd = -99 storm(n)%tcv_stdir = -99 write (storm(n)%tcv_storm_id,'(i4.4)') n write (storm(n)%tcv_storm_name,'(i4.4)') n stormswitch(n) = 1 if (cparm == 'mslp') then if ( verb .ge. 3 ) then write (6,71) maxmini(n),maxminj(n),slonfg(n,ifh) & ,360.-slonfg(n,ifh),slatfg(n,ifh) & ,slp(maxmini(n),maxminj(n))/100.0 endif endif enddo else if ( verb .ge. 3 ) then print *,' ' print *,' New search: ' print *,'!!! NOTE: No new storms found in find_all_maxmins' print *,'!!! at ifh = ',ifh,' stormct= ',stormct print *,'!!! oldstormct= ',oldstormct print *,' ' endif endif 71 format (1x,'i= ',i4,' j= ',i4,' lon: ',f7.2,'E (',f6.2,'W)' & ,2x,' lat: ',f6.2,' mslp: ',f6.1,' mb') c return end c c--------------------------------------------------------------------- c c--------------------------------------------------------------------- subroutine find_all_maxmins (imax,jmax,ibeg,iend,jbeg,jend,fxy & ,valid_pt,masked_out,contour_info,dx,dy & ,trkrinfo,cmaxmin,maxstorm,stormct,maxmini & ,maxminj,ifamret) c c ABSTRACT: This subroutine will search an area delineated by c input i and j indeces in order to find all local maxes or mins c in that area. The (i,j) locations of the maxes/mins are returned c in the maxmini and maxminj arrays. The input 3-character string c cmaxmin will tell the subroutine to look for a "max" or a "min". c c INPUT: c imax Number of gridpoints in i direction in input grid c jmax Number of gridpoints in j direction in input grid c ibeg i-index for upper left location of grid to search c iend i-index for lower right location of grid to search c jbeg j-index for upper left location of grid to search c jend j-index for lower right location of grid to search c fxy Real array of data values c valid_pt Logical bitmap masking non-valid grid points. This is a c concern for the regional models, which are interpolated c from Lam-Conf or NPS grids onto lat/lon grids, leaving c grid points around the edges which have no valid data. c masked_out Logical. T = data point is already accounted for, under c the influence of another nearby max or min center, c F = data point is available to be scanned by this c subroutine for max or min centers. c contour_info Type cint_stuff from module contours containing the c the following 4 variables: c 1. xmincont Real value for min contour level in the fxy data array c 2. xmaxcont Real value for max contour level in the fxy data array c 3. contvals Real array holding values of cont levels at this time c 4. numcont Number of contour intervals found at this time c dx Grid spacing in x-direction c dy Grid spacing in y-direction c trkrinfo derived type containing various user-input tracker parms c cmaxmin String that declares if "min" or "max" is being searched c maxstorm max # of storms that can be handled in this run c c INPUT/OUTPUT: c stormct Integer: keeps and increments a running tab of the number c of storms that have been tracked at any time across all c forecast hours c c OUTPUT: c maxmini integer array containing i-indeces of the max/min points c maxminj integer array containing j-indeces of the max/min points c ifamret return code from this subroutine USE trkrparms; USE set_max_parms; USE contours USE verbose_output implicit none type (trackstuff) trkrinfo type (cint_stuff) contour_info integer stormct,i,j,ibeg,iend,jbeg,jend,ix,jx,ixp1,ixm1 integer ip,jp,maxstorm,jxp1,jxm1,ifamret,isret,iaret,iclmret integer isoiret,icccret,igicwret,imax,jmax character ccflag*1,get_last_isobar_flag*1,point_is_over_water*1 character(*) cmaxmin logical(1) still_finding_valid_maxmins,rough_gradient_check_okay logical(1) valid_pt(imax,jmax),masked_out(imax,jmax) integer maxmini(maxstorm),maxminj(maxstorm) real fxy(imax,jmax) real xavg,stdv,search_cutoff,dmin,dmax,sphere_cutoff real plastbar,rlastbar,fract_land,dx,dy c----- still_finding_valid_maxmins = .true. c print *,'ctm beg of find_all_maxmins, maxstorm= ',maxstorm c First, we want to get the mean and standard deviation of the input c field to be searched. We can use the standard deviation info as c part of our guideline for when to stop searching for maxes & mins. c We will set the search cut-off threshold at 1/2 standard deviation c above the mean for min searches. So, for the example of mslp, if c the mean pressure over the whole domain is 1010 mb and the c standard deviation is 12 mb, then when we are searching, if the c lowest available (i.e., hasn't been found in a previous iteration c of this loop) pressure is 1016, then it's time to stop searching. call avgcalc (fxy,imax*jmax,valid_pt,xavg,iaret) call stdevcalc (fxy,imax*jmax,valid_pt,xavg,stdv,isret) if (iaret /= 0 .or. isret /= 0) then if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: In find_all_maxmins, the calls to avgcalc' print *,'!!! and/or stdevcalc returned an error.' print *,'!!! iaret= ',iaret,' isret= ',iaret print *,' ' endif ifamret = 98 return endif if (cmaxmin == 'min') then search_cutoff = xavg + stdv*0.5 else search_cutoff = xavg - stdv*0.5 endif if ( verb .ge. 3 ) then print *,' ' print *,'In find_all_maxmins, search_cutoff= ',search_cutoff print *,' ' endif c Now begin to search the domain. We do a simple gridpoint scan, c and once we find the max/min value, we pass the (i,j) coordinates c at that point to a routine to check for a closed contour. Then c we mask out those points in the contour (or, if there is not a c closed contour, just the 8 points immediately surrounding the low c center) and we do another iteration of search_loop to look for c more lows. We mask out points we've found so that on subsequent c iterations of search_loop, we don't find the same old center c again and again and again..... search_loop: do while (still_finding_valid_maxmins) dmin = 9.99e20 dmax = -9.99e20 jloop: do j = jbeg,jend iloop: do i = ibeg,iend ip = i jp = j if (ip > imax) then if (trkrinfo%gridtype == 'global') then ip = i - imax ! If wrapping past GM else if ( verb .ge. 3 ) then print *,' ' print *,'!!! WARNING: In find_all_maxmins, the ' print *,'!!! user-requested eastern search boundary' print *,'!!! is beyond the eastern bounds of ' print *,'!!! this regional grid. The search' print *,'!!! will not extend to the user-requested' print *,'!!! grid boundary.' print *,'!!! ' print *,'!!! imax of regional grid = ',imax print *,'!!! User-requested eastern i = ',ip print *,' ' endif exit iloop endif endif if (valid_pt(ip,jp) .and..not. masked_out(ip,jp)) then if (cmaxmin == 'min') then if (fxy(ip,jp) < dmin) then dmin = fxy(ip,jp) ix = ip jx = jp endif else if (fxy(ip,jp) > dmax) then dmax = fxy(ip,jp) ix = ip jx = jp endif endif endif enddo iloop enddo jloop if (cmaxmin == 'min') then if (dmin < search_cutoff) then continue else still_finding_valid_maxmins = .false. exit search_loop endif else if (dmax > search_cutoff) then continue else still_finding_valid_maxmins = .false. exit search_loop endif endif c As a rough first check, see if the neighboring points on all c 4 sides have a gradient sloping down into the found min point, c or at least that there is a flat field not having a gradient c sloping away from the center point. call get_ijplus1_check_wrap (imax,jmax,ix,jx,ixp1,jxp1,ixm1 & ,jxm1,trkrinfo,igicwret) if (igicwret /= 0) then if ( verb .ge. 3 ) then print *,' ' print *,'!!! NOTE: In find_all_maxmins, the center we found' print *,'!!! is too close to the grid boundary and will' print *,'!!! NOT be checked for a closed contour.' print *,'!!! ix= ',ix,' jx= ',jx,' fxy= ',fxy(ix,jx) print *,'!!! ' print *,' ' endif masked_out(ix,jx) = .true. cycle search_loop endif if (cmaxmin == 'min') then if (fxy(ix,jx) <= fxy(ixp1,jx) .and. & fxy(ix,jx) <= fxy(ix,jxm1) .and. & fxy(ix,jx) <= fxy(ixm1,jx) .and. & fxy(ix,jx) <= fxy(ix,jxp1)) then rough_gradient_check_okay = .true. else rough_gradient_check_okay = .false. endif else if (fxy(ix,jx) >= fxy(ixp1,jx) .and. & fxy(ix,jx) >= fxy(ix,jxm1) .and. & fxy(ix,jx) >= fxy(ixm1,jx) .and. & fxy(ix,jx) >= fxy(ix,jxp1)) then rough_gradient_check_okay = .true. else rough_gradient_check_okay = .false. endif endif if (rough_gradient_check_okay) then if ( verb .ge. 3 ) then print *,'Found a possible max/min at ix= ',ix,' jx= ',jx endif c From this rough check, we appear to have a gradient sloping c in towards the center point. Now call the subroutine to c check whether or not there is in fact a closed contour c surrounding this local maximum or minimum. get_last_isobar_flag = 'n' ccflag = 'n' call check_closed_contour (imax,jmax,ix,jx,fxy,valid_pt & ,masked_out,ccflag,cmaxmin,trkrinfo & ,1,contour_info,get_last_isobar_flag,plastbar & ,rlastbar,icccret) if (ccflag == 'y') then if (stormct < maxstorm) then stormct = stormct + 1 if ( verb .ge. 3 ) then print *,'AAA stormct= ',stormct,' ix= ',ix,' jx= ',jx endif ! For a tcgen case, we will add in one additional check, ! and that is to ensure the point is (mostly) over water. ! Only do this check if the user has requested it (some ! of the global models do not have a land-sea mask ! included in the grib data files). point_is_over_water = 'u' if (trkrinfo%use_land_mask == 'y') then call check_land_mask (imax,jmax,ix,jx,fract_land & ,valid_pt,dx,dy,point_is_over_water,iclmret) if (iclmret /= 0) then print *,' ' print *,'!!! ERROR from check_land_mask for ix= ',ix & ,' jx= ',jx print *,'!!! STOPPING PROGRAM' stop 95 endif endif if (point_is_over_water /= 'n') then maxmini(stormct) = ix maxminj(stormct) = jx endif else if ( verb .ge. 3 ) then print *,'---max stormct reached, stormct= ', stormct endif endif else if ( verb .ge. 3 ) then print *,'!!! contour check negative, ccflag= ',ccflag endif endif if ( verb .ge. 3 ) then print *,' ' print *,'*-----------------------------------------------*' print *,'* After check_closed_contour... *' print *,'*-----------------------------------------------*' print *,' ' endif endif c Regardless of whether or not the found point turns out to have c a closed contour, we don't want to find this local minimum or c its 8 surrounding points again in a search on a subsequent c iteration of this loop. masked_out(ix,jx) = .true. masked_out(ix,jxp1) = .true. masked_out(ixp1,jxp1) = .true. masked_out(ixp1,jx) = .true. masked_out(ixp1,jxm1) = .true. masked_out(ix,jxm1) = .true. masked_out(ixm1,jxm1) = .true. masked_out(ixm1,jx) = .true. masked_out(ixm1,jxp1) = .true. enddo search_loop return end c c--------------------------------------------------------------------- c c--------------------------------------------------------------------- subroutine mask_based_on_wind_circ (imax,jmax,dx,dy,level & ,valid_pt,masked_outc,trkrinfo & ,ctlon,ctlat,cmodel_type,imbowret) c c ABSTRACT: This subroutine masks out grid points for a storm that c is currently being tracked. It is called after a fix has been c made at the current forecast hour. It is only used as a backup, c that is, if the mslp data were not there and/or a fix position c for mslp could not be made, then that means that the mask would c not be able to get updated using the routine in subroutine c check_closed_contour. But we still do need to update that mask, c so we will instead do it based on wind circulation. We will go c out radially from the center, starting at 40 km, then every c 40 km from there on out. When the mean cyclonic Vt drops below c 3 m/s, stop searching, and then mask out all grid points within c that last-searched radius. c c INPUT: c imax Num pts in i-direction on grid c jmax Num pts in j-direction on grid c ix i index for location of local max or min c jx j index for location of local max or min c fxy input data array c valid_pt Logical; bitmap indicating if valid data at that pt c masked_outc Logical. T = data point is already accounted for, c under the influence of another nearby max or min c center; F = data point is available to be scanned by c this subroutine for max or min centers. c ctlon Fix longitude for the input parameter to this routine c ctlon Fix latitude for the input parameter to this routine c cmodel_type character, 'global' or 'regional' USE set_max_parms; USE trkrparms; USE grid_bounds USE verbose_output; USE level_parms implicit none type (trackstuff) trkrinfo character(*) cmodel_type integer, parameter :: numazim=24 integer imax,jmax,level,imbowret,nlev,iazim,i,j integer ibiret1,ibiret2,azimuth_ct,igvtret integer jnfix,jsfix,iefix,iwfix real vr(numazim),vt(numazim) real dx,dy,ctlon,ctlat,rdist,bear,targlat,targlon real xintrp_u,xintrp_v,grid_buffer,xmax_rdist_reached real vt_mean,vt_azim_sum,xbear,dist,degrees logical(1) valid_pt(imax,jmax),masked_outc(imax,jmax) logical(1) searching_valid_pts imbowret = 0 select case (level) case (850); nlev = nlev850 ! check module level_parms for case (700); nlev = nlev700 ! the values of these.... case (500); nlev = nlev500 case (1020); nlev = levsfc end select if (cmodel_type == 'regional') then grid_buffer = 0.30 else grid_buffer = 0.0 endif searching_valid_pts = .true. rdist = 40.0 ! units in km xmax_rdist_reached = rdist ! units in km radial_loop: do while (searching_valid_pts) azimuth_ct = 0 vt_azim_sum = 0.0 vt = -999.0 vr = -999.0 azimloop: do iazim = 1,numazim bear = ((iazim-1) * 15.) + 7.5 call distbear (ctlat,ctlon,rdist,bear,targlat,targlon) if (targlon >= glonmax) then if (trkrinfo%gridtype == 'global') then targlon = targlon - 360. ! We just GM-wrapped for the ! full, regular, global grid. else xmax_rdist_reached = rdist exit radial_loop endif endif if (targlon < glonmin) then if (trkrinfo%gridtype == 'global') then targlon = targlon + 360. ! We just GM-wrapped for the ! full, regular, global grid. else xmax_rdist_reached = rdist exit radial_loop endif endif if (targlat > glatmax .or. targlat < glatmin) then xmax_rdist_reached = rdist exit radial_loop endif ! These calls to bilin_int_uneven pass a variable, level, ! that contains the vertical level to pull the wind data ! from, either 850, 700 or surface (which will be ! indicated by a value/code of 1020). call bilin_int_uneven (targlat,targlon & ,dx,dy,imax,jmax,trkrinfo,level,'u',xintrp_u,ibiret1) call bilin_int_uneven (targlat,targlon & ,dx,dy,imax,jmax,trkrinfo,level,'v',xintrp_v,ibiret2) if (ibiret1 == 0 .and. ibiret2 == 0) then call getvrvt (ctlon,ctlat,targlon,targlat & ,xintrp_u,xintrp_v,vr(iazim) & ,vt(iazim),igvtret) azimuth_ct = azimuth_ct + 1 vt_azim_sum = vt_azim_sum + vt(iazim) else xmax_rdist_reached = rdist exit radial_loop endif enddo azimloop if (azimuth_ct > 0) then ! Compute azimuthally-averaged Vt at this distance vt_mean = vt_azim_sum / float(azimuth_ct) else vt_mean = -999.0 endif if ( verb .ge. 3 ) then print *,'mbow: rdist= ',rdist,' azimuth_ct= ',azimuth_ct & ,' vt_azim_sum= ',vt_azim_sum,' vt_mean= ',vt_mean endif if (ctlat >= 0.0) then if (vt_mean >= 3.0) then ! For a NH storm, if the cyclonic mean Vt >= 3.0, increment ! rdist and cycle through to the next iteration of ! radial_loop. rdist = rdist + 40.0 else xmax_rdist_reached = rdist exit radial_loop endif else if (vt_mean <= -3.0 .and. vt_mean > -998.0) then ! For a SH storm, if the cyclonic mean Vt <= -3.0, increment ! rdist and cycle through to the next iteration of ! radial_loop. rdist = rdist + 40.0 else xmax_rdist_reached = rdist exit radial_loop endif endif enddo radial_loop if ( verb .ge. 3 ) then print *,'mbow: After radial_loop, rdist= ',rdist & ,' xmax_rdist_reached= ',xmax_rdist_reached endif c ----------------------------------------------------------------- c At this point, we are done searching radially outwards away from c the storm center. The max radial distance we reached is called c xmax_rdist_reached. By getting to this spot in the subroutine, c that means that we bumped out of radial_loop above because the c rdist being used in that loop got to a radius at which the mean c cyclonic Vt no longer was strong enough to continue the search c outward, so we need to reduce it by 40 km here (back to the value c for the last successful search). At a minimum, we will mask to a c radius of 80 km. if (xmax_rdist_reached > 80.0) then xmax_rdist_reached = xmax_rdist_reached - 40.0 else xmax_rdist_reached = 80.0 endif if ( verb .ge. 3 ) then print *,'mbow: After adjustment of xmax_rdist_reached, rdist= ' & ,rdist,' xmax_rdist_reached= ',xmax_rdist_reached endif bearloop: do i = 1,4 ! Now find the values of the longitude for the farthest west ! and east points and find the values of the latitude for the ! farthest north and south points. The i and j indices ! associated with these lons and lats will be used to define ! the bounds of the grid over which we scan to find points ! that will update the mask. select case (i) case (1); xbear = 0.0; case (2); xbear = 90.0; case (3); xbear = 180.0; case (4); xbear = 270.0; end select call distbear (ctlat,ctlon,xmax_rdist_reached,xbear & ,targlat,targlon) if ( verb .ge. 3 ) then print *,'mbow: distbear for i= ',i,' targlon= ',targlon & ,' targlat= ',targlat endif if (targlon >= glonmax) then if (trkrinfo%gridtype == 'global') then targlon = targlon - 360. ! We just GM-wrapped for the ! full, regular, global grid. else print *,' ' print *,'WARNING: In subroutine mask_based_on_wind_circ,' print *,'targlon > glonmax for a regional grid, so we ' print *,'cannot update the mask.' print *,'targlon= ',targlon,' glonmax= ',glonmax imbowret = 95 return endif endif if (targlon < glonmin) then if (trkrinfo%gridtype == 'global') then targlon = targlon + 360. ! We just GM-wrapped for the ! full, regular, global grid. else print *,' ' print *,'WARNING: In subroutine mask_based_on_wind_circ,' print *,'targlon < glonmin for a regional grid, so we ' print *,'cannot update the mask.' print *,'targlon= ',targlon,' glonmin= ',glonmin imbowret = 95 return endif endif if (targlat > glatmax .or. targlat < glatmin) then print *,' ' print *,'WARNING: In subroutine mask_based_on_wind_circ,' print *,'either targlat > glatmx or targlat < glatmin, so' print *,'we cannot update the mask.' print *,'targlat= ',targlat,' glatmin= ',glatmin print *,' glatmin= ',glatmin imbowret = 95 return cycle bearloop endif ! Get the i & j starting and ending points for our loop where ! we will update the mask.... if (i == 1) then ! Get j for northern latitude. Fix targlat to the *nearest* ! j-point (i.e., round it....) if (targlat >= 0.0) then ! N. Hemisphere jnfix = int((glatmax - targlat)/dy + 1.0 + 0.5) else ! S. Hemisphere jnfix = ceiling((glatmax - targlat)/dy + 1.0 - 0.5) endif elseif (i == 2) then ! Get i for eastern longitude. Fix targlon to the *nearest* ! i-point (i.e., round it....) iefix = int((targlon - glonmin)/dx + 1.0 + 0.5) elseif (i == 3) then ! Get i for southern latitude. Fix targlat to the *nearest* ! j-point (i.e., round it....) if (targlat >= 0.0) then ! N. Hemisphere jsfix = int((glatmax - targlat)/dy + 1.0 + 0.5) else ! S. Hemisphere jsfix = ceiling((glatmax - targlat)/dy + 1.0 - 0.5) endif elseif (i == 4) then ! Get i for western longitude. Fix targlon to the *nearest* ! i-point (i.e., round it....) iwfix = int((targlon - glonmin)/dx + 1.0 + 0.5) endif enddo bearloop if ( verb .ge. 3 ) then print *,'mbow: iwfix= ',iwfix,' iefix= ',iefix & ,' jnfix= ',jnfix,' jsfix= ',jsfix endif do i = iwfix,iefix do j = jnfix,jsfix call calcdist (glon(i),glat(j),ctlon,ctlat,dist,degrees) if (dist < xmax_rdist_reached) then masked_outc(i,j) = .true. endif enddo enddo return end c c--------------------------------------------------------------------- c c--------------------------------------------------------------------- subroutine check_closed_contour (imax,jmax,ix,jx,fxy,valid_pt & ,masked_out,closed_contour,cmaxmin,trkrinfo & ,num_requested_contours,contour_info & ,get_last_isobar_flag,plastbar,rlastbar,icccret) c c ABSTRACT: This subroutine checks a field of data around an input c (ix,jx) data point to see if a closed contour exists around c that data point. It can check for a closed contour on a max or a c min field, depending on the value of the input variable 'cmaxmin'. c The algorithm works by examining rings of the 8 data points c surrounding a data point that is in the contour interval. For c example, in the diagram below, the X represents the location of c the local minimum value which was passed into this routine with c the coordinates (ix,jx), let's say it's 985 mb. And let's assume c that the data values at points A-I are all in the 4 mb contour c interval of 985-989 mb, and that all the surrounding points have c data values >= 989. To test for a closed contour, we first check c the ring of 8 points immediately around point X to see what their c data values are. If a data value is found that is below the c lower limit of this contour interval (985 mb) or lower than the c local minimum value at the X point that we initially targeted c (985 mb), then we do NOT have a closed contour, and we exit this c subroutine. But in our example, that's not the case, and we have c 5 points (B,D,E,F,G) that are in the interval. So in our next c iteration of the loop, we set up 5 rings, each one set up around c the points found in the first iteration (B,D,E,F,G), and we check c the 8 points around each of those points. A logical array is c used so that as soon as a point is found, it is flagged as being c found. In this way, when we look at the ring around point D, for c example, we won't pick point X again and set up another ring c around it in the next ring iteration and end up in an infinite c loop, going back and forth between point X and point D. While c checking the 8 points in a ring, if a found data value is above c our contour interval (i.e., >= 989 mb), we just ignore the c point; we only mark points that are in our contour interval, c and again, if we find a point below our contour interval, we c exit the subroutine with a flag indicating a closed contour was c NOT found. So in this method, we keep spreading out from the c initial local minimum and creating and checking new rings until c we either: (a) Hit the edge of the regional grid, in which case c we consider a closed contour NOT found, (b) Run into a data c point that has been marked as being under the influence of c another nearby low, in which case we consider a closed contour c NOT found, (c) Run into a point which is below (above) our c contour interval for a min (max) check, in which case we c consider a closed contour NOT found, or (d) we run out of c points to keep searching, we have no rings left to create and c check because all of the surrounding points are above (below) c our contour interval for a min (max) check, and by default we c consider this a closed contour and return to the calling c subroutine a flag indicating such. c c + + + + + + + + + + c + + + + + + + + + + c + + A B + + + + + + c + + C D X E + + + + c + + + + F G + + + + c + + + + + H I + + + c + + + + + + + + + + c + + + + + + + + + + c c UPDATE: This subroutine was updated to keep searching for c multiple closed contours until it can't find anymore. The c input parameter num_requested_contours dictates how many c contours to search for. In the case of just trying to roughly c locate new centers and establish that there is a closed c circulation, num_requested_contours will = 1, and we will exit c after finding that 1 contour. But for a check after making a c full center fix, we set num_requested_contours = 999 so that c we can keep searching for all closed contours around the low. c In this 999 case, you will eventually get to a point where c there is no closed contour. In that case, in the standard c output you will see a message telling you that you hit a point c that is not in the contour and that there is no closed contour, c but you will also notice that the ccflag = y, meaning there is c a closed contour (because you have found at least 1 closed c contour along the way). The reason to keep searching for more c closed contours is that we can then return the value of the c outermost closed isobar. c c INPUT: c imax Num pts in i-direction on grid c jmax Num pts in j-direction on grid c ix i index for location of local max or min c jx j index for location of local max or min c fxy input data array c valid_pt Logical; bitmap indicating if valid data at that pt c masked_out Logical. T = data point is already accounted for, under c the influence of another nearby max or min center, c F = data point is available to be scanned by this c subroutine for max or min centers. c cmaxmin character string ('max' or 'min') that tells this c routine what we're looking for. c trkrinfo derived type that holds/describes various tracker parms c contour_info Type cint_stuff from module contours. Contains c contour information c num_requested_contours For the simple first_ges_center check, c this will be 1 (we just want to know if there's at c least 1 closed contour). For the verifying check after c we've found a center, this will be 9999 (i.e., just keep c searching for more contours) c get_last_isobar_flag character ('y' or 'n') to indicate whether c or not to report on the value of the last closed isobar c and the radius of the last closed isobar. c c OUTPUT: c closed_contour character; A returned value of 'y' indicates that c this routine was able to find a closed contour. c plastbar Contains the value of the last closed isobar (unrounded) c rlastbar Contains the mean radius of the last closed isobar c c LOCAL: c num_pts_in_all_contours Counter for the number of pts inside of c the contour we're looking at c next_ring_ct Counter for the number of points that have been c tagged to be used as center points for the next c iteration of multiple_ring_loop. c next_contour_ct Counter for the number of points that have been c tagged to be used as center points in the first iteration c through single_contour_scan_loop as we begin to scan c points in the *next* contour interval. This counter gets c incremented when, for example, we are searching points c around a current center point and we find one that is not c in our current interval, but rather is in the next c interval. We want to remember this point and store the c location, so we increment this counter and store the c location in next_contour_i and next_contour_j arrays. c beyond_contour_ct Counter for the number of points that have been c tagged to be used as center points for some subsequent c iteration of successive_contours_loop. This is c different from next_contour_ct, which is used to hold c the locations of points that are definitely in the c *next* contour interval. Here, we have points that we c just store in a pool of potential points to be searched c in future iterations. These points can come about in c cases where there is a very intense, very compact low c with a tight pressure gradient, such that multiple c contour intervals could be spanned in between 2 adjacent c gridpoints (this is especially the case if the contour c interval you have chosen is small). You need to be c careful with how you handle this array. Once you find c that you have searchable points in next_contour_i or c next_contour_j, do not just simply empty out this c beyond_contour count and its i and j arrays. The c reason being that some of these "beyond" points may end c up being used and searched in subsequent iterations, but c not if we just delete them now. USE set_max_parms; USE trkrparms; USE contours; USE grid_bounds USE verbose_output implicit none type (trackstuff) trkrinfo type (cint_stuff) contour_info integer i,j,ir,iria,irja,irx,jrx,ix,jx,imax,jmax integer nb,ibx,jby,nct,iflip integer mr,ringct,ixp1,ixm1,jxp1,jxm1,nring,iter integer icenx,jcenx,icccret,next_ring_ct,igicwret integer num_pts_in_all_contours,next_contour_ct integer beyond_contour_ct integer num_pts_in_one_contour integer num_requested_contours,num_found_contours integer nm,im,jm,inall,insingle,isc_count,rlast_distct character found_a_point_in_our_contour*1,closed_contour*1 character found_a_point_below_contour*1 character found_a_point_above_contour*1,get_last_isobar_flag*1 character(*) cmaxmin logical(1) still_scanning logical(1) valid_pt(imax,jmax),masked_out(imax,jmax) logical(1) point_is_already_in_our_contour(imax,jmax) logical(1) point_is_already_in_next_contour(imax,jmax) logical(1) point_is_already_in_beyond_pool(imax,jmax) integer isni,isnj,inci,incj,ibci,ibcj,ihmi,ihmj,itmi,itmj integer, allocatable :: search_next_i(:) integer, allocatable :: search_next_j(:) integer, allocatable :: next_contour_i(:) integer, allocatable :: next_contour_j(:) integer, allocatable :: beyond_contour_i(:) integer, allocatable :: beyond_contour_j(:) integer, allocatable :: hold_mask_i_loc(:) integer, allocatable :: hold_mask_j_loc(:) integer, allocatable :: temp_mask_i_loc(:) integer, allocatable :: temp_mask_j_loc(:) integer, allocatable :: ringposi(:),ringposj(:) real,allocatable :: ringpos(:,:) real fxy(imax,jmax),contvals(maxconts) real contlo,conthi,xcentval,contlo_next,conthi_next real dist,degrees,rlast_distsum,plastbar,rlastbar c if (allocated(search_next_i)) deallocate (search_next_i) if (allocated(search_next_j)) deallocate (search_next_j) if (allocated(next_contour_i)) deallocate (next_contour_i) if (allocated(next_contour_j)) deallocate (next_contour_j) if (allocated(beyond_contour_i)) deallocate (beyond_contour_i) if (allocated(beyond_contour_j)) deallocate (beyond_contour_j) if (allocated(hold_mask_i_loc)) deallocate (hold_mask_i_loc) if (allocated(hold_mask_j_loc)) deallocate (hold_mask_j_loc) if (allocated(temp_mask_i_loc)) deallocate (temp_mask_i_loc) if (allocated(temp_mask_j_loc)) deallocate (temp_mask_j_loc) allocate (search_next_i(imax*jmax),stat=isni) allocate (search_next_j(imax*jmax),stat=isnj) allocate (next_contour_i(imax*jmax),stat=inci) allocate (next_contour_j(imax*jmax),stat=incj) allocate (beyond_contour_i((imax*jmax)/2),stat=ibci) allocate (beyond_contour_j((imax*jmax)/2),stat=ibcj) allocate (hold_mask_i_loc(imax*jmax),stat=ihmi) allocate (hold_mask_j_loc(imax*jmax),stat=ihmj) allocate (temp_mask_i_loc(imax*jmax),stat=itmi) allocate (temp_mask_j_loc(imax*jmax),stat=itmj) if (isni /= 0 .or. isnj /= 0 .or. inci /= 0 .or. incj /= 0 .or. & ibci /= 0 .or. ibcj /= 0 .or. ihmi /= 0 .or. ihmj /= 0 .or. & itmi /= 0 .or. itmj /= 0) then if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in check_closed_contour allocating' print *,'!!! various search, hold and temp arrays.' print *,'!!! isni = ',isni,' isnj= ',isnj print *,'!!! inci = ',inci,' incj= ',incj print *,'!!! ibci = ',ibci,' ibcj= ',ibcj print *,'!!! ihmi = ',ihmi,' ihmj= ',ihmj print *,'!!! itmi = ',itmi,' itmj= ',itmj print *,' ' endif STOP 98 endif closed_contour = 'n' xcentval = fxy(ix,jx) num_found_contours = 0 next_contour_ct = 0 beyond_contour_ct = 0 num_pts_in_all_contours = 0 hold_mask_i_loc = 0 hold_mask_j_loc = 0 beyond_contour_i = 0 beyond_contour_j = 0 point_is_already_in_our_contour = .false. point_is_already_in_beyond_pool = .false. icccret = 0 isc_count = 0 plastbar = -999.0 rlastbar = -999.0 if ( verb .ge. 3 ) then print *,' ' print *,'*-----------------------------------------------*' print *,'* Top of check_closed_contour, ix= ',ix,' jx= ',jx print *,'*-----------------------------------------------*' print *,' ' print *,'fxy(ix,jx)= ',fxy(ix,jx),' xcentval= ',xcentval endif c First, set up the contour intervals that will be used. In c the original version of this code, we used preset c standard intervals (984,988,992,996,1000,1004....). But upon c further review, it was decided that this was too arbitrary. c So instead, we consider the found min (max) value to be the c bottom (top) of the list of contour intervals. In this way, c we can clearly specify and screen storms based on the "depth" c of the pressure field as compared to the surroundings. i = 1 do while (i <= maxconts) if (cmaxmin == 'min') then contvals(i) = xcentval + float(i-1)*trkrinfo%contint i = i + 1 else iflip = maxconts - i + 1 contvals(iflip) = xcentval - float(i-1)*trkrinfo%contint i = i + 1 endif enddo c This successive_contours loop is the master loop.... successive_contours_loop: do while (num_found_contours < & num_requested_contours) c Find the contour interval in which the center value resides. c Note that the lower bound is included for a min check, while c the upper bound is included for a max check. Note also that c this subroutine can be used to find the last closed contour, c and part of that functionality shows up in the next while c statement where we reference "num_found_contours" in the c array indeces for the contour values. Basically, the way we c do this is, for example, if our central value is 990.4 mb and c our contour interval is 4 mb, then in the first run through c successive_contours_loop we see if we have a closed contour in c the interval 990.4-994.4. If yes, then the next time through c this loop, we see if we have a closed contour in the interval c 994.4-998.4. If yes, then the next loop check is for 998.4- c 1002.4, and so on.... We stop searching if we find a value c that is either below the xcentval input into this subroutine c or below the lower value of the current contour interval (this c would mean a change in the gradient and would indicate that, c in the case of mslp, we are heading down towards another, c different low). isc_count = isc_count + 1 point_is_already_in_next_contour = .false. i = 1 do while (i < maxconts) if (cmaxmin == 'min') then if (contvals(i) <= xcentval .and. xcentval < contvals(i+1)) & then if ( verb .ge. 3 ) then print *,'At A, num_found_contours= ',num_found_contours endif contlo = contvals(i+num_found_contours) conthi = contvals(i+1+num_found_contours) if ( verb .ge. 3 ) then print *,'At A, contlo= ',contlo,' conthi= ',conthi endif exit endif else if (contvals(i) < xcentval .and. xcentval <= contvals(i+1)) & then contlo = contvals(i-num_found_contours) conthi = contvals(i-num_found_contours+1) exit endif endif i = i + 1 enddo if ( verb .ge. 3 ) then print *,' ' print *,'num_found_contours= ',num_found_contours print *,'contlo= ',contlo,' conthi= ',conthi print *,'xcentval= ',xcentval endif c This single_contour_scan_loop is the main loop for searching c for one individual contour. If it is determined that a contour c exists, control is returned to the successive_contours_loop, c and if more contours were requested to be found, then the c search continues onward & outward.... temp_mask_i_loc = 0 temp_mask_j_loc = 0 iter = 1 num_pts_in_one_contour = 0 still_scanning = .true. rlast_distsum = 0.0 rlast_distct = 0 single_contour_scan_loop: do while (still_scanning) c print *,' ' c print *,' top of single contour scan loop' c print *,'+++ iter= ',iter c print *,' N1: next_contour_ct= ',next_contour_ct if (iter == 1 .and. num_found_contours == 0) then ! For the first iteration, we have only the first ring, ! which is centered on the input minimum/maximum point. ringct = 1 search_next_i(1) = ix search_next_j(1) = jx c point_is_already_in_our_contour(ix,jx) = .true. c num_pts_in_one_contour = num_pts_in_one_contour + 1 c temp_mask_i_loc(num_pts_in_one_contour) = ix c temp_mask_j_loc(num_pts_in_one_contour) = jx else if (iter == 1 .and. num_found_contours > 0) then ! This is the first iteration in a *new* contour. ! That is, we have already found 1 or more previous ! contours while in previous iterations of ! successive_contours_loop and we are now beginning ! to look for the next contour. c print *,' N2: next_contour_ct= ',next_contour_ct if (next_contour_ct == 0) then ! This would be for the special case in which, for ! example, you've got a very intense, compact storm ! that "skips" a contour. That is, suppose the ! min pressure of a storm is 982 mb, and we are ! utilizing a 4-mb contour interval, but all ! surrounding data points are, say, 987 mb or ! higher. Then, next_contour_ct would be 0 since no ! data points were found in the next contour interval ! of 982-986 mb, but we can continue searching since the ! gradient is still sloping the correct way. The code in ! this if statement handles this special case. if ( verb .ge. 3 ) then print *,' ' print *,'ALERT: next_contour_ct = 0 ' endif if (cmaxmin == 'min') then contlo_next = conthi conthi_next = conthi + trkrinfo%contint c print *,'b4 ZZ, ringct= ',ringct c print *,'at ZZ, bcc= ',beyond_contour_ct c & ,'contlo_next= ',contlo_next c & ,'conthi_next= ',conthi_next bey_con_min_loop: do nb = 1,beyond_contour_ct ibx = beyond_contour_i(nb) jby = beyond_contour_j(nb) if (.not. point_is_already_in_beyond_pool(ibx,jby)) & then ! If this point is no longer in our pool of "beyond ! contour" points, then just cycle out of this ! iteration.... cycle bey_con_min_loop endif c print *,'-- ZZ, ibx= ',ibx,' jby= ',jby c & ,' fxy(ibx,jby)= ',fxy(ibx,jby) if (fxy(ibx,jby) >= contlo_next .and. & fxy(ibx,jby) < conthi_next) then c print *,'>> ZZ HIT!!, ibx= ',ibx,' jby= ',jby c c print *,' +++ BEYOND in NEXT: i= ',ibx,' j= ',jby c & ,' fxy= ',fxy(ibx,jby) next_contour_ct = next_contour_ct + 1 next_contour_i(next_contour_ct) = ibx next_contour_j(next_contour_ct) = jby ! This point has now been identified as being in ! the "next" contour interval, i.e., no longer in ! the "beyond" contour pool. Therefore, set the ! logical flag to indicate that this point is no ! longer in the "beyond" contour pool. point_is_already_in_beyond_pool(ibx,jby) = .false. endif c print *,'.. ZZ, next_contour_ct= ',next_contour_ct enddo bey_con_min_loop else contlo_next = contlo - trkrinfo%contint conthi_next = contlo c print *,'At A, beyond_contour_ct= ',beyond_contour_ct c print *,' contlo_next = ',contlo_next c print *,' conthi_next = ',conthi_next bey_con_max_loop: do nb = 1,beyond_contour_ct c print *,'in bey_con_max_loop, nb= ',nb ibx = beyond_contour_i(nb) jby = beyond_contour_j(nb) if (.not. point_is_already_in_beyond_pool(ibx,jby)) & then ! If this point is no longer in our pool of "beyond ! contour" points, then just cycle out of this ! iteration.... cycle bey_con_max_loop endif c print *,'ibx= ',ibx,' jby= ',jby,' data= ' c & ,fxy(ibx,jby) if (fxy(ibx,jby) > contlo_next .and. & fxy(ibx,jby) <= conthi_next) then next_contour_ct = next_contour_ct + 1 next_contour_i(next_contour_ct) = ibx next_contour_j(next_contour_ct) = jby c print *,' ++ HIT! ibx= ',ibx,' jby= ',jby ! This point has now been identified as being in ! the "next" contour interval, i.e., no longer in ! the "beyond" contour pool. Therefore, set the ! logical flag to indicate that this point is no ! longer in the "beyond" contour pool. point_is_already_in_beyond_pool(ibx,jby) = .false. endif enddo bey_con_max_loop endif if (next_contour_ct > 0) then ringct = next_contour_ct else if ( verb .ge. 3 ) then print *,' ' print *,'!!! XXX next_contour_ct not > 0 !!!' print *,'next_contour_ct= ',next_contour_ct print *,'beyond_contour_ct= ',beyond_contour_ct print *,'ringct= ',ringct print *,'next_ring_ct= ',next_ring_ct print *,'cycling to top of successive_contours_loop..' print *,' ' endif ! The number of rings that we have available to search ! in the next contour interval is 0, so cycle all the ! way back to the top of the outer loop, which is ! successive_contours_loop, so that we can increase the ! contour bounds and search inside those new bounds. ! Again, this is for the case in which we have an ! intense, compact storm and we are using a small ! contour interval, such that we are essentially ! "skipping" over one of these intervals in one of the ! loop iterations. We need to bump up the ! num_found_contours by one in order to increase the ! array index in the contvals array at the top of the ! successive_contours_loop. It is kosher to do this ! since the reason we are cycling back to the top of ! that loop is that we are skipping over a contour ! interval. num_found_contours = num_found_contours + 1 cycle successive_contours_loop endif else ringct = next_contour_ct endif do nring = 1,ringct search_next_i(nring) = next_contour_i(nring) search_next_j(nring) = next_contour_j(nring) c print *,'at A, nring= ',nring,' next_contour_i(nring)= ' c & ,next_contour_i(nring),' next_contour_j(nring)= ' c & ,next_contour_j(nring) enddo next_contour_ct = 0 else ringct = next_ring_ct endif if (allocated(ringposi)) deallocate (ringposi) if (allocated(ringposj)) deallocate (ringposj) allocate (ringposi(ringct),stat=iria) allocate (ringposj(ringct),stat=irja) if (iria /= 0 .or. irja /= 0) then if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in check_closed_contour allocating' print *,'!!! various ring arrays. iria = ',iria print *,'!!! irja = ',irja print *,' ' endif STOP 98 endif ctm c print *,' ' c print *,'ringct= ',ringct do nring = 1,ringct ringposi(nring) = search_next_i(nring) ringposj(nring) = search_next_j(nring) ctm c print *,'nring= ',nring,' ringposi= ',ringposi(nring) c & ,' ringposj= ',ringposj(nring) enddo next_ring_ct = 0 ! This next loop reviews the points that have been ! labelled for the "beyond_contour" pool. As we get further ! into successive iterations of successive_contours_loop, ! some of these previously "beyond" points are now within ! the contour interval range that we are checking, so we ! need to go through the list of "beyond" points and remove ! any that are no longer in that "beyond" category.... check_beyond_loop: do nb = 1,beyond_contour_ct ibx = beyond_contour_i(nb) jby = beyond_contour_j(nb) if (.not. point_is_already_in_beyond_pool(ibx,jby)) & then ! This point may have been removed already in a ! previous iteration of successive_contours_loop. ! If this point is no longer in our pool of "beyond ! contour" points, then just cycle out of this ! iteration.... cycle check_beyond_loop endif ! Check to see if any of the points being searched in the ! upcoming multiple_ring_loop are points that had previously ! been saved as "beyond_contour" points. If so, remove ! their status as "beyond_contour" points by setting the ! logical flag to false. do nring = 1,ringct if (ibx == ringposi(nring) .and. jby == ringposj(nring)) & then c print *,' ' c print *,'!!! beyond remove: ibx= ',ibx,' jby= ',jby point_is_already_in_beyond_pool(ibx,jby) = .false. endif enddo enddo check_beyond_loop c In each iteration of single_contour_scan_loop, we can have a c different number of rings to analyze. In the first c iteration, we only have 1 ring, the initial ring around the c local max/min that was input to this subroutine. Subsequent c iterations will have a variable number of rings, depending on c how many new data points within our contour interval were c found in the previous iteration. multiple_ring_loop: do mr = 1,ringct icenx = ringposi(mr) jcenx = ringposj(mr) ctm c print *,' --- iter= ',iter,' mr= ',mr,' icenx= ',icenx c & ,' jcenx= ',jcenx,' imax= ',imax,' jmax= ',jmax call get_ijplus1_check_wrap (imax,jmax,icenx,jcenx,ixp1,jxp1 & ,ixm1,jxm1,trkrinfo,igicwret) if (igicwret /= 0) then if ( verb .ge. 3 ) then print *,' ' print *,'!!! NO CLOSED CONTOUR: The call to ' print *,'!!! get_ijplus1_check_wrap indicates the' print *,'!!! max/min contour extends past the edge of' print *,'!!! our regional grid. ' print *,' ' print *,' ' endif do nm = 1,num_pts_in_all_contours im = hold_mask_i_loc(nm) jm = hold_mask_j_loc(nm) masked_out(im,jm) = .true. enddo deallocate (ringposi); deallocate (ringposj) deallocate (search_next_i); deallocate (search_next_j) deallocate (next_contour_i); deallocate (next_contour_j) deallocate (beyond_contour_i) deallocate (beyond_contour_j) deallocate (hold_mask_i_loc) deallocate (hold_mask_j_loc) deallocate (temp_mask_i_loc) deallocate (temp_mask_j_loc) icccret = 0 return endif c For each individual ring, we check all 8 points surrounding c the center point. The points are numbered for each ring as c shown in the diagram to the right of the "select case" c statement just below. REMEMBER: The j in our grids c increases from north to south, so that for a global grid, c j=1 is at 90N and j=jmax is at 90S. individual_ring_loop: do ir = 1,9 select case (ir) case (1); irx=ixm1; jrx=jcenx;! 2 3 4 case (2); irx=ixm1; jrx=jxm1; ! case (3); irx=icenx;jrx=jxm1; ! case (4); irx=ixp1; jrx=jxm1; ! 1 (icenx,jcenx) 5 case (5); irx=ixp1; jrx=jcenx;! case (6); irx=ixp1; jrx=jxp1; ! case (7); irx=icenx;jrx=jxp1; ! 8 7 6 case (8); irx=ixm1; jrx=jxp1; ! case (9); irx=icenx; jrx=jcenx; ! = center pt of ring end select c Make sure the point we are looking at has valid data. c This is an issue only on regional grids, where we have a c buffer of bitmapped (null) data points surrounding the c real grid. c print *,'ind ring loop: ir= ',ir,' irx= ',irx,' jrx= ',jrx if (.not. valid_pt(irx,jrx)) then if ( verb .ge. 3 ) then print *,' ' print *,'!!! NOTE: In check_closed_contour, while ' print *,'!!! checking points around (icenx,jcenx)=' print *,'!!! (',icenx,',',jcenx,'), we hit a non-' print *,'!!! valid point, meaning we are near the' print *,'!!! bounds of the grid, or at least the ' print *,'!!! bounds of the valid data for this ' print *,'!!! grid. We will skip the' print *,'!!! search for this center.' print *,'!!! ' print *,'!!! (i,j) of non-valid pt = (' & ,irx,',',jrx,')' print *,'!!! ' endif do nm = 1,num_pts_in_all_contours im = hold_mask_i_loc(nm) jm = hold_mask_j_loc(nm) masked_out(im,jm) = .true. enddo deallocate (ringposi); deallocate (ringposj) deallocate (search_next_i); deallocate (search_next_j) deallocate (next_contour_i); deallocate (next_contour_j) deallocate (beyond_contour_i) deallocate (beyond_contour_j) deallocate (hold_mask_i_loc) deallocate (hold_mask_j_loc) deallocate (temp_mask_i_loc) deallocate (temp_mask_j_loc) icccret = 0 return endif c Check to make sure that the point we are looking at is c not considered under the influence of another nearby low. if (masked_out(irx,jrx)) then if ( verb .ge. 3 ) then print *,' ' print *,'!!! NOTE: In check_closed_contour, while ' print *,'!!! checking points around (icenx,jcenx)=' print *,'!!! (',icenx,',',jcenx,'), we hit a point' print *,'!!! that has been masked out, meaning it' print *,'!!! belongs under the influence of ' print *,'!!! another nearby low, so we will skip' print *,'!!! the search for this center....' print *,'!!! ' print *,'!!! Min central value = ',xcentval print *,'!!! (i,j) of central value = (',ix,',',jx,')' print *,'!!! ' print *,'!!! Masked-out value found = ',fxy(irx,jrx) print *,'!!! (i,j) of masked value = (',irx,',' & ,jrx,')' print *,'!!! ' print *,'!!! Lower bound of contour interval = ' & ,contlo print *,'!!! Upper bound of contour interval = ' & ,conthi print *,'!!! Contour interval = ',trkrinfo%contint print *,'!!! ' print *,'!!! closed_contour flag = ',closed_contour print *,'!!! ' endif do nm = 1,num_pts_in_all_contours im = hold_mask_i_loc(nm) jm = hold_mask_j_loc(nm) masked_out(im,jm) = .true. enddo deallocate (ringposi); deallocate (ringposj) deallocate (search_next_i); deallocate (search_next_j) deallocate (next_contour_i); deallocate (next_contour_j) deallocate (beyond_contour_i) deallocate (beyond_contour_j) deallocate (hold_mask_i_loc) deallocate (hold_mask_j_loc) deallocate (temp_mask_i_loc) deallocate (temp_mask_j_loc) icccret = 0 return endif c If we have already hit this point on a previous ring c check, then just ignore this point and cycle past it. if (point_is_already_in_our_contour(irx,jrx)) then ctm c print *,' ' c print *,'Pt. AAA, already-in-contour.....' c print *,'irx= ',irx,' jrx= ',jrx cycle individual_ring_loop endif c For a MIN check, check to see if the data point is below c the contour interval or is below the local minimum value c passed into this subroutine. In either case, exit and c consider this to NOT be a closed contour. c For a MAX check, check to see if the data point is above c the contour interval or is above the local maximum value c passed into this subroutine. In either case, exit and c consider this to NOT be a closed contour. c c For example, for mslp, this would be as we're moving c outward away from lower pressures to higher pressures, c and then all of a sudden we come upon a lower pressure. c This probably means we're heading toward another low c pressure area, so mark the point and return to the c calling routine. found_a_point_below_contour = 'n' found_a_point_above_contour = 'n' if (cmaxmin == 'min') then if (fxy(irx,jrx) < xcentval .or. fxy(irx,jrx) < contlo) & then found_a_point_below_contour = 'y' endif else if (fxy(irx,jrx) > xcentval .or. fxy(irx,jrx) > conthi) & then found_a_point_above_contour = 'y' endif endif if (found_a_point_below_contour == 'y' .or. & found_a_point_above_contour == 'y') then if ( verb .ge. 3 ) then print *,' ' print *,'!!! NOTE: In check_closed_contour, while ' print *,'!!! checking points around (icenx,jcenx)=' print *,'!!! (',icenx,',',jcenx,'), we hit a data' print *,'!!! value that is less (greater) than the' print *,'!!! current contour interval bound for a' print *,'!!! min (max) and/or is less (greater) ' print *,'!!! than the minimum (maximum) central ' print *,'!!! value that we are centering the ' print *,'!!! search on.' print *,'!!! ' print *,'!!! Central value = ',xcentval print *,'!!! (i,j) of central value = (',ix,',',jx,')' print *,'!!! ' print *,'!!! Flagged value found = ',fxy(irx,jrx) print *,'!!! (i,j) of flagged value = (',irx,',' & ,jrx,')' print *,'!!! ' print *,'!!! Lower bound of contour interval = ' & ,contlo print *,'!!! Upper bound of contour interval = ' & ,conthi print *,'!!! Contour interval = ',trkrinfo%contint print *,'!!! ' print *,'!!! closed_contour flag = ',closed_contour print *,'!!! ' endif do nm = 1,num_pts_in_all_contours im = hold_mask_i_loc(nm) jm = hold_mask_j_loc(nm) masked_out(im,jm) = .true. enddo deallocate (ringposi); deallocate (ringposj) deallocate (search_next_i); deallocate (search_next_j) deallocate (next_contour_i); deallocate (next_contour_j) deallocate (beyond_contour_i) deallocate (beyond_contour_j) deallocate (hold_mask_i_loc) deallocate (hold_mask_j_loc) deallocate (temp_mask_i_loc) deallocate (temp_mask_j_loc) icccret = 0 return endif c If we've made it this far, then we at least know that the c gradient is still heading in the right direction. Do the c check now to see if the value at this point is within our c specific contour interval (there is the possibility that c the value is beyond our interval, which will be checked c for just below, and if that's the case, then that point c will be processed in a subsequent iteration of this loop c that encompasses that correct contour interval). found_a_point_in_our_contour = 'n' if (cmaxmin == 'min') then if (fxy(irx,jrx) >= contlo .and. fxy(irx,jrx) < conthi) & then found_a_point_in_our_contour = 'y' endif else if (fxy(irx,jrx) > contlo .and. fxy(irx,jrx) <= conthi) & then found_a_point_in_our_contour = 'y' endif endif if (found_a_point_in_our_contour == 'y') then ! We've found a data point in our interval, something ! that is inside the closed contour, and it hasn't been ! marked as being found in a previous iteration of this ! loop, so mark it now and store the (i,j) location so ! that we can scan a ring around this point in a ! successive iteration of this loop for more potential ! points within this interval... point_is_already_in_our_contour(irx,jrx) = .true. next_ring_ct = next_ring_ct + 1 search_next_i(next_ring_ct) = irx search_next_j(next_ring_ct) = jrx c print *,'at B, next_ring_ct= ',next_ring_ct c & ,' search_next_i()= ',search_next_i(next_ring_ct) c & ,' search_next_j()= ',search_next_j(next_ring_ct) num_pts_in_one_contour = num_pts_in_one_contour + 1 temp_mask_i_loc(num_pts_in_one_contour) = irx temp_mask_j_loc(num_pts_in_one_contour) = jrx if (get_last_isobar_flag == 'y') then call calcdist (glon(ix),glat(jx) & ,glon(irx),glat(jrx),dist,degrees) rlast_distsum = rlast_distsum + dist rlast_distct = rlast_distct + 1 endif ctm c print *,' ' c print *,' PT IN! irx= ',irx,' jrx= ',jrx,' xval= ' c & ,fxy(irx,jrx) c print *,'next_ring_ct= ',next_ring_ct c print *,'num_pts_in_one_contour= ' c & ,num_pts_in_one_contour endif c If we've made it this far AND the c found_a_point_in_our_contour flag indicates that this c point is not in our contour interval, then by default that c means that this point is for a contour interval beyond c what we're currently looking at. E.g., if we're looking c at the contours around a 972 mb low and we're moving c outward and currently checking the 984-988 mb contour c interval, it means that we found, say, a gridpoint with c 991 mb. So we want to mark that point for a future c iteration of this loop that would be checking the c 988-992 mb contour interval. if (found_a_point_in_our_contour /= 'y' .and. & .not. point_is_already_in_next_contour(irx,jrx)) then ! We've found a data point that is beyond our interval, ! so this is not a concern for finding the bounds of ! our current contour interval, but we want to mark ! these points and remember them for the next iteration ! of successive_scan_loop. (For example, suppose we ! are currently searching for points in the 984-988 mb ! range, and we find a point that is 990 -- mark it ! here to be remembered when we scan for 988-992 mb). if (cmaxmin == 'min') then contlo_next = conthi conthi_next = conthi + trkrinfo%contint if (fxy(irx,jrx) >= contlo_next .and. & fxy(irx,jrx) < conthi_next) then ! "NEXT_CONTOUR" Comment: ! We've found a point that is in the very next ! contour interval.... next_contour_ct = next_contour_ct + 1 next_contour_i(next_contour_ct) = irx next_contour_j(next_contour_ct) = jrx point_is_already_in_next_contour(irx,jrx) = .true. else if (fxy(irx,jrx) >= conthi_next) then ! "BEYOND_CONTOUR" Comment: ! This point is at least 1 contour interval beyond ! the next contour interval. Dump the info into ! these i and j arrays. This info will be used if ! in the next iteration of single_contour_scan_loop, ! next_contour_ct = 0. That would mean that we ! have, e.g., an intensely deep low with a sharp ! mslp gradient that essentially "skips" over a ! contour interval. E.g., if using a 4 mb interval, ! we go from 947 to 953 AND there are NO ! intervening gridpoints in the 948-952 interval. beyond_contour_ct = beyond_contour_ct + 1 beyond_contour_i(beyond_contour_ct) = irx beyond_contour_j(beyond_contour_ct) = jrx point_is_already_in_beyond_pool(irx,jrx) = .true. c print *,'bcc= ',beyond_contour_ct c & ,'beyond_contour_i()= ' c & ,beyond_contour_i(beyond_contour_ct) c & ,'beyond_contour_j()= ' c & ,beyond_contour_j(beyond_contour_ct) endif else contlo_next = contlo - trkrinfo%contint conthi_next = contlo if (fxy(irx,jrx) > contlo_next .and. & fxy(irx,jrx) <= conthi_next) then ! See "NEXT_CONTOUR" comment just above.... next_contour_ct = next_contour_ct + 1 next_contour_i(next_contour_ct) = irx next_contour_j(next_contour_ct) = jrx point_is_already_in_next_contour(irx,jrx) = .true. c print *,'NEXT ncc= ',next_contour_ct c & ,'next_contour_i()= ' c & ,next_contour_i(next_contour_ct) c & ,'next_contour_j()= ' c & ,next_contour_j(next_contour_ct) c & ,' fxy= ',fxy(irx,jrx) else if (fxy(irx,jrx) <= contlo_next) then ! See "BEYOND_CONTOUR" comment just above.... beyond_contour_ct = beyond_contour_ct + 1 beyond_contour_i(beyond_contour_ct) = irx beyond_contour_j(beyond_contour_ct) = jrx point_is_already_in_beyond_pool(irx,jrx) = .true. c print *,'BEYOND bcc= ',beyond_contour_ct c & ,'beyond_contour_i()= ' c & ,beyond_contour_i(beyond_contour_ct) c & ,'beyond_contour_j()= ' c & ,beyond_contour_j(beyond_contour_ct) c & ,' fxy= ',fxy(irx,jrx) endif endif endif enddo individual_ring_loop enddo multiple_ring_loop if (next_ring_ct > 0) then iter = iter + 1 else icccret = 0 still_scanning = .false. if (allocated(ringposi)) deallocate (ringposi) if (allocated(ringposj)) deallocate (ringposj) num_found_contours = num_found_contours + 1 closed_contour = 'y' if (num_found_contours == 1) then if ( verb .ge. 3 ) then print *,' ' print *,'+++ Closed contour found ' endif endif endif enddo single_contour_scan_loop do insingle = 1,num_pts_in_one_contour num_pts_in_all_contours = num_pts_in_all_contours + 1 inall = num_pts_in_all_contours hold_mask_i_loc(inall) = temp_mask_i_loc(insingle) hold_mask_j_loc(inall) = temp_mask_j_loc(insingle) enddo if (get_last_isobar_flag == 'y') then if (cmaxmin == 'min') then plastbar = conthi else plastbar = contlo endif if (rlast_distct > 0) then rlastbar = rlast_distsum / float(rlast_distct) rlastbar = rlastbar * 0.539638 ! convert km to nm else rlastbar = -999.0 endif endif enddo successive_contours_loop if ( verb .ge. 3 ) then print *,' ' print *,'END SUM: num of iterations = ',isc_count endif do nm = 1,num_pts_in_all_contours im = hold_mask_i_loc(nm) jm = hold_mask_j_loc(nm) masked_out(im,jm) = .true. enddo if (allocated(search_next_i)) deallocate (search_next_i) if (allocated(search_next_j)) deallocate (search_next_j) if (allocated(next_contour_i)) deallocate (next_contour_i) if (allocated(next_contour_j)) deallocate (next_contour_j) if (allocated(beyond_contour_i)) deallocate (beyond_contour_i) if (allocated(beyond_contour_j)) deallocate (beyond_contour_j) if (allocated(hold_mask_i_loc)) deallocate (hold_mask_i_loc) if (allocated(hold_mask_j_loc)) deallocate (hold_mask_j_loc) if (allocated(temp_mask_i_loc)) deallocate (temp_mask_i_loc) if (allocated(temp_mask_j_loc)) deallocate (temp_mask_j_loc) if (allocated(ringposi)) deallocate (ringposi) if (allocated(ringposj)) deallocate (ringposj) c return end c c--------------------------------------------------------------------- c c--------------------------------------------------------------------- subroutine check_land_mask (imax,jmax,ix,jx,fract_land,valid_pt & ,dx,dy,point_is_over_water,iclmret) c c ABSTRACT: This subroutine looks at the values for the land-sea c mask surrounding an input (i,j) position to determine if less c than 50% of the area surrounding the input (i,j) position within c 75 km radius is land. c c INPUT: c imax Num pts in i-direction on grid c jmax Num pts in j-direction on grid c ix i index for location of local max or min c jx j index for location of local max or min c valid_pt Logical; bitmap indicating if valid data at that pt c dx Grid spacing in x-direction c dy Grid spacing in y-direction c c OUTPUT: c fract_land Fraction of points/area that is covered by land c point_is_over_water y/n: A value of 'y' is returned if <50% c of the points/area is covered by land c iclmret Return code from this routine c USE grid_bounds; USE tracked_parms USE trkrparms; USE verbose_output implicit none type (trackstuff) trkrinfo integer date_time(8) character (len=10) big_ben(3) logical(1) valid_pt(imax,jmax) character point_is_over_water*1 integer, parameter :: numazim=8 integer iazim,ibiret1,imax,jmax,ix,jx,iclmret,imct real bear,targlat,targlon,xplon,yplat,rdist,xintrp_mask real fract_land,dx,dy,xmask_sum c iclmret = 0 c First, calculate the longitude and latitude of the input ix and c jx points. If the xplon value ends up being >360.0 (this can c happen for basin-scale HWRF), don't worry about it. Just leave c it be, as the trigonometry will work out the same for lons >360. xplon = glonmin + (ix-1)*dx yplat = glatmax - (jx-1)*dy rdist = 75.0 ! (We will always look only 75 km radius out for ! this particular land-sea mask application) imct = 0 c Now go around the storm via azimloop and get interpolated c values of the land-sea mask at each azimuth at a radial c distance of 75 km from the center point.... xmask_sum = 0.0 azimloop: do iazim = 1,numazim bear = ((iazim-1) * 15.) + 45.0 call distbear (yplat,xplon,rdist,bear,targlat,targlon) ! These calls to bilin_int_uneven pass a variable, level, ! that is used for applications of interpolating wind ! data. Here, we are instead interpolating the land-sea ! mask data, so we don't care about the level, so just ! pass a dummy value of 850, which never gets used. call bilin_int_uneven (targlat,targlon & ,dx,dy,imax,jmax,trkrinfo,850,'m',xintrp_mask,ibiret1) if (ibiret1 == 0) then xmask_sum = xmask_sum + xintrp_mask imct = imct + 1 else iclmret = 95 return endif enddo azimloop c Now get the mask value directly at the point that was input to c this routine.... xmask_sum = xmask_sum + lsmask(ix,jx) imct = imct + 1 c Now get the mean land fraction.... if (imct > 0) then fract_land = xmask_sum / float(imct) if (fract_land < 0.50) then point_is_over_water = 'y' if ( verb .ge. 3 ) then print *,' ' print *,'+++ Land check yes: Point is over water. ' print *,' Land check value: fract_land= ',fract_land endif else point_is_over_water = 'n' if ( verb .ge. 3 ) then print *,' ' print *,'!!! Land check NO: Point is over land. ' print *,' Land check value: fract_land= ',fract_land endif endif else iclmret = 95 return endif c return end c c--------------------------------------------------------------------- c c--------------------------------------------------------------------- subroutine get_ijplus1_check_wrap (imax,jmax,i,j,iplus1,jplus1 & ,iminus1,jminus1,trkrinfo,igicwret) c c ABSTRACT: This subroutine takes an (i,j) position input and c returns the four neighboring (i,j) points to the east, south, c west and north. The routine checks for wrap around the GM, so c that if, for example, you are on a global 360x181 grid and you c are at point i=360, then i+1 = 361, so you need something to c adjust that back to i = 1. Likewise, if you are at i=1 and c looking for point i-1, it will adjust it to be point 360 c instead of the meaningless point 0 (i=0). USE trkrparms USE verbose_output implicit none type (trackstuff) trkrinfo integer i,j,imax,jmax,iplus1,jplus1,iminus1,jminus1,igicwret igicwret = 0 jplus1 = j + 1 jminus1 = j - 1 iplus1 = i + 1 iminus1 = i - 1 if (iplus1 > imax) then if (trkrinfo%gridtype == 'global') then iplus1 = iplus1 - imax ! If wrapping east of GM else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: Error in get_ijplus1_check_wrap. The' print *,'!!! user-requested eastern search boundary' print *,'!!! is too close to the eastern bounds of' print *,'!!! this regional grid. When we check ' print *,'!!! neighboring points, we are going past' print *,'!!! the edge of the grid by one point. ' print *,'!!! Cut back your requested eastern ' print *,'!!! boundary by a degree or 2 in the ' print *,'!!! script and resubmit....' print *,'!!! ' print *,'!!! imax of regional grid = ',imax print *,'!!! User-requested eastern i = ',iplus1 print *,' ' endif igicwret = 98 return endif endif if (iminus1 < 1) then if (trkrinfo%gridtype == 'global') then iminus1 = imax + iminus1 ! If wrapping west of GM else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: Error in get_ijplus1_check_wrap. The' print *,'!!! user-requested western search boundary' print *,'!!! is too close to the western bounds of' print *,'!!! this regional grid. When we check ' print *,'!!! neighboring points, we are going past' print *,'!!! the edge of the grid by one point. ' print *,'!!! Cut back your requested western ' print *,'!!! boundary by a degree or 2 in the ' print *,'!!! script and resubmit....' print *,'!!! ' print *,'!!! User-requested western i = ',iminus1 print *,' ' endif igicwret = 98 return endif endif if (jplus1 > jmax .or. jminus1 < 1) then if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR: Error in get_ijplus1_check_wrap. The ' print *,'!!! user-requested northern or southern search' print *,'!!! boundary is too close to the bounds of the' print *,'!!! grid. Cut back your requested northern or' print *,'!!! southern boundary by a degree or 2 in the' print *,'!!! script and resubmit....' print *,'!!! ' print *,'!!! User-requested northern j = ',jminus1 print *,'!!! User-requested southern j = ',jplus1 print *,'!!! jmax of grid = ',jmax print *,' ' endif igicwret = 91 return endif return end c------------------------------------------------------------------ c c------------------------------------------------------------------ SUBROUTINE qsort(x,ind,n) c c Code converted using TO_F90 by Alan Miller c Date: 2002-12-18 Time: 11:55:47 IMPLICIT NONE INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(12, 60) REAL (dp), INTENT(IN) :: x(n) INTEGER, INTENT(OUT) :: ind(n) INTEGER, INTENT(IN) :: n c *************************************************************************** c c ROBERT RENKA c OAK RIDGE NATL. LAB. c c THIS SUBROUTINE USES AN ORDER N*LOG(N) QUICK SORT TO SORT A REAL (dp) c ARRAY X INTO INCREASING ORDER. THE ALGORITHM IS AS FOLLOWS. IND IS c INITIALIZED TO THE ORDERED SEQUENCE OF INDICES 1,...,N, AND ALL INTERCHANGES c ARE APPLIED TO IND. X IS DIVIDED INTO TWO PORTIONS BY PICKING A CENTRAL c ELEMENT T. THE FIRST AND LAST ELEMENTS ARE COMPARED WITH T, AND c INTERCHANGES ARE APPLIED AS NECESSARY SO THAT THE THREE VALUES ARE IN c ASCENDING ORDER. INTERCHANGES ARE THEN APPLIED SO THAT ALL ELEMENTS c GREATER THAN T ARE IN THE UPPER PORTION OF THE ARRAY AND ALL ELEMENTS c LESS THAN T ARE IN THE LOWER PORTION. THE UPPER AND LOWER INDICES OF ONE c OF THE PORTIONS ARE SAVED IN LOCAL ARRAYS, AND THE PROCESS IS REPEATED c ITERATIVELY ON THE OTHER PORTION. WHEN A PORTION IS COMPLETELY SORTED, c THE PROCESS BEGINS AGAIN BY RETRIEVING THE INDICES BOUNDING ANOTHER c UNSORTED PORTION. c c INPUT PARAMETERS - N - LENGTH OF THE ARRAY X. c c X - VECTOR OF LENGTH N TO BE SORTED. c c IND - VECTOR OF LENGTH >= N. c c N AND X ARE NOT ALTERED BY THIS ROUTINE. c c OUTPUT PARAMETER - IND - SEQUENCE OF INDICES 1,...,N PERMUTED IN THE SAME c FASHION AS X WOULD BE. THUS, THE ORDERING ON c X IS DEFINED BY Y(I) = X(IND(I)). c c ********************************************************************* ! NOTE -- IU AND IL MUST BE DIMENSIONED >= LOG(N) WHERE LOG HAS BASE 2. !********************************************************************* INTEGER :: iu(21), il(21) INTEGER :: m, i, j, k, l, ij, it, itt, indx REAL :: r REAL (dp) :: t ! LOCAL PARAMETERS - ! IU,IL = TEMPORARY STORAGE FOR THE UPPER AND LOWER ! INDICES OF PORTIONS OF THE ARRAY X ! M = INDEX FOR IU AND IL ! I,J = LOWER AND UPPER INDICES OF A PORTION OF X ! K,L = INDICES IN THE RANGE I,...,J ! IJ = RANDOMLY CHOSEN INDEX BETWEEN I AND J ! IT,ITT = TEMPORARY STORAGE FOR INTERCHANGES IN IND ! INDX = TEMPORARY INDEX FOR X ! R = PSEUDO RANDOM NUMBER FOR GENERATING IJ ! T = CENTRAL ELEMENT OF X IF (n <= 0) RETURN ! INITIALIZE IND, M, I, J, AND R DO i = 1, n ind(i) = i END DO m = 1 i = 1 j = n r = .375 ! TOP OF LOOP 20 IF (i >= j) GO TO 70 IF (r <= .5898437) THEN r = r + .0390625 ELSE r = r - .21875 END IF ! INITIALIZE K 30 k = i ! SELECT A CENTRAL ELEMENT OF X AND SAVE IT IN T ij = i + r*(j-i) it = ind(ij) t = x(it) ! IF THE FIRST ELEMENT OF THE ARRAY IS GREATER THAN T, ! INTERCHANGE IT WITH T indx = ind(i) IF (x(indx) > t) THEN ind(ij) = indx ind(i) = it it = indx t = x(it) END IF ! INITIALIZE L l = j ! IF THE LAST ELEMENT OF THE ARRAY IS LESS THAN T, ! INTERCHANGE IT WITH T indx = ind(j) IF (x(indx) >= t) GO TO 50 ind(ij) = indx ind(j) = it it = indx t = x(it) ! IF THE FIRST ELEMENT OF THE ARRAY IS GREATER THAN T, ! INTERCHANGE IT WITH T indx = ind(i) IF (x(indx) <= t) GO TO 50 ind(ij) = indx ind(i) = it it = indx t = x(it) GO TO 50 ! INTERCHANGE ELEMENTS K AND L 40 itt = ind(l) ind(l) = ind(k) ind(k) = itt ! FIND AN ELEMENT IN THE UPPER PART OF THE ARRAY WHICH IS ! NOT LARGER THAN T 50 l = l - 1 indx = ind(l) IF (x(indx) > t) GO TO 50 ! FIND AN ELEMENT IN THE LOWER PART OF THE ARRAY WHCIH IS NOT SMALLER THAN T 60 k = k + 1 indx = ind(k) IF (x(indx) < t) GO TO 60 ! IF K <= L, INTERCHANGE ELEMENTS K AND L IF (k <= l) GO TO 40 ! SAVE THE UPPER AND LOWER SUBSCRIPTS OF THE PORTION OF THE ! ARRAY YET TO BE SORTED IF (l-i > j-k) THEN il(m) = i iu(m) = l i = k m = m + 1 GO TO 80 END IF il(m) = k iu(m) = j j = l m = m + 1 GO TO 80 ! BEGIN AGAIN ON ANOTHER UNSORTED PORTION OF THE ARRAY 70 m = m - 1 IF (m == 0) RETURN i = il(m) j = iu(m) 80 IF (j-i >= 11) GO TO 30 IF (i == 1) GO TO 20 i = i - 1 ! SORT ELEMENTS I+1,...,J. NOTE THAT 1 <= I < J AND J-I < 11. 90 i = i + 1 IF (i == j) GO TO 70 indx = ind(i+1) t = x(indx) it = indx indx = ind(i) IF (x(indx) <= t) GO TO 90 k = i 100 ind(k+1) = ind(k) k = k - 1 indx = ind(k) IF (t < x(indx)) GO TO 100 ind(k+1) = it GO TO 90 END SUBROUTINE qsort c c----------------------------------------------------------------------- c Added by JPENG 03/21/2018, regarding FTN compiler with FORT11/FORT31 subroutine open_grib_files (inp,lugb,lugi,gfilename,ifilename & ,lout,iret) C ABSTRACT: This subroutine must be called before any attempt is C made to read from the input GRIB files. The GRIB and index files C are opened with a call to baopenr. This call to baopenr was not C needed in the cray version of this program (the files could be C opened with a simple Cray assign statement), but the GRIB-reading C utilities on the SP do require calls to this subroutine (it has C something to do with the GRIB I/O being done in C on the SP, and C the C I/O package needs an explicit open statement). C C INPUT: c inp Contains user-input info on the date & data C lugb The Fortran unit number for the GRIB data file C lugi The Fortran unit number for the GRIB index file c ifh integer index for lead time level c gfilename If using individual files for each tau, gfilename will c contain the grib data filename for this tau. Otherwise, c if using one big file for all taus, this contains dummy c character data. c ifilename If using individual files for each tau, gfilename will c contain the grib index filename for this tau. Otherwise, c if using one big file for all taus, this contains dummy c character data. C lout The Fortran unit number for the output grib file C C OUTPUT: C iret The return code from this subroutine USE inparms USE verbose_output implicit none c type (datecard) inp logical(1) output_file_open logical(1) file_open character(*) gfilename,ifilename character(120) gopen_g_file,gopen_i_file character(2) lugb_c,lugi_c character(6) enameb,enamei integer igoret,iioret,iooret,lugb,lugi,lout,iret,nlen1,nlen2 iret=0 if (inp%file_seq == 'onebig') then write(lugb_c,'(i2)')lugb write(lugi_c,'(i2)')lugi enameb='FORT'//adjustl(lugb_c) enamei='FORT'//adjustl(lugi_c) call get_environment_variable(enameb,gopen_g_file,status=igoret) call get_environment_variable(enamei,gopen_i_file,status=iioret) if (igoret /= 0 .or. iioret /= 0 .or. iooret /= 0) then gopen_g_file(1:5) = "fort." gopen_i_file(1:5) = "fort." write(gopen_g_file(6:7),'(I2)') lugb write(gopen_i_file(6:7),'(I2)') lugi endif else nlen1 = len_trim(gfilename) gopen_g_file = trim(gfilename(1:nlen1)) nlen2 = len_trim(ifilename) gopen_i_file = trim(ifilename(1:nlen2)) endif call baopenr (lugb,gopen_g_file,igoret) call baopenr (lugi,gopen_i_file,iioret) c print *,'gopen_g_file= ',gopen_g_file,'....' c print *,'gopen_i_file= ',gopen_i_file,'....' inquire (unit=lugb, opened=file_open) if (file_open) then print *,'TEST open_grib_files, unit lugb= ',lugb & ,' is OPEN' else print *,'TEST open_grib_files, unit lugb= ',lugb & ,' is CLOSED' endif inquire (unit=lugi, opened=file_open) if (file_open) then print *,'TEST open_grib_files, unit lugi= ',lugi & ,' is OPEN' else print *,'TEST open_grib_files, unit lugi= ',lugi & ,' is CLOSED' endif if ( verb .ge. 3 ) then print *,' ' print *,'baopen: igoret= ',igoret,' iioret= ',iioret & ,' iooret= ',iooret endif if (igoret /= 0 .or. iioret /= 0 .or. iooret /= 0) then if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in sub open_grib_files opening grib file' print *,'!!! or grib index file. baopen return codes:' print *,'!!! grib file return code = igoret = ',igoret print *,'!!! index file return code = iioret = ',iioret print *,'!!! output file return code = iooret = ',iooret endif iret = 113 return endif return end c----------------------------------------------------------------------- c Added by JPENG 03/21/2018, regarding FTN compiler with FORT12 subroutine read_tcv_card (lucard,maxstorm,trkrinfo,numtcv,iret) c c ABSTRACT: This subroutine reads in the updated TC Vitals file c for the current time and prints out those cards (storms) c that have been selected to be processed. It also c takes the initial positions from the tcv card for each c storm and puts them into the slonfg & slatfg arrays. c Note that this routine is reading in vitals in the c standard format for TCs only. Any genesis vitals are c read in in subroutine read_gen_vitals. c c INPUT: c lucard integer unit number for tcvitals card c trkrinfo derived type that contains info on the type of c tracker run that we are performing. c c OUTPUT: c maxstorm max # of storms to be handled for this case c numtcv number of storms read off of the input tcvitals file c iret return code from this subroutine c c OTHER: c stormswitch 1,2 or 3 (see more description under Main pgm section) c slonfg first guess array for longitude c slatfg first guess array for latitude c storm contains the tcvitals info c (storm, stormswitch, slonfg and slatfg are allocatable and are c defined in module def_vitals) USE def_vitals; USE set_max_parms; USE trkrparms USE verbose_output implicit none type (tcvcard) tmpstorm(maxstorm_tc) type (trackstuff) trkrinfo integer isa,issa,ioa,iaa,ita,iret,ict,maxstorm integer i,ii,lucard,numtcv c------ ii=1 do while (.true. .and. ii <= maxstorm_tc) read (lucard,21,END=801,ERR=891) tmpstorm(ii) ii = ii + 1 enddo 21 format (a4,1x,a3,1x,a9,1x,i8,1x,i4,1x,i3,a1,1x,i4,a1,1x,i3,1x & ,i3,3(1x,i4),1x,i2,1x,i3,1x,4(i4,1x),a1) 801 continue numtcv = ii - 1 if (trkrinfo%type == 'midlat' .or. trkrinfo%type == 'tcgen') then ! For the mid-latitude or tc genesis cases, the max number ! of storms (maxstorm) allowed to be tracked throughout a ! forecast is defined in module set_max_parms. if ( verb .ge. 3 ) then print *,' ' print *,'In read_tcv_card, tracker type of "midlat" or ' print *,'"tcgen" indicates that this run of the tracker is' print *,'for a midlat or a tcgen case....' endif maxstorm = maxstorm_mg allocate (stormswitch(maxstorm),stat=isa) allocate (storm(maxstorm),stat=issa) allocate (slonfg(maxstorm,maxtime),stat=ioa) allocate (slatfg(maxstorm,maxtime),stat=iaa) allocate (stcvtype(maxstorm),stat=ita) if (isa /= 0 .or. ioa /= 0 .or. iaa /= 0 .or. issa /= 0 .or. & ita /= 0) then if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in read_tcv_card allocating stormswitch,' print *,'!!! slonfg, storm, slatfg or stcvtype arrays. ' print *,'!!! isa = ',isa,' ioa= ',ioa,' iaa= ',iaa,' issa= ' print *,'!!! ',issa,' ita= ',ita endif iret = 97 return endif slonfg = 0.0; slatfg = 0.0 stcvtype = 'FOF' ! Found On the Fly by tracker (not on tcvitals) stormswitch = 3 ! Initialize whole array to case of '3' if (numtcv > 0) then if ( verb .ge. 3 ) then print *,' ' print *,'Following are the already-existing storms that' print *,'were read in from the tc vitals file: ' print *,' ' endif ict = 0 do i=1,numtcv stormswitch(i) = 1 storm(i) = tmpstorm(i) ict = ict + 1 if ( verb .ge. 3 ) then write (*,31) storm(i) endif if (storm(i)%tcv_lonew == 'W') then slonfg(i,1) = 360. - float(storm(i)%tcv_lon)/10.0 else slonfg(i,1) = float(storm(i)%tcv_lon)/10.0 endif if (storm(i)%tcv_latns == 'S') then slatfg(i,1) = -1. * float(storm(i)%tcv_lat)/10.0 else slatfg(i,1) = float(storm(i)%tcv_lat)/10.0 endif stcvtype(i) = 'TCV' ! Storm listed on tcvitals c if (trkrinfo%type == 'midlat') then c storm(i)%tcv_center = 'MIDL' c else if (trkrinfo%type == 'tcgen') then c storm(i)%tcv_center = 'TCG ' c endif c write (storm(i)%tcv_storm_id,'(i4.4)') i c write (storm(i)%tcv_storm_name,'(i4.4)') i enddo endif iret=0 return else ! For the tracker cases, the max number of storms (maxstorm) ! allowed to be tracked throughout a forecast is defined by ! the number of vitals read in above. maxstorm = numtcv allocate (stormswitch(maxstorm),stat=isa) allocate (storm(maxstorm),stat=issa) allocate (slonfg(maxstorm,maxtime),stat=ioa) allocate (slatfg(maxstorm,maxtime),stat=iaa) allocate (stcvtype(maxstorm),stat=ita) if (isa /= 0 .or. ioa /= 0 .or. iaa /= 0 .or. issa /= 0 .or. & ita /= 0) then if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in read_tcv_card allocating stormswitch,' print *,'!!! slonfg, storm, slatfg or stcvtype arrays. ' print *,'!!! isa = ',isa,' ioa= ',ioa,' iaa= ',iaa,' issa= ' print *,'!!! ',issa,' ita= ',ita endif iret = 97 return endif if ( verb .ge. 3 ) then print *,' ' print *,'Following are the storms to be processed: ' print *,' ' endif slonfg = 0.0; slatfg = 0.0 stcvtype = ' ' ! Not needed for regular tracker run.... ict=0 do i=1,maxstorm stormswitch(i) = 1 storm(i) = tmpstorm(i) ict = ict + 1 if ( verb .ge. 3 ) then write (*,31) storm(i) endif if (storm(i)%tcv_lonew == 'W') then slonfg(i,1) = 360. - float(storm(i)%tcv_lon)/10.0 else slonfg(i,1) = float(storm(i)%tcv_lon)/10.0 endif if (storm(i)%tcv_latns == 'S') then slatfg(i,1) = -1. * float(storm(i)%tcv_lat)/10.0 else slatfg(i,1) = float(storm(i)%tcv_lat)/10.0 endif enddo if (ict.gt.0) then iret = 0 return else if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in read_tcv_card, num storms to be ' print *,'!!! processed is not greater than 0 for a tracker' print *,'!!! case. Check to see that you have the Fortran' print *,'!!! unit assigned right in your script.' endif iret = 99 return endif endif 31 format (a4,1x,a3,1x,a9,1x,i8.8,1x,i4.4,1x,i3,a1,1x,i4,a1,1x & ,i3,1x,i3,3(1x,i4),1x,i2,1x,i3,1x,4(i4,1x),a1) 891 continue if ( verb .ge. 1 ) then print *,'!!! ERROR in read_tcv_card reading unit ',lucard endif iret = 98 c return end c----------------------------------------------------------------------- c Added by JPENG 03/21/2018, regarding FTN compiler with FORT14 subroutine read_gen_vitals (lgvcard,maxstorm,trkrinfo,numtcv,iret) c c ABSTRACT: This subroutine reads in a modified TC Vitals file c for the current time and prints out those cards (storms) that c have been selected to be processed. It also takes the initial c positions from the tcv card for each storm and puts them into c the slonfg & slatfg arrays. c c The reason that these are referred to as modified tcvitals is c that the format is different from standard TC vitals format. c These vitals are created by a previous run of this tracker c executable, and the storm identifier is different than that c for a standard tcvitals. The storm c identifier contains the date/time that the storm was first c identified, and the lat/lon position at which it was first c identified. c c EXAMPLE: The following is a standard TC Vitals record, split c up over 3 lines: c c NHC 01L ALBERTO 20060614 1200 343N 0807W 035 093 1004 1012 c 0278 15 222 -999 -999 -999 -999 M -999 -999 -999 -999 72 c 520N 410W -999 -999 -999 -999 c c EXAMPLE: The following is the format for the "genesis" vitals, c split over 3 lines, for the same system: c c 2006061000_F000_210N_0853W_01L 20060614 1200 343N 0807W 035 093 c 1004 1012 0278 15 222 -999 -999 -999 -999 M -999 -999 c -999 -999 72 520N 410W -999 -999 -999 -999 c c EXAMPLE: If the vitals record is for a non-officially numbered c system (i.e., any system that's not a TC being tracked c by NHC or JTWC), then the storm number is replaced c by the characters "FOF", for "Found On the Fly" by c the tracker. c c 2006071500_F000_150N_0681W_FOF 20060718 1200 185N 0792W 035 093 c 1004 1012 0278 15 222 -999 -999 -999 -999 M -999 -999 c -999 -999 72 520N 410W -999 -999 -999 -999 c c NOTE: The "F000" in there at character positions 12-15 are to c indicate the forecast hour within that forecast cycle c that the storm was first detected. For a vitals record, c this is always going to be 000 for fhr=0h, and really, c it's not even needed. However, I'm keeping it in there c in order to keep the storm ID format exactly the same c as the output_atcf_sink forecast track record, which c does have a use for that "FXXX" identifier in the c output. c c INPUT: c lgvcard integer unit number for tcgen-tcvitals card c c OUTPUT: c maxstorm max # of storms to be handled for this case c iret return code from this subroutine c c INPUT/OUTPUT: c numtcv As an input, this variable contains the number of c *tropical* cyclone vitals (i.e., regular tcvitals) that c were read off of the input tcvitals file in subroutine c read_tcv_card. This variable will be incremented for c each "modified" vitals record that is read in this c subroutine, and so as output, this variable will c contain the combined total of tcvitals and modified c vitals records. c c OTHER: c stormswitch 1,2 or 3 (see more description under Main pgm section) c slonfg first guess array for longitude c slatfg first guess array for latitude c storm contains the tcvitals info c (storm, stormswitch, slonfg and slatfg are allocatable and are c defined in module def_vitals) c USE def_vitals; USE set_max_parms; USE trkrparms; USE gen_vitals USE verbose_output implicit none type (gencard) tmpstorm(maxstorm_mg) type (trackstuff) trkrinfo integer iret,maxstorm integer i,ii,lgvcard,numtcv,num_mod_vit,vitix,iga c------ ! Read in all of the "genesis vitals" into a temp array. The ! index for the first array member is one past the number of ! tc vitals that were read in in subroutine read_tcv_card. ii = numtcv + 1 do while (.true. .and. ii <= maxstorm_mg) read (lgvcard,24,END=801,ERR=891) tmpstorm(ii) ii = ii + 1 enddo 24 format (i10,2x,i3,1x,i3,a1,1x,i4,a1,1x,a3,1x,i8,1x,i4,1x,i3,a1,1x & ,i4,a1,1x,i3,1x,i3,3(1x,i4),1x,i2,1x,i3,1x,4(i4,1x),a1) 801 continue num_mod_vit = ii - numtcv - 1 allocate (gstorm(maxstorm_mg),stat=iga) if (iga /= 0) then if ( verb .ge. 1 ) then print *,' ' print *,'!!! ERROR in read_gen_vitals allocating gstorm array' print *,'!!! iga = ',iga endif iret = 97 return endif ! Initialize all "genesis dates" to 99999. Any new genesis ! vitals that are read in below will bring in real dates, and ! then we can test the date in output_gen_vitals to know if a ! storm was already defined or not at the beginning of this ! executable or if it was a new storm that was found. do i = 1,maxstorm_mg gstorm(i)%gv_gen_date = 99999 enddo ! If there are any TC vitals (i.e., officially named TCs ! that are being numbered/tracked by either NHC or JTWC), then ! we want to take the important information from those vitals ! and put that into genesis vitals. This will enable us to ! output *all* of these systems in the "gen_vitals" or ! "gstorm" format. The one difference here is that for the ! genesis date, we use the starting date of this forecast, not ! the time that the storm first formed. Also, set the genesis ! forecast hour (gv_gen_fhr) to be 0 for TCs that have a ! TC vitals record. if (numtcv > 0) then do i = 1,numtcv gstorm(i)%gv_gen_date = storm(i)%tcv_ymd * 100 + & storm(i)%tcv_hhmm / 100 gstorm(i)%gv_gen_fhr = 0 gstorm(i)%gv_gen_lat = storm(i)%tcv_lat gstorm(i)%gv_gen_latns = storm(i)%tcv_latns gstorm(i)%gv_gen_lon = storm(i)%tcv_lon gstorm(i)%gv_gen_lonew = storm(i)%tcv_lonew gstorm(i)%gv_gen_type = storm(i)%tcv_storm_id gstorm(i)%gv_obs_ymd = storm(i)%tcv_ymd gstorm(i)%gv_obs_hhmm = storm(i)%tcv_hhmm gstorm(i)%gv_obs_lat = storm(i)%tcv_lat gstorm(i)%gv_obs_latns = storm(i)%tcv_latns gstorm(i)%gv_obs_lon = storm(i)%tcv_lon gstorm(i)%gv_obs_lonew = storm(i)%tcv_lonew if ( verb .ge. 3 ) then write (*,34) gstorm(i) endif enddo endif if (num_mod_vit > 0) then if ( verb .ge. 3 ) then print *,' ' print *,'Following are the vitals for storms that were' print *,'read in from the modified (genesis) tc vitals file: ' print *,' ' endif do i=1,num_mod_vit vitix = i + numtcv stormswitch(vitix) = 1 ! On the following line we are filling the array gstorm, ! which is new in this subroutine. Note, however, that we ! are not necessarily starting it at 1, but at the point in ! the array after any TC Vitals may have been read in. gstorm(vitix) = tmpstorm(vitix) if ( verb .ge. 3 ) then write (*,34) gstorm(vitix) endif ! For the sake of consistency (and sanity!!), we need to also ! use the same "storm" array as was used in read_tcv_card, ! since this "storm" array is used often throughout the rest ! of this executable. write (storm(vitix)%tcv_storm_id,'(i4.4)') vitix write (storm(vitix)%tcv_storm_name,'(i4.4)') vitix storm(vitix)%tcv_ymd = gstorm(vitix)%gv_obs_ymd storm(vitix)%tcv_hhmm = gstorm(vitix)%gv_obs_hhmm storm(vitix)%tcv_lat = gstorm(vitix)%gv_obs_lat storm(vitix)%tcv_latns = gstorm(vitix)%gv_obs_latns storm(vitix)%tcv_lon = gstorm(vitix)%gv_obs_lon storm(vitix)%tcv_lonew = gstorm(vitix)%gv_obs_lonew storm(vitix)%tcv_stdir = gstorm(vitix)%gv_stdir storm(vitix)%tcv_stspd = gstorm(vitix)%gv_stspd if (trkrinfo%type == 'midlat') then storm(vitix)%tcv_center = 'MIDL' else if (trkrinfo%type == 'tcgen') then storm(vitix)%tcv_center = 'TCG ' endif if (gstorm(vitix)%gv_obs_lonew == 'W') then slonfg(vitix,1) = 360. - float(gstorm(vitix)%gv_obs_lon) & / 10.0 else slonfg(vitix,1) = float(gstorm(vitix)%gv_obs_lon)/10.0 endif if (gstorm(vitix)%gv_obs_latns == 'S') then slatfg(vitix,1) = -1. * float(gstorm(vitix)%gv_obs_lat)/10.0 else slatfg(vitix,1) = float(gstorm(vitix)%gv_obs_lat)/10.0 endif stcvtype(vitix) = 'FOF' ! Storm "Found On the Fly" by tracker enddo endif 34 format (i10,1x,'F',i3.3,1x,i3.3,a1,1x,i4.4,a1,1x,a3,1x,i8,1x,i4.4 & ,1x,i3.3,a1,1x,i4.4,a1,1x,i3,1x,i3,3(1x,i4),1x,i2,1x,i3,1x & ,4(i4,1x),a1) c Update the total number of vitals that have been read in numtcv = numtcv + num_mod_vit goto 895 c 891 continue if ( verb .ge. 1 ) then print *,'!!! ERROR in read_gen_vitals reading unit ',lgvcard endif iret = 98 895 continue c return end