From 174091ebeed58de0d645ec95b4041000d18a8e23 Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz Date: Mon, 5 Aug 2019 12:35:24 -0400 Subject: [PATCH 001/205] add test program for AIRCFT bias correction --- .../GMAO_Etc/GMAO_bias/air_update.f | 867 ++++++++++++++++++ 1 file changed, 867 insertions(+) create mode 100644 src/Applications/GMAO_Etc/GMAO_bias/air_update.f diff --git a/src/Applications/GMAO_Etc/GMAO_bias/air_update.f b/src/Applications/GMAO_Etc/GMAO_bias/air_update.f new file mode 100644 index 00000000..a1b883b7 --- /dev/null +++ b/src/Applications/GMAO_Etc/GMAO_bias/air_update.f @@ -0,0 +1,867 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! NASA/GSFC, Global Modeling and Assimilation Office, Code 610.1 ! +!----------------------------------------------------------------------- +!BOP +! +! !MODULE: acdatad data type for aircraft data read from diag or prepbufr +! +! !INTERFACE: +! + module acdatad +! +! !USES: + + implicit none +! +! !DESCRIPTION: +! This module defines observation types for handling aircraft data +! and aircraft bias data +! +! !REVISION HISTORY: +! +! Apr2013 Sienkiewicz Created module +! 4Jun2013 Sienkiewicz added prologue +! 7Mar2014 Sienkiewicz added YYYYMM (kym) to bias structure +! +!EOP +!------------------------------------------------------------------------- + + type :: cft_data_type + real :: xob ! longitude + real :: yob ! latitude + real :: elv ! level + real :: dmn ! delta time (hr) in assim window + real :: pob ! pressure + real :: tob ! temperature + real :: omf ! (obs - ges) + real :: alrt ! asceent/descent rate + character (len=8) :: sid ! aircraft ID + integer :: ityp ! obs type + integer :: itqm ! temperature quality mark + integer :: ks ! 'sounding' index + integer :: is ! index within 'sounding' + end type cft_data_type + + integer, parameter :: maxobs=300000 + integer, parameter :: maxcft=7000 +! +! data type for bias file + type :: bias_data_type + character (len=8) :: sid + real :: bias + real :: err + integer :: nval + integer :: kount + integer :: kskip + integer :: kym + end type bias_data_type + + end module acdatad + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! NASA/GSFC, Global Modeling and Assimilation Office, Code 610.1 ! +!----------------------------------------------------------------------- +!BOP +! +! !ROUTINE: cft_update --- update aircraft bias correction files +! +! !INTERFACE: +! + program cft_update + +! !USES: + + use acdatad + use m_MergeSorts + + implicit none + +! +! !DESCRIPTION: Reads in conventional diag file output from GSI and uses +! the observed-minus-forecast values for aircraft temperature +! data (KX=131,133) to update bias correction values for each +! aircraft tail number. +! +! This version calculates ascent/descent rate from consecutive +! observations and optionally uses that information to screen +! out observations in ascending/descending legs from use in +! the bias calculation. +! +! +! !USAGE: cft_update.x diag_file bias_file [outputfile] < gmao_acft_bias.parm +! +! +! !REVISION HISTORY +! +! 15Apr2013 Sienkiewicz Initial code +! 24Apr2013 Sienkiewicz revise to use uncorrected OmF in bias calculation +! 15May2013 Sienkiewicz New more modular version - determine range of +! obs with same tail number and pass to subroutine +! to calculate bias correction. Add constraint +! for level-flight obs for use in bias calculation +! 29May2013 Sienkiewicz Namelist input to control parameters for screening +! allow to run like original version (all good obs) +! or to screen for level flight obs +! 30May2012 Sienkiewicz Write elevation in optional output file in terms of kilo-ft +! (i.e. ~aircraft flight levels) +! 4Jun2013 Sienkiewicz added prologue +! 25Jun2013 Sienkiewicz put additional fields in bias file (for testing) +! to track current stats, number of updates to bias +! and number of times since bias last updated +! 26Jun2013 Sienkiewicz try 'dfact' factor to scale down the bias corr with +! time if it is not updated +! 26Nov2013 Sienkiewicz add restriction of minimum date = 1991040100 for bias corr. +! 11Dec2013 Sienkiewicz Revised defaults to match namelist values +! 7Mar2014 Sienkiewicz Modified output to match format from Yanqiu's code, add index +! column, extra predictor columns, and column with YYYYMM of +! last update for bias. Results same as before, just format change. +! 28Jul2016 Sienkiewicz Switch variance and count columns so they are in the same order +! as in the NCEP bias files. (Probably will otherwise get confused.) +! 17Nov2016 Sienkiewicz add namelist array to choose KX values for bias correction accumulation +! +!EOP +!------------------------------------------------------------------------- + + integer,parameter :: nhdr=8 + integer,parameter :: ntime=8 + integer,parameter :: maxkx=15 + + real, parameter :: m2kft = 39.37/12000. + + CHARACTER(len=200) diagfile,outputfile,biasfile + character(len=3) dtype + CHARACTER(len=8) SUBSET,cstid + + character(8),allocatable, dimension(:):: cdiagbuf + real,allocatable,dimension(:,:)::rdiagbuf + + character(len=11) c_nrlqm + character(len=8) sid + integer idate, lui,luo,lub + type (cft_data_type) :: adata(maxobs) + integer isrt(maxobs),idex(maxobs),n,m,i1,i2 + + type (bias_data_type) :: bdata(maxcft) + type (bias_data_type) :: cdata(maxcft) + type (bias_data_type) :: ddata(maxcft) + integer jdex(maxcft), kdex(maxcft) + + integer argc,iargc + integer nchar, nreal, nobs, mype + integer ndat + integer i,ios + integer ipre, ip, ks, is, im1 + integer itstart,itend + integer idum, kount, kskip + integer nkx + + integer,dimension(maxkx):: kx_list, kx2chk + + integer nflt, nbflt, mflt + integer idx, iym, izero + + real bias, errr + real zero + integer nval + real bnew, enew + real dum + + real plevlim ! limiting pressure level to use in bias calc + real adsclm ! limiting asc/dsc rate to use in bias calc + real dfact ! reduction factor for bias corr + integer nobsmin ! min nobs value used to toss old bias entry + real bvarmin ! minimum value for bias error + integer nminb ! min nobs value for using bias correction + logical docount ! keep tally of # of times tail number + ! appears and count since last updated + integer mindate ! minimum date for aircraft bias to be active + logical apply_bias ! if .false. set bias (as read by GSI) to zero + ! i.e. if prior to mindate + + namelist/acftbias/ plevlim, adsclm, dfact, nobsmin, bvarmin, nminb, + & docount, mindate, kx_list + + integer ichk, jchk, kchk + + logical lprint, verbose + + data lui /10/,lub/11/ + + ndat = 0 + luo = 6 + kdex = -1 + lprint = .false. + verbose = .false. + dfact = 0.99 ! set '1' to be compatible with original + ! recommend value = 0.99 + nobsmin = 0 ! use -1 to match original, recommend > 0 + bvarmin = 0.001 ! default 0.001 to match original + nminb = 10 ! use 1 to be compatible with original + docount = .false. ! default .false. , leave off count + ! (avoid eventual integer overflow) + mindate = 1991040100 ! default minimum date to apply Apr 01, 1991 00z + apply_bias= .true. ! default is to apply the bias + + zero = 0.0 + izero = 0 + + argc = iargc() + if (argc .lt. 2) then + print *,'usage: cft_update.x diag_file bias_file ' + & // '[outputfile] < namelist ' + stop + end if + +! default values for screening + plevlim = 600. + adsclm = 10. + kx_list = 0 + + read(5,acftbias,end=1234) + + go to 1235 + + 1234 continue + print *,'using default values for aircraft bias namelist' + + 1235 continue + + nkx = 0 ! walk through kx_list, stop at 0 value + do i = 1,maxkx + if (kx_list(i) .le. 0) exit + nkx = nkx + 1 + kx2chk(nkx) = kx_list(i) + end do + + if (nkx .eq. 0) then ! if no kx values, use defaults + kx_list(1) = 131 + kx_list(2) = 133 + kx2chk = kx_list + nkx = 2 + end if + + write(*,acftbias) + + print *,'kx2chk = ',kx2chk(1:nkx) + + call getarg(2,biasfile) + if (argc .gt. 2) then + luo = 20 + lprint = .true. + call getarg(3,outputfile) + open(unit=luo,file=outputfile,form='formatted') + end if + + cdata%sid = 'ZZZZZZZZ' + bdata%sid = 'YZZZZZZZ' + ddata%bias = 0.0 + ddata%err = 0.0 + ddata%nval = 0 + + + open(unit=lub,file=biasfile,form='formatted',status='old') + ios = 0 + nbflt = 0 + +! read in bias correction from file, apply reduction factor to +! downweight prior bias + + do while (ios .eq. 0) + read(lub,2010,iostat=ios) sid, idx, dum, dum, dum, + & nval, idum, idum, + & errr, dum, dum, + & iym, bias, dum, dum, idum, kount, kskip + if (ios .eq. 0) then + nbflt = nbflt + 1 + cdata(nbflt)%sid = trim(sid) + cdata(nbflt)%bias = bias ! don't rescale bias + cdata(nbflt)%err = errr*errr/dfact + cdata(nbflt)%nval = nval*dfact + cdata(nbflt)%kount = kount + cdata(nbflt)%kskip = kskip + 1 + cdata(nbflt)%kym = iym + end if + end do + print *,'Read in from biasfile ',trim(biasfile),' total of ', + & nbflt,' entries' + close(lub) + nflt = nbflt + call IndexSet(nflt,jdex) + call IndexSort(nflt,jdex,cdata(1:nflt)%sid,descend=.false.) + +! Read data in from diag files, select observations with kx=131 (AMDAR) or 133 (MDCRS) +! + call getarg(1,diagfile) + open(unit=lui,file=diagfile,form='unformatted',status='old') + + read(lui) idate + + if (idate .lt. mindate) then + print *,'Current date ',idate,' is less than minimum date' + print *,'Calculate bias but pass zero value to GSI' + apply_bias = .false. + end if + + idate = idate / 10000 + + do while (ndat .lt. maxobs) + read(lui,iostat=ios) dtype,nchar,nreal,nobs,mype + if (ios .ne. 0) exit + if (dtype .ne. ' t') then + read(lui) + cycle + end if + allocate(cdiagbuf(nobs),rdiagbuf(nreal,nobs)) + read(lui) cdiagbuf,rdiagbuf + do i = 1,nobs +c$$$ select case (nint(rdiagbuf(1,i))) +c$$$ case (130, 131, 133) + if (any(nint(rdiagbuf(1,i))==kx2chk(1:nkx))) then + ndat = ndat + 1 + if (ndat .gt. maxobs) then + print *,'exceeded maxobs value, ndat = ',ndat + exit + end if + adata(ndat)%xob = rdiagbuf(4,i) + adata(ndat)%yob = rdiagbuf(3,i) + adata(ndat)%elv = rdiagbuf(5,i)*m2kft + adata(ndat)%dmn = rdiagbuf(8,i)*60. + adata(ndat)%pob = rdiagbuf(6,i) + adata(ndat)%tob = rdiagbuf(17,i) + adata(ndat)%omf = rdiagbuf(19,i) + adata(ndat)%sid = trim(cdiagbuf(i)) + adata(ndat)%ityp = nint(rdiagbuf(1,i)) + adata(ndat)%itqm = nint(rdiagbuf(12,i)) + end if +c$$$ case default +c$$$ end select + end do + deallocate(cdiagbuf,rdiagbuf) + + end do + print *,'processed ', ndat, ' obs' + + call IndexSet(ndat,idex) + call IndexSort(ndat,idex,adata(1:ndat)%ityp,descend=.false.) + call IndexSort(ndat,idex,adata(1:ndat)%dmn,descend=.false.) + call IndexSort(ndat,idex,adata(1:ndat)%sid,descend=.false.) + +! +! at this point the obs are sorted by kx, time, and tail number +! we can move along the index array and label flights and calculate +! ascent descent rates and mean values + + mflt = 0 + ipre = idex(1) + ks = 1 + is = 1 + adata(ipre)%ks = ks + adata(ipre)%is = is + adata(ipre)%alrt = 0.0 + itstart = 1 + i1 = 2 + do while (i1 <= ndat) + ip = idex(i1) + if (adata(ip)%sid .ne. adata(ipre)%sid) then + itend = i1-1 + call process_tailno(itstart,itend,idex,adata,plevlim) + call process_bias(itstart,itend,adata,idex,bias,errr,nval, + & plevlim,adsclm) + if (nval .gt. 1) then + mflt = mflt + 1 + bdata(mflt)%sid = adata(ipre)%sid + bdata(mflt)%bias = bias + bdata(mflt)%err = errr + bdata(mflt)%nval = nval + end if + + itstart = i1 + ks = ks + 1 + is = 0 + end if + is = is + 1 + adata(ip)%ks = ks + adata(ip)%is = is + ipre = ip + i1 = i1 + 1 + end do + call process_tailno(itstart,ndat,idex,adata,plevlim) + call process_bias(itstart,ndat,adata,idex,bias,errr,nval, + & plevlim,adsclm) + if (nval .gt. 1) then + mflt = mflt + 1 + bdata(mflt)%sid = adata(ipre)%sid + bdata(mflt)%bias = bias + bdata(mflt)%err = errr + bdata(mflt)%nval = nval + end if + + print *,'total flights extracted from diag file = ',mflt + + ichk = 1 + kchk = 0 + + do jchk = 1,mflt + + do while(ichk .le. nbflt) + if (cdata(jdex(ichk))%sid .ge. bdata(jchk)%sid) exit + if (verbose) print *,cdata(jdex(ichk))%sid, ' lt ', + & bdata(jchk)%sid, ' so no match in new file' + kchk = kchk + 1 + kdex(kchk) = jdex(ichk) + ichk = ichk + 1 + end do + + if (ichk .le. nbflt) then + + if (cdata(jdex(ichk))%sid .eq. bdata(jchk)%sid) then + +! combine the entries + print *,'combining entries for ',bdata(jchk)%sid + i1 = jdex(ichk) +! enew = bdata(jchk)%err*cdata(i1)%err/ +! & (bdata(jchk)%err+cdata(i1)%err) + enew = 1./(1./bdata(jchk)%err + + & 1./cdata(i1)%err) + bnew = (cdata(i1)%bias/cdata(i1)%err + + & bdata(jchk)%bias/bdata(jchk)%err)* + & bdata(jchk)%err*cdata(i1)%err/ + & (bdata(jchk)%err+cdata(i1)%err) + cdata(i1)%bias = bnew + cdata(i1)%err = max(enew,bvarmin) + cdata(i1)%nval = min(5000,bdata(jchk)%nval+ + & cdata(i1)%nval) + cdata(i1)%kskip = 0 + cdata(i1)%kount = cdata(i1)%kount + 1 + cdata(i1)%kym = idate + + ddata(i1)%bias = bdata(jchk)%bias + ddata(i1)%err = bdata(jchk)%err + ddata(i1)%nval = bdata(jchk)%nval + + kchk = kchk + 1 + kdex(kchk) = i1 + ichk = ichk + 1 + + else + +! add an entry at the end of the array and put the location +! in the (after merge) pointer array + + im1 = ichk - 1 + if (im1 .gt. 0) then + print *,'insert ',bdata(jchk)%sid,' between ', + & cdata(jdex(im1))%sid,' and ',cdata(jdex(ichk))%sid + else + print *,'insert ',bdata(jchk)%sid,' at start before ', + & cdata(jdex(ichk))%sid + end if + kchk = kchk + 1 + nflt = nflt + 1 + kdex(kchk) = nflt + cdata(nflt)%sid = bdata(jchk)%sid + cdata(nflt)%bias = bdata(jchk)%bias + cdata(nflt)%err = bdata(jchk)%err + cdata(nflt)%nval = bdata(jchk)%nval + cdata(nflt)%kskip = 0 + cdata(nflt)%kount = 1 + cdata(nflt)%kym = idate + + ddata(nflt)%bias = bdata(jchk)%bias + ddata(nflt)%err = bdata(jchk)%err + ddata(nflt)%nval = bdata(jchk)%nval + + end if + else +! add an entry at the end of the array and put the location +! in the (after merge) pointer array + + print *,'insert ',bdata(jchk)%sid,' at end of array' + kchk = kchk + 1 + nflt = nflt + 1 + kdex(kchk) = nflt + cdata(nflt)%sid = bdata(jchk)%sid + cdata(nflt)%bias = bdata(jchk)%bias + cdata(nflt)%err = bdata(jchk)%err + cdata(nflt)%nval = bdata(jchk)%nval + cdata(nflt)%kskip = 0 + cdata(nflt)%kount = 1 + cdata(nflt)%kym = idate + + ddata(nflt)%bias = bdata(jchk)%bias + ddata(nflt)%err = bdata(jchk)%err + ddata(nflt)%nval = bdata(jchk)%nval + + end if + + end do + + if (ichk .le. nbflt) then + do i1 = ichk,nbflt + if (verbose) print *,cdata(jdex(i1))%sid, + & ' no match in new file' + kchk = kchk + 1 + kdex(kchk) = jdex(i1) + end do + end if + + print *,'total flights in merged file: ',nflt + + + if (lprint) then + write(luo,1999) + 1999 format(' SID DMIN ELEV POB', + & ' XOB YOB TOB TQM KX') + do i1 = 1,ndat + i2 = idex(i1) + write(luo,2000) adata(i2)%sid,adata(i2)%dmn, + & adata(i2)%elv,adata(i2)%pob,adata(i2)%xob, + & adata(i2)%yob,adata(i2)%tob, + & adata(i2)%itqm,adata(i2)%ityp, + & adata(i2)%ks,adata(i2)%is,adata(i2)%alrt + end do + + end if + + open(unit=lub,file=biasfile,form='formatted') + idx = 0 + do i1 = 1,nflt + i2 = kdex(i1) + if (cdata(i2)%nval .gt. nobsmin) then +! fill in bias value read by GSI + if ( apply_bias .and. cdata(i2)%nval >= nminb ) then + bias = cdata(i2)%bias + else + bias = zero + end if + idx = idx + 1 +! +! columns being written 1-12 are read by GSI, 13-18 only in external program +! 1 - tail number +! 2 - index for tail ID +! 3 - bias value to be used by GSI (zerored if too +! little data used or estimate is too old) +! 4 - zero (unused second predictor coefficient) +! 5 - zero (unused third predictor coefficient) +! 6 - running count of obs +! 7 - zero (unused count for second predictor) +! 8 - zero (unused count for third predictor) +! 9 - error value for calculated bias +! 10 - zero (unused slot for second predictor) +! 11 - zero (unused slot for third predictor) +! 12 - YYYYMM time indicator +! 13 - actual bias value calculated +! 14 - mean OmF for tail number for current synoptic time +! 15 - std.dev OmF for tail number for current synoptic time +! 16 - count for tail number for current synoptic time +! (optional) +! 17 - number of days tail number has appeared +! 18 - count of days missing for tail number + if (docount) then + write(lub,2010) cdata(i2)%sid,idx,bias,zero,zero, + & cdata(i2)%nval, izero, izero, + & sqrt(cdata(i2)%err), zero, zero, cdata(i2)%kym, + & cdata(i2)%bias, ddata(i2)%bias, sqrt(ddata(i2)%err), + & ddata(i2)%nval, cdata(i2)%kount, cdata(i2)%kskip + else + write(lub,2010) cdata(i2)%sid,idx,bias,zero,zero, + & cdata(i2)%nval, izero, izero, + & sqrt(cdata(i2)%err), zero, zero, cdata(i2)%kym, + & cdata(i2)%bias, ddata(i2)%bias, sqrt(ddata(i2)%err), + & ddata(i2)%nval + endif + + else + print *,'Removing old bias correction for ',cdata(i2)%sid + end if + end do + + stop + 2000 format(2x,a8,2x,f10.2,5(2x,f10.2),i4,3i6,f10.2) + 2010 format(1x,a8,i5,3f10.2,3i8,3f10.4,i8,2f10.2,f10.3,3i8) + + end program cft_update + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! NASA/GSFC, Global Modeling and Assimilation Office, Code 610.1 ! +!----------------------------------------------------------------------- +!BOP +! +! !ROUTINE: process_tailno +! +! !INTERFACE: +! + subroutine process_tailno(itstart,itend,idex,adata,plevlim) + +! !USES: + use acdatad + implicit none + +! !INPUT PARAMETERS: +! + integer itstart ! start value in index of flight + integer itend ! end value in index of flight + integer idex(maxobs) ! sorted index of observations + real plevlim ! limiting pressure level to use for fill value +! +! !INPUT/OUTPUT PARAMETERS: + type (cft_data_type) :: adata(maxobs) ! data structure with observations + +! !DESCRIPTION: process data with same tail number to calculate +! ascent/descent rates +! +! !REVISION HISTORY: +! 24Oct2013 Sienkiewicz new wrapper to separate out 'flights' from +! all obs with same tail number - copied from +! cft_prp_vv.f90 +! +!EOP +!------------------------------------------------------------------------- +! +! run through tail number array to see if delta-dhr is too large, +! split into new flight (no acid available in diag file) +! + integer i + integer ip1, is1, iptr, iprev + real, parameter :: dtlim = 25. + real dt + + is1 = itstart + ip1 = idex(is1) + iprev = ip1 + + do i = itstart+1,itend + iptr = idex(i) + dt = adata(iptr)%dmn-adata(iprev)%dmn + if ( dt .gt. dtlim ) then +! +! end of current flight, process and start new flight + call process_flight(is1,i-1,idex,adata,plevlim) + is1 = i + ip1 = iptr + end if + iprev = iptr + end do + if (is1 <= itend) then + call process_flight(is1,itend,idex,adata,plevlim) + end if + return + end subroutine process_tailno + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! NASA/GSFC, Global Modeling and Assimilation Office, Code 610.1 ! +!----------------------------------------------------------------------- +!BOP +! +! !ROUTINE: process_flight +! +! !INTERFACE: +! + subroutine process_flight(itstart,itend,idex,adata,plevlim) + +! !USES: + use acdatad + implicit none + +! !INPUT PARAMETERS: +! + integer itstart ! start value in index of flight + integer itend ! end value in index of flight + integer idex(maxobs) ! sorted index of observations + real plevlim ! limiting pressure level to use for fill value +! +! !INPUT/OUTPUT PARAMETERS: + type (cft_data_type) :: adata(maxobs) ! data structure with observations + +! !DESCRIPTION: process data with same tail number to calculate +! ascent/descent rates +! +! !REVISION HISTORY: +! 15May2013 Sienkiewicz Initial code +! 4Jun2013 Sienkiewicz added prologue +! 23Oct2013 Sienkiewicz trying centered difference calculation +! 29Oct2013 Sienkiewicz add code to exclude 'bad' obs, rename to +! 'process_flight' (changes from cft_prp_vv.f90; +! note we are using dP/dt hPa/min not dZ/dt m/s) +! 30Oct2013 Sienkiewicz pass in plevlim to limit "fill" values for isolated obs +!EOP +!------------------------------------------------------------------------- + + + real, allocatable :: utime(:), ulev(:), alr(:) + integer, allocatable :: nattime(:) + + integer i1,ialrt, intm + integer ier + integer iptr + integer nflt + + nflt = itend - itstart + 1 + + if (nflt .lt. 1) then + print *,'bad flight?',itstart,itend + return + end if + + allocate(utime(nflt),ulev(nflt),alr(nflt),nattime(nflt),stat=ier) + if (ier .ne. 0) then + print *,'error allocating arrays for ascent/descent processing',ier + stop + end if + + utime = 0.0 + ulev = 0.0 + alr = 0.0 + nattime = 0 + + iptr = idex(itstart) + intm = 1 + utime(intm) = adata(iptr)%dmn + ulev(intm) = adata(iptr)%pob + nattime(intm) = 1 + do i1 = itstart+1,itend + iptr=idex(i1) + if (adata(iptr)%dmn .ne. utime(intm)) then +! +! if time is different, add new unique time to array +! + intm = intm + 1 + utime(intm) = adata(iptr)%dmn + ulev(intm) = adata(iptr)%pob + nattime(intm) = 1 + else +! +! if time is the same, combine with other reports with the same time stamp +! + ulev(intm) = ((ulev(intm)*nattime(intm))+adata(iptr)%pob)/ + & (nattime(intm)+1) + nattime(intm) = nattime(intm) + 1 + end if + end do + +! +! add fill value for isolated reports - if below 'plevlim' use -9999.9, if above they +! may be isolated reports at cruise level so leave the 0.0 value + if (intm .lt. 2) then + if(ulev(1) .gt. plevlim) then + alr(1) = -9999.9 + endif + else +! +! we now have 'intm' unique time/level pairs so we can calculate ascent/descent +! rates for each of these times (with an "average" value for the obs with +! identical times) + + alr(1) = (ulev(2)-ulev(1))/(utime(2)-utime(1)) + + do i1 = 2,intm-1 + alr(i1) = (ulev(i1+1)-ulev(i1-1))/(utime(i1+1)-utime(i1-1)) + end do + + alr(intm) = (ulev(intm)-ulev(intm-1))/(utime(intm)-utime(intm-1)) + + end if +! now fill in the calculated ascent/descent rate for each obs in the flight + + ialrt = 1 + do i1 = itstart,itend + iptr = idex(i1) + if (adata(iptr)%itqm .ne. 1) then + adata(iptr)%alrt = -9999.9 + cycle + end if + do while(ialrt < intm .and. utime(ialrt) .ne. adata(iptr)%dmn) + ialrt = ialrt + 1 + end do + if (utime(ialrt) .ne. adata(iptr)%dmn) then + print *,'Error, time not found in array' + adata(iptr)%alrt = -9999.9 + else + adata(iptr)%alrt = alr(ialrt) + end if + end do + + deallocate(utime, ulev, nattime, alr, stat=ier) + if (ier .ne. 0) then + print *,'deallocate failed, ier=',ier + end if + + return + + end subroutine process_flight + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! NASA/GSFC, Global Modeling and Assimilation Office, Code 610.1 ! +!----------------------------------------------------------------------- +!BOP +! +! !ROUTINE: process_bias +! +! !INTERFACE: +! + subroutine process_bias(itstart,itend,adata,idex,bias,errr,nval, + & plevlim,adsclm) + +! !USES: + use acdatad + implicit none + +! !INPUT PARAMETERS: +! + integer itstart + integer itend + type (cft_data_type) :: adata(maxobs) + integer idex(maxobs) + real plevlim + real adsclm + +! !OUTPUT PARAMETERS: + integer nval + real bias + real errr + +! !DESCRIPTION: calculate bias for data from given tail number +! with restriction based on ascent/descent rate +! and pressure level +! +! +! !REVISION HISTORY: +! 15May2013 Sienkiewicz Initial code +! 4Jun2013 Sienkiewicz added prologue +!EOP +!------------------------------------------------------------------------- + + +! local variables + real(8) sum,sum2 + integer i, ii + real omf + + sum = 0.0 + sum2 = 0.0 + nval = 0 + do i = itstart,itend + ii = idex(i) + if (adata(ii)%itqm .ne. 1) cycle ! only data that passed qc + if (adata(ii)%pob .ge. plevlim) cycle ! only data higher than plevlim + if (abs(adata(ii)%alrt) .gt. adsclm) cycle !only level(ish) flight + + omf = adata(ii)%omf + sum = sum + omf + sum2 = sum2 + omf*omf + nval = nval + 1 + + end do + + if (nval .gt. 1) then + bias = sum/float(nval) + errr = max((sum2-sum*sum/float(nval))/ + & float(nval*nval),0.01) + end if + + return + + end subroutine process_bias From bfd267c8a51ba5eb9ba672e98a79859c0ed4ff8a Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz Date: Mon, 19 Aug 2019 16:25:44 -0400 Subject: [PATCH 002/205] Changes for NRL aircraft QC --- .../prepobs_acarsqc.fd/CMakeLists.txt | 20 - .../NCEP_Paqc/prepobs_acarsqc.fd/acarsqc.f | 2732 -- .../prepobs_acarsqc.merra.parm | 9 - .../prepobs_prepacqc.fd/CMakeLists.txt | 4 +- .../prepobs_prepacqc.fd/acftobs_qc.f | 29961 ++++++++++++++++ .../NCEP_Paqc/prepobs_prepacqc.fd/indexc40.f | 103 + .../prepobs_prepacqc.fd/input_acqc.f | 1952 + .../prepobs_prepacqc.fd/output_acqc_noprof.f | 1581 + .../prepobs_prepacqc.fd/output_acqc_prof.f | 1441 + .../NCEP_Paqc/prepobs_prepacqc.fd/pietc.f90 | 95 + .../NCEP_Paqc/prepobs_prepacqc.fd/pkind.f90 | 8 + .../NCEP_Paqc/prepobs_prepacqc.fd/pmat.f90 | 1086 + .../NCEP_Paqc/prepobs_prepacqc.fd/pmat2.f90 | 1231 + .../NCEP_Paqc/prepobs_prepacqc.fd/pmat3.f90 | 912 + .../NCEP_Paqc/prepobs_prepacqc.fd/prepacqc.f | 9551 +---- .../prepobs_prepacqc.fd/prepobs_landc | Bin 285020 -> 0 bytes .../prepobs_prepacqc.gdas.parm | 16 + .../prepobs_prepacqc.merra.parm | 18 + .../prepobs_prepacqc.fd/prepobs_waypoints | 32 - .../NCEP_Paqc/prepobs_prepacqc.fd/pspl.f90 | 2088 ++ .../prepobs_prepacqc.fd/sub2mem_mer.f | 1918 + .../prepobs_prepacqc.fd/sub2mem_um.f | 649 + .../prepobs_prepacqc.fd/tranQCflags.f | 813 + 23 files changed, 45564 insertions(+), 10656 deletions(-) delete mode 100644 src/Applications/NCEP_Paqc/prepobs_acarsqc.fd/CMakeLists.txt delete mode 100755 src/Applications/NCEP_Paqc/prepobs_acarsqc.fd/acarsqc.f delete mode 100644 src/Applications/NCEP_Paqc/prepobs_acarsqc.fd/prepobs_acarsqc.merra.parm create mode 100644 src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/acftobs_qc.f create mode 100644 src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/indexc40.f create mode 100644 src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/input_acqc.f create mode 100644 src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/output_acqc_noprof.f create mode 100644 src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/output_acqc_prof.f create mode 100644 src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/pietc.f90 create mode 100644 src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/pkind.f90 create mode 100644 src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/pmat.f90 create mode 100644 src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/pmat2.f90 create mode 100644 src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/pmat3.f90 delete mode 100644 src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/prepobs_landc create mode 100755 src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/prepobs_prepacqc.gdas.parm delete mode 100644 src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/prepobs_waypoints create mode 100644 src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/pspl.f90 create mode 100644 src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/sub2mem_mer.f create mode 100644 src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/sub2mem_um.f create mode 100644 src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/tranQCflags.f diff --git a/src/Applications/NCEP_Paqc/prepobs_acarsqc.fd/CMakeLists.txt b/src/Applications/NCEP_Paqc/prepobs_acarsqc.fd/CMakeLists.txt deleted file mode 100644 index 365d8c61..00000000 --- a/src/Applications/NCEP_Paqc/prepobs_acarsqc.fd/CMakeLists.txt +++ /dev/null @@ -1,20 +0,0 @@ -# This is equivalent to FOPT= in GNU Make -if (CMAKE_Fortran_COMPILER_ID MATCHES Intel) - string (REPLACE "${FOPT3}" "" CMAKE_Fortran_FLAGS_RELEASE ${CMAKE_Fortran_FLAGS_RELEASE}) - string (REPLACE "${OPTREPORT0}" "" CMAKE_Fortran_FLAGS_RELEASE ${CMAKE_Fortran_FLAGS_RELEASE}) - string (REPLACE "${FTZ}" "" CMAKE_Fortran_FLAGS_RELEASE ${CMAKE_Fortran_FLAGS_RELEASE}) - string (REPLACE "${ALIGN_ALL}" "" CMAKE_Fortran_FLAGS_RELEASE ${CMAKE_Fortran_FLAGS_RELEASE}) - string (REPLACE "${NO_ALIAS}" "" CMAKE_Fortran_FLAGS_RELEASE ${CMAKE_Fortran_FLAGS_RELEASE}) -endif () - -ecbuild_add_executable ( - TARGET acarsqc.x - SOURCES acarsqc.f - LIBS NCEP_bufr_r4i4 NCEP_w3_r4i4 NCEP_bacio_r4i4) - -if (EXTENDED_SOURCE) - set_target_properties (acarsqc.x PROPERTIES COMPILE_FLAGS ${EXTENDED_SOURCE}) -endif() - -file(GLOB parm_files *.parm) -install(FILES ${parm_files} DESTINATION etc) diff --git a/src/Applications/NCEP_Paqc/prepobs_acarsqc.fd/acarsqc.f b/src/Applications/NCEP_Paqc/prepobs_acarsqc.fd/acarsqc.f deleted file mode 100755 index 3b25c176..00000000 --- a/src/Applications/NCEP_Paqc/prepobs_acarsqc.fd/acarsqc.f +++ /dev/null @@ -1,2732 +0,0 @@ -C$$$ MAIN PROGRAM DOCUMENTATION BLOCK -C -C MAIN PROGRAM: PREPOBS_ACARSQC -C PRGMMR: KEYSER ORG: NP22 DATE: 2011-03-30 -C -C ABSTRACT: READS IN PREPBUFR FILE CONTAINING ALL PREPROCESSED DATA -C TYPES. {ONLY BUFR TABLE A ENTRY MESSAGES "AIRCAR " ARE OPERATED -C ON.} PERFORMS CERTAIN RUDIMENTARY QUALITY CHECKS ON THE DATA -C (E.G., GROSS CHECKS AND SANITY CHECK). SORTS BY STATION ID, DOES -C TRACK CHECKING (NOT YET), AND AGGRAGATES OBS BY POSITION (CALLED -C A 'STACK'). DOES QUALITY CONTROL BY MAKING TRACK CHECKS ON -C FLIGHTS (NOT YET), REMOVING DUPLICATES (NOT YET) AND COMPARING -C COLOCATED OBSERVATIONS, (NOT YET). A SERIES OF NEW PREPBUFR -C QUALITY MARKS ARE ATTACHED TO EACH OBSERVATION (SEE REMARKS). -C FINALLY: WRITES STACKED EVENTS (CONSISTING OF THE UPDATED PREPBUFR -C QUALITY MARKS) ONTO THE EXISTING PREPBUFR DATA. IN ALL CASES, THE -C NEW FILE CONTAINS ALL OF THE ORIGINAL OBSERVATIONAL DATA (P-ALT, -C TEMP, SPECIFIC HUMIDITY, WIND) MINUS THE DUPLICATES (IF ANY) AND -C THOSE OUTSIDE THE DESIRED TIME WINDOW. FUTURE Q.C. MAY INVOLVE -C CHECKS OVER CONUS VS. OUTSIDE CONUS. -C -C PROGRAM HISTORY LOG: -C 2002-05-07 D. A. KEYSER -- ORIGINAL AUTHOR (ADAPTED FROM EXISITNG -C PROGRAM "PREPOBS_PREPACQC") -C 2008-09-25 D. A. KEYSER -- IN RESPONSE TO CHANGE FROM SINGLE LEVEL -C TO DELAYED REPLICATION FOR "AIRCAR" REPORT LEVEL DATA NOW -C IN PREPBUFR FILE (IN PREPARATION FOR NRL AIRCRAFT QC -C PROGRAM WHICH WILL REPLACE THIS PROGRAM AND CAN GENERATE -C AIRCRAFT "PROFILES"), RECEIPT TIME (RCT) (WHICH IS NOW -C PART OF LEVEL DATA) IS NO LONGER RETRIEVED IN SAME CALL -C TO UFBINT AS REMAINING SINGLE-LEVEL HEADER DATA (TO AVOID -C BUFRLIB ERROR) (ALL LEVEL DATA HERE STILL HAS JUST ONE -C REPLICATION AT THIS POINT) -C 2009-08-03 D. A. KEYSER -- WILL NO LONGER TRY TO PULL OUT RECEIPT -C TIME (RCT) FROM PRE-DECEMBER 2008 VERSIONS OF PREPBUFR -C FILE WHICH DO YET INCLUDE IT IN ACARS REPORT HEADER (DONE -C SO THAT CFSRR RUNS WILL NOT FAIL) -C 2011-03-30 D. A. KEYSER -- INCREASED THE SIZE OF PARAMETERS "IRMX" -C FROM 60000 TO 90000, "ISMX" FROM 2000 TO 4000, "ISUP" -C FROM 1000 TO 2000, AND "ITMX" FROM 2000 TO 4000 - ALL TO -C ACCOUNT FOR INCREASED NUMBER OF REPORTS NOW BEING DECODED -C DUE TO THE NEW INCLUSION OF ALASKAN ACARS REPORTS; IF -C "IRMX" IS EXCEEDED, CODE NO LONGER FAILS BUT RATHER -C PROCESSES FIRST "IRMX" REPORTS AND POSTS A WARNING -C MESSAGE TO THE PRODUCTION JOBLOG FILE -C 2012-12-07 M. SIENKIEWICZ -- INCREASED "IRMX" TO 120000 TO HANDLE -C INCREASE IN ACARS REPORTS IN NOV 2012 -C 2015-11-10 M. SIENKIEWICZ -- INCREASED "IRMX" TO 200000 TO HANDLE -C INCREASE IN ACARS REPORTS SINCE 2012 -C -C INPUT FILES: -C UNIT 05 - NAMELIST INPUT -C UNIT 14 - PREPBUFR FILE CONTAINING ALL DATA -C UNIT 15 - SEQUENTIAL FILE HOLDING FIXED FIELDS: N.H. 1 DEG. -C LAT/LON GRID LAND/SEA INDICATOR; S.H. 2.5 DEG. -C LAT/LON GRID LAND/SEA INDICATOR; N.H. CONUS 1 DEG -C LAT/LON YES/NO INDICATOR (NOT YET USED IN ANY -C CHECKS, BUT PROVIDED FOR FUTURE NEEDS) -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C UNIT 52 - TEXT FILE FOR SDM PERUSAL (LIST OF REPORTS -C - THAT ARE FLAGGED FOR NON-USE BY THIS PROGRAM AS WELL -C - AS THOSE WITH LARGE INCREMENTS) -C UNIT 61 - PREPBUFR FILE CONTAINING ALL DATA (NOW WITH ACARS QC) -C -C SUBPROGRAMS CALLED: -C UNIQUE: - RPACKR INDEXF INDEXC TRKCHK ACCOUNT -C - IDSORT FORSDM DBUFR IBUFR OBUFR -C - CMDDFF -C LIBRARY: -C SYSTEM - SYSTEM -C W3LIB : - W3FI04 ERREXIT -C BURLIB: - DATELEN OPENBF READMG READSB UFBINT -C - CLOSBF OPENMB UFBCPY WRITSB UFBCNT -C - COPYMG UFBQCD CLOSMG STATUS NEMTAB -C -C EXIT STATES: -C COND = 0 - SUCCESSFUL RUN -C COND = 04 - NO REPORTS WERE PROCESSED (NO "AIRCAR" TABLE A -C MESSAGES FOUND) -C COND = 22 - CHARACTERS ON THIS MACHINE ARE NEITHER ASCII NOR -C - EBCDIC -C COND = 70 - THE NUMBER OF LEVELS IN A DECODED REPORT'S HEADER -C - AND/OR OBS. AND/OR FCST LVL IS NOT 1 -C -C REMARKS: SEE COMMENT CARDS FOLLOWING DOCBLOCK. -C THE FOLLOWING DESCRIBE THE COMMON BLOCKS IN THIS PROGRAM: -C /ALLDAT/ -- CONTAINS ARRAYS FOR ALL ACARS OBSERVATIONS -C /SUMDAT/ -- CONTAINS ARRAYS FOR ONLY GROUP OF STACKED OBS. -C -C THE POSSIBLE OUTPUT QUALITY MARKERS ARE DEFINED AS FOLLOWS: -C (WHERE: 'T' IS TEMPERATURE, 'Q' IS SPECIFIC HUMIDITY AND -C 'W' IS WIND) -C -C PREPBUFR -C ORIGINAL SDM KEEP FLAG MAINTAINED (T/Q/W)......... 0 -C CHECKED BY THIS PROGRAM AND GOOD (T/Q/W).......... 1 -C ORIGINAL DATA NOT CHECKED BY THIS PROGRAM (T/Q/W). 2 -C ORIGINAL DATA MISSING (T/Q/W)..................... 15 -C CHECKED BY THIS PROGRAM AND SUSPECT (T/Q/W)....... 3 -C CHECKED BY THIS PROGRAM AND BAD/FAILED (T/Q/W).... 13 -C ORIGINAL SDM PURGE FLAG MAINTAINED (T/Q/W)........ 14 -C -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ -CC -C ***** VARIABLES IN NAMELIST INPUT READ IN MAIN PROGRAM ***** -CC -C WINDOW - TIME WINDOW FOR REPORTS TO BE OUTPUT BY THIS PROGRAM (IF -C WINDOW=X, TIME WINDOW IS +/- X HOURS OF CYCLE TIME) -C (DEFAULT=3.00, 6-HOUR TOTAL WINDOW) -C {NOTE: THE MAXIMUM VALUE FOR WINDOW IS 5.75 (5-HOURS, -C 45-MINUTES; ANYTHING LARGER WILL RESULT IN ERROR!} -C (NOTE: FOR INPUT, THE TIME WINDOW IS SET TO THE LARGER OF -C 3-HOURS 15-MINUTES OR "WINDOW" PLUS 15-MINUTES. -C THIS ALLOWS THE TRACK CHECKING TO BE DONE PROPERLY. -C ON OUTPUT, THE VALUE OF "WINDOW" IS USED - ALL -C REPORTS OUTSIDE WINDOW ARE OMITTED FROM OUTPUT) -C RCPTST - SWITCH TO PERFORM THE RECEIPT-TIME TEST -C RCPTST=.TRUE. ---> PERFORM THE TEST (DEFAULT) -C RCPTST=.FALSE. --> DO NOT PERFORM THE TEST -C (NOTE: THE RECEIPT TIME TEST CHECKS FOR REPORTS WITH A -C STRANGE RECEIPT TIME COMPARED TO THE REPORT TIME - -C MAY BE YESTERDAY'S REPORT PROCESSED TODAY -- -C IF THE RECEIPT TIME IS OUTSIDE THE RANGE OF REPORT -C TIME MINUS 1-HOUR TO REPORT TIME PLUS 11.99 HOURS, THE -C REPORT IS SKIPPED SINCE ITS VALIDITY IS IN QUESTION) -CC -C N O T E -- THE FOLLOWING 6-WORD ARRAYS REFER TO SIX LATITUDE -C BANDS: -90 TO -70, -70 TO -20, -20 TO 0, 0 TO 20, -C 20 TO 70, 70 TO 90 DEGREES (N +) -CC -C JAMASS - PROCESS ACARS MASS REPORTS ON OUTPUT? -C JAMASS = 0 ---> YES, PROCESS MASS REPORTS -C JAMASS = 9999 ---> NO, DO NOT PROCESS MASS REPORTS -C (DEFAULT = JAMASS(6)/6*0/) -C JAWIND - PROCESS ACARS WIND REPORTS ON OUTPUT? -C JAWIND = 0 ---> YES, PROCESS WIND REPORTS -C JAWIND = 9999 ---> NO, DO NOT PROCESS WIND REPORTS -C (DEFAULT = JAWIND(6)/6*0/) -CC -C FWRITE - SWITCH TO GET STANDARD OUTPUT PRINTOUT OF FINAL LISTING -C OF ORIGINAL REPORTS IN AIRCAR FILE WITH NEW Q. MARKS -C FWRITE=.TRUE. ---> PRODUCE PRINTOUT -C FWRITE=.FALSE. --> NO PRINTOUT (DEFAULT) -C IWRITE - SWITCH TO GET STANDARD OUTPUT PRINTOUT OF INPUT LISTING -C OF ORIGINAL REPORTS IN AIRCAR FILE BEFORE IDSORT, AFTER -C IDSORT, AND AFTER TRACK CHECK -C IWRITE=.TRUE. ---> PRODUCE PRINTOUT -C IWRITE=.FALSE. --> NO PRINTOUT (DEFAULT) -C EWRITE - SWITCH TO GET STANDARD OUTPUT PRINTOUT OF "EVENTS" -C (WHEN A BUFR EVENT OCCURS, I.E. CHANGING A QUALITY MARK) -C {NOTE: DOES NOT APPLY TO EVENT # 7 (SEE EWRITE_7)} -C EWRITE=.TRUE. ---> PRODUCE PRINTOUT -C EWRITE=.FALSE. --> NO PRINTOUT (DEFAULT) -C EWRITE_7 - SWITCH TO GET STANDARD OUTPUT PRINTOUT OF EVENT # 7 -C (REPORT WITH A TEMP, SPEC. HUMIDITY AND/OR WIND THAT -C HAS PASSED ALL CHECKS AND IS CONSIDERED TO BE GOOD) -C {NOTE: DOES NOT APPLY TO OTHER EVENT NUMBERS -C (SEE EWRITE)} -C EWRITE_7=.TRUE. ---> PRODUCE PRINTOUT -C EWRITE_7=.FALSE. --> NO PRINTOUT (DEFAULT) -CCCCC - PROGRAM PREPOBS_ACARSQC -C -C PARAMETER NAME "IRMX" THROUGHOUT THIS PROGRAM SETS THE MAXIMUM -C NUMBER OF ACARS RPTS THAN CAN BE UNPACKED FROM THE INPUT FILE CHOSEN -C PARAMETER NAME "ISMX" THROUGHOUT THIS PROGRAM SETS THE MAXIMUM -C NUMBER OF ACARS RPTS THAT CAN BE TREATED IN A STACK - PARAMETER (IRMX= 200000, ISMX= 4000) -C PARAMETER NAME "ISUP" THROUGHOUT THIS PROGRAM SETS THE MAXIMUM -C NUMBER OF SUPEROBED REPORTS THAT CAN BE PROCESSED - PARAMETER (ISUP= 2000) -C PARAMETER NAME "ISIZE" THROUGHOUT THIS PROGRAM SETS THE NUMBER OF -C VARIABLES THAT ARE AFFECTED BY THE SORTS ID IDSORT AND TRKCHK -C (EXCLUDING STATION ID AND THE TAGS WHICH ARE IN SEPARATE ARRAYS) - PARAMETER (ISIZE= 18) - - LOGICAL FWRITE,IWRITE,EWRITE,EWRITE_7,RCPTST - - CHARACTER*1 CF,INACMK(11),PF,CINCR - CHARACTER*4 SPEC5,SPEC6,SSMARK - CHARACTER*6 CIRMX - CHARACTER*8 ACID,SAID,IDENT,AAID(IRMX) - CHARACTER*16 TAG,CTAG(IRMX),STAG(IRMX) - - INTEGER IDATA(1608),NNIN(11),IDSTR(400,2) - - REAL RDATA(1608) - - COMMON/OUTPUT/KNTOUT(2) - COMMON/SUMDAT/SAID(ISMX),SLAT(ISMX),SLON(ISMX),SHGT(ISMX), - $ STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX),SSPH(ISMX), - $ KBAD(ISMX),NUMORG,SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX) - COMMON/ALLDAT/ACID(IRMX),ALAT(IRMX),ALON(IRMX),AALT(IRMX), - $ TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE,ATMP(IRMX),ASPH(IRMX), - $ TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX),ITEVNT(IRMX), - $ IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX),ADIRF(IRMX), - $ IQEVNT(IRMX) - COMMON/CMPNTS/U(ISMX),V(ISMX),UF(ISMX),VF(ISMX) - COMMON/ACCONT/KISO(11) - COMMON/INPT/TMAXO,TMINO,JAMASS(6),JAWIND(6),RCPTST - COMMON/STWRIT/EWRITE,EWRITE_7,IWRITE - COMMON/MASK/GDNH(362,91),GDSH(145,37),GDUS(362,91) - COMMON/XXXXX/AAID,JARRAY(IRMX,ISIZE),CTAG,KARRAY(IRMX,ISIZE),STAG - COMMON/CBUFR/IDENT,IRCTME,RDATA,KIX,CINCR,CF,PF - COMMON/SUPOBS/SSLAT(ISUP),SSLON(ISUP),SSTIM(ISUP),SSHGT(ISUP), - $ SSTMP(ISUP),SSSPH(ISUP),SSDIR(ISUP),SSSPD(ISUP),SSHGTF(ISUP), - $ SSTMPF(ISUP),SSDIRF(ISUP),SSSPDF(ISUP),SSMARK(ISUP) - COMMON/STDATE/IDATE(5) - COMMON/WORD/ICHTP - COMMON/QUALITY/ITQM,IQQM,IWQM - COMMON/NEWTABLE/IPRSLEVLA - - NAMELIST/INPUT/WINDOW,FWRITE,IWRITE,EWRITE,EWRITE_7,JAMASS,JAWIND, - $ RCPTST - - EQUIVALENCE (RDATA,IDATA) - - DATA XMSG/99999./,INACMK/'Q','R','S','T','U','V','W','X','Y','Z', - $ 'N'/ - - CALL W3TAGB('PREPOBS_ACARSQC',2011,0089,0087,'NP22') - - PRINT 2111 - 2111 FORMAT(//11X,'***** WELCOME TO THE ACARS QUALITY CONTROL ', - $'PROGRAM ACARSQM -- VERSION CREATED 30 MAR 2011 *****'/) - -C CALL W3FI04 TO DETERMINE MACHINE WORD LENGTH (BYTES) -C AND TO TEST FOR ASCII(ICHTP=0) OR EBCDIC(ICHTP=1) CHARACTERS - CALL W3FI04(IENDN,ICHTP,LW) - PRINT 2213, LW, ICHTP, IENDN - 2213 FORMAT(/' ---> CALL TO W3FI04 RETURNS: LW = ',I3,', ICHTP = ',I3, - $ ', IENDN = ',I3/) - IF(ICHTP.GT.1) THEN -C----------------------------------------------------------------------- -C CHARACTERS ON THIS MACHINE ARE NEITHER ASCII OR EBCDIC!! -- STOP 22 - PRINT 217 - 217 FORMAT(/5X,'++ CHARACTERS ON THIS MACHINE ARE NEITHER ASCII', - $ ' NOR EBCDIC - STOP 22'/) - CALL W3TAGE('PREPOBS_ACARSQC') - CALL ERREXIT(22) -C----------------------------------------------------------------------- - END IF - -C INITIALIZE CONSTANTS FOR ACCOUNTING - KDUP = 0 - ICNT1 = 0 - KISO = 0 - NNIN = 0 - -C READ IN NAMELIST, FIRST SET-UP ANY DEFAULTS - WINDOW = 3.00 - RCPTST = .TRUE. - FWRITE = .FALSE. - IWRITE = .FALSE. - EWRITE = .FALSE. - EWRITE_7 = .FALSE. - JAMASS = 0 - JAWIND = 0 - READ(5,INPUT,END=9222) - - 9222 CONTINUE - -C GET DATE OF PREPBUFR FILE - CALL DBUFR(IDATEP) - IDATE(1) = IDATEP/1000000 - IDATE(2) = MOD((IDATEP/10000),100) - IDATE(3) = MOD((IDATEP/100),100) - IDATE(4) = MOD(IDATEP,100) - IDATE(5) = 0 - KOUNT = 0 - KNTIN = 0 - KNTOUT = 0 - TBASE = REAL(IDATE(4) * 100.) - IF(NINT(TBASE).LT.600) TBASE = TBASE + 2400. -C THE TIME WINDOW UPON INPUT IS SET TO THE LARGER OF 3-HRS 15-MIN OR -C "WINDOW" PLUS 15-MINUTES. REMOVE ALL REPORTS OUTSIDE THIS TIME -C WINDOW. (THE LARGER INPUT TIME WINDOW ALLOWS THE TRACK CHECKING TO -C BE DONE PROPERLY (FUTURE).) - TWNDOW = AMAX1(((WINDOW*100.)+25.0),325.) - TMAX = TBASE + TWNDOW - TMIN = TBASE - TWNDOW - TMAXO = TBASE + (WINDOW * 100.) - TMINO = TBASE - (WINDOW * 100.) - PRINT 1111, IDATE,TBASE,TMIN,TMAX,TMINO,TMAXO - 1111 FORMAT(39X,'===> OPERATIONAL AIRCAR FILE HAS DATE: ',I6,4I4/ - $ 41X,'===> TIME BASE IS ',F8.0/ - $ 41X,'===> INPUT TIME WINDOW IS ',F8.0,' TO ',F8.0/ - $ 41X,'===> OUTPUT TIME WINDOW IS ',F8.0,' TO ',F8.0//) - WRITE(6,INPUT) - -C READ IN N.H. CONUS MASK (1 DEG GRID); IF MASK > 0 THEN GRID LOCATED -C HERE -- THIS IS NEEDED LATER IN PROGRAM (FUTURE) - PRINT 101 - 101 FORMAT(/1X,'**** OPEN UNIT 15 TO GET CONUS GRID FOR POSSIBLE ', - $ 'LOCATION CHECKS ****'/) - READ(15,ERR=8814) GDNH - READ(15,ERR=8814) GDSH - READ(15,ERR=8814) GDUS - GO TO 8812 -C----------------------------------------------------------------------- - 8814 CONTINUE -C PROBLEM W/ READ; INIT. GDUS ARRAY TO 0 - (HAVE TO ASSUME ALL N.H. OBS. -C ARE OUTSIDE OF CONUS REGION) - GDUS = 0.0 - PRINT 102 - 102 FORMAT(/' +++> TROUBLE READING U.S. MASK FILE; ASSUME ALL N.H. ', - $ 'DATA OUTSIDE CONUS REGION IN ANY CONUS TEST'/) -C----------------------------------------------------------------------- - - 8812 CONTINUE - IF(IWRITE) PRINT 6176 - 6176 FORMAT(/' LISTING OF ORIGINAL DATA BEFORE IDSORT----'/9X,'ACID', - $ 7X,'LAT WLON UTC ALT TEMP SHUM DIR SPD -QM ----TAGS', - $ '----- ITP RPTIME KNTINI GALT GTEMP GDIR GSPD'/) - - 5 CONTINUE - - ALTF = XMSG - DIRF = XMSG - SPDF = XMSG - TMPF = XMSG -C*********************************************************************** -C READ IN NEXT ACARS REPORT -C*********************************************************************** - IY = 43 - SPEC5 = '----' - SPEC6 = '----' - CALL IBUFR(ALTF,DIRF,SPDF,TMPF,*2) - SPEC5(3:3) = PF - SPEC6(3:3) = CF - IF(KOUNT+1.GT.IRMX) THEN -C....................................................................... -C THERE ARE MORE RPTS IN INPUT FILE THAN "IRMX" -- DO NOT PROCESS ANY -C MORE REPORTS - PRINT 53, IRMX,IRMX - 53 FORMAT(/' #####> WARNING: THERE ARE MORE THAN ',I7,' ACARS ', - $ 'REPORTS IN INPUT FILE -- MUST INCREASE SIZE OF PARAMETER NAME', - $ ' "IRMX" - WILL, CONTINUE ON PROCESSING ONLY ',I7,' REPORTS'/) - WRITE(CIRMX,'(I6)') IRMX -! CALL SYSTEM('[ -n "$jlogfile" ] && $DATA/postmsg'// -! $ ' "$jlogfile" "***WARNING:'//CIRMX//' ACARS REPORT LIMIT '// -! $ 'EXCEEDED IN PREPOBS_ACARSQC, ONLY '//CIRMX//' RPTS '// -! $ 'PROCESSED"') - CALL CLOSBF(14) - PRINT 301 - 301 FORMAT(/5X,'===> PREPBUFR DATA SET IN UNIT 14 SUCCESSFULLY', - $ ' CLOSED FROM INITIAL READ OF ACARS OBS.') - go to 2 -ccccc CALL W3TAGE('PREPOBS_ACARSQC') -ccccc CALL ERREXIT(20) -C....................................................................... - END IF - KOUNT = KOUNT + 1 - KNTIN = KNTIN + 1 - KNTINI(KOUNT) = KNTIN - TAG(KOUNT)(12:12) = '-' - ALAT(KOUNT) = RDATA(1) - ALON(KOUNT) = RDATA(2) - INTP(KOUNT) = IDATA(8) - - IF(NINT(ALON(KOUNT)*100.).EQ.36000) ALON(KOUNT) = 0.0 -C IF MISSING OR UNREASONABLE LAT/LON (SET LATTER TO MISSING), SET POS. -C 12 OF TAG TO '@' TO MARK THEM (AT END OF SORT) - IF(NINT(ALAT(KOUNT)*100.).GT.9000.OR.NINT(ALAT(KOUNT)*100.).LT. - $ -9000) THEN -CVVVVV%%%%% - PRINT *,'~~~~~ HERE IS A MISSING/UNREASONABLE LAT - SET TO MSG!!' -CAAAAA%%%%% - ALAT(KOUNT) = XMSG - TAG(KOUNT)(12:12) = '@' - END IF - IF(NINT(ALON(KOUNT)*100.).GT.36000.OR.NINT(ALON(KOUNT)*100.).LT. - $ 0) THEN -CVVVVV%%%%% - PRINT *,'~~~~~ HERE IS A MISSING/UNREASONABLE LON - SET TO MSG!!' -CAAAAA%%%%% - ALON(KOUNT) = XMSG - TAG(KOUNT)(12:12) = '@' - END IF - - ACID(KOUNT) = IDENT - TIME(KOUNT) = RDATA(4) -CVVVVV%%%%% - IF(NINT(TIME(KOUNT)).GT.2400.OR.NINT(TIME(KOUNT)).LT.0) - $ PRINT *,'~~~~~ HERE IS A MISSING/UNREASONABLE TIME, TOSSED?' -CAAAAA%%%%% - IRTM(KOUNT) = IRCTME - -C DO A TIME CHECK ON REPORT -- IF OUTSIDE EXPANDED INPUT WINDOW TOSS IT - ITIME = NINT(TIME(KOUNT)) - IF(NINT(TBASE).GT.2300.AND.NINT(TIME(KOUNT)).LE. - $ (IDATE(4)*100)+600) TIME(KOUNT) = TIME(KOUNT) + 2400. - IF(TIME(KOUNT).LT.TMIN.OR.TIME(KOUNT).GT.TMAX) THEN -C SKIP REPORTS OUTSIDE REQUESTED TIME WINDOW -CCCCCC PRINT 9002,KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT),TIME(KOUNT) -C9002 FORMAT(/' ##########: MAIN; REPORTS OUTSIDE TIME WINDOW SKIPPED.', -CCCCC$ I5,2X,A8,2X,F6.2,1X,F7.2,2X,F4.0) - KOUNT = KOUNT - 1 - GO TO 5 - END IF - - IF(RCPTST.AND.IRCTME.LE.2400) THEN -C CHECK FOR DATA WITH STRANGE RECEIPT TIME COMPARED TO REPORT TIME - -C MAY BE YESTERDAY'S REPORT PROCESSED TODAY -- IF THE RECEIPT TIME -C IS OUTSIDE THE RANGE OF REPORT TIME MINUS 1-HOUR TO REPORT TIME -C PLUS 11.99 HOURS, SKIP THE REPORT AS WE CAN'T DETERMINE ITS VALIDITY - IF(ITIME.LT.100) ITIME = ITIME + 2400 - IETIME = ITIME - 100 - ILTIME = ITIME + 1199 - IF(IRCTME.LT.IETIME.OR.IRCTME.GT.ILTIME) THEN -C RECEIPT TIME IS OUTSIDE EXPECTED RANGE, BUT MAY BE AROUND 00Z SO ADD -C 2400 TO RECEIPT TIME AND TEST AGAIN - IRCTMN = IRCTME + 2400 - IF(IRCTMN.LT.IETIME.OR.IRCTMN.GT.ILTIME) THEN -C RECEIPT TIME IS STILL OUTSIDE EXPECTED RANGE, SKIP REPORT -CVVVVV%%%%% - PRINT *,'~~~~~ THE STRANGE RECEIPT TIME DIFF. HAS OCCURRED!!' -CAAAAA%%%%% - PRINT 9393, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), - $ TIME(KOUNT),IRCTME,SPEC6(3:3) - 9393 FORMAT(/' ##########: SKIP RPTS WHERE OBS. & RCPT. TIME ARE INCON' - $,'SISTENT ',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F4.0,'; REC. TIME ',I4, - $ '; CAFB? ',A1) - KOUNT = KOUNT - 1 - GO TO 5 - END IF - END IF - END IF - - AALT(KOUNT) = RDATA(IY) - ADIR(KOUNT) = RDATA(IY+3) - ASPD(KOUNT) = RDATA(IY+4) - ATMP(KOUNT) = RDATA(IY+1) - ASPH(KOUNT) = RDATA(IY+2) -C FILL IN FORECAST VALUES FOR ALTITUDE, WIND DIR., WIND SPEED & TEMP. - AALTF(KOUNT) = ALTF - ADIRF(KOUNT) = DIRF - ASPDF(KOUNT) = SPDF - ATMPF(KOUNT) = TMPF - ITEVNT(KOUNT) = 0 - IQEVNT(KOUNT) = 0 - IWEVNT(KOUNT) = 0 -C*********************************************************************** -C*********************************************************************** -C INPUT AIRCAR TABLE A ENTRY MESSAGE QUALITY MARKER SITUATION - -C (P-ALTITUDE, TEMPERATURE. SPECIFIC HUMIDITY AND WIND) -C -C WILL CONTAIN VALUE OF 14 IF SDM HAS PURGED -C ELSE WILL CONTAIN VALUE OF 0 IF SDM KEEPS -C ELSE WILL CONTAIN DEFAULT VALUE OF 2 -C ELSE WILL CONTAIN A VALUE OF 15 IF DATA ARE MISSING -C -C OTHER INPUT REPORT INFORMATION AS INDICATED: -C -C +++ CONTAINS PROPER ACARS FLIGHT NUMBER (UP TO EIGHT CHARACTERS) -C +++ CONTAINS SCALED VECTOR WIND INCREMENT (USES ASSIMILATING -C FORECAST DIRECTLY, ASSUMING FCST U AND V ARE IN BUFR DATA) -C +++ CONTAINS RECEIPT TIME (HOURS) -C +++ CONTAINS INSTRUMENT TYPE -C -C -C OUTPUT QUALITY MARKER SITUATION - SEE DOCBLOCK REMARKS -C (P-ALTITUDE, TEMPERATURE. SPECIFIC HUMIDITY AND WIND) -C -C -C EVENTS WRITTEN BY THIS PROGRAM INTO OUTPUT PREPBUFR FILE: -C NOTE: AN EVENT CAN ONLY CHANGE A VARIABLE'S QUALITY MARKER, -C THE OBSERVED VARIABLE ITSELF IS NEVER CHANGED. -C IF THE OBSERVED VARIABLE IS MISSING, THE EVENT IS -C NOT ACTIVE. -C VARIABLE -C EVENT SUBR. MEANING QUAL. MARK -C ----- ------ -------------------------------------------- ---------- -C 1 MAIN REPORT WITH AN ALTITUDE > 16,500 METERS TEMP = 13 -C (~95 MB). PROBABLY A MISCODED REPORT. SHUM = 13 -C TEMPERATURE, SPECIFIC HUMIDITY AND/OR WIND = 13 -C WIND CONSIDERED BAD IF PRESENT. -C -C 2 MAIN REPORT WITH A LATITUDE OF 0 DEGREES. COULD TEMP = 13 -C BE A MISCODED REPORT. TEMPERATURE, WIND = 13 -C SPECIFIC HUMIDITY AND/OR WIND CONSIDERED SHUM = 13 -C BAD IF PRESENT. -C -C 3 MAIN REPORT WITH A LONGITUDE OF 0 DEGREES. TEMP = 13 -C COULD BE A MISCODED REPORT. TEMPERATURE, WIND = 13 -C SPECIFIC HUMIDITY AND/OR WIND CONSIDERED SHUM = 13 -C BAD IF PRESENT. -C -C 4 MAIN REPORT WITH CALM WIND. WIND CONSIDERED BAD WIND = 13 -C IF PRESENT. -C -C 5 MAIN REPORT WITH ALTITUDE BETWEEN 2000 & 5000 FT. TEMP = 13 -C WITH TEMPERATURE THAT DIFFERS FROM GUESS SHUM = 13 -C BY > 25 DEG. C {PROBABLY DUE TO "0" DIGIT WIND = 13 -C DROPPED FROM REPORTED ALTITUDE (TRUE -C ALTITUDE BETWEEN 20,000 & 50,000 FT.)} -C TEMPERATURE, SPECIFIC HUMIDITY AND/OR WIND -C CONSIDERED BAD IF PRESENT. -C -C 6 RPACKR REPORT WITH A MISSING PHASE OF FLIGHT TEMP = 3 -C INDICATOR (PROBABLY BANKING). TEMPERATURE, SHUM = 3 -C SPECIFIC HUMIDITY AND/OR WIND CONSIDERED WIND = 3 -C SUSPECT IF PRESENT. -C -C 7 RPACKR REPORT WITH A TEMPERATURE, SPECIFIC HUMIDITY TEMP = 1 -C AND/OR WIND THAT HAS PASSED ALL CHECKS. SHUM = 1 -C TEMPERATURE, SPECIFIC HUMIDITY AND/OR WIND WIND = 1 -C CONSIDERED GOOD IF PRESENT. -C -C 8 RPACKR REPORT WITH A TEMPERATURE THAT HAS FAILED SHUM = 13 -C ONE OR MORE CHECKS AND IS CONSIDERED BAD. -C SPECIFIC HUMIDITY CONSIDERED BAD. -C -C -C*********************************************************************** -C -C EACH REPORT CARRIES WITH IT IN THIS PROGRAM THE FOLLOWING 'TAG' INFO: -C -C BYTE 1 : +++ TEMPERATURE QUALITY MARKER -C "H" - Manual (SDM) Keep -C "A" - Good -C "-" - Neutral -C "Q" - Suspect -C "F" - Failed -C "P" - Manual (SDM) Purge -C BYTE 2 : +++ SPECIFIC HUMIDITY QUALITY MARKER -C "H" - Manual (SDM) Keep -C "A" - Good -C "-" - Neutral -C "Q" - Suspect -C "F" - Failed -C "P" - Manual (SDM) Purge -C BYTE 3 : +++ WIND QUALITY MARKER -C "H" - Manual (SDM) Keep -C "A" - Good -C "-" - Neutral -C "Q" - Suspect -C "F" - Failed -C "P" - Manual (SDM) Purge -C BYTE 4 : WILL CONTAIN 'D' IF THIS REPORT IS A DUPLICATE -C : ELSE WILL BE '-' IF THIS REPORT IS NOT A DUPLICATE -C BYTE 5 : +++ SCALED VECTOR INCREMENT VALUE : WILL CONTAIN -C 'Q' - 'Z' IF INCREMENT COULD BE PRODUCED -C : ELSE WILL CONTAIN 'N' IF NOT CALCULATED -C BYTE 6 : +++ TEMPERATURE PRECISION -C : WILL CONTAIN '0' IF LOW PRECISION -C : WILL CONTAIN '1' IF HIGH PRECISION -C : ELSE WILL BE '-' IF TEMPERATURE PRECISION NOT -C REPORTED -C BYTE 7 : +++ CURRENTLY NOT USED AND SET TO '-' -C BYTE 8 : +++ TURBULENCE INDICATOR -C : WILL CONTAIN '0' IF NO TURBULENCE -C : WILL CONTAIN '1' IF LIGHT TURBULENCE -C : WILL CONTAIN '2' IF MODERATE TURBULENCE -C : WILL CONTAIN '3' IF SEVERE TURBULENCE -C : ELSE WILL BE '-' IF NONE OF ABOVE -C BYTE 9 : +++ CURRENTLY NOT USED AND SET TO '-' -C BYTE 10 : +++ PHASE OF FLIGHT INDICATOR -C : WILL CONTAIN '0' - '2' IF RESERVED -C : WILL CONTAIN '3' IF LVL FLIGHT, ROUTINE OBSERVATION -C : WILL CONTAIN '4' IF LVL FLIGHT, HIGHEST WIND ENCOUNTERED -C : WILL CONTAIN '5' IF ASCENDING -C : WILL CONTAIN '6' IF DESCENDING -C : WILL CONTAIN '7' IF MISSING (PROBABLY BANKING) -C BYTE 11 : +++ CURRENTLY NOT USED AND SET TO '-' -C BYTE 12 : +++ INDICATOR FOR "BAD" REPORTS EXCLUDED FROM CHECKS -C : WILL CONTAIN '@' IF A "BAD"/EXCLUDED REPORT -C : ELSE WILL BE '-' -C BYTE 13 : +++ NUMERICAL VALUE FOR TEMPERATURE QUALITY MARKER -C : LOWER NUMBER ALWAYS SUPERCEDES HIGHER NUMBER (SEE && ) -C BYTE 14 : +++ NUMERICAL VALUE FOR WIND QUALITY MARKER -C : LOWER NUMBER ALWAYS SUPERCEDES HIGHER NUMBER (SEE && ) -C BYTE 15 : +++ NUMERICAL VALUE FOR SPECIFIC HUMIDITY QUALITY MARKER -C : LOWER NUMBER ALWAYS SUPERCEDES HIGHER NUMBER (SEE && ) -C BYTE 16 : +++ TRACK CHECK INDICATOR -C : WILL CONTAIN 'E' IF SUSPECTED TRACK CHECK ERROR -C : ELSE WILL BE '-' -C -C && - '0' -- DUPLICATE ('D') ('D' IS ONLY STORED IN POS. 1 OF TAG) -C '1' -- PURGE ('P') -- OR -- -C KEEP ('H') -C '2' -- DATA ARE MISSING -C '3' -- BAD ('F') -C '4' -- RESERVED FOR FUTURE USE -C '5' -- SUSPECT ('Q') -C '6' -- GOOD ('A') -C '7' -- CANNOT BE CHECKED/UNTREATABLE OR NOT CHECKED (' ' OR -C '-') -C '8' -- INITIAL VALUE -C -C - - TAG(KOUNT)(1:4) = '----' - TAG(KOUNT)(5:5) = CINCR - TAG(KOUNT)(6:9) = '----' - TAG(KOUNT)(10:10) = SPEC5(3:3) - TAG(KOUNT)(11:11) = '-' - TAG(KOUNT)(13:15) = '888' - TAG(KOUNT)(16:16) = '-' - - IF(MAX(ASPD(KOUNT),ADIR(KOUNT)).GE.XMSG) THEN -C IF WIND IS MISSING, QUALITY MARKER IS SET TO 'x' - TAG(KOUNT)(3:3) = 'x' - TAG(KOUNT)(15:15) ='2' - ELSE IF(IWQM.EQ.14) THEN -C IF SDM PURGE FLAG ON WIND, WIND Q.M. IS SET TO 'P' - PRINT 9029, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), - $ TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 9029 FORMAT(/' P-P-P-P-P-: SDM PURGE FLAG ON WIND, WIND Q.M. IS ', - $ 'SET TO "P"..',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/) - TAG(KOUNT)(3:3) = 'P' - TAG(KOUNT)(15:15) = '1' - ELSE IF(IWQM.EQ.0) THEN -C IF SDM KEEP FLAG ON WIND, WIND Q.M. IS SET TO 'H' - PRINT 8029, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), - $ TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 8029 FORMAT(/' H-H-H-H-H-: SDM KEEP FLAG ON WIND, WIND Q.M. IS ', - $ 'SET TO "H"..',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/) - TAG(KOUNT)(3:3) = 'H' - TAG(KOUNT)(15:15) = '1' - ELSE IF(IWQM.GT.3.AND.IWQM.LT.16) THEN -C IF EXISTING BAD Q.M. ON WIND, WIND Q.M. IS SET TO 'F' - PRINT 9629, IWQM,KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), - $ TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 9629 FORMAT(/' F-F-F-F-F-: EXISTING BAD QM ON WIND (=',I2,'), WIND ', - $ 'Q.M. IS SET TO "F"..',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X, - $ A13/) - TAG(KOUNT)(3:3) = 'F' - TAG(KOUNT)(15:15) = '3' - END IF - - IF(ATMP(KOUNT).GE.XMSG) THEN -C IF TEMPERATURE IS MISSING, QUALITY MARKER IS SET TO 'x' - TAG(KOUNT)(1:1) = 'x' - TAG(KOUNT)(13:13) = '2' - ELSE IF(ITQM.EQ.14) THEN -C IF SDM PURGE FLAG ON TEMPERATURE, TEMPERATURE Q.M. IS SET TO 'P' - PRINT 9039, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), - $ TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 9039 FORMAT(/' P-P-P-P-P-: SDM PURGE FLAG ON TEMP, TEMP Q.M. IS ', - $ 'SET TO "P"..',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/) - TAG(KOUNT)(1:1) = 'P' - TAG(KOUNT)(13:13) = '1' - IF(ASPH(KOUNT).LT.XMSG) THEN -C IF SDM PURGE FLAG ON TEMPERATURE, SPECIFIC HUMIDITY Q.M. IS SET TO 'P' -C (UNLESS SPECIFIC HUMIDITY IS MISSING) - PRINT 9049, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), - $ TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 9049 FORMAT(/' P-P-P-P-P-: SDM PURGE FLAG ON TEMP, SHUM Q.M. IS ', - $ 'SET TO "P"..',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/) - TAG(KOUNT)(2:2) = 'P' - TAG(KOUNT)(14:14) = '1' - END IF - ELSE IF(ITQM.EQ.0) THEN -C IF SDM KEEP FLAG ON TEMPERATURE, TEMPERATURE Q.M. IS SET TO 'H' - PRINT 8039, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), - $ TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 8039 FORMAT(/' H-H-H-H-H-: SDM KEEP FLAG ON TEMP, TEMP Q.M. IS ', - $ 'SET TO "H"..',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/) - TAG(KOUNT)(1:1) = 'H' - TAG(KOUNT)(13:13) = '1' - ELSE IF(ITQM.GT.3.AND.ITQM.LT.16) THEN -C IF EXISTING BAD Q.M. ON TEMP, TEMP Q.M. IS SET TO 'F' - PRINT 9639, ITQM,KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), - $ TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 9639 FORMAT(/' F-F-F-F-F-: EXISTING BAD QM ON TEMP (=',I2,'), TEMP ', - $ 'Q.M. IS SET TO "F"..',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X, - $ A13/) - TAG(KOUNT)(1:1) = 'F' - TAG(KOUNT)(13:13) = '3' - IF(ASPH(KOUNT).LT.XMSG) THEN -C IF EXISTING BAD Q.M. ON TEMPERATURE, SPECIFIC HUMIDITY Q.M. IS SET TO -C 'P' (UNLESS SPECIFIC HUMIDITY IS MISSING) - PRINT 9099, ITQM,KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), - $ TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 9099 FORMAT(/' F-F-F-F-F-: EXISTING BAD QM ON TEMP (=',I2,'), SHUM ', - $ 'Q.M. IS SET TO "F"..',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X, - $ A13/) - TAG(KOUNT)(2:2) = 'F' - TAG(KOUNT)(14:14) = '3' - END IF - END IF - - IF(TAG(KOUNT)(14:14).GT.'3') THEN - IF(ASPH(KOUNT).GE.XMSG) THEN -C IF SPECIFIC HUMIDITY IS MISSING, QUALITY MARKER IS SET TO 'x' - TAG(KOUNT)(2:2) = 'x' - TAG(KOUNT)(14:14) ='2' - ELSE IF(IQQM.EQ.14) THEN -C IF SDM PURGE FLAG ON SPECIFIC HUMIDITY, SPECIFIC HUMIDITY Q.M. IS SET -C TO 'P' - PRINT 9059, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), - $ TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 9059 FORMAT(/' P-P-P-P-P-: SDM PURGE FLAG ON SHUM, SHUM Q.M. IS ', - $ 'SET TO "P"..',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/) - TAG(KOUNT)(2:2) = 'P' - TAG(KOUNT)(14:14) = '1' - ELSE IF(IQQM.EQ.0) THEN -C IF SDM KEEP FLAG ON SPECIFIC HUMIDITY, SPECIFIC HUMIDITY Q.M. IS SET -C TO 'H' - PRINT 8059, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), - $ TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 8059 FORMAT(/' H-H-H-H-H-: SDM KEEP FLAG ON SHUM, SHUM Q.M. IS ', - $ 'SET TO "H"..',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13,/) - TAG(KOUNT)(2:2) = 'H' - TAG(KOUNT)(14:14) = '1' - ELSE IF(IQQM.GT.3.AND.IQQM.LT.16) THEN -C IF EXISTING BAD Q.M. ON SHUM, SHUM Q.M. IS SET TO 'F' - PRINT 9649, IQQM,KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), - $ TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 9649 FORMAT(/' F-F-F-F-F-: EXISTING BAD QM ON SHUM (=',I2,'), SHUM ', - $ 'Q.M. IS SET TO "F"..',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X, - $ A13/) - TAG(KOUNT)(2:2) = 'F' - TAG(KOUNT)(14:14) = '3' - END IF - END IF - -C SET POS. 12 OF TAG TO '@' TO MARK PURGE FLAG OR MISSING DATA ON BOTH -C WIND AND TEMPERATURE (THESE REPORTS WILL BE EXCLUDED FROM MOST -C FURTHER PROCESSING) - IF((TAG(KOUNT)(1:1).EQ.'P'.OR.TAG(KOUNT)(1:1).EQ.'x') .AND. - $ (TAG(KOUNT)(3:3).EQ.'P'.OR.TAG(KOUNT)(3:3).EQ.'x')) - $ TAG(KOUNT)(12:12) = '@' - - IF(AALT(KOUNT).GT.16500) THEN - TAG(KOUNT)(12:12) = '@' -CVVVVV%%%%% -ccc PRINT *,'~~~~~ HERE IS A RPT WITH ALT > 16,500 METERS' -CAAAAA%%%%% - IF(TAG(KOUNT)(13:13).GT.'3') THEN - IF(EWRITE) PRINT 9108, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 9108 FORMAT(/' #EVENT 1: ALTITUDE IS > 16,500 M (~95 MB), TEMP QM ', - $ '"F" ',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/) - TAG(KOUNT)(1:1) = 'F' - TAG(KOUNT)(13:13) = '3' - ITEVNT(KOUNT) = 1 - END IF - IF(TAG(KOUNT)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 7108, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 7108 FORMAT(/' #EVENT 1: ALTITUDE IS > 16,500 M (~95 MB), SHUM QM ', - $ '"F" ',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/) - TAG(KOUNT)(2:2) = 'F' - TAG(KOUNT)(14:14) = '3' - IQEVNT(KOUNT) = 1 - END IF - IF(TAG(KOUNT)(15:15).GT.'3') THEN - IF(EWRITE) PRINT 7908, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 7908 FORMAT(/' #EVENT 1: ALTITUDE IS > 16,500 M (~95 MB), WIND QM ', - $ '"F" ',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/) - TAG(KOUNT)(3:3) = 'F' - TAG(KOUNT)(15:15) = '3' - IWEVNT(KOUNT) = 1 - END IF - END IF - - IF(NINT(ALAT(KOUNT)*100.).EQ.0) THEN - TAG(KOUNT)(12:12) = '@' -CVVVVV%%%%% -ccc PRINT *,'~~~~~ HERE IS A RPT WITH LATITUDE OF 0 DEGREES' -CAAAAA%%%%% - IF(TAG(KOUNT)(13:13).GT.'3') THEN - IF(EWRITE) PRINT 9908, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 9908 FORMAT(/' #EVENT 2: LATITUDE IS 0 DEGREES, TEMP QM "F" ',I5,2X, - $ A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/) - TAG(KOUNT)(1:1) = 'F' - TAG(KOUNT)(13:13) = '3' - ITEVNT(KOUNT) = 2 - END IF - IF(TAG(KOUNT)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 2908, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 2908 FORMAT(/' #EVENT 2: LATITUDE IS 0 DEGREES, SHUM QM "F" ',I5,2X, - $ A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/) - TAG(KOUNT)(2:2) = 'F' - TAG(KOUNT)(14:14) = '3' - IQEVNT(KOUNT) = 2 - END IF - IF(TAG(KOUNT)(15:15).GT.'3') THEN - IF(EWRITE) PRINT 8908, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 8908 FORMAT(/' #EVENT 2: LATITUDE IS 0 DEGREES, WIND QM "F" ',I5,2X, - $ A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/) - TAG(KOUNT)(3:3) = 'F' - TAG(KOUNT)(15:15) = '3' - IWEVNT(KOUNT) = 2 - END IF - END IF - - IF(NINT(ALON(KOUNT)*100.).EQ.0) THEN - TAG(KOUNT)(12:12) = '@' -CVVVVV%%%%% -ccc PRINT *,'~~~~~ HERE IS A RPT WITH LONGITUDE OF 0 DEGREES' -CAAAAA%%%%% - IF(TAG(KOUNT)(13:13).GT.'3') THEN - IF(EWRITE) PRINT 5908, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 5908 FORMAT(/' #EVENT 3: LONGITUDE IS 0 DEGREES, TEMP QM "F" ',I5,2X, - $ A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/) - TAG(KOUNT)(1:1) = 'F' - TAG(KOUNT)(13:13) = '3' - ITEVNT(KOUNT) = 3 - END IF - IF(TAG(KOUNT)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 5909, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 5909 FORMAT(/' #EVENT 3: LONGITUDE IS 0 DEGREES, SHUM QM "F" ',I5,2X, - $ A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/) - TAG(KOUNT)(2:2) = 'F' - TAG(KOUNT)(14:14) = '3' - IQEVNT(KOUNT) = 3 - END IF - IF(TAG(KOUNT)(15:15).GT.'3') THEN - IF(EWRITE) PRINT 5910, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 5910 FORMAT(/' #EVENT 3: LONGITUDE IS 0 DEGREES, WIND QM "F" ',I5,2X, - $ A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/) - TAG(KOUNT)(3:3) = 'F' - TAG(KOUNT)(15:15) = '3' - IWEVNT(KOUNT) = 3 - END IF - END IF - - IF(TAG(KOUNT)(15:15).GT.'3'.AND.NINT(ASPD(KOUNT)*10.).EQ.0.) THEN -C FLAG ALL CALM WINDS - IF(EWRITE) PRINT 9005, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 9005 FORMAT(/' #EVENT 4: CALM WIND, WIND Q.M. SET "F".', - $ I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/) - TAG(KOUNT)(3:3) = 'F' - TAG(KOUNT)(15:15) = '3' - IWEVNT(KOUNT) = 4 - END IF - - IF(TAG(KOUNT)(13:13).GT.'2'.AND.ATMPF(KOUNT).LT.XMSG) THEN -C IF GUESS TEMPERATURE AVAILABLE, CHECK TEMPERATURE OF REPORTS WITH -C ALTITUDE BETWEEN 2000 AND 5000 FEET - IF NOT WITHIN 25 DEG. C OF -C GUESS TEMPERATURE FLAG THE REPORT; SET POS. 12 OF TAG TO '@' TO MARK -C THEM -C (NOTE: DONE TO FLAG RPTS THAT ARE ACTUALLY AT AN ALT. BETWEEN 20,000 -C AND 50,000 FT. BUT ARE REPORTED WITH A '0' DIGIT DROPPED) - IF((AALT(KOUNT).GT.609..AND.AALT(KOUNT).LT.1524.).AND. - $ (ABS(ATMP(KOUNT)-ATMPF(KOUNT)).GT.25.)) THEN - TAG(KOUNT)(12:12) = '@' -CVVVVV%%%%% - PRINT *,'~~~~~ HERE IS A RPT WITH INCORRECT? ALTITUDE!!' -CAAAAA%%%%% - IF(TAG(KOUNT)(13:13).GT.'3') THEN - IF(EWRITE) PRINT 9902, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 9902 FORMAT(/' #EVENT 5: "0" DIGIT DROPPED FROM ALT.?, TEMP QM "F" ', - $ I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/) - TAG(KOUNT)(1:1) = 'F' - TAG(KOUNT)(13:13) = '3' - ITEVNT(KOUNT) = 5 - END IF - IF(TAG(KOUNT)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 7902, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 7902 FORMAT(/' #EVENT 5: "0" DIGIT DROPPED FROM ALT.?, SHUM QM "F" ', - $ I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/) - TAG(KOUNT)(2:2) = 'F' - TAG(KOUNT)(14:14) = '3' - IQEVNT(KOUNT) = 5 - END IF - IF(TAG(KOUNT)(15:15).GT.'3') THEN - IF(EWRITE) PRINT 8902, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 8902 FORMAT(/' #EVENT 5: "0" DIGIT DROPPED FROM ALT.?, WIND QM "F" ', - $ I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/) - TAG(KOUNT)(3:3) = 'F' - TAG(KOUNT)(15:15) = '3' - IWEVNT(KOUNT) = 5 - END IF - END IF - END IF - - IF(IWRITE) THEN - PRINT 6177, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), - $ NINT(TIME(KOUNT)),NINT(AALT(KOUNT)),ATMP(KOUNT),ASPH(KOUNT), - $ NINT(ADIR(KOUNT)),ASPD(KOUNT),TAG(KOUNT)(1:3), - $ TAG(KOUNT)(4:16),INTP(KOUNT),IRTM(KOUNT),KNTINI(KOUNT), - $ NINT(AALTF(KOUNT)),ATMPF(KOUNT),NINT(ADIRF(KOUNT)), - $ ASPDF(KOUNT) - 6177 FORMAT(' ',I5,2X,A8,1X,2(1X,F6.2),1X,I4,1X,I5,2(1X,F5.1),1X, - $ I3,1X,F4.1,2X,A3,2X,A13,3X,I2,3X,I4,2X,I5,1X,I5,1X,F5.1,2X, - $ I3,1X,F4.1) - END IF - -C NOW GO BACK AND READ IN NEXT REPORT - GO TO 5 - -C*********************************************************************** - - 2 CONTINUE - -C ALL MESSAGES READ IN -- FINISHED READING IN REPORTS - PRINT 812, KOUNT - 812 FORMAT(/' ALL MESSAGES READ IN PREPBUFR FILE -- TOTAL NUMBER OF ', - $ 'REPORTS READ=',I6) - NFILE = KOUNT - - IF(KOUNT.EQ.0) GO TO 6000 - -C*********************************************************************** -C SORT BY ACARS STATION ID (FOR TRACK CHECKING) -C*********************************************************************** - CALL IDSORT(NFILE,NEXCLUDE) - IF(IWRITE) THEN - PRINT 2177 - 2177 FORMAT(/' LISTING OF ORIGINAL DATA AFTER IDSORT----'/9X,'ACID', - $ 7X,'LAT WLON UTC ALT TEMP SHUM DIR SPD -QM ----TAGS', - $ '----- ITP RPTIME KNTINI GALT GTEMP GDIR GSPD'/) - DO K = 1,KOUNT - PRINT 6177, K,ACID(K),ALAT(K),ALON(K),NINT(TIME(K)),NINT(AALT(K)), - $ ATMP(K),ASPH(K),NINT(ADIR(K)),ASPD(K),TAG(K)(1:3),TAG(K)(4:16), - $ INTP(K),IRTM(K),KNTINI(K),NINT(AALTF(K)),ATMPF(K),NINT(ADIRF(K)), - $ ASPDF(K) - ENDDO - END IF - PRINT 6122, KOUNT,NEXCLUDE - 6122 FORMAT(/' AFTER ID SORT: INPUT FILE COUNT=',I7,', NUMBER OF ', - $ 'EXCLUDED REPORTS=',I5/) - -C*********************************************************************** -C TRACK CHECK -C*********************************************************************** -C CALL TRACK CHECK WITH NEXCLUDE (GOOD REPORTS ARE FIRST IN SORTED -C ARRAY, REPORTS EXCLUDED FROM ALL CHECKS ARE LAST IN SORTED ARRAY) -C CALL TRACK CHECK WITH NFILE=KOUNT, RETURNS NEW KOUNT (NO DUPS) - CALL TRKCHK(KOUNT,NEXCLUDE) ! Not much happens in here yet! -C*********************************************************************** -C HERE, TAG(KOUNT)(16:16) NOW CONTAINS '-' OR 'E' FOR SUSPECTED TRKCHK -C ERROR - DO CENSUS ON INCREMENTS - DO K = 1,KOUNT - IF(TIME(K).GE.TMINO.AND.TIME(K).LE.TMAXO) THEN - DO M = 1,11 - IF(TAG(K)(5:5).EQ.INACMK(M)) THEN - NNIN(M) = NNIN(M) + 1 - EXIT - END IF - ENDDO - END IF - ENDDO -C INITIALIZE SDM LOOKAT FILE FOR FLAGGED REPORTS -- UNIT 52 - WRITE(52,15) (IDATE(I),I=1,4) - 15 FORMAT(/'SDM ACARS QC CHECK FILE FOR ',I6,3I4.2) - WRITE(52,16) - 16 FORMAT('REPORTS TOSSED (WIND AND/OR TEMP QM=F), OR WITH LARGE ', - $ 'WIND INCREMENTS (.GE. 50 )'/ - $ ' (SUSPECT QM=Q, GOOD QM=A)'/ - $ '(NOTE1: ACARS ARE NEVER FLAGGED AS BAD DUE ONLY TO LARGE ', - $ 'INCREMENTS)'/ - $ '(NOTE2: DOES NOT INCLUDE REPORTS MARKED FOR EXCLUSION BY ', - $ 'THIS PROGRAM - THESE'/9X,'ARE NOT CONSIDERED CANDIDATES FOR ', - $ 'RETENTION)'// - $ 'SDMEDIT CAN BE USED TO MARK THESE FOR RETENTION (KEEP FLAG) ', - $ 'IN LATER RUNS'/' OR FLAG (PURGE) THOSE WITH LARGE WIND ', - $ 'INCREMENTS'//) - - WRITE(52,17) - 17 FORMAT(/' AC',9X,'LAT LON UTC ALT TEMP SHUM WDIR ', - $ 'WSPD INCR WND TMP'/'IDENT',27X,'(MB) (C) (G/KG)',7X, - $ '(M/S) (KTS) QM QM'/'-------- ------ ------- ---- ----', - $ ' ----- ----- ---- ----- ----- --- ---'/) - - KDUP = NFILE - KOUNT -C ARRANGE STACK - INDX RUNS FROM 1 TO KOUNT - JARRAY = 0 - CTAG = '----------------' - AAID = ' ' - DO INDX = 1,KOUNT - SLAT(1) = ALAT(INDX) - SLON(1) = ALON(INDX) - SAID(1) = ACID(INDX) - SHGT(1) = AALT(INDX) - STIM(1) = TIME(INDX) - SDIR(1) = ADIR(INDX) - SSPD(1) = ASPD(INDX) - STMP(1) = ATMP(INDX) - SSPH(1) = ASPH(INDX) - SHGTF(1) = AALTF(INDX) - SDIRF(1) = ADIRF(INDX) - SSPDF(1) = ASPDF(INDX) - STMPF(1) = ATMPF(INDX) - -C CALL RPACKR - CALL RPACKR(INDX) - -C CALL FORSDM TO ALERT SDM TO FLAGGED REPORTS OR REPORTS WITH LARGE -C INCREMENTS (SKIP EXCLUDED REPORTS AT END OF THE LIST) - IF(INDX.LE.KOUNT-NEXCLUDE) CALL FORSDM(INDX) - - ICNT1 = ICNT1 + 1 - ENDDO - - 6000 CONTINUE - -C----------------------------------------------------------------------- -C PACK Q.C'ED OBSERVATIONS INTO PREPBUFR FILE -C----------------------------------------------------------------------- - CALL OBUFR(KOUNT) - -C----------------------------------------------------------------------- -C ALL REPORTS HAVE BEEN PROCESSED -- WE ARE DONE -C----------------------------------------------------------------------- - PRINT 8926, KNTOUT - 8926 FORMAT(/5X,'@@@@@ ALL REPORTS PROCESSED: NUMBER OF ORIGINAL ', - $ '"AIRCAR" MASS REPORTS COPIED TO OUTPUT FILE =',I6/35X,'NUMBER ', - $ 'OF ORIGINAL "AIRCAR" WIND REPORTS COPIED TO OUTPUT FILE =',I6) - IF(FWRITE) THEN - PRINT 8923 - 8923 FORMAT(//26X,'>>>>> ORIGINAL LISTING OF ACARS REPORTS NOW WITH ', - $ 'NEW QUALITY MARKS <<<<<'//' K STNID TIME LAT LON ', - $ ' ALT TEMP SHUM DIR SPD -QM ----TAGS----- ITP ', - $ 'KINI TEV QEV WEV GALT GTEMP GDIR GSPD'/16X,'UTC',10X,'WEST',5X, - $ 'M C G/KG DEG M/S',8X,13('-'),27X,'M C DEG M/S'/) - KNT = 0 - DO K = 1,KOUNT - IF(TAG(K)(4:4).EQ.'D') GO TO 200 - KNT = KNT + 1 - PRINT 6111, KNT,ACID(K),NINT(TIME(K)),ALAT(K),ALON(K), - $ NINT(AALT(K)),ATMP(K),ASPH(K),NINT(ADIR(K)),ASPD(K),TAG(K)(1:3), - $ TAG(K)(4:16),INTP(K),KNTINI(K),ITEVNT(K),IQEVNT(K),IWEVNT(K), - $ NINT(AALTF(K)),ATMPF(K),NINT(ADIRF(K)),ASPDF(K) - 6111 FORMAT(' ',I7,1X,A8,1X,I4,2(1X,F6.2),1X,I5,2(1X,F5.1),2X,I3,2X, - $ F4.1,2X,A3,2X,A13,3X,I2,1X,I5,3(1X,I3),1X,I5,1X,F5.1,2X,I3,1X, - $ F4.1) - 200 CONTINUE - ENDDO - END IF - - PRINT 5001, NFILE,ICNT1,KDUP - 5001 FORMAT(//' ORIGINAL DATA (WITHIN EXPANDED INPUT TIME WINDOW)'/ - $ ' INPUT FILE COUNT=',I6,'; NUMBER OF NON-DUPLICATES WRITTEN ', - $ 'OUT=',I6,'; NUMBER OF DUPLICATES NOT WRITTEN OUT=',I5) - PRINT 5014, INACMK - 5014 FORMAT(//' ORIGINAL DATA (WITHIN OUTPUT TIME WINDOW)'/49X, - $ 11(5X,A1)/) - PRINT 5331, NNIN - 5331 FORMAT(' NUMBER ACCORDING TO OBS-GUESS INCREMENT (INPUT) ',11I6) - PRINT 5337, KISO - 5337 FORMAT(' NUMBER ACCORDING TO OBS-GUESS INCREMENT (OUTPUT) ',11I6) - - END FILE 52 - - REWIND 52 - - PRINT 5015 - 5015 FORMAT(/49X,'************PROGRAM COMPLETED *********') - - CALL W3TAGE('PREPOBS_ACARSQC') - - STOP - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: TRKCHK COMPLETE TRACK CHECK FOR ALL FLIGHTS -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2002-05-07 -C -C ABSTRACT: PERFORMS COMPLETE TRACK CHECK FOR ALL ACARS FLIGHTS WITH -C TWO OR MORE REPORTS. USING REPORTS ALREADY SORTED BY STATION -C ID (TAIL NUMBER), CALCULATES GROUND SPEED AND OTHER LOGICAL -C QUANTITIES TO ENTER DECISION MAKING ALGORITHM FOR CHOOSING BAD -C REPORTS. THESE OBSERVATIONS ARE FLAGGED. DUPLICATE REPORTS ARE -C ELIMINATED. NOTE: THIS IS NOT YET RUNNING, ALL THIS SUBROUTINE -C DOES NOW IS RESORT REPORTS ACCORDING TO REPORTED LATITUDE. -C -C PROGRAM HISTORY LOG: -C 2002-05-07 D. A. KEYSER -- ORIGINAL AUTHOR (NO TRACK CHECKING -C LOGIC YET IN PLACE) -C -C USAGE: CALL TRKCHK(NFILE,NEXCLUDE) -C INPUT ARGUMENT LIST: -C NFILE - NUMBER OF OBSERVATIONS TO BE TREATED -C NEXCLUDE - NUMBER OF EXCLUDED REPORTS AT END OF SORT -C -C OUTPUT ARGUMENT LIST: -C NFILE - NUMBER OF OBSERVATIONS AFTER DUPLICATES REMOVED -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C REMARKS: CALLED BY MAIN PROGRAM. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE TRKCHK(NFILE,NEXCLUDE) - - PARAMETER (IRMX= 200000, ISMX= 4000) - PARAMETER (ISIZE= 18) -C PARAMETER NAME "ITMX" IN THIS SUBROUTINE (ONLY) SETS THE MAXIMUM -C NUMBER OF ACARS RPTS THAT CAN BE CHECKED IN A SINGLE TRACK - PARAMETER (ITMX= 4000) - PARAMETER (ITRKL= 20) - - LOGICAL LOGLAT,LOGTME,LOGLT1,LOGWND,DUP,LOGTRK,LOGALT,NEW,LOGLON, - $ LOGLO,LOGTMP,LOGGT3,LOGHI,LPOS25,TRACE,LUTCEQ,LLATEQ,LLONEQ, - $ LVAREQ,EWRITE,EWRITE_7,IWRITE - - CHARACTER*1 TOSLIM,CTG - CHARACTER*8 ACID,SAAID(IRMX),AAID(IRMX),TYPE(ITRKL) - CHARACTER*16 TAG,CTAG(IRMX),STAG(IRMX) - CHARACTER*32 CARRAY(IRMX) - - INTEGER IPTNAD(ITRKL),JPTNAD(ITRKL),IPTADJ(ITRKL),IPTTRK(5), - $ DTKNT,IARRAY(ISMX),INDR(IRMX) - - REAL AVESPD(ITMX),DELPOS(ITMX),DELLAT(ITMX),DELLON(ITMX) - - COMMON/STWRIT/EWRITE,EWRITE_7,IWRITE - COMMON/XXXXX/AAID,JARRAY(IRMX,ISIZE),CTAG,KARRAY(IRMX,ISIZE),STAG - COMMON/ACCONT/KISO(11) - COMMON/ALLDAT/ACID(IRMX),ALAT(IRMX),ALON(IRMX),AALT(IRMX), - $ TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE,ATMP(IRMX),ASPH(IRMX), - $ TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX),ITEVNT(IRMX), - $ IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX),ADIRF(IRMX), - $ IQEVNT(IRMX) - - DATA XMSG/99999./,IMSG/99999/ - - KOUNT = NFILE - TRACE = .TRUE. - TRACE = .FALSE. - DG2RAD = (4.0 * ATAN(1.0))/180. - -C TRANSFER ORIGINAL DATA TO TEMPORARY ARRAYS TO HOLD FOR RE-ARRANGING -C (ORIGINAL DATA HAS BEEN SORTED BY TAIL NUMBER ID, WITH BAD REPORTS -C LAST) - AAID(1:NFILE) = ACID(1:NFILE) - SAAID(1:NFILE) = AAID(1:NFILE) - JARRAY(1:NFILE,1) = NINT(ALAT(1:NFILE)*100.) - JARRAY(1:NFILE,2) = NINT(ALON(1:NFILE)*100.) - JARRAY(1:NFILE,3) = NINT(AALT(1:NFILE)) - JARRAY(1:NFILE,4) = NINT(TIME(1:NFILE)) - JARRAY(1:NFILE,5) = NINT(ATMP(1:NFILE)*10.) - JARRAY(1:NFILE,6) = NINT(ADIR(1:NFILE)) - JARRAY(1:NFILE,7) = NINT(ASPD(1:NFILE)*10.) - JARRAY(1:NFILE,8) = INTP(1:NFILE) - JARRAY(1:NFILE,9) = IRTM(1:NFILE) - JARRAY(1:NFILE,10) = KNTINI(1:NFILE) - JARRAY(1:NFILE,11) = ITEVNT(1:NFILE) - JARRAY(1:NFILE,12) = IWEVNT(1:NFILE) - JARRAY(1:NFILE,13) = NINT(AALTF(1:NFILE)) - JARRAY(1:NFILE,14) = NINT(ADIRF(1:NFILE)) - JARRAY(1:NFILE,15) = NINT(ASPDF(1:NFILE)*10.) - JARRAY(1:NFILE,16) = NINT(ATMPF(1:NFILE)*10.) - JARRAY(1:NFILE,17) = NINT(ASPH(1:NFILE)*10.) - JARRAY(1:NFILE,18) = IQEVNT(1:NFILE) - KARRAY(1:NFILE,:) = JARRAY(1:NFILE,:) - CTAG(1:NFILE) = TAG(1:NFILE) - STAG(1:NFILE) = CTAG(1:NFILE) - NACARS = NFILE - NEXCLUDE - PRINT 501, KOUNT,NACARS,NEXCLUDE - 501 FORMAT(1X,128('*')/43X,'ACARS TRACK CHECK SORT - NCEP ', - $ 'WASHINGTON'/128('*')//' INPUT FILE COUNT=',I6,', NUMBER OF ', - $ 'NON-EXCLUDED REPORTS=',I6,', NUMBER OF EXCLUDED REPORTS=',I6) -CCCCC PRINT 502 -CC502 FORMAT(' LISTING OF DATA, SORTED BY ID, ENTERING TRKCHK----'/9X, -CCCCC$ 'ACID',7X,'LAT WLON UTC ALT TEMP SHUM DIR SPD ', -CCCCC$ '-QM ----TAGS----- ITP RPTIME KNTINI GALT GTEMP GDIR GSPD'/) -CCCCC DO J = 1,KOUNT -CCCCC SARRY1 = XMSG -CCCCC IF(JARRAY(J, 1).LT.IMSG) SARRY1 = JARRAY(J, 1) * 0.01 -CCCCC SARRY2 = XMSG -CCCCC IF(JARRAY(J, 2).LT.IMSG) SARRY2 = JARRAY(J, 2) * 0.01 -CCCCC SARRY5 = XMSG -CCCCC IF(JARRAY(J, 5).LT.IMSG) SARRY5 = JARRAY(J, 5) * 0.1 -CCCCC SARRY7 = XMSG -CCCCC IF(JARRAY(J, 7).LT.IMSG) SARRY7 = JARRAY(J, 7) * 0.1 -CCCCC SARRY15 = XMSG -CCCCC IF(JARRAY(J,15).LT.IMSG) SARRY15 = JARRAY(J,15) * 0.1 -CCCCC SARRY16 = XMSG -CCCCC IF(JARRAY(J,16).LT.IMSG) SARRY16 = JARRAY(J,16) * 0.1 -CCCCC SARRY17 = XMSG -CCCCC IF(JARRAY(J,17).LT.IMSG) SARRY17 = JARRAY(J,17) * 0.1 -CCCCC PRINT 331, J,AAID(J),SARRY1,SARRY2,JARRAY(J,4),JARRAY(J,3), -CCCCC$ SARRAY5,SARRAY17,JARRAY(J,6),SARRAY7,CTAG(J)(1:3), -CCCCC$ CTAG(J)(4:16),JARRAY(J,8),JARRAY(J,9),JARRAY(J,10), -CCCCC$ JARRAY(J,13),SARRY16,JARRAY(J,14),SARRY15 -CCCCC ENDDO - PRINT 574 - 574 FORMAT(/' ----------------------------------') - NTRK = 0 - ITRK = NACARS + 1 - 65 CONTINUE - PRINT 574 - -C*********************************************************************** -C DETERMINE TRACK FOR EACH NON-EXCLUDED ACARS FLIGHT ID -C*********************************************************************** - PRINT 574 - NTRK = 0 - ITRK = 1 - PRINT 574 - -C Future Track checking logic will go here - - -C RESORT FOR SUBSEQUENT Q.C. CHECKING: -C 1ST ORDER - LATITUDE (SOUTH TO NORTH) -C 2ND ORDER - LONGITUDE (WEST, INCREASING) -C 3RD ORDER - TIME (INCREASING) -C 4TH ORDER - ALITITUDE (INCREASING) -C SORT BY CONCATENATING THESE QUANITIIES INTO CHARACTER ARRAY - DO J = 1,NACARS - WRITE(CARRAY(J)(1:5),'(I5.5)') JARRAY(J,1) + 9000 - WRITE(CARRAY(J)(6:10),'(I5.5)') JARRAY(J,2) - WRITE(CARRAY(J)(11:14),'(I4.4)') JARRAY(J,4) - WRITE(CARRAY(J)(15:20),'(I6.6)') JARRAY(J,3) - CARRAY(J)(21:32) = '000000000000' -CCCCC PRINT 788, J,AAID(J),CARRAY(J) -CC788 FORMAT(' DBG J ',I6,2X,'; ID=',A8,'; CARRAY=',A32) - ENDDO -C CALL SORT ROUTINE- PUTS POINTERS INTO IPOINT ARRAY/DOES NOT REARRANGE - IF(NACARS.GT.0) CALL INDEXC(NACARS,CARRAY,INDR) -C WRITE SORTED REPORTS INTO SAAID, KARRAY, AND STAG ARRAYS (REMAINING -C EXCLUDED REPORTS ALREADY IN THESE ARRAYS IN PROPER POSITION FROM -C STORE MADE AT BEGINNING OF SUBROUTINE) - DO I = 1,NACARS - J = INDR(I) - SAAID(I) = AAID(J) - STAG(I) = CTAG(J) - KARRAY(I,:) = JARRAY(J,:) - ENDDO -CCCCC PRINT 562 -CC562 FORMAT(' LAT/LON ACID ',6X,' LAT LON ',4X,'UTC ALT ', -CCCCC$' TEMP SHUM WDIR WSPD ') -CCCCC DO J = 1,KOUNT -CCCCC KARRY1 = MIN(KARRAY(J, 1),IMSG) -CCCCC KARRY2 = MIN(KARRAY(J, 2),IMSG) -CCCCC KARRY5 = MIN(KARRAY(J, 5),IMSG) -CCCCC KARRY17 = MIN(KARRAY(J,17),IMSG) -CCCCC KARRY7 = MIN(KARRAY(J, 7),IMSG) -CCCCC PRINT 711, J,SAAID(J),KARRY1*.01,KARRY2*.01,KARRAY(J,4), -CCCCC$ KARRAY(J,3),KARRAY5*.1,KARRAY17*.1,KARRAY(J,6),KARRAY7*.1, -CCCCC$ STAG(J)(1:3),STAG(J)(4:16) -CC711 FORMAT(' ',I5,2X,A8,2(2X,F6.2),4X,I4,3X,I5,2(3X,F5.1),5X,I3,4X, -CCCCC$ F4.1,A3,1X,A13) -CCCCC ENDDO -C WRITE SORTED REPORTS BACK INTO ORIGINAL ARRAYS AND ELIMINATE DUPS - IF(IWRITE) PRINT 557 - 557 FORMAT(/' FINAL LISTING OF DATA, SORTED BY ID AND LATITUDE, ', - $ ' LEAVING TRKCHK----'/9X,'ACID',7X,'LAT WLON UTC ALT ', - $ 'TEMP SHUM DIR SPD -QM ----TAGS----- ITP RPTIME KNTINI ', - $ 'GALT GTEMP GDIR GSPD'/) - M = 0 - DO I = 1,KOUNT - IF(STAG(I)(4:4).EQ.'D') THEN - PRINT 9022, I,SAAID(I),REAL(KARRAY(I,1))*.01, - $ REAL(KARRAY(I,2))*.01,REAL(KARRAY(I,4)),STAG(I)(1:3), - $ STAG(I)(4:16) - 9022 FORMAT(/' ##########: TRKCHK; DUPLICATE REMOVED AT END OF SUBR..', - $ I5,2X,A8,2(2X,F6.2),1X,F5.0,2X,A3,1X,A13/) - CYCLE - END IF - M = M + 1 - ACID(M) = SAAID(I) - ALAT(M) = KARRAY(I,1) * .01 - ALON(M) = KARRAY(I,2) * .01 - AALT(M) = KARRAY(I,3) - TIME(M) = KARRAY(I,4) - ATMP(M) = KARRAY(I,5) * .1 - ADIR(M) = KARRAY(I,6) - ASPD(M) = KARRAY(I,7) * .1 - INTP(M) = KARRAY(I,8) - IRTM(M) = KARRAY(I,9) - KNTINI(M) = KARRAY(I,10) - ITEVNT(M) = KARRAY(I,11) - IWEVNT(M) = KARRAY(I,12) - AALTF(M) = KARRAY(I,13) - ADIRF(M) = KARRAY(I,14) - ASPDF(M) = KARRAY(I,15) * .1 - ATMPF(M) = KARRAY(I,16) * .1 - ASPH(M) = KARRAY(I,17) * .1 - IQEVNT(M) = KARRAY(I,18) - TAG(M) = STAG(I) - IF(IWRITE) PRINT 331, M,ACID(M),ALAT(M),ALON(M),NINT(TIME(M)), - $ NINT(AALT(M)),ATMP(M),ASPH(M),NINT(ADIR(M)),ASPD(M), - $ TAG(M)(1:3),TAG(M)(4:16),INTP(M),IRTM(M),KNTINI(M), - $ NINT(AALTF(M)),ATMPF(M),NINT(ADIRF(M)),ASPDF(M) - 331 FORMAT(' ',I5,2X,A8,1X,2(1X,F6.2),1X,I4,1X,I5,2(1X,F5.1),1X, - $ I3,1X,F4.1,2X,A3,2X,A13,3X,I2,3X,I4,2X,I5,1X,I5,1X,F5.1,2X, - $ I3,1X,F4.1) - ENDDO - NFILE = M - PRINT 681, NFILE - 681 FORMAT(//1X,128('*')/25X,'OUT OF TRACK CHECK - NUMBER OF NON-', - $ 'DUPLICATE REPORTS (INCL. PREVIOUSLY EXCLUDED) =',I7/1X,128('*') - $ ///) - - RETURN - - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FORSDM WRITES FLAGGED OR LARGE INCREMENT REPORTS -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2002-05-07 -C -C ABSTRACT: WRITES ALL REPORTS CONTAINING A TEMPERATURE AND/OR WIND -C WHICH HAS BEEN FLAGGED FOR NON-USE TO A TEXT FILE WHICH THE SDM -C CAN EXAMINE. ALSO WRITES ALL REPORTS WITH LARGE WIND INCREMENTS, -C REGARDLESS OF QUALITY MARKER. THIS ALLOWS THE SDM TO USE SDMEDIT -C TO 'KEEP' ANY OF THESE REPORTS IN THE NEXT NETWORK RUN. -C -C PROGRAM HISTORY LOG: -C 2002-05-07 D. A. KEYSER -- ORIGINAL AUTHOR (ADAPTED FROM SUBROUTINE -C IN EXISTING PROGRAM "PREPOBS_PREPACQC") -C -C USAGE: CALL FORSDM(INDX) -C INPUT ARGUMENT LIST: -C INDX - POINTER TO POSITION IN ORIGINAL ACARS ARRAY -C -C OUTPUT FILES: -C UNIT 52 - TEXT FILE FOR SDM PERUSAL (LIST OF REPORTS THAT ARE -C - FLAGGED FOR NON-USE BY THIS PROGRAM AS WELL AS THOSE -C - WITH LARGE INCREMENTS) -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE FORSDM(INDX) - - PARAMETER (IRMX= 200000) - - CHARACTER*1 CTG,CLON,TAGX(3),CH1(9) - CHARACTER*8 ACID - CHARACTER*16 TAG - - INTEGER ICH1(9) - - COMMON/INPT/TMAXO,TMINO,JAMASS(6),JAWIND(6),RCPTST - COMMON/MASK/GDNH(362,91),GDSH(145,37),GDUS(362,91) - COMMON/ALLDAT/ACID(IRMX),ALAT(IRMX),ALON(IRMX),AALT(IRMX), - $ TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE,ATMP(IRMX),ASPH(IRMX), - $ TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX),ITEVNT(IRMX), - $ IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX),ADIRF(IRMX), - $ IQEVNT(IRMX) - - DATA XMSG/99999./ - DATA CH1 /'Q','R','S','T','U','V','W','X','Y'/ - DATA ICH1 /10, 20, 30, 40, 50, 60, 70, 80, 90 / - - IF((TAG(INDX)(5:5).GE.'U'.AND.TAG(INDX)(5:5).LE.'Z').OR. - $ TAG(INDX)(1:1).EQ.'F'.OR.TAG(INDX)(3:3).EQ.'F') THEN -C SKIP WRITING OF ANY FLAGGED REPORTS OUTSIDE REQUESTED TIME WINDOW - IF(TIME(INDX).LT.TMINO.OR.TIME(INDX).GT.TMAXO) RETURN -C WRITE SDM WINDS W/ VECTOR INCR. U-Z OR WINDS AND/OR TEMPS FLAGGED BY -C THIS PROGRAM; SCALE BASED ON VALUE OF SCALED INCREMENT CHARACTER Q-Z, -C IF INCREMENT NOT AVAIL. SCALE SET TO MSG - SCALE = XMSG - IF(TAG(INDX)(5:5).GE.'Q'.AND.TAG(INDX)(5:5).LE.'Z') THEN - CTG = TAG(INDX)(5:5) - SCALE = 100.0 - DO I=1,9 - IF(CTG.EQ.CH1(I)) THEN - SCALE = ICH1(I) - EXIT - END IF - ENDDO - END IF - - IF(AALT(INDX).LE.11000.) THEN - PRALT = 1013.25 * - $ (((288.15 - (.0065*AALT(INDX)))/288.15)**5.256) - ELSE - PRALT = 226.3 * EXP(1.576106E-4*(11000.-AALT(INDX))) - END IF - - QTIME = MOD(TIME(INDX),2400.) - QLON = ALON(INDX) - CLON = 'W' - IF(NINT(QLON).GT.180) THEN - QLON = (360. - QLON) - CLON = 'E' - END IF - DO M = 1,3,1 - TAGX(M) = TAG(INDX)(M:M) - IF(TAG(INDX)(M:M).EQ.'-'.OR.TAG(INDX)(M:M).EQ.'x') - $ TAGX(M) = ' ' - END DO - WRITE(52,25) ACID(INDX),ALAT(INDX),QLON,CLON,NINT(QTIME), - $ NINT(PRALT),ATMP(INDX),ASPH(INDX),NINT(ADIR(INDX)),ASPD(INDX), - $ NINT(SCALE),TAGX(3),TAGX(1) - 25 FORMAT(A8,2X,F6.2,1X,F6.2,A1,2(2X,I4),2(1X,F5.1),3X,I3,1X,F5.1,2X, - $ I3,2X,2(3X,A1)) - END IF - - RETURN - - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: RPACKR PREPARES OBS. FOR PACKING -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2002-05-07 -C -C ABSTRACT: PREPARES OBSERVATIONS FOR FINAL PACKING TO OUTPUT FILE. -C FINAL CHECK TO REMOVE DUPLICATES, FINAL ASSIGNMENT OF TEMPERATURE, -C SPECIFIC HUMIDITY AND WIND QUALITY MARKERS (IF APPLICABLE) AND -C ACCUMULATION OF NEW SUPEROBS IN HOLDING ARRAYS (IF APPLICABLE). -C -C PROGRAM HISTORY LOG: -C 2002-05-07 D. A. KEYSER -- ORIGINAL AUTHOR (ADAPTED FROM SUBROUTINE -C IN EXISTING PROGRAM "PREPOBS_PREPACQC") -C -C USAGE: CALL RPACKR(INDX) -C INPUT ARGUMENT LIST: -C INDX - POINTER TO POSITION IN ORIGINAL ACARS ARRAY -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C REMARKS: CALLED BY MAIN PROGRAM. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - - SUBROUTINE RPACKR(INDX) - - PARAMETER (IRMX= 200000, ISMX= 4000) - PARAMETER (ISUP= 2000) - - LOGICAL EWRITE,EWRITE_7 - - CHARACTER*4 SSMARK - CHARACTER*8 ACID,SAID - CHARACTER*16 TAG - - INTEGER IDATA(1608) - - REAL ORIGTM(10),RDATA(1608) - - COMMON/INPT/TMAXO,TMINO,JAMASS(6),JAWIND(6),RCPTST - COMMON/OUTPUT/KNTOUT(2) - COMMON/STWRIT/EWRITE,EWRITE_7,IWRITE - COMMON/SUMDAT/SAID(ISMX),SLAT(ISMX),SLON(ISMX),SHGT(ISMX), - $ STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX),SSPH(ISMX), - $ KBAD(ISMX),NUMORG,SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX) - COMMON/ALLDAT/ACID(IRMX),ALAT(IRMX),ALON(IRMX),AALT(IRMX), - $ TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE,ATMP(IRMX),ASPH(IRMX), - $ TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX),ITEVNT(IRMX), - $ IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX),ADIRF(IRMX), - $ IQEVNT(IRMX) - COMMON/SUPOBS/SSLAT(ISUP),SSLON(ISUP),SSTIM(ISUP),SSHGT(ISUP), - $ SSTMP(ISUP),SSSPH(ISUP),SSDIR(ISUP),SSSPD(ISUP),SSHGTF(ISUP), - $ SSTMPF(ISUP),SSDIRF(ISUP),SSSPDF(ISUP),SSMARK(ISUP) - - EQUIVALENCE (IDATA,RDATA) - - DATA IMSG/99999/ - -C INVENTORY INCREMENTS - CALL ACCOUNT(INDX) - IF(TAG(INDX)(4:4).EQ.'D') THEN -C SKIP REPACKING OF ORIGINAL REPORT IF IT IS INDEED A DUPLICATE REPORT - PRINT 9026, INDX,ACID(INDX),ALAT(INDX),ALON(INDX), - $ TIME(INDX),TAG(INDX)(1:3),TAG(INDX)(4:16) - 9026 FORMAT(/' ##########: RPACKR; DUPLICATE REMOVED AT BEG OF SUBR..', - $ I5,2X,A8,2(2X,F6.2),1X,F5.0,2X,A3,1X,A13/) - KNTINI(INDX) = IMSG - GO TO 1 - END IF -C SKIP REPACKING OF ORIGINAL REPORT IF IT IS OUTSIDE REQ. TIME WINDOW - IF(TIME(INDX).LT.TMINO.OR.TIME(INDX).GT.TMAXO) THEN -C SET POS.1 OF TAG TO 'D' TO REMOVE FROM FINAL LISTING OF ORIG. REPORTS - TAG(INDX)(4:4) = 'D' -CCCCC PRINT 9002, INDX,ACID(INDX),ALAT(INDX),ALON(INDX), -CCCCC$ TIME(INDX),TAG(INDX)(1:3),TAG(INDX)(4:16) -C9002 FORMAT(/' ##########: RPACKR; RPTS OUTSIDE TIME WINDOW SKIPPED..', -CCCCC$ I5,2X,A8,2(2X,F6.2),1X,F5.0,2X,A3,1X,A13/) - KNTINI(INDX) = IMSG - GO TO 1 - END IF -C NOW, MAKE FINAL ASSIGNMENT OF TEMPERATURE, SPECIFIC HUMIDITY AND WIND -C Q. MARKS (IF APPL.) - IF(TAG(INDX)(13:13).GT.'5') THEN - IF(TAG(INDX)(10:10).EQ.'7') THEN - IF(EWRITE) PRINT 9095, INDX,ACID(INDX),ALAT(INDX), - $ ALON(INDX),TIME(INDX),TAG(INDX)(1:3),TAG(INDX)(4:16) - 9095 FORMAT(/' #EVENT 6: RPACKR; ACARS BANKING?, TEMP QM. Q', - $ I5,2X,A8,2(2X,F6.2),1X,F5.0,2X,A3,1X,A13/) - TAG(INDX)(1:1) = 'Q' - TAG(INDX)(13:13) = '5' - ITEVNT(INDX) = 6 - ELSE IF(TAG(INDX)(13:13).GT.'6') THEN -C IF "GOOD" REPORT, TEMP Q.M. IS 'A' - IF(EWRITE_7) PRINT 9090, INDX,ACID(INDX),ALAT(INDX), - $ ALON(INDX),TIME(INDX),TAG(INDX)(1:3),TAG(INDX)(4:16) - 9090 FORMAT(' #EVENT 7: RPACKR; "GOOD" ACARS, TEMP Q.M. A', - $ I5,2X,A8,2(2X,F6.2),1X,F5.0,2X,A3,1X,A13) - TAG(INDX)(1:1) = 'A' - TAG(INDX)(13:13) = '6' - ITEVNT(INDX) = 7 - END IF - END IF - IF(TAG(INDX)(14:14).GT.'5') THEN - IF(TAG(INDX)(10:10).EQ.'7') THEN - IF(EWRITE) PRINT 7095, INDX,ACID(INDX),ALAT(INDX), - $ ALON(INDX),TIME(INDX),TAG(INDX)(1:3),TAG(INDX)(4:16) - 7095 FORMAT(/' #EVENT 6: RPACKR; ACARS BANKING?, SHUM QM. Q', - $ I5,2X,A8,2(2X,F6.2),1X,F5.0,2X,A3,1X,A13/) - TAG(INDX)(2:2) = 'Q' - TAG(INDX)(14:14) = '5' - IQEVNT(INDX) = 6 - ELSE IF(TAG(INDX)(14:14).GT.'6') THEN -C IF "GOOD" REPORT, SPECIFIC HUMIDITY Q.M. IS 'A' - IF(EWRITE_7) PRINT 7090, INDX,ACID(INDX),ALAT(INDX), - $ ALON(INDX),TIME(INDX),TAG(INDX)(1:3),TAG(INDX)(4:16) - 7090 FORMAT(' #EVENT 7: RPACKR; "GOOD" ACARS, SHUM Q.M. A', - $ I5,2X,A8,2(2X,F6.2),1X,F5.0,2X,A3,1X,A13) - TAG(INDX)(2:2) = 'A' - TAG(INDX)(14:14) = '6' - IQEVNT(INDX) = 7 - END IF - END IF - IF(TAG(INDX)(15:15).GT.'5') THEN - IF(TAG(INDX)(10:10).EQ.'7') THEN - IF(EWRITE) PRINT 8095, INDX,ACID(INDX),ALAT(INDX), - $ ALON(INDX),TIME(INDX),TAG(INDX)(1:3),TAG(INDX)(4:16) - 8095 FORMAT(/' #EVENT 6: RPACKR; ACARS BANKING?, WIND QM. Q', - $ I5,2X,A8,2(2X,F6.2),1X,F5.0,2X,A3,1X,A13/) - TAG(INDX)(3:3) = 'Q' - TAG(INDX)(15:15) = '5' - IWEVNT(INDX) = 6 - ELSE IF(TAG(INDX)(15:15).GT.'6') THEN -C IF "GOOD" ACARS REPORT, WIND Q.M. IS 'A' - IF(EWRITE_7) PRINT 9091, INDX,ACID(INDX),ALAT(INDX), - $ ALON(INDX),TIME(INDX),TAG(INDX)(1:3),TAG(INDX)(4:16) - 9091 FORMAT(' #EVENT 7: RPACKR; "GOOD" ACARS, WIND Q.M. A', - $ I5,2X,A8,2(2X,F6.2),1X,F5.0,2X,A3,1X,A13) - TAG(INDX)(3:3) = 'A' - TAG(INDX)(15:15) = '6' - IWEVNT(INDX) = 7 - END IF - END IF - IF(TAG(INDX)(1:1).EQ.'F'.AND.TAG(INDX)(14:14).GT.'3') THEN -C IF TEMPERATURE IS FLAGGED, THEN SPECIFIC HUMIDITY IS ALWAYS -C ALSO FLAGGED - IF(EWRITE) PRINT 7033, INDX,ACID(INDX),ALAT(INDX), - $ ALON(INDX),TIME(INDX),TAG(INDX)(1:3),TAG(INDX)(4:16) - 7033 FORMAT(/' #EVENT 8: RPACKR; BAD TEMP, SHUM Q.M. SET TO "F"....', - $ I5,2X,A8,2(2X,F6.2),1X,F5.0,2X,A3,1X,A13/) - TAG(INDX)(2:2) = 'F' - TAG(INDX)(14:14) = '3' - IQEVNT(INDX) = 8 - END IF - - 1 CONTINUE - - NPT = 1 - - RETURN - - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: ACCOUNT DOES SIMPLE ACCOUNTING OF REPORTS -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2002-05-07 -C -C ABSTRACT: DOES SIMPLE ACCOUNTING BY LOGGING NUMBER OF REPORTS BY -C SCALED VECTOR INCREMENT. IN ADDITION, LOGS THE NUMBER OF -C SDM KEEPS AND SDM PURGES. THE NUMBER OF BAD TEMPERATURES -C IS ALSO ACCOUNTED FOR HERE. -C -C PROGRAM HISTORY LOG: -C 2002-05-07 D. A. KEYSER -- ORIGINAL AUTHOR (ADAPTED FROM SUBROUTINE -C IN EXISTING PROGRAM "PREPOBS_PREPACQC") -C -C USAGE: CALL ACCOUNT(INDX) -C INPUT ARGUMENT LIST: -C INDX - POINTER TO POSITION IN ORIGINAL ACARS ARRAY -C -C REMARKS: CALLED BY SUBROUTINE 'RPACKR'. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - - SUBROUTINE ACCOUNT(INDX) - - PARAMETER (IRMX= 200000) - - CHARACTER*1 INACMK(11) - CHARACTER*8 ACID - CHARACTER*16 TAG - - COMMON/ACCONT/KISO(11) - COMMON/ALLDAT/ACID(IRMX),ALAT(IRMX),ALON(IRMX),AALT(IRMX), - $ TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE,ATMP(IRMX),ASPH(IRMX), - $ TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX),ITEVNT(IRMX), - $ IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX),ADIRF(IRMX), - $ IQEVNT(IRMX) - COMMON/INPT/TMAXO,TMINO,JAMASS(6),JAWIND(6),RCPTST - - DATA INACMK/'Q','R','S','T','U','V','W','X','Y','Z','N'/ - - IF(TIME(INDX).GE.TMINO.AND.TIME(INDX).LE.TMAXO) THEN - DO M = 1,11 - IF(TAG(INDX)(5:5).EQ.INACMK(M)) THEN - KISO(M) = KISO(M) + 1 - EXIT - END IF - ENDDO - END IF - - RETURN - - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: IDSORT SORTS INPUT AIRCAR REPORTS BY STATION ID -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2002-05-07 -C -C ABSTRACT: USES LOCAL SORT ROUTINE TO SORT ENTIRE ACARS FILE -C BY THE 8-CHARACTER STATION (FLIGHT) IDENTIFICATION. -C -C PROGRAM HISTORY LOG: -C 2002-05-07 D. A. KEYSER -- ORIGINAL AUTHOR (ADAPTED FROM SUBROUTINE -C IN EXISTING PROGRAM "PREPOBS_PREPACQC") -C -C USAGE: CALL IDSORT(NFILE,NEXCLUDE) -C INPUT ARGUMENT LIST: -C NFILE - NUMBER OF OBSERVATIONS TO SORT -C -C OUTPUT ARGUMENT LIST: -C NEXCLUDE - NUMBER OF EXCLUDED REPORTS AT END OF SORT -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C REMARKS: CALLED BY MAIN PROGRAM. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - - SUBROUTINE IDSORT(NFILE,NEXCLUDE) - - PARAMETER (IRMX= 200000) - PARAMETER (ISIZE= 18) - - CHARACTER*8 ACID,AAID(IRMX) - CHARACTER*16 TAG,STAG(IRMX) - CHARACTER*32 CARRAY(IRMX) - - REAL SARRAY(IRMX,ISIZE) - - INTEGER INDR(IRMX) - - COMMON/ALLDAT/ACID(IRMX),ALAT(IRMX),ALON(IRMX),AALT(IRMX), - $ TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE,ATMP(IRMX),ASPH(IRMX), - $ TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX),ITEVNT(IRMX), - $ IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX),ADIRF(IRMX), - $ IQEVNT(IRMX) - COMMON/WORD/ICHTP - - DATA IMSG/99999/ - - NEXCLUDE = 0 -C FILL IN CARRAY FOR SORT ROUTINE - DO J = 1,NFILE - IF(TAG(J)(12:12).EQ.'@') THEN -C EXCLUDED RPTS ARE COUNTED AND WILL BE AT VERY END OF SORT -C (DO THIS BY CHANGING CHARACTER STRING TO: -C '99999' IF CHARACTERS ARE EBCDIC, -C '~~~~~' IF CHARACTERS ARE ASCII) -C 1ST ORDER - "99999" or "~~~~~"//STATION ID -C 2ND ORDER - TIME (INCREASING) -C 3RD ORDER - LONGITUDE (WEST, INCREASING) -C 4TH ORDER - LATITUDE (SOUTH TO NORTH) -C 5TH ORDER - ALTITUDE (INCREASING) - NEXCLUDE = NEXCLUDE + 1 - CARRAY(J)(1:5) = '99999' - IF(ICHTP.EQ.0) CARRAY(J)(1:5) = '~~~~~' - CARRAY(J)( 6:12) = ACID(J)(1:7) - WRITE(CARRAY(J)(13:16),'(I4.4)') NINT(TIME(J)) - WRITE(CARRAY(J)(17:21),'(I5.5)') NINT(ALON(J)*100.) - WRITE(CARRAY(J)(22:26),'(I5.5)') NINT(ALAT(J)*100.) + 9000 - WRITE(CARRAY(J)(27:32),'(I6.6)') NINT(AALT(J)) - ELSE -C GOOD REPORTS WILL BE AT BEGINNING OF SORT -C 1ST ORDER - STATION ID -C 2ND ORDER - LONGITUDE (WEST, INCREASING) -C 3RD ORDER - TIME (INCREASING) -C 4TH ORDER - LATITUDE (SOUTH TO NORTH) -C 5TH ORDER - ALTITUDE (INCREASING) - CARRAY(J)(1:7) = ACID(J)(1:7) - WRITE(CARRAY(J)(8:12),'(I5.5)') NINT(ALON(J)*100.) - WRITE(CARRAY(J)(13:16),'(I4.4)') NINT(TIME(J)) - WRITE(CARRAY(J)(17:21),'(I5.5)') NINT(ALAT(J)*100.) + 9000 - WRITE(CARRAY(J)(22:27),'(I6.6)') NINT(AALT(J)) - CARRAY(J)(28:32) = '00000' - END IF -C TRANSFER ORIGINAL DATA TO TEMPORARY ARRAYS TO HOLD FOR RE-ARRANGING - AAID(J) = ACID(J) - SARRAY(J,1) = ALAT(J) - SARRAY(J,2) = ALON(J) - SARRAY(J,3) = AALT(J) - SARRAY(J,4) = TIME(J) - SARRAY(J,5) = ATMP(J) - SARRAY(J,6) = ADIR(J) - SARRAY(J,7) = ASPD(J) - SARRAY(J,8) = REAL(INTP(J)) - SARRAY(J,9) = REAL(IRTM(J)) - SARRAY(J,10) = REAL(KNTINI(J)) - SARRAY(J,11) = REAL(ITEVNT(J)) - SARRAY(J,12) = REAL(IWEVNT(J)) - SARRAY(J,13) = AALTF(J) - SARRAY(J,14) = ADIRF(J) - SARRAY(J,15) = ASPDF(J) - SARRAY(J,16) = ATMPF(J) - SARRAY(J,17) = ASPH(J) - SARRAY(J,18) = REAL(IQEVNT(J)) - STAG(J) = TAG(J) -CCCCC LON = IMSG -CCCCC PRINT 1927, AAID(J),NINT(TIME(J)),ALON(J),CARRAY(J) -C1927 FORMAT(' ',A8,6X,I4,3X,F6.2,A32) -CCCCC PRINT 100, J,AAID(J),SARRAY(J,1),SARRAY(J,2),SARRAY(J,4), -CCCCC$ SARRAY(J,3),SARRAY(J,5),SARRAY(J,17),SARRAY(J,6),SARRAY(J,7), -CCCCC$ STAG(J)(1:3) -CC100 FORMAT(' ', I7,2X,A8,2X,2(3X,F6.2),4X,F5.0,3X,F6.0,2(4X,F5.1), -CCCCC$ 5X,F4.0,5X,F4.1,1X,A3) - ENDDO -C CALL SORT ROUTINE- PUTS POINTERS INTO IPOINT ARRAY/DOES NOT REARRANGE - IF(NFILE.GT.0) CALL INDEXC(NFILE,CARRAY,INDR) - DO I = 1,NFILE - J = INDR(I) -C WRITE SORTED REPORTS BACK INTO ORIGINAL ARRAYS - ACID(I) = AAID(J) - ALAT(I) = SARRAY(J,1) - ALON(I) = SARRAY(J,2) - AALT(I) = SARRAY(J,3) - TIME(I) = SARRAY(J,4) - ATMP(I) = SARRAY(J,5) - ADIR(I) = SARRAY(J,6) - ASPD(I) = SARRAY(J,7) - INTP(I) = NINT(SARRAY(J,8)) - IRTM(I) = NINT(SARRAY(J,9)) - KNTINI(I) = NINT(SARRAY(J,10)) - ITEVNT(I) = NINT(SARRAY(J,11)) - IWEVNT(I) = NINT(SARRAY(J,12)) - AALTF(I) = SARRAY(J,13) - ADIRF(I) = SARRAY(J,14) - ASPDF(I) = SARRAY(J,15) - ATMPF(I) = SARRAY(J,16) - ASPH(I) = SARRAY(J,17) - IQEVNT(I) = NINT(SARRAY(J,18)) - TAG(I) = STAG(J) - ENDDO - - RETURN - - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: INDEXC GENERAL SORT ROUTINE FOR CHARACTER ARRAY -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1999-08-23 -C -C ABSTRACT: USES EFFICIENT SORT ALGORITHM TO PRODUCE INDEX SORT LIST -C FOR A 32-CHARACTER ARRAY. DOES NOT REARRANGE THE FILE. -C -C PROGRAM HISTORY LOG: -C 1993-06-05 R KISTLER --- FORTRAN VERSION OF C-PROGRAM -C 1993-07-15 P. JULIAN ---- MODIFIED TO SORT 12-CHARACTER ARRAY -C 1994-08-25 D. A. KEYSER - MODIFIED TO SORT 16-CHARACTER ARRAY -C 1995-05-30 D. A. KEYSER - TESTS FOR < 2 ELEMENTS IN SORT LIST, -C IF SO RETURNS WITHOUT SORTING (BUT FILLS INDX ARRAY) -C 1999-08-23 D. A. KEYSER - EXPANDED CHARACTER ARRAY FROM 16 TO 32 -C BYTES (ALLOWS HIGHER ORDERS TO BE INCLUDED IN SORT) -C -C USAGE: CALL INDEXC(N,CARRIN,INDX) -C INPUT ARGUMENT LIST: -C N - SIZE OF ARRAY TO BE SORTED -C CARRIN - 32-CHARACTER ARRAY TO BE SORTED -C -C OUTPUT ARGUMENT LIST: -C INDX - ARRAY OF POINTERS GIVING SORT ORDER OF CARRIN IN -C - ASCENDING ORDER {E.G., CARRIN(INDX(I)) IS SORTED IN -C - ASCENDING ORDER FOR ORIGINAL I = 1, ... ,N} -C -C REMARKS: CALLED BY SUBROUTINES 'TRKCHK' AND 'IDSORT'. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - - SUBROUTINE INDEXC(N,CARRIN,INDX) - - CHARACTER*32 CARRIN(N),CC - - INTEGER INDX(N) - - DO J = 1,N - INDX(J) = J - ENDDO - -C MUST BE > 1 ELEMENT IN SORT LIST, ELSE RETURN - IF(N.LE.1) RETURN - - L = N/2 + 1 - IR = N - - 33 CONTINUE - - IF(L.GT.1) THEN - L = L - 1 - INDXT = INDX(L) - CC = CARRIN(INDXT) - ELSE - INDXT = INDX(IR) - CC = CARRIN(INDXT) - INDX(IR) = INDX(1) - IR = IR - 1 - IF(IR.EQ.1) THEN - INDX(1) = INDXT - RETURN - END IF - END IF - I = L - J = L * 2 - - 30 CONTINUE - - IF(J.LE.IR) THEN - IF(J.LT.IR) THEN - IF(CARRIN(INDX(J)).LT.CARRIN(INDX(J+1))) J = J + 1 - END IF - IF(CC.LT.CARRIN(INDX(J))) THEN - INDX(I) = INDX(J) - I = J - J = J + I - ELSE - J = IR + 1 - ENDIF - END IF - IF(J.LE.IR) GO TO 30 - INDX(I) = INDXT - GO TO 33 - - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: INDEXF GENERAL SORT ROUTINE FOR INTEGER ARRAY -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1995-05-30 -C -C ABSTRACT: USES EFFICIENT SORT ALGORITHM TO PRODUCE INDEX SORT LIST -C FOR AN INTEGER ARRAY. DOES NOT REARRANGE THE FILE. -C -C PROGRAM HISTORY LOG: -C 1993-06-05 R KISTLER -- FORTRAN VERSION OF C-PROGRAM -C 1995-05-30 D. A. KEYSER - TESTS FOR < 2 ELEMENTS IN SORT LIST, -C IF SO RETURNS WITHOUT SORTING (BUT FILLS INDX ARRAY) -C -C USAGE: CALL INDEXF(N,IARRIN,INDX) -C INPUT ARGUMENT LIST: -C N - SIZE OF ARRAY TO BE SORTED -C IARRIN - INTEGER ARRAY TO BE SORTED -C -C OUTPUT ARGUMENT LIST: -C INDX - ARRAY OF POINTERS GIVING SORT ORDER OF IARRIN IN -C - ASCENDING ORDER {E.G., IARRIN(INDX(I)) IS SORTED IN -C - ASCENDING ORDER FOR ORIGINAL I = 1, ... ,N} -C -C REMARKS: CALLED BY SUBROUTINES 'TRKCHK' AND 'OBUFR'. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - - SUBROUTINE INDEXF(N,IARRIN,INDX) - - INTEGER INDX(N),IARRIN(N) - - DO J = 1,N - INDX(J) = J - ENDDO - -C MUST BE > 1 ELEMENT IN SORT LIST, ELSE RETURN - IF(N.LE.1) RETURN - L = N/2 + 1 - IR = N - - 33 CONTINUE - - IF(L.GT.1) THEN - L = L - 1 - INDXT = INDX(L) - II = IARRIN(INDXT) - ELSE - INDXT = INDX(IR) - II = IARRIN(INDXT) - INDX(IR) = INDX(1) - IR = IR - 1 - IF(IR.EQ.1) THEN - INDX(1) = INDXT - RETURN - END IF - END IF - I = L - J = L * 2 - - 30 CONTINUE - - IF(J.LE.IR) THEN - IF(J.LT.IR) THEN - IF(IARRIN(INDX(J)).LT.IARRIN(INDX(J+1))) J = J + 1 - END IF - IF(II.LT.IARRIN(INDX(J))) THEN - INDX(I) = INDX(J) - I = J - J = J + I - ELSE - J = IR + 1 - END IF - END IF - IF(J.LE.IR) GO TO 30 - INDX(I) = INDXT - GO TO 33 - - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: DBUFR GETS THE DATE FROM A PREPBUFR FILE -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2009-08-03 -C -C ABSTRACT: READS THRU SUCCESSIVE BUFR MESSAGES UNTIL THE BUFR TABLE -C A ENTRY "AIRCAR" (ACARS AIRCRAFT REPORTS) IS FOUND IN A PREPBUFR -C FILE. RETURNS THE DATE OF THIS MESSAGE TO THE CALLING PROGRAM. -C -C PROGRAM HISTORY LOG: -C 2002-05-07 D. A. KEYSER -- ORIGINAL AUTHOR (ADAPTED FROM SUBROUTINE -C IN EXISTING PROGRAM "PREPOBS_PREPACQC") -C 2009-08-03 D. A. KEYSER -- WILL NO LONGER TRY TO PULL OUT RECEIPT -C TIME (RCT) FROM PRE-DECEMBER 2008 VERSIONS OF PREPBUFR -C FILE WHICH DO YET INCLUDE IT IN ACARS REPORT HEADER (DONE -C SO THAT CFSRR RUNS WILL NOT FAIL) -C -C USAGE: CALL DBUFR(IDATEP) -C OUTPUT ARGUMENT LIST: -C IDATEP - DATE FROM FIRST TABLE A "AIRCAR" MESSAGE (YYYYMMDDHH) -C -C INPUT FILES: -C UNIT 14 - PREPBUFR FILE CONTAINING ALL DATA -C -C OUTPUT FILES: -C UNIT06 - PRINTOUT -C -C REMARKS: CALLED BY MAIN PROGRAM. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - - SUBROUTINE DBUFR(IDATEP) - - CHARACTER*8 SUBSET - CHARACTER*1 CTAB - - COMMON/NEWTABLE/IPRSLEVLA - - CALL DATELEN(10) - - CALL OPENBF(14,'IN',14) - -C Check to see if the post 12/2008 version of the PREPBUFR mnemonic -C table which includes Table D mnemonic "PRSLEVLA" is being used here -C -------------------------------------------------------------------- - - CALL STATUS(14,LUN,IDUMMY1,IDUMMY2) - CALL NEMTAB(LUN,'PRSLEVLA',IDUMMY1,CTAB,IRET) - IPRSLEVLA = 0 - IF(IRET.GT.0.AND.CTAB.EQ.'D') IPRSLEVLA = 1 - - 10 CONTINUE - - CALL READMG(14,SUBSET,IDATEP,IRET) - IF(IRET.NE.0) GO TO 999 - IF(SUBSET.NE.'AIRCAR ') GO TO 10 -cppppp - print * ,' ' - print *, 'First AIRCAR message found ... ' - print *,'PREPBUFR File Sec. 1 message date (IDATEP) = ',IDATEP -cppppp - IF(IDATEP.LT.1000000000) THEN - -C If 2-digit year returned in IDATEP, must use "windowing" technique -C to create a 4-digit year - -C IMPORTANT: IF DATELEN(10) IS CALLED, THE DATE HERE SHOULD ALWAYS -C CONTAIN A 4-DIGIT YEAR, EVEN IF INPUT FILE IS NOT -C Y2K COMPLIANT (BUFRLIB DOES THE WINDOWING HERE) - - PRINT *, '##ACARSQC - THE FOLLOWING SHOULD NEVER HAPPEN!!!!!' - PRINT *, '##ACARSQC - 2-DIGIT YEAR IN IDATEP RETURNED FROM ', - $ 'READMG (IDATEP IS: ',IDATEP,') - USE WINDOWING TECHNIQUE ', - $ 'TO OBTAIN 4-DIGIT YEAR' - IF(IDATEP/1000000.GT.20) THEN - IDATEP = 1900000000 + IDATEP - ELSE - IDATEP = 2000000000 + IDATEP - ENDIF - PRINT *, '##ACARSQC - CORRECTED IDATEP WITH 4-DIGIT YEAR, ', - $ 'IDATEP NOW IS: ',IDATEP - ENDIF - - RETURN - -C----------------------------------------------------------------------- - 999 CONTINUE -C PREPBUFR DATA SET CONTAINS NO "AIRCAR" TABLE A MSGS -- STOP 4 !!! - PRINT 14 - 14 FORMAT(/' PREPBUFR DATA SET CONTAINS NO "AIRCAR" TABLE A ', - $ 'MESSAGES - STOP 4'/) - CALL CLOSBF(14) - CALL W3TAGE('PREPOBS_ACARSQC') - CALL ERREXIT(4) -C----------------------------------------------------------------------- - - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: IBUFR DECODES ACARS OBS. FROM PREPBUFR FILE -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2009-08-03 -C -C ABSTRACT: DECODES AN ACARS AIRCRAFT OBSERVATION FROM A TABLE A -C ENTRY "AIRCAR" MESSAGE IN A PREPBUFR FILE FOR EACH CALL. IF ALL -C SUBSETS HAVE BEEN DECODED IN A MESSAGE THE NEXT TABLE A ENTRY -C "AIRCAR" MESSAGE IN READ IN AND DECODED. A RETURN 1 OCCURS WHEN -C ALL TABLE A ENTRY "AIRCAR" MESSAGES HAVE BEEN PROCESSED. SPECIAL -C LOGIC COMBINES THE SEPARATE WIND AND MASS REPORT "PIECES" INTO A -C SINGLE OBSERVATION PRIOR TO RETURN TO CALLING PROGRAM. -C -C PROGRAM HISTORY LOG: -C 2002-05-07 D. A. KEYSER -- ORIGINAL AUTHOR (ADAPTED FROM SUBROUTINE -C IN EXISTING PROGRAM "PREPOBS_PREPACQC") -C 2008-09-25 D. A. KEYSER -- IN RESPONSE TO CHANGE FROM SINGLE LEVEL -C TO DELAYED REPLICATION FOR "AIRCAR" REPORT LEVEL DATA NOW -C IN PREPBUFR FILE (IN PREPARATION FOR NRL AIRCRAFT QC -C PROGRAM WHICH WILL REPLACE THIS PROGRAM AND CAN GENERATE -C AIRCRAFT "PROFILES"), RECEIPT TIME (RCT) (WHICH IS NOW -C PART OF LEVEL DATA) IS NO LONGER RETRIEVED IN SAME CALL -C TO UFBINT AS REMAINING SINGLE-LEVEL HEADER DATA (TO AVOID -C BUFRLIB ERROR) (ALL LEVEL DATA HERE STILL HAS JUST ONE -C REPLICATION AT THIS POINT) -C 2009-08-03 D. A. KEYSER -- WILL NO LONGER TRY TO PULL OUT RECEIPT -C TIME (RCT) FROM PRE-DECEMBER 2008 VERSIONS OF PREPBUFR -C FILE WHICH DO YET INCLUDE IT IN ACARS REPORT HEADER (DONE -C SO THAT CFSRR RUNS WILL NOT FAIL) -C -C USAGE: CALL IBUFR(ALTF,DIRF,SPDF,TMPF,*) -C INPUT ARGUMENT LIST: -C ALTF - INITIAL FORECAST VALUE FOR PRESSURE ALTITUDE, MISSING -C DIRF - INITIAL FORECAST VALUE FOR WIND DIRECTION, MISSING -C SPDF - INITIAL FORECAST VALUE FOR WIND SPEED, MISSING -C TMPF - INITIAL FORECAST VALUE FOR TEMPERATURE, MISSING -C -C OUTPUT ARGUMENT LIST: -C ALTF - FORECAST VALUE FOR PRESSURE ALTITUDE (METERS) -C DIRF - FORECAST VALUE FOR WIND DIRECTION (DEGREES) -C SPDF - FORECAST VALUE FOR WIND SPEED (M/S) -C TMPF - FORECAST VALUE FOR TEMPERATURE (DEG. C) -C -C INPUT FILES: -C UNIT 14 - PREPBUFR FILE CONTAINING ALL DATA -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C REMARKS: CALLED BY MAIN PROGRAM. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - - SUBROUTINE IBUFR(ALTF,DIRF,SPDF,TMPF,*) - - CHARACTER*1 CIQMMK(10),CF,PF,CINCR - CHARACTER*8 SUBSET,IDENT - CHARACTER*40 HEADR,OBLVL,FCLVL - - REAL(8) HDR6_8,OBS_8(10),HDR_8(9),FST_8(4),RCT_8 - REAL ACAT(9) - - COMMON/QUALITY/ITQM,IQQM,IWQM - COMMON/CBUFR/IDENT,IRCTME,RDATA(1608),KIX,CINCR,CF,PF - COMMON/STDATE/IDATE(5) - COMMON/NEWTABLE/IPRSLEVLA - - EQUIVALENCE (IDENT,HDR6_8),(IRPTYP,RDATA(8)) - - DATA CIQMMK/'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z'/ - DATA ACAT/10.5,20.5,30.5,40.5,50.5,60.5,70.5,80.5,90.5/ - DATA HEADR/'YOB XOB NUL DHR TSB SID ITP TYP SQN '/ - DATA OBLVL/'ZOB TOB DDO FFO TQM WQM UOB VOB QOB QQM '/ - DATA FCLVL/'UFC VFC TFC ZFC '/ - DATA XMSG/99999./,IMSG/99999/,IFLAG/0/,ILOOP/1/,KI/0/,SQNL/0/ - DATA BMISS /10E10/ - -C ON INPUT: IFLAG =0 - 1ST "PIECE" OF NEXT OBS. HAS NOT YET BEEN DECODED -C IFLAG =1 - 1ST "PIECE" OF NEXT OBS. DECODED IN PREVIOUS CALL - IF(IFLAG.EQ.1) GO TO 45 - RDATA = XMSG - - 30 CONTINUE - - CALL READSB(14,IRET) - IF(IRET.NE.0) THEN - 20 CONTINUE - CALL READMG(14,SUBSET,IDATEP,IRET) - IF(IRET.NE.0) THEN -C NON-ZERO IRET IN READMG MEANS ALL BUFR MESSAGES IN FILE HAVE BEEN READ -C FILE WILL BE CLOSED - PRINT 101 - 101 FORMAT(/5X,'===> PREPBUFR DATA SET IN UNIT 14 SUCCESSFULLY', - $ ' CLOSED FROM INITIAL READ OF ACARS OBS.') - CALL CLOSBF(14) - RETURN 1 - END IF - IF(SUBSET.NE.'AIRCAR ') GO TO 20 - GO TO 30 - END IF - - CALL UFBINT(14,HDR_8, 9,1,N1LEV,HEADR) - CALL UFBINT(14,OBS_8,10,1,NLEV ,OBLVL) - CALL UFBINT(14,FST_8, 4,1,NLEV2,FCLVL) - IF(IPRSLEVLA.EQ.1) THEN - -C If the post 12/2008 version of the PREPBUFR mnemonic table which -C includes Table D mnemonic "PRSLEVLA" is being used here, then 'RCT' -C is present in the ACARS report header -C -------------------------------------------------------------------- - - CALL UFBINT(14,RCT_8, 1,1,N3LEV,'RCT') - ELSE - -C .... otherwise, 'RCT' is not present in the ACARS report header -C ---------------------------------------------------------- - - RCT_8 = BMISS - N3LEV = 1 ! set so that if test below will not be satisfied - END IF - IF(N1LEV.NE.NLEV.OR.NLEV2.NE.NLEV.OR.NLEV.NE.1.OR.N3LEV.NE.NLEV) - $ GO TO 999 - KI = NINT(HDR_8(8))/100 - IF(ILOOP.EQ.2) THEN -C COMPARE RPT SEQ. NUMBERS IN HEADERS OF TWO "PIECES" DECODED IN THIS -C CALL - IF THEY AGREE THEN BOTH ARE PART OF SAME OBS., OTHERWISE THIS -C OBS. CONSISTS OF ONLY ONE "PIECE" AND IT IS RETURNED TO CALLING PGM -C (IFLAG=1 ON RETURN INDICATES NEXT OBS. 1ST "PIECE" HAS BEEN DECODED) - IF(HDR_8(9).EQ.SQNL) GO TO 40 - ILOOP = 1 - IFLAG = 1 - RETURN - END IF - - 45 CONTINUE - -C CONSTRUCT OBSERVATION HEADER(ONLY DONE FOR 1ST DECODED REPORT "PIECE") - CF = '-' - PF = '-' - CINCR = 'N' - RDATA(1) = MIN(99999._8,HDR_8(1)) - RDATA(2) = MIN(99999._8,(360._8-HDR_8(2))) -C IRCTME = MIN(IMSG,NINT(HDR_8(3)*100.)) - IRCTME = NINT(MIN(9999._8,HDR_8(3)*100.)) -C NDT = MIN(IMSG,NINT(HDR_8(4)*100.)) - NDT = NINT(MIN(9999._8,HDR_8(4)*100.)) - RDATA(4) = NDT + (IDATE(4) * 100) - RDATA(4) = MOD(NINT(RDATA(4)),2400) - IF(NINT(RDATA(4)).LT.0) RDATA(4) = NINT(2400. + RDATA(4)) - if (hdr_8(5) .lt. xmsg) then - IF(NINT(HDR_8(5)).EQ.1) CF = 'C' - IF(NINT(HDR_8(5)).EQ.2) PF = '7' - endif -C IRPTYP = MIN(99,NINT(HDR_8(7))) - IRPTYP = NINT(MIN(99._8,HDR_8(7))) - HDR6_8 = HDR_8(6) - KIX = HDR_8(8) - - 40 CONTINUE - - IF(KI.EQ.2) THEN -C CONSTRUCT WIND PART OF OBSERVATION FROM DECODED WIND REPORT "PIECE" - -C CINCR HOLDS SCALED VECTOR WIND INCREMENT MARKER (IF APPLICABLE) -C OBTAINED FROM THE CALCULATED VECTOR INCREMENT (NOTE: IF REPORT TIME -C IS > 3.33-HOURS FROM CYCLE TIME THE DEFAULT SCALE = 'N' IS STORED) - IF(MAX(FST_8(1),FST_8(2)).LT.XMSG) THEN - IF(MAX(OBS_8(7),OBS_8(8)).LT.XMSG.AND.(ABS(RDATA(4)- - $ REAL(IDATE(4)*100.)).LE.333..OR.(RDATA(4)- - $ REAL(IDATE(4)*100.)).GE.2067.)) THEN - VDIF = SQRT((FST_8(1)-OBS_8(7))**2 - $ +(FST_8(2)-OBS_8(8))**2)*1.9425 - CINCR = 'Z' - DO J = 1,9 - IF(VDIF.LT.ACAT(J)) THEN - CINCR = CIQMMK(J) - EXIT - END IF - ENDDO - END IF -C CONSTRUCT FCST WIND DIR. (DEG) & SPD (M/S) FROM FCST WIND COMPONENTS - ISUNIT = 2 - UFC = FST_8(1) - VFC = FST_8(2) - CALL CMDDFF(ISUNIT,UFC,VFC,DIRF,SPDF) - DIRF = NINT(DIRF) - END IF -C RDATA(43) HOLDS PRESSURE ALTITUDE (METERS) - RDATA(43) = MIN(99999._8,OBS_8(1)) -C ALTF HOLDS FORECAST PRESSURE ALTITUDE (METERS) - IF(FST_8(4).LT.XMSG) ALTF = NINT(FST_8(4)) -C RDATA(46) HOLDS WIND DIRECTION (DEGREES) - RDATA(46) = MIN(99999._8,OBS_8(3)) -C RDATA(46) HOLDS WIND SPEED (M/S) - SPEED = XMSG - IF(MAX(OBS_8(7),OBS_8(8)).LT.XMSG) - $ SPEED = SQRT(OBS_8(7)**2 + OBS_8(8)**2) - RDATA(47) = MIN(XMSG,SPEED) -C IWQM HOLDS WIND QUALITY MARKER (NUMERIC) - IWQM = MIN(99._8,OBS_8(6)) - ELSE -C CONSTRUCT MASS PART OF OBSERVATION FROM DECODED MASS REPORT "PIECE" - -C RDATA(43) HOLDS PRESSURE ALTITUDE (METERS) - RDATA(43) = MIN(99999._8,OBS_8(1)) -C ALTF HOLDS FORECAST PRESSURE ALTITUDE (METERS) - IF(FST_8(4).LT.XMSG) ALTF = NINT(FST_8(4)) -C RDATA(44) HOLDS TEMPERATURE (DEGREES CELSIUS) - RDATA(44) = MIN(99999._8,OBS_8(2)) -C TMPF HOLDS FORECAST TEMPERATURE (DEGREES CELSIUS X 10) - IF(FST_8(3).LT.XMSG) TMPF = FST_8(3) -C ITQM HOLDS TEMPERATURE QUALITY MARKER (NUMERIC) - ITQM = MIN(99._8,OBS_8(5)) -C RDATA(45) HOLDS SPECIFIC HUMIDITY (G/KG) - RDATA(45) = MIN(99999._8,OBS_8(9)*.001) -C IQQM HOLDS SPECIFIC HUMIDITY QUALITY MARKER (NUMERIC) - IQQM = MIN(99._8,OBS_8(10)) - END IF - - IF(ILOOP.EQ.1) THEN -C IF ONLY ONE "PIECE" HAS BEEN DECODED IN THIS CALL, DECODE NEXT "PIECE" -C TO DETERMINE IF IT IS THE SECOND "PIECE" OF THE ACARS OBSERVATION -C (SAVE RPT SEQ. # OF 1ST "PIECE" FOR LATER COMPARISON AGAINST SECOND) - SQNL = HDR_8(9) - ILOOP = 2 - GO TO 30 - END IF - -C IF TWO "PIECES" HAVE BEEN DECODED IN THIS CALL, READY TO RETURN -C COMPLETE ACARS OBSERVATION TO CALLING PROGRAM - ILOOP = 1 - IFLAG = 0 - - RETURN - -C----------------------------------------------------------------------- - 999 CONTINUE -C THE NUMBER OF DECODED LEVELS IS NOT 1!! -- STOP 70 - PRINT 217 - 217 FORMAT(/' THE NUMBER OF DECODED LEVELS FOR A REPORT IS NOT 1 -- ', - $ 'STOP 70'/) - CALL W3TAGE('PREPOBS_ACARSQC') - CALL ERREXIT(70) -C----------------------------------------------------------------------- - - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: OBUFR WRITES ACARS RPTS TO PREPBUFR FILE -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2002-05-07 -C -C ABSTRACT: RESORTS ALL OBS. IN HOLDING ARRAYS BACK TO ORIGINAL ORDER, -C THEN FOR ALL TABLE A ENTRY MESSAGES EXCEPT "AIRCAR" DOES A -C STRAIGHT COPY OF EACH SUBSET (REPORT) FROM THE INPUT PREPBUFR -C FILE TO THE OUTPUT PREPBUFR FILE. FOR TABLE A ENTRY "AIRCAR" -C MESSAGES, ALSO COPIES ALL SUBSETS (RPTS) THAT ARE NOT DUPLICATES -C OR NOT OUTSIDE USER-SPECIFIED TIME WINDOW. HOWEVER, FROM RESORTED -C OBS. HOLDING ARRAYS, DETERMINES IF AN "EVENT" HAS OCCURRED (I.E., -C A CHANGED TEMPERATURE, SPECIFIC HUMIDITY OR WIND QUALITY MARKER). -C IF SO, PUSHES DOWN TEMPERATURE, SPECIFIC HUMIDITY OR WIND STACKED -C EVENTS AND RECORDS THIS EVENT (REASON CODE) ALONG WITH THE NEW -C QUALITY MARKER PRIOR TO WRITING THE SUBSET TO THE OUTPUT PREPBUFR -C FILE. WILL ALSO UPDATE LAT/LON IF IT WAS CHANGED DUE TO A WAYPOINT -C ERROR (THIS IS NOT A STACKED EVENT, HOWEVER). -C -C PROGRAM HISTORY LOG: -C 2002-05-07 D. A. KEYSER -- ORIGINAL AUTHOR (ADAPTED FROM SUBROUTINE -C IN EXISTING PROGRAM "PREPOBS_PREPACQC") -C -C USAGE: CALL OBUFR(KOUNT) -C INPUT ARGUMENT LIST: -C KOUNT - THE NUMBER OF ACARS OBSERVATIONS IN HOLDING ARRAYS -C -C INPUT FILES: -C UNIT 14 - PREPBUFR FILE CONTAINING ALL DATA -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C UNIT 61 - PREPBUFR FILE CONTAINING ALL DATA (NOW WITH ACARS QC) -C -C REMARKS: CALLED BY MAIN PROGRAM. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - - SUBROUTINE OBUFR(KOUNT) - - PARAMETER (IRMX= 200000) - PARAMETER (ISIZE= 18) - - CHARACTER*1 CHRQM(6) - CHARACTER*8 LAST,ACID,AAID(IRMX),SUBSET,POSITN,HEADR - CHARACTER*16 TAG,STAG(IRMX) - CHARACTER*20 QM1LVL,QM2LVL,QM3LVL - - REAL(8) HDR_8(2),QMS1_8(4),QMS2_8(5),QMS3_8(4) - REAL RQM(6),SARRAY(IRMX,ISIZE),PHIACF(7) - - INTEGER INDR(IRMX),IARRAY(IRMX),MFLAG(2) - - COMMON/ALLDAT/ACID(IRMX),ALAT(IRMX),ALON(IRMX),AALT(IRMX), - $ TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE,ATMP(IRMX),ASPH(IRMX), - $ TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX),ITEVNT(IRMX), - $ IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX),ADIRF(IRMX), - $ IQEVNT(IRMX) - COMMON/OUTPUT/KNTOUT(2) - COMMON/INPT/TMAXO,TMINO,JAMASS(6),JAWIND(6),RCPTST - COMMON/MASK/GDNH(362,91),GDSH(145,37),GDUS(362,91) - - DATA QM1LVL/'TOB TQM TPC TRC '/ - DATA QM2LVL/'UOB WQM WPC WRC VOB '/ - DATA QM3LVL/'QOB QQM QPC QRC '/ - DATA HEADR/'TYP SQN '/ - DATA POSITN/'YOB XOB '/ - DATA KNTBFR/0/,KKK/0/,IFLAG/0/,SQNL/0/ - DATA RQM / 0., 1., 3.,13.,10.,14./ - DATA CHRQM/'H','A','Q','F','O','P'/ - DATA LAST/'XXXXXXXX'/,ISUBO/0/,ISUBOT/0/,IRECOL/0/,IRECO/0/ - DATA PHIACF/-90.,-70.,-20.,0.,20.,70.,90./ - DATA MFLAG/2*0/ - - PRINT 199 - 199 FORMAT(/5X,'===> ALL REPORTS Q.C.ED AND READY FOR REPACKING'/) -C TRANSFER ORIGINAL DATA TO TEMPORARY ARRAYS TO HOLD FOR RE-ARRANGING - - DO J = 1,KOUNT - AAID(J) = ACID(J) - SARRAY(J,1) = ALAT(J) - SARRAY(J,2) = ALON(J) - SARRAY(J,3) = AALT(J) - SARRAY(J,4) = TIME(J) - SARRAY(J,5) = ATMP(J) - SARRAY(J,6) = ADIR(J) - SARRAY(J,7) = ASPD(J) - SARRAY(J,8) = REAL(INTP(J)) - SARRAY(J,9) = REAL(IRTM(J)) - SARRAY(J,10) = REAL(KNTINI(J)) - SARRAY(J,11) = REAL(ITEVNT(J)) - SARRAY(J,12) = REAL(IWEVNT(J)) - SARRAY(J,13) = AALTF(J) - SARRAY(J,14) = ADIRF(J) - SARRAY(J,15) = ASPDF(J) - SARRAY(J,16) = ATMPF(J) - SARRAY(J,17) = ASPH(J) - SARRAY(J,18) = REAL(IQEVNT(J)) - STAG(J) = TAG(J) - IARRAY(J) = KNTINI(J) - ENDDO - -C NEED TO RESORT OBS. ACCORDING TO ORIGINAL ORDER THAT WAS READ IN -C CALL SORT ROUTINE- PUTS POINTERS INTO IPOINT ARRAY/DOES NOT REARRANGE - IF(KOUNT.GT.0) CALL INDEXF(KOUNT,IARRAY,INDR) -C WRITE SORTED REPORTS BACK INTO ORIGINAL ARRAYS - DO I = 1,KOUNT - J = INDR(I) - ACID(I) = AAID(J) - ALAT(I) = SARRAY(J,1) - ALON(I) = SARRAY(J,2) - AALT(I) = SARRAY(J,3) - TIME(I) = SARRAY(J,4) - ATMP(I) = SARRAY(J,5) - ADIR(I) = SARRAY(J,6) - ASPD(I) = SARRAY(J,7) - INTP(I) = NINT(SARRAY(J,8)) - IRTM(I) = NINT(SARRAY(J,9)) - KNTINI(I) = NINT(SARRAY(J,10)) - ITEVNT(I) = NINT(SARRAY(J,11)) - IWEVNT(I) = NINT(SARRAY(J,12)) - AALTF(I) = SARRAY(J,13) - ADIRF(I) = SARRAY(J,14) - ASPDF(I) = SARRAY(J,15) - ATMPF(I) = SARRAY(J,16) - ASPH(I) = SARRAY(J,17) - IQEVNT(I) = NINT(SARRAY(J,18)) - TAG(I) = STAG(J) - ENDDO - - CALL DATELEN(10) - CALL OPENBF(14,'IN',14) - PRINT 200 - 200 FORMAT(/5X,'+++> PREPBUFR DATA SET IN UNIT 14 SUCCESSFULLY', - $ ' OPENED FOR INPUT; FIRST MESSAGE CONTAINS BUFR TABLES A,B,D'/) - CALL OPENBF(61,'OUT',14) - PRINT 100 - 100 FORMAT(/5X,'+++> PREPBUFR DATA SET IN UNIT 61 SUCCESSFULLY', - $ ' OPENED FOR OUTPUT; CUSTOMIZED BUFR TABLES A,B,D IN UNIT 14'/ - $ 12X,'READ IN AND ENCODED INTO MESSAGE NO. 1 OF OUTPUT DATA SET'/) - -C GET THE "PROGRAM CODE" CORRESPONDING TO "ACARSQC" - CALL UFBQCD1(14,'ACARSQC',PCODE) - - 10 CONTINUE - -C READ IN NEXT BUFR MESSAGE FROM INPUT FILE - CALL READMG(14,SUBSET,IDATEP,IRET) - IF(IRET.NE.0) THEN -C NON-ZERO IRET IN READMG MEANS ALL BUFR MESSAGES IN FILE HAVE BEEN READ -C CLOSE INPUT DATA SET - IF(LAST.EQ.'AIRCAR ') THEN - CALL UFBCNT(61,IRECO,ISUBO) - ISUBOT = ISUBOT + ISUBO - PRINT 1254, IRECO,LAST,ISUBO,ISUBOT - 1254 FORMAT(/' --- WROTE BUFR DATA MSG NO. ',I10,' -- TABLE A ENTRY "', - $A8,'" - CONTAINS',I6,' REPORTS (TOTAL NO. RPTS WRITTEN =',I7,')'/) - END IF - PRINT 9101, IRECO,ISUBOT - 9101 FORMAT(/' --- ALL TOTAL OF',I11,' BUFR MESSAGES WRITTEN OUT -- TO' - $,'TAL NUMBER OF REPORTS WRITTEN =',I7//5X,'===> PREPBUFR DATA ' - $,'SET IN UNIT 14 SUCCESSFULLY CLOSED FROM FINAL READ OF ALL OBS') - CALL CLOSBF(61) - PRINT 9102 - 9102 FORMAT(/5X,'===> PREPBUFR DATA SET IN UNIT 61 SUCCESSFULLY ', - $ 'CLOSED AFTER WRITING OF ALL OBS'/25X,' *** ALL DONE ***'/) - RETURN - END IF - CALL UFBCNT(14,IRECI,ISUBI) -CCCCC PRINT 1364, IRECI,SUBSET - IF(SUBSET.EQ.'AIRCAR ') PRINT 1364, IRECI,SUBSET - 1364 FORMAT(' --- READ IN BUFR DATA MESSAGE NUMBER',I6,' WITH TABLE ', - $ 'A ENTRY "',A8,'"') - IF(LAST.NE.SUBSET) THEN - IF(LAST.EQ.'AIRCAR ') THEN - CALL UFBCNT(61,IRECO,ISUBO) - ISUBOT = ISUBOT + ISUBO - PRINT 1254, IRECO,LAST,ISUBO,ISUBOT -C MUST CLOSE THE LAST "AIRCAR" TABLE A ENTRY MESSAGE - CALL CLOSMG(61) - END IF - PRINT 105, SUBSET,IDATEP - 105 FORMAT(/' ===> NEXT MESSAGE IN OUTPUT PREPBUFR DATA SET IN ', - $ 'UNIT 61 HAS NEW TABLE A ENTRY OF "',A6,'" -- DATE IS',I11) - CALL UFBCNT(61,IRECOL,ISUBO) - IRECOL = IRECOL + 1 - END IF - LAST = SUBSET - IF(SUBSET.NE.'AIRCAR ') THEN -C ALL TABLE A ENTRY BUFR MESSAGES THAT ARE NOT "AIRCAR" ARE SIMPLY -C COPIED FROM INPUT FILE TO OUTPUT FILE AS IS (NO DECODING OF SUBSETS) - CALL COPYMG(14,61) - CALL UFBCNT(61,IRECO,ISUBO) - ISUBOT = ISUBOT + ISUBO -CCCCC PRINT 1254, IRECO,SUBSET,ISUBO,ISUBOT - GO TO 10 - END IF -C TABLE A ENTRY "AIRCAR" MESSAGES COME HERE TO DECODE/ENCODE EACH SUBSET - CALL OPENMB(61,SUBSET,IDATEP) - - 2 CONTINUE - -C READ IN NEXT SUBSET (REPORT) FROM THIS BUFR MESSAGE - CALL READSB(14,IRET) -C NON-ZERO IRET IN READSB MEANS ALL SUBSETS IN BUFR MSG HAVE BEEN READ -C GO ON TO READ NEXT BUFR MESSAGE - IF(IRET.NE.0) GO TO 10 -C OTHERWISE, MUST LOOK AT RPT SEQ. NUMBER TO SEE IF THIS IS PIECE 1 OF A -C 1- OR 2-PIECE(MASS/WIND) OBS. (KNEW=1) OR IF THIS IS PIECE 2 (KNEW=0) - CALL UFBINT(14,HDR_8,2,1,N1LEV,HEADR) - IF(N1LEV.NE.1) GO TO 999 - KNEW = 0 - IF(HDR_8(2).NE.SQNL) THEN - KNEW = 1 - IF(IFLAG.EQ.0) THEN -C TEST BELOW SATISFIED WHEN BOTH JAMASS & JAWIND ARE 9999 FOR LAT BAND -C (SET POS. 1 OF TAG TO 'D' TO REMOVE FROM FINAL PRINTOUT LISTING) - IF(MIN(MFLAG(1),MFLAG(2)).EQ.1) TAG(KKK)(4:4) = 'D' - KKK = KKK + 1 - MFLAG(1) = 1 - MFLAG(2) = 1 - END IF - IFLAG = 0 - KNTBFR = KNTBFR + 1 - END IF - SQNL = HDR_8(2) -C DETERMINE IF THIS "AIRCAR" OBS SHOULD INDEED BE WRITTEN TO OUTPUT FILE - IF(KNTBFR.NE.KNTINI(KKK)) THEN -C -- COME HERE IF NOT AND SET IFLAG=1 IN CASE NEXT PIECE READ IN IS -C PART OF THIS SAME OBS. - IFLAG = 1 - GO TO 2 - END IF -C DETERMINE LATITUDE BAND INDEX (IBNDA) - DO IBNDA = 1,5 - IF(ALAT(KKK).LT.(PHIACF(IBNDA+1)-0.005)) GO TO 6701 - ENDDO - IBNDA = 6 - 6701 CONTINUE - KI = NINT(HDR_8(1))/100 - IF((JAMASS(IBNDA).NE.0.AND.KI.EQ.1).OR.(JAWIND(IBNDA).NE.0.AND. - $ KI.EQ.2)) GO TO 3 - MFLAG(KI) = 0 -C ALL SUBSETS THAT ARE TO BE RETAINED ARE FIRST COPIED FROM INPUT BUFFER -C TO OUTPUT BUFFER AS IS - CALL UFBCPY(14,61) - IF(KI.EQ.1) THEN - IF(ITEVNT(KKK).GT.0) THEN -C --> COME HERE IF THERE IS A TEMPERATURE EVENT (NEW Q. MARKER) -C STACK NEW Q.MARK, PGM CODE, REASON CODE (EVENT) AND TEMP. OB - CALL UFBINT(14,QMS1_8,4,1,N1LEV,QM1LVL) - IF(N1LEV.NE.1) GO TO 999 - QMS1_8(2) = 2. - QMS1_8(3) = PCODE - QMS1_8(4) = ITEVNT(KKK) - DO I = 1,6 - IF(TAG(KKK)(1:1).EQ.CHRQM(I)) THEN - QMS1_8(2) = RQM(I) - EXIT - END IF - ENDDO - CALL UFBINT(61,QMS1_8,4,1,IRET,QM1LVL) - END IF - IF(IQEVNT(KKK).GT.0) THEN -C --> COME HERE IF THERE IS A SPECIFIC HUMIDITY EVENT (NEW Q. MARKER) -C STACK NEW Q.MARK, PGM CODE, REASON CODE (EVENT) AND SHUM OB - CALL UFBINT(14,QMS3_8,4,1,N1LEV,QM3LVL) - IF(N1LEV.NE.1) GO TO 999 - QMS3_8(2) = 2. - QMS3_8(3) = PCODE - QMS3_8(4) = IQEVNT(KKK) - DO I = 1,6 - IF(TAG(KKK)(2:2).EQ.CHRQM(I)) THEN - QMS3_8(2) = RQM(I) - EXIT - END IF - ENDDO - CALL UFBINT(61,QMS3_8,4,1,IRET,QM3LVL) - END IF - ELSE IF(KI.EQ.2.AND.IWEVNT(KKK).GT.0) THEN -C --> COME HERE IF THERE IS A WIND EVENT (NEW Q. MARKER) -C STACK NEW Q.MARK, PGM CODE, REASON CODE (EVENT) AND WIND OB - CALL UFBINT(14,QMS2_8,5,1,N1LEV,QM2LVL) - IF(N1LEV.NE.1) GO TO 999 - QMS2_8(2) = 2. - QMS2_8(3) = PCODE - QMS2_8(4) = IWEVNT(KKK) - DO I = 1,6 - IF(TAG(KKK)(3:3).EQ.CHRQM(I)) THEN - QMS2_8(2) = RQM(I) - EXIT - END IF - ENDDO - CALL UFBINT(61,QMS2_8,5,1,IRET,QM2LVL) - END IF - IF(KI.EQ.1) THEN - KNTOUT(1) = KNTOUT(1) + 1 - ELSE - KNTOUT(2) = KNTOUT(2) + 1 - END IF -C FINALLY, WRITE SUBSET (REPORT) WITH ANY ADDED EVENTS (IF APPL.) TO -C OUTPUT FILE - CALL WRITSB(61) - CALL UFBCNT(61,IRECO,ISUBON) - IF(IRECO.GT.IRECOL) THEN - IRECOL = IRECO - ISUBOT = ISUBOT + ISUBO - PRINT 1264, IRECO-1,ISUBO,ISUBOT - 1264 FORMAT(/' --- THIS REPORT OPENS NEW MSG (SAME TABLE A): LAST ', - $ 'DATA MSG WAS NO.',I5,' WITH',I5,' REPORTS (TOTAL NO. REPORTS ', - $ 'WRITTEN =',I7,')'/) - END IF - ISUBO = ISUBON - - 3 CONTINUE - -CCCCC IF(KNEW.EQ.1) THEN -CCCCC PRINT 6111, KKK,ACID(KKK),TIME(KKK),ALAT(KKK),ALON(KKK), -CCCCC$ AALT(KKK),ATMP(KKK),ASPH(KKK),ADIR(KKK),ASPD(KKK), -CCCCC$ TAG(KKK)(1:3),TAG(KKK)(4:16),INTP(KKK),KNTINI(KKK),ITEVNT(KKK), -CCCCC$ IQEVNT(KKK),IWEVNT(KKK) -C6111 FORMAT(' ',I5,2X,A8,3X,F5.0,2(3X,F6.2),1X,F6.0,2(4X,F5.1),2X, -CCCCC$ F4.0,3X,F4.1,4X,A3,3X,A13,I6,I8,3I6) -CCCCC END IF - GO TO 2 - -C----------------------------------------------------------------------- - 999 CONTINUE -C THE NUMBER OF DECODED HEADER AND/OR OBS. LEVELS IS NOT 1!! -- STOP 70 - PRINT 217 - 217 FORMAT(/' THE NUMBER OF DECODED HEADER AND/OR OBS. LEVELS FOR', - $ ' A REPORT IS NOT 1 -- STOP 70'/) - CALL W3TAGE('PREPOBS_ACARSQC') - CALL ERREXIT(70) -C----------------------------------------------------------------------- - - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: CMDDFF CONVERTS WIND U/V COMPONENTS TO DIR/SPD -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1995-03-27 -C -C ABSTRACT: CONVERTS GRID U AND V COMPONENTS OF VELOCITY (M/S) TO WIND -C DIRECTION AND SPEED. SEE ARGUMENT 'ISUNIT' FOR OUTPUT SPEED UNITS. -C -C PROGRAM HISTORY LOG: -C UNKNOWN -C 1995-03-27 D. A. KEYSER -- ORIGINAL AUTHOR -C -C USAGE: CALL CMDDFF(ISUNIT,U,V,DD,FF) -C INPUT ARGUMENT LIST: -C ISUNIT - OUTPUT SPEED UNIT INDICATOR (=1 - KNOTS, =2 - M/S) -C U - U-COMPONENT OF WIND VELOCITY (M/S) -C V - V-COMPONENT OF WIND VELOCITY (M/S) -C -C OUTPUT ARGUMENT LIST: -C DD - DIRECTION OF WIND (DEGREES) -C FF - SPEED OF WIND (SEE 'ISUNIT' FOR UNITS) -C -C REMARKS: CALLED BY SUBROUTINE IBUFR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - - SUBROUTINE CMDDFF(ISUNIT,U,V,DD,FF) - - REAL FACTOR(2) - - DATA FACTOR/0.5148,1.0/,CONV2R/0.017453293/ - - IF(U.EQ.0.0) THEN - DD = 0. - IF(V.GT.0.0) DD = 180. - ELSE - IF(V.EQ.0.0) THEN - DD = 90. - IF(U.GT.0.0) DD = 270. - ELSE - DD = (ATAN2(U,V)/CONV2R) + 180. - DD = AMOD(DD,360.) - END IF - END IF - FF = SQRT(U**2 + V**2)/FACTOR(ISUNIT) - - RETURN - - END - - SUBROUTINE UFBQCD1(LUNIT,NEMO,QCD) - - CHARACTER*(*) NEMO - CHARACTER*6 FXY,ADN30 - CHARACTER*1 TAB - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - CALL STATUS(LUNIT,LUN,IL,IM) - IF(IL.EQ.0) GOTO 900 - - CALL NEMTAB(LUN,NEMO,IDN,TAB,IRET) - IF(TAB.NE.'D') then - QCD = 14 ! hardwire when missing - return - endif - - FXY = ADN30(IDN,6) - IF(FXY(2:3).NE.'63') GOTO 902 - READ(FXY(4:6),'(F3.0)',ERR=903) QCD - - RETURN -900 CALL BORT('UFBQCD - FILE IS CLOSED ') -901 CALL BORT('UFBQCD - MISSING OR INVALID TABLE D QC CODE ') -902 CALL BORT('UFBQCD - TABLE D QC CODE DESCRIPTOR NOT 363YYY') -903 CALL BORT('UFBQCD - ERROR READING YYY FROM QC CODE DESCRP') - END diff --git a/src/Applications/NCEP_Paqc/prepobs_acarsqc.fd/prepobs_acarsqc.merra.parm b/src/Applications/NCEP_Paqc/prepobs_acarsqc.fd/prepobs_acarsqc.merra.parm deleted file mode 100644 index 84e45fec..00000000 --- a/src/Applications/NCEP_Paqc/prepobs_acarsqc.fd/prepobs_acarsqc.merra.parm +++ /dev/null @@ -1,9 +0,0 @@ - - Cards for ACARSQC -- Version 7 May 2002 - Here: GMAO/MERRA system -- Effective: origination to present - - &INPUT - WINDOW=3.00, JAMASS = 6*0, JAWIND= 6*0, - FWRITE = .TRUE., IWRITE=.FALSE., EWRITE=.TRUE., EWRITE_7=.FALSE. - / - diff --git a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/CMakeLists.txt b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/CMakeLists.txt index bef4d659..4e235069 100644 --- a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/CMakeLists.txt +++ b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/CMakeLists.txt @@ -5,8 +5,8 @@ endif () ecbuild_add_executable ( TARGET prepacqc.x - SOURCES prepacqc.f + SOURCES prepacqc.f acftobs_qc.f indexc40.f input_acqc.f output_acqc_noprof.f output_acqc_prof.f sub2mem_mer.f sub2mem_um.f tranQCflags.f pmat.f90 pmat2.f90 pmat3.f90 pietc.f90 pspl.f90 pkind.f90 LIBS NCEP_bufr_r4i4 NCEP_w3_r4i4) file(GLOB parm_files *.parm) -install(FILES ${parm_files} prepobs_landc prepobs_waypoints DESTINATION etc) +install(FILES ${parm_files} DESTINATION etc) diff --git a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/acftobs_qc.f b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/acftobs_qc.f new file mode 100644 index 00000000..0e5a03ef --- /dev/null +++ b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/acftobs_qc.f @@ -0,0 +1,29961 @@ +ccccc +c 2013-02-07 D. Keyser -- Final changes to run on WCOSS: use formatted print statements +c where previously unformatted print was > 80 characters; use GNU +c standard call "date_and_time" instead of calls to "date" and +c "time" to obtain system date and time to avoid ifort compiler +c warning +c 2014-07-18 D. Keyser -- +c - Keep track of maximum value for number of flights calculated at some +c point during the processing of subroutine acftobs_qc. If, at the end +c of acftobs_qc, this value is at least 90% of the allowed limit +c ("maxflt", set in the main program), post a diagnostic warning message +c to the production joblog file prior to exiting from acftobs_qc. +c - In subr. do_flt and do_reg, return (abnormally) immediately if +c "maxflt" is exceeded rather than waiting to test for this at end of +c do_flt and do_reg and then return (abnormally). Prior to return +c subtract 1 from number of flights so it will remain at "maxflt". The +c immediate return avoids clobbering of memory in these cases. +c - In subr. reorder, where any new flight exceeding "maxflt" replaces the +c previous flight at index "maxflt" in the arrays to avoid an array +c overflow (done in two places original NRL version), post a diagnostic +c warning message to the production joblog file (found a third instance +c where this needs to be done in subr, reorder - original NRL version +c did not trap it and arrays limited to length "maxflt" would have +c overflowed). +c - If "maxflt" is exceeded in subr. dupchk (1 place possible) or in subr. +c do_flt (2 places possible), the abnormal return back to subr. +c acftobs_qc results in subr. acftobs_qc now continuing on but setting a +c flag for "maxflt_exceeded". Prior to this, subr. acftobs_qc itself +c immediately performed an abnormal return back to main program in such +c cases resulting in no more NRL QC processing. Now NRL QC processing +c will continue on to the end of subr. acftobs_qc where the abnormal +c return back to the main program will be triggered by the +c "maxflt_exceeded" flag. +c - There is one, apparently rare, condition where "maxflt" could be +c exceeded in subr. acft_obs itself (within logic which generates master +c list of tail numbers and counts). Since it can't be determined if +c continuing on without processing (QC'ing) any more data would yield +c acceptable results, the program now immediately stops with condition +c code 98 and a diagnostic warning message is posted to the production +c joblog file noting that "maxflt" needs to be increased. Prior to this +c it returned to the main program where it also immediately stopped with +c condition code 98 (so no real change in what happens here, just where +c it happens). +c - Increased format width from I5 to I6 in all places where aircraft obs +c index is listed out (since there now can be > 99999 reports). +c 2013-10-07 Sienkiewicz Initialize some uninitialzed variables in 'benford_qc' and +c 'rejlist_qc', for 'gfortran' compile +c 2016-12-09 D. Keyser -- +c - Since "ACARS" as referred to here is not used and we earlier decided to +c use this to provide a separate category for TAMDARs (for stratifying +c statistics), all printout here changes the term "ACARS" to "TAMDAR". +c In addition, all comments now refer to "TAMDAR" instead of "ACARS". +c - Variables holding latitude and longitude data (including input +c arguments "alat" and "alon") now double precision. XOB and YOB in +c PREPBUFR file now scaled to 10**5 (was 10**2) to handle new v7 AMDAR +c and MDCRS reports which have this higher precision. +c BENEFIT: Retains exact precison here. Improves QC processing. +c - Note: QC here can be improved further by changing logic in many +c places to account for the increased precision. This needs to +c be investigated. For now, locations in code where this +c seems possible are noted by the spanning comments: +c ! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c ! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c - The format for all print statements containing latitude and longitude +c changed to print to 5 decimal places. +c - Intrinsic function "ifix" replaced with "int" for cases where the +c argument is now a real*8 lat or lon (else compiler error if "ifix" +c operates on a real*8 argument). +c +c BEST VIEWED WITH 94-CHARACTER WIDTH WINDOW +ccccc +c +c ################################################################### +c subroutine acftobs_qc +c ################################################################### +c + subroutine acftobs_qc(max_reps,cdtg_an,numreps,krej + x, c_acftreg,c_acftid,itype,idt,idp,alon,alat,pres,ht_ft + x, ob_t,ob_q,ob_dir,ob_spd,t_prcn + x, xiv_t,xiv_q,xiv_d,xiv_s,ichk_t,ichk_q,ichk_d,ichk_s + x, nchk_t,nchk_q,nchk_d,nchk_s + x, indx,isave,in_bad,c_qc,csort + x, maxflt,kflight,creg_flt,cid_flt,cid_flt_old,l_newflt + x, nobs_flt,iobs_flt,ntot_flt,nrej_flt,ntot_flt_old,nrej_flt_old + x, creg_reg,nobs_reg,ntot_reg,nrej_reg,ntemp_reg,nwind_reg + x, nwhol_reg,creg_reg_tot,nobs_reg_tot,nwhol_reg_tot + x, nrej_reg_tot,ntemp_reg_tot,nwind_reg_tot,nrej_inv_tot + x, nrej_stk_tot,nrej_grc_tot,nrej_pos_tot,nrej_ord_tot + x, nrej_sus_tot,lead_t_tot,lead_d_tot,lead_s_tot,n_xiv_t + x, n_xiv_d,n_xiv_s,sum_xiv_t,sum_xiv_d,sum_xiv_s,sumabs_xiv_t + x, sumabs_xiv_d,sumabs_xiv_s,l_minus9c + x, l_last,l_first_date,l_operational,l_pc,l_ncep,*) +c +c This routine performs qc checks on the combined ACARS, AIREP, PIREP, +c AMDAR and TAMDAR aircraft data. To the extent possible, the data are +c sorted into tracks and checked for consistency along the tracks. + +cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +c For NCEP purposes NRL ACARS applies to TAMDAR - all references to +c ACARS are changed to TAMDAR in printout +cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + +c Adapted from sortacrs--P.M. Pauley's original ACARS QC program +c Most QC checks patterned after those developed by Bill Moninger +c +c Programmer: P.M. Pauley (12/22/97--modified 09/13/99) +c version of 2/9/2000 +c +c Input: arrays containing observations +c +c Output: (possibly re-ordered) arrays containing observations with qc flags set +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c + implicit none +c +c Parameter statements +c -------------------- + integer io8,io30,io31,io32,io33,io34,io35,io36,io37,io38 + parameter(io8 = 8) ! i/o unit number for log file +c + parameter(io30 = 30) ! i/o unit for duplicate check rejects + parameter(io31 = 31) ! i/o unit for spike check rejects + parameter(io32 = 32) ! i/o unit for invalid check rejects + parameter(io33 = 33) ! i/o unit for stuck check rejects + parameter(io34 = 34) ! i/o unit for gross check rejects + parameter(io35 = 35) ! i/o unit for position check rejects + parameter(io36 = 36) ! i/o unit for ordering check rejects + parameter(io37 = 37) ! i/o unit for suspect data check rejects + parameter(io38 = 38) ! i/o unit for reject list check rejects +c (If it is desirable to place all rejected reports in a single file, the +c numbers assigned in these parameter statements should be set equal so that +c the bad reports are all written to the bad data file.) +c +c integer nbadlat,nbadwind +c parameter(nbadlat = 63) ! # of acft with decimal lat/lons +c parameter(nbadwind = 198) ! # of acft with flipped winds +c + integer nbadtemp,nblkwind,nblktemp + parameter(nbadtemp = 59) ! # of acft with temps in whole degrees + parameter(nblkwind = 67) ! # of acft blacklisted for wind errors + parameter(nblktemp = 45) ! # of acft blacklisted for temp errors +c + integer imiss + real amiss + parameter(imiss = 99 999) ! integer missing value flag + parameter(amiss = -9999.) ! real missing value flag +c + character*8 cregmiss,cidmiss + parameter(cregmiss = ' ') ! missing value flag for tail number + parameter(cidmiss = '9999-999') ! missing value flag for flight number +c + real ft2m + parameter(ft2m = 3.28084) ! conversion factor to convert ft to m +c + integer idt_near,idt_updn,idt_samflt + parameter(idt_near = 1805) ! time diff between "near" neighbors (was a0) + parameter(idt_updn = 180) ! time diff to check ascents/descents + parameter(idt_samflt = 7200) ! time diff allowed for same flight +c + real htdif_same + parameter(htdif_same = 100.) ! height difference considered negligible +c + real htdif_1min + parameter(htdif_1min = 8000.) ! maximum height difference allowed in one minute +c +c Declaration statements +c ---------------------- + integer max_reps ! maximum number of input reports allowed + ! (initialized by calling routine) +cvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv +c replace above with this in event of future switch to dynamic memory allocation + +callocinteger max_reps ! original number of input reports obtained from +calloc ! first pass through to get total for array allocation +c^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +c +c Internal QC flags +c ----------------- + character*11 c_qc(max_reps) +c +c Legend for QC flags +c ------------------- +c ( 1:1 ) info about reject +c 'A'--altitude error +c 'B'--report declared bad in decoder or aircraft id = XX999 +c 'd'--near duplicate +c 'D'--exact duplicate +c 'e'--encode error--reject report with missing winds +c 'E'--encode error--report rejected +c 'N'--duplicate check or stuck value check not performed +c 'O'--isolated off-track point +c 'p'--point closer to last rejected point than to current point +c 'P'--unrealistic airspeed +c 'r'--redundant report +c 's'--suspect reports--too few reports to check +c 'S'--suspect reports--too many rejects for flight +c 't'--time error +c 'v'--report failed bounce test +c 'V'--unrealistic vertical speed +c 'W'--waypoint error +c 'X'--isolated minimum/maximum altitude +c '2'--second flight with same ident found +c '.'--good report +c '-'--not checked +c +c 'A'--anomalous +c ( 2:2 ) time \ 'B' or 'b'--bad +c ( 3:3 ) latitude | 'E'--encode error +c ( 4:4 ) longitude | 'I' or 'i'--inconsistent +c ( 5:5 ) pressure/altitude | 'K'--constant (stuck) values +c ( 6:6 ) temperature | 'M'--missing +c ( 7:7 ) direction | 'N'--not checked +c ( 8:8 ) speed | 'R' or 'r'--rehabilitated [1] +c ( 9:9 ) moisture / 'S'--suspect +c '-'--not checked +c '.'--passed checks +c +c (10:10) black lists +c 'C'--aircraft reports temperature in whole deg C +c 'F'--aircraft reports flipped winds (not checked here) +c 'L'--aircraft reports decimal lat/lon (not checked here) +c 'T'--temperature blacklisted +c 'W'--winds blacklisted +c 'O'--both temperature and winds blacklisted +c '.'--passed black-list checks +c +c (11:11) flight phase +c 'a'--low-resolution ascent +c 'A'--high-resolution ascent +c 'd'--low-resolution descent +c 'D'--high-resolution descent +c 'I'--isolated report +c 'L'--level flight +c 'N'--time difference too great to permit check +c 'U'--unknown +c +c [1] If altitude is read and pressure computed, c_qc(ii)(5:5) = 'R' +c If pressure is read and altitude computed, c_qc(ii)(5:5) = 'r' +c +c Data arrays +c ----------- + character*10 cdtg_an ! date time group for analysis + integer numreps_orig ! original number of reports passed in (bad and good) + integer numreps ! number of reports (deemped "good" + ! reports after each QC step) + integer itype(max_reps) ! type of aircraft data + integer idt(max_reps) ! time in seconds to analysis time + integer idp(max_reps) ! surface pressure change at ob location + character*8 c_acftreg(max_reps) ! aircraft registration (tail) number + character*9 c_acftid(max_reps) ! aircraft flight number + real*8 alat(max_reps) ! latitude + $, alon(max_reps) ! longitude + real pres(max_reps) ! pressure + $, ht_ft(max_reps) ! height in feet + real t_prcn(max_reps) ! temperature precision + real ob_t(max_reps) ! temperature + $, ob_q(max_reps) ! specific humidity + $, ob_dir(max_reps) ! wind direction + $, ob_spd(max_reps) ! wind speed + real xiv_t(max_reps) ! temperature innovation (ob - bk) + $, xiv_q(max_reps) ! specific humidity innovation (ob - bk) + $, xiv_d(max_reps) ! wind direction innovation (ob - bk) + $, xiv_s(max_reps) ! wind speed innovation (ob - bk) + integer ichk_t(max_reps) ! NRL QC flag for temperature ob + $, ichk_q(max_reps) ! NRL QC flag for specific humidity ob + $, ichk_d(max_reps) ! NRL QC flag for wind direction ob + $, ichk_s(max_reps) ! NRL QC flag for wind speed ob + integer nchk_t(max_reps) ! NCEP QC flag for temperature ob + $, nchk_q(max_reps) ! NCEP QC flag for specific humidity ob + $, nchk_d(max_reps) ! NCEP QC flag for wind direction ob + $, nchk_s(max_reps) ! NCEP QC flag for wind speed ob + logical l_minus9c(max_reps) ! true for mdcrs -9C temperatures +c +c Arrays for mixed duplicates +c --------------------------- + integer maxflt ! maximum number of flights in dataset + ! (initialized by calling routine) + integer maxflt_exceeded ! flag to indicate that maxflt has been exceeded (=1, + ! else =0) + character*6 cmaxflt ! character form of maxflt for NCEP print statement +c character*9 c_air_id(max_reps) ! airep flight id for mixed duplicate +ccccdak x, c_acr_id(max_reps) ! acars flight id for mixed duplicate +c x, c_acr_id(max_reps) ! tamdar flight id for mixed duplicate +ccccdak character*8 c_acr_reg(maxflt) ! acars tail number for mixed duplicate +c character*8 c_acr_reg(maxflt) ! tamdar tail number for mixed duplicate +c integer idt_min(maxflt) ! min time for flight segment +c $, idt_max(maxflt) ! max time for flight segment +c +c Pointers +c -------- + integer indx(max_reps) ! pointer index for good reports + $, in_bad(max_reps) ! pointer index for bad reports + $, isave(max_reps) ! second pointer index + $, krej ! counter for number of reports rejected +c +c Blacklists +c ---------- + character*8 cbadtemp(nbadtemp) ! acft reports temperature in whole deg C +c $, cbadlat(nbadlat) ! acft reports decimal lat/lon +c $, cbadwind(nbadwind) ! acft reports flipped winds + $, cblkwind(nblkwind) ! winds blacklisted + $, cblktemp(nblktemp) ! temperatures blacklisted +c +c Flight statistics +c ----------------- + integer kflight ! number of flights in dataset + integer kflight_max ! number of flights in dataset (maximum over course of + ! processing) + character*8 creg_flt(maxflt) ! tail number for each flight + character*9 cid_flt(maxflt) ! flight id for each flight + $, cid_flt_old(maxflt) ! previous value of cid_flt + integer nobs_flt(maxflt) ! number of reports per flight + $, iobs_flt(maxflt) ! index for first report in each flight + $, ntot_flt(maxflt) ! total number of reports per flight + $, nrej_flt(maxflt) ! number of reports rejected per flight + $, ntot_flt_old(maxflt)! previous value of total number of reports per flight + $, nrej_flt_old(maxflt)! previous value of # of reports rejected per flight +c +c Tail number statistics +c ---------------------- + integer kreg ! actual number of tail numbers in dataset + integer kreg_max ! actual number of tail numbers in dataset (maximum + ! over course of processing) + character*8 creg_reg(maxflt) ! tail numbers + integer nobs_reg(maxflt,5) ! number of reports per tail number per type + integer ntot_reg(maxflt,5) ! total number of reports rejected per tail number + integer nrej_reg(maxflt,5) ! number of reports rejected per tail number + integer ntemp_reg(maxflt,5) ! number of reports w. rejected temp + integer nwind_reg(maxflt,5) ! number of reports w. rejected winds + integer nwhol_reg(maxflt,5) ! number of reports w. temp in whole deg +c + integer kreg_tot ! number of unique tail numbers + integer kreg_tot_max ! number of unique tail numbers (maximum over course + ! of processing) + character*8 creg_reg_tot(maxflt)! master list of tail numbers + integer nobs_reg_tot(maxflt,5) ! number of reports per tail number + $, nwhol_reg_tot(maxflt,5)! number of temps in whole degs /tail number + $, nrej_reg_tot(maxflt,5) ! number of reports rejected per tail number + $, ntemp_reg_tot(maxflt,5)! number of temps rejected per tail number + $, nwind_reg_tot(maxflt,5)! number of winds rejected per tail number + $, nrej_inv_tot(maxflt,5) ! number of reports rejected in invalid + $, nrej_stk_tot(maxflt,5) ! number of reports rejected in stkchek + $, nrej_grc_tot(maxflt,5) ! number of reports rejected in grchek + $, nrej_pos_tot(maxflt,5) ! number of reports rejected in poschek + $, nrej_ord_tot(maxflt,5) ! number of reports rejected in ordchek + $, nrej_sus_tot(maxflt,5) ! number of reports rejected in suspect data check + integer lead_t_tot(maxflt,11,2) ! distribution of temperature innovations + $, lead_d_tot(maxflt,11,2) ! distribution of temperature innovations + $, lead_s_tot(maxflt,11,2) ! distribution of temperature innovations + $, n_xiv_t(maxflt,2) ! number of temperature innovations + $, n_xiv_d(maxflt,2) ! number of wind direction innovations + $, n_xiv_s(maxflt,2) ! number of wind speed innovations + integer mm ! do loop index--over tail numbers + real percent ! percentage of obs rejected + real sum_xiv_t(maxflt,2) ! sum of temperature innovations + $, sum_xiv_d(maxflt,2) ! sum of wind direction innovations + $, sum_xiv_s(maxflt,2) ! sum of wind speed innovations + $, sumabs_xiv_t(maxflt,2) ! sum of absolute value of temperature innovations + $, sumabs_xiv_d(maxflt,2) ! sum of absolute value of wind direction innovations + $, sumabs_xiv_s(maxflt,2) ! sum of absolute value of wind speed innovations + logical l_newflt(maxflt) ! true if flight is new flight +c +c Data counters +c ------------- + integer kbadtot ! total number of rejected reports + $, n_minus9C(5) ! number of -9C temperatures rejected +c +c Functions +c --------- + character*16 c_insty_ob ! function to convert integer instrument + ! type to character instrument type +c + integer insty_ob_fun ! function to convert character + ! instrument type to integer +c +c Other variables +c --------------- + integer ii ! do loop index + $, kk ! do loop index + $, iob ! do loop index--over reports + $, len ! length of filename +ccccdak integer knt_acars ! number of acars reports + integer knt_acars ! number of tamdar reports + $, knt_mdcrs ! number of mdcrs reports + $, knt_man_airep ! number of manual airep reports + $, knt_man_Yairep ! number of manual YRXX airep reports + $, knt_airep ! number of airep reports + $, knt_amdar ! number of amdar reports +c +ccccdak integer i_acars ! instrument type for acars + integer i_acars ! instrument type for tamdar +ccccdak $, i_acars_lvl ! instrument type for acars--level flt + $, i_acars_lvl ! instrument type for tamdar--level flt +ccccdak $, i_acars_asc ! instrument type for acars--ascent + $, i_acars_asc ! instrument type for tamdar--ascent +ccccdak $, i_acars_des ! instrument type for acars--descent + $, i_acars_des ! instrument type for tamdar--descent + $, i_mdcrs ! instrument type for mdcrs + $, i_mdcrs_lvl ! instrument type for mdcrs--level flt + $, i_mdcrs_asc ! instrument type for mdcrs--ascent + $, i_mdcrs_des ! instrument type for mdcrs--descent + $, i_man_airep ! instrument type for manual aireps + $, i_man_Yairep ! instrument type for manual aireps (YRXX) + $, i_airep ! instrument type for airep + $, i_airep_lvl ! instrument type for airep--level flt + $, i_airep_asc ! instrument type for airep--ascent + $, i_airep_des ! instrument type for airep--descent + $, i_amdar ! instrument type for amdar + $, i_amdar_lvl ! instrument type for amdar--level flt + $, i_amdar_asc ! instrument type for amdar--ascent + $, i_amdar_des ! instrument type for amdar--descent + $, kidt ! relative time + 100 000 for sort +c + integer iht_ft ! integer form of flight level + $, ilat ! integer form of latitude + $, ilon ! integer form of longitude +c $, kdup(maxflt) ! number of mixed duplicates per id pair +c + integer kdtg_an ! integer form of date-time group + $, k_AMDAR_tot ! total number of AMDAR reports + $, k_AIREP_tot ! total number of AIREP reports + $, k_UAL_tot ! total number of UAL AIREP reports + $, k_EU_tot ! total number of EU AIREP reports + $, k_AU_tot ! total number of AU AIREP reports + $, k_other_tot ! total number of other AIREP reports + $, k_AIREP_good ! number of good AIREP reports + $, k_YAIREP_good ! number of good YRXX86 AIREP reports + $, k_UAL_good ! number of good UAL AIREP reports + $, k_EU_good ! number of good EU AIREP reports + $, k_AU_good ! number of good AU AIREP reports + $, k_other_good ! number of good other AIREP reports + real per_AIREP ! percentage of good AIREP reports + $, per_UAL ! percentage of good UAL AIREP reports + $, per_EU ! percentage of good EU AIREP reports + $, per_AU ! percentage of good AU AIREP reports + $, per_other ! percentage of good other AIREP reports +c + integer k_total ! total number of aircraft reports + $, k_good ! number of good aircraft reports + $, k_tot_mdcrs ! total number of unspecified mdcrs reports + $, k_good_mdcrs ! number of good unspecified mdcrs reports + $, k_tot_mdcrs_lvl ! total number of level mdcrs reports + $, k_good_mdcrs_lvl ! number of good level mdcrs reports + $, k_tot_mdcrs_asc ! total number of ascent mdcrs reports + $, k_good_mdcrs_asc ! number of good ascent mdcrs reports + $, k_tot_mdcrs_des ! total number of descent mdcrs reports + $, k_good_mdcrs_des ! number of good descent mdcrs reports + $, k_tot_amdar ! total number of unspecified amdar reports + $, k_good_amdar ! number of good unspecified amdar reports + $, k_tot_amdar_lvl ! total number of level amdar reports + $, k_good_amdar_lvl ! number of good level amdar reports + $, k_tot_amdar_asc ! total number of ascent amdar reports + $, k_good_amdar_asc ! number of good ascent amdar reports + $, k_tot_amdar_des ! total number of descent amdar reports + $, k_good_amdar_des ! number of good descent amdar reports + $, k_tot_airep ! total number of unspecified airep reports + $, k_good_airep ! number of good unspecified airep reports + $, k_tot_airep_lvl ! total number of level airep reports + $, k_good_airep_lvl ! number of good level airep reports + $, k_tot_airep_asc ! total number of ascent airep reports + $, k_good_airep_asc ! number of good ascent airep reports + $, k_tot_airep_des ! total number of descent airep reports + $, k_good_airep_des ! number of good descent airep reports + $, k_tot_man_airep ! total number of man_airep reports + $, k_good_man_airep ! number of good man_airep reports +c + character*6 c_ht_ft ! character form of flight level + character*4 c_type ! character form of ob type + character*5 c_lat ! character form of latitude + character*6 c_lon ! character form of longitude + character*7 c_idt ! character form of relative time + character*25 csort(max_reps) ! variable used for sorting data +c + character*200 c_path ! path name for output files + integer lpath ! length of c_path +c + character*200 infile30 ! file name for rejected duplicates + $, infile31 ! file name for rejected spike reports + $, infile32 ! file name for rejected invalid reports + $, infile33 ! file name for rejected stuck reports + $, infile34 ! file name for rejected gross errors + $, infile35 ! file name for rejected position errors + $, infile36 ! file name for rejected ordering errors + $, infile37 ! file name for rejected suspect data errors + $, infile38 ! file name for rejected reject list reports + $, logfile ! file name for log file +c + logical l_opn ! true if file is already open + $, l_first ! true first time subroutine is called + $, l_first_date ! true for first date + ! (initialized by calling routine) + $, l_print ! true for printing values + $, l_sort ! true if data need to be sorted + $, l_flight ! true if flight stats to be updated + $, l_found ! true if tail numbers found on list + $, l_last ! true if last time subroutine is called + ! (initialized by calling routine) + $, l_pc ! if true, set up path names for Pat's PC + ! (initialized by calling routine) + $, l_ncep ! if true, use NCEP preferences + ! (initialized by calling routine) +c + logical l_do_innov ! compute innovation distribution if true + $, l_operational ! run QC in operational mode if true + ! (initialized by calling routine) + $, l_init ! initialize counters if true + $, l_innov_miss ! true if all innovations missing +c +c Data statements +c --------------- +cc +cc List of aircraft that report lat/lon in decimal instead of degrees, +cc minutes, tenths of minutes. (NOTE: this may ONLY be true at FSL) +cc (from W. Moninger at FSL) +cc ------------------------------------------------------------------- +c data cbadlat/'N000UA','N105UA','N106UA','N171UA','N172UA' +c A, 'N173UA','N174UA','N175UA','N176UA','N177UA','N178UA' +c B, 'N179UA','N180UA','N181UA','N182UA','N183UA','N184UA' +c C, 'N185UA','N186UA','N187UA','N188UA','N189UA','N190UA' +c D, 'N191UA','N192UA','N403UP','N404UP','N405UP','N406UP' +c E, 'N410UP','N414UP','N416UP','N417UP','N419UP','N421UP' +c F, 'N425UP','N426UP','N427UP','N429UP','N434UP','N641UA' +c G, 'N642UA','N643UA','N644UA','N645UA','N646UA','N647UA' +c H, 'N648UA','N649UA','N650UA','N651UA','N652UA','N653UA' +c I, 'N654UA','N655UA','N656UA','N657UA','N658UA','N659UA' +c J, 'N660UA','N661UA','N662UA','N663UA'/ +c +c List of aircraft that report temperature in degrees celsius, +c rather than in the expected tenths of degrees. +c (from W. Moninger at FSL) +c (Pseudo-id list derived from Oct 1998 data) +c (Pseudo-id list corrected from Sept 1999 data +c '35SYR4RA','5UUIR4BA','D5KYR5BA','ECOIR4BA' fixed) +c Check by tail number disabled in grchek after 1999100100--modified on 5/3/01 by PMP +c In 19-31 Oct 1999 dataset, the following aircraft were also fixed: +c '2OZYR4JA','4QJYR4BA','CE5YR4BA','NH5YR3BA','PI1IR4ZA', +c 'QJ5IR5BA','UUEYR3ZA','WSAIR3JA','XV2YR3RA','YITYR4ZA' +c ----------------------------------------------------------------------------------- + data cbadtemp/'N916UA', 'N917UA', 'N918UA', 'N919UA', 'N920UA' + A, 'N921UA', 'N923UA', 'N924UA', 'N925UA', 'N926UA' + B, 'N927UA', 'N928UA', 'N929UA', 'N930UA', 'N931UA' + C, 'N932UA', 'N933UA', 'N934UA', 'N936UA', 'N937UA' + D, 'N938UA', 'N940UA', 'N941UA', 'N942UA', 'N944UA' + E, 'N945UA', 'N946UA', 'N947UA', 'N948UA', 'N949UA' + F, 'N950UA', 'N951UA', 'N953UA', 'N954UA' + G, '034IR4RA','2OZYR4JA','4JPIR4RA','4QJYR4BA','A12YR4RA' + H, 'CE5YR4BA','G5GIR5BA','KTQYR3BA','NH5YR3BA','O2KYR4ZA' + J, 'PI1IR4ZA','QJ5IR5BA','QQZYR3ZA','RUMIR3ZA','TGPIR3JA' + K, 'UUEYR3ZA','VAVIR3ZA','WSAIR3JA','XV2YR3RA','YITYR4ZA' + L, 'ZZAYR4JA','35SYR4RA','5UUIR4BA','D5KYR5BA','ECOIR4BA'/ +cc +cc List of Delta MD88s to be flipped. +cc (from W. Moninger at FSL) +cc ---------------------------------- +c data cbadwind/'N900DE','N900DL','N901DE','N901DL','N902DE' +c A, 'N902DL','N903DE','N903DL','N904DE','N904DL','N905DE','N905DL' +c B, 'N906DE','N906DL','N907DE','N907DL','N908DE','N908DL','N909DE' +c C, 'N909DL','N910DE','N910DL','N911DE','N911DL','N912DE','N912DL' +c D, 'N913DL','N914DE','N914DL','N915DE','N915DL','N916DE','N916DL' +c E, 'N917DE','N917DL','N918DE','N918DL','N919DE','N919DL','N920DE' +c F, 'N920DL','N921DE','N921DL','N922DE','N922DL','N923DE','N923DL' +c G, 'N924DE','N924DL','N925DE','N925DL','N926DE','N926DL','N927DE' +c H, 'N927DL','N928DE','N928DL','N929DE','N929DL','N930DE','N930DL' +c I, 'N931DE','N931DL','N932DE','N932DL','N933DE','N933DL','N934DE' +c J, 'N934DL','N935DE','N935DL','N936DE','N936DL','N937DE','N937DL' +c K, 'N938DE','N938DL','N939DE','N939DL','N940DE','N940DL','N941DE' +c L, 'N941DL','N942DE','N942DL','N943DE','N943DL','N944DE','N945DE' +c M, 'N945DL','N946DE','N946DL','N947DE','N947DL','N948DE','N948DL' +c N, 'N949DE','N949DL','N950DE','N950DL','N951DE','N951DL','N952DE' +c O, 'N952DL','N953DE','N953DL','N954DE','N954DL','N955DE','N955DL' +c P, 'N956DE','N956DL','N957DE','N957DL','N958DE','N958DL','N959DE' +c Q, 'N959DL','N960DE','N960DL','N961DE','N961DL','N962DE','N962DL' +c R, 'N963DE','N963DL','N964DE','N964DL','N965DE','N965DL','N966DE' +c S, 'N966DL','N967DE','N967DL','N968DE','N968DL','N969DE','N969DL' +c T, 'N970DE','N970DL','N971DE','N971DL','N972DE','N972DL','N973DE' +c U, 'N973DL','N974DE','N974DL','N975DE','N975DL','N976DE','N976DL' +c V, 'N977DE','N977DL','N978DE','N978DL','N979DE','N979DL','N980DE' +c W, 'N980DL','N981DE','N981DL','N982DE','N982DL','N983DE','N983DL' +c X, 'N984DE','N984DL','N985DE','N985DL','N986DE','N986DL','N987DE' +c Y, 'N987DL','N988DE','N988DL','N989DE','N989DL','N990DE','N990DL' +c Z, 'N991DE','N991DL','N992DE','N992DL','N993DE','N993DL','N994DE' +c a, 'N994DL','N995DE','N995DL','N996DE','N996DL','N997DE','N997DL' +c b, 'N998DE','N998DL','N999DE','N999DL'/ +c +c Aircraft blacklisted for wind errors +c (from W. Moninger at FSL) +c ------------------------------------ + data cblkwind/'N508UA','N581UA','N586UA','N587UA','N902DL' + A, 'N904DL','N908DL','N909DL','N910DL','N911DL','N912DL' + B, 'N913DE','N913DL','N914DE','N914DL','N915DE','N915DL' + C, 'N916DL','N917DE','N917DL','N918DE','N918DL','N919DE' + D, 'N921DL','N922DL','N924DL','N926DL','N928DL','N929DL' + E, 'N930DL','N931DL','N933DL','N934DL','N936DL','N938DL' + F, 'N939DL','N940DL','N941DL','N942DL','N943DL','N944DL' + G, 'N948DL','N949DL','N950DL','N951DL','N952DL','N953DL' + H, 'N954DL','N955DL','N957DL','N958DL','N960DL','N964DL' + I, 'N964DL','N966DL','N967DL','N968DL','N969DL','N970DL' + J, 'N971DL','N972DL','N981DL','N983DL','N984DL','N985DL' + K, 'N986DL','N?O970'/ +c +c Aircraft blacklisted for temperature errors +c (from W. Moninger at FSL) +c ------------------------------------------- + data cblktemp/'N508UA','N581UA','N585UA','N586UA','N587UA' + A, 'N916UA','N917UA','N918UA','N919UA','N920UA','N921UA' + B, 'N922UA','N923UA','N924UA','N925UA','N926UA','N927UA' + C, 'N928UA','N929UA','N930UA','N931UA','N932UA','N933UA' + D, 'N934UA','N935UA','N936UA','N937UA','N938DL','N938UA' + E, 'N940UA','N941UA','N942UA','N944UA','N945UA','N946UA' + F, 'N947UA','N948UA','N949UA','N950UA','N951UA','N952UA' + G, 'N953UA','N954UA','N955UA','N985DL'/ +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # + +c Start subroutine. +c ----------------- + write(*,*) + write(*,*) '**********************' + write(*,*) 'Welcome to acftobs_qc' + call system('date') + write(*,*) '**********************' + write(*,*) + + numreps_orig = numreps ! need to save numreps_orig for input to INDEXC later +c +c Set up path for output files +c ---------------------------- + if(l_pc) then + l_init = .false. + l_do_innov = .true. +cc c_path = 'c:\MyFiles\acft_data\acftqc_tfile\' ! path for pc + c_path = 'c:\MyFiles\acft_data\acftqc_tfile\\' ! path for pc + call slen(c_path,lpath) +c + elseif(.not.l_operational) then + l_init = .true. + l_do_innov = .false. + call getenv('INNOVATIONS',c_path) + call slen(c_path,lpath) + c_path = c_path(1:lpath)//'acft/' ! path for Origin + call slen(c_path,lpath) +c + elseif(l_ncep) then + l_init = .true. ! init counters for each run + l_operational = .false. ! extra printout/log files = yes + l_do_innov = .true. + c_path = ' ' ! output will go to working directory + call slen(c_path,lpath) + +c Open log file for acftobs_qc. +c ----------------------------- +c open(io8,status='new') + + else + l_init = .true. + l_do_innov = .false. + endif +c +c Test if log file is already open +c -------------------------------- + print *, 'checking if io8 is open...' + + inquire(unit = io8,opened = l_opn) + print *, 'done checking if io8 is open...',l_opn +c +c Open file if not already open +c ----------------------------- + if(.not.l_opn) then + if(lpath.gt.0) then + logfile = c_path(1:lpath)//'acftqc_'//cdtg_an//'.log' + else + logfile = 'acftqc_'//cdtg_an//'.log' + endif + call slen(logfile,len) + print *, 'trying to open io8 ', trim(logfile) + open(unit = io8, file = logfile(1:len) + $, form = 'FORMATTED',status = 'UNKNOWN') + print *, 'done trying to open io8' + + endif +c + write(io8,*) + write(io8,*) 'Beginning acftobs_qc!' +c +c Open individual files for rejected data if the assigned unit is not opened +c (The io numbers may all be set equal to put all rejected data in same file.) +c ----------------------------------------------------------------------------- + if(.not.l_operational) then + inquire(unit = io30,opened = l_opn) + if(.not.l_opn) then + if(lpath.gt.0) then + infile30 = c_path(1:lpath)//'acftqc_'//cdtg_an//'.dup' + else + infile30 = 'acftqc_'//cdtg_an//'.dup' + endif + call slen(infile30,len) + open(unit = io30, file = infile30(1:len) + $, form = 'FORMATTED',status = 'UNKNOWN') + write(io8,*) + write(io8,*) infile30(1:len),' successfully opened' + else + write(io8,*) + write(io8,*) infile30(1:len),' already open' + endif +c + inquire(unit = io31,opened = l_opn) + if(.not.l_opn) then + if(lpath.gt.0) then + infile31 = c_path(1:lpath)//'acftqc_'//cdtg_an//'.spk' + else + infile31 = 'acftqc_'//cdtg_an//'.spk' + endif + call slen(infile31,len) + open(unit = io31, file = infile31(1:len) + $, form = 'FORMATTED',status = 'UNKNOWN') + write(io8,*) + write(io8,*) infile31(1:len),' successfully opened' + else + write(io8,*) + write(io8,*) infile31(1:len),' already open' + endif +c + inquire(unit = io32,opened = l_opn) + if(.not.l_opn) then + if(lpath.gt.0) then + infile32 = c_path(1:lpath)//'acftqc_'//cdtg_an//'.inv' + else + infile32 = 'acftqc_'//cdtg_an//'.inv' + endif + call slen(infile32,len) + open(unit = io32, file = infile32(1:len) + $, form = 'FORMATTED',status = 'UNKNOWN') + write(io8,*) + write(io8,*) infile32(1:len),' successfully opened' + else + write(io8,*) + write(io8,*) infile32(1:len),' already open' + endif +c + inquire(unit = io33,opened = l_opn) + if(.not.l_opn) then + if(lpath.gt.0) then + infile33 = c_path(1:lpath)//'acftqc_'//cdtg_an//'.stk' + else + infile33 = 'acftqc_'//cdtg_an//'.stk' + endif + call slen(infile33,len) + open(unit = io33, file = infile33(1:len) + $, form = 'FORMATTED',status = 'UNKNOWN') + write(io8,*) + write(io8,*) infile33(1:len),' successfully opened' + else + write(io8,*) + write(io8,*) infile33(1:len),' already open' + endif +c + inquire(unit = io34,opened = l_opn) + if(.not.l_opn) then + if(lpath.gt.0) then + infile34 = c_path(1:lpath)//'acftqc_'//cdtg_an//'.grc' + else + infile34 = 'acftqc_'//cdtg_an//'.grc' + endif + call slen(infile34,len) + open(unit = io34, file = infile34(1:len) + $, form = 'FORMATTED',status = 'UNKNOWN') + write(io8,*) + write(io8,*) infile34(1:len),' successfully opened' + else + write(io8,*) + write(io8,*) infile34(1:len),' already open' + endif +c + inquire(unit = io35,opened = l_opn) + if(.not.l_opn) then + if(lpath.gt.0) then + infile35 = c_path(1:lpath)//'acftqc_'//cdtg_an//'.inc' + else + infile35 = 'acftqc_'//cdtg_an//'.inc' + endif + call slen(infile35,len) + open(unit = io35, file = infile35(1:len) + $, form = 'FORMATTED',status = 'UNKNOWN') + write(io8,*) + write(io8,*) infile35(1:len),' successfully opened' + else + write(io8,*) + write(io8,*) infile35(1:len),' already open' + endif +c + inquire(unit = io36,opened = l_opn) + if(.not.l_opn) then + if(lpath.gt.0) then + infile36 = c_path(1:lpath)//'acftqc_'//cdtg_an//'.ord' + else + infile36 = 'acftqc_'//cdtg_an//'.ord' + endif + call slen(infile36,len) + open(unit = io36, file = infile36(1:len) + $, form = 'FORMATTED',status = 'UNKNOWN') + write(io8,*) + write(io8,*) infile36(1:len),' successfully opened' + else + write(io8,*) + write(io8,*) infile36(1:len),' already open' + endif +c + inquire(unit = io37,opened = l_opn) + if(.not.l_opn) then + if(lpath.gt.0) then + infile37 = c_path(1:lpath)//'acftqc_'//cdtg_an//'.sus' + else + infile37 = 'acftqc_'//cdtg_an//'.sus' + endif + call slen(infile37,len) + open(unit = io37, file = infile37(1:len) + $, form = 'FORMATTED',status = 'UNKNOWN') + write(io8,*) + write(io8,*) infile37(1:len),' successfully opened' + else + write(io8,*) + write(io8,*) infile37(1:len),' already open' + endif +c + inquire(unit = io38,opened = l_opn) + if(.not.l_opn) then + if(lpath.gt.0) then + infile38 = c_path(1:lpath)//'acftqc_'//cdtg_an//'.lst' + else + infile38 = 'acftqc_'//cdtg_an//'.lst' + endif + call slen(infile38,len) + open(unit = io38, file = infile38(1:len) + $, form = 'FORMATTED',status = 'UNKNOWN') + write(io8,*) + write(io8,*) infile38(1:len),' successfully opened' + else + write(io8,*) + write(io8,*) infile38(1:len),' already open' + endif + endif +c +c Initialize arrays +c ----------------- + do ii=1,max_reps + csort(ii) = 'zzzzzzzzzzzzzzzzzzzzzzzzz' + indx(ii) = ii + enddo +c + krej = 0 + maxflt_exceeded = 0 +c + kreg = 0 + if(l_first_date) then + kreg_tot = 0 + creg_reg_tot = 'xxxxxxxx' +c + if(.not.l_operational) then + nobs_reg_tot = 0 + nrej_reg_tot = 0 + nrej_inv_tot = 0 + nrej_stk_tot = 0 + nrej_grc_tot = 0 + nrej_pos_tot = 0 + nrej_ord_tot = 0 + nrej_sus_tot = 0 + nwhol_reg_tot = 0 + ntemp_reg_tot = 0 + nwind_reg_tot = 0 + endif +c + endif + l_first_date = .false. +c + ntot_reg = 0 +c +c Initialize aircraft data types +c ------------------------------ + i_acars = insty_ob_fun('acars') + i_acars_lvl = insty_ob_fun('acars_lvl') + i_acars_asc = insty_ob_fun('acars_asc') + i_acars_des = insty_ob_fun('acars_des') + i_mdcrs = insty_ob_fun('mdcrs') + i_mdcrs_lvl = insty_ob_fun('mdcrs_lvl') + i_mdcrs_asc = insty_ob_fun('mdcrs_asc') + i_mdcrs_des = insty_ob_fun('mdcrs_des') + i_man_airep = insty_ob_fun('man-airep') + i_man_Yairep = insty_ob_fun('man-Yairep') + i_airep = insty_ob_fun('airep') + i_airep_lvl = insty_ob_fun('airep_lvl') + i_airep_asc = insty_ob_fun('airep_asc') + i_airep_des = insty_ob_fun('airep_des') + i_amdar = insty_ob_fun('amdar') + i_amdar_lvl = insty_ob_fun('amdar_lvl') + i_amdar_asc = insty_ob_fun('amdar_asc') + i_amdar_des = insty_ob_fun('amdar_des') +c +c Output reports to log file if desired +c ------------------------------------- + l_print = .false. +c + if(l_print) then + write(io8,*) + write(io8,*) 'Reports before QC processing' + write(io8,*) '----------------------------' + call pr_workdata(max_reps,numreps,indx + x, alat,alon,pres,ht_ft,idt,idp,c_acftreg,c_acftid,itype + x, t_prcn,ob_t,ob_q,ob_dir,ob_spd + x, xiv_t,xiv_q,xiv_d,xiv_s,ichk_t,ichk_q,ichk_d,ichk_s + x, cdtg_an,c_qc,csort,io8) + endif +c +c Count reports by aircraft data type +c ----------------------------------- + knt_acars = 0 + knt_mdcrs = 0 + knt_man_airep = 0 + knt_man_Yairep = 0 + knt_airep = 0 + knt_amdar = 0 +c +c Form variable to sort--time + level + lat + lon + type +c (first sort is to check for duplicates) +c ------------------------------------------------------ + write(io8,*) + write(io8,*) 'Forming variable to sort--time+level+lat+lon+type' + write(io8,*) '-------------------------------------------------' +c + if(l_pc) call p_ddtg('Forming variable to sort',io8) +c + do ii=1,numreps +c + if(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des) then +c + knt_acars = knt_acars + 1 +c + elseif(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des) then +c + knt_mdcrs = knt_mdcrs + 1 +c + elseif(itype(ii).eq.i_man_airep) then +c + knt_man_airep = knt_man_airep + 1 +c + elseif(itype(ii).eq.i_man_Yairep) then +c + knt_man_Yairep = knt_man_Yairep + 1 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des) then +c + knt_airep = knt_airep + 1 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des) then +c + knt_amdar = knt_amdar + 1 + endif +c + kidt = idt(ii) + 100 000 + if(kidt.ge.1 000 000) + $ write(io8,*) 'kidt too large--',kidt + write(c_idt,'(i6)') kidt +c + if(ht_ft(ii).eq.amiss) then + c_ht_ft = '999999' + else + iht_ft = nint(ht_ft(ii)) + 100 000 + if(iht_ft.ge.200 000) then ! if nint(ht_ft(ii)) = 100,000 or greater + write(io8,*) + write(io8,*) 'iht_ft too large--',iht_ft + write (io8,8001) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii),pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii),idp(ii) + 8001 format(i6,1x,a8,1x,a8,1x,a9,1x + x, i7,1x,2f11.5,1x,f8.1,1x,f7.0,1x + x, f5.2,4(2(1x,f8.2),1x,i5),1x,i4) + iht_ft = imiss + endif + + if(iht_ft.ge.0) then + write(c_ht_ft,'(i6.6)') iht_ft + else + write(c_ht_ft,'(i6.5)') iht_ft + endif + endif +c +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alat(ii).eq.amiss) then + c_lat = '99999' + else + ilat = nint(alat(ii)*100.) + if(abs(ilat).ge.100 000) write(io8,*)'ilat too large--',ilat + write(c_lat,'(i5)') ilat + endif +c + if(alon(ii).eq.amiss) then + c_lon = '999999' + else + ilon = nint(alon(ii)*100.) + if(abs(ilon).ge.1 000 000) write(io8,*)'ilon too large--',ilon + write(c_lon,'(i6)') ilon + endif +c + c_type = c_insty_ob(itype(ii)) +c + csort(ii) = c_idt(1:6) + $ //c_ht_ft(1:6) +cc $ //c_ht_ft(1:5) + $ //c_lat(1:5) + $ //c_lon(1:6) + $ //c_type(1:2) + enddo +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c + write(io8,*) +ccccdak write(io8,*) 'Number of raw acars reports = ',knt_acars + write(io8,*) 'Number of raw tamdar reports = ',knt_acars + write(io8,*) 'Number of raw mdcrs reports = ',knt_mdcrs + write(io8,*) 'Number of raw man_airep reports = ',knt_man_airep + write(io8,*) 'Number of raw man_Yairep reports = ',knt_man_Yairep + write(io8,*) 'Number of raw airep reports = ',knt_airep + write(io8,*) 'Number of raw amdar reports = ',knt_amdar +c +c Sort reports in file according to array csort +c --------------------------------------------- + write(*,*) 'Sorting reports by time first' + write(io8,*) + write(io8,*) 'Sorting reports by time first' + write(io8,*) '-----------------------------' +c + if(l_pc) call p_ddtg('Calling INDEXC for the first sort',io8) +c + call INDEXC(numreps_orig,csort,indx) +c +c Output reports to log file if desired +c ------------------------------------- + l_print = .false. +c + if(l_print) then + write(io8,*) + write(io8,*) 'Reports after first sort' + write(io8,*) '------------------------' + call pr_workdata(max_reps,numreps,indx + x, alat,alon,pres,ht_ft,idt,idp,c_acftreg,c_acftid,itype + x, t_prcn,ob_t,ob_q,ob_dir,ob_spd + x, xiv_t,xiv_q,xiv_d,xiv_s,ichk_t,ichk_q,ichk_d,ichk_s + x, cdtg_an,c_qc,csort,io8) + endif +c +c Perform first pass through data--duplicate removal +c -------------------------------------------------- + write(*,*)'Beginning 1st pass through data--duplicate removal' + write(io8,*) + write(io8,*)'Beginning 1st pass through data--duplicate removal' + write(io8,*)'----------------------------------------------------' +c + if(l_pc) call p_ddtg('Calling dupchek_qc',io8) +c + call dupchek_qc(numreps,max_reps,maxflt,htdif_same + $, c_acftreg,c_acftid,c_qc,cdtg_an + $, alat,alon,pres,ht_ft,t_prcn,ob_t,ob_q,ob_dir,ob_spd + $, xiv_t,xiv_q,xiv_d,xiv_s + $, idt,itype,ichk_t,ichk_q,ichk_d,ichk_s,kbadtot + $, kreg,creg_reg,nobs_reg,nrej_reg,ntemp_reg,nwind_reg + $, indx,csort,amiss,imiss,io8,io30,l_last,l_operational,l_init + $, l_ncep,*199) + go to 198 + 199 continue + print *, '----------------------------------------------------' + print *, '~~~> maxflt_exceeded -- coming out of call to dupchk' + print *, '----------------------------------------------------' + maxflt_exceeded = 1 + 198 continue + kreg_max = kreg + kreg_tot_max = kreg_tot +cppppp +cc print *, 'after call to dupchek_qc kreg, kreg_tot: ', +cc $ kreg, kreg_tot +cc print *, 'kreg_max, kreg_tot_max: ',kreg_max, kreg_tot_max +cppppp +c + if(l_pc) call p_ddtg('Back from dupchek_qc',io8) +c +c Re-order index array to skip bad reports +c ---------------------------------------- + l_flight = .false. + l_print = .false. + if(kbadtot.gt.0) then + call reorder(l_flight,numreps,max_reps,indx,krej,in_bad + $, io8,l_print,cregmiss,csort,c_acftid,itype + $, kflight,maxflt,cid_flt,creg_flt,nobs_flt,ntot_flt + $, nrej_flt,iobs_flt,cid_flt_old,ntot_flt_old,nrej_flt_old + $, kreg,creg_reg,nobs_reg,nrej_reg,c_acftreg,l_newflt) + kflight_max = kflight + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call 1 to reorder kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp + +c + endif +c +c Output reports to log file if desired +c ------------------------------------- + l_print = .false. +c + if(l_print) then + write(io8,*) + write(io8,*) 'Reports after duplicate removal' + write(io8,*) '-------------------------------' + call pr_workdata(max_reps,numreps,indx + x, alat,alon,pres,ht_ft,idt,idp,c_acftreg,c_acftid,itype + x, t_prcn,ob_t,ob_q,ob_dir,ob_spd + x, xiv_t,xiv_q,xiv_d,xiv_s,ichk_t,ichk_q,ichk_d,ichk_s + x, cdtg_an,c_qc,csort,io8) + endif +c +c Generate master list of tail numbers and counts +c ----------------------------------------------- + if(l_pc) call p_ddtg('Setting up master list of tail numbers',io8) +c + do mm=1,kreg + l_found = .false. +c + if(kreg_tot.ne.0) then + do ii=1,kreg_tot + if(creg_reg(mm)(1:8).eq.creg_reg_tot(ii)(1:8)) then + if(.not.l_operational) then + nobs_reg_tot(ii,1:5) = nobs_reg_tot(ii,1:5) + nobs_reg(mm,1:5) + l_found = .true. + endif + endif + enddo + endif +c + if(.not.l_found) then + kreg_tot = kreg_tot + 1 + if(kreg_tot.gt.maxflt) then +c............................................................................................ + write(*,*) 'WARNING: kreg_tot > maxflt--',kreg_tot + +c There are more flights in input file than "maxflt" -- stop abnormally with c. code 98 +c (can't be sure continuing on w/o processing any more data would turn out ok) +c -------------------------------------------------------------------------------------- + print 53, maxflt + 53 format(/' #####> WARNING: THERE ARE MORE THAN ',I6,' AIRCRAFT ', + + '"FLIGHTS" IN INPUT FILE -- MUST INCREASE SIZE OF PARAMETER ', + + 'NMAE "MAXFLT" - STOP 98'/) + + write(cmaxflt,'(i6)') maxflt + call system('[ -n "$jlogfile" ] && $DATA/postmsg'// + + ' "$jlogfile" "***WARNING:'//cmaxflt//' AIRCRAFT "FLIGHT" '// + + 'LIMIT EXCEEDED IN PREPOBS_PREPACQC, STOP 98"') + + call w3tage('PREPOBS_PREPACQC') + call errexit(98) +c............................................................................................ + endif + creg_reg_tot(kreg_tot)(1:8) = creg_reg(mm)(1:8) +c + if(.not.l_operational) then + nobs_reg_tot(kreg_tot,1:5) = nobs_reg(mm,1:5) + endif + endif + enddo +c + do mm=1,kreg + do ii=1,kreg_tot + if(creg_reg(mm)(1:8).eq.creg_reg_tot(ii)(1:8).and. + $ creg_reg(mm).ne.'xxxxxxxx') then +c + if(.not.l_operational) then + ntemp_reg_tot(ii,1:5)=ntemp_reg_tot(ii,1:5)+ntemp_reg(mm,1:5) + nwind_reg_tot(ii,1:5)=nwind_reg_tot(ii,1:5)+nwind_reg(mm,1:5) + nrej_reg_tot(ii,1:5)=nrej_reg_tot(ii,1:5)+nrej_reg(mm,1:5) + endif +c + ntot_reg(mm,1:5)=ntot_reg(mm,1:5)+nrej_reg(mm,1:5) + endif + enddo + enddo +c +c Output innovation distributions +c ------------------------------- + if(l_do_innov.and.(.not.l_operational)) then +c + if(l_pc) call p_ddtg('Calling innov_qc',io8) +c + call innov_qc(max_reps,numreps,indx,xiv_t,xiv_d,xiv_s,amiss, + $ c_qc,1,io8,l_init,l_innov_miss) + endif +c +c Examine first digit distribution for comparison with Benford's law +c Perform after duplicate check and before other QC checks +c ------------------------------------------------------------------ + if(l_do_innov.and. + $ (.not.l_operational).and. + $ (.not.l_innov_miss)) then +c + if(l_pc) call p_ddtg('Calling benford_qc',io8) +c + call benford_qc(max_reps,numreps,indx,xiv_t,xiv_d,xiv_s,amiss, + $ c_acftreg,itype,maxflt,kreg_tot,creg_reg_tot, + $ c_qc,lead_t_tot,lead_d_tot,lead_s_tot, + $ n_xiv_t,n_xiv_d,n_xiv_s, + $ sum_xiv_t,sum_xiv_d,sum_xiv_s, + $ sumabs_xiv_t,sumabs_xiv_d,sumabs_xiv_s,1,io8 + $, l_init,l_last) + kflight_max = max(kflight,kflight_max) + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call 1 to benford_qc kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp + endif +c +c Perform second pass through data--spike check +c --------------------------------------------- + write(*,*)'Beginning 2nd pass through data--spike check' + write(io8,*) + write(io8,*)'Beginning 2nd pass through data--spike check' + write(io8,*)'--------------------------------------------' +c + if(l_pc) call p_ddtg('Calling spike_qc',io8) +c + call spike_qc(numreps,max_reps,c_acftreg,c_acftid,c_qc + $, alat,alon,pres,ht_ft,t_prcn,ob_t,ob_q,ob_dir,ob_spd + $, xiv_t,xiv_q,xiv_d,xiv_s,idt,itype,ichk_t,ichk_q + $, ichk_d,ichk_s,kbadtot,indx,csort,amiss,imiss,io8 + $, io31,cdtg_an,l_operational,l_init) +c + if(l_pc) call p_ddtg('Back from spike_qc',io8) +c +c Re-order index array to skip bad reports +c ---------------------------------------- + l_flight = .false. + l_print = .false. + if(kbadtot.gt.0) then + call reorder(l_flight,numreps,max_reps,indx,krej,in_bad + $, io8,l_print,cregmiss,csort,c_acftid,itype + $, kflight,maxflt,cid_flt,creg_flt,nobs_flt,ntot_flt + $, nrej_flt,iobs_flt,cid_flt_old,ntot_flt_old,nrej_flt_old + $, kreg,creg_reg,nobs_reg,nrej_reg,c_acftreg,l_newflt) + kflight_max = max(kflight,kflight_max) + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call 2 to reorder kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp +c + do mm=1,kreg + do ii=1,kreg_tot + if(creg_reg(mm)(1:8).eq.creg_reg_tot(ii)(1:8).and. + $ creg_reg(mm).ne.'xxxxxxxx') then + + if(.not.l_operational) then + nrej_inv_tot(ii,1:5)=nrej_inv_tot(ii,1:5)+nrej_reg(mm,1:5) + nrej_reg_tot(ii,1:5)=nrej_reg_tot(ii,1:5)+nrej_reg(mm,1:5) + endif +c + ntot_reg(mm,1:5)=ntot_reg(mm,1:5)+nrej_reg(mm,1:5) + endif + enddo + enddo + endif +c +c Output reports to log file if desired +c ------------------------------------- + l_print = .false. +c + if(l_print) then + write(io8,*) + write(io8,*) 'Reports after spike check' + write(io8,*) '-------------------------' + call pr_workdata(max_reps,numreps,indx + x, alat,alon,pres,ht_ft,idt,idp,c_acftreg,c_acftid,itype + x, t_prcn,ob_t,ob_q,ob_dir,ob_spd + x, xiv_t,xiv_q,xiv_d,xiv_s,ichk_t,ichk_q,ichk_d,ichk_s + x, cdtg_an,c_qc,csort,io8) + endif +c +c Form variable to sort--flight number + time + level + type +c (second sort is to begin to form tracks) +c ---------------------------------------------------------- + write(io8,*) + write(io8,*) 'Forming variable to sort--flight#+time+level+type' + write(io8,*) '-------------------------------------------------' +c + if(l_pc) call p_ddtg('Forming variable for second sort',io8) +c + do iob=1,numreps + ii = indx(iob) +c +c Exclude previously rejected reports +c ----------------------------------- + if(csort(ii)(1:5).eq.'badob') then + csort(ii) = 'zzzzzzzzzzzzzzzzzzzzzzzzz' +c write(io8,*) 'badob found for iob = ',iob,' ii = ',ii +c + elseif(csort(ii).ne.'zzzzzzzzzzzzzzzzzzzzzzzzz') then +c + kidt = idt(ii) + 100 000 + if(kidt.ge.1 000 000) write(io8,*) 'kidt too large--',kidt + write(c_idt,'(i6)') kidt +c + if(ht_ft(ii).eq.amiss) then + c_ht_ft = '999999' + else + iht_ft = nint(ht_ft(ii)) + 100 000 + if(iht_ft.ge.200 000) then ! if nint(ht_ft(iob)) = 100,000 or greater + write(io8,*) 'iht_ft too large--',iht_ft + write (io8,8001) iob,c_insty_ob(itype(iob)) + x, c_acftreg(iob),c_acftid(iob) + x, idt(iob),alat(iob),alon(iob),pres(iob),ht_ft(iob) + x, t_prcn(iob),ob_t(iob),xiv_t(iob),ichk_t(iob) + x, ob_q(iob),xiv_q(iob),ichk_q(iob) + x, ob_dir(iob),xiv_d(iob),ichk_d(iob) + x, ob_spd(iob),xiv_s(iob),ichk_s(iob),idp(iob) + iht_ft = imiss + endif + + if(iht_ft.ge.0) then + write(c_ht_ft,'(i6.6)') iht_ft + else + write(c_ht_ft,'(i6.5)') iht_ft + endif + endif +c + c_type = c_insty_ob(itype(ii)) +c + csort(ii) = c_acftid(ii)(1:9) + $ //c_idt(1:6) + $ //c_ht_ft(1:6) + $ //c_type(1:2) + $ //' ' + endif + enddo +c +c Sort reports in file according to array csort +c --------------------------------------------- + write(*,*) 'Sorting reports by flight number first' + write(io8,*) + write(io8,*) 'Sorting reports by flight number first' + write(io8,*) '--------------------------------------' +c + if(l_pc) call p_ddtg('Calling INDEXC for second sort',io8) +c + call INDEXC(numreps_orig,csort,indx) +c +c Output reports to log file if desired +c ------------------------------------- + l_print = .false. +c + if(l_print) then + write(io8,*) + write(io8,*) 'Reports after second sort' + write(io8,*) '-------------------------' + call pr_workdata(max_reps,numreps,indx + x, alat,alon,pres,ht_ft,idt,idp,c_acftreg,c_acftid,itype + x, t_prcn,ob_t,ob_q,ob_dir,ob_spd + x, xiv_t,xiv_q,xiv_d,xiv_s,ichk_t,ichk_q,ichk_d,ichk_s + x, cdtg_an,c_qc,csort,io8) + endif +c +c Determine starting index for each flight and number of reports per flight +c ------------------------------------------------------------------------- + write(*,*) 'Determine starting index/length for each flight' + write(io8,*) + write(io8,*) 'Determine starting index/length for each flight' + write(io8,*) '-----------------------------------------------' +c + if(l_pc) call p_ddtg('Calling do_flt',io8) +c + l_first = .true. + l_print = .false. + call do_flt(l_first,numreps,max_reps,c_acftid,c_acftreg,idt, + $ ht_ft,cidmiss,cregmiss,indx,idt_samflt, + $ kflight,maxflt,cid_flt,creg_flt,nobs_flt,ntot_flt, + $ nrej_flt,iobs_flt,csort,l_sort,l_print,amiss,io8,*299) + go to 298 + 299 continue + print *, '-------------------------------------------------------' + print *, '~~~> maxflt_exceeded -- coming out of call #1 to do_flt' + print *, '-------------------------------------------------------' + maxflt_exceeded = 1 + 298 continue + kflight_max = max(kflight,kflight_max) + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call 1 to do_flt kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp +c +c Re-sort if flight number with two tail numbers was found +c -------------------------------------------------------- + if(l_sort) then +c + write(*,*) 'Re-sorting reports by flight number first' + write(io8,*) + write(io8,*) 'Re-sorting reports by flight number first' + write(io8,*) '-----------------------------------------' +c + if(l_pc) call p_ddtg('Calling INDEXC to redo second sort',io8) +c + call INDEXC(numreps_orig,csort,indx) +c +c Redo starting index for each flight and number of reports per flight +c -------------------------------------------------------------------- + if(l_pc) call p_ddtg('Calling do_flt after re-sort',io8) +c + l_first = .false. + l_print = .false. + call do_flt(l_first,numreps,max_reps,c_acftid,c_acftreg,idt, + $ ht_ft,cidmiss,cregmiss,indx,idt_samflt, + $ kflight,maxflt,cid_flt,creg_flt,nobs_flt,ntot_flt, + $ nrej_flt,iobs_flt,csort,l_sort,l_print,amiss,io8,*399) + go to 398 + 399 continue + print *, '-------------------------------------------------------' + print *, '~~~> maxflt_exceeded -- coming out of call #2 to do_flt' + print *, '-------------------------------------------------------' + maxflt_exceeded = 1 + 398 continue + kflight_max = max(kflight,kflight_max) + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call 2 to do_flt kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp +c +c Output reports to log file if desired +c ------------------------------------- +c DAK: may want to set l_print=F below to save time and space in prod runs + l_print = .true. +c + if(l_print) then + write(io8,*) + write(io8,*) 'Reports after re-sort' + write(io8,*) '---------------------' + call pr_workdata(max_reps,numreps,indx + x, alat,alon,pres,ht_ft,idt,idp,c_acftreg,c_acftid,itype + x, t_prcn,ob_t,ob_q,ob_dir,ob_spd + x, xiv_t,xiv_q,xiv_d,xiv_s,ichk_t,ichk_q,ichk_d,ichk_s + x, cdtg_an,c_qc,csort,io8) + endif + endif +c +c Perform third pass through data--invalid data check +c --------------------------------------------------- + write(*,*)'Beginning 3rd pass through data--invalid data check' + write(io8,*) + write(io8,*)'Beginning 3rd pass through data--invalid data check' + write(io8,*)'---------------------------------------------------' +c + if(l_pc) call p_ddtg('Calling invalid_qc',io8) +c + call invalid_qc(numreps,max_reps,c_acftreg,c_acftid,c_qc + $, alat,alon,pres,ht_ft,t_prcn,ob_t,ob_q,ob_dir,ob_spd + $, xiv_t,xiv_q,xiv_d,xiv_s,maxflt,kreg,creg_reg,ntemp_reg + $, idt,itype,ichk_t,ichk_q,ichk_d,ichk_s,kbadtot,n_minus9C + $, indx,csort,amiss,imiss,io8,io32,l_operational,l_init + $, cdtg_an,l_minus9c) + kflight_max = max(kflight,kflight_max) + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call to invalid_qc kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp +c + if(l_pc) call p_ddtg('Back from invalid_qc',io8) +c +c Re-order index array to skip bad reports +c ---------------------------------------- + l_flight = .true. + l_print = .true. + if(kbadtot.gt.0) then + call reorder(l_flight,numreps,max_reps,indx,krej,in_bad + $, io8,l_print,cregmiss,csort,c_acftid,itype + $, kflight,maxflt,cid_flt,creg_flt,nobs_flt,ntot_flt + $, nrej_flt,iobs_flt,cid_flt_old,ntot_flt_old,nrej_flt_old + $, kreg,creg_reg,nobs_reg,nrej_reg,c_acftreg,l_newflt) + kflight_max = max(kflight,kflight_max) + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call 3 to reorder kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp +c + do mm=1,kreg + do ii=1,kreg_tot + if(creg_reg(mm)(1:8).eq.creg_reg_tot(ii)(1:8).and. + $ creg_reg(mm).ne.'xxxxxxxx') then + + if(.not.l_operational) then + nrej_inv_tot(ii,1:5)=nrej_inv_tot(ii,1:5)+nrej_reg(mm,1:5) + nrej_reg_tot(ii,1:5)=nrej_reg_tot(ii,1:5)+nrej_reg(mm,1:5) + endif +c + ntot_reg(mm,1:5)=ntot_reg(mm,1:5)+nrej_reg(mm,1:5) + endif + enddo + enddo + endif +c + if(.not.l_operational) then + do mm=1,kreg + do ii=1,kreg_tot + if(creg_reg(mm)(1:8).eq.creg_reg_tot(ii)(1:8).and. + $ creg_reg(mm).ne.'xxxxxxxx') then + ntemp_reg_tot(ii,1:5)=ntemp_reg_tot(ii,1:5)+ntemp_reg(mm,1:5) + endif + enddo + enddo + endif +c +c Output reports to log file if desired +c ------------------------------------- + l_print = .false. +c + if(l_print) then + write(io8,*) + write(io8,*) 'Reports after invalid data check' + write(io8,*) '--------------------------------' + call pr_workdata(max_reps,numreps,indx + x, alat,alon,pres,ht_ft,idt,idp,c_acftreg,c_acftid,itype + x, t_prcn,ob_t,ob_q,ob_dir,ob_spd + x, xiv_t,xiv_q,xiv_d,xiv_s,ichk_t,ichk_q,ichk_d,ichk_s + x, cdtg_an,c_qc,csort,io8) + endif +c +c Perform fourth pass through data--reports with stuck values +c ---------------------------------------------------------- + write(*,*) 'Beginning 4th pass through data--stuck values' + write(io8,*) + write(io8,*) 'Beginning 4th pass through data--stuck values' + write(io8,*) '---------------------------------------------' +c + if(l_pc) call p_ddtg('Calling stk_val_qc',io8) +c + call stk_val_qc(numreps,max_reps,indx,csort,amiss,cdtg_an + $, c_acftreg,c_acftid,c_qc + $, alat,alon,pres,ht_ft,t_prcn,ob_t,ob_q,ob_dir,ob_spd + $, xiv_t,xiv_q,xiv_d,xiv_s + $, idt,itype,ichk_t,ichk_q,ichk_d,ichk_s + $, kflight,maxflt,nobs_flt,iobs_flt + $, kreg,creg_reg,nwhol_reg,ntemp_reg,nwind_reg + $, kbadtot,io8,io33,l_operational,l_init,l_ncep) + kflight_max = max(kflight,kflight_max) + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call to stk_val_qc kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp +c + if(l_pc) call p_ddtg('Back from stk_val_qc',io8) +c +c Re-order index array to skip bad reports +c ---------------------------------------- + l_flight = .true. + l_print = .true. + if(kbadtot.gt.0) then + call reorder(l_flight,numreps,max_reps,indx,krej,in_bad + $, io8,l_print,cregmiss,csort,c_acftid,itype + $, kflight,maxflt,cid_flt,creg_flt,nobs_flt,ntot_flt + $, nrej_flt,iobs_flt,cid_flt_old,ntot_flt_old,nrej_flt_old + $, kreg,creg_reg,nobs_reg,nrej_reg,c_acftreg,l_newflt) + kflight_max = max(kflight,kflight_max) + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call 4 to reorder kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp +c + do mm=1,kreg + do ii=1,kreg_tot + if(creg_reg(mm)(1:8).eq.creg_reg_tot(ii)(1:8).and. + $ creg_reg(mm).ne.'xxxxxxxx') then +c + if(.not.l_operational) then + nrej_stk_tot(ii,1:5)=nrej_stk_tot(ii,1:5)+nrej_reg(mm,1:5) + nrej_reg_tot(ii,1:5)=nrej_reg_tot(ii,1:5)+nrej_reg(mm,1:5) + endif +c + ntot_reg(mm,1:5)=ntot_reg(mm,1:5)+nrej_reg(mm,1:5) + endif + enddo + enddo + endif +c + if(.not.l_operational) then + do mm=1,kreg + do ii=1,kreg_tot + if(creg_reg(mm)(1:8).eq.creg_reg_tot(ii)(1:8).and. + $ creg_reg(mm).ne.'xxxxxxxx') then + nwhol_reg_tot(ii,1:5)=nwhol_reg_tot(ii,1:5)+nwhol_reg(mm,1:5) + ntemp_reg_tot(ii,1:5)=ntemp_reg_tot(ii,1:5)+ntemp_reg(mm,1:5) + nwind_reg_tot(ii,1:5)=nwind_reg_tot(ii,1:5)+nwind_reg(mm,1:5) + endif + enddo + enddo + endif +c +c Output reports to log file if desired +c ------------------------------------- + l_print = .false. +c + if(l_print) then + write(io8,*) + write(io8,*) 'Reports after stuck value check' + write(io8,*) '-------------------------------' + call pr_workdata(max_reps,numreps,indx + x, alat,alon,pres,ht_ft,idt,idp,c_acftreg,c_acftid,itype + x, t_prcn,ob_t,ob_q,ob_dir,ob_spd + x, xiv_t,xiv_q,xiv_d,xiv_s,ichk_t,ichk_q,ichk_d,ichk_s + x, cdtg_an,c_qc,csort,io8) + endif +c +c Perform fifth pass through data--gross checks +c --------------------------------------------- + write(*,*) 'Beginning 5th pass through data--gross checks' + write(io8,*) + write(io8,*) 'Beginning 5th pass through data--gross checks' + write(io8,*) '---------------------------------------------' +c + if(l_pc) call p_ddtg('Calling grchek_qc',io8) +c + call grchek_qc(numreps,max_reps,indx,csort,amiss,cdtg_an + $, c_acftreg,c_acftid,c_qc + $, alat,alon,pres,ht_ft,t_prcn,ob_t,ob_q,ob_dir,ob_spd + $, xiv_t,xiv_q,xiv_d,xiv_s + $, idt,itype,ichk_t,ichk_q,ichk_d,ichk_s + $, cbadtemp,nbadtemp + $, cblkwind,nblkwind,cblktemp,nblktemp,kbadtot,io8,io34 + $, maxflt,kreg,creg_reg,nwhol_reg,nwind_reg + $, ft2m,l_operational,l_init) + kflight_max = max(kflight,kflight_max) + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call to grchek_qc kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp +c + if(l_pc) call p_ddtg('Back from grchek_qc',io8) +c +c Re-order index array to skip bad reports +c ---------------------------------------- + l_flight = .true. + l_print = .true. + if(kbadtot.gt.0) then + call reorder(l_flight,numreps,max_reps,indx,krej,in_bad + $, io8,l_print,cregmiss,csort,c_acftid,itype + $, kflight,maxflt,cid_flt,creg_flt,nobs_flt,ntot_flt + $, nrej_flt,iobs_flt,cid_flt_old,ntot_flt_old,nrej_flt_old + $, kreg,creg_reg,nobs_reg,nrej_reg,c_acftreg,l_newflt) + kflight_max = max(kflight,kflight_max) + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call 5 to reorder kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp +c + do mm=1,kreg + do ii=1,kreg_tot + if(creg_reg(mm)(1:8).eq.creg_reg_tot(ii)(1:8).and. + $ creg_reg(mm).ne.'xxxxxxxx') then + + if(.not.l_operational) then + nrej_grc_tot(ii,1:5)=nrej_grc_tot(ii,1:5)+nrej_reg(mm,1:5) + nrej_reg_tot(ii,1:5)=nrej_reg_tot(ii,1:5)+nrej_reg(mm,1:5) + endif +c + ntot_reg(mm,1:5)=ntot_reg(mm,1:5)+nrej_reg(mm,1:5) + endif + enddo + enddo + endif +c + if(.not.l_operational) then + do mm=1,kreg + do ii=1,kreg_tot + if(creg_reg(mm)(1:8).eq.creg_reg_tot(ii)(1:8).and. + $ creg_reg(mm).ne.'xxxxxxxx') then + nwhol_reg_tot(ii,1:5)=nwhol_reg_tot(ii,1:5)+nwhol_reg(mm,1:5) + nwind_reg_tot(ii,1:5)=nwind_reg_tot(ii,1:5)+nwind_reg(mm,1:5) + endif + enddo + enddo + endif +c +c Output reports to log file if desired +c ------------------------------------- + l_print = .false. +c + if(l_print) then + write(io8,*) + write(io8,*) 'Reports after gross check' + write(io8,*) '-------------------------' + call pr_workdata(max_reps,numreps,indx + x, alat,alon,pres,ht_ft,idt,idp,c_acftreg,c_acftid,itype + x, t_prcn,ob_t,ob_q,ob_dir,ob_spd + x, xiv_t,xiv_q,xiv_d,xiv_s,ichk_t,ichk_q,ichk_d,ichk_s + x, cdtg_an,c_qc,csort,io8) + endif +c +c Perform six pass through data +c Check for inconsistent altitudes or positions in duplicates +c ----------------------------------------------------------- + write(*,*) 'Beginning 6th pass through data--inconsistent posn' + write(io8,*) + write(io8,*) 'Beginning 6th pass through data--inconsistent posn' + write(io8,*) '--------------------------------------------------' +c + if(l_pc) call p_ddtg('Calling poschek_qc',io8) +c + call poschek_qc(numreps,max_reps,indx,csort,imiss,amiss + $, idt_updn,c_acftreg,c_acftid,cidmiss,c_qc,cdtg_an + $, alat,alon,pres,ht_ft,t_prcn,ob_t,ob_q,ob_dir,ob_spd + $, xiv_t,xiv_q,xiv_d,xiv_s + $, idt,itype,ichk_t,ichk_q,ichk_d,ichk_s + $, kflight,maxflt,nobs_flt,iobs_flt,kbadtot,io8,io35 + $, l_operational,l_init) + kflight_max = max(kflight,kflight_max) + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call to poschek_qc kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp +c + if(l_pc) call p_ddtg('Back from poschek_qc',io8) +c +c Re-order index array to skip bad reports +c ---------------------------------------- + l_flight = .true. + l_print = .true. + if(kbadtot.gt.0) then + call reorder(l_flight,numreps,max_reps,indx,krej,in_bad + $, io8,l_print,cregmiss,csort,c_acftid,itype + $, kflight,maxflt,cid_flt,creg_flt,nobs_flt,ntot_flt + $, nrej_flt,iobs_flt,cid_flt_old,ntot_flt_old,nrej_flt_old + $, kreg,creg_reg,nobs_reg,nrej_reg,c_acftreg,l_newflt) + kflight_max = max(kflight,kflight_max) + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call 6 to reorder kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp +c + do mm=1,kreg + do ii=1,kreg_tot + if(creg_reg(mm)(1:8).eq.creg_reg_tot(ii)(1:8).and. + $ creg_reg(mm).ne.'xxxxxxxx') then +c + if(.not.l_operational) then + nrej_pos_tot(ii,1:5)=nrej_pos_tot(ii,1:5)+nrej_reg(mm,1:5) + nrej_reg_tot(ii,1:5)=nrej_reg_tot(ii,1:5)+nrej_reg(mm,1:5) + endif +c + ntot_reg(mm,1:5)=ntot_reg(mm,1:5)+nrej_reg(mm,1:5) + endif + enddo + enddo + endif +c +c Output reports to log file if desired +c ------------------------------------- + l_print = .false. +c + if(l_print) then + write(io8,*) + write(io8,*) 'Reports after inconsistent position check' + write(io8,*) '-----------------------------------------' + call pr_workdata(max_reps,numreps,indx + x, alat,alon,pres,ht_ft,idt,idp,c_acftreg,c_acftid,itype + x, t_prcn,ob_t,ob_q,ob_dir,ob_spd + x, xiv_t,xiv_q,xiv_d,xiv_s,ichk_t,ichk_q,ichk_d,ichk_s + x, cdtg_an,c_qc,csort,io8) + endif +c +c Check ordering of near-duplicate reports +c ---------------------------------------- + write(io8,*) + write(io8,*) 'Check ordering of near-duplicates' + write(io8,*) '---------------------------------' +c + if(l_pc) call p_ddtg('Calling orddup_qc',io8) +c + call orddup_qc(max_reps,indx,isave,ht_ft,idt,alat,alon + $, kflight,maxflt,nobs_flt,iobs_flt + $, c_acftreg,c_acftid,cidmiss,idt_near,io8) + kflight_max = max(kflight,kflight_max) + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call to orddup_qc kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp +c + if(l_pc) call p_ddtg('Back from orddup_qc',io8) +c +c Output reports to log file if desired +c ------------------------------------- + l_print = .false. +c + if(l_print) then + write(io8,*) + write(io8,*) 'Reports after check of near-dup ordering' + write(io8,*) '----------------------------------------' + call pr_workdata(max_reps,numreps,indx + x, alat,alon,pres,ht_ft,idt,idp,c_acftreg,c_acftid,itype + x, t_prcn,ob_t,ob_q,ob_dir,ob_spd + x, xiv_t,xiv_q,xiv_d,xiv_s,ichk_t,ichk_q,ichk_d,ichk_s + x, cdtg_an,c_qc,csort,io8) + endif +c +c Perform seventh pass through data--check ordering of flights +c ------------------------------------------------------------ + write(*,*) 'Beginning 7th pass through data--ordering check' + write(io8,*) + write(io8,*) 'Beginning 7th pass through data--ordering check' + write(io8,*) '-----------------------------------------------' +c + if(l_pc) call p_ddtg('Calling ordchek_qc',io8) +c + call ordchek_qc(numreps,max_reps,indx,csort,imiss,amiss,idt_near + $, idt_updn,htdif_same,c_acftreg,c_acftid,cidmiss,c_qc + $, alat,alon,pres,ht_ft,t_prcn,ob_t,ob_q,ob_dir,ob_spd + $, xiv_t,xiv_q,xiv_d,xiv_s + $, idt,itype,ichk_t,ichk_q,ichk_d,ichk_s + $, kreg,creg_reg,nwind_reg + $, kflight,maxflt,nobs_flt,ntot_flt,iobs_flt,kbadtot + $, io8,io36,l_operational,l_init) + kflight_max = max(kflight,kflight_max) + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call to ordchek_qc kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp +c + if(l_pc) call p_ddtg('Back from ordchek_qc',io8) +c +c Re-order index array to skip bad reports +c ---------------------------------------- + l_flight = .true. + l_print = .true. + if(kbadtot.gt.0) then + call reorder(l_flight,numreps,max_reps,indx,krej,in_bad + $, io8,l_print,cregmiss,csort,c_acftid,itype + $, kflight,maxflt,cid_flt,creg_flt,nobs_flt,ntot_flt + $, nrej_flt,iobs_flt,cid_flt_old,ntot_flt_old,nrej_flt_old + $, kreg,creg_reg,nobs_reg,nrej_reg,c_acftreg,l_newflt) + kflight_max = max(kflight,kflight_max) + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call 7 to reorder kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp +c + do mm=1,kreg + do ii=1,kreg_tot + if(creg_reg(mm)(1:8).eq.creg_reg_tot(ii)(1:8).and. + $ creg_reg(mm).ne.'xxxxxxxx') then +c + if(.not.l_operational) then + nrej_ord_tot(ii,1:5)=nrej_ord_tot(ii,1:5)+nrej_reg(mm,1:5) + nrej_reg_tot(ii,1:5)=nrej_reg_tot(ii,1:5)+nrej_reg(mm,1:5) + endif +c + ntot_reg(mm,1:5)=ntot_reg(mm,1:5)+nrej_reg(mm,1:5) + endif + enddo + enddo + endif +c + if(.not.l_operational) then + do mm=1,kreg + do ii=1,kreg_tot + if(creg_reg(mm)(1:8).eq.creg_reg_tot(ii)(1:8).and. + $ creg_reg(mm).ne.'xxxxxxxx') then + nwind_reg_tot(ii,1:5)=nwind_reg_tot(ii,1:5)+nwind_reg(mm,1:5) + endif + enddo + enddo + endif +c +c Output reports to log file if desired +c ------------------------------------- + l_print = .false. +c + if(l_print) then + write(io8,*) + write(io8,*) 'Reports after ordering check' + write(io8,*) '----------------------------' + call pr_workdata(max_reps,numreps,indx + x, alat,alon,pres,ht_ft,idt,idp,c_acftreg,c_acftid,itype + x, t_prcn,ob_t,ob_q,ob_dir,ob_spd + x, xiv_t,xiv_q,xiv_d,xiv_s,ichk_t,ichk_q,ichk_d,ichk_s + x, cdtg_an,c_qc,csort,io8) + endif +c +c Perform eighth pass through data--suspect data check +c ---------------------------------------------------- + write(*,*) 'Beginning 8th pass through data--suspect check' + write(io8,*) + write(io8,*) 'Beginning 8th pass through data--suspect check' + write(io8,*) '----------------------------------------------' +c +c Re-examine data flagged as suspect +c ---------------------------------- + if(l_pc) call p_ddtg('Calling suspect_qc',io8) +c + call suspect_qc(numreps,max_reps,indx,csort,imiss,idt_near,amiss + $, c_acftreg,c_acftid,c_qc + $, alat,alon,pres,ht_ft,t_prcn,ob_t,ob_q,ob_dir,ob_spd + $, xiv_t,xiv_q,xiv_d,xiv_s + $, idt,itype,ichk_t,ichk_q,ichk_d,ichk_s + $, maxflt,kflight,creg_flt,nobs_flt,ntot_flt + $, nrej_flt,iobs_flt,kreg,creg_reg,nobs_reg,nwind_reg + $, ntot_reg,kbadtot,io8,io37,l_operational,l_init) + kflight_max = max(kflight,kflight_max) + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call to suspect_qc kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp +c + if(l_pc) call p_ddtg('Back from suspect_qc',io8) +c +c Re-order index array to skip bad reports +c ---------------------------------------- + l_flight = .true. + l_print = .true. + if(kbadtot.gt.0) then + call reorder(l_flight,numreps,max_reps,indx,krej,in_bad + $, io8,l_print,cregmiss,csort,c_acftid,itype + $, kflight,maxflt,cid_flt,creg_flt,nobs_flt,ntot_flt + $, nrej_flt,iobs_flt,cid_flt_old,ntot_flt_old,nrej_flt_old + $, kreg,creg_reg,nobs_reg,nrej_reg,c_acftreg,l_newflt) + kflight_max = max(kflight,kflight_max) + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call 8 to reorder kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp +c + do mm=1,kreg + do ii=1,kreg_tot + if(creg_reg(mm)(1:8).eq.creg_reg_tot(ii)(1:8).and. + $ creg_reg(mm).ne.'xxxxxxxx') then +c + if(.not.l_operational) then + nrej_sus_tot(ii,1:5)=nrej_sus_tot(ii,1:5)+nrej_reg(mm,1:5) + nrej_reg_tot(ii,1:5)=nrej_reg_tot(ii,1:5)+nrej_reg(mm,1:5) + endif +c + ntot_reg(mm,1:5)=ntot_reg(mm,1:5)+nrej_reg(mm,1:5) + endif + enddo + enddo + endif +c + if(.not.l_operational) then + do mm=1,kreg + do ii=1,kreg_tot + if(creg_reg(mm)(1:8).eq.creg_reg_tot(ii)(1:8).and. + $ creg_reg(mm).ne.'xxxxxxxx') then + nwind_reg_tot(ii,1:5)=nwind_reg_tot(ii,1:5)+nwind_reg(mm,1:5) + endif + enddo + enddo + endif +c +c Output reports to log file if desired +c ------------------------------------- + l_print = .false. +c + if(l_print) then + write(io8,*) + write(io8,*) 'Reports after suspect data check' + write(io8,*) '--------------------------------' + call pr_workdata(max_reps,numreps,indx + x, alat,alon,pres,ht_ft,idt,idp,c_acftreg,c_acftid,itype + x, t_prcn,ob_t,ob_q,ob_dir,ob_spd + x, xiv_t,xiv_q,xiv_d,xiv_s,ichk_t,ichk_q,ichk_d,ichk_s + x, cdtg_an,c_qc,csort,io8) + endif +c +c Perform ninth pass through data--reject list check +c -------------------------------------------------- + write(*,*) 'Beginning 9th pass through data--reject list check' + write(io8,*) + write(io8,*) 'Beginning 9th pass through data--reject list check' + write(io8,*) '--------------------------------------------------' +c + if(l_pc) call p_ddtg('Calling rejlist_qc',io8) +c + call rejlist_qc(numreps,max_reps,indx,csort + $, c_acftreg,c_acftid,c_qc + $, alat,alon,pres,ht_ft,t_prcn,ob_t,ob_q,ob_dir,ob_spd + $, xiv_t,xiv_q,xiv_d,xiv_s + $, idt,itype,ichk_t,ichk_q,ichk_d,ichk_s + $, nchk_t,nchk_q,nchk_d,nchk_s + $, maxflt,kreg,creg_reg,nwind_reg,ntemp_reg + $, kbadtot,io8,io38,l_operational,l_init,l_ncep) + kflight_max = max(kflight,kflight_max) + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call to rejlist_qc kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp +c + if(l_pc) call p_ddtg('Back from rejlist_qc',io8) +c +c Re-order index array to skip bad reports +c ---------------------------------------- + l_flight = .true. + l_print = .true. + if(kbadtot.gt.0) then + call reorder(l_flight,numreps,max_reps,indx,krej,in_bad + $, io8,l_print,cregmiss,csort,c_acftid,itype + $, kflight,maxflt,cid_flt,creg_flt,nobs_flt,ntot_flt + $, nrej_flt,iobs_flt,cid_flt_old,ntot_flt_old,nrej_flt_old + $, kreg,creg_reg,nobs_reg,nrej_reg,c_acftreg,l_newflt) + kflight_max = max(kflight,kflight_max) + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call 9 to reorder kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp + endif +c + if(.not.l_operational) then + do mm=1,kreg + do ii=1,kreg_tot + if(creg_reg(mm)(1:8).eq.creg_reg_tot(ii)(1:8).and. + $ creg_reg(mm).ne.'xxxxxxxx') then + ntemp_reg_tot(ii,1:5)=ntemp_reg_tot(ii,1:5)+ntemp_reg(mm,1:5) + nwind_reg_tot(ii,1:5)=nwind_reg_tot(ii,1:5)+nwind_reg(mm,1:5) + endif + enddo + enddo + endif +c +c Output reports to log file if desired +c ------------------------------------- + l_print = .false. +c + if(l_print) then + write(io8,*) + write(io8,*) 'Reports after reject list check' + write(io8,*) '-------------------------------' + call pr_workdata(max_reps,numreps,indx + x, alat,alon,pres,ht_ft,idt,idp,c_acftreg,c_acftid,itype + x, t_prcn,ob_t,ob_q,ob_dir,ob_spd + x, xiv_t,xiv_q,xiv_d,xiv_s,ichk_t,ichk_q,ichk_d,ichk_s + x, cdtg_an,c_qc,csort,io8) + endif +c +c write(io8,*) +c write(io8,*) 'Post-QC reports from HZMYCWBA,415IC1BA, or JHCWUURA' +c write(io8,*) '---------------------------------------------------' +c do iob = 1,max_reps +c ii = iob +cc if(c_acftreg(ii)(1:8).eq.'HZMYCWBA'.or. +cc $ c_acftreg(ii)(1:8).eq.'415IC1BA'.or. +cc $ c_acftreg(ii)(1:8).eq.'JHCWUURA') then +c if(c_acftreg(ii)(1:8).eq.'HN3ICWBA'.or. +c $ c_acftreg(ii)(1:8).eq.'JSYYCURA'.or. +c $ c_acftreg(ii)(1:8).eq.'U5IICUZA'.or. +c $ c_acftreg(ii)(1:8).eq.'415IC1BA'.or. +c $ c_acftreg(ii)(1:8).eq.'OIIYC1ZA'.or. +c $ c_acftreg(ii)(1:8).eq.'E5QYZFRA'.or. +c $ c_acftreg(ii)(1:8).eq.'QNVYCWBA'.or. +c $ c_acftreg(ii)(1:8).eq.'1ZUYC1RA'.or. +c $ c_acftreg(ii)(1:8).eq.'1GUUIRRA'.or. +c $ c_acftreg(ii)(1:8).eq.'JI0KEWJA') then +cc +c write (io8,8011) iob,ii,c_insty_ob(itype(ii)) +c x, c_acftreg(ii),c_acftid(ii) +c x, idt(ii),alat(ii),alon(ii),pres(ii),ht_ft(ii) +c x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) +c x, ob_q(ii),xiv_q(ii),ichk_q(ii) +c x, ob_dir(ii),xiv_d(ii),ichk_d(ii) +c x, ob_spd(ii),xiv_s(ii),ichk_s(ii),idp(ii) +c x, c_qc(ii),csort(ii) +c 8011 format(i5,1x,i6,1x,a8,1x,a8,1x,a9,1x +c x, i7,1x,2f11.5,1x,f8.1,1x,f7.0,1x +c x, f5.2,4(2(1x,f8.2),1x,i5),1x,i4 +c x, 1x,'!',a11,'!',1x,a25) +c endif +c enddo +c +c Output innovation distributions +c ------------------------------- + if(l_do_innov.and.(.not.l_operational)) then +c + if(l_pc) call p_ddtg('Calling innov_qc',io8) +c + call innov_qc(max_reps,numreps,indx,xiv_t,xiv_d,xiv_s,amiss, + $ c_qc,2,io8,l_init,l_innov_miss) + endif +c +c Examine first digit distribution for comparison with Benford's law +c Perform after all QC checks +c ------------------------------------------------------------------ + if(l_do_innov.and. + $ (.not.l_operational).and. + $ (.not.l_innov_miss)) then +c + if(l_pc) call p_ddtg('Calling benford_qc',io8) +c + call benford_qc(max_reps,numreps,indx,xiv_t,xiv_d,xiv_s,amiss, + $ c_acftreg,itype,maxflt,kreg_tot,creg_reg_tot, + $ c_qc,lead_t_tot,lead_d_tot,lead_s_tot, + $ n_xiv_t,n_xiv_d,n_xiv_s, + $ sum_xiv_t,sum_xiv_d,sum_xiv_s, + $ sumabs_xiv_t,sumabs_xiv_d,sumabs_xiv_s,2,io8 + $, l_init,l_last) + kflight_max = max(kflight,kflight_max) + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call 2 to benford_qc kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp +c + if(l_pc) call p_ddtg('Back from benford_qc',io8) +c + endif +c +c Compute statistics for automated AIREPs +c --------------------------------------- +c (Additional AMDAR bulletins turned on Feb 10, 1999--automated AIREPs +c are largely superfluous after that date. Before then, Australian +c and Asian AMDAR reports were only received as AIREPs.) +c -------------------------------------------------------------------- + read(cdtg_an,'(i8)') kdtg_an +c + k_AMDAR_tot = 0 + k_AIREP_tot = 0 + k_AIREP_good = 0 + k_UAL_tot = 0 + k_UAL_good = 0 + k_EU_tot = 0 + k_EU_good = 0 + k_AU_tot = 0 + k_AU_good = 0 + k_other_tot = 0 + k_other_good = 0 + l_print = .true. +c + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'Unrejected re-encoded ACARS and AMDAR reports' + write(io8,*) 'Unrejected re-encoded TAMDAR and AMDAR reports' + write(io8,*) '---------------------------------------------' + endif +c + do ii=1,numreps_orig +c +c Count the total number of AMDAR reports +c --------------------------------------- + if(itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des.or. + $ itype(ii).eq.i_amdar) then +c + k_AMDAR_tot = k_AMDAR_tot + 1 +c +c Count the total number of AIREP reports +c --------------------------------------- + elseif(itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des.or. + $ itype(ii).eq.i_airep) then +c + k_AIREP_tot = k_AIREP_tot + 1 +c +c Count the total number of UAL AIREPs +ccccdak (Most of these are re-encoded ACARS) +c (Most of these are re-encoded TAMDAR) +c ------------------------------------- + if(c_acftid(ii)(1:3).eq.'UAL') then + k_UAL_tot = k_UAL_tot + 1 +c +c Count the total number of EU AIREPs +c ----------------------------------- + elseif(c_acftid(ii)(1:2).eq.'EU') then + k_EU_tot = k_EU_tot + 1 +c +c Count the total number of AU AIREPs +c ----------------------------------- + elseif(c_acftid(ii)(1:2).eq.'AU') then + k_AU_tot = k_AU_tot + 1 +c +c Count the total number of other AIREPs +c -------------------------------------- + else + k_other_tot = k_other_tot + 1 + endif +c +c Count the number of good AIREP reports +c -------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') then +c + k_AIREP_good = k_AIREP_good + 1 +c +c Count the number of good UAL AIREPs +c ----------------------------------- + if(c_acftid(ii)(1:3).eq.'UAL') then + k_UAL_good = k_UAL_good + 1 +c +c Count the number of good EU AIREPs +c ---------------------------------- + elseif(c_acftid(ii)(1:2).eq.'EU') then + k_EU_good = k_EU_good + 1 +c +c Count the number of good AU AIREPs +c ---------------------------------- + elseif(c_acftid(ii)(1:2).eq.'AU') then + k_AU_good = k_AU_good + 1 +c +c Count the number of good other AIREPs +c ------------------------------------- + else + k_other_good = k_other_good + 1 + endif +c +c Output data after the date the Australian AMDAR was turned on +c ------------------------------------------------------------- + if(kdtg_an.ge.19990210) then +c +c Output reports if desired +c ------------------------- + if(l_print) then + write(io8,3002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii),idp(ii) + x, c_qc(ii) + 3002 format(i6,1x,a8,1x,a8,1x,a9,1x,i7,1x,2f11.5,1x,f8.1,1x + x, f7.0,1x,f5.2,4(2(1x,f8.2),1x,i5),1x,i4,1x,'!',a11,'!') + endif + endif + endif + endif + enddo +c +c Compute and output statistics +c ----------------------------- + if(k_AIREP_tot.gt.0) then + per_AIREP = 100. * k_AIREP_good / k_AIREP_tot + else + per_AIREP = amiss + endif + if(k_UAL_tot.gt.0) then + per_UAL = 100. * k_UAL_good / k_UAL_tot + else + per_UAL = amiss + endif + if(k_EU_tot.gt.0) then + per_EU = 100. * k_EU_good / k_EU_tot + else + per_EU = amiss + endif + if(k_AU_tot.gt.0) then + per_AU = 100. * k_AU_good / k_AU_tot + else + per_AU = amiss + endif + if(k_other_tot.gt.0) then + per_other = 100. * k_other_good / k_other_tot + else + per_other = amiss + endif +c + write(io8,*) + write(io8,*) 'Counts for re-encoded AMDAR reports' + write(io8,*) '-----------------------------------' + write(io8,*) 'Total number of AMDARs = ',k_AMDAR_tot + write(io8,*) + write(io8,*) 'Total number of AIREPs = ',k_AIREP_tot + write(io8,*) ' Total number of UAL = ',k_UAL_tot + write(io8,*) ' Total number of EU = ',k_EU_tot + write(io8,*) ' Total number of AU = ',k_AU_tot + write(io8,*) ' Total number of other = ',k_other_tot + write(io8,*) + write(io8,*) 'Number of good AIREPs = ',k_AIREP_good + write(io8,*) ' Number of UAL = ',k_UAL_good + write(io8,*) ' Number of EU = ',k_EU_good + write(io8,*) ' Number of AU = ',k_AU_good + write(io8,*) ' Number of other = ',k_other_good + write(io8,*) + write(io8,*) 'Percentage of good AIREPs = ',per_AIREP + write(io8,*) ' Percentage of good UAL = ',per_UAL + write(io8,*) ' Percentage of good EU = ',per_EU + write(io8,*) ' Percentage of good AU = ',per_AU + write(io8,*) ' Percentage of good other = ',per_other +c +c Compute similar statistics for YRXX86 AIREPs--keypad reports +c ------------------------------------------------------------ + k_total = 0 + k_good = 0 + k_tot_mdcrs = 0 + k_good_mdcrs = 0 + k_tot_mdcrs_lvl = 0 + k_good_mdcrs_lvl = 0 + k_tot_mdcrs_asc = 0 + k_good_mdcrs_asc = 0 + k_tot_mdcrs_des = 0 + k_good_mdcrs_des = 0 + k_tot_amdar = 0 + k_good_amdar = 0 + k_tot_amdar_lvl = 0 + k_good_amdar_lvl = 0 + k_tot_amdar_asc = 0 + k_good_amdar_asc = 0 + k_tot_amdar_des = 0 + k_good_amdar_des = 0 + k_tot_airep = 0 + k_good_airep = 0 + k_tot_airep_lvl = 0 + k_good_airep_lvl = 0 + k_tot_airep_asc = 0 + k_good_airep_asc = 0 + k_tot_airep_des = 0 + k_good_airep_des = 0 + k_tot_man_airep = 0 + k_good_man_airep = 0 + knt_man_Yairep = 0 + k_YAIREP_good = 0 +c + write(io8,*) + write(io8,*) 'Unrejected YRXX86 keypad AIREP reports' + write(io8,*) '--------------------------------------' +c + do ii=1,numreps_orig +c +c Count the total number of aircraft obs +c -------------------------------------- + if(itype(ii).ne.imiss) then +c + k_total = k_total + 1 +c +c Count the total number of good aircraft obs +c ------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good = k_good + 1 +c + endif +c +c Count the total number of unspecified MDCRS reports +c --------------------------------------------------- + if(itype(ii).eq.i_mdcrs) then +c + k_tot_mdcrs = k_tot_mdcrs + 1 +c +c Count the number of good unspecified MDCRS reports +c -------------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_mdcrs = k_good_mdcrs + 1 +c +c Count the total number of level MDCRS reports +c --------------------------------------------- + elseif(itype(ii).eq.i_mdcrs_lvl) then +c + k_tot_mdcrs_lvl = k_tot_mdcrs_lvl + 1 +c +c Count the number of good level MDCRS reports +c -------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_mdcrs_lvl = k_good_mdcrs_lvl + 1 +c +c Count the total number of ascent MDCRS reports +c ---------------------------------------------- + elseif(itype(ii).eq.i_mdcrs_asc) then +c + k_tot_mdcrs_asc = k_tot_mdcrs_asc + 1 +c +c Count the number of good ascent MDCRS reports +c --------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_mdcrs_asc = k_good_mdcrs_asc + 1 +c +c Count the total number of descent MDCRS reports +c ----------------------------------------------- + elseif(itype(ii).eq.i_mdcrs_des) then +c + k_tot_mdcrs_des = k_tot_mdcrs_des + 1 +c +c Count the number of good descent MDCRS reports +c ---------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_mdcrs_des = k_good_mdcrs_des + 1 +c +c Count the total number of unspecified AMDAR reports +c --------------------------------------------------- + elseif(itype(ii).eq.i_amdar) then +c + k_tot_amdar = k_tot_amdar + 1 +c +c Count the number of good unspecified AMDAR reports +c -------------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_amdar = k_good_amdar + 1 +c +c Count the total number of level AMDAR reports +c --------------------------------------------- + elseif(itype(ii).eq.i_amdar_lvl) then +c + k_tot_amdar_lvl = k_tot_amdar_lvl + 1 +c +c Count the number of good level AMDAR reports +c -------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_amdar_lvl = k_good_amdar_lvl + 1 +c +c Count the total number of ascent AMDAR reports +c ---------------------------------------------- + elseif(itype(ii).eq.i_amdar_asc) then +c + k_tot_amdar_asc = k_tot_amdar_asc + 1 +c +c Count the number of good ascent AMDAR reports +c --------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_amdar_asc = k_good_amdar_asc + 1 +c +c Count the total number of descent AMDAR reports +c ----------------------------------------------- + elseif(itype(ii).eq.i_amdar_des) then +c + k_tot_amdar_des = k_tot_amdar_des + 1 +c +c Count the number of good descent AMDAR reports +c ---------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_amdar_des = k_good_amdar_des + 1 +c +c Count the total number of unspecified AIREP reports +c --------------------------------------------------- + elseif(itype(ii).eq.i_airep) then +c + k_tot_airep = k_tot_airep + 1 +c +c Count the number of good unspecified AIREP reports +c -------------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_airep = k_good_airep + 1 +c +c Count the total number of level AIREP reports +c --------------------------------------------- + elseif(itype(ii).eq.i_airep_lvl) then +c + k_tot_airep_lvl = k_tot_airep_lvl + 1 +c +c Count the number of good level AIREP reports +c -------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_airep_lvl = k_good_airep_lvl + 1 +c +c Count the total number of ascent AIREP reports +c ---------------------------------------------- + elseif(itype(ii).eq.i_airep_asc) then +c + k_tot_airep_asc = k_tot_airep_asc + 1 +c +c Count the number of good ascent AIREP reports +c --------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_airep_asc = k_good_airep_asc + 1 +c +c Count the total number of descent AIREP reports +c ----------------------------------------------- + elseif(itype(ii).eq.i_airep_des) then +c + k_tot_airep_des = k_tot_airep_des + 1 +c +c Count the number of good descent AIREP reports +c ---------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_airep_des = k_good_airep_des + 1 +c +c Count the total number of manAIREP reports +c ------------------------------------------- + elseif(itype(ii).eq.i_man_airep) then +c + k_tot_man_airep = k_tot_man_airep + 1 +c +c Count the number of good manAIREP reports +c ----------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_man_airep = k_good_man_airep + 1 +c +c Count the total number of man-Yairep reports +c -------------------------------------------- + elseif(itype(ii).eq.i_man_Yairep) then +c + knt_man_Yairep = knt_man_Yairep + 1 +c +c Count the number of good man-Yairep reports +c ------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') then +c + k_YAIREP_good = k_YAIREP_good + 1 +c +c Output data after the date the Tinker bulletins were turned on +c -------------------------------------------------------------- + if(kdtg_an.ge.20001001) then +c +c Output reports if desired +c ------------------------- + if(l_print) then + write(io8,3002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii),idp(ii) + x, c_qc(ii) + endif + endif + endif + endif + enddo +c + if(knt_man_Yairep.gt.0) then + per_AIREP = 100. * k_YAIREP_good / knt_man_Yairep + else + per_AIREP = amiss + endif +c + write(io8,*) + write(io8,*) 'Counts for YRXX86 keypad AIREP reports' + write(io8,*) '--------------------------------------' + write(io8,*) 'Total number of man-Yaireps = ',knt_man_Yairep + write(io8,*) 'Number of good man-Yaireps = ',k_YAIREP_good + write(io8,*) 'Percentage of good man-Yaireps = ',per_AIREP +c +c Output overall totals +c --------------------- + write(io8,*) + write(io8,*) ' Counts by specified data type' + write(io8,*) ' -----------------------------' + write(io8,*) ' Type #Total #Good' + write(io8,*) ' --------------------------' + write(io8,*) 'mdcrs ',k_tot_mdcrs,k_good_mdcrs + write(io8,*) 'mdcrs_lvl',k_tot_mdcrs_lvl,k_good_mdcrs_lvl + write(io8,*) 'mdcrs_asc',k_tot_mdcrs_asc,k_good_mdcrs_asc + write(io8,*) 'mdcrs_des',k_tot_mdcrs_des,k_good_mdcrs_des + write(io8,*) ' --------------------------' + write(io8,*) 'amdar ',k_tot_amdar,k_good_amdar + write(io8,*) 'amdar_lvl',k_tot_amdar_lvl,k_good_amdar_lvl + write(io8,*) 'amdar_asc',k_tot_amdar_asc,k_good_amdar_asc + write(io8,*) 'amdar_des',k_tot_amdar_des,k_good_amdar_des + write(io8,*) ' --------------------------' + write(io8,*) 'airep ',k_tot_airep,k_good_airep + write(io8,*) 'airep_lvl',k_tot_airep_lvl,k_good_airep_lvl + write(io8,*) 'airep_asc',k_tot_airep_asc,k_good_airep_asc + write(io8,*) 'airep_des',k_tot_airep_des,k_good_airep_des + write(io8,*) ' --------------------------' + write(io8,*) 'man_airep',k_tot_man_airep,k_good_man_airep + write(io8,*) 'man-Yaire',knt_man_Yairep,k_YAIREP_good + write(io8,*) ' --------------------------' + write(io8,*) 'total ',k_total,k_good + write(io8,*) ' --------------------------' +c +c Re-count totals using determined data type +c ------------------------------------------ + k_total = 0 + k_good = 0 + k_tot_mdcrs = 0 + k_good_mdcrs = 0 + k_tot_mdcrs_lvl = 0 + k_good_mdcrs_lvl = 0 + k_tot_mdcrs_asc = 0 + k_good_mdcrs_asc = 0 + k_tot_mdcrs_des = 0 + k_good_mdcrs_des = 0 + k_tot_amdar = 0 + k_good_amdar = 0 + k_tot_amdar_lvl = 0 + k_good_amdar_lvl = 0 + k_tot_amdar_asc = 0 + k_good_amdar_asc = 0 + k_tot_amdar_des = 0 + k_good_amdar_des = 0 + k_tot_airep = 0 + k_good_airep = 0 + k_tot_airep_lvl = 0 + k_good_airep_lvl = 0 + k_tot_airep_asc = 0 + k_good_airep_asc = 0 + k_tot_airep_des = 0 + k_good_airep_des = 0 + k_tot_man_airep = 0 + k_good_man_airep = 0 + knt_man_Yairep = 0 + k_YAIREP_good = 0 +c + do ii=1,numreps_orig +c +c Count the total number of aircraft obs +c -------------------------------------- + if(itype(ii).ne.imiss) then +c + k_total = k_total + 1 +c +c Count the total number of good aircraft obs +c ------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good = k_good + 1 +c + endif +c +c Count the total number of manAIREP reports +c ------------------------------------------- + if(itype(ii).eq.i_man_airep) then +c + k_tot_man_airep = k_tot_man_airep + 1 +c +c Count the number of good manAIREP reports +c ----------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_man_airep = k_good_man_airep + 1 +c +c Count the total number of man-Yairep reports +c -------------------------------------------- + elseif(itype(ii).eq.i_man_Yairep) then +c + knt_man_Yairep = knt_man_Yairep + 1 +c +c Count the number of good man-Yairep reports +c ------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + 4 k_YAIREP_good = k_YAIREP_good + 1 +c +c Count the number of level reports +c --------------------------------- + elseif(c_qc(ii)(11:11).eq.'L') then +c +c Count the total number of level MDCRS reports +c --------------------------------------------- + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des) then +c + k_tot_mdcrs_lvl = k_tot_mdcrs_lvl + 1 +c +c Count the number of good level MDCRS reports +c -------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_mdcrs_lvl = k_good_mdcrs_lvl + 1 +c +c Count the total number of level AMDAR reports +c --------------------------------------------- + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des) then +c + k_tot_amdar_lvl = k_tot_amdar_lvl + 1 +c +c Count the number of good level AMDAR reports +c -------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_amdar_lvl = k_good_amdar_lvl + 1 +c +c Count the total number of level AIREP reports +c --------------------------------------------- + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des) then +c + k_tot_airep_lvl = k_tot_airep_lvl + 1 +c +c Count the number of good level AIREP reports +c -------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_airep_lvl = k_good_airep_lvl + 1 +c + endif +c +c Count the number of ascent reports +c ---------------------------------- + elseif(c_qc(ii)(11:11).eq.'A'.or. + $ c_qc(ii)(11:11).eq.'a') then +c +c Count the total number of ascent MDCRS reports +c ---------------------------------------------- + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des) then +c + k_tot_mdcrs_asc = k_tot_mdcrs_asc + 1 +c +c Count the number of good ascent MDCRS reports +c --------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_mdcrs_asc = k_good_mdcrs_asc + 1 +c +c Count the total number of ascent AMDAR reports +c ---------------------------------------------- + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des) then +c + k_tot_amdar_asc = k_tot_amdar_asc + 1 +c +c Count the number of good ascent AMDAR reports +c --------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_amdar_asc = k_good_amdar_asc + 1 +c +c Count the total number of ascent AIREP reports +c ---------------------------------------------- + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des) then +c + k_tot_airep_asc = k_tot_airep_asc + 1 +c +c Count the number of good ascent AIREP reports +c --------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_airep_asc = k_good_airep_asc + 1 +c + endif +c +c Count the number of descent reports +c ----------------------------------- + elseif(c_qc(ii)(11:11).eq.'D'.or. + $ c_qc(ii)(11:11).eq.'d') then +c +c Count the total number of descent MDCRS reports +c ----------------------------------------------- + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des) then +c + k_tot_mdcrs_des = k_tot_mdcrs_des + 1 +c +c Count the number of good descent MDCRS reports +c ---------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_mdcrs_des = k_good_mdcrs_des + 1 +c +c Count the total number of descent AMDAR reports +c ----------------------------------------------- + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des) then +c + k_tot_amdar_des = k_tot_amdar_des + 1 +c +c Count the number of good descent AMDAR reports +c ---------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_amdar_des = k_good_amdar_des + 1 +c +c Count the total number of descent AIREP reports +c ----------------------------------------------- + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des) then +c + k_tot_airep_des = k_tot_airep_des + 1 +c +c Count the number of good descent AIREP reports +c ---------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_airep_des = k_good_airep_des + 1 +c + endif +c +c Count the remaining reports +c --------------------------- + else +c +c Count the total number of other MDCRS reports +c --------------------------------------------- + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des) then +c + k_tot_mdcrs = k_tot_mdcrs + 1 +c +c Count the number of good other MDCRS reports +c -------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_mdcrs = k_good_mdcrs + 1 +c +c Count the total number of other AMDAR reports +c --------------------------------------------- + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des) then +c + k_tot_amdar = k_tot_amdar + 1 +c +c Count the number of good other AMDAR reports +c -------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_amdar = k_good_amdar + 1 +c +c Count the total number of other AIREP reports +c --------------------------------------------- + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des) then +c + k_tot_airep = k_tot_airep + 1 +c +c Count the number of good other AIREP reports +c -------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_airep = k_good_airep + 1 +c + endif +c + endif + enddo +c + write(io8,*) + write(io8,*) ' Counts by determined data type' + write(io8,*) ' ------------------------------' + write(io8,*) ' Type #Total #Good' + write(io8,*) ' --------------------------' + write(io8,*) 'mdcrs ',k_tot_mdcrs,k_good_mdcrs + write(io8,*) 'mdcrs_lvl',k_tot_mdcrs_lvl,k_good_mdcrs_lvl + write(io8,*) 'mdcrs_asc',k_tot_mdcrs_asc,k_good_mdcrs_asc + write(io8,*) 'mdcrs_des',k_tot_mdcrs_des,k_good_mdcrs_des + write(io8,*) ' --------------------------' + write(io8,*) 'amdar ',k_tot_amdar,k_good_amdar + write(io8,*) 'amdar_lvl',k_tot_amdar_lvl,k_good_amdar_lvl + write(io8,*) 'amdar_asc',k_tot_amdar_asc,k_good_amdar_asc + write(io8,*) 'amdar_des',k_tot_amdar_des,k_good_amdar_des + write(io8,*) ' --------------------------' + write(io8,*) 'airep ',k_tot_airep,k_good_airep + write(io8,*) 'airep_lvl',k_tot_airep_lvl,k_good_airep_lvl + write(io8,*) 'airep_asc',k_tot_airep_asc,k_good_airep_asc + write(io8,*) 'airep_des',k_tot_airep_des,k_good_airep_des + write(io8,*) ' --------------------------' + write(io8,*) 'man_airep',k_tot_man_airep,k_good_man_airep + write(io8,*) 'man-Yaire',knt_man_Yairep,k_YAIREP_good + write(io8,*) ' --------------------------' + write(io8,*) 'total ',k_total,k_good + write(io8,*) ' --------------------------' +c +c Output totals for each flight +c ----------------------------- + if(.not.l_operational) then + write(io8,*) + write(io8,*) 'Totals for tail#s with rejected reports' + write(io8,*) '---------------------------------------' + write(io8,'(27x,a12,22x,a8)')'Total Number','Rejected' + write(io8,'(a47,a43)') + $ ' kk tail num #Md #Ac #Am #Ar #Ma', + $ ' #Md #Ac #Am #Ar #Ma % ' + write(io8,'(1x,a47,a43)') + $ '----- -------- ------ ------ ------ ------ ----', + $ '-- ------ ------ ------ ------ ------ -----' +c + do kk=1,kreg_tot + if(nobs_reg_tot(kk,1).ne.0.or. + $ nobs_reg_tot(kk,2).ne.0.or. + $ nobs_reg_tot(kk,3).ne.0.or. + $ nobs_reg_tot(kk,4).ne.0.or. + $ nobs_reg_tot(kk,5).ne.0) then +c + percent = (nrej_reg_tot(kk,1) + nrej_reg_tot(kk,2) + $ + nrej_reg_tot(kk,3) + nrej_reg_tot(kk,4) + $ + nrej_reg_tot(kk,5)) * 100.0 + $ / (nobs_reg_tot(kk,1) + nobs_reg_tot(kk,2) + $ + nobs_reg_tot(kk,3) + nobs_reg_tot(kk,4) + $ + nobs_reg_tot(kk,5)) +c + write(io8,'(i5,1x,a8,10(1x,i6),f6.1)') kk,creg_reg_tot(kk), + $ nobs_reg_tot(kk,1),nobs_reg_tot(kk,2), + $ nobs_reg_tot(kk,3),nobs_reg_tot(kk,4), + $ nobs_reg_tot(kk,5), + $ nrej_reg_tot(kk,1),nrej_reg_tot(kk,2), + $ nrej_reg_tot(kk,3),nrej_reg_tot(kk,4), + $ nrej_reg_tot(kk,5),percent + endif + enddo +c + write(io8,*) + write(io8,*) 'Totals for tail#s with temp in whole degrees' + write(io8,*) '--------------------------------------------' + write(io8,'(27x,a12,22x,a8)')'Total Number','Rejected' + write(io8,'(a47,a43)') + $ ' kk tail num #Md #Ac #Am #Ar #Ma', + $ ' #Md #Ac #Am #Ar #Ma % ' + write(io8,'(1x,a47,a43)') + $ '----- -------- ------ ------ ------ ------ ----', + $ '-- ------ ------ ------ ------ ------ -----' +c + do kk=1,kreg_tot + if(nwhol_reg_tot(kk,1).ne.0.or. + $ nwhol_reg_tot(kk,2).ne.0.or. + $ nwhol_reg_tot(kk,3).ne.0.or. + $ nwhol_reg_tot(kk,4).ne.0.or. + $ nwhol_reg_tot(kk,5).ne.0) then +c + percent = (nwhol_reg_tot(kk,1) + nwhol_reg_tot(kk,2) + $ + nwhol_reg_tot(kk,3) + nwhol_reg_tot(kk,4) + $ + nwhol_reg_tot(kk,5)) * 100.0 + $ / (nobs_reg_tot(kk,1) + nobs_reg_tot(kk,2) + $ + nobs_reg_tot(kk,3) + nobs_reg_tot(kk,4) + $ + nobs_reg_tot(kk,5)) +c + write(io8,'(i5,1x,a8,10(1x,i6),f6.1)') kk,creg_reg_tot(kk), + $ nobs_reg_tot(kk,1),nobs_reg_tot(kk,2), + $ nobs_reg_tot(kk,3),nobs_reg_tot(kk,4), + $ nobs_reg_tot(kk,5), + $ nwhol_reg_tot(kk,1),nwhol_reg_tot(kk,2), + $ nwhol_reg_tot(kk,3),nwhol_reg_tot(kk,4), + $ nwhol_reg_tot(kk,5),percent + endif + enddo +c + write(io8,*) + write(io8,*) 'Totals for tail#s with rejected temperatures' + write(io8,*) '--------------------------------------------' + write(io8,'(27x,a12,22x,a8)')'Total Number','Rejected' + write(io8,'(a47,a43)') + $ ' kk tail num #Md #Ac #Am #Ar #Ma', + $ ' #Md #Ac #Am #Ar #Ma % ' + write(io8,'(1x,a47,a43)') + $ '----- -------- ------ ------ ------ ------ ----', + $ '-- ------ ------ ------ ------ ------ -----' +c + do kk=1,kreg_tot + if(ntemp_reg_tot(kk,1).ne.0.or. + $ ntemp_reg_tot(kk,2).ne.0.or. + $ ntemp_reg_tot(kk,3).ne.0.or. + $ ntemp_reg_tot(kk,4).ne.0.or. + $ ntemp_reg_tot(kk,5).ne.0) then +c + percent = (ntemp_reg_tot(kk,1) + ntemp_reg_tot(kk,2) + $ + ntemp_reg_tot(kk,3) + ntemp_reg_tot(kk,4) + $ + ntemp_reg_tot(kk,5)) *100.0 + $ / (nobs_reg_tot(kk,1) + nobs_reg_tot(kk,2) + $ + nobs_reg_tot(kk,3) + nobs_reg_tot(kk,4) + $ + nobs_reg_tot(kk,5)) +c + write(io8,'(i5,1x,a8,10(1x,i6),f6.1)') kk,creg_reg_tot(kk), + $ nobs_reg_tot(kk,1),nobs_reg_tot(kk,2), + $ nobs_reg_tot(kk,3),nobs_reg_tot(kk,4), + $ nobs_reg_tot(kk,5), + $ ntemp_reg_tot(kk,1),ntemp_reg_tot(kk,2), + $ ntemp_reg_tot(kk,3),ntemp_reg_tot(kk,4), + $ ntemp_reg_tot(kk,5),percent + endif + enddo +c + write(io8,*) + write(io8,*) 'Totals for tail#s with rejected winds' + write(io8,*) '-------------------------------------' + write(io8,'(27x,a12,22x,a8)')'Total Number','Rejected' + write(io8,'(a47,a43)') + $ ' kk tail num #Md #Ac #Am #Ar #Ma', + $ ' #Md #Ac #Am #Ar #Ma % ' + write(io8,'(1x,a47,a43)') + $ '----- -------- ------ ------ ------ ------ ----', + $ '-- ------ ------ ------ ------ ------ -----' +c + do kk=1,kreg_tot + if(nwind_reg_tot(kk,1).ne.0.or. + $ nwind_reg_tot(kk,2).ne.0.or. + $ nwind_reg_tot(kk,3).ne.0.or. + $ nwind_reg_tot(kk,4).ne.0.or. + $ nwind_reg_tot(kk,5).ne.0) then +c + percent = (nwind_reg_tot(kk,1) + nwind_reg_tot(kk,2) + $ + nwind_reg_tot(kk,3) + nwind_reg_tot(kk,4) + $ + nwind_reg_tot(kk,5)) * 100.0 + $ / (nobs_reg_tot(kk,1) + nobs_reg_tot(kk,2) + $ + nobs_reg_tot(kk,3) + nobs_reg_tot(kk,4) + $ + nobs_reg_tot(kk,5)) +c + write(io8,'(i5,1x,a8,10(1x,i6),f6.1)') kk,creg_reg_tot(kk), + $ nobs_reg_tot(kk,1),nobs_reg_tot(kk,2), + $ nobs_reg_tot(kk,3),nobs_reg_tot(kk,4), + $ nobs_reg_tot(kk,5), + $ nwind_reg_tot(kk,1),nwind_reg_tot(kk,2), + $ nwind_reg_tot(kk,3),nwind_reg_tot(kk,4), + $ nwind_reg_tot(kk,5),percent + endif + enddo +c + write(io8,*) + write(io8,*) 'Totals for tail#s with invalid check errors' + write(io8,*) '-------------------------------------------' + write(io8,'(27x,a12,22x,a8)')'Total Number','Rejected' + write(io8,'(a47,a43)') + $ ' kk tail num #Md #Ac #Am #Ar #Ma', + $ ' #Md #Ac #Am #Ar #Ma % ' + write(io8,'(1x,a47,a43)') + $ '----- -------- ------ ------ ------ ------ ----', + $ '-- ------ ------ ------ ------ ------ -----' +c + do kk=1,kreg_tot + if(nrej_inv_tot(kk,1).ne.0.or. + $ nrej_inv_tot(kk,2).ne.0.or. + $ nrej_inv_tot(kk,3).ne.0.or. + $ nrej_inv_tot(kk,4).ne.0.or. + $ nrej_inv_tot(kk,5).ne.0) then +c + percent = (nrej_inv_tot(kk,1) + nrej_inv_tot(kk,2) + $ + nrej_inv_tot(kk,3) + nrej_inv_tot(kk,4) + $ + nrej_inv_tot(kk,5)) * 100.0 + $ / (nobs_reg_tot(kk,1) + nobs_reg_tot(kk,2) + $ + nobs_reg_tot(kk,3) + nobs_reg_tot(kk,4) + $ + nobs_reg_tot(kk,5)) +c + write(io8,'(i5,1x,a8,10(1x,i6),f6.1)') kk,creg_reg_tot(kk), + $ nobs_reg_tot(kk,1),nobs_reg_tot(kk,2), + $ nobs_reg_tot(kk,3),nobs_reg_tot(kk,4), + $ nobs_reg_tot(kk,5), + $ nrej_inv_tot(kk,1),nrej_inv_tot(kk,2), + $ nrej_inv_tot(kk,3),nrej_inv_tot(kk,4), + $ nrej_inv_tot(kk,5),percent + endif + enddo +c + write(io8,*) + write(io8,*) 'Totals for tail#s with stuck values' + write(io8,*) '-----------------------------------' + write(io8,'(27x,a12,22x,a8)')'Total Number','Rejected' + write(io8,'(a47,a43)') + $ ' kk tail num #Md #Ac #Am #Ar #Ma', + $ ' #Md #Ac #Am #Ar #Ma % ' + write(io8,'(1x,a47,a43)') + $ '----- -------- ------ ------ ------ ------ ----', + $ '-- ------ ------ ------ ------ ------ -----' +c + do kk=1,kreg_tot + if(nrej_stk_tot(kk,1).ne.0.or. + $ nrej_stk_tot(kk,2).ne.0.or. + $ nrej_stk_tot(kk,3).ne.0.or. + $ nrej_stk_tot(kk,4).ne.0.or. + $ nrej_stk_tot(kk,5).ne.0) then +c + percent = (nrej_stk_tot(kk,1) + nrej_stk_tot(kk,2) + $ + nrej_stk_tot(kk,3) + nrej_stk_tot(kk,4) + $ + nrej_stk_tot(kk,5)) * 100.0 + $ / (nobs_reg_tot(kk,1) + nobs_reg_tot(kk,2) + $ + nobs_reg_tot(kk,3) + nobs_reg_tot(kk,4) + $ + nobs_reg_tot(kk,5)) +c + write(io8,'(i5,1x,a8,10(1x,i6),f6.1)') kk,creg_reg_tot(kk), + $ nobs_reg_tot(kk,1),nobs_reg_tot(kk,2), + $ nobs_reg_tot(kk,3),nobs_reg_tot(kk,4), + $ nobs_reg_tot(kk,5), + $ nrej_stk_tot(kk,1),nrej_stk_tot(kk,2), + $ nrej_stk_tot(kk,3),nrej_stk_tot(kk,4), + $ nrej_stk_tot(kk,5),percent + endif + enddo +c + write(io8,*) + write(io8,*) 'Totals for tail#s with gross check errors' + write(io8,*) '-----------------------------------------' + write(io8,'(27x,a12,22x,a8)')'Total Number','Rejected' + write(io8,'(a47,a43)') + $ ' kk tail num #Md #Ac #Am #Ar #Ma', + $ ' #Md #Ac #Am #Ar #Ma % ' + write(io8,'(1x,a47,a43)') + $ '----- -------- ------ ------ ------ ------ ----', + $ '-- ------ ------ ------ ------ ------ -----' +c + do kk=1,kreg_tot + if(nrej_grc_tot(kk,1).ne.0.or. + $ nrej_grc_tot(kk,2).ne.0.or. + $ nrej_grc_tot(kk,3).ne.0.or. + $ nrej_grc_tot(kk,4).ne.0.or. + $ nrej_grc_tot(kk,5).ne.0) then +c + percent = (nrej_grc_tot(kk,1) + nrej_grc_tot(kk,2) + $ + nrej_grc_tot(kk,3) + nrej_grc_tot(kk,4) + $ + nrej_grc_tot(kk,5)) * 100.0 + $ / (nobs_reg_tot(kk,1) + nobs_reg_tot(kk,2) + $ + nobs_reg_tot(kk,3) + nobs_reg_tot(kk,4) + $ + nobs_reg_tot(kk,5)) +c + write(io8,'(i5,1x,a8,10(1x,i6),f6.1)') kk,creg_reg_tot(kk), + $ nobs_reg_tot(kk,1),nobs_reg_tot(kk,2), + $ nobs_reg_tot(kk,3),nobs_reg_tot(kk,4), + $ nobs_reg_tot(kk,5), + $ nrej_grc_tot(kk,1),nrej_grc_tot(kk,2), + $ nrej_grc_tot(kk,3),nrej_grc_tot(kk,4), + $ nrej_grc_tot(kk,5),percent + endif + enddo +c + write(io8,*) + write(io8,*) 'Totals for tail#s with position check errors' + write(io8,*) '--------------------------------------------' + write(io8,'(27x,a12,22x,a8)')'Total Number','Rejected' + write(io8,'(a47,a43)') + $ ' kk tail num #Md #Ac #Am #Ar #Ma', + $ ' #Md #Ac #Am #Ar #Ma % ' + write(io8,'(1x,a47,a43)') + $ '----- -------- ------ ------ ------ ------ ----', + $ '-- ------ ------ ------ ------ ------ -----' +c + do kk=1,kreg_tot + if(nrej_pos_tot(kk,1).ne.0.or. + $ nrej_pos_tot(kk,2).ne.0.or. + $ nrej_pos_tot(kk,3).ne.0.or. + $ nrej_pos_tot(kk,4).ne.0.or. + $ nrej_pos_tot(kk,5).ne.0) then +c + percent = (nrej_pos_tot(kk,1) + nrej_pos_tot(kk,2) + $ + nrej_pos_tot(kk,3) + nrej_pos_tot(kk,4) + $ + nrej_pos_tot(kk,5)) * 100.0 + $ / (nobs_reg_tot(kk,1) + nobs_reg_tot(kk,2) + $ + nobs_reg_tot(kk,3) + nobs_reg_tot(kk,4) + $ + nobs_reg_tot(kk,5)) +c + write(io8,'(i5,1x,a8,10(1x,i6),f6.1)') kk,creg_reg_tot(kk), + $ nobs_reg_tot(kk,1),nobs_reg_tot(kk,2), + $ nobs_reg_tot(kk,3),nobs_reg_tot(kk,4), + $ nobs_reg_tot(kk,5), + $ nrej_pos_tot(kk,1),nrej_pos_tot(kk,2), + $ nrej_pos_tot(kk,3),nrej_pos_tot(kk,4), + $ nrej_pos_tot(kk,5),percent + endif + enddo +c + write(io8,*) + write(io8,*) 'Totals for tail#s with ordering check errors' + write(io8,*) '--------------------------------------------' + write(io8,'(27x,a12,22x,a8)')'Total Number','Rejected' + write(io8,'(a47,a43)') + $ ' kk tail num #Md #Ac #Am #Ar #Ma', + $ ' #Md #Ac #Am #Ar #Ma % ' + write(io8,'(1x,a47,a43)') + $ '----- -------- ------ ------ ------ ------ ----', + $ '-- ------ ------ ------ ------ ------ -----' +c + do kk=1,kreg_tot + if(nrej_ord_tot(kk,1).ne.0.or. + $ nrej_ord_tot(kk,2).ne.0.or. + $ nrej_ord_tot(kk,3).ne.0.or. + $ nrej_ord_tot(kk,4).ne.0.or. + $ nrej_ord_tot(kk,5).ne.0) then +c + percent = (nrej_ord_tot(kk,1) + nrej_ord_tot(kk,2) + $ + nrej_ord_tot(kk,3) + nrej_ord_tot(kk,4) + $ + nrej_ord_tot(kk,5)) * 100.0 + $ / (nobs_reg_tot(kk,1) + nobs_reg_tot(kk,2) + $ + nobs_reg_tot(kk,3) + nobs_reg_tot(kk,4) + $ + nobs_reg_tot(kk,5)) +c + write(io8,'(i5,1x,a8,10(1x,i6),f6.1)') kk,creg_reg_tot(kk), + $ nobs_reg_tot(kk,1),nobs_reg_tot(kk,2), + $ nobs_reg_tot(kk,3),nobs_reg_tot(kk,4), + $ nobs_reg_tot(kk,5), + $ nrej_ord_tot(kk,1),nrej_ord_tot(kk,2), + $ nrej_ord_tot(kk,3),nrej_ord_tot(kk,4), + $ nrej_ord_tot(kk,5),percent + endif + enddo +c + write(io8,*) + write(io8,*) 'Totals for tail#s with suspect check errors' + write(io8,*) '-------------------------------------------' + write(io8,'(27x,a12,22x,a8)')'Total Number','Rejected' + write(io8,'(a47,a43)') + $ ' kk tail num #Md #Ac #Am #Ar #Ma', + $ ' #Md #Ac #Am #Ar #Ma % ' + write(io8,'(1x,a47,a43)') + $ '----- -------- ------ ------ ------ ------ ----', + $ '-- ------ ------ ------ ------ ------ -----' +c + do kk=1,kreg_tot + if(nrej_sus_tot(kk,1).ne.0.or. + $ nrej_sus_tot(kk,2).ne.0.or. + $ nrej_sus_tot(kk,3).ne.0.or. + $ nrej_sus_tot(kk,4).ne.0.or. + $ nrej_sus_tot(kk,5).ne.0) then +c + percent = (nrej_sus_tot(kk,1) + nrej_sus_tot(kk,2) + $ + nrej_sus_tot(kk,3) + nrej_sus_tot(kk,4) + $ + nrej_sus_tot(kk,5)) * 100.0 + $ / (nobs_reg_tot(kk,1) + nobs_reg_tot(kk,2) + $ + nobs_reg_tot(kk,3) + nobs_reg_tot(kk,4) + $ + nobs_reg_tot(kk,5)) +c + write(io8,'(i5,1x,a8,10(1x,i6),f6.1)') kk,creg_reg_tot(kk), + $ nobs_reg_tot(kk,1),nobs_reg_tot(kk,2), + $ nobs_reg_tot(kk,3),nobs_reg_tot(kk,4), + $ nobs_reg_tot(kk,5), + $ nrej_sus_tot(kk,1),nrej_sus_tot(kk,2), + $ nrej_sus_tot(kk,3),nrej_sus_tot(kk,4), + $ nrej_sus_tot(kk,5),percent + endif + enddo + endif +c +c Close files +c ----------- + if(.not.l_operational) then + close(io30) + close(io31) + close(io32) + close(io33) + close(io34) + close(io35) + close(io36) + close(io37) + close(io38) + elseif(l_ncep) then + close(io8) + endif + +cppppp +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp + kflight_max = max(kreg_max,kflight_max,kreg_tot_max) +cppppp +cc print *, 'overall flight number max:', kflight_max +cppppp + if(kflight_max/.90.gt.maxflt .and. kflight_max.lt.maxflt ) then + +c If the maximum number of calculated flights at some point in this processing read in from +c PREPBUFR file is at least 90% of the maximum number of flights allowed ("maxflt"), print +c diagnostic warning message to production joblog file +c ----------------------------------------------------------------------------------------- + + print 153, kflight_max,maxflt + 153 format(/' #####> WARNING: THE MAX NUMBER OF CALCULATED ', + $ 'AIRCRAFT FLIGHTS FROM INPUT FILE (',I6,') ARE > 90% OF UPPER', + $ ' LIMIT OF ',I6,' -- INCREASE SIZE OF "MAXFLT" SOON!'/) + write(cmaxflt,'(i6)') maxflt + call system('[ -n "$jlogfile" ] && $DATA/postmsg "$jlogfile" '// + + '"***WARNING: HIT 90% OF '//cmaxflt//' AIRCRAFT FLIGHT LIMIT'// + + ' IN PREPOBS_PREPACQC, INCREASE SIZE OF PARM MAXFLT"') + endif + + + write(*,*) + write(*,*) '********************' + write(*,*) 'acftobs_qc has ended' + call system('date') + write(*,*) '--> # flights = ',kflight_max + write(*,*) '********************' + write(*,*) + +c return 1 if # flts > maxflt out of subr. do_flt, and subr. do_reg (latter transferred here +c via subr. dupchek_qc) + if(maxflt_exceeded .gt. 0) then + print *, '--------------------------------------------------' + print *, '~~~> maxflt_exceeded -- return 1 out of acftobs_qc' + print *, '--------------------------------------------------' + return 1 + endif + + return + + end +c +c ################################################################### +c subroutine pr_workdata +c ################################################################### +c + subroutine pr_workdata(max_reps,numdo,indx + x, alat,alon,pres,ht_ft,idt,idp,c_acftreg,c_acftid,itype + x, t_prcn,ob_t,ob_q,ob_dir,ob_spd + x, xiv_t,xiv_q,xiv_d,xiv_s,ichk_t,ichk_q,ichk_d,ichk_s + x, cdtg_an,c_qc,csort,io8) +c +c Print work arrays +c + implicit none +c + integer io8 ! i/o unit number for log file + integer ii,iob ! do loop indices + integer max_reps ! maximum number of observations allowed + $, numdo ! number of reports to print + real*8 alat(max_reps) ! latitude + $, alon(max_reps) ! longitude + real pres(max_reps) ! pressure + $, ht_ft(max_reps) ! height in feet + integer idt(max_reps) ! time in seconds to analysis time + integer idp(max_reps) ! surface pressure change at ob location + character*8 c_acftreg(max_reps) ! acft registration (tail) number + character*9 c_acftid(max_reps) ! acft flight number + integer itype(max_reps) ! instrument type + real t_prcn(max_reps) ! temperature precision + real ob_t(max_reps) ! temperature + $, ob_q(max_reps) ! specific humidity + $, ob_dir(max_reps) ! wind direction + $, ob_spd(max_reps) ! wind speed + real xiv_t(max_reps) ! temperature innovation (ob - bk) + $, xiv_q(max_reps) ! specific humidity innovation (ob - bk) + $, xiv_d(max_reps) ! wind direction innovation (ob - bk) + $, xiv_s(max_reps) ! wind speed innovation (ob - bk) + integer ichk_t(max_reps) ! NRL quality control flag for temperature ob + $, ichk_q(max_reps) ! NRL quality control flag for specific humidity + $, ichk_d(max_reps) ! NRL quality control flag for wind direction + $, ichk_s(max_reps) ! NRL quality control flag for wind speed + integer indx(max_reps) ! pointer index for reports + character*10 cdtg_an ! date time group for analysis + character*11 c_qc(max_reps) ! quality control flags for reports + character*25 csort(max_reps) ! variable used for sorting data +c + character*16 c_insty_ob ! function to convert integer instrument type + ! to character instrument type +c + integer ihr_an ! hour of analysis time + $, ihr ! ob hour + $, imin ! ob minute + $, isec ! ob second + $, itime ! ob minute/second +c + real*8 wlon ! west longitude +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c + write(io8,8030) + 8030 format(' index type tail num flight time hh:mm:ss ' + $,'lat lon pres height t-pr temp ichk dir ichk spd' + $ ' ichk humid ichk') +c + read(cdtg_an,'(8x,i2)') ihr_an +c + do iob = 1,numdo + ii = indx(iob) +c + ihr = idt(ii) / 3600 + if(idt(ii).lt.0) then + itime = (abs(ihr)+1)*3600 + idt(ii) + ihr = ihr_an + ihr - 1 + if(ihr.lt.0) ihr = ihr + 24 + else + itime = idt(ii) - ihr*3600 + ihr = ihr_an + ihr + endif +c + imin = itime / 60 + if(imin.eq.60) then + imin = 0 + ihr = ihr + 1 + itime = itime - 3600 + endif +c + isec = itime - imin*60 +c + if(alon(ii).gt.180.0) then + wlon = alon(ii) - 360.0 + else + wlon = alon(ii) + endif +c +c if(alon(ii).ge.300.0) then + write (io8,8001) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),ihr,imin,isec + x, alat(ii),wlon,pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),ichk_t(ii) + x, ob_dir(ii),ichk_d(ii) + x, ob_spd(ii),ichk_s(ii) + x, ob_q(ii),ichk_q(ii) + 8001 format(i6,1x,a8,1x,a8,1x,a9,1x + x, i6,1x,i2,':',i2.2,':',i2.2,1x + x, f9.5,1x,f10.5,1x,f6.1,1x,f6.0,1x + x, f5.2,1x,f6.2,1x,i4,1x,f4.0,1x,i3,1x + x, f5.1,1x,i3,1x,f6.2,1x,i3) +c endif + enddo +c + return + end +c +c ################################################################### +c subroutine indexc +c ################################################################### +c +c$$$ subprogram documentation block +c . . . . +c subprogram: indexc general sort routine for character array +c prgmmr: d. a. keyser org: w/nmc22 date: 95-05-30 +c +c abstract: uses efficient sort algorithm to produce index sort list +c for a 25-character array. does not rearrange the file. +c +c program history log: +c 93-06-05 r kistler --- fortran version of c-program +c 93-07-15 p. julian ---- modified to sort 12-character array +c 94-08-25 d. a. keyser - modified to sort 16-character array +c 95-05-30 d. a. keyser - tests for < 2 elements in sort list, +c if so returns without sorting (but fills indx array) +c ??-??-?? p. m. pauley - size of carrin changed to character*24 +c 10-11-15 s. m. bender - size of carrin changed to character*25 +c +c usage: call indexc(n,carrin,indx) +c input argument list: +c n - size of array to be sorted +c carrin - 25-character array to be sorted +c +c output argument list: +c indx - array of pointers giving sort order of carrin in +c - ascending order {e.g., carrin(indx(i)) is sorted in +c - ascending order for original i = 1, ... ,n} +c +c remarks: none. +c +c attributes: +c language: Fortran 90 +c machine: NCEP WCOSS +c +c$$$ + subroutine indexc(n,carrin,indx) +c + implicit none +c + integer n ! dimension of array to be sorted + $, j ! do loop index, sort variable + $, i ! sort variable + $, l ! variable used to decide if sort is finished + $, ir ! " " + integer indx(n) ! pointer array + $, indxt ! pointer used in sort +c + character*25 carrin(n) ! input array to be sorted + $, cc ! character variable used in sort +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c + do 10 j = 1,n + indx(j) = j + 10 continue +c +c must be > 1 element in sort list, else return +c + if(n.le.1) return +c + l = n/2 + 1 + ir = n +c + 33 continue + if(l.gt.1) then + l = l - 1 + indxt = indx(l) + cc = carrin(indxt) + else + indxt = indx(ir) + cc = carrin(indxt) + indx(ir) = indx(1) + ir = ir - 1 + if(ir.eq.1) then + indx(1) = indxt + return + end if + end if +c + i = l + j = l * 2 +c + 30 continue + if(j.le.ir) then + if(j.lt.ir) then + if(carrin(indx(j)).lt.carrin(indx(j+1))) j = j + 1 + end if + if(cc.lt.carrin(indx(j))) then + indx(i) = indx(j) + i = j + j = j + i + else + j = ir + 1 + endif + end if +c + if(j.le.ir) go to 30 + indx(i) = indxt + go to 33 +c + end +c +c ################################################################### +c subroutine dupchek_qc +c ################################################################### +c + subroutine dupchek_qc(numreps,max_reps,maxflt,htdif_same + $, c_acftreg,c_acftid,c_qc,cdtg_an + $, alat,alon,pres,ht_ft,t_prcn,ob_t,ob_q,ob_dir,ob_spd + $, xiv_t,xiv_q,xiv_d,xiv_s + $, idt,itype,ichk_t,ichk_q,ichk_d,ichk_s,kbadtot + $, kreg,creg_reg,nobs_reg,nrej_reg,ntemp_reg,nwind_reg + $, indx,csort,amiss,imiss,io8,io30,l_last,l_operational,l_init + $, l_ncep,*) +c +c Remove duplicates from dataset +c +c Modified 8/15/01 (P.M. Pauley) to change time threshold to 90 seconds. +c 60 sec is required for AMDAR reports from different centers and for +c MDCRS-AIREP duplicates that use different rounding. 63 seconds was +c required to overcome an ISIS2000 error that led to a missing value +c for seconds being interpreted as 63. Finally, 70 seconds is needed +c to catch position report duplicates. The position reports can be +c up to 70 seconds out of sync with the ascent sounding data as a +c result of rounding error. +c + implicit none +c +c Declaration statements +c ---------------------- + integer max_reps ! maximum number of reports +c + character*11 c_qc(max_reps) ! internal qc flags +c +c Data arrays +c ----------- + character*10 cdtg_an ! date time group for analysis + integer numreps ! actual number of reports + integer itype(max_reps) ! type of aircraft data + $, ktype ! pointer for instrument type + integer idt(max_reps) ! time in seconds to analysis time + character*8 c_acftreg(max_reps) ! aircraft registration (tail) number + character*9 c_acftid(max_reps) ! aircraft flight number + real*8 alat(max_reps) ! latitude + $, alon(max_reps) ! longitude + real pres(max_reps) ! pressure + $, ht_ft(max_reps) ! height in feet + real t_prcn(max_reps) ! temperature precision + real ob_t(max_reps) ! temperature + $, ob_q(max_reps) ! specific humidity + $, ob_dir(max_reps) ! wind direction + $, ob_spd(max_reps) ! wind speed + real xiv_t(max_reps) ! temperature innovation (ob - bk) + $, xiv_q(max_reps) ! specific humidity innovation (ob - bk) + $, xiv_d(max_reps) ! wind direction innovation (ob - bk) + $, xiv_s(max_reps) ! wind speed innovation (ob - bk) + integer ichk_t(max_reps) ! NRL QC flag for temperature ob + $, ichk_q(max_reps) ! NRL QC flag for specific humidity ob + $, ichk_d(max_reps) ! NRL QC flag for wind direction ob + $, ichk_s(max_reps) ! NRL QC flag for wind speed ob + character*25 csort(max_reps) ! sort variable +c +c Arrays for mixed duplicates +c --------------------------- + integer maxflt ! max number of flights allowed +c x, ndup ! number of ids with mixed duplicates +c character*9 c_air_id(maxflt) ! airep flight id for mixed duplicate +ccccdak x, c_acr_id(maxflt) ! acars flight id for mixed duplicate +c x, c_acr_id(maxflt) ! tamdar flight id for mixed duplicate +ccccdak character*8 c_acr_reg(maxflt) ! acars tail number for mixed duplicate +c character*8 c_acr_reg(maxflt) ! tamdar tail number for mixed duplicate +c integer kdup(maxflt) ! number of mixed duplicates per id pair +c $, idt_min(maxflt) ! min time for flight segment +c $, idt_max(maxflt) ! max time for flight segment +c +c Pointers +c -------- + integer indx(max_reps) ! pointer index for good reports +c +c Functions +c --------- + character*16 c_insty_ob ! function to convert integer instrument + ! type to character instrument type + integer insty_ob_fun ! function to convert character + ! instrument type to integer +c +c Other variables +c --------------- + integer io8 ! i/o unit number for log file + integer io30 ! i/o unit number for rejected dups +c + integer imiss ! integer missing value flag + real amiss ! real missing value flag +c + real htdif_same ! height difference considered negligible + integer idt_dif ! time difference (current - previous) + $, difdir ! difference between wind directions +c +c integer idt_samflt ! time difference allowed for same flight +c $, min_idt,max_idt ! limits on rel time allowed for same flight +c + integer iob ! do loop index + $, ii ! index pointing to current report + $, iim1 ! index pointing to previous report + $, kkdup ! do loop index + integer knt ! counter used to define indices + $, knt0 ! " + $, knt1 ! " + integer isave ! variable used to shuffle indices + $, kbadtot ! total number of rejected duplicates + $, kbad(5,3) ! counter for number of exact, near duplicates +c +ccccdak integer i_acars ! instrument type for acars + integer i_acars ! instrument type for tamdar +ccccdak $, i_acars_lvl ! instrument type for acars--level flt + $, i_acars_lvl ! instrument type for tamdar--level flt +ccccdak $, i_acars_asc ! instrument type for acars--ascent + $, i_acars_asc ! instrument type for tamdar--ascent +ccccdak $, i_acars_des ! instrument type for acars--descent + $, i_acars_des ! instrument type for tamdar--descent + $, i_mdcrs ! instrument type for mdcrs + $, i_mdcrs_lvl ! instrument type for mdcrs--level flt + $, i_mdcrs_asc ! instrument type for mdcrs--ascent + $, i_mdcrs_des ! instrument type for mdcrs--descent + $, i_man_airep ! instrument type for manual aireps + $, i_man_Yairep ! instrument type for manual aireps (YRXX) + $, i_airep ! instrument type for airep + $, i_airep_lvl ! instrument type for airep--level flt + $, i_airep_asc ! instrument type for airep--ascent + $, i_airep_des ! instrument type for airep--descent + $, i_amdar ! instrument type for amdar + $, i_amdar_lvl ! instrument type for amdar--level flt + $, i_amdar_asc ! instrument type for amdar--ascent + $, i_amdar_des ! instrument type for amdar--descent +c + integer n_exact ! number of exact dups + $, n_exact_sh ! number of exact dups with short ids + $, n_ex_sh_MaMa ! --manAIREP-manAIREP + $, n_ex_sh_MaAr ! --manAIREP-AIREP + $, n_ex_sh_MaMd ! --manAIREP-MDCRS +ccccdak $, n_ex_sh_MaAc ! --manAIREP-ACARS + $, n_ex_sh_MaAc ! --manAIREP-TAMDAR + $, n_ex_sh_ArMa ! --AIREP-manAIREP + $, n_ex_sh_ArAr ! --AIREP-AIREP + $, n_exact_0ll ! number of exact dups with zero lat/lon +ccccdak $, n_ex_0ll_AcAc ! --ACARS-ACARS + $, n_ex_0ll_AcAc ! --TAMDAR-TAMDAR + $, n_ex_0ll_MdMd ! --MDCRS-MDCRS + $, n_ex_0ll_MaMa ! --manAIREP-manAIREP + $, n_ex_0ll_MaAr ! --manAIREP-AIREP +ccccdak $, n_exact_MdAc ! number of exact dups--MDCRS-ACARS + $, n_exact_MdAc ! number of exact dups--MDCRS-TAMDAR +ccccdak $, n_exact_AcMa ! number of exact dups--ACARS-manAIREP + $, n_exact_AcMa ! number of exact dups--TAMDAR-manAIREP +ccccdak $, n_exact_AcAr ! number of exact dups--ACARS-AIREP + $, n_exact_AcAr ! number of exact dups--TAMDAR-AIREP + $, n_exact_MdMa ! number of exact dups--MDCRS-manAIREP + $, n_exact_MdAr ! number of exact dups--MDCRS-AIREP + $, n_exact_AmAr ! number of exact dups--AMDAR-AIREP + $, n_exact_AmMa ! number of exact dups--AMDAR-manAIREP + $, n_exact_ArMa ! number of exact dups--AIREP-manAIREP +ccccdak $, n_exact_AcAc ! number of exact dups--ACARS-ACARS + $, n_exact_AcAc ! number of exact dups--TAMDAR-TAMDAR + $, n_exact_MdMd ! number of exact dups--MDCRS-MDCRS + $, n_exact_ArAr ! number of exact dups--AIREP-AIREP + $, n_exact_MaMa ! number of exact dups--manAIREP-manAIREP + $, n_exact_AmAm ! number of exact dups--AMDAR-AMDAR +c + integer n_near ! number of near dups + $, n_near_sh ! number of near dups with short ids + $, n_nr_sh_MaMa ! --manAIREP-manAIREP + $, n_nr_sh_MaAr ! --manAIREP-AIREP + $, n_nr_sh_MaMd ! --manAIREP-MDCRS +ccccdak $, n_nr_sh_MaAc ! --manAIREP-ACARS + $, n_nr_sh_MaAc ! --manAIREP-TAMDAR + $, n_nr_sh_ArMa ! --AIREP-manAIREP + $, n_nr_sh_ArAr ! --AIREP-AIREP + $, n_near_0ll ! number of near dups with zero lat/lon +ccccdak $, n_nr_0ll_AcAc ! --ACARS-ACARS + $, n_nr_0ll_AcAc ! --TAMDAR-TAMDAR + $, n_nr_0ll_MdMd ! --MDCRS-MDCRS + $, n_nr_0ll_MaAr ! --manAIREP-AIREP + $, n_nr_0ll_AmAr ! --AMDAR-AIREP + $, n_nr_0ll_MaMa ! --manAIREP-manAIREP + $, n_nr_0ll_MaMd ! --manAIREP-MDCRS + $, n_nr_0ll_MdMa ! --MDCRS-manAIREP + $, n_nr_0ll_MaAm ! --manAIREP-AMDAR + $, n_nr_0ll_AmMa ! --AMDAR-manAIREP + $, n_near_ws ! number of near dups with missing winds + $, n_nr_mswn_MaMa ! --manAIREP-manAIREP + $, n_nr_mswn_MaAr ! --manAIREP-AIREP + $, n_nr_mswn_MaAm ! --manAIREP-AMDAR + $, n_nr_mswn_ArMa ! --AIREP-manAIREP + $, n_nr_mswn_ArAr ! --AIREP-AIREP +ccccdak $, n_nr_mswn_AcAc ! --ACARS-ACARS + $, n_nr_mswn_AcAc ! --TAMDAR-TAMDAR + $, n_nr_mswn_MdMd ! --MDCRS-MDCRS +ccccdak $, n_nr_mswn_AcMd ! --ACARS-MDCRS + $, n_nr_mswn_AcMd ! --TAMDAR-MDCRS +ccccdak $, n_nr_mswn_MdAc ! --MDCRS-ACARS + $, n_nr_mswn_MdAc ! --MDCRS-TAMDAR + $, n_nr_mswn_MdAm ! --MDCRS-AMDAR + $, n_nr_mswn_MdAr ! --MDCRS-AIREP + $, n_nr_mswn_MdMa ! --MDCRS-manAIREP +ccccdak $, n_nr_mswn_ArAc ! --AIREP-ACARS + $, n_nr_mswn_ArAc ! --AIREP-TAMDAR + $, n_nr_mswn_ArMd ! --AIREP-MDCRS +ccccdak $, n_nr_mswn_MaAc ! --manAIREP-ACARS + $, n_nr_mswn_MaAc ! --manAIREP-TAMDAR + $, n_nr_mswn_MaMd ! --manAIREP-MDCRS + $, n_nr_mswn_AmAm ! --AMDAR-AMDAR + $, n_nr_mswn_ArAm ! --AIREP-AMDAR + $, n_nr_mswn_AmAr ! --AMDAR-AIREP +ccccdak $, n_nr_mswn_AcAm ! --ACARS-AMDAR + $, n_nr_mswn_AcAm ! --TAMDAR-AMDAR + $, n_near_ws_IT ! number of near dups with missing winds + ! and with flight # beginning with 'IT' + $, n_near_ws_EU ! number of near dups with missing winds + ! and with flight # beginning with 'EU' + $, n_near_0ws ! number of near dups with zero winds + $, n_near_0ws_ArAm ! --AIREP-AMDAR + $, n_near_0ws_AmAr ! --AMDAR-AIREP + $, n_near_0ws_AmAm ! --AMDAR-AMDAR + $, n_near_0ws_ArAr ! --AIREP-AIREP + $, n_near_0ws_MaMa ! --manAIREP-manAIREP + $, n_near_0ws_MaMd ! --manAIREP-MDCRS + $, n_near_0ws_MaAm ! --manAIREP-AMDAR + $, n_near_0ws_MaAr ! --manAIREP-AIREP + $, n_near_0ws_ArMd ! --AIREP-MDCRS + $, n_near_0ws_MdMd ! --MDCRS-MDCRS + $, n_near_mst ! number of near dups with missing temperature + $, n_nr_mst_MaMa ! --manAIREP-manAIREP + $, n_nr_mst_MaAr ! --manAIREP-AIREP + $, n_nr_mst_MaAm ! --manAIREP-AMDAR +ccccdak $, n_nr_mst_ArAc ! --AIREP-ACARS + $, n_nr_mst_ArAc ! --AIREP-TAMDAR + $, n_nr_mst_ArMd ! --AIREP-MDCRS +ccccdak $, n_nr_mst_MaAc ! --manAIREP-ACARS + $, n_nr_mst_MaAc ! --manAIREP-TAMDAR + $, n_nr_mst_MaMd ! --manAIREP-MDCRS + $, n_nr_mst_MdMd ! --MDCRS-MDCRS + $, n_nr_mst_ArMa ! --manAIREP-AIREP + $, n_nr_mst_AmAm ! --AMDAR-AMDAR + $, n_nr_mst_ArAr ! --AIREP-AIREP + $, n_nr_mst_AmAr ! --AMDAR-AIREP + $, n_nr_mst_ArAm ! --AIREP-AMDAR +ccccdak $, n_near_MdAc ! number of near dups--MDCRS-ACARS + $, n_near_MdAc ! number of near dups--MDCRS-TAMDAR +ccccdak $, n_near_AcAr ! number of near dups--ACARS-AIREP + $, n_near_AcAr ! number of near dups--TAMDAR-AIREP + $, n_near_MdAr ! number of near dups--MDCRS-AIREP + $, n_near_AmAr ! number of near dups--AMDAR-AIREP +ccccdak $, n_near_AcMa ! number of near dups--ACARS-manAIREP + $, n_near_AcMa ! number of near dups--TAMDAR-manAIREP + $, n_near_MdMa ! number of near dups--MDCRS-manAIREP + $, n_near_ArMa ! number of near dups--AIREP-manAIREP + $, n_near_AmMa ! number of near dups--AIREP-manAIREP +ccccdak $, n_near_AcAc ! number of near dups--ACARS-ACARS + $, n_near_AcAc ! number of near dups--TAMDAR-TAMDAR + $, n_near_MdMd ! number of near dups--MDCRS-MDCRS + $, n_near_ArAr ! number of near dups--AIREP-AIREP + $, n_near_MaMa ! number of near dups--manAIREP-manAIREP + $, n_near_AmAm ! number of near dups--AMDAR-AMDAR + $, n_near_negpos ! number of near dups with neg/pos altitude +c +ccccdak integer n_slow_MdAc ! number of low-wind dups--MDCRS-ACARS + integer n_slow_MdAc ! number of low-wind dups--MDCRS-TAMDAR +ccccdak $, n_slow_AcAr ! number of low-wind dups--ACARS-AIREP + $, n_slow_AcAr ! number of low-wind dups--TAMDAR-AIREP + $, n_slow_MdAr ! number of low-wind dups--MDCRS-AIREP + $, n_slow_AmAr ! number of low-wind dups--AMDAR-AIREP + $, n_slow_ArMa ! number of low-wind dups--AIREP-manAIREP +ccccdak $, n_slow_AcAc ! number of low-wind dups--ACARS-ACARS + $, n_slow_AcAc ! number of low-wind dups--TAMDAR-TAMDAR + $, n_slow_MdMd ! number of low-wind dups--MDCRS-MDCRS + $, n_slow_ArAr ! number of low-wind dups--AIREP-AIREP + $, n_slow_MaMa ! number of low-wind dups--manAIREP-manAIREP + $, n_slow_AmAm ! number of low-wind dups--AMDAR-AMDAR +c + integer n_bad_encode ! number of bad-encode dups +c + integer n_ex_bad_roll_Md ! number of exact bad roll angle dups--MDCRS-MDCRS + integer n_ex_bad_roll_Am ! number of exact bad roll angle dups--AMDAR-AMDAR + integer n_nr_bad_roll_Md ! number of near bad roll angle dups--MDCRS-MDCRS + integer n_nr_bad_roll_Am ! number of near bad roll angle dups--AMDAR-AMDAR + integer n_nr_posrep ! number of position report dups--MDCRS-MDCRS +c + integer n_xx999_Ar ! number of aireps with missing id + $, n_xx999_Ma ! number of manual aireps with missing id + $, n_sh_Ar ! number of aireps with short id + $, n_sh_Ma ! number of manual aireps with short id + $, n_00_Md ! number of mdcrs with rounded position + $, n_0000_Md ! number of mdcrs with rounded position (0,0 deg) +ccccdak $, n_00_Ac ! number of acars with rounded position + $, n_00_Ac ! number of tamdar with rounded position +ccccdak $, n_0000_Ac ! number of acars with rounded position (0,0 deg) + $, n_0000_Ac ! number of tamdar with rounded position (0,0 deg) + $, n_00_Ar ! number of aireps with rounded position + $, n_0000_Ar ! number of aireps with rounded position (0,0 deg) + $, n_00_Ma ! number of manual aireps with rounded position + $, n_0000_Ma ! number of manual aireps with rounded pos (0,0 deg) + $, n_00_Am ! number of amdar with rounded position + $, n_0000_Am ! number of amdar with rounded position (0,0 deg) +c + integer n_lat ! latitude index + $, n_lon ! longitude index + $, n_area_Md(19,37) ! number of mdcrs reports by area +ccccdak $, n_area_Ac(19,37) ! number of acars reports by area + $, n_area_Ac(19,37) ! number of tamdar reports by area + $, n_area_Ar(19,37) ! number of airep reports by area + $, n_area_Ma(19,37) ! number of manual airep reports by area + $, n_area_Am(19,37) ! number of amdar reports by area + $, n_time_Md(24) ! number of mdcrs reports by time +ccccdak $, n_time_Ac(24) ! number of acars reports by time + $, n_time_Ac(24) ! number of tamdar reports by time + $, n_time_Ar(24) ! number of airep reports by time + $, n_time_Ma(24) ! number of manual airep reports by time + $, n_time_Am(24) ! number of amdar reports by time + $, n_lev_Md(53) ! number of mdcrs reports by level +ccccdak $, n_lev_Ac(53) ! number of acars reports by level + $, n_lev_Ac(53) ! number of tamdar reports by level + $, n_lev_Ar(53) ! number of airep reports by level + $, n_lev_Ma(53) ! number of manual airep reports by level + $, n_lev_Am(53) ! number of amdar reports by level + $, klev ! index for level + $, n_temp_Md(36,13) ! number of mdcrs reports by temp, alt +ccccdak $, n_temp_Ac(36,13) ! number of acars reports by temp, alt + $, n_temp_Ac(36,13) ! number of tamdar reports by temp, alt + $, n_temp_Ar(36,13) ! number of airep reports by temp, alt + $, n_temp_Ma(36,13) ! number of manual airep reports by temp, alt + $, n_temp_Am(36,13) ! number of amdar reports by temp, alt + $, ktemp ! index for temperature + $, kalt ! index for altitude + $, n_wspd_Md(40,13) ! number of mdcrs reports by wspd, alt +ccccdak $, n_wspd_Ac(40,13) ! number of acars reports by wspd, alt + $, n_wspd_Ac(40,13) ! number of tamdar reports by wspd, alt + $, n_wspd_Ar(40,13) ! number of airep reports by wspd, alt + $, n_wspd_Ma(40,13) ! number of manual airep reports by wspd, alt + $, n_wspd_Am(40,13) ! number of amdar reports by wspd, alt + $, kwspd ! index for windspeed +c +ccccdak integer nrep_Ac ! number of acars reports considered + integer nrep_Ac ! number of tamdar reports considered + $, nrep_Md ! number of mdcrs reports considered + $, nrep_Ma ! number of manual airep reports considered + $, nrep_Ar ! number of airep reports considered + $, nrep_Am ! number of amdar reports considered +ccccdak $, nbad_Ac ! number of bad acars + $, nbad_Ac ! number of bad tamdar + $, nbad_Md ! number of bad mdcrs + $, nbad_Ma ! number of bad manual aireps + $, nbad_Ar ! number of bad aireps + $, nbad_Am ! number of bad amdar +ccccdak $, ndup_Ac ! number of duplicate acars + $, ndup_Ac ! number of duplicate tamdar + $, ndup_Md ! number of duplicate mdcrs + $, ndup_Ma ! number of duplicate manual aireps + $, ndup_Ar ! number of duplicate aireps + $, ndup_Am ! number of duplicate amdar +c + integer kk ! index pointing to current flight +c $, kk1 ! index pointing to current flight +c $, kmap ! number of re-mapped flight ids + $, ihr_an ! hour of analysis + $, ihr_ob ! hour of observation +c +c Tail number statistics +c ---------------------- + integer kreg ! actual number of tail#s in dataset + $, mm ! index pointing to current tail number + character*8 creg_reg(maxflt) ! tail numbers + integer nobs_reg(maxflt,5) ! number of reports per tail# per type + integer nrej_reg(maxflt,5) ! number of reports rejected per tail# + integer ntemp_reg(maxflt,5) ! number of reports w. rejected temp + integer nwind_reg(maxflt,5) ! number of reports w. rejected winds +c +c Switches +c -------- + logical l_print ! print values if true + $, l_ii_sh ! true if ii rep has short id + $, l_iim1_sh ! true if iim1 rep has short id + $, l_ii_0lat ! true if ii rep has zero latitude + $, l_iim1_0lat ! true if iim1 rep has zero latitude + $, l_ii_0lon ! true if ii rep has zero latitude + $, l_iim1_0lon ! true if iim1 rep has zero latitude +ccccdak $, l_ii_acars ! true if ii rep is type acars + $, l_ii_acars ! true if ii rep is type tamdar +ccccdak $, l_iim1_acars ! true if iim1 rep is type acars + $, l_iim1_acars ! true if iim1 rep is type tamdar + $, l_ii_mdcrs ! true if ii rep is type mdcrs + $, l_iim1_mdcrs ! true if iim1 rep is type mdcrs + $, l_ii_airep ! true if ii rep is type airep + $, l_iim1_airep ! true if iim1 rep is type airep + $, l_ii_man ! true if ii rep is type manual airep + $, l_iim1_man ! true if iim1 rep is type manual airep + $, l_ii_amdar ! true if ii rep is type amdar + $, l_iim1_amdar ! true if iim1 rep is type amdar + $, l_last ! true if last time subroutine is called + $, l_save_dups ! save dups if true + $, l_operational ! run QC in operational mode if true + $, l_init ! initialize counters if true +c $, l_ual_all ! true if all remapped ids are UAL acft + $, l_ncep ! run QC w/ NCEP preferences if true +c + data l_save_dups/ .false. / +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c +c Initialize variables +c -------------------- +c ndup = 0 + nrej_reg = 0 + ntemp_reg = 0 + nwind_reg = 0 +c +c Initialize aircraft data types +c ------------------------------ + i_acars = insty_ob_fun('acars') + i_acars_lvl = insty_ob_fun('acars_lvl') + i_acars_asc = insty_ob_fun('acars_asc') + i_acars_des = insty_ob_fun('acars_des') + i_mdcrs = insty_ob_fun('mdcrs') + i_mdcrs_lvl = insty_ob_fun('mdcrs_lvl') + i_mdcrs_asc = insty_ob_fun('mdcrs_asc') + i_mdcrs_des = insty_ob_fun('mdcrs_des') + i_man_airep = insty_ob_fun('man-airep') + i_man_Yairep = insty_ob_fun('man-Yairep') + i_airep = insty_ob_fun('airep') + i_airep_lvl = insty_ob_fun('airep_lvl') + i_airep_asc = insty_ob_fun('airep_asc') + i_airep_des = insty_ob_fun('airep_des') + i_amdar = insty_ob_fun('amdar') + i_amdar_lvl = insty_ob_fun('amdar_lvl') + i_amdar_asc = insty_ob_fun('amdar_asc') + i_amdar_des = insty_ob_fun('amdar_des') +c +c Initialize counters +c ------------------- + if(l_init) then +c + n_exact = 0 + n_exact_sh = 0 + n_ex_sh_MaMa = 0 + n_ex_sh_MaAr = 0 + n_ex_sh_MaMd = 0 + n_ex_sh_MaAc = 0 + n_ex_sh_ArMa = 0 + n_ex_sh_ArAr = 0 + n_exact_0ll = 0 + n_ex_0ll_AcAc = 0 + n_ex_0ll_MdMd = 0 + n_ex_0ll_MaMa = 0 + n_ex_0ll_MaAr = 0 + n_exact_MdAc = 0 + n_exact_AcMa = 0 + n_exact_AcAr = 0 + n_exact_MdMa = 0 + n_exact_MdAr = 0 + n_exact_AmAr = 0 + n_exact_AmMa = 0 + n_exact_ArMa = 0 + n_exact_AcAc = 0 + n_exact_MdMd = 0 + n_exact_ArAr = 0 + n_exact_MaMa = 0 + n_exact_AmAm = 0 +c + n_near = 0 + n_near_sh = 0 + n_nr_sh_MaMa = 0 + n_nr_sh_MaAr = 0 + n_nr_sh_MaMd = 0 + n_nr_sh_MaAc = 0 + n_nr_sh_ArMa = 0 + n_nr_sh_ArAr = 0 + n_near_0ll = 0 + n_nr_0ll_AcAc = 0 + n_nr_0ll_MdMd = 0 + n_nr_0ll_MaAr = 0 + n_nr_0ll_AmAr = 0 + n_nr_0ll_MaMa = 0 + n_nr_0ll_MaMd = 0 + n_nr_0ll_MdMa = 0 + n_nr_0ll_MaAm = 0 + n_nr_0ll_AmMa = 0 + n_near_ws = 0 + n_nr_mswn_MaMa = 0 + n_nr_mswn_MaAr = 0 + n_nr_mswn_MaAm = 0 + n_nr_mswn_ArMa = 0 + n_nr_mswn_ArAr = 0 + n_nr_mswn_AcAc = 0 + n_nr_mswn_MdMd = 0 + n_nr_mswn_AcMd = 0 + n_nr_mswn_MdAc = 0 + n_nr_mswn_MdAm = 0 + n_nr_mswn_MdAr = 0 + n_nr_mswn_MdMa = 0 + n_nr_mswn_ArAc = 0 + n_nr_mswn_ArMd = 0 + n_nr_mswn_MaAc = 0 + n_nr_mswn_MaMd = 0 + n_nr_mswn_AmAm = 0 + n_nr_mswn_ArAm = 0 + n_nr_mswn_AmAr = 0 + n_nr_mswn_AcAm = 0 + n_near_ws_IT = 0 + n_near_ws_EU = 0 + n_near_0ws = 0 + n_near_0ws_ArAm = 0 + n_near_0ws_AmAr = 0 + n_near_0ws_AmAm = 0 + n_near_0ws_ArAr = 0 + n_near_0ws_MaMa = 0 + n_near_0ws_MaMd = 0 + n_near_0ws_MaAm = 0 + n_near_0ws_MaAr = 0 + n_near_0ws_ArMd = 0 + n_near_0ws_MdMd = 0 + n_near_mst = 0 + n_nr_mst_MaMa = 0 + n_nr_mst_MaAr = 0 + n_nr_mst_MaAm = 0 + n_nr_mst_ArAc = 0 + n_nr_mst_ArMd = 0 + n_nr_mst_MaAc = 0 + n_nr_mst_MaMd = 0 + n_nr_mst_MdMd = 0 + n_nr_mst_ArMa = 0 + n_nr_mst_AmAm = 0 + n_nr_mst_ArAr = 0 + n_nr_mst_AmAr = 0 + n_nr_mst_ArAm = 0 + n_near_MdAc = 0 + n_near_AcAr = 0 + n_near_MdAr = 0 + n_near_AmAr = 0 + n_near_AcMa = 0 + n_near_MdMa = 0 + n_near_ArMa = 0 + n_near_AmMa = 0 + n_near_AcAc = 0 + n_near_MdMd = 0 + n_near_ArAr = 0 + n_near_MaMa = 0 + n_near_AmAm = 0 + n_near_negpos = 0 + n_slow_MdAc = 0 + n_slow_AcAr = 0 + n_slow_MdAr = 0 + n_slow_AmAr = 0 + n_slow_ArMa = 0 + n_slow_AcAc = 0 + n_slow_MdMd = 0 + n_slow_ArAr = 0 + n_slow_MaMa = 0 + n_slow_AmAm = 0 +c + n_bad_encode = 0 +c + n_ex_bad_roll_Md = 0 + n_ex_bad_roll_Am = 0 + n_nr_bad_roll_Md = 0 + n_nr_bad_roll_Am = 0 + n_nr_posrep = 0 +c + n_xx999_Ar = 0 + n_xx999_Ma = 0 + n_sh_Ar = 0 + n_sh_Ma = 0 + n_00_Md = 0 + n_0000_Md = 0 + n_00_Ac = 0 + n_0000_Ac = 0 + n_00_Ar = 0 + n_0000_Ar = 0 + n_00_Ma = 0 + n_0000_Ma = 0 + n_00_Am = 0 + n_0000_Am = 0 +c + n_area_Md = 0 + n_area_Ac = 0 + n_area_Ar = 0 + n_area_Ma = 0 + n_area_Am = 0 +c + n_time_Md = 0 + n_time_Ac = 0 + n_time_Ar = 0 + n_time_Ma = 0 + n_time_Am = 0 +c + n_lev_Md = 0 + n_lev_Ac = 0 + n_lev_Ar = 0 + n_lev_Ma = 0 + n_lev_Am = 0 +c + n_temp_Md = 0 + n_temp_Ac = 0 + n_temp_Ar = 0 + n_temp_Ma = 0 + n_temp_Am = 0 +c + n_wspd_Md = 0 + n_wspd_Ac = 0 + n_wspd_Ar = 0 + n_wspd_Ma = 0 + n_wspd_Am = 0 +c + nrep_Ac = 0 + nrep_Md = 0 + nrep_Ma = 0 + nrep_Ar = 0 + nrep_Am = 0 + nbad_Ac = 0 + nbad_Md = 0 + nbad_Ma = 0 + nbad_Ar = 0 + nbad_Am = 0 + ndup_Ac = 0 + ndup_Md = 0 + ndup_Ma = 0 + ndup_Ar = 0 + ndup_Am = 0 + endif +c + read(cdtg_an,'(8x,i2)') ihr_an +c +c Begin loop over reports +c ----------------------- + do iob = 1,numreps +c +c Initialize indices +c ------------------ + ii = indx(iob) + knt0 = iob + knt = iob + if(iob.gt.1) then + iim1 = indx(iob-1) + else + iim1 = 0 + endif +c + if(iob.eq.1.and.c_qc(ii)(1:1).eq.'-') c_qc(ii)(1:1) = 'N' +c +c Set ktype +c --------- + if(itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des.or. + $ itype(ii).eq.i_mdcrs) then + ktype = 1 +c + elseif(itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des.or. + $ itype(ii).eq.i_acars) then + ktype = 2 +c + elseif(itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des.or. + $ itype(ii).eq.i_amdar) then + ktype = 3 +c + elseif(itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des.or. + $ itype(ii).eq.i_airep) then + ktype = 4 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + ktype = 5 + endif +c +c Examine the data distribution +c ----------------------------- +c +c Count UA reports with short ids +c ------------------------------- + if(c_acftid(ii)(1:2).eq.'UA'.and. + $ c_acftid(ii)(3:3).ne.'L'.and. + $ ktype.eq.4)then + n_sh_Ar = n_sh_Ar + 1 +c + elseif(c_acftid(ii)(1:2).eq.'UA'.and. + $ c_acftid(ii)(3:3).ne.'L'.and. + $ ktype.eq.5) then + n_sh_Ma = n_sh_Ma + 1 + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c +c Count reports with lat and lon in whole degrees +c (Count positions of 0.0 lat and 0.0 lon separately) +c --------------------------------------------------- + if((abs(alat(ii)-float(int(alat(ii)))).lt.0.001).and. + $ (abs(alon(ii)-float(int(alon(ii)))).lt.0.001)) then +c + if(ktype.eq.1) then + if(abs(alat(ii)).lt.0.001.and. + $ abs(alon(ii)).lt.0.001) then + n_0000_Md = n_0000_Md + 1 + else + n_00_Md = n_00_Md + 1 + endif + elseif(ktype.eq.2) then + if(abs(alat(ii)).lt.0.001.and. + $ abs(alon(ii)).lt.0.001) then + n_0000_Ac = n_0000_Ac + 1 + else + n_00_Ac = n_00_Ac + 1 + endif + elseif(ktype.eq.3) then + if(abs(alat(ii)).lt.0.001.and. + $ abs(alon(ii)).lt.0.001) then + n_0000_Am = n_0000_Am + 1 + else + n_00_Am = n_00_Am + 1 + endif + elseif(ktype.eq.4) then + if(abs(alat(ii)).lt.0.001.and. + $ abs(alon(ii)).lt.0.001) then + n_0000_Ar = n_0000_Ar + 1 + else + n_00_Ar = n_00_Ar + 1 + endif + elseif(ktype.eq.5) then + if(abs(alat(ii)).lt.0.001.and. + $ abs(alon(ii)).lt.0.001) then + n_0000_Ma = n_0000_Ma + 1 + else + n_00_Ma = n_00_Ma + 1 + endif + endif + endif +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c +c Count reports by geographic area +c -------------------------------- + n_lat = int(alat(ii))/10 + 10 + n_lon = int(alon(ii))/10 + 1 +c + if(ktype.eq.1) then + n_area_Md(n_lat,n_lon) = n_area_Md(n_lat,n_lon) + 1 +c + elseif(ktype.eq.2) then + n_area_Ac(n_lat,n_lon) = n_area_Ac(n_lat,n_lon) + 1 +c + elseif(ktype.eq.3) then + n_area_Am(n_lat,n_lon) = n_area_Am(n_lat,n_lon) + 1 +c + elseif(ktype.eq.4) then + n_area_Ar(n_lat,n_lon) = n_area_Ar(n_lat,n_lon) + 1 +c + elseif(ktype.eq.5) then + n_area_Ma(n_lat,n_lon) = n_area_Ma(n_lat,n_lon) + 1 + endif +c +c Count reports by time +c --------------------- + ihr_ob = idt(ii) + ihr_an * 3600 + if(ihr_ob.lt.0) then + ihr_ob = (24 * 3600) + ihr_ob + endif + ihr_ob = ihr_ob / 3600 + if(ihr_ob.lt.0.or.ihr_ob.gt.23) then + if(l_ncep) then +! DAK - NCEP runs centered at 21z (NDAS/RAP), 22z (RAP) and 23z (RAP) have many obs with +! ihr_ob > 23 since obs at the tail end of the time window radius move into the next +! day - so, if ihr_ob is 24-29, change to 00-05 to avoid array overflow here + if(ihr_ob.gt.23.and.ihr_ob.le.29) ihr_ob = ihr_ob - 24 + else + write(io8,*) 'Bad ihr_ob = ',ihr_ob, ihr_an, idt(ii), ii, + $ iob, c_acftid(ii), alat(ii), alon(ii), ht_ft(ii) + endif + endif +c + if(ktype.eq.1) then + n_time_Md(ihr_ob+1) = n_time_Md(ihr_ob+1) + 1 +c + elseif(ktype.eq.2) then + n_time_Ac(ihr_ob+1) = n_time_Ac(ihr_ob+1) + 1 +c + elseif(ktype.eq.3) then + n_time_Am(ihr_ob+1) = n_time_Am(ihr_ob+1) + 1 +c + elseif(ktype.eq.4) then + n_time_Ar(ihr_ob+1) = n_time_Ar(ihr_ob+1) + 1 +c + elseif(ktype.eq.5) then + n_time_Ma(ihr_ob+1) = n_time_Ma(ihr_ob+1) + 1 + endif +c +c Count reports by level, temperature, and windspeed +c -------------------------------------------------- + if(ht_ft(ii).lt.0) then + klev = 53 + elseif(ht_ft(ii).gt.50 000) then + klev = 52 + else + klev = ifix(ht_ft(ii)+500.) / 1000 + 1 + endif +c + if(ht_ft(ii).lt.0) then + kalt = 13 + elseif(ht_ft(ii).gt.50 000) then + kalt = 12 + else + kalt = ifix(ht_ft(ii)) / 5000 + 1 + endif +c + if(ob_t(ii).eq.amiss) then + ktemp = 36 + elseif(ob_t(ii).lt.173.16) then + ktemp = 35 + elseif(ob_t(ii).gt.333.16) then + ktemp = 34 + else + ktemp = (ob_t(ii)-173.16) / 5 + 1 + endif +c + if(ob_spd(ii).eq.amiss) then + kwspd = 40 + elseif(ob_spd(ii).lt.0) then + kwspd = 39 + elseif(ob_spd(ii).gt.180) then + kwspd = 38 + else + kwspd = ob_spd(ii) / 5 + 1 + endif +c + if(ktype.eq.1) then + n_lev_Md(klev) = n_lev_Md(klev) + 1 + n_temp_Md(ktemp,kalt) = n_temp_Md(ktemp,kalt) + 1 + n_wspd_Md(kwspd,kalt) = n_wspd_Md(kwspd,kalt) + 1 +c + elseif(ktype.eq.2) then + n_lev_Ac(klev) = n_lev_Ac(klev) + 1 + n_temp_Ac(ktemp,kalt) = n_temp_Ac(ktemp,kalt) + 1 + n_wspd_Ac(kwspd,kalt) = n_wspd_Ac(kwspd,kalt) + 1 +c + elseif(ktype.eq.3) then + n_lev_Am(klev) = n_lev_Am(klev) + 1 + n_temp_Am(ktemp,kalt) = n_temp_Am(ktemp,kalt) + 1 + n_wspd_Am(kwspd,kalt) = n_wspd_Am(kwspd,kalt) + 1 +c + elseif(ktype.eq.4) then + n_lev_Ar(klev) = n_lev_Ar(klev) + 1 + n_temp_Ar(ktemp,kalt) = n_temp_Ar(ktemp,kalt) + 1 + n_wspd_Ar(kwspd,kalt) = n_wspd_Ar(kwspd,kalt) + 1 +c + elseif(ktype.eq.5) then + n_lev_Ma(klev) = n_lev_Ma(klev) + 1 + n_temp_Ma(ktemp,kalt) = n_temp_Ma(ktemp,kalt) + 1 + n_wspd_Ma(kwspd,kalt) = n_wspd_Ma(kwspd,kalt) + 1 + endif +c +c Count reports with missing ids +c ------------------------------ + if(c_acftid(ii)(1:5).eq.'XX999'.or. + $ c_acftid(ii)(1:4).eq.'////') then +c + if(ktype.eq.4) then + n_xx999_Ar = n_xx999_Ar + 1 +c + elseif(ktype.eq.5) then + n_xx999_Ma = n_xx999_Ma + 1 + endif +c + endif +c +c Check for duplicates--uses algorithm like P. Phoebus's airepd +c Checks tail number, date-time, lat/lon, flight level, temp, winds +c ----------------------------------------------------------------- +c idt_dif = idt(ii) - idt(iim1) +c + idt_dif = 0 + kkdup = 0 +c +c Repeat check for all reports within 90 sec +c (90 sec used to check for dups with position reports--8/15/01) +c -------------------------------------------------------------- +c do while(idt_dif.eq.0.and. +c + do while(idt_dif.le.90.and. + $ idt_dif.ne.imiss.and. + $ iim1.ne.0) +c +c Initialize print switch +c ----------------------- + l_print = .false. +c +c Compute index for previous report +c --------------------------------- + knt = knt - 1 + 10 if(knt.gt.0) then + iim1 = indx(knt) + knt1 = knt + if(c_qc(iim1)(1:1).eq.'D'.or. + $ c_qc(iim1)(1:1).eq.'d'.or. + $ c_qc(iim1)(1:1).eq.'e'.or. + $ c_qc(iim1)(1:1).eq.'E'.or. + $ c_qc(iim1)(1:1).eq.'B') then + knt = knt - 1 + goto 10 + endif + else + iim1 = 0 + knt1 = 0 + endif +c +c Perform check only for valid iim1 +c --------------------------------- + if(iim1.ne.0) then +c +c Compute time difference between reports +c (Allow a time difference of up to 60 sec-- +c dups may have a time difference of 1 min) +c (changed to 90 sec--6/5/01) +c ------------------------------------------ + idt_dif = idt(ii) - idt(iim1) +c + kkdup = kkdup + 1 +c +c Set up logical variables used in testing for duplicates +c ------------------------------------------------------- +c +c iim1 report has short id? +c ------------------------- + l_iim1_sh = .false. + if(itype(iim1).eq.i_man_airep.or. + $ itype(iim1).eq.i_man_Yairep) then +c + if(c_acftid(iim1)(1:8).eq.c_acftid(ii)(1:8)) then + l_iim1_sh = .false. + elseif(c_acftid(ii)(1:3).eq.'UAL') then + if(c_acftid(iim1)(1:2).eq.'UA'.and. + $ c_acftid(iim1)(3:3).ne.'L') then + l_iim1_sh = .true. + else + l_iim1_sh = .false. + endif + elseif(c_acftid(iim1)(1:6).eq.c_acftid(ii)(1:6).and. + $ c_acftid(ii) (7:7).ne.' '.and. + $ c_acftid(iim1)(7:7).eq.' ') then + l_iim1_sh = .true. + elseif(c_acftid(iim1)(1:6).eq. + $ c_acftid(ii)(2:7)) then + l_iim1_sh = .true. + elseif(c_acftid(iim1)(1:6).eq. + $ c_acftid(ii)(1:2)//c_acftid(ii)(4:7)) then + l_iim1_sh = .true. + elseif(c_acftid(iim1)(1:6).eq. + $ c_acftid(ii)(1:3)//c_acftid(ii)(5:7)) then + l_iim1_sh = .true. + endif + endif +c +c ii report has short id? +c ----------------------- + l_ii_sh = .false. + if(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then +c + if(c_acftid(iim1)(1:8).eq.c_acftid(ii)(1:8)) then + l_ii_sh = .false. + elseif(c_acftid(iim1)(1:3).eq.'UAL') then + if(c_acftid(ii)(1:2).eq.'UA'.and. + $ c_acftid(ii)(3:3).ne.'L') then + l_ii_sh = .true. + else + l_ii_sh = .false. + endif + elseif(c_acftid(iim1)(1:6).eq.c_acftid(ii)(1:6).and. + $ c_acftid(iim1)(7:7).ne.' '.and. + $ c_acftid(ii) (7:7).eq.' ') then + l_ii_sh = .true. + elseif(c_acftid(ii)(1:6).eq. + $ c_acftid(iim1)(2:7)) then + l_ii_sh = .true. + elseif(c_acftid(ii)(1:6).eq. + $ c_acftid(iim1)(1:2)//c_acftid(iim1)(4:7)) then + l_ii_sh = .true. + elseif(c_acftid(ii)(1:6).eq. + $ c_acftid(iim1)(1:3)//c_acftid(iim1)(5:7)) then + l_ii_sh = .true. + endif + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c +c iim1 report has zero latitude? +c ------------------------------ + l_iim1_0lat = .false. + if(abs(alat(iim1)).lt.0.001.and. + $ alat(ii).gt.0.125.and. + $ alat(ii).lt.359.875) + $ l_iim1_0lat = .true. +c +c ii report has zero latitude? +c ---------------------------- + l_ii_0lat = .false. + if(abs(alat(ii)).lt.0.001.and. + $ alat(iim1).gt.0.125.and. + $ alat(iim1).lt.359.875) + $ l_ii_0lat = .true. +c +c iim1 report has zero longitude? +c ------------------------------- + l_iim1_0lon = .false. + if(abs(alon(iim1)).lt.0.001.and. + $ alon(ii).gt.0.125.and. + $ alon(ii).lt.359.875) + $ l_iim1_0lon = .true. +c +c ii report has zero longitude? +c ----------------------------- + l_ii_0lon = .false. + if(abs(alon(ii)).lt.0.001.and. + $ alon(iim1).gt.0.125.and. + $ alon(iim1).lt.359.875) + $ l_ii_0lon = .true. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c +ccccdak iim1 report is ACARS? +c iim1 report is TAMDAR? +c ---------------------- + l_iim1_acars = .false. + if(itype(iim1).eq.i_acars.or. + $ itype(iim1).eq.i_acars_lvl.or. + $ itype(iim1).eq.i_acars_des.or. + $ itype(iim1).eq.i_acars_asc) l_iim1_acars = .true. +c +ccccdak ii report is ACARS? +c ii report is TAMDAR? +c -------------------- + l_ii_acars = .false. + if(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_des.or. + $ itype(ii).eq.i_acars_asc) l_ii_acars = .true. +c +c iim1 report is MDCRS? +c --------------------- + l_iim1_mdcrs = .false. + if(itype(iim1).eq.i_mdcrs.or. + $ itype(iim1).eq.i_mdcrs_lvl.or. + $ itype(iim1).eq.i_mdcrs_des.or. + $ itype(iim1).eq.i_mdcrs_asc) l_iim1_mdcrs = .true. +c +c ii report is MDCRS? +c ------------------- + l_ii_mdcrs = .false. + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_des.or. + $ itype(ii).eq.i_mdcrs_asc) l_ii_mdcrs = .true. +c +c iim1 report is AIREP? +c --------------------- + l_iim1_airep = .false. + if(itype(iim1).eq.i_airep.or. + $ itype(iim1).eq.i_airep_lvl.or. + $ itype(iim1).eq.i_airep_des.or. + $ itype(iim1).eq.i_airep_asc) l_iim1_airep = .true. +c +c ii report is AIREP? +c ------------------- + l_ii_airep = .false. + if(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_des.or. + $ itype(ii).eq.i_airep_asc) l_ii_airep = .true. +c +c iim1 report is manual AIREP? +c ---------------------------- + l_iim1_man = .false. + if(itype(iim1).eq.i_man_airep.or. + $ itype(iim1).eq.i_man_Yairep) l_iim1_man = .true. +c +c ii report is manual AIREP? +c -------------------------- + l_ii_man = .false. + if(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) l_ii_man = .true. +c +c iim1 report is AMDAR? +c --------------------- + l_iim1_amdar = .false. + if(itype(iim1).eq.i_amdar.or. + $ itype(iim1).eq.i_amdar_lvl.or. + $ itype(iim1).eq.i_amdar_des.or. + $ itype(iim1).eq.i_amdar_asc) l_iim1_amdar = .true. +c +c ii report is AMDAR? +c ------------------- + l_ii_amdar = .false. + if(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_des.or. + $ itype(ii).eq.i_amdar_asc) l_ii_amdar = .true. +c +c Compute magnitude of direction difference +c (constrain to be less than 180 deg +c ----------------------------------------- + if(ob_dir(ii).eq.amiss.or. + $ ob_dir(iim1).eq.amiss) then + difdir = amiss + else + difdir = abs(ob_dir(iim1)-ob_dir(ii)) + if(difdir.gt.180) difdir = 360. - difdir + endif +c +c Check if report is exact dup (qc flag = 'D') +c -------------------------------------------- + if(idt_dif.eq.0) then +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if((abs(alat(iim1)-alat(ii)).lt.0.015.or. + $ l_iim1_0lat.or.l_ii_0lat).and. + $ (abs(alon(iim1)-alon(ii)).lt.0.015.or. + $ l_iim1_0lon.or.l_ii_0lon).and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ (abs(pres(iim1)-pres(ii)).lt.0.05.or. + $ abs(ht_ft(iim1)-ht_ft(ii)).lt.0.5).and. + $ abs(ob_t(iim1)-ob_t(ii)).lt.0.05.and. + $ ((abs(difdir).lt.2.5).or. + $ (ob_dir(iim1).eq.amiss.and.ob_dir(ii).eq.amiss)).and. + $ abs(ob_spd(iim1)-ob_spd(ii)).lt.0.05) then +c +c If exact dup found, decide which report to keep: +ccccdak Choose MDCRS over ACARS +c Choose MDCRS over TAMDAR +ccccdak Choose ACARS/MDCRS over AIREP +c Choose TAMDAR or MDCRS over AIREP +c Choose AMDAR over AIREP +c Choose automated over manual AIREP +c Choose 7-char flight number over 6-char flight number +c Choose present over missing flight/tail number +c Choose non-zero over zero lat or lon +c ------------------------------------------------------- +c +c Keep ob ii +c ---------- + if((l_ii_mdcrs.and.l_iim1_acars).or. + $ (l_ii_acars.and.l_iim1_airep).or. + $ (l_ii_mdcrs.and.l_iim1_airep).or. + $ (l_ii_amdar.and.l_iim1_airep).or. + $ (l_ii_mdcrs.and.l_iim1_man ).or. + $ (l_ii_acars.and.l_iim1_man ).or. + $ (l_ii_amdar.and.l_iim1_man ).or. + $ (l_ii_airep.and.l_iim1_man ).or. + $ l_iim1_sh.or. + $ l_iim1_0lat.or. + $ l_iim1_0lon) then +c + if(c_qc(iim1)(1:1).eq.'-'.or. + $ c_qc(iim1)(1:1).eq.'.'.or. + $ c_qc(iim1)(1:1).eq.'N') + $ c_qc(iim1)(1:1) = 'D' +c + if(c_qc(ii)(1:1).eq.'-') c_qc(ii)(1:1) = '.' +c +c Count rejects by category +c ------------------------- + n_exact = n_exact + 1 +c + if(l_iim1_sh) then + n_exact_sh = n_exact_sh + 1 + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*)'Exact dup found with short id--' + $, ii + endif + if(l_iim1_man.and.l_ii_man) then + n_ex_sh_MaMa = n_ex_sh_MaMa + 1 + if(l_print) + $ write(io8,*) 'manAIREP-manAIREP dup' + elseif(l_iim1_man.and.l_ii_airep) then + n_ex_sh_MaAr = n_ex_sh_MaAr + 1 + if(l_print) write(io8,*) 'manAIREP-AIREP dup' + elseif(l_iim1_man.and.l_ii_mdcrs) then + n_ex_sh_MaMd = n_ex_sh_MaMd + 1 + if(l_print) write(io8,*) 'manAIREP-MDCRS dup' + elseif(l_iim1_man.and.l_ii_acars) then + n_ex_sh_MaAc = n_ex_sh_MaAc + 1 +ccccdak if(l_print) write(io8,*) 'manAIREP-ACARS dup' + if(l_print) write(io8,*) 'manAIREP-TAMDAR dup' + elseif(l_ii_man.and.l_iim1_airep) then + n_ex_sh_ArMa = n_ex_sh_ArMa + 1 + if(l_print) write(io8,*) 'AIREP-manAIREP dup' + elseif(l_iim1_airep.and.l_ii_airep) then + n_ex_sh_ArAr = n_ex_sh_ArAr + 1 + if(l_print) write(io8,*) 'AIREP-AIREP dup' + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*)'Uncategorized short-id dup' + endif + endif +c + elseif(l_iim1_0lat.or.l_iim1_0lon) then + n_exact_0ll = n_exact_0ll + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Exact dup found with 0l/l--',ii + endif + if(l_iim1_acars.and.l_ii_acars) then + n_ex_0ll_AcAc = n_ex_0ll_AcAc + 1 +ccccdak if(l_print) write(io8,*) 'ACARS-ACARS dup' + if(l_print) write(io8,*) 'TAMDAR-TAMDAR dup' + elseif(l_iim1_mdcrs.and.l_ii_mdcrs) then + n_ex_0ll_MdMd = n_ex_0ll_MdMd + 1 + if(l_print) write(io8,*) 'MDCRS-MDCRS dup' + elseif(l_iim1_man.and.l_ii_man) then + n_ex_0ll_MaMa = n_ex_0ll_MaMa + 1 + if(l_print) + $ write(io8,*) 'manAIREP-manAIREP dup' + elseif(l_iim1_man.and.l_ii_airep) then + n_ex_0ll_MaAr = n_ex_0ll_MaAr + 1 + if(l_print) write(io8,*) 'manAIREP-AIREP dup' + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncategorized exact 0l/l dup' + endif + endif +c + elseif(l_ii_mdcrs.and.l_iim1_acars) then + n_exact_MdAc = n_exact_MdAc + 1 + l_print = .false. + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'MDCRS-ACARS exact dup found--' + write(io8,*) 'MDCRS-TAMDAR exact dup found--' + x, ii + endif +c + elseif(l_ii_acars.and.l_iim1_man) then + n_exact_AcMa = n_exact_AcMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'ACARS-manAIREP exact dup--',ii + write(io8,*) 'TAMDAR-manAIREP exact dup--',ii + endif +c + elseif(l_ii_acars.and.l_iim1_airep) then + n_exact_AcAr = n_exact_AcAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'ACARS-AIREP exact dup--',ii + write(io8,*) 'TAMDAR-AIREP exact dup--',ii + endif +c + elseif(l_ii_mdcrs.and.l_iim1_man) then + n_exact_MdMa = n_exact_MdMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'MDCRS-manAIREP exact dup--',ii + endif +c + elseif(l_ii_mdcrs.and.l_iim1_airep) then + n_exact_MdAr = n_exact_MdAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'MDCRS-AIREP exact dup found--',ii + endif +c + elseif(l_ii_amdar.and.l_iim1_airep) then + n_exact_AmAr = n_exact_AmAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AMDAR-AIREP exact dup found--' + $, ii + endif +c + elseif(l_ii_amdar.and.l_iim1_man) then + n_exact_AmMa = n_exact_AmMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AMDAR-manAIREP exact dup--',ii + endif +c + elseif(l_ii_airep.and.l_iim1_man) then + n_exact_ArMa = n_exact_ArMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AIREP-manAIREP exact dup--',ii + endif +c + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncategorized exact dup-1-',ii + endif + endif +c +c Keep ob iim1 +c ------------ + elseif((l_iim1_mdcrs.and.l_ii_acars).or. + $ (l_iim1_acars.and.l_ii_airep).or. + $ (l_iim1_mdcrs.and.l_ii_airep).or. + $ (l_iim1_amdar.and.l_ii_airep).or. + $ (l_iim1_mdcrs.and.l_ii_man ).or. + $ (l_iim1_acars.and.l_ii_man ).or. + $ (l_iim1_amdar.and.l_ii_man ).or. + $ (l_iim1_airep.and.l_ii_man ).or. + $ l_ii_sh.or. + $ l_ii_0lat.or. + $ l_ii_0lon) then +c + indx(knt1) = ii + indx(knt0) = iim1 + isave = ii + ii = iim1 + iim1 = isave +c + if(c_qc(iim1)(1:1).eq.'-'.or. + $ c_qc(iim1)(1:1).eq.'.'.or. + $ c_qc(iim1)(1:1).eq.'N') + $ c_qc(iim1)(1:1) = 'D' +c + if(c_qc(ii)(1:1).eq.'-') c_qc(ii)(1:1) = '.' +c +c Count rejects by category +c ------------------------- + n_exact = n_exact + 1 +c + if(l_ii_sh) then + n_exact_sh = n_exact_sh + 1 + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Exact dup with short id--',ii + endif + if(l_ii_man.and.l_iim1_man) then + n_ex_sh_MaMa = n_ex_sh_MaMa + 1 + if(l_print) + $ write(io8,*) 'manAIREP-manAIREP dup' + elseif(l_ii_man.and.l_iim1_airep) then + n_ex_sh_MaAr = n_ex_sh_MaAr + 1 + if(l_print) write(io8,*) 'manAIREP-AIREP dup' + elseif(l_ii_man.and.l_iim1_mdcrs) then + n_ex_sh_MaMd = n_ex_sh_MaMd + 1 + if(l_print) write(io8,*) 'manAIREP-MDCRS dup' + elseif(l_ii_man.and.l_iim1_acars) then + n_ex_sh_MaAc = n_ex_sh_MaAc + 1 +ccccdak if(l_print) write(io8,*) 'manAIREP-ACARS dup' + if(l_print) write(io8,*) 'manAIREP-TAMDAR dup' + elseif(l_iim1_man.and.l_ii_airep) then + n_ex_sh_ArMa = n_ex_sh_ArMa + 1 + if(l_print) write(io8,*) 'AIREP-manAIREP dup' + elseif(l_ii_airep.and.l_iim1_airep) then + n_ex_sh_ArAr = n_ex_sh_ArAr + 1 + if(l_print) write(io8,*) 'AIREP-AIREP dup' + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*)'Uncategorized short-id dup' + endif + endif +c + elseif(l_ii_0lat.or.l_ii_0lon) then + n_exact_0ll = n_exact_0ll + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Exact dup found with 0l/l--',ii + endif + if(l_iim1_acars.and.l_ii_acars) then + n_ex_0ll_AcAc = n_ex_0ll_AcAc + 1 +ccccdak if(l_print) write(io8,*) 'ACARS-ACARS dup' + if(l_print) write(io8,*) 'TAMDAR-TAMDAR dup' + elseif(l_iim1_mdcrs.and.l_ii_mdcrs) then + n_ex_0ll_MdMd = n_ex_0ll_MdMd + 1 + if(l_print) write(io8,*) 'MDCRS-MDCRS dup' + elseif(l_iim1_man.and.l_ii_man) then + n_ex_0ll_MaMa = n_ex_0ll_MaMa + 1 + if(l_print) + $ write(io8,*) 'manAIREP-manAIREP dup' + elseif(l_iim1_man.and.l_ii_airep) then + n_ex_0ll_MaAr = n_ex_0ll_MaAr + 1 + if(l_print) write(io8,*) 'manAIREP-AIREP dup' + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncategorized exact 0l/l dup' + endif + endif +c + elseif(l_iim1_mdcrs.and.l_ii_acars) then + n_exact_MdAc = n_exact_MdAc + 1 + l_print = .false. + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'MDCRS-ACARS exact dup found--' + write(io8,*) 'MDCRS-TAMDAR exact dup found--' + $, ii + endif +c + elseif(l_iim1_acars.and.l_ii_man) then + n_exact_AcMa = n_exact_AcMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'ACARS-manAIREP exact dup--',ii + write(io8,*) 'TAMDAR-manAIREP exact dup--',ii + endif +c + elseif(l_iim1_acars.and.l_ii_airep) then + n_exact_AcAr = n_exact_AcAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'ACARS-AIREP exact dup--',ii + write(io8,*) 'TAMDAR-AIREP exact dup--',ii + endif +c + elseif(l_iim1_mdcrs.and.l_ii_man) then + n_exact_MdMa = n_exact_MdMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'MDCRS-manAIREP exact dup--',ii + endif +c + elseif(l_iim1_mdcrs.and.l_ii_airep) then + n_exact_MdAr = n_exact_MdAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'MDCRS-AIREP exact dup found--',ii + endif +c + elseif(l_iim1_amdar.and.l_ii_airep) then + n_exact_AmAr = n_exact_AmAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AMDAR-AIREP exact dup found--' + $, ii + endif +c + elseif(l_iim1_amdar.and.l_ii_man) then + n_exact_AmMa = n_exact_AmMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AMDAR-manAIREP exact dup--',ii + endif +c + elseif(l_iim1_airep.and.l_ii_man) then + n_exact_ArMa = n_exact_ArMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AIREP-manAIREP exact dup--',ii + endif +c + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncategorized exact dup-2-',ii + endif + endif +c +c Duplicate pair doesn't fall in any of the above categories +c Keep ob ii +c ---------------------------------------------------------- + else +c + if(c_qc(iim1)(1:1).eq.'-'.or. + $ c_qc(iim1)(1:1).eq.'.'.or. + $ c_qc(iim1)(1:1).eq.'N') + $ c_qc(iim1)(1:1) = 'D' +c + if(c_qc(ii)(1:1).eq.'-') c_qc(ii)(1:1) = '.' +c +c Count rejects by category +c ------------------------- + n_exact = n_exact + 1 +c + if(l_ii_acars.and.l_iim1_acars) then + n_exact_AcAc = n_exact_AcAc + 1 + l_print = .false. + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'ACARS-ACARS exact dup found--' + write(io8,*) 'TAMDAR-TAMDAR exact dup found--' + $, ii + endif +c + elseif(l_ii_mdcrs.and.l_iim1_mdcrs) then + if(ichk_s(ii).eq.-10) then + n_ex_bad_roll_Md = n_ex_bad_roll_Md + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad roll qc ii--MdMd exact' + endif + ichk_t(ii) = ichk_t(iim1) + ichk_q(ii) = ichk_q(iim1) + ichk_d(ii) = ichk_d(iim1) + ichk_s(ii) = ichk_s(iim1) +c + elseif(ichk_s(iim1).eq.-10) then + n_ex_bad_roll_Md = n_ex_bad_roll_Md + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*)'Bad roll qc iim1--MdMd exact' + endif +c + else + n_exact_MdMd = n_exact_MdMd + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'MDCRS-MDCRS exact dup--',ii,iim1 + write(io8,*) 'c_qc =..',c_qc(ii),'..',c_qc(iim1) + endif + endif +c + elseif(l_ii_amdar.and.l_iim1_amdar) then + if(ichk_s(ii).eq.-10) then + n_ex_bad_roll_Am = n_ex_bad_roll_Am + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad roll qc ii--AmAm exact' + endif + ichk_t(ii) = ichk_t(iim1) + ichk_q(ii) = ichk_q(iim1) + ichk_d(ii) = ichk_d(iim1) + ichk_s(ii) = ichk_s(iim1) +c + elseif(ichk_s(iim1).eq.-10) then + n_ex_bad_roll_Am = n_ex_bad_roll_Am + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*)'Bad roll qc iim1--AmAm exact' + endif +c + else + n_exact_AmAm = n_exact_AmAm + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AMDAR-AMDAR exact dup--',ii,iim1 + write(io8,*) 'c_qc =..',c_qc(ii),'..',c_qc(iim1) + endif + endif +c + elseif(l_ii_airep.and.l_iim1_airep) then + n_exact_ArAr = n_exact_ArAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AIREP-AIREP exact dup found--' + $, ii + endif +c + elseif(l_ii_man.and.l_iim1_man) then + n_exact_MaMa = n_exact_MaMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'manAIREP-manAIREP exact dup--' + $, ii + endif +c + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncategorized exact dup-3-',ii + endif + endif + endif + endif + endif +c +c Check if report is a near dup (qc flag = 'd') +c Most near dups came in different formats with different units/precision +c ----------------------------------------------------------------------- +c +! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c First exclude reports that are too far apart--set c_qc to '.' +c ------------------------------------------------------------- + if((abs(alat(iim1)-alat(ii)).lt.0.125.or. + $ ( (l_iim1_0lat.or.l_ii_0lat).and. + $ (c_acftid(ii).eq.c_acftid(iim1).or. + $ l_ii_man.or.l_iim1_man) )).and. + $ (abs(alon(iim1)-alon(ii)).lt.0.125.or. + $ ( (l_iim1_0lon.or.l_ii_0lon).and. + $ (c_acftid(ii).eq.c_acftid(iim1).or. + $ l_ii_man.or.l_iim1_man) ))) then +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c +c Time threshold changed to 90 sec to look for position reports (8/15/01) +c ----------------------------------------------------------------------- + if((idt_dif.ge.0.and.idt_dif.le.90).and. + $ c_qc(iim1)(1:1).ne.'D'.and. +c +c AMDAR-AIREP dups below 25,000' +c + $ ((ht_ft(ii).lt.25000..and. + $ ifix(ht_ft(iim1)).eq.-ifix(ht_ft(ii)).and. + $ ((( (l_ii_amdar.and.l_iim1_airep).or. + $ (l_ii_airep.and.l_iim1_amdar) ).and. + $ c_acftid(ii).eq.c_acftid(iim1) ).or. ! new + $ l_ii_amdar.and.l_iim1_man.or. + $ l_ii_man.and.l_iim1_amdar ).or. +c +c high-res dups below 25,000' +c + $ abs(ht_ft(iim1)-ht_ft(ii)).lt. + $ htdif_same/4.+0.5).or. +c +c MDCRS cross-type dups below 25,000' +c + $ (ht_ft(ii).lt.25000..and. + $ ((l_ii_mdcrs.and.(.not.l_iim1_mdcrs)).or. ! new + $ (l_iim1_mdcrs.and.(.not.l_ii_mdcrs)).or. ! new + $ (l_ii_mdcrs.and. ! new on 6/5/01 + $ (itype(ii ).ne.i_mdcrs.and. ! " + $ itype(iim1).eq.i_mdcrs).and. ! " + $ c_acftid(ii).eq.c_acftid(iim1)).or. ! " + $ (l_iim1_mdcrs.and. ! " + $ (itype(iim1).ne.i_mdcrs.and. ! " + $ itype(ii ).eq.i_mdcrs).and. ! " + $ c_acftid(ii).eq.c_acftid(iim1)).or. ! " + $ (l_ii_acars.and.(.not.l_iim1_acars)).or. ! new + $ (l_iim1_acars.and.(.not.l_ii_acars)).or. ! new + $ (l_ii_man.and.(.not.l_iim1_man)).or. ! new + $ (l_iim1_man.and.(.not.l_ii_man)).or. ! new + $ (((l_ii_amdar.and.l_iim1_amdar).or. ! new + $ (l_ii_airep.and.l_iim1_amdar).or. ! new + $ (l_iim1_airep.and.l_ii_amdar)).and. ! new + $ c_acftid(ii).eq.c_acftid(iim1))).and. ! new + $ abs(ht_ft(iim1)-ht_ft(ii)).lt.htdif_same+0.5).or. +c +c dups above 25,000' +c + $ (ht_ft(ii).gt.24999.5.and. + $ abs(ht_ft(iim1)-ht_ft(ii)).lt.htdif_same+0.5)).and. +c +c other criteria +c + $ (abs(ob_t(iim1)-ob_t(ii)).lt.1.25.or. + $ (ob_t(iim1).eq.amiss.and.ob_t(ii).ne.amiss).or. + $ (ob_t(iim1).ne.amiss.and.ob_t(ii).eq.amiss)).and. +c + $ (abs(difdir).lt.10.5.or. + $ (ob_dir(iim1).eq.amiss.and.ob_dir(ii).eq.amiss).or. + $ (ob_dir(iim1).eq.amiss.and.ob_dir(ii).ne.amiss).or. + $ (ob_dir(iim1).ne.amiss.and.ob_dir(ii).eq.amiss).or. + $ (ob_spd(iim1).eq.amiss.and.ob_spd(ii).ne.amiss).or. + $ (ob_spd(iim1).ne.amiss.and.ob_spd(ii).eq.amiss).or. + $ (ob_dir(iim1).lt.0.5.and.ob_dir(ii).lt.0.5).or. + $ (ob_dir(iim1).lt.0.5.and.difdir.gt.10.5).or. + $ (difdir.gt.10.5.and.ob_dir(ii).lt.0.5)).and. +c + $ (abs(ob_spd(iim1)-ob_spd(ii)).lt.1.25.or. + $ (ob_spd(iim1).eq.amiss.and.ob_spd(ii).eq.amiss).or. + $ (ob_spd(iim1).eq.amiss.and.ob_spd(ii).ne.amiss).or. + $ (ob_spd(iim1).ne.amiss.and.ob_spd(ii).eq.amiss).or. + $ (ob_dir(iim1).eq.amiss.and.ob_dir(ii).eq.amiss).or. + $ (ob_dir(iim1).eq.amiss.and.ob_dir(ii).ne.amiss).or. + $ (ob_dir(iim1).ne.amiss.and.ob_dir(ii).eq.amiss).or. + $ (ob_spd(iim1).lt.0.05.and.ob_spd(ii).lt.0.05).or. + $ (ob_spd(iim1).lt.0.05.and.ob_spd(ii).gt.1.25).or. + $ (ob_spd(iim1).gt.1.25.and.ob_spd(ii).lt.0.05))) then +c +c Count duplicates where one has neg and the other pos altitude +c ------------------------------------------------------------- + if(abs(abs(ht_ft(iim1))-abs(ht_ft(ii))).lt.0.5.and. + $ abs(ht_ft(iim1)-ht_ft(ii)).gt.0.5) then + n_near_negpos = n_near_negpos + 1 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Neg-pos altitude dup found' + endif + endif +c +c If near dup found, decide which report to keep +ccccdak Choose MDCRS over ACARS +c Choose MDCRS over TAMDAR +c Choose reports with flight phase over no reported flight phase +ccccdak Choose ACARS/MDCRS over AIREP/manual AIREP +c Choose TAMDAR or MDCRS over AIREP/manual AIREP +c Choose AMDAR over AIREP/manual AIREP +c Choose automated over manual AIREP +c Choose 7-char flight number over 6-char flight number +c Choose present over missing flight/tail number +c Choose present over missing/zero wind speed or direction +c Choose non-zero over zero lat or lon +c ---------------------------------------------------------------- +c +c Keep ob ii +c ---------- + if( ( ( ((l_ii_mdcrs.and.l_iim1_acars).or. + $ (l_ii_mdcrs.and.l_iim1_mdcrs.and. + $ .not.(itype(ii).eq.i_mdcrs.and. + $ itype(iim1).ne.i_mdcrs)).or. + $ (l_ii_acars.and.l_iim1_acars).or. + $ (l_ii_amdar.and.l_iim1_amdar).or. ! new + $ (l_ii_amdar.and.l_iim1_airep)).and. ! new + $ c_acftreg(ii).eq.c_acftreg(iim1) ).and. +c +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + $ ((abs(alat(iim1)-alat(ii)).lt.0.025.and. + $ abs(alon(iim1)-alon(ii)).lt.0.025.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ abs(ob_t(iim1)-ob_t(ii)).lt.0.65.and. + $ ((abs(difdir).lt.5.5).or. + $ (ob_dir(ii).eq.amiss.and. + $ ob_dir(iim1).eq.amiss).or. + $ (ob_dir(ii).ne.amiss.and. + $ ob_dir(iim1).eq.amiss).or. + $ (ob_spd(ii).ne.amiss.and. + $ ob_spd(iim1).eq.amiss).or. + $ (ob_dir(ii).gt.10.5.and. + $ ob_dir(iim1).lt.0.5)).and. + $ ((abs(ob_spd(iim1)-ob_spd(ii)).lt.0.55).or. + $ (ob_spd(ii).eq.amiss.and. + $ ob_spd(iim1).eq.amiss).or. + $ (ob_spd(ii).ne.amiss.and. + $ ob_spd(iim1).eq.amiss).or. + $ (ob_dir(ii).eq.amiss.and. + $ ob_dir(iim1).eq.amiss).or. + $ (ob_dir(ii).ne.amiss.and. + $ ob_dir(iim1).eq.amiss).or. + $ (ob_spd(ii).gt.1.25.and. + $ ob_spd(iim1).lt.0.05)) ).or. +c +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + $ (abs(alat(iim1)-alat(ii)).lt.0.055.and. + $ abs(alon(iim1)-alon(ii)).lt.0.055.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ abs(ht_ft(iim1)-ht_ft(ii)).lt.15.5.and. + $ idt_dif.le.30.and. + $ abs(ob_t(iim1)-ob_t(ii)).lt.1.25.and. + $ ((abs(difdir).lt.10.5).or. + $ (ob_dir(ii).eq.amiss.and. + $ ob_dir(iim1).eq.amiss).or. + $ (ob_dir(ii).ne.amiss.and. + $ ob_dir(iim1).eq.amiss).or. + $ (ob_spd(ii).ne.amiss.and. + $ ob_spd(iim1).eq.amiss).or. + $ (ob_dir(ii).gt.10.5.and. + $ ob_dir(iim1).lt.0.5)).and. + $ ((abs(ob_spd(iim1)-ob_spd(ii)).lt.1.25).or. + $ (ob_spd(ii).eq.amiss.and. + $ ob_spd(iim1).eq.amiss).or. + $ (ob_spd(ii).ne.amiss.and. + $ ob_spd(iim1).eq.amiss).or. + $ (ob_dir(ii).eq.amiss.and. + $ ob_dir(iim1).eq.amiss).or. + $ (ob_dir(ii).ne.amiss.and. + $ ob_dir(iim1).eq.amiss).or. + $ (ob_spd(ii).gt.1.25.and. + $ ob_spd(iim1).lt.0.05)) ))).or. +c + $ (l_ii_airep.and.l_iim1_man).or. +c + $ (l_ii_acars.and.l_iim1_airep).or. + $ (l_ii_mdcrs.and.l_iim1_airep).or. +c + $ (l_ii_acars.and.l_iim1_man).or. + $ (l_ii_mdcrs.and.l_iim1_man).or. +c + $ (l_ii_amdar.and.l_iim1_man).or. +c + $ ((itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des).and. + $ itype(iim1).eq.i_mdcrs).or. +c + $ l_iim1_sh.or. +c +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + $ (l_iim1_0lat.and.abs(alat(ii)).gt.0.125).or. +c + $ (l_iim1_0lon.and. + $ (alon(ii).gt.0.125.and.alon(ii).lt.359.875)).or. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c + $ (ob_t(ii).ne.amiss.and.ob_t(iim1).eq.amiss).or. +c + $ (.not.(l_ii_mdcrs.and.l_iim1_acars).and. + $ .not.(l_ii_mdcrs.and.l_iim1_mdcrs).and. + $ .not.(l_ii_acars.and.l_iim1_acars).and. + $ ((ob_spd(ii).ne.amiss.and.ob_spd(iim1).eq.amiss).or. + $ (ob_dir(ii).ne.amiss.and.ob_dir(iim1).eq.amiss).or. + $ (((ob_spd(ii).gt.1.25.and.ob_spd(iim1).lt.0.05).or. + $ (difdir.gt.10.5.and.ob_dir(iim1).lt.0.5)).and. + $ c_acftid(ii).eq.c_acftid(iim1)))) ) then +c + if(c_qc(iim1)(1:1).eq.'-'.or. + $ c_qc(iim1)(1:1).eq.'.'.or. + $ c_qc(iim1)(1:1).eq.'N') + $ c_qc(iim1)(1:1) = 'd' +c + if(c_qc(ii)(1:1).eq.'-') c_qc(ii)(1:1) = '.' +c +c Count rejects by category +c ------------------------- + n_near = n_near + 1 +c + if(l_iim1_sh) then + n_near_sh = n_near_sh + 1 + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Near dup found with short id--' + $, ii + endif + if(l_iim1_man.and.l_ii_man) then + n_nr_sh_MaMa = n_nr_sh_MaMa + 1 + if(l_print) + $ write(io8,*) 'manAIREP-manAIREP dup' + elseif(l_iim1_man.and.l_ii_airep) then + n_nr_sh_MaAr = n_nr_sh_MaAr + 1 + if(l_print) write(io8,*) 'manAIREP-AIREP dup' + elseif(l_iim1_man.and.l_ii_mdcrs) then + n_nr_sh_MaMd = n_nr_sh_MaMd + 1 + if(l_print) write(io8,*) 'manAIREP-MDCRS dup' + elseif(l_iim1_man.and.l_ii_acars) then + n_nr_sh_MaAc = n_nr_sh_MaAc + 1 +ccccdak if(l_print) write(io8,*) 'manAIREP-ACARS dup' + if(l_print) write(io8,*) 'manAIREP-TAMDAR dup' + elseif(l_ii_man.and.l_iim1_airep) then + n_nr_sh_ArMa = n_nr_sh_ArMa + 1 + if(l_print) write(io8,*) 'AIREP-manAIREP dup' + elseif(l_iim1_airep.and.l_ii_airep) then + n_nr_sh_ArAr = n_nr_sh_ArAr + 1 + if(l_print) write(io8,*) 'AIREP-AIREP dup' + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncategorized short-id dup' + endif + endif +c +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + elseif(((l_iim1_0lat.and. + $ abs(alat(ii)).gt.0.125).or. + $ (l_iim1_0lon.and. + $ (alon(ii).gt.0.125.and. + $ alon(ii).lt.359.875))).and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ (c_acftid(ii).eq.c_acftid(iim1).or. + $ l_ii_man.or.l_iim1_man)) then + n_near_0ll = n_near_0ll + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Near dup found with 0l/l--',ii + endif + if(l_iim1_acars.and.l_ii_acars) then + n_nr_0ll_AcAc = n_nr_0ll_AcAc + 1 +ccccdak if(l_print) write(io8,*) 'ACARS-ACARS dup' + if(l_print) write(io8,*) 'TAMDAR-TAMDAR dup' + elseif(l_iim1_mdcrs.and.l_ii_mdcrs) then + n_nr_0ll_MdMd = n_nr_0ll_MdMd + 1 + if(l_print) write(io8,*) 'MDCRS-MDCRS dup' + elseif(l_iim1_man.and.l_ii_airep) then + n_nr_0ll_MaAr = n_nr_0ll_MaAr + 1 + if(l_print) write(io8,*) 'manAIREP-AIREP dup' + elseif(l_iim1_amdar.and.l_ii_airep) then + n_nr_0ll_AmAr = n_nr_0ll_AmAr + 1 + if(l_print) write(io8,*) 'AMDAR-AIREP dup' + elseif(l_iim1_man.and.l_ii_man) then + n_nr_0ll_MaMa = n_nr_0ll_MaMa + 1 + if(l_print) write(io8,*) 'manAIREP-manAIREP dup' + elseif(l_iim1_man.and.l_ii_mdcrs) then + n_nr_0ll_MaMd = n_nr_0ll_MaMd + 1 + if(l_print) write(io8,*) 'manAIREP-MDCRS dup' + elseif(l_iim1_mdcrs.and.l_ii_man) then + n_nr_0ll_MdMa = n_nr_0ll_MdMa + 1 + if(l_print) write(io8,*) 'MDCRS-manAIREP dup' + elseif(l_iim1_man.and.l_ii_amdar) then + n_nr_0ll_MaAm = n_nr_0ll_MaAm + 1 + if(l_print) write(io8,*) 'manAIREP-AMDAR dup' + elseif(l_iim1_amdar.and.l_ii_man) then + n_nr_0ll_AmMa = n_nr_0ll_AmMa + 1 + if(l_print) write(io8,*) 'AMDAR-manAIREP dup' + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncategorized near 0l/l dup' + endif + endif +c + elseif(ob_t(ii).ne.amiss.and. + $ ob_t(iim1).eq.amiss) then + n_near_mst = n_near_mst + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Near dup found with msg temp--' + $, ii + endif + if(l_iim1_man.and.l_ii_man) then + n_nr_mst_MaMa = n_nr_mst_MaMa + 1 + if(l_print) + $ write(io8,*) 'manAIREP-manAIREP dup' + elseif(l_iim1_man.and.l_ii_airep) then + n_nr_mst_MaAr = n_nr_mst_MaAr + 1 + if(l_print) write(io8,*) 'manAIREP-AIREP dup' + elseif(l_iim1_man.and.l_ii_amdar) then + n_nr_mst_MaAm = n_nr_mst_MaAm + 1 + if(l_print) write(io8,*) 'manAIREP-AMDAR dup' + elseif(l_iim1_airep.and.l_ii_acars) then + n_nr_mst_ArAc = n_nr_mst_ArAc + 1 +ccccdak if(l_print) write(io8,*) 'AIREP-ACARS dup' + if(l_print) write(io8,*) 'AIREP-TAMDAR dup' + elseif(l_iim1_airep.and.l_ii_mdcrs) then + n_nr_mst_ArMd = n_nr_mst_ArMd + 1 + if(l_print) write(io8,*) 'AIREP-MDCRS dup' + elseif(l_iim1_man.and.l_ii_acars) then + n_nr_mst_MaAc = n_nr_mst_MaAc + 1 +ccccdak if(l_print) write(io8,*) 'manAIREP-ACARS dup' + if(l_print) write(io8,*) 'manAIREP-TAMDAR dup' + elseif(l_iim1_man.and.l_ii_mdcrs) then + n_nr_mst_MaMd = n_nr_mst_MaMd + 1 + if(l_print) write(io8,*) 'manAIREP-MDCRS dup' + elseif(l_iim1_mdcrs.and.l_ii_mdcrs) then + n_nr_mst_MdMd = n_nr_mst_MdMd + 1 + if(l_print) write(io8,*) 'MDCRS-MDCRS dup' + elseif(l_iim1_airep.and.l_ii_man) then + n_nr_mst_ArMa = n_nr_mst_ArMa + 1 + if(l_print) write(io8,*) 'AIREP-manAIREP dup' + elseif(l_iim1_amdar.and.l_ii_amdar) then + n_nr_mst_AmAm = n_nr_mst_AmAm + 1 + if(l_print) write(io8,*) 'AMDAR-AMDAR dup' + elseif(l_iim1_airep.and.l_ii_airep) then + n_nr_mst_ArAr = n_nr_mst_ArAr + 1 + if(l_print) write(io8,*) 'AIREP-AIREP dup' + elseif(l_iim1_airep.and.l_ii_amdar) then + n_nr_mst_ArAm = n_nr_mst_ArAm + 1 + if(l_print) write(io8,*) 'AIREP-AMDAR dup' + elseif(l_iim1_amdar.and.l_ii_airep) then + n_nr_mst_AmAr = n_nr_mst_AmAr + 1 + if(l_print) write(io8,*) 'AMDAR-AIREP dup' + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncategorized msg-temp dup' + endif + endif +c + elseif((ob_spd(ii).ne.amiss.and. + $ ob_spd(iim1).eq.amiss).or. + $ (ob_dir(ii).ne.amiss.and. + $ ob_dir(iim1).eq.amiss)) then + n_near_ws = n_near_ws + 1 + l_print = .false. + if(c_acftid(ii)(1:2).eq.'IT') then + n_near_ws_IT = n_near_ws_IT + 1 + l_print = .false. + elseif(c_acftid(ii)(1:2).eq.'EU') then + n_near_ws_EU = n_near_ws_EU + 1 + l_print = .false. + endif + if(l_print) then + write(io8,*) + write(io8,*) 'Near dup with msg winds--',ii + endif + if(l_iim1_man.and.l_ii_man) then + n_nr_mswn_MaMa = n_nr_mswn_MaMa + 1 + if(l_print) + $ write(io8,*) 'manAIREP-manAIREP dup' + elseif(l_iim1_man.and.l_ii_airep) then + n_nr_mswn_MaAr = n_nr_mswn_MaAr + 1 + if(l_print) write(io8,*) 'manAIREP-AIREP dup' + elseif(l_iim1_man.and.l_ii_amdar) then + n_nr_mswn_MaAm = n_nr_mswn_MaAm + 1 + if(l_print) write(io8,*) 'manAIREP-AMDAR dup' + elseif(l_ii_man.and.l_iim1_airep) then + n_nr_mswn_ArMa = n_nr_mswn_ArMa + 1 + if(l_print) write(io8,*) 'AIREP-manAIREP dup' + elseif(l_iim1_airep.and.l_ii_airep) then + n_nr_mswn_ArAr = n_nr_mswn_ArAr + 1 + if(l_print) write(io8,*) 'AIREP-AIREP dup' + elseif(l_iim1_acars.and.l_ii_acars) then + n_nr_mswn_AcAc = n_nr_mswn_AcAc + 1 +ccccdak if(l_print) write(io8,*) 'ACARS-ACARS dup' + if(l_print) write(io8,*) 'TAMDAR-TAMDAR dup' + elseif(l_iim1_mdcrs.and.l_ii_mdcrs) then + n_nr_mswn_MdMd = n_nr_mswn_MdMd + 1 + if(l_print) write(io8,*) 'MDCRS-MDCRS dup' + elseif(l_iim1_acars.and.l_ii_mdcrs) then + n_nr_mswn_AcMd = n_nr_mswn_AcMd + 1 +ccccdak if(l_print) write(io8,*) 'ACARS-MDCRS dup' + if(l_print) write(io8,*) 'TAMDAR-MDCRS dup' + elseif(l_iim1_mdcrs.and.l_ii_acars) then + n_nr_mswn_MdAc = n_nr_mswn_MdAc + 1 +ccccdak if(l_print) write(io8,*) 'MDCRS-ACARS dup' + if(l_print) write(io8,*) 'MDCRS-TAMDAR dup' + elseif(l_iim1_mdcrs.and.l_ii_amdar) then + n_nr_mswn_MdAm = n_nr_mswn_MdAm + 1 + if(l_print) write(io8,*) 'MDCRS-AMDAR dup' + elseif(l_iim1_mdcrs.and.l_ii_airep) then + n_nr_mswn_MdAr = n_nr_mswn_MdAr + 1 + if(l_print) write(io8,*) 'MDCRS-AIREP dup' + elseif(l_iim1_mdcrs.and.l_ii_man) then + n_nr_mswn_MdMa = n_nr_mswn_MdMa + 1 + if(l_print) write(io8,*) 'MDCRS-manAIREP dup' + elseif(l_iim1_airep.and.l_ii_acars) then + n_nr_mswn_ArAc = n_nr_mswn_ArAc + 1 +ccccdak if(l_print) write(io8,*) 'AIREP-ACARS dup' + if(l_print) write(io8,*) 'AIREP-TAMDAR dup' + elseif(l_iim1_airep.and.l_ii_mdcrs) then + n_nr_mswn_ArMd = n_nr_mswn_ArMd + 1 + if(l_print) write(io8,*) 'AIREP-MDCRS dup' + elseif(l_iim1_man.and.l_ii_acars) then + n_nr_mswn_MaAc = n_nr_mswn_MaAc + 1 +ccccdak if(l_print) write(io8,*) 'manAIREP-ACARS dup' + if(l_print) write(io8,*) 'manAIREP-TAMDAR dup' + elseif(l_iim1_man.and.l_ii_mdcrs) then + n_nr_mswn_MaMd = n_nr_mswn_MaMd + 1 + if(l_print) write(io8,*) 'manAIREP-MDCRS dup' + elseif(l_iim1_amdar.and.l_ii_amdar) then + n_nr_mswn_AmAm = n_nr_mswn_AmAm + 1 + if(l_print) write(io8,*) 'AMDAR-AMDAR dup' + elseif(l_iim1_airep.and.l_ii_amdar) then + n_nr_mswn_ArAm = n_nr_mswn_ArAm + 1 + if(l_print) write(io8,*) 'AIREP-AMDAR dup' + elseif(l_iim1_amdar.and.l_ii_airep) then + n_nr_mswn_AmAr = n_nr_mswn_AmAr + 1 + if(l_print) write(io8,*) 'AMDAR-AIREP dup' + elseif(l_iim1_acars.and.l_ii_amdar) then + n_nr_mswn_AcAm = n_nr_mswn_AcAm + 1 +ccccdak if(l_print) write(io8,*) 'ACARS-AMDAR dup' + if(l_print) write(io8,*) 'TAMDAR-AMDAR dup' + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncategorized msg-wind dup' + endif + endif +c + elseif((ob_spd(ii).gt.1.25.and. + $ ob_spd(iim1).lt.0.05).or. + $ (ob_dir(ii).gt.10.5.and. + $ difdir.gt.10.5.and. + $ ob_dir(iim1).lt.0.5)) then + n_near_0ws = n_near_0ws + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Near dup found with 0 winds-1-' + $, ii + endif + if(l_iim1_airep.and.l_ii_amdar) then + n_near_0ws_ArAm = n_near_0ws_ArAm + 1 + if(l_print) write(io8,*) 'AIREP-AMDAR dup' + elseif(l_iim1_amdar.and.l_ii_airep) then + n_near_0ws_AmAr = n_near_0ws_AmAr + 1 + if(l_print) write(io8,*) 'AMDAR-AIREP dup' + elseif(l_iim1_amdar.and.l_ii_amdar) then + n_near_0ws_AmAm = n_near_0ws_AmAm + 1 + if(l_print) write(io8,*) 'AMDAR-AMDAR dup' + elseif(l_iim1_airep.and.l_ii_airep) then + n_near_0ws_ArAr = n_near_0ws_ArAr + 1 + if(l_print) write(io8,*) 'AIREP-AIREP dup' + elseif(l_iim1_man.and.l_ii_man) then + n_near_0ws_MaMa = n_near_0ws_MaMa + 1 + if(l_print) + $ write(io8,*) 'manAIREP-manAIREP dup' + elseif(l_iim1_man.and.l_ii_mdcrs) then + n_near_0ws_MaMd = n_near_0ws_MaMd + 1 + if(l_print) + $ write(io8,*) 'manAIREP-MDCRS dup' + elseif(l_iim1_man.and.l_ii_amdar) then + n_near_0ws_MaAm = n_near_0ws_MaAm + 1 + if(l_print) + $ write(io8,*) 'manAIREP-AMDAR dup' + elseif(l_iim1_man.and.l_ii_airep) then + n_near_0ws_MaAr = n_near_0ws_MaAr + 1 + if(l_print) + $ write(io8,*) 'manAIREP-AIREP dup' + elseif(l_iim1_airep.and.l_ii_mdcrs) then + n_near_0ws_ArMd = n_near_0ws_ArMd + 1 + if(l_print) + $ write(io8,*) 'AIREP-MDCRS dup' + elseif(l_iim1_mdcrs.and.l_ii_mdcrs) then + n_near_0ws_MdMd = n_near_0ws_MdMd + 1 + if(l_print) + $ write(io8,*) 'MDCRS-MDCRS dup' + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*)'Uncategorized zero-wind dup' + write(io8,*) ' dir difference = ',difdir + endif + endif +c + elseif(l_ii_mdcrs.and.l_iim1_acars) then + n_near_MdAc = n_near_MdAc + 1 + l_print = .false. + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'MDCRS-ACARS near dup found--',ii + write(io8,*) 'MDCRS-TAMDAR near dup found--',ii + endif +c + elseif(l_ii_mdcrs.and.l_iim1_mdcrs) then + if(itype(iim1).eq.i_mdcrs.and. + $ itype(ii ).ne.i_mdcrs) then + n_nr_posrep = n_nr_posrep + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'MDCRS position report dup-1-',ii + endif +c + elseif(ichk_s(ii ).eq.-10.and. + $ ichk_s(iim1).ne.-10) then + n_nr_bad_roll_Md = n_nr_bad_roll_Md + 1 + l_print = .false. !!!! + if(l_print) then + write(io8,*) + write(io8,*) 'Bad roll qc ii--MdMd near' + endif + ichk_t(ii) = ichk_t(iim1) + ichk_q(ii) = ichk_q(iim1) + ichk_d(ii) = ichk_d(iim1) + ichk_s(ii) = ichk_s(iim1) +c + elseif(ichk_s(iim1).eq.-10.and. + $ ichk_s(ii ).ne.-10) then + n_nr_bad_roll_Md = n_nr_bad_roll_Md + 1 + l_print = .false. !!!! + if(l_print) then + write(io8,*) + write(io8,*) 'Bad roll qc iim1--MdMd near' + endif +c + else + n_near_MdMd = n_near_MdMd + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'MDCRS-MDCRS near dup found--',ii + endif + endif +c + elseif(l_ii_acars.and.l_iim1_acars) then + n_near_AcAc = n_near_AcAc + 1 + l_print = .false. + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'ACARS-ACARS near dup found--',ii + write(io8,*) 'TAMDAR-TAMDAR near dup found--',ii + endif +c + elseif(l_ii_acars.and.l_iim1_airep) then + n_near_AcAr = n_near_AcAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'ACARS-AIREP near dup found--',ii + write(io8,*) 'TAMDAR-AIREP near dup found--',ii + endif +c + elseif(l_ii_mdcrs.and.l_iim1_airep) then + n_near_MdAr = n_near_MdAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'MDCRS-AIREP near dup found--',ii + endif +c + elseif(l_ii_amdar.and.l_iim1_amdar) then + if(ichk_s(ii ).eq.-10.and. + $ ichk_s(iim1).ne.-10) then + n_nr_bad_roll_Am = n_nr_bad_roll_Am + 1 + l_print = .false. !!!! + if(l_print) then + write(io8,*) + write(io8,*) 'Bad roll qc ii--AmAm near' + endif + ichk_t(ii) = ichk_t(iim1) + ichk_q(ii) = ichk_q(iim1) + ichk_d(ii) = ichk_d(iim1) + ichk_s(ii) = ichk_s(iim1) +c + elseif(ichk_s(iim1).eq.-10.and. + $ ichk_s(ii ).ne.-10) then + n_nr_bad_roll_Am = n_nr_bad_roll_Am + 1 + l_print = .false. !!!! + if(l_print) then + write(io8,*) + write(io8,*) 'Bad roll qc iim1--AmAm near' + endif +c + else + n_near_AmAm = n_near_AmAm + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AMDAR-AMDAR near dup found--',ii + endif + endif +c + elseif(l_ii_amdar.and.l_iim1_airep) then + n_near_AmAr = n_near_AmAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AMDAR-AIREP near dup found--',ii + endif +c + elseif(l_ii_acars.and.l_iim1_man) then + n_near_AcMa = n_near_AcMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'ACARS-manAIREP near dup--',ii + write(io8,*) 'TAMDAR-manAIREP near dup--',ii + endif +c + elseif(l_ii_mdcrs.and.l_iim1_man) then + n_near_MdMa = n_near_MdMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'MDCRS-manAIREP near dup--',ii + endif +c + elseif(l_ii_airep.and.l_iim1_man) then + n_near_ArMa = n_near_ArMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AIREP-manAIREP near dup--',ii + endif +c + elseif(l_ii_amdar.and.l_iim1_man) then + n_near_AmMa = n_near_AmMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AMDAR-manAIREP near dup--',ii + endif +c + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncategorized near dup-1-',ii, + $ ' difdir = ',difdir + endif + endif +c +c Keep ob iim1 +c ------------ + elseif( ( ( ((l_iim1_mdcrs.and.l_ii_acars).or. + $ (itype(ii).eq.i_mdcrs.and. + $ itype(iim1).ne.i_mdcrs).or. + $ (l_iim1_amdar.and.l_ii_airep)).and. + $ c_acftreg(ii).eq.c_acftreg(iim1)).and. +! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c + $ ((abs(alat(iim1)-alat(ii)).lt.0.025.and. + $ abs(alon(iim1)-alon(ii)).lt.0.025.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ abs(ob_t(iim1)-ob_t(ii)).lt.0.65.and. + $ ((abs(difdir).lt.5.5).or. + $ (ob_dir(ii).eq.amiss.and. + $ ob_dir(iim1).eq.amiss).or. + $ (ob_dir(ii).eq.amiss.and. + $ ob_dir(iim1).ne.amiss).or. + $ (ob_spd(ii).eq.amiss.and. + $ ob_spd(iim1).ne.amiss).or. + $ (ob_dir(iim1).gt.10.5.and. + $ ob_dir(ii).lt.0.5)).and. + $ ((abs(ob_spd(iim1)-ob_spd(ii)).lt.0.55 ).or. + $ (ob_spd(ii).eq.amiss.and. + $ ob_spd(iim1).eq.amiss).or. + $ (ob_spd(ii).eq.amiss.and. + $ ob_spd(iim1).ne.amiss).or. + $ (ob_dir(ii).eq.amiss.and. + $ ob_dir(iim1).eq.amiss).or. + $ (ob_dir(ii).eq.amiss.and. + $ ob_dir(iim1).ne.amiss).or. + $ (ob_spd(iim1).gt.1.25.and. + $ ob_spd(ii).lt.0.05)) ).or. +c +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + $ (abs(alat(iim1)-alat(ii)).lt.0.055.and. + $ abs(alon(iim1)-alon(ii)).lt.0.055.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ abs(ht_ft(iim1)-ht_ft(ii)).lt.15.5.and. + $ idt_dif.le.30.and. + $ abs(ob_t(iim1)-ob_t(ii)).lt.1.25.and. + $ ((abs(difdir).lt.10.5).or. + $ (ob_dir(ii).eq.amiss.and. + $ ob_dir(iim1).eq.amiss).or. + $ (ob_dir(ii).eq.amiss.and. + $ ob_dir(iim1).ne.amiss).or. + $ (ob_spd(ii).eq.amiss.and. + $ ob_spd(iim1).ne.amiss).or. + $ (ob_dir(iim1).gt.10.5.and. + $ ob_dir(ii).lt.0.5)).and. + $ ((abs(ob_spd(iim1)-ob_spd(ii)).lt.1.25 ).or. + $ (ob_spd(ii).eq.amiss.and. + $ ob_spd(iim1).eq.amiss).or. + $ (ob_spd(ii).eq.amiss.and. + $ ob_spd(iim1).ne.amiss).or. + $ (ob_dir(ii).eq.amiss.and. + $ ob_dir(iim1).ne.amiss).or. + $ (ob_dir(ii).eq.amiss.and. + $ ob_dir(iim1).eq.amiss).or. + $ (ob_spd(iim1).gt.1.25.and. + $ ob_spd(ii).lt.0.05)) ))).or. +c + $ (l_iim1_airep.and.l_ii_man).or. +c + $ (l_iim1_acars.and.l_ii_airep).or. + $ (l_iim1_mdcrs.and.l_ii_airep).or. +c + $ (l_iim1_acars.and.l_ii_man).or. + $ (l_iim1_mdcrs.and.l_ii_man).or. +c + $ (l_iim1_amdar.and.l_ii_man).or. +c + $ ((itype(iim1).eq.i_mdcrs_lvl.or. + $ itype(iim1).eq.i_mdcrs_asc.or. + $ itype(iim1).eq.i_mdcrs_des).and. + $ itype(ii).eq.i_mdcrs).or. +c + $ l_ii_sh.or. +c +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + $ (l_ii_0lat.and.abs(alat(ii)).gt.0.125).or. +c + $ (l_ii_0lon.and. + $ (alon(ii).gt.0.125.and.alon(ii).lt.359.875)).or. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c + $ (ob_t(iim1).ne.amiss.and.ob_t(ii).eq.amiss).or. +c + $ (.not.(l_ii_mdcrs.and.l_iim1_acars).and. + $ .not.(l_ii_mdcrs.and.l_iim1_mdcrs).and. + $ .not.(l_ii_acars.and.l_iim1_acars).and. + $ ((ob_spd(iim1).ne.amiss.and. + $ ob_spd(ii).eq.amiss).or. + $ (ob_dir(iim1).ne.amiss.and. + $ ob_dir(ii).eq.amiss).or. + $ (((ob_spd(iim1).gt.1.25.and. + $ ob_spd(ii).lt.0.05).or. + $ (difdir.gt.10.5.and.ob_dir(ii).lt.0.5)).and. + $ (c_acftid(ii).eq.c_acftid(iim1)) )) )) then +c + indx(knt1) = ii + indx(knt0) = iim1 + isave = ii + ii = iim1 + iim1 = isave +c + if(c_qc(iim1)(1:1).eq.'-'.or. + $ c_qc(iim1)(1:1).eq.'.'.or. + $ c_qc(iim1)(1:1).eq.'N') + $ c_qc(iim1)(1:1) = 'd' +c + if(c_qc(ii)(1:1).eq.'-') c_qc(ii)(1:1) = '.' +c +c Count rejects by category +c ------------------------- + n_near = n_near + 1 +c + if(l_ii_sh) then + n_near_sh = n_near_sh + 1 + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Near dup found with short id--' + $, ii + endif + if(l_ii_man.and.l_iim1_man) then + n_nr_sh_MaMa = n_nr_sh_MaMa + 1 + if(l_print) + $ write(io8,*) 'manAIREP-manAIREP dup' + elseif(l_ii_man.and.l_iim1_airep) then + n_nr_sh_MaAr = n_nr_sh_MaAr + 1 + if(l_print) write(io8,*) 'manAIREP-AIREP dup' + elseif(l_ii_man.and.l_iim1_mdcrs) then + n_nr_sh_MaMd = n_nr_sh_MaMd + 1 + if(l_print) write(io8,*) 'manAIREP-MDCRS dup' + elseif(l_ii_man.and.l_iim1_acars) then + n_nr_sh_MaAc = n_nr_sh_MaAc + 1 +ccccdak if(l_print) write(io8,*) 'manAIREP-ACARS dup' + if(l_print) write(io8,*) 'manAIREP-TAMDAR dup' + elseif(l_iim1_man.and.l_ii_airep) then + n_nr_sh_ArMa = n_nr_sh_ArMa + 1 + if(l_print) write(io8,*) 'AIREP-manAIREP dup' + elseif(l_ii_airep.and.l_iim1_airep) then + n_nr_sh_ArAr = n_nr_sh_ArAr + 1 + if(l_print) write(io8,*) 'AIREP-AIREP dup' + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncategorized short-id dup' + endif + endif +c +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + elseif(((l_ii_0lat.and.abs(alat(ii)).gt.0.125).or. + $ (l_ii_0lon.and. + $ (alon(ii).gt.0.125.and. + $ alon(ii).lt.359.875))).and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ (c_acftid(ii).eq.c_acftid(iim1).or. + $ l_ii_man.or.l_iim1_man)) then + n_near_0ll = n_near_0ll + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Near dup found with 0l/l--',ii + endif + if(l_iim1_acars.and.l_ii_acars) then + n_nr_0ll_AcAc = n_nr_0ll_AcAc + 1 +ccccdak if(l_print) write(io8,*) 'ACARS-ACARS dup' + if(l_print) write(io8,*) 'TAMDAR-TAMDAR dup' + elseif(l_iim1_mdcrs.and.l_ii_mdcrs) then + n_nr_0ll_MdMd = n_nr_0ll_MdMd + 1 + if(l_print) write(io8,*) 'MDCRS-MDCRS dup' + elseif(l_ii_man.and.l_iim1_airep) then + n_nr_0ll_MaAr = n_nr_0ll_MaAr + 1 + if(l_print) write(io8,*) 'manAIREP-AIREP dup' + elseif(l_ii_amdar.and.l_iim1_airep) then + n_nr_0ll_AmAr = n_nr_0ll_AmAr + 1 + if(l_print) write(io8,*) 'AMDAR-AIREP dup' + elseif(l_ii_man.and.l_iim1_man) then + n_nr_0ll_MaMa = n_nr_0ll_MaMa + 1 + if(l_print) write(io8,*) 'manAIREP-manAIREP dup' + elseif(l_ii_man.and.l_iim1_mdcrs) then + n_nr_0ll_MaMd = n_nr_0ll_MaMd + 1 + if(l_print) write(io8,*) 'manAIREP-MDCRS dup' + elseif(l_ii_mdcrs.and.l_iim1_man) then + n_nr_0ll_MdMa = n_nr_0ll_MdMa + 1 + if(l_print) write(io8,*) 'MDCRS-manAIREP dup' + elseif(l_ii_man.and.l_iim1_amdar) then + n_nr_0ll_MaAm = n_nr_0ll_MaAm + 1 + if(l_print) write(io8,*) 'manAIREP-AMDAR dup' + elseif(l_ii_amdar.and.l_iim1_man) then + n_nr_0ll_AmMa = n_nr_0ll_AmMa + 1 + if(l_print) write(io8,*) 'AMDAR-manAIREP dup' + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncategorized near 0l/l dup' + endif + endif +c + elseif(ob_t(ii).ne.amiss.and. + $ ob_t(iim1).eq.amiss) then + n_near_mst = n_near_mst + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Near dup found with msg temp--' + $, ii + endif + if(l_ii_man.and.l_iim1_man) then + n_nr_mst_MaMa = n_nr_mst_MaMa + 1 + if(l_print) + $ write(io8,*) 'manAIREP-manAIREP dup' + elseif(l_ii_man.and.l_iim1_airep) then + n_nr_mst_MaAr = n_nr_mst_MaAr + 1 + if(l_print) write(io8,*) 'manAIREP-AIREP dup' + elseif(l_ii_man.and.l_iim1_amdar) then + n_nr_mst_MaAm = n_nr_mst_MaAm + 1 + if(l_print) write(io8,*) 'manAIREP-AMDAR dup' + elseif(l_ii_airep.and.l_iim1_acars) then + n_nr_mst_ArAc = n_nr_mst_ArAc + 1 +ccccdak if(l_print) write(io8,*) 'AIREP-ACARS dup' + if(l_print) write(io8,*) 'AIREP-TAMDAR dup' + elseif(l_ii_airep.and.l_iim1_mdcrs) then + n_nr_mst_ArMd = n_nr_mst_ArMd + 1 + if(l_print) write(io8,*) 'AIREP-MDCRS dup' + elseif(l_ii_man.and.l_iim1_acars) then + n_nr_mst_MaAc = n_nr_mst_MaAc + 1 +ccccdak if(l_print) write(io8,*) 'manAIREP-ACARS dup' + if(l_print) write(io8,*) 'manAIREP-TAMDAR dup' + elseif(l_ii_man.and.l_iim1_mdcrs) then + n_nr_mst_MaMd = n_nr_mst_MaMd + 1 + if(l_print) write(io8,*) 'manAIREP-MDCRS dup' + elseif(l_ii_mdcrs.and.l_iim1_mdcrs) then + n_nr_mst_MdMd = n_nr_mst_MdMd + 1 + if(l_print) write(io8,*) 'manAIREP-MDCRS dup' + elseif(l_iim1_man.and.l_ii_airep) then + n_nr_mst_ArMa = n_nr_mst_ArMa + 1 + if(l_print) write(io8,*) 'AIREP-manAIREP dup' + elseif(l_ii_amdar.and.l_iim1_amdar) then + n_nr_mst_AmAm = n_nr_mst_AmAm + 1 + if(l_print) write(io8,*) 'AMDAR-AMDAR dup' + elseif(l_ii_airep.and.l_iim1_airep) then + n_nr_mst_ArAr = n_nr_mst_ArAr + 1 + if(l_print) write(io8,*) 'AIREP-AIREP dup' + elseif(l_ii_amdar.and.l_iim1_airep) then + n_nr_mst_AmAr = n_nr_mst_AmAr + 1 + if(l_print) write(io8,*) 'AMDAR-AIREP dup' + elseif(l_ii_airep.and.l_iim1_amdar) then + n_nr_mst_ArAm = n_nr_mst_ArAm + 1 + if(l_print) write(io8,*) 'AIREP-AMDAR dup' + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncategorized msg-temp dup' + endif + endif +c + elseif((ob_spd(ii).ne.amiss.and. + $ ob_spd(iim1).eq.amiss).or. + $ (ob_dir(ii).ne.amiss.and. + $ ob_dir(iim1).eq.amiss)) then + n_near_ws = n_near_ws + 1 + l_print = .false. + if(c_acftid(iim1)(1:2).eq.'IT') then + n_near_ws_IT = n_near_ws_IT + 1 + l_print = .false. + elseif(c_acftid(iim1)(1:2).eq.'EU') then + n_near_ws_EU = n_near_ws_EU + 1 + l_print = .false. + endif + if(l_print) then + write(io8,*) + write(io8,*) 'Near dup with msg winds--',ii + endif + if(l_ii_man.and.l_iim1_man) then + n_nr_mswn_MaMa = n_nr_mswn_MaMa + 1 + if(l_print) + $ write(io8,*) 'manAIREP-manAIREP dup' + elseif(l_ii_man.and.l_iim1_airep) then + n_nr_mswn_MaAr = n_nr_mswn_MaAr + 1 + if(l_print) write(io8,*) 'manAIREP-AIREP dup' + elseif(l_ii_man.and.l_iim1_amdar) then + n_nr_mswn_MaAm = n_nr_mswn_MaAm + 1 + if(l_print) write(io8,*) 'manAIREP-AMDAR dup' + elseif(l_iim1_man.and.l_ii_airep) then + n_nr_mswn_ArMa = n_nr_mswn_ArMa + 1 + if(l_print) write(io8,*) 'AIREP-manAIREP dup' + elseif(l_ii_airep.and.l_iim1_airep) then + n_nr_mswn_ArAr = n_nr_mswn_ArAr + 1 + if(l_print) write(io8,*) 'AIREP-AIREP dup' + elseif(l_ii_acars.and.l_iim1_acars) then + n_nr_mswn_AcAc = n_nr_mswn_AcAc + 1 +ccccdak if(l_print) write(io8,*) 'ACARS-ACARS dup' + if(l_print) write(io8,*) 'TAMDAR-TAMDAR dup' + elseif(l_ii_mdcrs.and.l_iim1_mdcrs) then + n_nr_mswn_MdMd = n_nr_mswn_MdMd + 1 + if(l_print) write(io8,*) 'MDCRS-MDCRS dup' + elseif(l_ii_acars.and.l_iim1_mdcrs) then + n_nr_mswn_AcMd = n_nr_mswn_AcMd + 1 +ccccdak if(l_print) write(io8,*) 'ACARS-MDCRS dup' + if(l_print) write(io8,*) 'TAMDAR-MDCRS dup' + elseif(l_ii_mdcrs.and.l_iim1_acars) then + n_nr_mswn_MdAc = n_nr_mswn_MdAc + 1 +ccccdak if(l_print) write(io8,*) 'MDCRS-ACARS dup' + if(l_print) write(io8,*) 'MDCRS-TAMDAR dup' + elseif(l_ii_mdcrs.and.l_iim1_amdar) then + n_nr_mswn_MdAm = n_nr_mswn_MdAm + 1 + if(l_print) write(io8,*) 'MDCRS-AMDAR dup' + elseif(l_ii_mdcrs.and.l_iim1_airep) then + n_nr_mswn_MdAr = n_nr_mswn_MdAr + 1 + if(l_print) write(io8,*) 'MDCRS-AIREP dup' + elseif(l_ii_mdcrs.and.l_iim1_man) then + n_nr_mswn_MdMa = n_nr_mswn_MdMa + 1 + if(l_print) write(io8,*) 'MDCRS-manAIREP dup' + elseif(l_ii_airep.and.l_iim1_acars) then + n_nr_mswn_ArAc = n_nr_mswn_ArAc + 1 +ccccdak if(l_print) write(io8,*) 'AIREP-ACARS dup' + if(l_print) write(io8,*) 'AIREP-TAMDAR dup' + elseif(l_ii_airep.and.l_iim1_mdcrs) then + n_nr_mswn_ArMd = n_nr_mswn_ArMd + 1 + if(l_print) write(io8,*) 'AIREP-MDCRS dup' + elseif(l_ii_man.and.l_iim1_acars) then + n_nr_mswn_MaAc = n_nr_mswn_MaAc + 1 +ccccdak if(l_print) write(io8,*) 'manAIREP-ACARS dup' + if(l_print) write(io8,*) 'manAIREP-TAMDAR dup' + elseif(l_ii_man.and.l_iim1_mdcrs) then + n_nr_mswn_MaMd = n_nr_mswn_MaMd + 1 + if(l_print) write(io8,*) 'manAIREP-MDCRS dup' + elseif(l_ii_amdar.and.l_iim1_amdar) then + n_nr_mswn_AmAm = n_nr_mswn_AmAm + 1 + if(l_print) write(io8,*) 'AMDAR-AMDAR dup' + elseif(l_ii_airep.and.l_iim1_amdar) then + n_nr_mswn_ArAm = n_nr_mswn_ArAm + 1 + if(l_print) write(io8,*) 'AIREP-AMDAR dup' + elseif(l_ii_amdar.and.l_iim1_airep) then + n_nr_mswn_AmAr = n_nr_mswn_AmAr + 1 + if(l_print) write(io8,*) 'AMDAR-AIREP dup' + elseif(l_ii_acars.and.l_iim1_amdar) then + n_nr_mswn_AcAm = n_nr_mswn_AcAm + 1 +ccccdak if(l_print) write(io8,*) 'ACARS-AMDAR dup' + if(l_print) write(io8,*) 'TAMDAR-AMDAR dup' + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncategorized msg-wind dup' + endif + endif +c + elseif((ob_spd(ii).gt.1.25.and. + $ ob_spd(iim1).lt.0.05).or. + $ (ob_dir(ii).gt.10.5.and. + $ difdir.gt.10.5.and. + $ ob_dir(iim1).lt.0.5)) then + n_near_0ws = n_near_0ws + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Near dup found with 0 winds-2-' + $, ii + endif + if(l_ii_airep.and.l_iim1_amdar) then + n_near_0ws_ArAm = n_near_0ws_ArAm + 1 + if(l_print) write(io8,*) 'AIREP-AMDAR dup' + elseif(l_ii_amdar.and.l_iim1_airep) then + n_near_0ws_AmAr = n_near_0ws_AmAr + 1 + if(l_print) write(io8,*) 'AMDAR-AIREP dup' + elseif(l_ii_amdar.and.l_iim1_amdar) then + n_near_0ws_AmAm = n_near_0ws_AmAm + 1 + if(l_print) write(io8,*) 'AMDAR-AMDAR dup' + elseif(l_ii_airep.and.l_iim1_airep) then + n_near_0ws_ArAr = n_near_0ws_ArAr + 1 + if(l_print) write(io8,*) 'AIREP-AIREP dup' + elseif(l_ii_man.and.l_iim1_man) then + n_near_0ws_MaMa = n_near_0ws_MaMa + 1 + if(l_print) + $ write(io8,*) 'manAIREP-manAIREP dup' + elseif(l_ii_man.and.l_iim1_mdcrs) then + n_near_0ws_MaMd = n_near_0ws_MaMd + 1 + if(l_print) + $ write(io8,*) 'manAIREP-MDCRS dup' + elseif(l_ii_man.and.l_iim1_amdar) then + n_near_0ws_MaAm = n_near_0ws_MaAm + 1 + if(l_print) + $ write(io8,*) 'manAIREP-AMDAR dup' + elseif(l_ii_man.and.l_iim1_airep) then + n_near_0ws_MaAr = n_near_0ws_MaAr + 1 + if(l_print) + $ write(io8,*) 'manAIREP-AIREP dup' + elseif(l_ii_airep.and.l_iim1_mdcrs) then + n_near_0ws_ArMd = n_near_0ws_ArMd + 1 + if(l_print) + $ write(io8,*) 'AIREP-MDCRS dup' + elseif(l_ii_mdcrs.and.l_iim1_mdcrs) then + n_near_0ws_MdMd = n_near_0ws_MdMd + 1 + if(l_print) + $ write(io8,*) 'MDCRS-MDCRS dup' + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*)'Uncategorized zero-wind dup' + write(io8,*) ' dir difference = ',difdir + endif + endif +c + elseif(l_iim1_mdcrs.and.l_ii_acars) then + n_near_MdAc = n_near_MdAc + 1 + l_print = .false. + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'MDCRS-ACARS near dup found--',ii + write(io8,*) 'MDCRS-TAMDAR near dup found--',ii + endif +c + elseif(itype(iim1).eq.i_mdcrs.and. + $ itype(ii ).ne.i_mdcrs) then + n_nr_posrep = n_nr_posrep + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'MDCRS position report dup-2-',ii + endif +c + elseif(l_iim1_acars.and.l_ii_airep) then + n_near_AcAr = n_near_AcAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'ACARS-AIREP near dup found--',ii + write(io8,*) 'TAMDAR-AIREP near dup found--',ii + endif +c + elseif(l_iim1_mdcrs.and.l_ii_airep) then + n_near_MdAr = n_near_MdAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'MDCRS-AIREP near dup found--',ii + endif +c + elseif(l_iim1_amdar.and.l_ii_airep) then + n_near_AmAr = n_near_AmAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AMDAR-AIREP near dup found--',ii + endif +c + elseif(l_iim1_acars.and.l_ii_man) then + n_near_AcMa = n_near_AcMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'ACARS-manAIREP near dup--',ii + write(io8,*) 'TAMDAR-manAIREP near dup--',ii + endif +c + elseif(l_iim1_mdcrs.and.l_ii_man) then + n_near_MdMa = n_near_MdMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'MDCRS-manAIREP near dup--',ii + endif +c + elseif(l_iim1_airep.and.l_ii_man) then + n_near_ArMa = n_near_ArMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AIREP-manAIREP near dup--',ii + endif +c + elseif(l_iim1_amdar.and.l_ii_man) then + n_near_AmMa = n_near_AmMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AMDAR-manAIREP near dup--',ii + endif +c + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncategorized near dup-2-',ii, + $ ' difdir = ',difdir + endif + endif +c +ccccdak Exclude other MDCRS-ACARS, MDCRS-AIREP, ACARS-AIREP, MDCRS-MDCRS +ccccdak or ACARS-ACARS duplicates +c Exclude other MDCRS-TAMDAR, MDCRS-AIREP, TAMDAR-AIREP, MDCRS-MDCRS +c or TAMDAR-TAMDAR duplicates +c ---------------------------------------------------------------- + elseif( (l_iim1_mdcrs.and.l_ii_acars).or. + $ (l_ii_mdcrs.and.l_iim1_acars).or. + $ (l_ii_mdcrs.and.l_iim1_mdcrs).or. + $ (l_ii_acars.and.l_iim1_acars).or. + $ (l_ii_amdar.and.l_iim1_amdar).or. + $ (l_ii_amdar.and.l_iim1_airep).or. + $ (l_ii_airep.and.l_iim1_amdar) ) then +c +c Duplicate pair doesn't fall in any of the above categories +c but ids are equal +c Keep ob ii +c ---------------------------------------------------------- + elseif((c_acftid(ii).eq.c_acftid(iim1)).or. + $ (l_ii_man.and.l_iim1_man).or. + $ (l_ii_amdar.and.l_ii_amdar.and. + $ c_acftid(ii)(1:6).eq.c_acftid(iim1)(1:6)))then +c + if(c_qc(iim1)(1:1).eq.'-'.or. + $ c_qc(iim1)(1:1).eq.'.'.or. + $ c_qc(iim1)(1:1).eq.'N') + $ c_qc(iim1)(1:1) = 'd' +c + if(c_qc(ii)(1:1).eq.'-') c_qc(ii)(1:1) = '.' +c +c Count rejects by category +c ------------------------- + n_near = n_near + 1 +c + if(l_ii_airep.and.l_iim1_airep) then + n_near_ArAr = n_near_ArAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AIREP-AIREP near dup found--',ii + endif +c + elseif(l_ii_man.and.l_iim1_man) then + n_near_MaMa = n_near_MaMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'manAIREP-manAIREP near dup--',ii + endif +c + elseif(l_ii_amdar.and.l_iim1_amdar) then + n_near_AmAm = n_near_AmAm + 1 + if(c_acftid(ii).eq.c_acftid(iim1)) then + l_print = .false. + else + l_print = .false. + endif + if(l_print) then + write(io8,*) + write(io8,*) 'AMDAR-AMDAR near dup found--',ii + endif +c + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncategorized near dup-3-',ii + endif + endif +c +c Duplicate pair doesn't fall in any of the above categories +c Flag to log file but don't reject +c ---------------------------------------------------------- + elseif(c_acftid(ii).eq.c_acftid(iim1)) then + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Leftover near duplicate found',ii + endif + endif +c +c Check if report is a low-windspeed dup not previously caught +c (These are typically near-surface observations) +c ------------------------------------------------------------ + elseif(idt_dif.ge.0.and.idt_dif.le.90.and. + $ c_qc(iim1)(1:1).ne.'D'.and. +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + $ abs(alat(iim1)-alat(ii)).lt.0.035.and. + $ abs(alon(iim1)-alon(ii)).lt.0.035.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c $ abs(ht_ft(iim1)-ht_ft(ii)).lt.50.5.and. + $ abs(ht_ft(iim1)-ht_ft(ii)).lt.25.5.and. + $ (c_acftid(ii).eq.c_acftid(iim1).or. + $ l_ii_sh.or.l_iim1_sh).and. +c $ abs(ob_t(iim1)-ob_t(ii)).lt.2.05.and. + $ abs(ob_t(iim1)-ob_t(ii)).lt.1.25.and. + $ ((ob_spd(iim1).lt.25.05.and. + $ ob_spd(ii).lt.25.05.and. + $ abs(ob_spd(iim1)-ob_spd(ii)).lt.2.05.and. + $ ((abs(difdir).lt.10.5).or. + $ (ob_dir(ii).eq.amiss.and. + $ ob_dir(iim1).eq.amiss))).or. + $ (ob_spd(iim1).lt.15.05.and. + $ ob_spd(ii).lt.15.05.and. + $ abs(ob_spd(iim1)-ob_spd(ii)).lt.3.55.and. + $ ((abs(difdir).lt.15.5).or. + $ (ob_dir(ii).eq.amiss.and. + $ ob_dir(iim1).eq.amiss))).or. + $ (ob_spd(iim1).lt.10.05.and. + $ ob_spd(ii).lt.10.05.and. + $ abs(ob_spd(iim1)-ob_spd(ii)).lt.5.05.and. + $ ((abs(difdir).lt.25.5).or. + $ (ob_dir(ii).eq.amiss.and. + $ ob_dir(iim1).eq.amiss))).or. + $ (ob_spd(iim1).lt.5.05.and. + $ ob_spd(ii).lt.5.05.and. + $ ((abs(difdir).lt.45.5).or. + $ (ob_dir(ii).eq.amiss.and. + $ ob_dir(iim1).eq.amiss))).or. + $ (ob_spd(iim1).lt.3.65.and. + $ ob_spd(ii).lt.3.65).or. + $ (ob_spd(iim1).eq.amiss.and.ob_spd(ii).ne.amiss).or. + $ (ob_spd(iim1).ne.amiss.and.ob_spd(ii).eq.amiss).or. + $ (ob_dir(iim1).eq.amiss.and.ob_dir(ii).ne.amiss).or. + $ (ob_dir(iim1).ne.amiss.and.ob_dir(ii).eq.amiss)) + $ ) then +c +c If near dup found, decide which report to keep +ccccdak Choose MDCRS over ACARS +c Choose MDCRS over TAMDAR +ccccdak Choose ACARS/MDCRS over AIREP/manual AIREP +c Choose TAMDAR or MDCRS over AIREP/manual AIREP +c Choose AMDAR over AIREP/manual AIREP +c Choose automated over manual AIREP +c Choose 7-char flight number over 6-char flight number +c Choose present over missing flight/tail number +c Choose present over missing wind speed +c Choose non-zero over zero lat or lon +c ------------------------------------------------------- +c +c Keep ob ii +c ---------- + if((l_ii_mdcrs.and.l_iim1_acars).or. + $ (l_ii_mdcrs.and.l_iim1_airep).or. + $ (l_ii_mdcrs.and.l_iim1_man).or. + $ (l_ii_mdcrs.and.l_iim1_mdcrs.and. + $ ichk_s(ii).ne.-10).or. + $ (l_ii_acars.and.l_iim1_airep).or. + $ (l_ii_acars.and.l_iim1_man).or. + $ (l_ii_acars.and.l_iim1_acars).or. + $ (l_ii_amdar.and.l_iim1_airep).or. + $ (l_ii_amdar.and.l_iim1_man).or. + $ (l_ii_amdar.and.l_iim1_amdar).or. + $ (l_ii_airep.and.l_iim1_man).or. + $ (l_ii_airep.and.l_iim1_airep).or. + $ (l_ii_man.and.l_iim1_man).or. + $ l_iim1_sh.or. + $ (ob_spd(ii).ne.amiss.and.ob_spd(iim1).eq.amiss).or. + $ (ob_dir(ii).ne.amiss.and.ob_dir(iim1).eq.amiss) + $ )then +c + if(c_qc(iim1)(1:1).eq.'-'.or. + $ c_qc(iim1)(1:1).eq.'.'.or. + $ c_qc(iim1)(1:1).eq.'N') + $ c_qc(iim1)(1:1) = 'd' +c + if(c_qc(ii)(1:1).eq.'-') c_qc(ii)(1:1) = '.' +c +c Count rejects by category +c ------------------------- + n_near = n_near + 1 +c + if(l_iim1_sh) then + n_near_sh = n_near_sh + 1 + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*)'Low-wind dup found with short id' + endif + if(l_iim1_man.and.l_ii_man) then + n_nr_sh_MaMa = n_nr_sh_MaMa + 1 + if(l_print) + $ write(io8,*) 'manAIREP-manAIREP dup' + elseif(l_iim1_man.and.l_ii_airep) then + n_nr_sh_MaAr = n_nr_sh_MaAr + 1 + if(l_print) write(io8,*) 'manAIREP-AIREP dup' + elseif(l_iim1_man.and.l_ii_mdcrs) then + n_nr_sh_MaMd = n_nr_sh_MaMd + 1 + if(l_print) write(io8,*) 'manAIREP-MDCRS dup' + elseif(l_iim1_man.and.l_ii_acars) then + n_nr_sh_MaAc = n_nr_sh_MaAc + 1 +ccccdak if(l_print) write(io8,*) 'manAIREP-ACARS dup' + if(l_print) write(io8,*) 'manAIREP-TAMDAR dup' + elseif(l_ii_man.and.l_iim1_airep) then + n_nr_sh_ArMa = n_nr_sh_ArMa + 1 + if(l_print) write(io8,*) 'AIREP-manAIREP dup' + elseif(l_iim1_airep.and.l_ii_airep) then + n_nr_sh_ArAr = n_nr_sh_ArAr + 1 + if(l_print) write(io8,*) 'AIREP-AIREP dup' + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncat. low-wind short-id dup' + endif + endif +c + elseif((ob_spd(ii).ne.amiss.and. + $ ob_spd(iim1).eq.amiss).or. + $ (ob_dir(ii).ne.amiss.and. + $ ob_dir(iim1).eq.amiss)) then + n_near_ws = n_near_ws + 1 + l_print = .false. + if(c_acftid(ii)(1:2).eq.'IT') then + n_near_ws_IT = n_near_ws_IT + 1 + l_print = .false. + elseif(c_acftid(ii)(1:2).eq.'EU') then + n_near_ws_EU = n_near_ws_EU + 1 + l_print = .false. + endif + if(l_print) then + write(io8,*) + write(io8,*)'Low-wind dup found with msg wind' + endif + if(l_iim1_man.and.l_ii_man) then + n_nr_mswn_MaMa = n_nr_mswn_MaMa + 1 + if(l_print) + $ write(io8,*) 'manAIREP-manAIREP dup' + elseif(l_iim1_man.and.l_ii_airep) then + n_nr_mswn_MaAr = n_nr_mswn_MaAr + 1 + if(l_print) write(io8,*) 'manAIREP-AIREP dup' + elseif(l_iim1_man.and.l_ii_amdar) then + n_nr_mswn_MaAm = n_nr_mswn_MaAm + 1 + if(l_print) write(io8,*) 'manAIREP-AMDAR dup' + elseif(l_ii_man.and.l_iim1_airep) then + n_nr_mswn_ArMa = n_nr_mswn_ArMa + 1 + if(l_print) write(io8,*) 'AIREP-manAIREP dup' + elseif(l_iim1_airep.and.l_ii_airep) then + n_nr_mswn_ArAr = n_nr_mswn_ArAr + 1 + if(l_print) write(io8,*) 'AIREP-AIREP dup' + elseif(l_iim1_acars.and.l_ii_acars) then + n_nr_mswn_AcAc = n_nr_mswn_AcAc + 1 +ccccdak if(l_print) write(io8,*) 'ACARS-ACARS dup' + if(l_print) write(io8,*) 'TAMDAR-TAMDAR dup' + elseif(l_iim1_mdcrs.and.l_ii_mdcrs) then + n_nr_mswn_MdMd = n_nr_mswn_MdMd + 1 + if(l_print) write(io8,*) 'MDCRS-MDCRS dup' + elseif(l_iim1_acars.and.l_ii_mdcrs) then + n_nr_mswn_AcMd = n_nr_mswn_AcMd + 1 +ccccdak if(l_print) write(io8,*) 'ACARS-MDCRS dup' + if(l_print) write(io8,*) 'TAMDAR-MDCRS dup' + elseif(l_iim1_mdcrs.and.l_ii_acars) then + n_nr_mswn_MdAc = n_nr_mswn_MdAc + 1 +ccccdak if(l_print) write(io8,*) 'MDCRS-ACARS dup' + if(l_print) write(io8,*) 'MDCRS-TAMDAR dup' + elseif(l_iim1_mdcrs.and.l_ii_amdar) then + n_nr_mswn_MdAm = n_nr_mswn_MdAm + 1 + if(l_print) write(io8,*) 'MDCRS-AMDAR dup' + elseif(l_iim1_mdcrs.and.l_ii_airep) then + n_nr_mswn_MdAr = n_nr_mswn_MdAr + 1 + if(l_print) write(io8,*) 'MDCRS-AIREP dup' + elseif(l_iim1_mdcrs.and.l_ii_man) then + n_nr_mswn_MdMa = n_nr_mswn_MdMa + 1 + if(l_print) write(io8,*) 'MDCRS-manAIREP dup' + elseif(l_iim1_airep.and.l_ii_acars) then + n_nr_mswn_ArAc = n_nr_mswn_ArAc + 1 +ccccdak if(l_print) write(io8,*) 'AIREP-ACARS dup' + if(l_print) write(io8,*) 'AIREP-TAMDAR dup' + elseif(l_iim1_airep.and.l_ii_mdcrs) then + n_nr_mswn_ArMd = n_nr_mswn_ArMd + 1 + if(l_print) write(io8,*) 'AIREP-MDCRS dup' + elseif(l_iim1_man.and.l_ii_acars) then + n_nr_mswn_MaAc = n_nr_mswn_MaAc + 1 +ccccdak if(l_print) write(io8,*) 'manAIREP-ACARS dup' + if(l_print) write(io8,*) 'manAIREP-TAMDAR dup' + elseif(l_iim1_man.and.l_ii_mdcrs) then + n_nr_mswn_MaMd = n_nr_mswn_MaMd + 1 + if(l_print) write(io8,*) 'manAIREP-MDCRS dup' + elseif(l_iim1_amdar.and.l_ii_amdar) then + n_nr_mswn_AmAm = n_nr_mswn_AmAm + 1 + if(l_print) write(io8,*) 'AMDAR-AMDAR dup' + elseif(l_iim1_airep.and.l_ii_amdar) then + n_nr_mswn_ArAm = n_nr_mswn_ArAm + 1 + if(l_print) write(io8,*) 'AIREP-AMDAR dup' + elseif(l_iim1_amdar.and.l_ii_airep) then + n_nr_mswn_AmAr = n_nr_mswn_AmAr + 1 + if(l_print) write(io8,*) 'AMDAR-AIREP dup' + elseif(l_iim1_acars.and.l_ii_amdar) then + n_nr_mswn_AcAm = n_nr_mswn_AcAm + 1 +ccccdak if(l_print) write(io8,*) 'ACARS-AMDAR dup' + if(l_print) write(io8,*) 'TAMDAR-AMDAR dup' + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncat. low-wind msg-wind dup' + endif + endif +c + elseif(l_ii_mdcrs.and.l_iim1_acars) then + n_slow_MdAc = n_slow_MdAc + 1 + l_print = .false. + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'MDCRS-ACARS low-wind dup found' + write(io8,*) 'MDCRS-TAMDAR low-wind dup found' + endif +c + elseif(l_ii_mdcrs.and.l_iim1_airep) then + n_slow_MdAr = n_slow_MdAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'MDCRS-AIREP low-wind dup found' + endif +c + elseif(l_ii_mdcrs.and.l_iim1_mdcrs) then + if(ichk_s(iim1).eq.-10) then + n_nr_bad_roll_Md = n_nr_bad_roll_Md + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*)'MDCRS-MDCRS bad roll qc lw dup' + endif + else + n_slow_MdMd = n_slow_MdMd + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*)'MDCRS-MDCRS low-wind dup found' + endif + endif +c + elseif(l_ii_acars.and.l_iim1_airep) then + n_slow_AcAr = n_slow_AcAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'ACARS-AIREP low-wind dup found' + write(io8,*) 'TAMDAR-AIREP low-wind dup found' + endif +c + elseif(l_ii_acars.and.l_iim1_acars) then + n_slow_AcAc = n_slow_AcAc + 1 + l_print = .false. + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'ACARS-ACARS low-wind dup found' + write(io8,*) 'TAMDAR-TAMDAR low-wind dup found' + endif +c + elseif(l_ii_amdar.and.l_iim1_airep) then + n_slow_AmAr = n_slow_AmAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AMDAR-AIREP low-wind dup found' + endif +c + elseif(l_ii_amdar.and.l_iim1_amdar) then + if(ichk_s(iim1).eq.-10) then + n_nr_bad_roll_Am = n_nr_bad_roll_Am + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*)'AMDAR-AMDAR bad roll qc lw dup' + endif + else + n_slow_AmAm = n_slow_AmAm + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AMDAR-AMDAR low-wind dup found' + endif + endif +c + elseif(l_ii_airep.and.l_iim1_man) then + n_slow_ArMa = n_slow_ArMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AIREP-manAIREP low-wind dup' + endif +c + elseif(l_ii_airep.and.l_iim1_airep) then + n_slow_ArAr = n_slow_ArAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AIREP-AIREP low-wind dup found' + endif +c + elseif(l_ii_man.and.l_iim1_man) then + n_slow_MaMa = n_slow_MaMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*)'manAIREP-manAIREP low-wind dup' + endif +c + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncategorized low-wind dup-1-' + endif + endif +c +c Keep ob iim1 +c ------------ + elseif((l_iim1_mdcrs.and.l_ii_acars).or. + $ (l_iim1_mdcrs.and.l_ii_airep).or. + $ (l_iim1_mdcrs.and.l_ii_man).or. + $ (l_iim1_mdcrs.and.l_ii_mdcrs).or. + $ (l_iim1_acars.and.l_ii_airep).or. + $ (l_iim1_acars.and.l_ii_man).or. + $ (l_iim1_acars.and.l_ii_acars).or. + $ (l_iim1_amdar.and.l_ii_airep).or. + $ (l_iim1_amdar.and.l_ii_man).or. + $ (l_iim1_airep.and.l_ii_man).or. + $ l_ii_sh.or. + $ (ob_spd(iim1).ne.amiss.and. + $ ob_spd(ii).eq.amiss).or. + $ (ob_dir(iim1).ne.amiss.and. + $ ob_dir(ii).eq.amiss)) then +c + indx(knt1) = ii + indx(knt0) = iim1 + isave = ii + ii = iim1 + iim1 = isave +c + if(c_qc(iim1)(1:1).eq.'-'.or. + $ c_qc(iim1)(1:1).eq.'.'.or. + $ c_qc(iim1)(1:1).eq.'N') + $ c_qc(iim1)(1:1) = 'd' +c + if(c_qc(ii)(1:1).eq.'-') c_qc(ii)(1:1) = '.' +c +c Count rejects by category +c ------------------------- + n_near = n_near + 1 +c + if(l_ii_sh) then + n_near_sh = n_near_sh + 1 + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*)'Low-wind dup found with short id' + endif + if(l_ii_man.and.l_iim1_man) then + n_nr_sh_MaMa = n_nr_sh_MaMa + 1 + if(l_print) + $ write(io8,*) 'manAIREP-manAIREP dup' + elseif(l_ii_man.and.l_iim1_airep) then + n_nr_sh_MaAr = n_nr_sh_MaAr + 1 + if(l_print) write(io8,*) 'manAIREP-AIREP dup' + elseif(l_ii_man.and.l_iim1_mdcrs) then + n_nr_sh_MaMd = n_nr_sh_MaMd + 1 + if(l_print) write(io8,*) 'manAIREP-MDCRS dup' + elseif(l_ii_man.and.l_iim1_acars) then + n_nr_sh_MaAc = n_nr_sh_MaAc + 1 +ccccdak if(l_print) write(io8,*) 'manAIREP-ACARS dup' + if(l_print) write(io8,*) 'manAIREP-TAMDAR dup' + elseif(l_iim1_man.and.l_ii_airep) then + n_nr_sh_ArMa = n_nr_sh_ArMa + 1 + if(l_print) write(io8,*) 'AIREP-manAIREP dup' + elseif(l_ii_airep.and.l_iim1_airep) then + n_nr_sh_ArAr = n_nr_sh_ArAr + 1 + if(l_print) write(io8,*) 'AIREP-AIREP dup' + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncat. low-wind short-id dup' + endif + endif +c + elseif((ob_spd(ii).ne.amiss.and. + $ ob_spd(iim1).eq.amiss).or. + $ (ob_dir(ii).ne.amiss.and. + $ ob_dir(iim1).eq.amiss)) then + n_near_ws = n_near_ws + 1 + l_print = .false. + if(c_acftid(iim1)(1:2).eq.'IT') then + n_near_ws_IT = n_near_ws_IT + 1 + l_print = .false. + elseif(c_acftid(iim1)(1:2).eq.'EU') then + n_near_ws_EU = n_near_ws_EU + 1 + l_print = .false. + endif + if(l_print) then + write(io8,*) + write(io8,*) 'Low-wind dup with msg winds' + endif + if(l_ii_man.and.l_iim1_man) then + n_nr_mswn_MaMa = n_nr_mswn_MaMa + 1 + if(l_print) + $ write(io8,*) 'manAIREP-manAIREP dup' + elseif(l_ii_man.and.l_iim1_airep) then + n_nr_mswn_MaAr = n_nr_mswn_MaAr + 1 + if(l_print) write(io8,*) 'manAIREP-AIREP dup' + elseif(l_ii_man.and.l_iim1_amdar) then + n_nr_mswn_MaAm = n_nr_mswn_MaAm + 1 + if(l_print) write(io8,*) 'manAIREP-AMDAR dup' + elseif(l_iim1_man.and.l_ii_airep) then + n_nr_mswn_ArMa = n_nr_mswn_ArMa + 1 + if(l_print) write(io8,*) 'AIREP-manAIREP dup' + elseif(l_ii_airep.and.l_iim1_airep) then + n_nr_mswn_ArAr = n_nr_mswn_ArAr + 1 + if(l_print) write(io8,*) 'AIREP-AIREP dup' + elseif(l_ii_acars.and.l_iim1_acars) then + n_nr_mswn_AcAc = n_nr_mswn_AcAc + 1 +ccccdak if(l_print) write(io8,*) 'ACARS-ACARS dup' + if(l_print) write(io8,*) 'TAMDAR-TAMDAR dup' + elseif(l_ii_mdcrs.and.l_iim1_mdcrs) then + n_nr_mswn_MdMd = n_nr_mswn_MdMd + 1 + if(l_print) write(io8,*) 'MDCRS-MDCRS dup' + elseif(l_ii_acars.and.l_iim1_mdcrs) then + n_nr_mswn_AcMd = n_nr_mswn_AcMd + 1 +ccccdak if(l_print) write(io8,*) 'ACARS-MDCRS dup' + if(l_print) write(io8,*) 'TAMDAR-MDCRS dup' + elseif(l_ii_mdcrs.and.l_iim1_acars) then + n_nr_mswn_MdAc = n_nr_mswn_MdAc + 1 +ccccdak if(l_print) write(io8,*) 'MDCRS-ACARS dup' + if(l_print) write(io8,*) 'MDCRS-TAMDAR dup' + elseif(l_ii_mdcrs.and.l_iim1_amdar) then + n_nr_mswn_MdAm = n_nr_mswn_MdAm + 1 + if(l_print) write(io8,*) 'MDCRS-AMDAR dup' + elseif(l_ii_mdcrs.and.l_iim1_airep) then + n_nr_mswn_MdAr = n_nr_mswn_MdAr + 1 + if(l_print) write(io8,*) 'MDCRS-AIREP dup' + elseif(l_ii_mdcrs.and.l_iim1_man) then + n_nr_mswn_MdMa = n_nr_mswn_MdMa + 1 + if(l_print) write(io8,*) 'MDCRS-manAIREP dup' + elseif(l_ii_airep.and.l_iim1_acars) then + n_nr_mswn_ArAc = n_nr_mswn_ArAc + 1 +ccccdak if(l_print) write(io8,*) 'AIREP-ACARS dup' + if(l_print) write(io8,*) 'AIREP-TAMDAR dup' + elseif(l_ii_airep.and.l_iim1_mdcrs) then + n_nr_mswn_ArMd = n_nr_mswn_ArMd + 1 + if(l_print) write(io8,*) 'AIREP-MDCRS dup' + elseif(l_ii_man.and.l_iim1_acars) then + n_nr_mswn_MaAc = n_nr_mswn_MaAc + 1 +ccccdak if(l_print) write(io8,*) 'manAIREP-ACARS dup' + if(l_print) write(io8,*) 'manAIREP-TAMDAR dup' + elseif(l_ii_man.and.l_iim1_mdcrs) then + n_nr_mswn_MaMd = n_nr_mswn_MaMd + 1 + if(l_print) write(io8,*) 'manAIREP-MDCRS dup' + elseif(l_ii_amdar.and.l_iim1_amdar) then + n_nr_mswn_AmAm = n_nr_mswn_AmAm + 1 + if(l_print) write(io8,*) 'AMDAR-AMDAR dup' + elseif(l_ii_airep.and.l_iim1_amdar) then + n_nr_mswn_ArAm = n_nr_mswn_ArAm + 1 + if(l_print) write(io8,*) 'AIREP-AMDAR dup' + elseif(l_ii_amdar.and.l_iim1_airep) then + n_nr_mswn_AmAr = n_nr_mswn_AmAr + 1 + if(l_print) write(io8,*) 'AMDAR-AIREP dup' + elseif(l_ii_acars.and.l_iim1_amdar) then + n_nr_mswn_AcAm = n_nr_mswn_AcAm + 1 +ccccdak if(l_print) write(io8,*) 'ACARS-AMDAR dup' + if(l_print) write(io8,*) 'TAMDAR-AMDAR dup' + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncat. low-wind msg-wind dup' + endif + endif +c + elseif(l_iim1_mdcrs.and.l_ii_acars) then + n_slow_MdAc = n_slow_MdAc + 1 + l_print = .false. + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'MDCRS-ACARS low-wind dup found' + write(io8,*) 'MDCRS-TAMDAR low-wind dup found' + endif +c + elseif(l_iim1_mdcrs.and.l_ii_airep) then + n_slow_MdAr = n_slow_MdAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'MDCRS-AIREP low-wind dup found' + endif +c + elseif(l_ii_mdcrs.and.l_iim1_mdcrs) then + if(ichk_s(iim1).eq.-10) then + n_nr_bad_roll_Md = n_nr_bad_roll_Md + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*)'MDCRS-MDCRS bad roll qc lw dup' + endif + else + n_slow_MdMd = n_slow_MdMd + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*)'MDCRS-MDCRS low-wind dup found' + endif + endif +c + elseif(l_iim1_acars.and.l_ii_airep) then + n_slow_AcAr = n_slow_AcAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'ACARS-AIREP low-wind dup found' + write(io8,*) 'TAMDAR-AIREP low-wind dup found' + endif +c + elseif(l_iim1_acars.and.l_ii_acars) then + n_slow_AcAc = n_slow_AcAc + 1 + l_print = .false. + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'ACARS-ACARS low-wind dup found' + write(io8,*) 'TAMDAR-TAMDAR low-wind dup found' + endif +c + elseif(l_ii_amdar.and.l_iim1_amdar) then + if(ichk_s(iim1).eq.-10) then + n_nr_bad_roll_Am = n_nr_bad_roll_Am + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*)'AMDAR-AMDAR bad roll qc lw dup' + endif + else + n_slow_AmAm = n_slow_AmAm + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*)'AMDAR-AMDAR low-wind dup found' + endif + endif +c + elseif(l_iim1_amdar.and.l_ii_airep) then + n_slow_AmAr = n_slow_AmAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AMDAR-AIREP low-wind dup found' + endif +c + elseif(l_iim1_airep.and.l_ii_man) then + n_slow_ArMa = n_slow_ArMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AIREP-manAIREP low-wind dup' + endif +c + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncategorized low-wind dup-2-' + endif + endif + endif +c +c Check if report is a near dup except for flight id (not rejected) +c Echo to log file for later inspection +c ----------------------------------------------------------------- + elseif(idt_dif.ge.0.and.idt_dif.le.90.and. + $ c_qc(iim1)(1:1).ne.'D'.and. +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + $ abs(alat(iim1)-alat(ii)).lt.0.125.and. + $ abs(alon(iim1)-alon(ii)).lt.0.125.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ ((ht_ft(ii).lt.25000.and. + $ abs(ht_ft(iim1)-ht_ft(ii)).lt.htdif_same/4+0.5).or. + $ (((l_ii_mdcrs.and.(.not.l_iim1_mdcrs)).or. ! new + $ (l_iim1_mdcrs.and.(.not.l_ii_mdcrs)).or. ! new + $ (l_ii_acars.and.(.not.l_iim1_acars)).or. ! new + $ (l_iim1_acars.and.(.not.l_ii_acars)).or. ! new + $ (l_ii_man.and.(.not.l_iim1_man)).or. ! new + $ (l_iim1_man.and.(.not.l_ii_man)).or. ! new + $ (((l_ii_amdar.and.l_iim1_amdar).or. ! new + $ (l_ii_airep.and.l_iim1_amdar).or. ! new + $ (l_iim1_airep.and.l_ii_amdar)).and. ! new + $ c_acftid(ii).eq.c_acftid(iim1)) ).and. ! new + $ ht_ft(ii).lt.25000.and. + $ abs(ht_ft(iim1)-ht_ft(ii)).lt.htdif_same+0.5).or. + $ (ht_ft(ii).gt.24999.5.and. + $ abs(ht_ft(iim1)-ht_ft(ii)).lt.htdif_same+0.5)).and. + $ abs(ob_t(iim1)-ob_t(ii)).lt.1.25.and. + $ ((abs(ob_spd(iim1)-ob_spd(ii)).lt.1.25.and. + $ ((abs(difdir).lt.10.5).or. + $ (ob_dir(ii).eq.amiss.and. + $ ob_dir(iim1).eq.amiss))).or. + $ (ob_spd(iim1).eq.amiss.and.ob_spd(ii).ne.amiss).or. + $ (ob_spd(iim1).ne.amiss.and.ob_spd(ii).eq.amiss).or. + $ (ob_dir(iim1).eq.amiss.and.ob_dir(ii).ne.amiss).or. + $ (ob_dir(iim1).ne.amiss.and.ob_dir(ii).eq.amiss)) + $ ) then +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Non-rejected duplicate found--',ii + endif +c +c Check if airep report is an exact dup except for large temperature or +c wind differences--assume encode error and reject both! +c ----------------------------------------------------------------- + elseif((idt_dif.ge.0.and.idt_dif.le.90).and. + $ c_qc(iim1)(1:1).ne.'D'.and. +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + $ abs(alat(iim1)-alat(ii)).lt.0.035.and. + $ abs(alon(iim1)-alon(ii)).lt.0.035.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ (abs(ht_ft(iim1)-ht_ft(ii)).lt.0.5.or. + $ abs(pres(iim1)-pres(ii)).lt.0.05).and. + $ (c_acftid(ii).eq.c_acftid(iim1).or. + $ l_ii_sh.or.l_iim1_sh).and. + $ (l_ii_man.and.l_iim1_man)) then +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Encoding problem detected' + endif +c +c Special case where winds are missing +c (Temperature for that report is usually way off!) +c Reject report with missing winds +c ------------------------------------------------- + if(ob_spd(iim1).eq.amiss.and.ob_spd(ii).ne.amiss.and. + $ ob_dir(iim1).eq.amiss.and.ob_dir(ii).ne.amiss.and. + $ (c_qc(iim1)(1:1).eq.'-'.or. + $ c_qc(iim1)(1:1).eq.'.'.or. + $ c_qc(iim1)(1:1).eq.'N')) then +c + c_qc(iim1)(1:1) = 'e' +c + elseif(ob_spd(ii).eq.amiss.and. + $ ob_spd(iim1).ne.amiss.and. + $ ob_dir(ii).eq.amiss.and. + $ ob_dir(iim1).ne.amiss.and. + $ (c_qc(ii)(1:1).eq.'-'.or. + $ c_qc(ii)(1:1).eq.'.'.or. + $ c_qc(ii)(1:1).eq.'N')) then +c + indx(knt1) = ii + indx(knt0) = iim1 + isave = ii + ii = iim1 + iim1 = isave + c_qc(iim1)(1:1) = 'e' +c + elseif((c_acftid(ii).eq.c_acftid(iim1).or. + $ l_iim1_sh).and. + $ (c_qc(iim1)(1:1).eq.'-'.or. + $ c_qc(iim1)(1:1).eq.'.'.or. + $ c_qc(iim1)(1:1).eq.'N')) then +c + c_qc(iim1)(1:1) = 'E' +c + elseif((c_acftid(ii).eq.c_acftid(iim1).or.l_ii_sh).and. + $ (c_qc(ii)(1:1).eq.'-'.or. + $ c_qc(ii)(1:1).eq.'.'.or. + $ c_qc(ii)(1:1).eq.'N')) then +c + indx(knt1) = ii + indx(knt0) = iim1 + isave = ii + ii = iim1 + iim1 = isave + c_qc(iim1)(1:1) = 'E' +c + endif +c + if(abs(ob_t(iim1)-ob_t(ii)).lt.2.05.and. + $ abs(difdir).lt.10.5.and. + $ abs(ob_spd(iim1)-ob_spd(ii)).lt.1.25) then +c + c_qc(iim1)(1:1) = 'd' +c + if(l_print) write(io8,*) 'Near duplicate' + n_near = n_near + 1 + n_near_MaMa = n_near_MaMa + 1 +c + else + n_bad_encode = n_bad_encode + 1 +c + if(abs(ob_t(iim1)-ob_t(ii)).gt.2.05.and. + $ c_qc(iim1)(1:1).ne.'e') then + c_qc(ii)(6:6) = 'E' + if(l_print) write(io8,*) 'Bad temperature' + endif +c + if(abs(difdir).gt.10.5.and. + $ c_qc(iim1)(1:1).ne.'e') then + c_qc(ii)(7:7) = 'E' + if(l_print) write(io8,*) 'Bad wind direction' + endif +c + if(abs(ob_spd(iim1)-ob_spd(ii)).gt.1.25.and. + $ c_qc(iim1)(1:1).ne.'e') then + c_qc(ii)(8:8) = 'E' + if(l_print) write(io8,*) 'Bad windspeed' + endif + endif +c +c Check if report is a position dup +c Echo to log file for later inspection +c ------------------------------------- + elseif(idt_dif.ge.0.and.idt_dif.le.90.and. + $ c_qc(iim1)(1:1).ne.'D'.and. +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + $ abs(alat(iim1)-alat(ii)).lt.0.035.and. + $ abs(alon(iim1)-alon(ii)).lt.0.035.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c $ abs(ht_ft(iim1)-ht_ft(ii)).lt.50.5.and. + $ abs(ht_ft(iim1)-ht_ft(ii)).lt.25.5.and. + $ (c_acftid(ii).eq.c_acftid(iim1).or. + $ l_ii_sh.or.l_iim1_sh)) then +c +c Check if MDCRS-MDCRS duplicate has a bad roll angle +c --------------------------------------------------- + if((ichk_s(iim1).eq.-10.and. + $ ichk_s(ii ).ne.-10).and. + $ l_iim1_mdcrs.and.l_ii_mdcrs.and. + $ abs(ob_t(iim1)-ob_t(ii)).lt.1.25.and. + $ (c_qc(iim1)(1:1).eq.'-'.or. + $ c_qc(iim1)(1:1).eq.'.'.or. + $ c_qc(iim1)(1:1).eq.'N')) then +c + c_qc(iim1)(1:1) = 'd' +c + n_near = n_near + 1 + n_nr_bad_roll_Md = n_nr_bad_roll_Md + 1 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad roll angle qc - MDCRS' + endif +c + elseif((ichk_s(ii ).eq.-10.and. + $ ichk_s(iim1).ne.-10).and. + $ l_iim1_mdcrs.and.l_ii_mdcrs.and. + $ abs(ob_t(iim1)-ob_t(ii)).lt.1.25.and. + $ (c_qc(ii)(1:1).eq.'-'.or. + $ c_qc(ii)(1:1).eq.'.'.or. + $ c_qc(ii)(1:1).eq.'N')) then +c + indx(knt1) = ii + indx(knt0) = iim1 + isave = ii + ii = iim1 + iim1 = isave +c + c_qc(iim1)(1:1) = 'd' +c + n_near = n_near + 1 + n_nr_bad_roll_Md = n_nr_bad_roll_Md + 1 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad roll angle qc - MDCRS' + endif +c +c Check if AMDAR-AMDAR duplicate has a bad roll angle +c --------------------------------------------------- + elseif((ichk_s(iim1).eq.-10.and. + $ ichk_s(ii ).ne.-10).and. + $ l_iim1_amdar.and.l_ii_amdar.and. + $ abs(ob_t(iim1)-ob_t(ii)).lt.1.25.and. + $ (c_qc(iim1)(1:1).eq.'-'.or. + $ c_qc(iim1)(1:1).eq.'.'.or. + $ c_qc(iim1)(1:1).eq.'N')) then +c + c_qc(iim1)(1:1) = 'd' +c + n_near = n_near + 1 + n_nr_bad_roll_Am = n_nr_bad_roll_Am + 1 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad roll angle qc - AMDAR' + endif +c + elseif((ichk_s(ii ).eq.-10.and. + $ ichk_s(iim1).ne.-10).and. + $ l_iim1_amdar.and.l_ii_amdar.and. + $ abs(ob_t(iim1)-ob_t(ii)).lt.1.25.and. + $ (c_qc(ii)(1:1).eq.'-'.or. + $ c_qc(ii)(1:1).eq.'.'.or. + $ c_qc(ii)(1:1).eq.'N')) then +c + indx(knt1) = ii + indx(knt0) = iim1 + isave = ii + ii = iim1 + iim1 = isave +c + c_qc(iim1)(1:1) = 'd' +c + n_near = n_near + 1 + n_nr_bad_roll_Am = n_nr_bad_roll_Am + 1 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad roll angle qc - AMDAR' + endif +c + else + if(c_qc(ii)(1:1).eq.'-') c_qc(ii)(1:1) = '.' + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Position duplicate found' + endif +c + endif +c +c Set c_qc to '.' if no duplicate found within 60 sec window +c ---------------------------------------------------------- + else + if(c_qc(ii)(1:1).eq.'-') c_qc(ii)(1:1) = '.' + endif +c +c Set c_qc to '.' if lats and lons too far apart +c ---------------------------------------------- + else + if(c_qc(ii)(1:1).eq.'-') c_qc(ii)(1:1) = '.' + endif +c + if(l_print) then +c if(c_qc(iim1)(1:1).eq.'d'.and. +c $ (idt(ii).ne.idt(iim1).or. +c $ c_acftid(ii).ne.c_acftid(iim1))) then + write(io8,*) + write(io8,8002) kkdup,iim1,c_insty_ob(itype(iim1)) + x, c_acftreg(iim1),c_acftid(iim1) + x, idt(iim1),alat(iim1),alon(iim1) + x, pres(iim1),ht_ft(iim1) + x, t_prcn(iim1),ob_t(iim1),xiv_t(iim1),ichk_t(iim1) + x, ob_q(iim1),xiv_q(iim1),ichk_q(iim1) + x, ob_dir(iim1),xiv_d(iim1),ichk_d(iim1) + x, ob_spd(iim1),xiv_s(iim1),ichk_s(iim1) + x, c_qc(iim1) + write(io8,8002) kkdup,ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + 8002 format(i3,1x,i6,1x,a8,1x,a8,1x,a9,1x,i7,1x,2f11.5,1x + x, f8.1,1x,f7.0,1x,f5.2,4(2(1x,f8.2),1x,i5),1x + x, '!',a11,'!') + endif +cc +ccccccdak Set up table associating airep and acars flight ids +cc Set up table associating airep and tamdar flight ids +cc Require that the report be within idt_samflt of the previously +cc saved minimum and maximum times for this flight segment +cc and is within fairly close limits on position, temp and winds +cc --------------------------------------------------------------- +c if( ( (l_ii_acars .and..not.l_iim1_acars ).or. +c $ (l_iim1_acars .and..not.l_ii_acars ).or. +c $ (l_ii_mdcrs .and..not.l_iim1_mdcrs).or. +c $ (l_iim1_mdcrs.and..not.l_ii_mdcrs ) ).and. +! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c $ abs(alat(iim1)-alat(ii)) .lt.0.025.and. +c $ abs(alon(iim1)-alon(ii)) .lt.0.025.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c $ abs(ob_t(iim1)-ob_t(ii)) .lt.0.65.and. +c $ abs(difdir).lt.5.5.and. +c $ abs(ob_spd(iim1)-ob_spd(ii)).lt.0.55.and. +c $ (c_qc(iim1)(1:1).eq.'D'.or.c_qc(iim1)(1:1).eq.'d').and. +c $ c_acftid(iim1)(1:8).ne.c_acftid(ii)(1:8) ) then +cc +c if(ndup.ne.0) then +c kk = 1 +cc +c do while (kk.le.ndup) +c min_idt = idt_min(kk) - idt_samflt +cc if(min_idt.lt.0) min_idt = 0 +c max_idt = idt_max(kk) + idt_samflt +cc if(max_idt.gt.24*60*60) max_idt = 24*60*60 +cc +c if(c_acftid(ii) .eq.c_acr_id(kk).and. +c $ c_acftreg(ii) .eq.c_acr_reg(kk).and. +c $ c_acftid(iim1).eq.c_air_id(kk).and. +c $ idt(ii).ge.min_idt.and. +c $ idt(ii).le.max_idt) then +cc +c kdup(kk) = kdup(kk) + 1 +c if(idt(ii).lt.idt_min(kk)) +c $ idt_min(kk) = idt(ii) +c if(idt(ii).gt.idt_max(kk)) +c $ idt_max(kk) = idt(ii) +cc +c goto 201 +c endif +cc +c kk = kk + 1 +c enddo +c endif +cc +c ndup = ndup + 1 +c c_acr_id(ndup) = c_acftid(ii) +c c_acr_reg(ndup) = c_acftreg(ii) +c c_air_id(ndup) = c_acftid(iim1) +c idt_min(ndup) = idt(ii) +c idt_max(ndup) = idt(ii) +c kdup(ndup) = 1 +cc +c 201 continue +c endif +c +c Set c_qc to '.' if iim1 = 0 +c --------------------------- + else + if(c_qc(ii)(1:1).eq.'-') c_qc(ii)(1:1) = '.' + endif +c +c End loop over reports within 60 seconds +c --------------------------------------- + enddo +c +c End loop over reports +c --------------------- + enddo +cc +cc Check mixed duplicates for double mapping +cc ----------------------------------------------- +c do kk=1,ndup-1 +c do kk1=kk+1,ndup +c if(c_air_id(kk).eq.c_air_id(kk1).and. +c $ c_acr_id(kk).ne.c_acr_id(kk1)) then +c if((kdup(kk).le.3.and.kdup(kk1).gt.5).or. +c $ ((kdup(kk1)-kdup(kk))*100/kdup(kk1).ge.70)) then +c c_air_id(kk) = ' ' +c c_acr_id(kk) = ' ' +c kdup(kk) = 0 +c elseif((kdup(kk).gt.5.and.kdup(kk1).le.3).or. +c $ ((kdup(kk)-kdup(kk1))*100/kdup(kk).ge.70)) then +c c_air_id(kk1) = ' ' +c c_acr_id(kk1) = ' ' +c kdup(kk1) = 0 +c else +c write(io8,*) +c write(io8,*) 'Multiple ids for mixed duplicates found' +c write(io8,*) 'Cannot choose which id to use' +c write(io8,*) kk,' ',c_air_id(kk),c_acr_id(kk), +c $ kdup(kk),idt_min(kk),idt_max(kk) +c write(io8,*) kk1,' ',c_air_id(kk1),c_acr_id(kk1), +c $ kdup(kk1),idt_min(kk1),idt_max(kk1) +c c_air_id(kk) = ' ' +c c_acr_id(kk) = ' ' +c kdup(kk) = 0 +c c_air_id(kk1) = ' ' +c c_acr_id(kk1) = ' ' +c kdup(kk1) = 0 +c endif +c endif +c enddo +c enddo +cc +cc Output mixed duplicate mapping +cc ------------------------------ +c write(io8,*) +ccccdak write(io8,*) ' kk airep id acars id # idt_min idt_max' +c write(io8,*) ' kk airep id tamdar id # idt_min idt_max' +c write(io8,*) ' -- -------- --------- --- ------- -------' +c do kk=1,ndup +c write(io8,*) kk,' ',c_air_id(kk),c_acr_id(kk),kdup(kk), +c $ idt_min(kk),idt_max(kk) +c enddo +cc +cc Map new flight ids and tail numbers on airep data +cc Check all flights--allow AMDAR-AIREP mixed dups +ccccccdak Almost all of the AIREP-ACARS/MDCRS dups are UAL +cc Almost all of the AIREP-TAMDAR/MDCRS dups are UAL +cc ------------------------------------------------- +c kmap = 0 +c l_ual_all = .false. +cc +c do iob=1,numreps +c ii = indx(iob) +c if(itype(ii).ne.i_acars .and. +c $ itype(ii).ne.i_acars_asc .and. +c $ itype(ii).ne.i_acars_lvl .and. +c $ itype(ii).ne.i_acars_des .and. +c $ itype(ii).ne.i_mdcrs .and. +c $ itype(ii).ne.i_mdcrs_asc.and. +c $ itype(ii).ne.i_mdcrs_lvl.and. +c $ itype(ii).ne.i_mdcrs_des.and. +c $ itype(ii).ne.i_amdar .and. +c $ itype(ii).ne.i_amdar_asc.and. +c $ itype(ii).ne.i_amdar_lvl.and. +c $ itype(ii).ne.i_amdar_des.and. +c $ c_qc(ii)(1:1).ne.'D'.and. +c $ c_qc(ii)(1:1).ne.'d'.and. +c $ c_qc(ii)(1:1).ne.'e'.and. +c $ c_qc(ii)(1:1).ne.'E'.and. +c $ (.not.l_ual_all.or. +c $ (l_ual_all.and.c_acftid(ii)(1:2).eq.'UA'))) then +cc +c do kk=1,ndup +c min_idt = idt_min(kk) - idt_samflt +c max_idt = idt_max(kk) + idt_samflt +cc +c if((c_acftid(ii)(1:8).eq. +c $ c_air_id(kk)(1:2)//c_air_id(kk)(4:9)).or. +c $ (c_acftid(ii)(1:9).eq.c_air_id(kk)(1:9)).and. +c $ idt(ii).ge.min_idt.and. +c $ idt(ii).le.max_idt) then +cc +cc write(io8,*) +cc write(io8,*) 'Flight id re-mapped: before and after' +cc write(io8,8002) kkdup,ii,c_insty_ob(itype(ii)) +cc x, c_acftreg(ii),c_acftid(ii) +cc x, idt(ii),alat(ii),alon(ii) +cc x, pres(ii),ht_ft(ii) +cc x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) +cc x, ob_q(ii),xiv_q(ii),ichk_q(ii) +cc x, ob_dir(ii),xiv_d(ii),ichk_d(ii) +cc x, ob_spd(ii),xiv_s(ii),ichk_s(ii) +cc x, c_qc(ii) +cc +c c_acftid(ii) = c_acr_id(kk) +c c_acftreg(ii) = c_acr_reg(kk) +c kmap = kmap + 1 +cc +cc write(io8,8002) kkdup,ii,c_insty_ob(itype(ii)) +cc x, c_acftreg(ii),c_acftid(ii) +cc x, idt(ii),alat(ii),alon(ii) +cc x, pres(ii),ht_ft(ii) +cc x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) +cc x, ob_q(ii),xiv_q(ii),ichk_q(ii) +cc x, ob_dir(ii),xiv_d(ii),ichk_d(ii) +cc x, ob_spd(ii),xiv_s(ii),ichk_s(ii) +cc x, c_qc(ii) +c endif +c enddo +c endif +c enddo +c +c If no tail number is found, copy airlines ident into tail number +c to accumulate stats by airline +c ----------------------------------------------------------------- +c DAK: Could this be written more efficiently? + do iob=1,numreps + ii = indx(iob) +C DAK: Here is the logic that originally did not work for TAMDAR reports whose tail number is +c missing, but flight number was all numbers (e.g., "00009934") meaning a tail number +c could not be created from the flight number -- this was bypassed by changing "000" in +c the 1st 3 characters of the flight number to "TAM" in subroutine input_acqc where the +c reports are read in from NCEP PREPBUFR file and stored in memory + if(c_acftreg(ii).eq.' ') then + if(c_acftid(ii)(1:5).eq.'XX999') then + c_acftreg(ii)(1:5) = 'XX999' + else + if(c_acftid(ii)(1:1).ge.'A'.and. + $ c_acftid(ii)(1:1).le.'Z') + $ c_acftreg(ii)(1:1) = c_acftid(ii)(1:1) +c + if(c_acftid(ii)(2:2).ge.'A'.and. + $ c_acftid(ii)(2:2).le.'Z'.and. + $ c_acftreg(ii)(1:1).ne.' ') + $ c_acftreg(ii)(2:2) = c_acftid(ii)(2:2) +c + if(c_acftid(ii)(3:3).ge.'A'.and. + $ c_acftid(ii)(3:3).le.'Z'.and. + $ c_acftreg(ii)(2:2).ne.' ') + $ c_acftreg(ii)(3:3) = c_acftid(ii)(3:3) +c + if(c_acftid(ii)(4:4).ge.'A'.and. + $ c_acftid(ii)(4:4).le.'Z'.and. + $ c_acftreg(ii)(3:3).ne.' ') + $ c_acftreg(ii)(4:4) = c_acftid(ii)(4:4) +c + if(c_acftid(ii)(5:5).ge.'A'.and. + $ c_acftid(ii)(5:5).le.'Z'.and. + $ c_acftreg(ii)(4:4).ne.' ') + $ c_acftreg(ii)(5:5) = c_acftid(ii)(5:5) + endif + endif + enddo +c +c write(io8,*) +c write(io8,*) 'Number of flight ids re-mapped = ',kmap +c +c Sum number of reports per tail numbers +c -------------------------------------- + write(*,*) 'Counting number of reports per tail number' + write(io8,*) + write(io8,*) 'Counting number of reports per tail number' + write(io8,*) '------------------------------------------' + l_print = .false. + call do_reg(l_print,io8, + $ max_reps,numreps,itype,c_qc,c_acftreg,indx, + $ maxflt,kreg,creg_reg,nobs_reg,*99) +c +c Output statistics and rejects +c ----------------------------- + kbad = 0 +c +c Write header to output file +c --------------------------- + if(.not.l_operational) then + write(io30,*) + write(io30,*) 'Encode dups (E or e)' + write(io30,*) '--------------------' + write(io30,3001) + 3001 format(' index type tail num flight time lat' + x, ' lon pres height ' + x, 't-prcn temp innov ichk' + x, ' spec hum innov ichk' + x, ' ob_dir innov ichk' + x, ' ob_spd innov ichk' + x, ' qc flag') + endif +c +c Loop over reports +c ----------------- + do iob = 1,numreps + ii = indx(iob) +c +c Count number of reports considered +c ---------------------------------- + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_des) then + nrep_Md = nrep_Md + 1 + ktype = 1 +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_des) then + nrep_Ac = nrep_Ac + 1 + ktype = 2 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_des) then + nrep_Am = nrep_Am + 1 + ktype = 3 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_des) then + nrep_Ar = nrep_Ar + 1 + ktype = 4 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + nrep_Ma = nrep_Ma + 1 + ktype = 5 +c + else + write(io8,*) + write(io8,*) 'Bad itype: ',itype(ii),' for ii = ',ii + ktype = 0 + endif +c +c Count number of reports rejected with encode errors +c --------------------------------------------------- + if(c_qc(ii)(1:1).eq.'e'.or. + $ c_qc(ii)(1:1).eq.'E') then +c + if(ktype.ne.0) kbad(ktype,1) = kbad(ktype,1) + 1 +c +c Count number of rejected reports by tail number +c ----------------------------------------------- + mm = 1 + do while(mm.le.kreg) + if(c_acftreg(ii).eq.creg_reg(mm)) then +c + if(ktype.gt.0.and.ktype.le.5) + $ nrej_reg(mm,ktype) = nrej_reg(mm,ktype) + 1 + mm = kreg + 1 + endif + mm = mm + 1 + enddo +c +c Flag bad report for reorder subroutine and output rejects +c --------------------------------------------------------- + csort(ii)(1:5) = 'badob' +c + if(.not.l_operational) then + write(io30,3002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + 3002 format(i6,1x,a8,1x,a8,1x,a9,1x,i7,1x,2f11.5,1x,f8.1,1x,f7.0 + x, 1x,f5.2,4(2(1x,f8.2),1x,i5),1x,'!',a11,'!') + endif +c +c Count number of bad temperatures and bad winds +c ---------------------------------------------- + elseif(c_qc(ii)(6:6).eq.'E'.or. + $ c_qc(ii)(7:7).eq.'E'.or. + $ c_qc(ii)(8:8).eq.'E') then +c +c Count number of rejected temps/winds by tail number +c --------------------------------------------------- + mm = 1 + do while(mm.le.kreg) + if(c_acftreg(ii).eq.creg_reg(mm)) then +c + if(ktype.gt.0.and.ktype.le.5) then + if(c_qc(ii)(6:6).eq.'E') + $ ntemp_reg(mm,ktype) = ntemp_reg(mm,ktype) + 1 + if(c_qc(ii)(7:7).eq.'E'.or. + $ c_qc(ii)(8:8).eq.'E') + $ nwind_reg(mm,ktype) = nwind_reg(mm,ktype) + 1 + endif + mm = kreg + 1 + endif + mm = mm + 1 + enddo + endif + enddo +c +c Output statistics +c ----------------- + if(.not.l_operational) then + write(io30,*) + write(io30,*)' Number of MDCRS encode dups rejected = ' + $, kbad(1,1) +ccccdak write(io30,*)' Number of ACARS encode dups rejected = ' + write(io30,*)' Number of TAMDAR encode dups rejected = ' + $, kbad(2,1) + write(io30,*)' Number of AMDAR encode dups rejected = ' + $, kbad(3,1) + write(io30,*)' Number of AIREP encode dups rejected = ' + $, kbad(4,1) + write(io30,*)' Number of manAIREP encode dups rejected = ' + $, kbad(5,1) + endif +c +c Output tail number counts +c ------------------------- + write(io8,*) + write(io8,*) ' Tail numbers for rejected encode dups' +ccccdak write(io8,*) ' Tail Num MDCRS ACARS AMDAR AIREP MAN ' + write(io8,*) ' Tail Num MDCRS TAMDAR AMDAR AIREP MAN ' + write(io8,*) ' -------------------------------------------' +c + do mm=1,kreg + if( nrej_reg(mm,1)+nrej_reg(mm,2)+nrej_reg(mm,3) + $ +nrej_reg(mm,4)+nrej_reg(mm,5).gt.0) then + write(io8,'(2x,a8,5(1x,i6))') + $ creg_reg(mm),(nrej_reg(mm,kk),kk=1,5) + endif + enddo +c + write(io8,*) + write(io8,*) ' Tail numbers for reports with bad temperature' +ccccdak write(io8,*) ' Tail Num MDCRS ACARS AMDAR AIREP MAN ' + write(io8,*) ' Tail Num MDCRS TAMDAR AMDAR AIREP MAN ' + write(io8,*) ' -------------------------------------------' +c + do mm=1,kreg + if( ntemp_reg(mm,1)+ntemp_reg(mm,2)+ntemp_reg(mm,3) + $ +ntemp_reg(mm,4)+ntemp_reg(mm,5).gt.0) then + write(io8,'(2x,a8,5(1x,i6))') + $ creg_reg(mm),(ntemp_reg(mm,kk),kk=1,5) + endif + enddo +c + write(io8,*) + write(io8,*) ' Tail numbers for reports with bad winds' +ccccdak write(io8,*) ' Tail Num MDCRS ACARS AMDAR AIREP MAN ' + write(io8,*) ' Tail Num MDCRS TAMDAR AMDAR AIREP MAN ' + write(io8,*) ' -------------------------------------------' +c + do mm=1,kreg + if( nwind_reg(mm,1)+nwind_reg(mm,2)+nwind_reg(mm,3) + $ +nwind_reg(mm,4)+nwind_reg(mm,5).gt.0) then + write(io8,'(2x,a8,5(1x,i6))') + $ creg_reg(mm),(nwind_reg(mm,kk),kk=1,5) + endif + enddo +c +c Write header to output file +c --------------------------- + if(l_save_dups.and.(.not.l_operational)) then + write(io30,*) + write(io30,*) 'True dups(D) and close dups (d)' + write(io30,*) '-------------------------------' + write(io30,3001) + endif +c +c Loop over reports +c ----------------- + do iob = 1,numreps + ii = indx(iob) +c +c Count number of exact duplicates +c -------------------------------- + if(c_qc(ii)(1:1).eq.'D'.and. + $ csort(ii)(1:5).ne.'badob') then +c + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_des) then + kbad(1,2) = kbad(1,2) + 1 + ndup_Md = ndup_Md + 1 +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_des) then + kbad(2,2) = kbad(2,2) + 1 + ndup_Ac = ndup_Ac + 1 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_des) then + kbad(3,2) = kbad(3,2) + 1 + ndup_Am = ndup_Am + 1 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_des) then + kbad(4,2) = kbad(4,2) + 1 + ndup_Ar = ndup_Ar + 1 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + kbad(5,2) = kbad(5,2) + 1 + ndup_Ma = ndup_Ma + 1 +c + else + write(io8,*) + write(io8,*) 'Bad itype: ',itype(ii),' for ii = ',ii + endif + endif +c +c Count number of near and encode duplicates +c ------------------------------------------ + if(c_qc(ii)(1:1).eq.'d'.and. + $ csort(ii)(1:5).ne.'badob') then +c + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_des) then + kbad(1,3) = kbad(1,3) + 1 + ndup_Md = ndup_Md + 1 +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_des) then + kbad(2,3) = kbad(2,3) + 1 + ndup_Ac = ndup_Ac + 1 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_des) then + kbad(3,3) = kbad(3,3) + 1 + ndup_Am = ndup_Am + 1 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_des) then + kbad(4,3) = kbad(4,3) + 1 + ndup_Ar = ndup_Ar + 1 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + kbad(5,3) = kbad(5,3) + 1 + ndup_Ma = ndup_Ma + 1 +c + else + write(io8,*) + write(io8,*) 'Bad itype: ',itype(ii),' for ii = ',ii + endif + endif +c +c Set flag for "reorder" and output dups if desired +c ------------------------------------------------- + if(c_qc(ii)(1:1).eq.'D'.or. + $ c_qc(ii)(1:1).eq.'d') then +c + csort(ii)(1:5) = 'badob' +c + if(l_save_dups.and.(.not.l_operational)) then + write(io30,3002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + endif +c + endif + enddo +c +c Output statistics +c ----------------- + if(.not.l_operational) then + write(io30,*)' Number of MDCRS exact dups rejected = ' + $, kbad(1,2) +ccccdak write(io30,*)' Number of ACARS exact dups rejected = ' + write(io30,*)' Number of TAMDAR exact dups rejected = ' + $, kbad(2,2) + write(io30,*)' Number of AMDAR exact dups rejected = ' + $, kbad(3,2) + write(io30,*)' Number of AIREP exact dups rejected = ' + $, kbad(4,2) + write(io30,*)' Number of manAIREP exact dups rejected = ' + $, kbad(5,2) + write(io30,*)' Number of MDCRS near dups rejected = ' + $, kbad(1,3) +ccccdak write(io30,*)' Number of ACARS near dups rejected = ' + write(io30,*)' Number of TAMDAR near dups rejected = ' + $, kbad(2,3) + write(io30,*)' Number of AMDAR near dups rejected = ' + $, kbad(3,3) + write(io30,*)' Number of AIREP near dups rejected = ' + $, kbad(4,3) + write(io30,*)' Number of manAIREP near dups rejected = ' + $, kbad(5,3) + endif +c + kbadtot = kbad(1,1) + kbad(2,1) + kbad(3,1) + kbad(4,1) + $ + kbad(5,1) + kbad(1,2) + kbad(2,2) + kbad(3,2) + $ + kbad(4,2) + kbad(5,2) + kbad(1,3) + kbad(2,3) + $ + kbad(3,3) + kbad(4,3) + kbad(5,3) +c + write(io8,*) + write(io8,*) numreps,' good reports processed' + write(io8,*) kbadtot,' reports failed qc in duplicate check' +c +c Output detailed stats +c --------------------- + if(l_last) then + write(io8,*) + write(io8,*) 'Distribution of MDCRS reports' + do ii=19,1,-1 + write(io8,'(37i7)') (n_area_Md(ii,kk),kk=1,37) + enddo +c + write(io8,*) +ccccdak write(io8,*) 'Distribution of ACARS reports' + write(io8,*) 'Distribution of TAMDAR reports' + do ii=19,1,-1 + write(io8,'(37i7)') (n_area_Ac(ii,kk),kk=1,37) + enddo +c + write(io8,*) + write(io8,*) 'Distribution of AMDAR reports' + do ii=19,1,-1 + write(io8,'(37i7)') (n_area_Am(ii,kk),kk=1,37) + enddo +c + write(io8,*) + write(io8,*) 'Distribution of AIREP reports' + do ii=19,1,-1 + write(io8,'(37i7)') (n_area_Ar(ii,kk),kk=1,37) + enddo +c + write(io8,*) + write(io8,*) 'Distribution of manAIREP reports' + do ii=19,1,-1 + write(io8,'(37i7)') (n_area_Ma(ii,kk),kk=1,37) + enddo +c + write(io8,*) + write(io8,*) 'Temporal distribution of MDCRS reports' + do ii=1,24 + write(io8,*) ii,n_time_Md(ii) + enddo +c + write(io8,*) +ccccdak write(io8,*) 'Temporal distribution of ACARS reports' + write(io8,*) 'Temporal distribution of TAMDAR reports' + do ii=1,24 + write(io8,*) ii,n_time_Ac(ii) + enddo +c + write(io8,*) + write(io8,*) 'Temporal distribution of AMDAR reports' + do ii=1,24 + write(io8,*) ii,n_time_Am(ii) + enddo +c + write(io8,*) + write(io8,*) 'Temporal distribution of AIREP reports' + do ii=1,24 + write(io8,*) ii,n_time_Ar(ii) + enddo +c + write(io8,*) + write(io8,*) 'Temporal distribution of manAIREP reports' + do ii=1,24 + write(io8,*) ii,n_time_Ma(ii) + enddo +c + write(io8,*) + write(io8,*) 'Vertical distribution of MDCRS reports' + write(io8,*) '<0 ',n_lev_Md(53) + do ii=0,50 + write(io8,*) ii,n_lev_Md(ii+1) + enddo + write(io8,*) '>50',n_lev_Md(52) +c + write(io8,*) +ccccdak write(io8,*) 'Vertical distribution of ACARS reports' + write(io8,*) 'Vertical distribution of TAMDAR reports' + write(io8,*) '<0 ',n_lev_Ac(53) + do ii=0,50 + write(io8,*) ii,n_lev_Ac(ii+1) + enddo + write(io8,*) '>50',n_lev_Ac(52) +c + write(io8,*) + write(io8,*) 'Vertical distribution of AMDAR reports' + write(io8,*) '<0 ',n_lev_Am(53) + do ii=0,50 + write(io8,*) ii,n_lev_Am(ii+1) + enddo + write(io8,*) '>50',n_lev_Am(52) +c + write(io8,*) + write(io8,*) 'Vertical distribution of AIREP reports' + write(io8,*) '<0 ',n_lev_Ar(53) + do ii=0,50 + write(io8,*) ii,n_lev_Ar(ii+1) + enddo + write(io8,*) '>50',n_lev_Ar(52) +c + write(io8,*) + write(io8,*) 'Vertical distribution of manAIREP reports' + write(io8,*) '<0 ',n_lev_Ma(53) + do ii=0,50 + write(io8,*) ii,n_lev_Ma(ii+1) + enddo + write(io8,*) '>50',n_lev_Ma(52) +c + write(io8,*) + write(io8,*) 'Vertical distribution of MDCRS temp reports' + write(io8,*) '-------------------------------------------' + write(io8,'('' Altitude (kft)'')') + write(io8,'(1x,a45,a41)') + $ 'Temp (C) <0 0-5 5-10 10-15 15-20 20-25 ', + $ '25-30 30-35 35-40 40-45 45-50 50 >50 ' + write(io8,'(1x,a45,a41)') + $ '-------- ----- ----- ----- ----- ----- ----- ', + $ '----- ----- ----- ----- ----- ----- -----' + write(io8,'('' missing '',13i7)') n_temp_Md(36,13), + $ (n_temp_Md(36,ii),ii=1,12) + write(io8,'(1x,a45,a41)') + $ '-------- ----- ----- ----- ----- ----- ----- ', + $ '----- ----- ----- ----- ----- ----- -----' + write(io8,'('' < -100 '',13i7)') n_temp_Md(35,13), + $ (n_temp_Md(35,ii),ii=1,12) + do kk=1,33 + ktemp = (5 * (kk-1) + 173) - 273 + write(io8,'(i9,13i7)') ktemp,n_temp_Md(kk,13), + $ (n_temp_Md(kk,ii),ii=1,12) + enddo + write(io8,'('' > 60 '',13i7)') n_temp_Md(34,13), + $ (n_temp_Md(34,ii),ii=1,12) +c + write(io8,*) +ccccdak write(io8,*) 'Vertical distribution of ACARS temp reports' + write(io8,*) 'Vertical distribution of TAMDAR temp reports' + write(io8,*) '--------------------------------------------' + write(io8,'('' Altitude (kft)'')') + write(io8,'(1x,a45,a41)') + $ 'Temp (C) <0 0-5 5-10 10-15 15-20 20-25 ', + $ '25-30 30-35 35-40 40-45 45-50 50 >50 ' + write(io8,'(1x,a45,a41)') + $ '-------- ----- ----- ----- ----- ----- ----- ', + $ '----- ----- ----- ----- ----- ----- -----' + write(io8,'('' missing '',13i7)') n_temp_Ac(36,13), + $ (n_temp_Ac(36,ii),ii=1,12) + write(io8,'(1x,a45,a41)') + $ '-------- ----- ----- ----- ----- ----- ----- ', + $ '----- ----- ----- ----- ----- ----- -----' + write(io8,'('' < -100 '',13i7)') n_temp_Ac(35,13), + $ (n_temp_Ac(35,ii),ii=1,12) + do kk=1,33 + ktemp = (5 * (kk-1) + 173) - 273 + write(io8,'(i9,13i7)') ktemp,n_temp_Ac(kk,13), + $ (n_temp_Ac(kk,ii),ii=1,12) + enddo + write(io8,'('' > 60 '',13i7)') n_temp_Ac(34,13), + $ (n_temp_Ac(34,ii),ii=1,12) +c + write(io8,*) + write(io8,*) 'Vertical distribution of AMDAR temp reports' + write(io8,*) '-------------------------------------------' + write(io8,'('' Altitude (kft)'')') + write(io8,'(1x,a45,a41)') + $ 'Temp (C) <0 0-5 5-10 10-15 15-20 20-25 ', + $ '25-30 30-35 35-40 40-45 45-50 50 >50 ' + write(io8,'(1x,a45,a41)') + $ '-------- ----- ----- ----- ----- ----- ----- ', + $ '----- ----- ----- ----- ----- ----- -----' + write(io8,'('' missing '',13i7)') n_temp_Am(36,13), + $ (n_temp_Am(36,ii),ii=1,12) + write(io8,'(1x,a45,a41)') + $ '-------- ----- ----- ----- ----- ----- ----- ', + $ '----- ----- ----- ----- ----- ----- -----' + write(io8,'('' < -100 '',13i7)') n_temp_Am(35,13), + $ (n_temp_Am(35,ii),ii=1,12) + do kk=1,33 + ktemp = (5 * (kk-1) + 173) - 273 + write(io8,'(i9,13i7)') ktemp,n_temp_Am(kk,13), + $ (n_temp_Am(kk,ii),ii=1,12) + enddo + write(io8,'('' > 60 '',13i7)') n_temp_Am(34,13), + $ (n_temp_Am(34,ii),ii=1,12) +c + write(io8,*) + write(io8,*) 'Vertical distribution of AIREP temp reports' + write(io8,*) '-------------------------------------------' + write(io8,'('' Altitude (kft)'')') + write(io8,'(1x,a45,a41)') + $ 'Temp (C) <0 0-5 5-10 10-15 15-20 20-25 ', + $ '25-30 30-35 35-40 40-45 45-50 50 >50 ' + write(io8,'(1x,a45,a41)') + $ '-------- ----- ----- ----- ----- ----- ----- ', + $ '----- ----- ----- ----- ----- ----- -----' + write(io8,'('' missing '',13i7)') n_temp_Ar(36,13), + $ (n_temp_Ar(36,ii),ii=1,12) + write(io8,'(1x,a45,a41)') + $ '-------- ----- ----- ----- ----- ----- ----- ', + $ '----- ----- ----- ----- ----- ----- -----' + write(io8,'('' < -100 '',13i7)') n_temp_Ar(35,13), + $ (n_temp_Ar(35,ii),ii=1,12) + do kk=1,33 + ktemp = (5 * (kk-1) + 173) - 273 + write(io8,'(i9,13i7)') ktemp,n_temp_Ar(kk,13), + $ (n_temp_Ar(kk,ii),ii=1,12) + enddo + write(io8,'('' > 60 '',13i7)') n_temp_Ar(34,13), + $ (n_temp_Ar(34,ii),ii=1,12) +c + write(io8,*) + write(io8,*) 'Vertical distribution of manAIREP temp reports' + write(io8,*) '-------------------------------------------' + write(io8,'('' Altitude (kft)'')') + write(io8,'(1x,a45,a41)') + $ 'Temp (C) <0 0-5 5-10 10-15 15-20 20-25 ', + $ '25-30 30-35 35-40 40-45 45-50 50 >50 ' + write(io8,'(1x,a45,a41)') + $ '-------- ----- ----- ----- ----- ----- ----- ', + $ '----- ----- ----- ----- ----- ----- -----' + write(io8,'('' missing '',13i7)') n_temp_Ma(36,13), + $ (n_temp_Ma(36,ii),ii=1,12) + write(io8,'(1x,a45,a41)') + $ '-------- ----- ----- ----- ----- ----- ----- ', + $ '----- ----- ----- ----- ----- ----- -----' + write(io8,'('' < -100 '',13i7)') n_temp_Ma(35,13), + $ (n_temp_Ma(35,ii),ii=1,12) + do kk=1,33 + ktemp = (5 * (kk-1) + 173) - 273 + write(io8,'(i9,13i7)') ktemp,n_temp_Ma(kk,13), + $ (n_temp_Ma(kk,ii),ii=1,12) + enddo + write(io8,'('' > 60 '',13i7)') n_temp_Ma(34,13), + $ (n_temp_Ma(34,ii),ii=1,12) +c + write(io8,*) + write(io8,*) 'Vertical distribution of MDCRS wspd reports' + write(io8,*) '-------------------------------------------' + write(io8,'('' Altitude (kft)'')') + write(io8,'(1x,a45,a41)') + $ 'Spd(m/s) <0 0-5 5-10 10-15 15-20 20-25 ', + $ '25-30 30-35 35-40 40-45 45-50 50 >50 ' + write(io8,'(1x,a45,a41)') + $ '-------- ----- ----- ----- ----- ----- ----- ', + $ '----- ----- ----- ----- ----- ----- -----' + write(io8,'('' missing '',13i7)') n_wspd_Md(40,13), + $ (n_wspd_Md(40,ii),ii=1,12) + write(io8,'(1x,a45,a41)') + $ '-------- ----- ----- ----- ----- ----- ----- ', + $ '----- ----- ----- ----- ----- ----- -----' + write(io8,'('' < 0 '',13i7)') n_wspd_Md(39,13), + $ (n_wspd_Md(39,ii),ii=1,12) + do kk=1,37 + kwspd = 5 * (kk-1) + write(io8,'(i9,13i7)') kwspd,n_wspd_Md(kk,13), + $ (n_wspd_Md(kk,ii),ii=1,12) + enddo + write(io8,'('' > 180 '',13i7)') n_wspd_Md(38,13), + $ (n_wspd_Md(38,ii),ii=1,12) +c + write(io8,*) +ccccdak write(io8,*) 'Vertical distribution of ACARS wspd reports' + write(io8,*) 'Vertical distribution of TAMDAR wspd reports' + write(io8,*) '-------------------------------------------' + write(io8,'('' Altitude (kft)'')') + write(io8,'(1x,a45,a41)') + $ 'Spd(m/s) <0 0-5 5-10 10-15 15-20 20-25 ', + $ '25-30 30-35 35-40 40-45 45-50 50 >50 ' + write(io8,'(1x,a45,a41)') + $ '-------- ----- ----- ----- ----- ----- ----- ', + $ '----- ----- ----- ----- ----- ----- -----' + write(io8,'('' missing '',13i7)') n_wspd_Ac(40,13), + $ (n_wspd_Ac(40,ii),ii=1,12) + write(io8,'(1x,a45,a41)') + $ '-------- ----- ----- ----- ----- ----- ----- ', + $ '----- ----- ----- ----- ----- ----- -----' + write(io8,'('' < 0 '',13i7)') n_wspd_Ac(39,13), + $ (n_wspd_Ac(39,ii),ii=1,12) + do kk=1,37 + kwspd = 5 * (kk-1) + write(io8,'(i9,13i7)') kwspd,n_wspd_Ac(kk,13), + $ (n_wspd_Ac(kk,ii),ii=1,12) + enddo + write(io8,'('' > 180 '',13i7)') n_wspd_Ac(38,13), + $ (n_wspd_Ac(38,ii),ii=1,12) +c + write(io8,*) + write(io8,*) 'Vertical distribution of AMDAR wspd reports' + write(io8,*) '-------------------------------------------' + write(io8,'('' Altitude (kft)'')') + write(io8,'(1x,a45,a41)') + $ 'Spd(m/s) <0 0-5 5-10 10-15 15-20 20-25 ', + $ '25-30 30-35 35-40 40-45 45-50 50 >50 ' + write(io8,'(1x,a45,a41)') + $ '-------- ----- ----- ----- ----- ----- ----- ', + $ '----- ----- ----- ----- ----- ----- -----' + write(io8,'('' missing '',13i7)') n_wspd_Am(40,13), + $ (n_wspd_Am(40,ii),ii=1,12) + write(io8,'(1x,a45,a41)') + $ '-------- ----- ----- ----- ----- ----- ----- ', + $ '----- ----- ----- ----- ----- ----- -----' + write(io8,'('' < 0 '',13i7)') n_wspd_Am(39,13), + $ (n_wspd_Am(39,ii),ii=1,12) + do kk=1,37 + kwspd = 5 * (kk-1) + write(io8,'(i9,13i7)') kwspd,n_wspd_Am(kk,13), + $ (n_wspd_Am(kk,ii),ii=1,12) + enddo + write(io8,'('' > 180 '',13i7)') n_wspd_Am(38,13), + $ (n_wspd_Am(38,ii),ii=1,12) +c + write(io8,*) + write(io8,*) 'Vertical distribution of AIREP wspd reports' + write(io8,*) '-------------------------------------------' + write(io8,'('' Altitude (kft)'')') + write(io8,'(1x,a45,a41)') + $ 'Spd(m/s) <0 0-5 5-10 10-15 15-20 20-25 ', + $ '25-30 30-35 35-40 40-45 45-50 50 >50 ' + write(io8,'(1x,a45,a41)') + $ '-------- ----- ----- ----- ----- ----- ----- ', + $ '----- ----- ----- ----- ----- ----- -----' + write(io8,'('' missing '',13i7)') n_wspd_Ar(40,13), + $ (n_wspd_Ar(40,ii),ii=1,12) + write(io8,'(1x,a45,a41)') + $ '-------- ----- ----- ----- ----- ----- ----- ', + $ '----- ----- ----- ----- ----- ----- -----' + write(io8,'('' < 0 '',13i7)') n_wspd_Ar(39,13), + $ (n_wspd_Ar(39,ii),ii=1,12) + do kk=1,37 + kwspd = 5 * (kk-1) + write(io8,'(i9,13i7)') kwspd,n_wspd_Ar(kk,13), + $ (n_wspd_Ar(kk,ii),ii=1,12) + enddo + write(io8,'('' > 180 '',13i7)') n_wspd_Ar(38,13), + $ (n_wspd_Ar(38,ii),ii=1,12) +c + write(io8,*) + write(io8,*) 'Vertical distribution of manAIREP wspd reports' + write(io8,*) '-------------------------------------------' + write(io8,'('' Altitude (kft)'')') + write(io8,'(1x,a45,a41)') + $ 'Spd(m/s) <0 0-5 5-10 10-15 15-20 20-25 ', + $ '25-30 30-35 35-40 40-45 45-50 50 >50 ' + write(io8,'(1x,a45,a41)') + $ '-------- ----- ----- ----- ----- ----- ----- ', + $ '----- ----- ----- ----- ----- ----- -----' + write(io8,'('' missing '',13i7)') n_wspd_Ma(40,13), + $ (n_wspd_Ma(40,ii),ii=1,12) + write(io8,'(1x,a45,a41)') + $ '-------- ----- ----- ----- ----- ----- ----- ', + $ '----- ----- ----- ----- ----- ----- -----' + write(io8,'('' < 0 '',13i7)') n_wspd_Ma(39,13), + $ (n_wspd_Ma(39,ii),ii=1,12) + do kk=1,37 + kwspd = 5 * (kk-1) + write(io8,'(i9,13i7)') kwspd,n_wspd_Ma(kk,13), + $ (n_wspd_Ma(kk,ii),ii=1,12) + enddo + write(io8,'('' > 180 '',13i7)') n_wspd_Ma(38,13), + $ (n_wspd_Ma(38,ii),ii=1,12) + endif +c + write(*,*) + write(*,*) 'Duplicate check data counts--',cdtg_an + write(*,*) '---------------------------------------' + write(*,'(1x,a55)') +ccccdak $ 'Type of check MDCRS ACARS AMDAR AIREP man' + $ 'Type of check MDCRS TAMDAR AMDAR AIREP man' + write(*,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(*,'('' Num considered '',5(1x,i7))') + $ nrep_Md,nrep_Ac,nrep_Am,nrep_Ar,nrep_Ma + write(*,'('' Short ids '',24x,2(1x,i7),8x)') + $ n_sh_Ar,n_sh_Ma + write(*,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(*,'('' All duplicates '',5(1x,i7))') + $ ndup_Md,ndup_Ac,ndup_Am,ndup_Ar,ndup_Ma + write(*,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(*,'('' Bad encode dup '',32x,(1x,i7),8x)') + $ n_bad_encode + write(*,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + write(io8,*) + write(io8,*) 'Duplicate check data counts' + write(io8,*) '---------------------------' + write(io8,'(1x,a55)') +ccccdak $ 'Type of check MDCRS ACARS AMDAR AIREP man' + $ 'Type of check MDCRS TAMDAR AMDAR AIREP man' + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Num considered '',5(1x,i7))') + $ nrep_Md,nrep_Ac,nrep_Am,nrep_Ar,nrep_Ma + write(io8,'(''Missing ids '',24x,2(1x,i7),8x)') + $ n_xx999_Ar,n_xx999_Ma + write(io8,'(''Short ids '',24x,2(1x,i7),8x)') + $ n_sh_Ar,n_sh_Ma + write(io8,'(''Whole deg pos '',5(1x,i7))') + $ n_00_Md,n_00_Ac,n_00_Am,n_00_Ar,n_00_Ma + write(io8,'(''Zero lat/lon '',5(1x,i7))') + $ n_0000_Md,n_0000_Ac,n_0000_Am,n_0000_Ar,n_0000_Ma + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''All duplicates '',5(1x,i7))') + $ ndup_Md,ndup_Ac,ndup_Am,ndup_Ar,ndup_Ma + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Bad encode dup '',32x,(1x,i7),8x)') + $ n_bad_encode + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,*) + write(io8,*) ' Exact duplicates: ',n_exact + write(io8,*) ' Exact duplicates with short ids: ',n_exact_sh + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Duplicates Md '',32x,(1x,i7))') + $ n_ex_sh_MaMd + write(io8,'(''Duplicates Ac '',32x,(1x,i7))') + $ n_ex_sh_MaAc + write(io8,'(''Duplicates Ar '',24x,2(1x,i7))') + $ n_ex_sh_ArAr,n_ex_sh_MaAr + write(io8,'(''Duplicates Ma '',24x,2(1x,i7))') + $ n_ex_sh_ArMa,n_ex_sh_MaMa + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,*) + write(io8,*) ' Exact dups with 0 lat and 0 lon: ',n_exact_0ll + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Duplicates Md '',5(1x,i7))') + $ n_ex_0ll_MdMd,n_ex_0ll_AcAc + write(io8,'(''Duplicates Ar '',32x,2(1x,i7))') + $ n_ex_0ll_MaAr + write(io8,'(''Duplicates Ma '',32x,2(1x,i7))') + $ n_ex_0ll_MaMa + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,*) + write(io8,*) ' Other exact duplicates:' + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Duplicates Md '',2(1x,i7),8x,2(1x,i7))') + $ n_exact_MdMd,n_exact_MdAc,n_exact_MdAr,n_exact_MdMa + write(io8,'(''Duplicates Ac '',8x,(1x,i7),8x,2(1x,i7))') + $ n_exact_AcAc,n_exact_AcAr,n_exact_AcMa + write(io8,'(''Duplicates Am '',16x,4(1x,i7))') + $ n_exact_AmAm,n_exact_AmAr,n_exact_AmMa + write(io8,'(''Duplicates Ar '',24x,3(1x,i7))') + $ n_exact_ArAr,n_exact_ArMa + write(io8,'(''Duplicates Ma '',32x,2(1x,i7))') + $ n_exact_MaMa + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + write(io8,*) + write(io8,*) 'Exact duplicates with bad roll angle qc flags: ' + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Duplicates Md '',(1x,i7))') + $ n_ex_bad_roll_Md + write(io8,'(''Duplicates Am '',16x,(1x,i7))') + $ n_ex_bad_roll_Am + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + write(io8,*) + write(io8,*) ' Near duplicates: ',n_near + write(io8,*) ' Near duplicates with short ids: ',n_near_sh + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Duplicates Md '',32x,(1x,i7))') + $ n_nr_sh_MaMd + write(io8,'(''Duplicates Ac '',32x,(1x,i7))') + $ n_nr_sh_MaAc + write(io8,'(''Duplicates Ar '',24x,2(1x,i7))') + $ n_nr_sh_ArAr,n_nr_sh_MaAr + write(io8,'(''Duplicates Ma '',24x,2(1x,i7))') + $ n_nr_sh_ArMa,n_nr_sh_MaMa + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,*) + write(io8,*) ' Near dups with 0 lat and 0 lon: ',n_near_0ll + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Duplicates Md '',(1x,i7),24x,(1x,i7))') + $ n_nr_0ll_MdMd,n_nr_0ll_MaMd + write(io8,'(''Duplicates Ac '',8x,5(1x,i7))') + $ n_nr_0ll_AcAc + write(io8,'(''Duplicates Am '',32x,(1x,i7))') + $ n_nr_0ll_MaAm + write(io8,'(''Duplicates Ar '',16x,(1x,i7),8x,(1x,i7))') + $ n_nr_0ll_AmAr,n_nr_0ll_MaAr + write(io8,'(''Duplicates Ma '',(1x,i7),8x,(1x,i7),8x,(1x,i7))') + $ n_nr_0ll_MdMa,n_nr_0ll_AmMa,n_nr_0ll_MaMa + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,*) + write(io8,*) ' Near dups with missing temp: ',n_near_mst + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Duplicates Md '',(1x,i7),16x,2(1x,i7))') + $ n_nr_mst_MdMd,n_nr_mst_ArMd,n_nr_mst_MaMd + write(io8,'(''Duplicates Ac '',24x,2(1x,i7))') + $ n_nr_mst_ArAc,n_nr_mst_MaAc + write(io8,'(''Duplicates Am '',16x,3(1x,i7))') + $ n_nr_mst_AmAm,n_nr_mst_ArAm,n_nr_mst_MaAm + write(io8,'(''Duplicates Ar '',16x,3(1x,i7))') + $ n_nr_mst_AmAr,n_nr_mst_ArAr,n_nr_mst_MaAr + write(io8,'(''Duplicates Ma '',24x,2(1x,i7))') + $ n_nr_mst_ArMa,n_nr_mst_MaMa + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,*) + write(io8,*) ' Near dups with missing winds: ',n_near_ws + write(io8,*) ' ID begins with IT:',n_near_ws_IT + write(io8,*) ' ID begins with EU:',n_near_ws_EU + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Duplicates Md '',2(1x,i7),8x,2(1x,i7))') + $ n_nr_mswn_MdMd,n_nr_mswn_AcMd,n_nr_mswn_ArMd,n_nr_mswn_MaMd + write(io8,'(''Duplicates Ac '',2(1x,i7),8x,2(1x,i7))') + $ n_nr_mswn_MdAc,n_nr_mswn_AcAc,n_nr_mswn_ArAc,n_nr_mswn_MaAc + write(io8,'(''Duplicates Am '',5(1x,i7))') + $ n_nr_mswn_MdAm,n_nr_mswn_AcAm,n_nr_mswn_AmAm,n_nr_mswn_ArAm + $, n_nr_mswn_MaAm + write(io8,'(''Duplicates Ar '',(1x,i7),8x,4(1x,i7))') + $ n_nr_mswn_MdAr,n_nr_mswn_AmAr,n_nr_mswn_ArAr,n_nr_mswn_MaAr + write(io8,'(''Duplicates Ma '',(1x,i7),16x,3(1x,i7))') + $ n_nr_mswn_MdMa,n_nr_mswn_ArMa,n_nr_mswn_MaMa + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,*) + write(io8,*) ' Near dups with zero winds: ',n_near_0ws + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Duplicates Md '',(1x,i7),16x,2(1x,i7))') + $ n_near_0ws_MdMd,n_near_0ws_ArMd,n_near_0ws_MaMd + write(io8,'(''Duplicates Am '',16x,3(1x,i7))') + $ n_near_0ws_AmAm,n_near_0ws_ArAm,n_near_0ws_MaAm + write(io8,'(''Duplicates Ar '',16x,3(1x,i7))') + $ n_near_0ws_AmAr,n_near_0ws_ArAr,n_near_0ws_MaAr + write(io8,'(''Duplicates Ma '',32x,(1x,i7))') + $ n_near_0ws_MaMa + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,*) + write(io8,*) ' Other near duplicates:' + write(io8,*) ' Neg AMDAR/pos AIREP altitude: ',n_near_negpos + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Duplicates Md '',2(1x,i7),8x,2(1x,i7))') + $ n_near_MdMd,n_near_MdAc,n_near_MdAr,n_near_MdMa + write(io8,'(''Duplicates Ac '',8x,(1x,i7),8x,2(1x,i7))') + $ n_near_AcAc,n_near_AcAr,n_near_AcMa + write(io8,'(''Duplicates Am '',16x,4(1x,i7))') + $ n_near_AmAm,n_near_AmAr,n_near_AmMa + write(io8,'(''Duplicates Ar '',24x,3(1x,i7))') + $ n_near_ArAr,n_near_ArMa + write(io8,'(''Duplicates Ma '',32x,2(1x,i7))') + $ n_near_MaMa + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + write(io8,*) + write(io8,*) 'Near duplicates with low windspeeds: ' + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Duplicates Md '',2(1x,i7),8x,2(1x,i7))') + $ n_slow_MdMd,n_slow_MdAc,n_slow_MdAr + write(io8,'(''Duplicates Ac '',8x,(1x,i7),8x,2(1x,i7))') + $ n_slow_AcAc,n_slow_AcAr + write(io8,'(''Duplicates Am '',16x,4(1x,i7))') + $ n_slow_AmAm,n_slow_AmAr + write(io8,'(''Duplicates Ar '',24x,3(1x,i7))') + $ n_slow_ArAr,n_slow_ArMa + write(io8,'(''Duplicates Ma '',32x,2(1x,i7))') + $ n_slow_MaMa + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + write(io8,*) + write(io8,*) 'Near duplicates with bad roll angle qc flags: ' + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Duplicates Md '',(1x,i7))') + $ n_nr_bad_roll_Md + write(io8,'(''Duplicates Am '',16x,(1x,i7))') + $ n_nr_bad_roll_Am + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + write(io8,*) + write(io8,*) 'Near duplicates with position reports: ' + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Duplicates Md '',2(1x,i7),8x,2(1x,i7))') + $ n_nr_posrep + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + return + + 99 continue + print *, '--------------------------------------------------' + print *, '~~~> SUBR. DUPCHEK_QC (transferred here from subr. ', + $ 'do_reg): RETURN 1' + print *, '--------------------------------------------------' + return 1 + + end +c +c ################################################################### +c subroutine reorder +c ################################################################### +c + subroutine reorder(l_flight,numreps,max_reps,indx,krej,in_bad + $, io8,l_print,cregmiss,csort,c_acftid,itype + $, kflight,maxflt,cid_flt,creg_flt,nobs_flt,ntot_flt + $, nrej_flt,iobs_flt,cid_flt_old,ntot_flt_old,nrej_flt_old + $, kreg,creg_reg,nobs_reg,nrej_reg,c_acftreg,l_newflt) +c +c Re-order index array to skip bad reports +c +c modified by p.m.pauley (3/2/01) to save extra ids not previously catalogued +c (needed for 2nd flights found in ordchek) +c + implicit none +c +c Declaration statements +c ---------------------- + integer max_reps ! max number of observations/reports +c +c Data arrays +c ----------- + integer numreps ! actual number of reports + integer itype(max_reps) ! instrument type + $, ktype ! pointer for instrument type + character*9 c_acftid(max_reps) ! acft flight number + character*8 c_acftreg(max_reps) ! aircraft registration (tail) number + character*25 csort(max_reps) ! variable used for sorting data +c +c Arrays for mixed duplicates +c --------------------------- + integer maxflt ! max number of flights allowed + $, kflight ! number of flights in dataset + character*6 cmaxflt ! character form of maxflt for NCEP print statement + character*8 creg_flt(maxflt) ! tail number for each flight + character*9 cid_flt(maxflt) ! flight id for each flight + character*9 cid_flt_old(maxflt) ! old value of flight id for each flight + integer nobs_flt(maxflt) ! number of reports per flight + $, ntot_flt(maxflt) ! previous value of total number of reports per flight + $, ntot_flt_old(maxflt)! previous value of total number of reports per flight + $, nrej_flt(maxflt) ! number of reports rejected per flight + $, nrej_flt_old(maxflt)! old value of number of reports rejected per flight + $, iobs_flt(maxflt) ! index for first report in each flight +c + logical l_newflt(maxflt) ! true if flight is new flight +c +c Tail number variables +c --------------------- + integer kreg ! number of tail numbers in dataset + character*8 creg_reg(maxflt) ! tail numbers + character*8 cregmiss ! missing value for tail number + integer nobs_reg(maxflt,5) ! # of reports / flight / type + integer nrej_reg(maxflt,5) ! # of reports rejected / flight / type + $, kk,mm ! index pointing to current tail number +c +c Pointers +c -------- + integer indx(max_reps) ! pointer index for reports + $, in_bad(max_reps) ! pointer index for bad reports +c +c Functions +c --------- + integer insty_ob_fun ! function to convert character +c +c Other variables +c --------------- + integer io8 ! i/o unit number for log file + integer iob,job ! do loop index + $, ii,jj ! index pointing to current report + $, iim1,jjm1 ! index pointing to previous report + integer keep ! counter for number of reports kept + $, krej ! counter for number of reports rejected + integer kbad(5) ! counter for number of bad reports + $, kgood(5) ! counter for number of good reports + $, kper(5) ! percentage of bad reports (out of # of good) + $, k_yairep ! number of YRXX86 AIREPs rejected + real percent ! percentage of rejected reports +c +ccccdak integer i_acars ! instrument type for acars + integer i_acars ! instrument type for tamdar +ccccdak $, i_acars_lvl ! instrument type for acars--level flt + $, i_acars_lvl ! instrument type for tamdar--level flt +ccccdak $, i_acars_asc ! instrument type for acars--ascent + $, i_acars_asc ! instrument type for tamdar--ascent +ccccdak $, i_acars_des ! instrument type for acars--descent + $, i_acars_des ! instrument type for tamdar--descent + $, i_mdcrs ! instrument type for mdcrs + $, i_mdcrs_lvl ! instrument type for mdcrs--level flt + $, i_mdcrs_asc ! instrument type for mdcrs--ascent + $, i_mdcrs_des ! instrument type for mdcrs--descent + $, i_man_airep ! instrument type for manual aireps + $, i_man_Yairep ! instrument type for manual aireps (YRXX) + $, i_airep ! instrument type for airep + $, i_airep_lvl ! instrument type for airep--level flt + $, i_airep_asc ! instrument type for airep--ascent + $, i_airep_des ! instrument type for airep--descent + $, i_amdar ! instrument type for amdar + $, i_amdar_lvl ! instrument type for amdar--level flt + $, i_amdar_asc ! instrument type for amdar--ascent + $, i_amdar_des ! instrument type for amdar--descent + $, ifirst1 ! indicator - 1st time in subr. maxflt @ ipt 1 exceeded + $, ifirst2 ! indicator - 1st time in subr. maxflt @ ipt 2 exceeded + $, ifirst3 ! indicator - 1st time in subr. maxflt @ ipt 3 exceeded +c +ccccdak save i_acars ! instrument type for acars + save i_acars ! instrument type for tamdar +ccccdak $, i_acars_lvl ! instrument type for acars--level flt + $, i_acars_lvl ! instrument type for tamdar--level flt +ccccdak $, i_acars_asc ! instrument type for acars--ascent + $, i_acars_asc ! instrument type for tamdar--ascent +ccccdak $, i_acars_des ! instrument type for acars--descent + $, i_acars_des ! instrument type for tamdar--descent + $, i_mdcrs ! instrument type for mdcrs + $, i_mdcrs_lvl ! instrument type for mdcrs--level flt + $, i_mdcrs_asc ! instrument type for mdcrs--ascent + $, i_mdcrs_des ! instrument type for mdcrs--descent + $, i_man_airep ! instrument type for manual aireps + $, i_man_Yairep ! instrument type for manual aireps (YRXX) + $, i_airep ! instrument type for airep + $, i_airep_lvl ! instrument type for airep--level flt + $, i_airep_asc ! instrument type for airep--ascent + $, i_airep_des ! instrument type for airep--descent + $, i_amdar ! instrument type for amdar + $, i_amdar_lvl ! instrument type for amdar--level flt + $, i_amdar_asc ! instrument type for amdar--ascent + $, i_amdar_des ! instrument type for amdar--descent + $, ifirst1 ! indicator - 1st time in subr. maxflt @ ipt 1 exceeded + $, ifirst2 ! indicator - 1st time in subr. maxflt @ ipt 2 exceeded + $, ifirst3 ! indicator - 1st time in subr. maxflt @ ipt 3 exceeded +c +c Switches +c -------- + logical l_flight ! true if flight stats to be updated + $, l_print ! true if flight stats to be printed + $, l_first ! true first time subroutine is called + $, l_done ! true if finished +c +c Data statements +c --------------- + data l_first /.true./,ifirst1/0/,ifirst2/0/,ifirst3/0/ +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c +c Initialize aircraft data types +c ------------------------------ + if(l_first) then + i_acars = insty_ob_fun('acars') + i_acars_lvl = insty_ob_fun('acars_lvl') + i_acars_asc = insty_ob_fun('acars_asc') + i_acars_des = insty_ob_fun('acars_des') + i_mdcrs = insty_ob_fun('mdcrs') + i_mdcrs_lvl = insty_ob_fun('mdcrs_lvl') + i_mdcrs_asc = insty_ob_fun('mdcrs_asc') + i_mdcrs_des = insty_ob_fun('mdcrs_des') + i_man_airep = insty_ob_fun('man-airep') + i_man_Yairep = insty_ob_fun('man-Yairep') + i_airep = insty_ob_fun('airep') + i_airep_lvl = insty_ob_fun('airep_lvl') + i_airep_asc = insty_ob_fun('airep_asc') + i_airep_des = insty_ob_fun('airep_des') + i_amdar = insty_ob_fun('amdar') + i_amdar_lvl = insty_ob_fun('amdar_lvl') + i_amdar_asc = insty_ob_fun('amdar_asc') + i_amdar_des = insty_ob_fun('amdar_des') +c + l_first = .false. + endif +c +c Initialize counters +c ------------------- + k_yairep = 0 +c + kbad = 0 + kgood = 0 +c + keep = 0 +c + l_newflt = .false. + nrej_reg = 0 +c + kk = 1 + mm = 1 +c +c Loop over obs +c ------------- + do iob = 1,numreps + ii = indx(iob) +c +c If report rejected... +c --------------------- + if(csort(ii)(1:5).eq.'badob') then +c + krej = krej+1 + in_bad(krej) = indx(iob) +c + csort(ii)(1:25) = 'zzzzzzzzzzzzzzzzzzzzzzzzz' +c + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_des) then + kbad(1) = kbad(1) + 1 + ktype = 1 +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_des) then + kbad(2) = kbad(2) + 1 + ktype = 2 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_des) then + kbad(3) = kbad(3) + 1 + ktype = 3 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_des) then + kbad(4) = kbad(4) + 1 + ktype = 4 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + kbad(5) = kbad(5) + 1 + ktype = 5 +c + if(itype(ii).eq.i_man_Yairep) + $ k_yairep = k_yairep + 1 +c + else + write(io8,*) + write(io8,*) 'Bad itype: ',itype(ii),' for ii = ',ii + endif +c +c Count rej reps by tail number/flight number, if desired +c ------------------------------------------------------- + if(l_flight) then +c +c Increment number of reports rejected per flight +c ----------------------------------------------- + 11 if(c_acftid(ii).eq.cid_flt(mm)) then + nrej_flt(mm) = nrej_flt(mm) + 1 + if(l_newflt(mm)) then + mm = 1 + endif +c + else + mm = mm + 1 + if(mm.le.kflight) then + goto 11 +c + else + if(kflight.ne.maxflt) then + kflight = kflight + 1 + else +c----------------------------------- + if(ifirst1.eq.0) then + ifirst1 = 1 + write(io8,*) + write(io8,*) 'WARNING-1: Need to increase maxflt!' + print 53, maxflt,maxflt + 53 format(/' #####> WARNING: THERE ARE MORE THAN ',I6,' AIRCRAFT ', + + '"FLIGHTS" IN INPUT FILE -- MUST INCREASE SIZE OF PARAMETER ', + +'NAME "MAXFLT" - WILL CONTINUE ON PROCESSING ONLY ',I6,' FLTS-1'/) + write(cmaxflt,'(i6)') maxflt + call system('[ -n "$jlogfile" ] && $DATA/postmsg'// + + ' "$jlogfile" "***WARNING:'//cmaxflt//' AIRCRAFT "FLIGHT" '// + + 'LIMIT EXCEEDED IN PREPOBS_PREPACQC, ONLY '// + + cmaxflt//' FLIGHTS PROCESSED-1"') + endif +c----------------------------------- + endif + cid_flt(kflight) = c_acftid(ii) + creg_flt(kflight) = c_acftreg(ii) + iobs_flt(kflight) = iob + ntot_flt(kflight) = 0 + nrej_flt(kflight) = 1 + l_newflt(kflight) = .true. + mm = 1 +c +c Search backwards for first ob from new flight +c --------------------------------------------- + job = iob + if(job.ne.1) then +12 jjm1 = indx(job-1) + if(c_acftid(jjm1)(1:9).eq.cid_flt(kflight)(1:9)) then + job = job-1 + if(job.ne.1) goto 12 + endif + endif +c +c Count total number of obs from new flight +c ----------------------------------------- + do while(job.le.numreps) + jj = indx(job) + if(c_acftid(jj)(1:9).eq.cid_flt(kflight)(1:9)) then + ntot_flt(kflight) = ntot_flt(kflight) + 1 + job = job + 1 + else + job = numreps + 1 + endif + enddo +c + nobs_flt(kflight) = ntot_flt(kflight) +c + endif + endif +c +c Skip blank tail numbers +c ----------------------- + if(c_acftreg(ii).ne.' ') then +c +c If tail numbers are equal, increment counters +c --------------------------------------------- + if(c_acftreg(ii).eq.creg_reg(kk)) then + nrej_reg(kk,ktype) = nrej_reg(kk,ktype) + 1 +c +c Otherwise, loop to find matching tail number +c -------------------------------------------- + else + kk = 1 + l_done = .false. + do while (.not.l_done) + if(c_acftreg(ii).eq.creg_reg(kk)) then + nrej_reg(kk,ktype) = nrej_reg(kk,ktype) + 1 + l_done = .true. + else + kk = kk + 1 + if(kk.eq.kreg+1) then + write(io8,*) + write(io8,*) 'Tail# not found--',c_acftreg(ii),ii + l_done = .true. + endif + endif + enddo + endif + endif + endif +c +c If report not rejected... +c ------------------------- + else + keep = keep + 1 +c + indx(keep) = indx(iob) +c + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_des) then + kgood(1) = kgood(1) + 1 +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_des) then + kgood(2) = kgood(2) + 1 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_des) then + kgood(3) = kgood(3) + 1 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_des) then + kgood(4) = kgood(4) + 1 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + kgood(5) = kgood(5) + 1 +c + else + write(io8,*) + write(io8,*) 'Bad itype: ',itype(ii),' for ii = ',ii + endif + endif + enddo +c +c Save number of good reports +c --------------------------- + numreps = keep +c +c Update flight stats if desired +c ------------------------------ + if(l_flight) then +c +c Initialize variables +c -------------------- + cid_flt_old = cid_flt ! DAK: has cid_flt been initialized at this point? + ntot_flt_old = ntot_flt ! DAK: has ntot_flt been initialized at this point? + nrej_flt_old = nrej_flt ! DAK: has nrej_flt been initialized at this point? + iobs_flt = 0 + nobs_flt = 0 + ntot_flt = 0 + nrej_flt = 0 + cid_flt = ' ' + creg_flt = ' ' + l_newflt = .false. +c +c + mm = 1 +c +c Begin loop over reports +c ----------------------- + do iob = 1,numreps + ii = indx(iob) + if(iob.eq.1) then + iim1 = 0 + else + iim1 = indx(iob-1) + endif +c +c Initialize variables for iob = 1 +c -------------------------------- + if(iob.eq.1) then + kk = 1 + iobs_flt(1) = 1 + nobs_flt(1) = 1 + cid_flt(1) = c_acftid(ii) + creg_flt(1) = c_acftreg(ii) +c + 101 if(cid_flt(1).eq.cid_flt_old(mm)) then + ntot_flt(1) = ntot_flt_old(mm) + nrej_flt(1) = nrej_flt_old(mm) + + else + mm = mm + 1 + if(mm.le.kflight) then + goto 101 + + else + write(io8,*) + write(io8,*) 'flight id #1 not found--',c_acftid(ii) +c +c ntot_flt(1) = nobs_flt(1) + cid_flt(1) = c_acftid(ii) + creg_flt(1) = c_acftreg(ii) + iobs_flt(1) = iob + nobs_flt(1) = 1 + ntot_flt(1) = 1 + nrej_flt(1) = 0 + l_newflt(1) = .true. + mm = 1 + endif + endif +c +c If flight numbers are equal, increment counter +c ---------------------------------------------- + elseif(c_acftid(iim1).eq.c_acftid(ii)) then + nobs_flt(kk) = nobs_flt(kk) + 1 + if(l_newflt(kk)) then + mm = 1 + endif + if(c_acftreg(ii).ne.cregmiss.and.creg_flt(kk).eq.cregmiss) + $ creg_flt(kk) = c_acftreg(ii) +c +c Otherwise, save starting index & start counting reports for next flight +c ------------------------------------------------------------------------- + else + if(kk.ne.maxflt) then + kk = kk + 1 + else +c----------------------------------- + if(ifirst2.eq.0) then + write(io8,*) + write(io8,*) 'WARNING-2: Need to increase maxflt!' + ifirst2 = 1 + print 753, maxflt,maxflt + 753 format(/' #####> WARNING: THERE ARE MORE THAN ',I6,' AIRCRAFT ', + + '"FLIGHTS" IN INPUT FILE -- MUST INCREASE SIZE OF PARAMETER ', + +'NAME "MAXFLT" - WILL CONTINUE ON PROCESSING ONLY ',I6,' FLTS-2'/) + write(cmaxflt,'(i6)') maxflt + call system('[ -n "$jlogfile" ] && $DATA/postmsg'// + + ' "$jlogfile" "***WARNING:'//cmaxflt//' AIRCRAFT "FLIGHT" '// + + 'LIMIT EXCEEDED IN PREPOBS_PREPACQC, ONLY '// + + cmaxflt//' FLIGHTS PROCESSED-2"') + endif +c----------------------------------- + endif + iobs_flt(kk) = iob + nobs_flt(kk) = 1 + cid_flt(kk) = c_acftid(ii) + creg_flt(kk) = c_acftreg(ii) +c + 201 if(cid_flt(kk).eq.cid_flt_old(mm)) then + ntot_flt(kk) = ntot_flt_old(mm) + nrej_flt(kk) = nrej_flt_old(mm) + mm = 1 +c + else + mm = mm + 1 + if(mm.le.kflight) then + goto 201 +c + else + if(kk.ne.maxflt) then + kk = kk + 1 + else +c----------------------------------- + if(ifirst3.eq.0) then + write(io8,*) + write(io8,*) 'WARNING-3: Need to increase maxflt!' + ifirst3 = 1 + print 853, maxflt,maxflt + 853 format(/' #####> WARNING: THERE ARE MORE THAN ',I6,' AIRCRAFT ', + + '"FLIGHTS" IN INPUT FILE -- MUST INCREASE SIZE OF PARAMETER ', + +'NAME "MAXFLT" - WILL CONTINUE ON PROCESSING ONLY ',I6,' FLTS-3'/) + write(cmaxflt,'(i6)') maxflt + call system('[ -n "$jlogfile" ] && $DATA/postmsg'// + + ' "$jlogfile" "***WARNING:'//cmaxflt//' AIRCRAFT "FLIGHT" '// + + 'LIMIT EXCEEDED IN PREPOBS_PREPACQC, ONLY '// + + cmaxflt//' FLIGHTS PROCESSED-3"') + endif +c----------------------------------- + endif + cid_flt(kk) = c_acftid(ii) + creg_flt(kk) = c_acftreg(ii) + iobs_flt(kk) = iob + ntot_flt(kk) = 0 + nrej_flt(kk) = 1 + l_newflt(kk) = .true. + mm = 1 +c +c Count total number of obs from new flight +c ----------------------------------------- + job = iob + do while(job.le.numreps) + jj = indx(job) + if(c_acftid(jj)(1:9).eq.cid_flt(kk)(1:9)) then + ntot_flt(kk) = ntot_flt(kk) + 1 + job = job + 1 + else + job = numreps + 1 + endif + enddo +c + nobs_flt(kk) = ntot_flt(kk) +c + endif + endif + endif + enddo + endif +c +c if(kflight.ne.kk) then +c write(io8,*) +c write(io8,*) 'Mismatch in numbers of flights' +c write(io8,*) ' kk = ',kk +c write(io8,*) ' kflight = ',kflight +c endif +c + kflight = kk +c +c Output number of reports retained/skipped +c ----------------------------------------- + if(kgood(1).eq.0)then + kper(1) = 0 + else + kper(1) = kbad(1) * 100 / (kgood(1)+kbad(1)) + endif +c + if(kgood(2).eq.0)then + kper(2) = 0 + else + kper(2) = kbad(2) * 100 / (kgood(2)+kbad(2)) + endif +c + if(kgood(3).eq.0)then + kper(3) = 0 + else + kper(3) = kbad(3) * 100 / (kgood(3)+kbad(3)) + endif +c + if(kgood(4).eq.0)then + kper(4) = 0 + else + kper(4) = kbad(4) * 100 / (kgood(4)+kbad(4)) + endif +c + if(kgood(5).eq.0)then + kper(5) = 0 + else + kper(5) = kbad(5) * 100 / (kgood(5)+kbad(5)) + endif +c + write(io8,*) + write(io8,*) ' Re-ordering index array' + write(io8,*) ' -----------------------' + write(io8,*) numreps,' reports retained' + write(io8,*) kbad(1),' MDCRS reports skipped leaving ',kgood(1) + $ ,'--',kper(1),'%' +ccccdak write(io8,*) kbad(2),' ACARS reports skipped leaving ',kgood(2) + write(io8,*) kbad(2),' TAMDAR rpts skipped leaving ',kgood(2) + $ ,'--',kper(2),'%' + write(io8,*) kbad(3),' AMDAR reports skipped leaving ',kgood(3) + $ ,'--',kper(3),'%' + write(io8,*) kbad(4),' AIREP reports skipped leaving ',kgood(4) + $ ,'--',kper(4),'%' + write(io8,*) kbad(5),' manAIREP reports skipped leaving ',kgood(5) + $ ,'--',kper(5),'%' + write(io8,*) ' out of these, ',k_yairep,' are YRXX reports' +c +c Output indices for each flight +c ------------------------------ + if(l_print.and.l_flight) then + write(io8,*) + write(io8,*) 'Subtotals for tail#s with rejected reports' + write(io8,*) '------------------------------------------' + write(io8,'(27x,a12,22x,a8)')'Total Number','Rejected' + write(io8,'(a47,a43)') + $ ' kk tail num #Md #Ac #Am #Ar #Ma', + $ ' #Md #Ac #Am #Ar #Ma % ' + write(io8,'(1x,a47,a43)') + $ '----- -------- ------ ------ ------ ------ ----', + $ '-- ------ ------ ------ ------ ------ -----' +c + do kk=1,kreg + + if((nobs_reg(kk,1)+nobs_reg(kk,2)+ + $ nobs_reg(kk,3)+nobs_reg(kk,4)+ + $ nobs_reg(kk,5)).ne.0) then +c + percent = (nrej_reg(kk,1) + nrej_reg(kk,2) + $ + nrej_reg(kk,3) + nrej_reg(kk,4) + $ + nrej_reg(kk,5)) * 100.0 + $ / (nobs_reg(kk,1) + nobs_reg(kk,2) + $ + nobs_reg(kk,3) + nobs_reg(kk,4) + $ + nobs_reg(kk,5)) + else + percent = -9999.0 + endif +c + write(io8,'(i5,1x,a8,10(1x,i6),f6.1)') kk,creg_reg(kk) + $, nobs_reg(kk,1),nobs_reg(kk,2) + $, nobs_reg(kk,3),nobs_reg(kk,4) + $, nobs_reg(kk,5) + $, nrej_reg(kk,1),nrej_reg(kk,2) + $, nrej_reg(kk,3),nrej_reg(kk,4) + $, nrej_reg(kk,5),percent + enddo + endif +c + return + end +c +c ################################################################### +c subroutine do_flt +c ################################################################### +c + subroutine do_flt(l_first,numreps,max_reps,c_acftid,c_acftreg,idt, + $ ht_ft,cidmiss,cregmiss,indx,idt_samflt, + $ kflight,maxflt,cid_flt,creg_flt,nobs_flt,ntot_flt, + $ nrej_flt,iobs_flt,csort,l_sort,l_print,amiss,io8,*) +c +c Determine starting index for each flight and number of reports per flight +c +c modified by p.pauley (4/1/01) to allow a shorter time gap between flight +c segments if a low altitude is found on either +c side of the time gap +c +c modified by p.pauley (11/1/01) to use both upper and lower case letters +c for the 9th character in the flight id. +c Required to deal with the large number of +c aircraft using flight id VYXAUSJA beginning +c in late October 2001. +c + implicit none +c +c Declaration statements +c ---------------------- + integer max_reps ! max number of observations/reports +c +c Data arrays +c ----------- + integer numreps ! actual number of reports + character*9 c_acftid(max_reps) ! acft flight number + character*8 c_acftreg(max_reps) ! acft registration (tail) number + integer idt(max_reps) ! time in seconds to analysis time + real ht_ft(max_reps) ! height in feet + character*25 csort(max_reps) ! variable used for sorting data +c +c Arrays for mixed duplicates +c --------------------------- + integer maxflt ! max number of flights allowed + $, kflight ! number of flights in dataset + character*8 creg_flt(maxflt) ! tail number for each flight + character*9 cid_flt(maxflt) ! flight id for each flight + integer nobs_flt(maxflt) ! number of reports per flight + $, ntot_flt(maxflt) ! total number of reports per flight + $, nrej_flt(maxflt) ! number of reports rejected per flight + $, iobs_flt(maxflt) ! index for first report in each flight +c +c Pointers +c -------- + integer indx(max_reps) ! pointer index for reports +c +c Other variables +c --------------- + integer io8 ! i/o unit number for log file + integer ii ! index for current ob + $, iim1 ! index for previous ob + $, iob ! do loop index--over reports + $, kk ! do loop index--over flights + integer nave ! average number of reports per flight + $, nmiss ! number of reps with missing flight id + $, idt_samflt ! time difference allowed for same flight + $, idt_dif ! actual time difference + integer istart ! first report in flight + $, iistart ! index for first report in flight + $, iend ! last report in flight + $, iiend ! index for last report in flight + integer k_abc ! pointer for c_abc + integer knt ! counter used in defining iim1 +c + real amiss ! real missing value flag +c + character*1 c_abc(62) ! array of lower-case and upper-case letters + character*8 cregmiss ! missing value flag for tail number + $, cidmiss ! missing value flag for flight number +c +c Switches +c -------- + logical l_first ! true first time subroutine is called + $, l_print ! true for printing values + $, l_sort ! true if data need to be sorted + $, l_same ! true if tail numbers are same + $, l_newid ! true if letter to be appended to flight id +c +c Data statements +c --------------- + data c_abc/'a','b','c','d','e','f','g','h','i','j','k','l','m', + $ 'n','o','p','q','r','s','t','u','v','w','x','y','z', + $ 'A','B','C','D','E','F','G','H','I','J','K','L','M', + $ 'N','O','P','Q','R','S','T','U','V','W','X','Y','Z', + $ '0','1','2','3','4','5','6','7','8','9'/ +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c +c Initialize variables +c -------------------- + l_sort = .false. +c + kflight = 0 + iobs_flt = 0 + nobs_flt = 0 + ntot_flt = 0 + nrej_flt = 0 + cid_flt = ' ' + creg_flt = ' ' +c +c Begin loop over reports +c ----------------------- + do iob = 1,numreps + ii = indx(iob) + if(iob.eq.1) then + iim1 = 0 + else + iim1 = indx(iob-1) + endif +c +c Initialize variables for iob = 1 +c -------------------------------- + if(iob.eq.1) then + kflight = 1 + iobs_flt(1) = 1 + nobs_flt(1) = 1 + ntot_flt(1) = 1 + cid_flt(1) = c_acftid(ii) + creg_flt(1) = c_acftreg(ii) + nmiss = 1 +c +c If flight numbers are equal, increment counter +c ---------------------------------------------- + elseif(c_acftid(iim1)(1:9).eq.c_acftid(ii)(1:9)) then + nobs_flt(kflight) = nobs_flt(kflight) + 1 + ntot_flt(kflight) = ntot_flt(kflight) + 1 + if(c_acftid(ii)(1:8).eq.cidmiss(1:8)) + $ nmiss = nmiss + 1 + if(c_acftreg(ii).ne.cregmiss.and. + $ creg_flt(kflight).eq.cregmiss) + $ creg_flt(kflight) = c_acftreg(ii) +c +c Otherwise, save starting index and start counting reports for next flight +c ------------------------------------------------------------------------- + else + kflight = kflight + 1 +c----------------------------------- +c Check index against maximum +c --------------------------- + if(kflight.gt.maxflt) then + kflight = kflight - 1 + write(io8,*) + write(io8,*) 'Subr. DO_FLT, ipoint 1: Max number of ', + $ 'flights exceeded--increase maxflt' + return 1 + endif +c----------------------------------- + cid_flt(kflight) = c_acftid(ii) + creg_flt(kflight) = c_acftreg(ii) + iobs_flt(kflight) = iob + nobs_flt(kflight) = 1 + ntot_flt(kflight) = 1 + endif + enddo +c +c Check for flights with same flight # (but different tail #s) +c (do this only the first time the subroutine is called) +c ------------------------------------------------------------ + if(l_first) then + do kk=1,kflight + istart = iobs_flt(kk) + iistart = indx(istart) + iend = iobs_flt(kk) + nobs_flt(kk) - 1 + iiend = indx(iend) + k_abc = 0 +c +c Check if tail number is constant for entire flight +c -------------------------------------------------- + l_same = .true. +c + do iob=istart+1,iend + ii = indx(iob) + if(c_acftreg(iistart).eq.cregmiss) then + istart = istart + 1 + iistart = indx(istart) + elseif(c_acftreg(ii).ne.c_acftreg(iistart).and. + $ c_acftreg(ii).ne.cregmiss) then + l_same = .false. + endif + enddo +c +c Change last char of tail # if second tail # found +c ------------------------------------------------- + if(.not.l_same) then + do iob=istart+1,iend + ii = indx(iob) + iim1 = indx(iob-1) +c +c ii report has different tail number than first report +c ----------------------------------------------------- + if(c_acftreg(ii).ne.c_acftreg(iistart)) then +c +c ii report has different tail number than ii report +c -------------------------------------------------- + if(c_acftreg(ii).ne.cregmiss.and. + $ c_acftreg(ii).ne.c_acftreg(iim1)) then +c +c look backwards for same tail number if different ids are found +c -------------------------------------------------------------- + knt = 1 + 10 continue + if(c_acftreg(ii).ne.c_acftreg(iim1).and. + $ iob-knt.gt.istart) then + knt = knt + 1 + iim1 = indx(iob-knt) + idt_dif = abs(idt(ii) - idt(iim1)) + goto 10 + endif +c +c use new 9th char if tail number not found +c ----------------------------------------- + if(iim1.eq.iistart) then + k_abc = k_abc + 1 +c + if(k_abc.gt.62) then + write(io8,*) + write(io8,*) 'k_abc too large--too many tail#s!' + c_acftid(ii)(9:9) = '?' + csort(ii)(9:9) = '?' + else + c_acftid(ii)(9:9) = c_abc(k_abc) + csort(ii)(9:9) = c_abc(k_abc) + endif +c + l_sort = .true. +c +c use old 9th char if tail number found +c ------------------------------------- + else + c_acftid(ii)(9:9) = c_acftid(iim1)(9:9) + csort(ii)(9:9) = c_acftid(ii)(9:9) + endif +c +c subsequent reports with different tail number +c --------------------------------------------- + elseif(c_acftreg(ii).ne.cregmiss.and. + $ c_acftreg(ii).eq.c_acftreg(iim1)) then +c + c_acftid(ii)(9:9) = c_acftid(iim1)(9:9) + csort(ii)(9:9) = c_acftid(iim1)(9:9) +c +c missing value for tail number +c ----------------------------- + elseif(c_acftreg(ii).eq.cregmiss.and. + $ iob.ne.istart) then +c + if(c_acftreg(iim1).ne.cregmiss.and. + $ abs(idt(ii)-idt(iim1)).le.7200) then + c_acftreg(ii) = c_acftreg(iim1) +c +c else +c write(io8,*) +c write(io8,*) 'Missing tail number found for rep #',ii +c write(io8,*) 'Not sure which tail number to choose!' + endif + endif + endif + enddo + endif + enddo + endif +c +c Check if large time gaps exist during flight +c and identify coherent flight segments +c -------------------------------------------- + if(.not.l_sort) then +c + l_sort = .false. +c + do kk=1,kflight + istart = iobs_flt(kk) + iistart = indx(istart) + iend = iobs_flt(kk) + nobs_flt(kk) - 1 + iiend = indx(iend) + k_abc = 0 +c + l_newid = .false. +c + do iob=istart+1,iend + ii = indx(iob) + iim1 = indx(iob-1) + idt_dif = abs(idt(ii) - idt(iim1)) + knt = 1 +c +c increment abc counter and change 8th char if time threshold crossed +c and flight ids don't change +c ------------------------------------------------------------------- + if(c_acftid(ii)(1:9).eq.c_acftid(iim1)(1:9).and. + $ (idt_dif.gt.idt_samflt.or. + $ (idt_dif.gt.idt_samflt/6.and. + $ ht_ft(ii).ne.amiss.and. + $ ht_ft(iim1).ne.amiss.and. + $ (ht_ft(ii).lt.5001..or.ht_ft(iim1).lt.5001.)))) then +c + l_newid = .true. + l_sort = .true. + k_abc = k_abc + 1 + if(c_abc(k_abc).eq.c_acftid(ii)(8:8)) k_abc = k_abc + 1 +c + if(k_abc.gt.10) then + write(io8,*) + write(io8,*) 'Large value: k_abc = ',k_abc + write(io8,*) ' ids = ',c_acftreg(ii),' ',c_acftid(ii) + endif +c + if(k_abc.gt.62) then + write(io8,*) + write(io8,*) 'k_abc too large!' + c_acftid(ii)(8:8) = '?' + csort(ii)(8:8) = '?' + else + c_acftid(ii)(8:8) = c_abc(k_abc) + csort(ii)(8:8) = c_acftid(ii)(8:8) + endif +c +c Check if flight numbers and tail numbers are the same, +c the time difference is small, and a new id is in use. +c Change flight id if so. +c ------------------------------------------------------- + elseif(c_acftid(ii)(1:7).eq.c_acftid(iim1)(1:7).and. + $ c_acftreg(ii)(1:8).eq.c_acftreg(iim1)(1:8).and. + $ idt_dif.le.idt_samflt.and. + $ l_newid) then +c + c_acftid(ii)(8:8) = c_acftid(iim1)(8:8) + csort(ii)(8:8) = c_acftid(ii)(8:8) + endif + enddo +c + enddo +c +c Re-do flight limits if time gaps found +c -------------------------------------- + if(l_sort) then + kflight = 0 + iobs_flt = 0 + nobs_flt = 0 + ntot_flt = 0 + nrej_flt = 0 + cid_flt = ' ' + creg_flt = ' ' +c + do iob = 1,numreps + ii = indx(iob) + if(iob.eq.1) then + iim1 = 0 + else + iim1 = indx(iob-1) + endif +c +c Initialize variables for iob = 1 +c -------------------------------- + if(iob.eq.1) then + kflight = 1 + iobs_flt(1) = 1 + nobs_flt(1) = 1 + ntot_flt(1) = 1 + cid_flt(1) = c_acftid(ii) + creg_flt(1) = c_acftreg(ii) + nmiss = 1 +c +c If flight numbers are equal, increment counter +c ---------------------------------------------- + elseif(c_acftid(iim1)(1:9).eq.c_acftid(ii)(1:9)) then + nobs_flt(kflight) = nobs_flt(kflight) + 1 + ntot_flt(kflight) = ntot_flt(kflight) + 1 + if(c_acftid(ii)(1:8).eq.cidmiss(1:8)) + $ nmiss = nmiss + 1 + if(c_acftreg(ii).ne.cregmiss.and. + $ creg_flt(kflight).eq.cregmiss) + $ creg_flt(kflight) = c_acftreg(ii) +c +c Otherwise, save starting index and start counting reports for next flight +c ------------------------------------------------------------------------- + else + kflight = kflight + 1 +c----------------------------------- +c Check index against maximum +c --------------------------- + if(kflight.gt.maxflt) then + kflight = kflight - 1 + write(io8,*) + write(io8,*) 'Subr. DO_FLT, ipoint 2: Max number of ', + $ 'flights exceeded--increase maxflt' + return 1 + endif +c----------------------------------- + cid_flt(kflight) = c_acftid(ii) + creg_flt(kflight) = c_acftreg(ii) + iobs_flt(kflight) = iob + nobs_flt(kflight) = 1 + ntot_flt(kflight) = 1 + endif + enddo + endif + endif +c +c Output basic stats +c ------------------ + nave = (numreps-nmiss) / (kflight-1) + write(io8,*) + write(io8,*) kflight,' different flights found' + write(io8,*) nave,' reports per flight, on average' +c +c Output indices for each flight +c ------------------------------ + if(l_print.and.((.not.l_sort.and.l_first).or..not.l_first)) then + write(io8,*) + write(io8,*) 'Indices for individual flights' + write(io8,*) '------------------------------' + write(io8,*) ' kk flight id istrt indx iend indx nobs' +c + do kk=1,kflight + istart = iobs_flt(kk) + iend = iobs_flt(kk) + nobs_flt(kk) - 1 + ii = indx(istart) + if(ii.eq.0) then + write(io8,*) + write(io8,*) 'ii = 0 in do_flt output section' + endif + write(io8,'(i5,1x,a9,5(1x,i5))') kk,c_acftid(ii),istart, + $ indx(istart),iend,indx(iend),nobs_flt(kk) + enddo + endif +c + return + end +c +c ################################################################### +c subroutine do_reg +c ################################################################### +c + subroutine do_reg(l_print,io8, + $ max_reps,numreps,itype,c_qc,c_acftreg,indx, + $ maxflt,kreg,creg_reg,nobs_reg,*) +c +c Count number of obs per tail (registration) number +c + implicit none +c +c Observation variables +c --------------------- + integer max_reps ! maximum number of reports allowed + integer numreps ! actual number of reports + $, itype(max_reps) ! observation type + character*11 c_qc(max_reps) ! qc flags + character*8 c_acftreg(max_reps) ! aircraft registration (tail) number + integer indx(max_reps) ! pointer index for reports + integer iob ! do loop index--over reports + integer ii ! index for current ob +c $, iim1 ! index for previous ob +c +c Tail number variables +c --------------------- + integer maxflt ! max number of flights/tail numbers + integer kreg ! actual number of tail#s in dataset + character*8 creg_reg(maxflt) ! tail numbers + integer nobs_reg(maxflt,5) ! number of reports per tail# per type + integer ktot ! sum of reports categorized + $, mm ! do loop index--over tail numbers +c +c Other variables +c --------------- + integer io8 ! i/o unit number for log file +c +ccccdak integer i_acars ! instrument type for acars + integer i_acars ! instrument type for tamdar +ccccdak $, i_acars_lvl ! instrument type for acars--level flt + $, i_acars_lvl ! instrument type for tamdar--level flt +ccccdak $, i_acars_asc ! instrument type for acars--ascent + $, i_acars_asc ! instrument type for tamdar--ascent +ccccdak $, i_acars_des ! instrument type for acars--descent + $, i_acars_des ! instrument type for tamdar--descent + $, i_mdcrs ! instrument type for mdcrs + $, i_mdcrs_lvl ! instrument type for mdcrs--level flt + $, i_mdcrs_asc ! instrument type for mdcrs--ascent + $, i_mdcrs_des ! instrument type for mdcrs--descent + $, i_man_airep ! instrument type for manual aireps + $, i_man_Yairep ! instrument type for manual aireps (YRXX) + $, i_airep ! instrument type for airep + $, i_airep_lvl ! instrument type for airep--level flt + $, i_airep_asc ! instrument type for airep--ascent + $, i_airep_des ! instrument type for airep--descent + $, i_amdar ! instrument type for amdar + $, i_amdar_lvl ! instrument type for amdar--level flt + $, i_amdar_asc ! instrument type for amdar--ascent + $, i_amdar_des ! instrument type for amdar--descent +c +c Function +c -------- + integer insty_ob_fun ! function to convert character + ! instrument type to integer +c +c Switches +c -------- + logical l_print ! true for printing values + logical l_done ! true if finished +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c +c Initialize aircraft data types +c ------------------------------ + i_acars = insty_ob_fun('acars') + i_acars_lvl = insty_ob_fun('acars_lvl') + i_acars_asc = insty_ob_fun('acars_asc') + i_acars_des = insty_ob_fun('acars_des') + i_mdcrs = insty_ob_fun('mdcrs') + i_mdcrs_lvl = insty_ob_fun('mdcrs_lvl') + i_mdcrs_asc = insty_ob_fun('mdcrs_asc') + i_mdcrs_des = insty_ob_fun('mdcrs_des') + i_man_airep = insty_ob_fun('man-airep') + i_man_Yairep = insty_ob_fun('man-Yairep') + i_airep = insty_ob_fun('airep') + i_airep_lvl = insty_ob_fun('airep_lvl') + i_airep_asc = insty_ob_fun('airep_asc') + i_airep_des = insty_ob_fun('airep_des') + i_amdar = insty_ob_fun('amdar') + i_amdar_lvl = insty_ob_fun('amdar_lvl') + i_amdar_asc = insty_ob_fun('amdar_asc') + i_amdar_des = insty_ob_fun('amdar_des') +c +c Initialize variables +c -------------------- + kreg = 0 + creg_reg = 'xxxxxxxx' + nobs_reg = 0 +c +c Begin loop over reports +c ----------------------- + do iob = 1,numreps + ii = indx(iob) +c +c +c Ignore reports with blank tail number and those marked as duplicates +c -------------------------------------------------------------------- + if(c_acftreg(ii).ne.' '.and. + $ c_qc(ii)(1:1).ne.'D'.and. + $ c_qc(ii)(1:1).ne.'d') then +c +c Handle case where kreg = 0 +c -------------------------- + if(kreg.eq.0) then + kreg = 1 + mm = 1 + creg_reg(kreg) = c_acftreg(ii) + l_done = .true. +c + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des) then + nobs_reg(kreg,1) = 1 +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des) then + nobs_reg(kreg,2) = 1 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des) then + nobs_reg(kreg,3) = 1 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des) then + nobs_reg(kreg,4) = 1 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + nobs_reg(kreg,5) = 1 + endif +c +c If tail numbers are equal, increment counter +c -------------------------------------------- + elseif(c_acftreg(ii).eq.creg_reg(mm)) then +c + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des) then + nobs_reg(mm,1) = nobs_reg(mm,1) + 1 +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des) then + nobs_reg(mm,2) = nobs_reg(mm,2) + 1 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des) then + nobs_reg(mm,3) = nobs_reg(mm,3) + 1 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des) then + nobs_reg(mm,4) = nobs_reg(mm,4) + 1 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + nobs_reg(mm,5) = nobs_reg(mm,5) + 1 + endif +c +c Otherwise, loop to find matching tail number +c -------------------------------------------- + else + mm = 1 + l_done = .false. +c + do while (.not.l_done) + if(c_acftreg(ii).eq.creg_reg(mm)) then + l_done = .true. +c + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des) then + nobs_reg(mm,1) = nobs_reg(mm,1) + 1 +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des) then + nobs_reg(mm,2) = nobs_reg(mm,2) + 1 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des) then + nobs_reg(mm,3) = nobs_reg(mm,3) + 1 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des) then + nobs_reg(mm,4) = nobs_reg(mm,4) + 1 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + nobs_reg(mm,5) = nobs_reg(mm,5) + 1 + endif +c +c If tail number not found, add to end +c ------------------------------------ + else + mm = mm + 1 + if(mm.eq.kreg+1) then + kreg = kreg + 1 +c----------------------------------- +c Check index against maximum +c --------------------------- + if(kreg.gt.maxflt) then + kreg = kreg - 1 + write(io8,*) + write(io8,*) 'Subr. DO_REG: Max number of flights ', + $ 'exceeded--increase maxflt' + return 1 + endif +c----------------------------------- + creg_reg(kreg) = c_acftreg(ii) + l_done = .true. +c + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des) then + nobs_reg(mm,1) = 1 +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des) then + nobs_reg(mm,2) = 1 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des) then + nobs_reg(mm,3) = 1 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des) then + nobs_reg(mm,4) = 1 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + nobs_reg(mm,5) = 1 + endif + endif + endif + enddo +c + endif + endif + enddo +c +c Output indices for each flight +c ------------------------------ + if(l_print) then + write(io8,*) + write(io8,*) 'Indices for individual tail numbers' + write(io8,*) '-----------------------------------' +ccccdak write(io8,*) ' mm flight# #MDCRS #ACARS #AMDAR ', + write(io8,*) ' mm flight# #MDCRS #TAMDAR #AMDAR ', + $ ' #AIREP #manAIREP ' + endif +c + ktot = 0 + do mm=1,kreg +c + if(l_print) write(io8,'(i5,1x,a8,6(1x,i5))') mm,creg_reg(mm), + $ nobs_reg(mm,1),nobs_reg(mm,2),nobs_reg(mm,3), + $ nobs_reg(mm,4),nobs_reg(mm,5) +c + ktot = ktot + nobs_reg(mm,1) + nobs_reg(mm,2) + nobs_reg(mm,3) + $ + nobs_reg(mm,4) + nobs_reg(mm,5) +c + enddo +c + write(io8,*) + write(io8,*) numreps,' reports input to do_reg' + write(io8,*) ktot,' reports categorized by tail number' +c + return + end +c +c ################################################################### +c subroutine innov_qc +c ################################################################### +c + subroutine innov_qc(max_reps,numreps,indx,xiv_t,xiv_d,xiv_s,amiss, + $ c_qc,knt,io8,l_init,l_innov_miss) +c +c Compute distribution of innovations +c + implicit none +c +c Work arrays +c ----------- + integer io8 ! i/o unit number for log file + $, knt ! counter for first or second time innov_qc is called + integer ii,nn,iob ! do loop indices + integer n_xiv ! computed innovation (integer) + integer max_reps ! maximum number of observations allowed + integer numreps ! actual number of reports + real amiss ! missing value flag (real) + real xiv_t(max_reps) ! temperature innovation (ob - bk) + $, xiv_d(max_reps) ! wind direction innovation (ob - bk) + $, xiv_s(max_reps) ! wind speed innovation (ob - bk) + integer knt_t(2) ! number of non-rejected temperature innovations + $, knt_d(2) ! number of non-rejected wind direction innovations + $, knt_s(2) ! number of non-rejected wind speed innovations + integer k_t(104,2) ! distribution of temperature innovations + $, k_d(40,2) ! distribution of wind direction innovations + $, k_s(104,2) ! distribution of wind speed innovations + integer indx(max_reps) ! pointer index for reports +c + character*11 c_qc(max_reps) ! qc flags +c + logical l_init ! initialize variables if true + $, l_innov_miss ! true if all innovations missing +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c + l_innov_miss = .true. +c +c Initialize histogram arrays +c --------------------------- + if(l_init) then + k_t(:,knt) = 0 +c + k_d(:,knt) = 0 +c + k_s(:,knt) = 0 +c + knt_t(knt) = 0 + knt_d(knt) = 0 + knt_s(knt) = 0 + endif +c +c Loop over reports +c ----------------- + do iob=1,numreps + ii = indx(iob) +c + nn = nint(xiv_t(ii)) + 52 + if(nn.eq.43) then + write(io8,*) + write(io8,*) 'Temperature innovation = -9 for ii = ',ii + write(io8,*) ' xiv_t = ',xiv_t(ii) + endif +c +c Count distribution of temperature innovations +c --------------------------------------------- + if(c_qc(ii)(6:6).ne.'B'.and. + $ c_qc(ii)(6:6).ne.'E'.and. + $ c_qc(ii)(6:6).ne.'I'.and. + $ c_qc(ii)(6:6).ne.'K'.and. + $ c_qc(ii)(6:6).ne.'b') then +c + knt_t(knt) = knt_t(knt) + 1 + nn = nint(xiv_t(ii)) + 52 +c + if(xiv_t(ii).eq.amiss) then + k_t(104,knt) = k_t(104,knt) + 1 + elseif(xiv_t(ii).lt.-50.) then + k_t(1,knt) = k_t(1,knt) + 1 + elseif(xiv_t(ii).gt.50.) then + k_t(103,knt) = k_t(103,knt) + 1 + else + k_t(nn,knt) = k_t(nn,knt) + 1 + endif + endif +c +c Count distribution of wind direction innovations +c ------------------------------------------------ + if(c_qc(ii)(7:7).ne.'S'.and. + $ c_qc(ii)(7:7).ne.'E'.and. + $ c_qc(ii)(7:7).ne.'K'.and. + $ c_qc(ii)(7:7).ne.'B'.and. + $ c_qc(ii)(7:7).ne.'I') then +c + knt_d(knt) = knt_d(knt) + 1 + nn = nint(xiv_d(ii)/10.) + 20 +c + if(xiv_d(ii).eq.amiss) then + k_d(40,knt) = k_d(40,knt) + 1 + elseif(xiv_d(ii).lt.-180.) then + k_d(1,knt) = k_d(1,knt) + 1 + elseif(xiv_d(ii).gt.180.) then + k_d(39,knt) = k_d(39,knt) + 1 + else + k_d(nn,knt) = k_d(nn,knt) + 1 + endif + endif +c +c Count distribution of wind speed innovations +c -------------------------------------------- + if(c_qc(ii)(8:8).ne.'S'.and. + $ c_qc(ii)(8:8).ne.'E'.and. + $ c_qc(ii)(8:8).ne.'K'.and. + $ c_qc(ii)(8:8).ne.'B'.and. + $ c_qc(ii)(8:8).ne.'A'.and. + $ c_qc(ii)(8:8).ne.'I') then +c + knt_s(knt) = knt_s(knt) + 1 + nn = nint(xiv_s(ii)) + 52 +c + if(xiv_s(ii).eq.amiss) then + k_s(104,knt) = k_s(104,knt) + 1 + elseif(xiv_s(ii).lt.-50.) then + k_s(1,knt) = k_s(1,knt) + 1 + elseif(xiv_s(ii).gt.50.) then + k_s(103,knt) = k_s(103,knt) + 1 + else + k_s(nn,knt) = k_s(nn,knt) + 1 + endif + endif +c + enddo +c +c Output distribution of temperature innovations if non-missing values present +c ---------------------------------------------------------------------------- + if(knt_t(knt).gt.k_t(104,knt)) then +c + l_innov_miss = .false. +c + write(io8,*) + write(io8,*) 'Distribution of Temperature Innovations (K)' + write(io8,*) '-------------------------------------------' + if(k_t(1,knt).gt.0) write(io8,*) ' < -50 ',k_t(1,knt) +c + do nn=2,102 + n_xiv = nn - 52 + if(k_t(nn,knt).gt.0) write(io8,*) n_xiv, k_t(nn,knt) + enddo +c + if(k_t(103,knt).gt.0) write(io8,*) ' > 50 ',k_t(103,knt) + if(k_t(104,knt).gt.0) write(io8,*) ' missing',k_t(104,knt) +c + else + write(io8,*) + write(io8,*) 'All temperature innovations missing' + endif +c +c Output distribution of wind direction innovations +c ------------------------------------------------- + if(knt_d(knt).gt.k_d(40,knt)) then +c + l_innov_miss = .false. +c + write(io8,*) + write(io8,*) 'Distribution of Wind Direction Innovations' + write(io8,*) '------------------------------------------' + if(k_d(1,knt).gt.0) write(io8,*) ' < -180 ',k_d(1,knt) +c + do nn=2,38 + n_xiv = (nn - 20) * 10 + if(k_d(nn,knt).gt.0) write(io8,*) n_xiv, k_d(nn,knt) + enddo +c + if(k_d(39,knt).gt.0) write(io8,*) ' > 180 ',k_d(39,knt) + if(k_d(40,knt).gt.0) write(io8,*) ' missing',k_d(40,knt) +c + else + write(io8,*) + write(io8,*) 'All wind direction innovations missing' + endif +c +c Output distribution of wind speed innovations +c --------------------------------------------- + if(knt_s(knt).gt.k_s(104,knt)) then +c + l_innov_miss = .false. +c + write(io8,*) + write(io8,*) 'Distribution of Wind Speed Innovations (m/s)' + write(io8,*) '--------------------------------------------' + if(k_s(1,knt).gt.0) write(io8,*) ' < -50 ',k_s(1,knt) +c + do nn=2,102 + n_xiv = nn - 52 + if(k_s(nn,knt).gt.0) write(io8,*) n_xiv, k_s(nn,knt) + enddo +c + if(k_s(103,knt).gt.0) write(io8,*) ' > 50 ',k_s(103,knt) + if(k_s(104,knt).gt.0) write(io8,*) ' missing',k_s(104,knt) +c + else + write(io8,*) + write(io8,*) 'All wind speed innovations missing' + endif +c + return + end +c +c ################################################################### +c subroutine benford_qc +c ################################################################### +c + subroutine benford_qc(max_reps,numreps,indx,xiv_t,xiv_d,xiv_s, + $ amiss,c_acftreg,itype,maxflt,kreg_tot,creg_reg_tot, + $ c_qc,lead_t_tot,lead_d_tot,lead_s_tot, + $ n_xiv_t,n_xiv_d,n_xiv_s, + $ sum_xiv_t,sum_xiv_d,sum_xiv_s, + $ sumabs_xiv_t,sumabs_xiv_d,sumabs_xiv_s,knt,io8 + $, l_init,l_last) +c +c Compute leading digit distributions to compare with Benford's law +c + implicit none +c +c Work arrays +c ----------- + integer io8 ! i/o unit number for log file + integer ii,jj,mm,iob,nid ! do loop indices + integer max_reps ! maximum number of observations allowed + integer numreps ! actual number of reports + $, lead ! value of leading digit + integer indx(max_reps) ! pointer index for reports + real amiss ! missing value flag (real) + real xiv_t(max_reps) ! temperature innovation (ob - bk) + $, xiv_d(max_reps) ! wind direction innovation (ob - bk) + $, xiv_s(max_reps) ! wind speed innovation (ob - bk) + integer itype(max_reps) ! type of aircraft data + character*8 c_acftreg(max_reps) ! tail numbers +c + character*11 c_qc(max_reps) ! qc flags +c + integer maxflt ! maximum number of tail numbers + $, kreg_tot ! number of unique tail numbers + $, knt ! counter for first or second time benford is called + $, ktype ! instrument type + character*8 creg_reg_tot(maxflt) ! master list of tail numbers + integer lead_t_tot(maxflt,11,2) ! distribution of temperature innovation leading digits + $, lead_d_tot(maxflt,11,2) ! distribution of wind direction innovation leading digits + $, lead_s_tot(maxflt,11,2) ! distribution of wind speed innovation leading digits + $, lead_t_sum(11,2) ! overall distribution of temperature innovations + $, lead_d_sum(11,2) ! overall distribution of wind direction innovations + $, lead_s_sum(11,2) ! overall distribution of wind speed innovations + $, lead_t_typ(5,11,2) ! distribution of temperature innovations by instrument type + $, lead_d_typ(5,11,2) ! distribution of wind direction innovations by instrument type + $, lead_s_typ(5,11,2) ! distribution of wind speed innovations by instrument type + $, lead_t_reg(33,11,2) ! distribution of temperature innovations by tail number group + $, lead_d_reg(33,11,2) ! distribution of wind direction innovations by tail number group + $, lead_s_reg(33,11,2) ! distribution of wind speed innovations by tail number group + $, n_xiv_t(maxflt,2) ! number of temperature innovations + $, n_xiv_d(maxflt,2) ! number of wind direction innovations + $, n_xiv_s(maxflt,2) ! number of wind speed innovations + $, ntot_xiv_t(2) ! total number of temperature innovations + $, ntot_xiv_d(2) ! total number of wind direction innovations + $, ntot_xiv_s(2) ! total number of wind speed innovations + $, ntyp_xiv_t(5,2) ! number of temperature innovations by instrument type + $, ntyp_xiv_d(5,2) ! number of wind direction innovations by instrument type + $, ntyp_xiv_s(5,2) ! number of wind speed innovations by instrument type + $, ntot_t_reg(33,2) ! total number of innovations by tail number type + $, ntot_d_reg(33,2) ! total number of innovations by tail number type + $, ntot_s_reg(33,2) ! total number of innovations by tail number type + real sum_xiv_t(maxflt,2) ! sum of temperature innovations + $, sum_xiv_d(maxflt,2) ! sum of wind direction innovations + $, sum_xiv_s(maxflt,2) ! sum of wind speed innovations + $, sumabs_xiv_t(maxflt,2) ! sum of absolute value of temperature innovations + $, sumabs_xiv_d(maxflt,2) ! sum of absolute value of wind direction innovations + $, sumabs_xiv_s(maxflt,2) ! sum of absolute value of wind speed innovations + $, avg ! average innovation + $, avgabs ! absolute average innovation + $, avg_lead(11) ! average number of innovations per leading digit +c + integer insty_ob_fun ! function to convert character + ! instrument type to integer +c + character*12 c_lead ! character form of xiv + character*8 c_label(5) ! label for output + character*2 c_reg_list(33) ! Tail number ids used to summarize stats + logical l_init ! initialize variables if true + $, l_last ! true if last time subroutine is called +c +ccccdak data c_label/'MDCRS ','ACARS ','AMDAR ', + data c_label/'MDCRS ','TAMDAR ','AMDAR ', + $ 'AIREP ','manAIREP'/ +c + data c_reg_list/'AN','AR','BA','EU','IT','KL','LH','MK','NZ','QF' + $, 'SA','SK','SV' + $, '13','L3','IC','YC','0I','EI','KI','UI','2M','IR' + $, 'YR','AS','JT','AU','GU','WU','FV','QV','VV','YW'/ +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c +c Initialize leading digit arrays +c ------------------------------- + if(l_init) then + ntot_xiv_t(1) = 0 + ntot_xiv_d(1) = 0 + ntot_xiv_s(1) = 0 + ntot_xiv_t(2) = 0 + ntot_xiv_d(2) = 0 + ntot_xiv_s(2) = 0 +c + sum_xiv_t(1:kreg_tot,:) = 0.0 + sum_xiv_d(1:kreg_tot,:) = 0.0 + sum_xiv_s(1:kreg_tot,:) = 0.0 + sumabs_xiv_t(1:kreg_tot,:) = 0.0 + sumabs_xiv_d(1:kreg_tot,:) = 0.0 + sumabs_xiv_s(1:kreg_tot,:) = 0.0 + n_xiv_t(1:kreg_tot,:) = 0 + n_xiv_d(1:kreg_tot,:) = 0 + n_xiv_s(1:kreg_tot,:) = 0 +c + lead_t_tot(1:kreg_tot,:,:) = 0 + lead_d_tot(1:kreg_tot,:,:) = 0 + lead_s_tot(1:kreg_tot,:,:) = 0 +c + lead_t_sum = 0 + lead_d_sum = 0 + lead_s_sum = 0 +c + lead_t_reg = 0 + lead_d_reg = 0 + lead_s_reg = 0 + lead_t_typ = 0 + lead_d_typ = 0 + lead_s_typ = 0 + ntot_t_reg = 0 + ntot_d_reg = 0 + ntot_s_reg = 0 + ntyp_xiv_t = 0 + ntyp_xiv_d = 0 + ntyp_xiv_s = 0 + + endif +c +c Loop over reports +c ----------------- + do iob=1,numreps + ii = indx(iob) +c +c Determine the instrument type +c ----------------------------- + if(itype(ii).eq.insty_ob_fun('mdcrs').or. + $ itype(ii).eq.insty_ob_fun('mdcrs_lvl').or. + $ itype(ii).eq.insty_ob_fun('mdcrs_asc').or. + $ itype(ii).eq.insty_ob_fun('mdcrs_des')) then + ktype = 1 +c + elseif(itype(ii).eq.insty_ob_fun('acars').or. + $ itype(ii).eq.insty_ob_fun('acars_lvl').or. + $ itype(ii).eq.insty_ob_fun('acars_asc').or. + $ itype(ii).eq.insty_ob_fun('acars_des')) then + ktype = 2 +c + elseif(itype(ii).eq.insty_ob_fun('amdar').or. + $ itype(ii).eq.insty_ob_fun('amdar_lvl').or. + $ itype(ii).eq.insty_ob_fun('amdar_asc').or. + $ itype(ii).eq.insty_ob_fun('amdar_des')) then + ktype = 3 +c + elseif(itype(ii).eq.insty_ob_fun('airep').or. + $ itype(ii).eq.insty_ob_fun('airep_lvl').or. + $ itype(ii).eq.insty_ob_fun('airep_asc').or. + $ itype(ii).eq.insty_ob_fun('airep_des')) then + ktype = 4 +c + elseif(itype(ii).eq.insty_ob_fun('man-airep').or. + $ itype(ii).eq.insty_ob_fun('man-Yairep')) then + ktype = 5 + endif +c +c Find this tail number in the master list +c ---------------------------------------- + do mm=1,kreg_tot +c + if(c_acftreg(ii)(1:8).eq.creg_reg_tot(mm)(1:8)) then +c write(io8,*) +c write(io8,*) 'Tail number found in master list at mm = ',mm +c +c Compute leading digit distribution for temperature innovations +c -------------------------------------------------------------- + if(c_qc(ii)(6:6).ne.'B'.and. + $ c_qc(ii)(6:6).ne.'E'.and. + $ c_qc(ii)(6:6).ne.'I'.and. + $ c_qc(ii)(6:6).ne.'K'.and. + $ c_qc(ii)(6:6).ne.'b') then +c + if(xiv_t(ii).eq.amiss) then + lead = 11 + elseif(xiv_t(ii).eq.0.0) then + lead = 10 + else + write(c_lead,'(e12.5)') xiv_t(ii) + if(c_lead(2:2).eq.' '.or. + $ c_lead(2:2).eq.'0'.or. + $ c_lead(2:2).eq.'-') then + lead = ichar(c_lead(4:4)) - 48 + else + lead = ichar(c_lead(2:2)) - 48 + write(io8,*) '?',xiv_t(ii),c_lead,lead + endif + endif +c +c write(io8,*) ' ii = ',ii,' mm = ',mm +c write(io8,*) ' xiv_t = ',xiv_t(ii),' lead = ',lead +c + lead_t_tot(mm,lead,knt) = lead_t_tot(mm,lead,knt) + 1 + lead_t_sum(lead,knt) = lead_t_sum(lead,knt) + 1 + lead_t_typ(ktype,lead,knt) = + $ lead_t_typ(ktype,lead,knt) + 1 +c + if(itype(ii).eq.insty_ob_fun('amdar').or. + $ itype(ii).eq.insty_ob_fun('amdar_lvl').or. + $ itype(ii).eq.insty_ob_fun('amdar_asc').or. + $ itype(ii).eq.insty_ob_fun('amdar_des')) then +c + nid = 1 + do while(nid.le.13) + if(c_acftreg(ii)(1:2).eq.c_reg_list(nid)(1:2)) then + lead_t_reg(nid,lead,knt) = + $ lead_t_reg(nid,lead,knt)+1 + if(lead.ne.11) + $ ntot_t_reg(nid,knt) = ntot_t_reg(nid,knt) + 1 + nid = 14 + else + nid = nid + 1 + endif + enddo +c + elseif(itype(ii).eq.insty_ob_fun('mdcrs').or. + $ itype(ii).eq.insty_ob_fun('mdcrs_lvl').or. + $ itype(ii).eq.insty_ob_fun('mdcrs_asc').or. + $ itype(ii).eq.insty_ob_fun('mdcrs_des').or. + $ itype(ii).eq.insty_ob_fun('acars').or. + $ itype(ii).eq.insty_ob_fun('acars_lvl').or. + $ itype(ii).eq.insty_ob_fun('acars_asc').or. + $ itype(ii).eq.insty_ob_fun('acars_des')) then +c + nid = 14 + do while(nid.le.33) + if(c_acftreg(ii)(4:5).eq.c_reg_list(nid)(1:2)) then + lead_t_reg(nid,lead,knt) = + $ lead_t_reg(nid,lead,knt) + 1 + if(lead.ne.11) + $ ntot_t_reg(nid,knt) = ntot_t_reg(nid,knt) + 1 + nid = 34 + else + nid = nid + 1 + endif + enddo + endif +c + if(lead.ne.11) then + sum_xiv_t(mm,knt) = sum_xiv_t(mm,knt) + xiv_t(ii) + sumabs_xiv_t(mm,knt) = sumabs_xiv_t(mm,knt) + $ + abs(xiv_t(ii)) + n_xiv_t(mm,knt) = n_xiv_t(mm,knt) + 1 + ntot_xiv_t(knt) = ntot_xiv_t(knt) + 1 + ntyp_xiv_t(ktype,knt) = ntyp_xiv_t(ktype,knt) + 1 + endif +c +c write(io8,*) 'lead_t_tot = ',(lead_t_tot(mm,jj,knt),jj=1,11) +c + endif +c +c +c Compute leading digit distribution for wind direction innovations +c ----------------------------------------------------------------- + if(c_qc(ii)(7:7).ne.'S'.and. + $ c_qc(ii)(7:7).ne.'E'.and. + $ c_qc(ii)(7:7).ne.'K'.and. + $ c_qc(ii)(7:7).ne.'B'.and. + $ c_qc(ii)(7:7).ne.'I') then +c + if(xiv_d(ii).eq.amiss) then + lead = 11 + elseif(xiv_d(ii).eq.0.0) then + lead = 10 + else + write(c_lead,'(e12.5)') xiv_d(ii) + if(c_lead(2:2).eq.' '.or. + $ c_lead(2:2).eq.'0'.or. + $ c_lead(2:2).eq.'-') then + lead = ichar(c_lead(4:4)) - 48 + else + lead = ichar(c_lead(2:2)) - 48 + write(io8,*) '?',xiv_d(ii),c_lead,lead + endif + endif +c +c write(io8,*) 'ii = ',ii,' mm = ',mm +c write(io8,*) 'xiv_d = ',xiv_d(ii),' lead = ',lead +c + lead_d_tot(mm,lead,knt) = lead_d_tot(mm,lead,knt) + 1 + lead_d_sum(lead,knt) = lead_d_sum(lead,knt) + 1 + lead_d_typ(ktype,lead,knt) = + $ lead_d_typ(ktype,lead,knt) + 1 +c + if(itype(ii).eq.insty_ob_fun('amdar').or. + $ itype(ii).eq.insty_ob_fun('amdar_lvl').or. + $ itype(ii).eq.insty_ob_fun('amdar_asc').or. + $ itype(ii).eq.insty_ob_fun('amdar_des')) then +c + nid = 1 + do while(nid.le.13) + if(c_acftreg(ii)(1:2).eq.c_reg_list(nid)(1:2)) then + lead_d_reg(nid,lead,knt) = + $ lead_d_reg(nid,lead,knt) + 1 + if(lead.ne.11) + $ ntot_d_reg(nid,knt) = ntot_d_reg(nid,knt) + 1 + nid = 14 + else + nid = nid + 1 + endif + enddo +c + elseif(itype(ii).eq.insty_ob_fun('mdcrs').or. + $ itype(ii).eq.insty_ob_fun('mdcrs_lvl').or. + $ itype(ii).eq.insty_ob_fun('mdcrs_asc').or. + $ itype(ii).eq.insty_ob_fun('mdcrs_des').or. + $ itype(ii).eq.insty_ob_fun('acars').or. + $ itype(ii).eq.insty_ob_fun('acars_lvl').or. + $ itype(ii).eq.insty_ob_fun('acars_asc').or. + $ itype(ii).eq.insty_ob_fun('acars_des')) then +c + nid = 14 + do while(nid.le.33) + if(c_acftreg(ii)(4:5).eq.c_reg_list(nid)(1:2)) then + lead_d_reg(nid,lead,knt) = + $ lead_d_reg(nid,lead,knt) + 1 + if(lead.ne.11) + $ ntot_d_reg(nid,knt) = ntot_d_reg(nid,knt) + 1 + nid = 34 + else + nid = nid + 1 + endif + enddo + endif +c + if(lead.ne.11) then + sum_xiv_d(mm,knt) = sum_xiv_d(mm,knt) + xiv_d(ii) + sumabs_xiv_d(mm,knt) = sumabs_xiv_d(mm,knt) + $ + abs(xiv_d(ii)) + n_xiv_d(mm,knt) = n_xiv_d(mm,knt) + 1 + ntot_xiv_d(knt) = ntot_xiv_d(knt) + 1 + ntyp_xiv_d(ktype,knt) = ntyp_xiv_d(ktype,knt) + 1 + endif +c +c write(io8,*) 'lead_d_tot = ',(lead_d_tot(mm,jj,knt),jj=1,11) +c + endif +c +c Compute leading digit distribution for wind speed innovations +c ------------------------------------------------------------- + if(c_qc(ii)(8:8).ne.'S'.and. + $ c_qc(ii)(8:8).ne.'E'.and. + $ c_qc(ii)(8:8).ne.'K'.and. + $ c_qc(ii)(8:8).ne.'B'.and. + $ c_qc(ii)(8:8).ne.'A'.and. + $ c_qc(ii)(8:8).ne.'I') then +c + if(xiv_s(ii).eq.amiss) then + lead = 11 + elseif(xiv_s(ii).eq.0.0) then + lead = 10 + else + write(c_lead,'(e12.5)') xiv_s(ii) + if(c_lead(2:2).eq.' '.or. + $ c_lead(2:2).eq.'0'.or. + $ c_lead(2:2).eq.'-') then + lead = ichar(c_lead(4:4)) - 48 + else + lead = ichar(c_lead(2:2)) - 48 + write(io8,*) '?',xiv_s(ii),c_lead,lead + endif + endif +c +c write(io8,*) 'ii = ',ii,' mm = ',mm +c write(io8,*) 'xiv_s = ',xiv_s(ii),' lead = ',lead +c + lead_s_tot(mm,lead,knt) = lead_s_tot(mm,lead,knt) + 1 + lead_s_sum(lead,knt) = lead_s_sum(lead,knt) + 1 + lead_s_typ(ktype,lead,knt) = + $ lead_s_typ(ktype,lead,knt) + 1 +c + if(itype(ii).eq.insty_ob_fun('amdar').or. + $ itype(ii).eq.insty_ob_fun('amdar_lvl').or. + $ itype(ii).eq.insty_ob_fun('amdar_asc').or. + $ itype(ii).eq.insty_ob_fun('amdar_des')) then +c + nid = 1 + do while(nid.le.13) + if(c_acftreg(ii)(1:2).eq.c_reg_list(nid)(1:2)) then + lead_s_reg(nid,lead,knt) = + $ lead_s_reg(nid,lead,knt) + 1 + if(lead.ne.11) + $ ntot_s_reg(nid,knt) = ntot_s_reg(nid,knt) + 1 + nid = 14 + else + nid = nid + 1 + endif + enddo +c + elseif(itype(ii).eq.insty_ob_fun('mdcrs').or. + $ itype(ii).eq.insty_ob_fun('mdcrs_lvl').or. + $ itype(ii).eq.insty_ob_fun('mdcrs_asc').or. + $ itype(ii).eq.insty_ob_fun('mdcrs_des').or. + $ itype(ii).eq.insty_ob_fun('acars').or. + $ itype(ii).eq.insty_ob_fun('acars_lvl').or. + $ itype(ii).eq.insty_ob_fun('acars_asc').or. + $ itype(ii).eq.insty_ob_fun('acars_des')) then +c + nid = 14 + do while(nid.le.33) + if(c_acftreg(ii)(4:5).eq.c_reg_list(nid)(1:2)) then + lead_s_reg(nid,lead,knt) = + $ lead_s_reg(nid,lead,knt) + 1 + if(lead.ne.11) + $ ntot_s_reg(nid,knt) = ntot_s_reg(nid,knt) + 1 + nid = 34 + else + nid = nid + 1 + endif + enddo + endif +c + if(lead.ne.11) then + sum_xiv_s(mm,knt) = sum_xiv_s(mm,knt) + xiv_s(ii) + sumabs_xiv_s(mm,knt) = sumabs_xiv_s(mm,knt) + $ + abs(xiv_s(ii)) + n_xiv_s(mm,knt) = n_xiv_s(mm,knt) + 1 + ntot_xiv_s(knt) = ntot_xiv_s(knt) + 1 + ntyp_xiv_s(ktype,knt) = ntyp_xiv_s(ktype,knt) + 1 + endif +c +c write(io8,*) 'lead_s_tot = ',(lead_s_tot(mm,jj,knt),jj=1,11) +c + endif + endif + enddo + enddo +c +c Output results +c -------------- + if(l_last) then + write(io8,*) + write(io8,*) 'Temperature statistics' + write(io8,*) '----------------------' + write(io8,'('' leading digit distribution'')') + write(io8,'('' Tail# 1 2 3 4 5 6 '' + $, '' 7 8 9 0 amiss tot avg avgabs'')') + write(io8,'(''--------------------------------------------------'' + $, ''-----------------------------------------------'')') + +c + do mm=1,kreg_tot + if(n_xiv_t(mm,knt).ne.0) then + if(sum_xiv_t(mm,knt).ne.0.0) then + avg = sum_xiv_t(mm,knt) / float(n_xiv_t(mm,knt)) + else + avg = 0.0 + endif + if(sumabs_xiv_t(mm,knt).ne.0.0) then + avgabs = sumabs_xiv_t(mm,knt) / float(n_xiv_t(mm,knt)) + else + avgabs = 0.0 + endif + avg_lead = float(lead_t_tot(mm,:,knt)) + $ / float(n_xiv_t(mm,knt)) * 100.0 +c + write(io8,'(1x,a8,1x,11i6,i7,2f7.2)') + $ creg_reg_tot(mm),(lead_t_tot(mm,lead,knt),lead=1,11), + $ n_xiv_t(mm,knt),avg,avgabs + write(io8,'(1x,8x,1x,11f6.1)') (avg_lead(lead),lead=1,11) + endif + enddo +c + write(io8,*) + do jj=1,33 + if(ntot_t_reg(jj,knt).ne.0) then + avg_lead = float(lead_t_reg(jj,:,knt)) + $ / float(ntot_t_reg(jj,knt)) * 100.0 +c + write(io8,'(1x,a8,1x,11i6,i7)') + $ c_reg_list(jj),(lead_t_reg(jj,lead,knt),lead=1,11), + $ ntot_t_reg(jj,knt) + write(io8,'(1x,8x,1x,11f6.1)') (avg_lead(lead),lead=1,11) + endif + enddo +c + write(io8,*) + do ktype=1,5 + if(ntyp_xiv_t(ktype,knt).ne.0) then + avg_lead = float(lead_t_typ(ktype,:,knt)) + $ / float(ntyp_xiv_t(ktype,knt)) * 100.0 +c + write(io8,'(1x,a8,1x,11i6,i7)') + $ c_label(ktype),(lead_t_typ(ktype,lead,knt),lead=1,11), + $ ntyp_xiv_t(ktype,knt) + write(io8,'(1x,8x,1x,11f6.1)') (avg_lead(lead),lead=1,11) + endif + enddo +c + write(io8,*) + if(ntot_xiv_t(knt).ne.0) then + avg_lead = float(lead_t_sum(:,knt)) + $ / float(ntot_xiv_t(knt)) * 100.0 +c + write(io8,'(1x,''Overall '',1x,11i6,i7)') + $ (lead_t_sum(lead,knt),lead=1,11), + $ ntot_xiv_t(knt) + write(io8,'(1x,8x,1x,11f6.1)') (avg_lead(lead),lead=1,11) + endif +c + write(io8,*) + write(io8,*) 'Wind direction statistics' + write(io8,*) '-------------------------' + write(io8,'('' leading digit distribution'')') + write(io8,'('' Tail# 1 2 3 4 5 6 '' + $, '' 7 8 9 0 amiss tot avg avgabs'')') + write(io8,'(''--------------------------------------------------'' + $, ''-----------------------------------------------'')') +c + do mm=1,kreg_tot + if(n_xiv_d(mm,knt).ne.0) then + if(sum_xiv_d(mm,knt).ne.0.0) then + avg = sum_xiv_d(mm,knt) / float(n_xiv_d(mm,knt)) + else + avg = 0.0 + endif + if(sumabs_xiv_d(mm,knt).ne.0.0) then + avgabs = sumabs_xiv_d(mm,knt) / float(n_xiv_d(mm,knt)) + else + avgabs = 0.0 + endif + avg_lead = float(lead_d_tot(mm,:,knt)) + $ / float(n_xiv_d(mm,knt)) * 100.0 +c + write(io8,'(1x,a8,1x,11i6,i7,2f7.2)') + $ creg_reg_tot(mm),(lead_d_tot(mm,lead,knt),lead=1,11), + $ n_xiv_d(mm,knt),avg,avgabs + write(io8,'(1x,8x,1x,11f6.1)') (avg_lead(lead),lead=1,11) + endif + enddo +c + write(io8,*) + do jj=1,33 + if(ntot_d_reg(jj,knt).ne.0) then + avg_lead = float(lead_d_reg(jj,:,knt)) + $ / float(ntot_d_reg(jj,knt)) * 100.0 +c + write(io8,'(1x,a8,1x,11i6,i7)') + $ c_reg_list(jj),(lead_d_reg(jj,lead,knt),lead=1,11), + $ ntot_d_reg(jj,knt) + write(io8,'(1x,8x,1x,11f6.1)') (avg_lead(lead),lead=1,11) + endif + enddo +c + write(io8,*) + do ktype=1,5 + if(ntyp_xiv_d(ktype,knt).ne.0) then + avg_lead = float(lead_d_typ(ktype,:,knt)) + $ / float(ntyp_xiv_d(ktype,knt)) * 100.0 +c + write(io8,'(1x,a8,1x,11i6,i7)') + $ c_label(ktype),(lead_d_typ(ktype,lead,knt),lead=1,11), + $ ntyp_xiv_d(ktype,knt) + write(io8,'(1x,8x,1x,11f6.1)') (avg_lead(lead),lead=1,11) + endif + enddo +c + write(io8,*) + if(ntot_xiv_d(knt).ne.0) then + avg_lead = float(lead_d_sum(:,knt)) + $ / float(ntot_xiv_d(knt)) * 100.0 +c + write(io8,'(1x,''Overall '',1x,11i6,i7)') + $ (lead_d_sum(lead,knt),lead=1,11), + $ ntot_xiv_d(knt) + write(io8,'(1x,8x,1x,11f6.1)') (avg_lead(lead),lead=1,11) + endif +c + write(io8,*) + write(io8,*) 'Wind speed statistics' + write(io8,*) '---------------------' + write(io8,'('' leading digit distribution'')') + write(io8,'('' Tail# 1 2 3 4 5 6 '' + $, '' 7 8 9 0 amiss tot avg avgabs'')') + write(io8,'(''--------------------------------------------------'' + $, ''-----------------------------------------------'')') +c + do mm=1,kreg_tot + if(n_xiv_s(mm,knt).ne.0) then + if(sum_xiv_s(mm,knt).ne.0.0) then + avg = sum_xiv_s(mm,knt) / float(n_xiv_s(mm,knt)) + else + avg = 0.0 + endif + if(sumabs_xiv_s(mm,knt).ne.0.0) then + avgabs = sumabs_xiv_s(mm,knt) / float(n_xiv_s(mm,knt)) + else + avgabs = 0.0 + endif + avg_lead = float(lead_s_tot(mm,:,knt)) + $ / float(n_xiv_s(mm,knt)) * 100.0 +c + write(io8,'(1x,a8,1x,11i6,i7,2f7.2)') + $ creg_reg_tot(mm),(lead_s_tot(mm,lead,knt),lead=1,11), + $ n_xiv_s(mm,knt),avg,avgabs + write(io8,'(1x,8x,1x,11f6.1)') (avg_lead(lead),lead=1,11) + endif + enddo +c + write(io8,*) + do jj=1,33 + if(ntot_s_reg(jj,knt).ne.0) then + avg_lead = float(lead_s_reg(jj,:,knt)) + $ / float(ntot_s_reg(jj,knt)) * 100.0 +c + write(io8,'(1x,a8,1x,11i6,i7)') + $ c_reg_list(jj),(lead_s_reg(jj,lead,knt),lead=1,11), + $ ntot_s_reg(jj,knt) + write(io8,'(1x,8x,1x,11f6.1)') (avg_lead(lead),lead=1,11) + endif + enddo +c + write(io8,*) + do ktype=1,5 + if(ntyp_xiv_s(ktype,knt).ne.0) then + avg_lead = float(lead_s_typ(ktype,:,knt)) + $ / float(ntyp_xiv_s(ktype,knt)) * 100.0 +c + write(io8,'(1x,a8,1x,11i6,i7)') + $ c_label(ktype),(lead_s_typ(ktype,lead,knt),lead=1,11), + $ ntyp_xiv_s(ktype,knt) + write(io8,'(1x,8x,1x,11f6.1)') (avg_lead(lead),lead=1,11) + endif + enddo +c + write(io8,*) + if(ntot_xiv_s(knt).ne.0) then + avg_lead = float(lead_s_sum(:,knt)) + $ / float(ntot_xiv_s(knt)) * 100.0 +c + write(io8,'(1x,''Overall '',1x,11i6,i7)') + $ (lead_s_sum(lead,knt),lead=1,11), + $ ntot_xiv_s(knt) + write(io8,'(1x,8x,1x,11f6.1)') (avg_lead(lead),lead=1,11) + endif + endif +c + return + end +c +c ################################################################### +c subroutine invalid_qc +c ################################################################### +c + subroutine invalid_qc(numreps,max_reps,c_acftreg,c_acftid,c_qc + $, alat,alon,pres,ht_ft,t_prcn,ob_t,ob_q,ob_dir,ob_spd + $, xiv_t,xiv_q,xiv_d,xiv_s,maxflt,kreg,creg_reg,ntemp_reg + $, idt,itype,ichk_t,ichk_q,ichk_d,ichk_s,kbadtot,n_minus9C + $, indx,csort,amiss,imiss,io8,io32,l_operational,l_init + $, cdtg_an,l_minus9c) +c +c Remove invalid data from dataset +c +c modified 5/18/01 by p.m.pauley-- -9c test refined +c modified 6/28/01 by p.m.pauley--test added for direction=360 +c some aircraft report 360 when they should report 180 +c modified 1/8/03 by P.M.Pauley--added check for truncated German +c AMDAR reports--these seem to have blank tail numbers, which +c the code changes to 'LH ' (which the test looks for) +c + implicit none +c +c Declaration statements +c ---------------------- + integer max_reps ! maximum number of reports +c + character*11 c_qc(max_reps) ! internal qc flags +c +c Data arrays +c ----------- + character*10 cdtg_an ! date time group for analysis + integer numreps ! actual number of reports + integer itype(max_reps) ! type of aircraft data + $, ktype ! pointer for instrument type + integer idt(max_reps) ! time in seconds to analysis time + character*8 c_acftreg(max_reps) ! aircraft registration (tail) number + character*9 c_acftid(max_reps) ! aircraft flight number + real*8 alat(max_reps) ! latitude + $, alon(max_reps) ! longitude + real pres(max_reps) ! pressure + $, ht_ft(max_reps) ! height in feet + real t_prcn(max_reps) ! temperature precision + real ob_t(max_reps) ! temperature + $, ob_q(max_reps) ! specific humidity + $, ob_dir(max_reps) ! wind direction + $, ob_spd(max_reps) ! wind speed + real xiv_t(max_reps) ! temperature innovation (ob - bk) + $, xiv_q(max_reps) ! specific humidity innovation (ob - bk) + $, xiv_d(max_reps) ! wind direction innovation (ob - bk) + $, xiv_s(max_reps) ! wind speed innovation (ob - bk) + integer ichk_t(max_reps) ! NRL QC flag for temperature ob + $, ichk_q(max_reps) ! NRL QC flag for specific humidity ob + $, ichk_d(max_reps) ! NRL QC flag for wind direction ob + $, ichk_s(max_reps) ! NRL QC flag for wind speed ob + character*25 csort(max_reps) ! sort variable + logical l_minus9c(max_reps) ! true for mdcrs -9C temperatures +c +c Pointers +c -------- + integer indx(max_reps) ! pointer index for good reports +c +c Functions +c --------- + character*16 c_insty_ob ! function to convert integer instrument + ! type to character instrument type + integer insty_ob_fun ! function to convert character + ! instrument type to integer +c +c Other variables +c --------------- + integer io8 ! i/o unit number for log file + integer io32 ! i/o unit number for rejected reports +c + integer imiss ! integer missing value flag + real amiss ! real missing value flag +c + integer iob ! do loop index + $, ii ! index pointing to current report + $, iim2 ! index pointing to report before previous report + $, iim1 ! index pointing to previous report + $, iip1 ! index pointing to following report + $, iip2 ! index pointing to report after following report + $, kbadtot ! total number of rejected duplicates + $, kbad(5) ! counter for number of invalid reports +c +ccccdak integer i_acars ! instrument type for acars + integer i_acars ! instrument type for tamdar +ccccdak $, i_acars_lvl ! instrument type for acars--level flt + $, i_acars_lvl ! instrument type for tamdar--level flt +ccccdak $, i_acars_asc ! instrument type for acars--ascent + $, i_acars_asc ! instrument type for tamdar--ascent +ccccdak $, i_acars_des ! instrument type for acars--descent + $, i_acars_des ! instrument type for tamdar--descent + $, i_mdcrs ! instrument type for mdcrs + $, i_mdcrs_lvl ! instrument type for mdcrs--level flt + $, i_mdcrs_asc ! instrument type for mdcrs--ascent + $, i_mdcrs_des ! instrument type for mdcrs--descent + $, i_man_airep ! instrument type for manual aireps + $, i_man_Yairep ! instrument type for manual aireps (YRXX) + $, i_airep ! instrument type for airep + $, i_airep_lvl ! instrument type for airep--level flt + $, i_airep_asc ! instrument type for airep--ascent + $, i_airep_des ! instrument type for airep--descent + $, i_amdar ! instrument type for amdar + $, i_amdar_lvl ! instrument type for amdar--level flt + $, i_amdar_asc ! instrument type for amdar--ascent + $, i_amdar_des ! instrument type for amdar--descent +c + integer n_empty(5) ! number of empty reports + $, n_zero_tmp(5) ! number of reports with zero winds and temperature + $, n_zero_alt(5) ! number of reports with zero winds and altitude + $, n_zero_pos(5) ! number of reports with zero lat/lon + $, n_bad_decode(5) ! number of reports with bad decodes + $, n_miss_time(5) ! number of reports with missing times + $, n_miss_pos(5) ! number of reports with missing positions + $, n_miss_pres(5) ! number of reports with missing pressures + $, n_small_pres(5) ! number of reports with too small pressures + $, n_low_airep(5) ! number of low-level aireps rejected + ! (sign on altitude is ambiguous) + $, n_minus9C(5) ! number of -9C temperatures rejected + $, n_bad360(5) ! number of erroneous north winds + $, n_bad180(5) ! number of erroneous south winds +c + integer n_xx999_Ar ! number of aireps with missing id + $, n_xx999_Ma ! number of manual aireps with missing id + integer n_blank_Ar ! number of aireps with blank id + $, n_blank_Ma ! number of manual aireps with blank id + $, n_blank_Md ! number of MDCRS reports with blank id + $, n_blank_Am ! number of AMDAR reports with blank id +c +ccccdak integer nrep_Ac ! number of acars reports considered + integer nrep_Ac ! number of tamdar reports considered + $, nrep_Md ! number of mdcrs reports considered + $, nrep_Ma ! number of manual airep reports considered + $, nrep_Ar ! number of airep reports considered + $, nrep_Am ! number of amdar reports considered +ccccdak $, nbad_Ac ! number of bad acars + $, nbad_Ac ! number of bad tamdar + $, nbad_Md ! number of bad mdcrs + $, nbad_Ma ! number of bad manual aireps + $, nbad_Ar ! number of bad aireps + $, nbad_Am ! number of bad amdar +c + integer maxflt ! max number of flights allowed + integer kreg ! actual number of tail#s in dataset + $, mm ! index pointing to current tail number + character*8 creg_reg(maxflt) ! tail numbers + integer ntemp_reg(maxflt,5) ! number of reports w. rejected temp +c + integer knt ! counter used in defining iim1, iip1 +c +c Switches +c -------- + logical l_print ! print values if true + $, l_operational ! run QC in operational mode if true + $, l_init ! initialize counters if true +c $, l_ual_all ! true if all remapped ids are UAL acft +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c +c Initialize aircraft data types +c ------------------------------ + i_acars = insty_ob_fun('acars') + i_acars_lvl = insty_ob_fun('acars_lvl') + i_acars_asc = insty_ob_fun('acars_asc') + i_acars_des = insty_ob_fun('acars_des') + i_mdcrs = insty_ob_fun('mdcrs') + i_mdcrs_lvl = insty_ob_fun('mdcrs_lvl') + i_mdcrs_asc = insty_ob_fun('mdcrs_asc') + i_mdcrs_des = insty_ob_fun('mdcrs_des') + i_man_airep = insty_ob_fun('man-airep') + i_man_Yairep = insty_ob_fun('man-Yairep') + i_airep = insty_ob_fun('airep') + i_airep_lvl = insty_ob_fun('airep_lvl') + i_airep_asc = insty_ob_fun('airep_asc') + i_airep_des = insty_ob_fun('airep_des') + i_amdar = insty_ob_fun('amdar') + i_amdar_lvl = insty_ob_fun('amdar_lvl') + i_amdar_asc = insty_ob_fun('amdar_asc') + i_amdar_des = insty_ob_fun('amdar_des') +c +c Initialize counters +c ------------------- + if(l_init) then + n_empty = 0 + n_zero_tmp = 0 + n_zero_alt = 0 + n_zero_pos = 0 + n_bad_decode = 0 + n_miss_time = 0 + n_miss_pos = 0 + n_miss_pres = 0 + n_small_pres = 0 + n_low_airep = 0 + n_minus9C = 0 + n_bad360 = 0 + n_bad180 = 0 +c + n_xx999_Ar = 0 + n_xx999_Ma = 0 + n_blank_Ar = 0 + n_blank_Ma = 0 + n_blank_Md = 0 + n_blank_Am = 0 +c + nrep_Ac = 0 + nrep_Md = 0 + nrep_Ma = 0 + nrep_Ar = 0 + nrep_Am = 0 + nbad_Ac = 0 + nbad_Md = 0 + nbad_Ma = 0 + nbad_Ar = 0 + nbad_Am = 0 + endif +c +c Begin loop over reports +c ----------------------- + do iob = 1,numreps +c + l_print = .false. +c +c Compute ii index +c ---------------- + ii = indx(iob) +c +c Compute ii-1 index +c ------------------ + knt = iob - 1 + 10 if(knt.ge.1) then + iim1 = indx(knt) + if(c_qc(iim1)(1:1).eq.'B'.or. + $ c_qc(iim1)(3:4).eq.'BB'.or. + $ c_qc(iim1)(2:2).eq.'M'.or. + $ c_qc(iim1)(3:3).eq.'M'.or. + $ c_qc(iim1)(4:4).eq.'M'.or. + $ c_qc(iim1)(5:5).eq.'M'.or. + $ c_qc(iim1)(5:5).eq.'B'.or. + $ c_qc(iim1)(6:6).eq.'B'.or. + $ c_qc(iim1)(7:7).eq.'B'.or. + $ c_qc(iim1)(6:8).eq.'MMM') then + knt = knt - 1 + goto 10 + endif + else + iim1 = 0 + endif +c +c Compute ii-2 index +c ------------------ + knt = knt - 1 + 15 if(knt.ge.1) then + iim2 = indx(knt) + if(c_qc(iim2)(1:1).eq.'B'.or. + $ c_qc(iim2)(3:4).eq.'BB'.or. + $ c_qc(iim2)(2:2).eq.'M'.or. + $ c_qc(iim2)(3:3).eq.'M'.or. + $ c_qc(iim2)(4:4).eq.'M'.or. + $ c_qc(iim2)(5:5).eq.'M'.or. + $ c_qc(iim2)(5:5).eq.'B'.or. + $ c_qc(iim2)(6:6).eq.'B'.or. + $ c_qc(iim2)(7:7).eq.'B'.or. + $ c_qc(iim2)(6:8).eq.'MMM') then + knt = knt - 1 + goto 15 + endif + else + iim2 = 0 + endif +c +c Compute ii+1 index +c ------------------ + knt = iob + 1 + 20 if(knt.le.numreps) then + iip1 = indx(knt) + if(c_qc(iip1)(1:1).eq.'B'.or. + $ c_qc(iip1)(3:4).eq.'BB'.or. + $ c_qc(iip1)(2:2).eq.'M'.or. + $ c_qc(iip1)(3:3).eq.'M'.or. + $ c_qc(iip1)(4:4).eq.'M'.or. + $ c_qc(iip1)(5:5).eq.'M'.or. + $ c_qc(iip1)(5:5).eq.'B'.or. + $ c_qc(iip1)(6:6).eq.'B'.or. + $ c_qc(iip1)(7:7).eq.'B'.or. + $ c_qc(iip1)(6:8).eq.'MMM') then + knt = knt + 1 + goto 20 + endif + else + iip1 = 0 + endif +c +c Compute ii+2 index +c ------------------ + knt = knt + 1 + 25 if(knt.le.numreps) then + iip2 = indx(knt) + if(c_qc(iip2)(1:1).eq.'B'.or. + $ c_qc(iip2)(3:4).eq.'BB'.or. + $ c_qc(iip2)(2:2).eq.'M'.or. + $ c_qc(iip2)(3:3).eq.'M'.or. + $ c_qc(iip2)(4:4).eq.'M'.or. + $ c_qc(iip2)(5:5).eq.'M'.or. + $ c_qc(iip2)(5:5).eq.'B'.or. + $ c_qc(iip2)(6:6).eq.'B'.or. + $ c_qc(iip2)(7:7).eq.'B'.or. + $ c_qc(iip2)(6:8).eq.'MMM') then + knt = knt + 1 + goto 25 + endif + else + iip2 = 0 + endif +c +c Set ktype +c --------- + if(itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des.or. + $ itype(ii).eq.i_mdcrs) then + ktype = 1 +c + elseif(itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des.or. + $ itype(ii).eq.i_acars) then + ktype = 2 +c + elseif(itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des.or. + $ itype(ii).eq.i_amdar) then + ktype = 3 +c + elseif(itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des.or. + $ itype(ii).eq.i_airep) then + ktype = 4 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + ktype = 5 + endif +c +c Count reports with missing ids +c ------------------------------ + if(c_acftid(ii)(1:5).eq.'XX999'.or. + $ c_acftid(ii)(1:4).eq.'////') then +c + c_qc(ii)(1:1) = 'B' +c + if(ktype.eq.4) then + n_xx999_Ar = n_xx999_Ar + 1 +c + elseif(ktype.eq.5) then + n_xx999_Ma = n_xx999_Ma + 1 + endif +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Report found with missing id' + endif +c +c Count reports with blank ids +c ---------------------------- + +C DAK: Here is where TAMDAR reports were originally tossed for having a blank tail number due +c to logic in subroutine dupchek_qc that would not allow one to be generated (flight +c number was all numbers and tail number was originally missing, thus a tail number +c could not be created from the flight number) -- this has since been bypassed by +c changing characters 1-3 in in the flight number to "TAM" in subroutine input_acqc +c where the reports are read in from NCEP PREPBUFR file and stored in memory + + elseif(c_acftreg(ii)(1:8).eq.' ') then +c + c_qc(ii)(1:1) = 'B' +c + if(ktype.eq.1) then + n_blank_Md = n_blank_Md + 1 +c + elseif(ktype.eq.3) then + n_blank_Am = n_blank_Am + 1 +c + elseif(ktype.eq.4) then + n_blank_Ar = n_blank_Ar + 1 +c + elseif(ktype.eq.5) then + n_blank_Ma = n_blank_Ma + 1 + endif +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Report found with blank tail number' + endif +c +c Look for truncated German AMDAR reports +c --------------------------------------- + elseif(c_acftreg(ii)(1:8).eq.'LH '.and. + $ ktype.eq.3) then +c + c_qc(ii)(1:1) = 'B' + n_bad_decode(3) = n_bad_decode(3) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Truncated German AMDAR report' + endif +c +c Count reports marked bad in decoder +c ----------------------------------- + elseif(c_qc(ii)(1:1).eq.'B') then +c + n_bad_decode(ktype) = n_bad_decode(ktype) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Report marked bad in decoder' + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c +c Check for zero position--lat/lon both zero +c ------------------------------------------ + elseif(abs(alat(ii)).lt.0.001.and. + $ abs(alon(ii)).lt.0.001) then +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c + c_qc(ii)(3:4) = 'BB' +c + n_zero_pos(ktype) = n_zero_pos(ktype) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Report found with zero lat and lon' + endif +c +c Check for missing time +c ---------------------- + elseif(idt(ii).eq.imiss) then +c + c_qc(ii)(2:2) = 'M' +c + n_miss_time(ktype) = n_miss_time(ktype) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Report found with missing time' + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c +c Check for missing latitude/longitude +c ------------------------------------ + elseif(alat(ii).eq.amiss.or. + $ alon(ii).eq.amiss) then +c + if(alat(ii).eq.amiss) c_qc(ii)(3:3) = 'M' + if(alon(ii).eq.amiss) c_qc(ii)(4:4) = 'M' +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c + n_miss_pos(ktype) = n_miss_pos(ktype) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Report found with missing lat or lon' + endif +c +c Check for missing pressure/altitude +c ----------------------------------- + elseif(pres(ii).eq.amiss.and.ht_ft(ii).eq.amiss) then +c + c_qc(ii)(5:5) = 'M' +c + n_miss_pres(ktype) = n_miss_pres(ktype) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Report found with missing pressure' + endif +c +c Check for too-small pressure (too-large altitude) +c Allow high altitude manual AIREPs from Concordes (BAW and AFR) +c -------------------------------------------------------------- + elseif(ht_ft(ii).gt.49999.5.or.pres(ii).lt.116.05) then + if((itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep).and. + $ (c_acftid(ii)(1:3).eq.'AFR'.or. + $ c_acftid(ii)(1:3).eq.'BAW')) then +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Valid high-altitude report--ii = ',ii + endif +c + else + c_qc(ii)(5:5) = 'B' +c + n_small_pres(ktype) = n_small_pres(ktype) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Altitude is too high!' + endif + endif +c +c Check for low-level airep reports--altitude sign not known +c ---------------------------------------------------------- + elseif((itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep).and. + $ abs(ht_ft(ii)).lt.600.0) then +c + c_qc(ii)(5:5) = 'B' +c + n_low_airep(ktype) = n_low_airep(ktype) + 1 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Low-altitude AIREP found' + endif +c +c Check for empty report--temperature and winds missing +c ----------------------------------------------------- + elseif(ob_t(ii).eq.amiss.and. + $ (ob_dir(ii).eq.amiss.or. + $ ob_spd(ii).eq.amiss)) then +c + c_qc(ii)(6:9) = 'MMMN' + if(ob_q(ii).eq.amiss) c_qc(ii)(9:9) = 'M' +c + n_empty(ktype) = n_empty(ktype) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Report found with missing temperature, winds' + endif +c +c Check for empty report--temperature and winds zero +c -------------------------------------------------- + elseif(abs(ob_t(ii)-273.16).lt.0.05.and. + $ (ifix(ob_dir(ii)).eq.360.or.ifix(ob_dir(ii)).eq.0).and. + $ ifix(ob_spd(ii)*10.0).eq.0.and. + $ (itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep)) then +c + c_qc(ii)(6:9) = 'MMMN' + if(ob_q(ii).eq.amiss) c_qc(ii)(9:9) = 'M' +c + n_zero_tmp(ktype) = n_zero_tmp(ktype) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Report found with zero C temperature, winds' + endif +c +c Check for empty report--altitude and winds zero +c ----------------------------------------------- + elseif(ifix(ht_ft(ii)).eq.0.and. + $ (ifix(ob_dir(ii)).eq.360.or.ifix(ob_dir(ii)).eq.0).and. + $ ifix(ob_spd(ii)).eq.0) then +c + c_qc(ii)(5:9) = 'BNMMN' + if(ob_q(ii).eq.amiss) c_qc(ii)(9:9) = 'M' +c + n_zero_alt(ktype) = n_zero_alt(ktype) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Report found with zero altitude, winds' + endif +c +c Perform checks on just temperature or wind direction +c ---------------------------------------------------- + else +c +c Check for -9C temperature, precision = 1.00, no phase indicated +c --------------------------------------------------------------- +c if(abs(ob_t(ii)-264.16).lt.0.05.and. + if(l_minus9c(ii)) then +c +c write(io8,*) +c write(io8,*) 'l_minus9c = T at iob,ii = ',iob,ii +c write(io8,*) ' t_prcn = ',t_prcn(ii) +c write(io8,*) ' itype = ',c_insty_ob(itype(ii)) +c write(io8,*) ' ht_ft = ',ht_ft(ii) +c write(io8,*) ' ids = ',c_acftreg(ii),c_acftid(ii) +c + if(ifix(t_prcn(ii)*100).eq.100.and. + $ itype(ii).eq.i_mdcrs) then +c + if(iob.eq.1) then + iim1 = 0 + else + iim1 = indx(iob-1) + endif +c + if(iob.eq.numreps) then + iip1 = 0 + else + iip1 = indx(iob+1) + endif +c +c Reject ob if -9C temperature exceeds gross check +c ------------------------------------------------ + if(ht_ft(ii).gt.30187.5) then +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*)'-9C temp would be rejected by gross chk!' + $, ' ii = ',ii + endif +c + if(c_qc(ii)(6:6).eq.'-') then + c_qc(ii)(6:6) = 'I' + n_minus9C(ktype) = n_minus9C(ktype) + 1 + endif +c +c Perform other checks if previous ob available +c --------------------------------------------- + elseif(iim1.ne.0) then +c +c Reject ob if previous ob is from same flight but does not +c have -9C temperature, precision = 1.00, no phase indicated +c ------------------------------------------------------------ + if(c_acftreg(ii)(1:8).eq.c_acftreg(iim1)(1:8).and. + $ c_acftid(ii)(1:8).eq.c_acftid(iim1)(1:8).and. +c $ abs(ob_t(iim1)-264.16).gt.0.05.and. + $ (.not.l_minus9c(iim1)).and. + $ ifix(t_prcn(iim1)*100).ne.100.and. + $ itype(iim1).ne.i_mdcrs) then +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Isolated -9C temperature found!--iim1' + $, ' ii = ',ii + endif +c + if(c_qc(ii)(6:6).eq.'-') then + c_qc(ii)(6:6) = 'I' + n_minus9C(ktype) = n_minus9C(ktype) + 1 + endif +c +c Check if previous ob has -9C temperature, precision = 1.00, no phase indicated +c ------------------------------------------------------------------------------ + elseif(c_acftreg(ii)(1:8).eq.c_acftreg(iim1)(1:8).and. + $ c_acftid(ii)(1:8).eq.c_acftid(iim1)(1:8).and. +c $ abs(ob_t(iim1)-264.16).lt.0.05.and. + $ l_minus9c(iim1).and. + $ ifix(t_prcn(ii)*100).eq.100.and. + $ itype(ii).eq.i_mdcrs) then +c +c Check if following ob is available +c ---------------------------------- + if(iip1.ne.0) then +c +c Check if following ob is from same flight +c ----------------------------------------- + if(c_acftreg(ii)(1:8).eq.c_acftreg(iip1)(1:8).and. + $ c_acftid(ii)(1:8).eq.c_acftid(iip1)(1:8)) then +c +c Reject all three obs if following ob has -9C temperature, +c precision = 1.00, no phase indicated +c --------------------------------------------------------- +c if(abs(ob_t(iip1)-264.16).lt.0.05.and. + if(l_minus9c(iip1).and. + $ ifix(t_prcn(iip1)*100).eq.100.and. + $ itype(iip1).eq.i_mdcrs) then +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*)'Three -9C temps in a row' + $, ' ii = ',ii + endif +c + if(c_qc(iim1)(6:6).eq.'-') then + c_qc(iim1)(6:6) = 'I' + n_minus9C(ktype) = n_minus9C(ktype) + 1 + endif +c + if(c_qc(ii)(6:6).eq.'-') then + c_qc(ii)(6:6) = 'I' + n_minus9C(ktype) = n_minus9C(ktype) + 1 + endif +c + if(c_qc(iip1)(6:6).eq.'-') then + c_qc(iip1)(6:6) = 'I' + n_minus9C(ktype) = n_minus9C(ktype) + 1 + endif +c + endif +c +c Following ob is not from same flight--reject two obs +c ---------------------------------------------------- + else +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*)'Two -9C temps in a row' + $, ' ii = ',ii + endif +c + if(c_qc(iim1)(6:6).eq.'-') then + c_qc(iim1)(6:6) = 'I' + n_minus9C(ktype) = n_minus9C(ktype) + 1 + endif +c + if(c_qc(ii)(6:6).eq.'-') then + c_qc(ii)(6:6) = 'I' + n_minus9C(ktype) = n_minus9C(ktype) + 1 + endif +c + endif + endif + endif +c +c Check if following ob is available +c ---------------------------------- + elseif(iip1.ne.0) then +c +c Reject ob if following ob is from same flight but does not +c have -9C temperature, precision = 1.00, no phase indicated +c ------------------------------------------------------------ + if(c_acftreg(ii)(1:8).eq.c_acftreg(iip1)(1:8).and. + $ c_acftid(ii)(1:8).eq.c_acftid(iip1)(1:8).and. +c $ abs(ob_t(iip1)-264.16).gt.0.05.and. + $ (.not.l_minus9c(iip1)).and. + $ ifix(t_prcn(iip1)*100).ne.100.and. + $ itype(iip1).ne.i_mdcrs) then +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Isolated -9C temperature found--iip1!' + $, ' ii = ',ii + endif +c + if(c_qc(ii)(6:6).eq.'-') then + c_qc(ii)(6:6) = 'I' + n_minus9C(ktype) = n_minus9C(ktype) + 1 + endif +c + endif + endif + endif + endif +c +c Check for erroneous 360 and 0 degree wind directions +c Exclude winds less than 5 kts? +c ---------------------------------------------------- + if((ifix(ob_dir(ii)).eq.360.or. + $ ifix(ob_dir(ii)).eq.0).and. + $ ifix(ob_spd(ii)*100.0).ne.0.and. + $ ob_spd(ii).ne.amiss.and. + $ itype(ii).ne.i_man_airep.and. + $ itype(ii).ne.i_man_Yairep) then +c +c Perform other checks if previous and following obs available +c ------------------------------------------------------------ + if(iim1.ne.0.and.iip1.ne.0) then +c +c Check if previous and following obs from same flight +c ---------------------------------------------------- + if(c_acftreg(ii)(1:8).eq.c_acftreg(iim1)(1:8).and. + $ c_acftid(ii)(1:8).eq.c_acftid(iim1)(1:8).and. + $ c_acftreg(ii)(1:8).eq.c_acftreg(iip1)(1:8).and. + $ c_acftid(ii)(1:8).eq.c_acftid(iip1)(1:8).and. + $ ob_dir(iim1).ne.amiss.and. + $ ob_spd(iim1).ne.amiss.and. + $ ifix(ob_dir(iim1)).ne.360.and. + $ ifix(ob_dir(iim1)).ne.0.and. + $ ob_dir(iip1).ne.amiss.and. + $ ob_spd(iip1).ne.amiss.and. + $ ifix(ob_dir(iip1)).ne.360.and. + $ ifix(ob_dir(iip1)).ne.0) then +c +c Reject ob if neither neighbor has a northerly component +c ------------------------------------------------------- + if(ifix(ob_dir(iim1)).lt.270.and. + $ ifix(ob_dir(iim1)).gt.90.and. + $ ifix(ob_dir(iip1)).lt.270.and. + $ ifix(ob_dir(iip1)).gt.90) then +c + if(ob_spd(ii).lt.7.75.and. + $ (ob_spd(iim1).lt.7.75.or. + $ ob_spd(iip1).lt.7.75).and. + $ abs(idt(ii)-idt(iim1)).gt.120.and. + $ abs(idt(ii)-idt(iip1)).gt.120) then +c +c light and variable ok except for high time resolution flights +c + elseif(ob_spd(ii).lt.2.55.and. + $ (ob_spd(iim1).lt.2.55.or. + $ ob_spd(iip1).lt.2.55)) then +c +c light and variable ok for high time resolution flights +c + elseif(ob_spd(ii).lt.7.75.and. + $ ht_ft(ii).lt.10000.0.and. + $ (ht_ft(iim1)-ht_ft(ii)).gt.8000.0.and. + $ (ht_ft(iip1)-ht_ft(ii)).gt.8000.0) then +c +c large shear in low-res descent-ascent probably ok +c + else +c + c_qc(ii)(7:7) = 'B' + n_bad360(ktype) = n_bad360(ktype) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad north wind found-1-ii = ',ii + endif + endif + endif +c +c Check if three consecutive north winds are ok +c --------------------------------------------- + elseif(c_acftreg(ii)(1:8).eq.c_acftreg(iim1)(1:8).and. + $ c_acftid(ii)(1:8).eq.c_acftid(iim1)(1:8).and. + $ c_acftreg(ii)(1:8).eq.c_acftreg(iip1)(1:8).and. + $ c_acftid(ii)(1:8).eq.c_acftid(iip1)(1:8).and. + $ ob_dir(iim1).ne.amiss.and. + $ ob_spd(iim1).ne.amiss.and. + $ (ifix(ob_dir(iim1)).eq.360.or. + $ ifix(ob_dir(iim1)).eq.0).and. + $ ob_dir(iip1).ne.amiss.and. + $ ob_spd(iip1).ne.amiss.and. + $ (ifix(ob_dir(iip1)).eq.360.or. + $ ifix(ob_dir(iip1)).eq.0).and. + $ iim2.ne.0.and. + $ iip2.ne.0) then +c +c Reject ob if neither neighbor has a northerly component +c ------------------------------------------------------- + if(ifix(ob_dir(iim2)).lt.270.and. + $ ifix(ob_dir(iim2)).gt.90.and. + $ ifix(ob_dir(iip2)).lt.270.and. + $ ifix(ob_dir(iip2)).gt.90) then +c + if(ob_spd(ii).lt.7.75.and. + $ ((ob_spd(iim2).lt.7.75.and. + $ ob_spd(iim1).lt.7.75).or. + $ (ob_spd(iip1).lt.7.75.and. + $ ob_spd(iip2).lt.7.75)).and. + $ abs(idt(ii)-idt(iim1)).gt.120.and. + $ abs(idt(ii)-idt(iip1)).gt.120) then +c +c light and variable ok +c + elseif(ob_spd(ii).lt.2.55.and. + $ ((ob_spd(iim2).lt.2.55.and. + $ ob_spd(iim1).lt.2.55).or. + $ (ob_spd(iip1).lt.2.55.and. + $ ob_spd(iip2).lt.2.55))) then +c +c light and variable ok +c + else +c + c_qc(ii)(7:7) = 'B' + n_bad360(ktype) = n_bad360(ktype) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad north wind found-1-ii = ',ii + endif + endif + endif +c +c Check if previous ob from same flight +c ------------------------------------- + elseif(c_acftreg(ii)(1:8).eq.c_acftreg(iim1)(1:8).and. + $ c_acftid(ii)(1:8).eq.c_acftid(iim1)(1:8).and. + $ ob_dir(iim1).ne.amiss.and. + $ ob_spd(iim1).ne.amiss.and. + $ ifix(ob_dir(iim1)).ne.360.and. + $ ifix(ob_dir(iim1)).ne.0) then +c +c Reject ob if neighbor does not have a northerly wind +c ---------------------------------------------------- + if(ifix(ob_dir(iim1)).lt.270.and. + $ ifix(ob_dir(iim1)).gt.90) then +c + if(ob_spd(ii).lt.7.75.and. + $ ob_spd(iim1).lt.7.75.and. + $ abs(idt(ii)-idt(iim1)).gt.120) then +c +c light and variable ok +c + elseif(ob_spd(ii).lt.2.55.and. + $ ob_spd(iim1).lt.2.55) then +c +c light and variable ok +c + elseif(ob_spd(ii).lt.7.75.and. + $ ht_ft(ii).lt.10000.0.and. + $ (ht_ft(iim1)-ht_ft(ii)).gt.8000.0) then +c +c large shear in low-res descent probably ok +c + else +c + c_qc(ii)(7:7) = 'B' + n_bad360(ktype) = n_bad360(ktype) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad north wind found-2-ii = ',ii + endif + endif + endif +c +c Check if following ob from same flight +c -------------------------------------- + elseif(c_acftreg(ii)(1:8).eq.c_acftreg(iip1)(1:8).and. + $ c_acftid(ii)(1:8).eq.c_acftid(iip1)(1:8).and. + $ ob_dir(iip1).ne.amiss.and. + $ ob_spd(iip1).ne.amiss.and. + $ ifix(ob_dir(iip1)).ne.360.and. + $ ifix(ob_dir(iip1)).ne.0) then +c +c Reject ob if neighbor does not have a northerly wind +c ---------------------------------------------------- + if(ifix(ob_dir(iip1)).lt.270.and. + $ ifix(ob_dir(iip1)).gt.90) then +c + if(ob_spd(ii).lt.7.75.and. + $ ob_spd(iip1).lt.7.75.and. + $ abs(idt(ii)-idt(iip1)).gt.120) then +c +c light and variable ok +c + elseif(ob_spd(ii).lt.2.55.and. + $ ob_spd(iip1).lt.2.55) then +c +c light and variable ok +c + elseif(ob_spd(ii).lt.7.75.and. + $ ht_ft(ii).lt.10000.0.and. + $ (ht_ft(iip1)-ht_ft(ii)).gt.8000.0) then +c +c large shear in low-res ascent probably ok +c + else +c + c_qc(ii)(7:7) = 'B' + n_bad360(ktype) = n_bad360(ktype) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad north wind found-3-ii = ',ii + endif + endif + endif +c +c If neither ob is valid or from same flight, reject ob +c ----------------------------------------------------- + else +c + c_qc(ii)(7:7) = 'B' + n_bad360(ktype) = n_bad360(ktype) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad north wind found-4-ii = ',ii + endif + endif +c +c If first or last ob, reject ob +c ------------------------------ + else +c + c_qc(ii)(7:7) = 'B' + n_bad360(ktype) = n_bad360(ktype) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad north wind found-5-ii = ',ii + endif + endif +c +c Check for erroneous 180 deg wind directions +c ------------------------------------------- + elseif(ifix(ob_dir(ii)).eq.180.and. + $ itype(ii).ne.i_man_airep.and. + $ itype(ii).ne.i_man_Yairep) then +c +c Perform other checks if previous and following obs available +c ------------------------------------------------------------ + if(iim1.ne.0.and.iip1.ne.0) then +c +c Check if previous and following obs from same flight +c ---------------------------------------------------- + if(c_acftreg(ii)(1:8).eq.c_acftreg(iim1)(1:8).and. + $ c_acftid(ii)(1:8).eq.c_acftid(iim1)(1:8).and. + $ c_acftreg(ii)(1:8).eq.c_acftreg(iip1)(1:8).and. + $ c_acftid(ii)(1:8).eq.c_acftid(iip1)(1:8).and. + $ ob_dir(iim1).ne.amiss.and. + $ ifix(ob_dir(iim1)).ne.0.and. + $ ob_dir(iip1).ne.amiss.and. + $ ifix(ob_dir(iip1)).ne.0) then +c +c Reject ob if neither neighbor has a southerly component +c ------------------------------------------------------- + if((ifix(ob_dir(iim1)).lt.90.or. + $ ifix(ob_dir(iim1)).gt.270).and. + $ (ifix(ob_dir(iip1)).lt.90.or. + $ ifix(ob_dir(iip1)).gt.270)) then +c + if(ob_spd(ii).lt.7.75.and. + $ (ob_spd(iim1).lt.7.75.or. + $ ob_spd(iip1).lt.7.75).and. + $ abs(idt(ii)-idt(iim1)).gt.120.and. + $ abs(idt(ii)-idt(iip1)).gt.120) then +c +c light and variable ok +c + elseif(ob_spd(ii).lt.2.55.and. + $ (ob_spd(iim1).lt.2.55.or. + $ ob_spd(iip1).lt.2.55)) then +c +c light and variable ok +c + elseif(ob_spd(ii).lt.7.75.and. + $ ht_ft(ii).lt.10000.0.and. + $ (ht_ft(iim1)-ht_ft(ii)).gt.8000.0.and. + $ (ht_ft(iip1)-ht_ft(ii)).gt.8000.0) then +c +c large shear in low-res descent-ascent probably ok +c + else +c + c_qc(ii)(7:7) = 'B' + n_bad180(ktype) = n_bad180(ktype) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad south wind found-1-ii = ',ii + write(io8,*) 'dirs = ',ob_dir(iim1),ob_dir(ii) + $, ob_dir(iip1) + endif + endif + endif +c +c Check if previous ob from same flight +c ------------------------------------- + elseif(c_acftreg(ii)(1:8).eq.c_acftreg(iim1)(1:8).and. + $ c_acftid(ii)(1:8).eq.c_acftid(iim1)(1:8).and. + $ ob_dir(iim1).ne.amiss.and. + $ ifix(ob_dir(iim1)).ne.0) then +c +c Reject ob if neighbor does not have a southerly wind +c ---------------------------------------------------- + if(ifix(ob_dir(iim1)).lt.90.or. + $ ifix(ob_dir(iim1)).gt.270) then +c + if(ob_spd(ii).lt.7.75.and. + $ ob_spd(iim1).lt.7.75.and. + $ abs(idt(ii)-idt(iim1)).gt.120) then +c +c light and variable ok +c + elseif(ob_spd(ii).lt.2.55.and. + $ ob_spd(iim1).lt.2.55) then +c +c light and variable ok +c + elseif(ob_spd(ii).lt.7.75.and. + $ ht_ft(ii).lt.10000.0.and. + $ (ht_ft(iim1)-ht_ft(ii)).gt.8000.0) then +c +c large shear in low-res descent probably ok +c + else +c + c_qc(ii)(7:7) = 'B' + n_bad180(ktype) = n_bad180(ktype) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad south wind found-2-ii = ',ii + endif + endif + endif +c +c Check if following ob from same flight +c -------------------------------------- + elseif(c_acftreg(ii)(1:8).eq.c_acftreg(iip1)(1:8).and. + $ c_acftid(ii)(1:8).eq.c_acftid(iip1)(1:8).and. + $ ob_dir(iip1).ne.amiss.and. + $ ifix(ob_dir(iip1)).ne.0) then +c +c Reject ob if neighbor does not have a southerly wind +c ---------------------------------------------------- + if(ifix(ob_dir(iip1)).lt.90.or. + $ ifix(ob_dir(iip1)).gt.270) then +c + if(ob_spd(ii).lt.7.75.and. + $ ob_spd(iip1).lt.7.75.and. + $ abs(idt(ii)-idt(iim1)).gt.120) then +c +c light and variable ok +c + elseif(ob_spd(ii).lt.2.55.and. + $ ob_spd(iip1).lt.2.55) then +c +c light and variable ok +c + elseif(ob_spd(ii).lt.7.75.and. + $ ht_ft(ii).lt.10000.0.and. + $ (ht_ft(iip1)-ht_ft(ii)).gt.8000.0) then +c +c large shear in low-res ascent probably ok +c + else +c + c_qc(ii)(7:7) = 'B' + n_bad180(ktype) = n_bad180(ktype) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad south wind found-3-ii = ',ii + endif + endif + endif +c +c If neither ob is valid or from same flight, reject ob +c ----------------------------------------------------- + else +c + c_qc(ii)(7:7) = 'B' + n_bad180(ktype) = n_bad180(ktype) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad south wind found-4-ii = ',ii + endif + endif +c +c If first or last ob, reject ob +c ------------------------------ + else +c + c_qc(ii)(7:7) = 'B' + n_bad180(ktype) = n_bad180(ktype) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad south wind found-5-ii = ',ii + endif + endif + endif +c + endif +c +c Print selected rejected reports +c ------------------------------- + if(l_print) then +c +c if(iob.gt.1) then +c iim1 = indx(iob-1) +c else +c iim1 = indx(1) +c endif +c if(iob.lt.numreps) then +c iip1 = indx(iob+1) +c else +c iip1 = indx(numreps) +c endif +c + if(iim1.eq.0) iim1 = ii + if(iip1.eq.0) iip1 = ii +c + write(io8,8002) iim1,c_insty_ob(itype(iim1)) + x, c_acftreg(iim1),c_acftid(iim1) + x, idt(iim1),alat(iim1),alon(iim1) + x, pres(iim1),ht_ft(iim1) + x, t_prcn(iim1),ob_t(iim1),xiv_t(iim1),ichk_t(iim1) + x, ob_q(iim1),xiv_q(iim1),ichk_q(iim1) + x, ob_dir(iim1),xiv_d(iim1),ichk_d(iim1) + x, ob_spd(iim1),xiv_s(iim1),ichk_s(iim1) + x, c_qc(iim1) + write(io8,8002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + write(io8,8002) iip1,c_insty_ob(itype(iip1)) + x, c_acftreg(iip1),c_acftid(iip1) + x, idt(iip1),alat(iip1),alon(iip1) + x, pres(iip1),ht_ft(iip1) + x, t_prcn(iip1),ob_t(iip1),xiv_t(iip1),ichk_t(iip1) + x, ob_q(iip1),xiv_q(iip1),ichk_q(iip1) + x, ob_dir(iip1),xiv_d(iip1),ichk_d(iip1) + x, ob_spd(iip1),xiv_s(iip1),ichk_s(iip1) + x, c_qc(iip1) + 8002 format(i6,1x,a8,1x,a8,1x,a9,1x,i7,1x,2f11.5,1x + x, f8.1,1x,f7.0,1x,f5.2,4(2(1x,f8.2),1x,i5),1x + x, '!',a11,'!') + endif +c +c End loop over reports +c --------------------- + enddo +c +c Write out bad reports +c --------------------- + if(.not.l_operational) then + write(io32,*) + write(io32,*) 'Invalid reports' + write(io32,*) '---------------' + write(io32,3001) + 3001 format(' index type tail num flight time lat' + x, ' lon pres height ' + x, 't-prcn temp innov ichk' + x, ' spec hum innov ichk' + x, ' ob_dir innov ichk' + x, ' ob_spd innov ichk' + x, ' qc flag') + endif +c + kbad = 0 +c +c Loop over reports +c ----------------- + do iob = 1,numreps + ii = indx(iob) +c +c Count number of reports considered +c ---------------------------------- + if(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_des) then + nrep_Ac = nrep_Ac + 1 + elseif(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_des) then + nrep_Md = nrep_Md + 1 + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + nrep_Ma = nrep_Ma + 1 + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_des) then + nrep_Ar = nrep_Ar + 1 + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_des) then + nrep_Am = nrep_Am + 1 + else + write(io8,*) + write(io8,*) 'Bad itype: ',itype(ii),' for ii = ',ii + endif +c +c Count number of reports rejected as invalid +c ------------------------------------------- + if(c_qc(ii)(1:1).eq.'B'.or. + $ c_qc(ii)(5:5).eq.'B'.or. + $ c_qc(ii)(2:2).eq.'M'.or. + $ c_qc(ii)(3:3).eq.'M'.or. + $ c_qc(ii)(4:4).eq.'M'.or. + $ c_qc(ii)(5:5).eq.'M'.or. + $ c_qc(ii)(6:8).eq.'MMM'.or. + $ c_qc(ii)(3:4).eq.'BB') then +c + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_des) then + nbad_Md = nbad_Md + 1 + ktype = 1 +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_des) then + nbad_Ac = nbad_Ac + 1 + ktype = 2 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_des) then + nbad_Am = nbad_Am + 1 + ktype = 3 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_des) then + nbad_Ar = nbad_Ar + 1 + ktype = 4 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + nbad_Ma = nbad_Ma + 1 + ktype = 5 +c + else + write(io8,*) + write(io8,*) 'Bad itype: ',itype(ii),' for ii = ',ii + endif +c +c Flag bad report for reorder subroutine and output rejects +c --------------------------------------------------------- + csort(ii)(1:5) = 'badob' +c + kbad(ktype) = kbad(ktype) + 1 +c + if(.not.l_operational) then + write(io32,3002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + 3002 format(i6,1x,a8,1x,a8,1x,a9,1x,i7,1x,2f11.5,1x,f8.1,1x,f7.0 + x, 1x,f5.2,4(2(1x,f8.2),1x,i5),1x,'!',a11,'!') + endif + endif + enddo +c +c Loop over reports +c ----------------- + if(.not.l_operational) then + write(io32,*) + write(io32,*) 'Invalid temperatures (-9C)' + write(io32,*) '--------------------------' + write(io32,3001) +c + do iob = 1,numreps + ii = indx(iob) +c +c Count number of reports rejected as invalid +c ------------------------------------------- + if(c_qc(ii)(6:6).eq.'I') then +c +c Output rejected temperatures +c ---------------------------- + write(io32,3002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) +c +c Count number of rejected temps by tail number +c --------------------------------------------- + mm = 1 + do while(mm.le.kreg) + if(c_acftreg(ii).eq.creg_reg(mm)) then +c + if(ktype.gt.0.and.ktype.le.5) then + ntemp_reg(mm,ktype) = ntemp_reg(mm,ktype) + 1 + endif + mm = kreg + 1 + endif + mm = mm + 1 + enddo + endif + enddo + endif +c +c Output statistics +c ----------------- + if(.not.l_operational) then + write(io32,*) + write(io32,*)' Number of invalid MDCRS reps rejected = ' + $, kbad(1) +ccccdak write(io32,*)' Number of invalid ACARS reps rejected = ' + write(io32,*)' Number of invalid TAMDAR reps rejected = ' + $, kbad(2) + write(io32,*)' Number of invalid AMDAR reps rejected = ' + $, kbad(3) + write(io32,*)' Number of invalid AIREP reps rejected = ' + $, kbad(4) + write(io32,*)' Number of invalid manAIREP reps rejected = ' + $, kbad(5) + endif +c + write(io8,*) + write(io8,*) ' Invalid reports--rejected' + write(io8,*) ' -------------------------' + write(io8,*)' Number of invalid MDCRS reps rejected = ' + $, kbad(1) +ccccdak write(io8,*)' Number of invalid ACARS reps rejected = ' + write(io8,*)' Number of invalid TAMDAR reps rejected = ' + $, kbad(2) + write(io8,*)' Number of invalid AMDAR reps rejected = ' + $, kbad(3) + write(io8,*)' Number of invalid AIREP reps rejected = ' + $, kbad(4) + write(io8,*)' Number of invalid manAIREP reps rejected = ' + $, kbad(5) +c +c Output detailed stats +c --------------------- + write(*,*) + write(*,*) 'Invalid check data counts--',cdtg_an + write(*,*) '-------------------------------------' + write(*,'(1x,a55)') +ccccdak $ 'Type of check MDCRS ACARS AMDAR AIREP man' + $ 'Type of check MDCRS TAMDAR AMDAR AIREP man' + write(*,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(*,'('' Num considered '',5(1x,i7))') + $ nrep_Md,nrep_Ac,nrep_Am,nrep_Ar,nrep_Ma + write(*,'('' Total invalid '',5(1x,i7))') + $ nbad_Md,nbad_Ac,nbad_Am,nbad_Ar,nbad_Ma + write(*,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + write(io8,*) + write(io8,*) 'Invalid check data counts' + write(io8,*) '-------------------------' + write(io8,'(1x,a55)') +ccccdak $ 'Type of check MDCRS ACARS AMDAR AIREP man' + $ 'Type of check MDCRS TAMDAR AMDAR AIREP man' + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Num considered '',5(1x,i7))') + $ nrep_Md,nrep_Ac,nrep_Am,nrep_Ar,nrep_Ma + write(io8,'(''Total invalid '',5(1x,i7))') + $ nbad_Md,nbad_Ac,nbad_Am,nbad_Ar,nbad_Ma + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Empty reports '',5(1x,i7))') + $ n_empty(1),n_empty(2),n_empty(3),n_empty(4),n_empty(5) + write(io8,'(''Zero tmp/winds '',5(1x,i7))') n_zero_tmp(1) + $, n_zero_tmp(2),n_zero_tmp(3),n_zero_tmp(4),n_zero_tmp(5) + write(io8,'(''Zero alt/winds '',5(1x,i7))') n_zero_alt(1) + $, n_zero_alt(2),n_zero_alt(3),n_zero_alt(4),n_zero_alt(5) + write(io8,'(''Zero lat/lon '',5(1x,i7))') n_zero_pos(1) + $, n_zero_pos(2),n_zero_pos(3),n_zero_pos(4),n_zero_pos(5) + write(io8,'(''Missing ids '',24x,2(1x,i7),8x)') + $ n_xx999_Ar,n_xx999_Ma + write(io8,'(''Blank ids '',1x,i7,8x,3(1x,i7))') + $ n_blank_Md,n_blank_Am,n_blank_Ar,n_blank_Ma + write(io8,'(''Bad decode '',5(1x,i7))') + $ n_bad_decode(1),n_bad_decode(2),n_bad_decode(3) + $, n_bad_decode(4),n_bad_decode(5) + write(io8,'(''Missing time '',5(1x,i7))') + $ n_miss_time(1),n_miss_time(2),n_miss_time(3) + $, n_miss_time(4),n_miss_time(5) + write(io8,'(''Missing pos '',5(1x,i7))') + $ n_miss_pos(1),n_miss_pos(2),n_miss_pos(3) + $, n_miss_pos(4),n_miss_pos(5) + write(io8,'(''Missing pres '',5(1x,i7))') + $ n_miss_pres(1),n_miss_pres(2),n_miss_pres(3) + $, n_miss_pres(4),n_miss_pres(5) + write(io8,'(''Small pres '',5(1x,i7))') + $ n_small_pres(1),n_small_pres(2),n_small_pres(3) + $, n_small_pres(4),n_small_pres(5) + write(io8,'(''Low AIREPs '',5(1x,i7))') + $ n_low_airep(1),n_low_airep(2),n_low_airep(3) + $, n_low_airep(4),n_low_airep(5) + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''-9C temps '',5(1x,i7))') + $ n_minus9C(1),n_minus9C(2),n_minus9C(3) + $, n_minus9C(4),n_minus9C(5) + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Bad north wind '',5(1x,i7))') + $ n_bad360(1),n_bad360(2),n_bad360(3) + $, n_bad360(4),n_bad360(5) + write(io8,'(''Bad south wind '',5(1x,i7))') + $ n_bad180(1),n_bad180(2),n_bad180(3) + $, n_bad180(4),n_bad180(5) + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + kbadtot = kbad(1) + kbad(2) + kbad(3) + $ + kbad(4) + kbad(5) +c + write(io8,*) + write(io8,*) numreps,' good reports processed' + write(io8,*) kbadtot,' reports failed qc in invalid check' +c + return + end +c +c ################################################################### +c subroutine stk_val_qc +c ################################################################### +c + subroutine stk_val_qc(numreps,max_reps,indx,csort,amiss,cdtg_an + $, c_acftreg,c_acftid,c_qc + $, alat,alon,pres,ht_ft,t_prcn,ob_t,ob_q,ob_dir,ob_spd + $, xiv_t,xiv_q,xiv_d,xiv_s + $, idt,itype,ichk_t,ichk_q,ichk_d,ichk_s + $, kflight,maxflt,nobs_flt,iobs_flt + $, kreg,creg_reg,nwhol_reg,ntemp_reg,nwind_reg + $, kbadtot,io8,io33,l_operational,l_init,l_ncep) +c +c Check for flights with stuck values +c (defined as a flight with three or more reports where all reports have the +c same time, lat, lon, pres, ob_t, ob_dir, or ob_spd) +c + implicit none +c +c Declaration statements +c ---------------------- + integer max_reps ! maximum number of reports +c + character*11 c_qc(max_reps) ! internal qc flags +c +c Data arrays +c ----------- + integer numreps ! actual number of reports + character*10 cdtg_an ! date time group for analysis + integer itype(max_reps) ! type of aircraft data + integer idt(max_reps) ! time in seconds to analysis time + character*8 c_acftreg(max_reps) ! aircraft registration (tail) number + character*9 c_acftid(max_reps) ! aircraft flight number + real*8 alat(max_reps) ! latitude + $, alon(max_reps) ! longitude + real pres(max_reps) ! pressure + $, ht_ft(max_reps) ! height in feet + real t_prcn(max_reps) ! temperature precision + real ob_t(max_reps) ! temperature + $, ob_q(max_reps) ! specific humidity + $, ob_dir(max_reps) ! wind direction + $, ob_spd(max_reps) ! wind speed + real xiv_t(max_reps) ! temperature innovation (ob - bk) + $, xiv_q(max_reps) ! specific humidity innovation (ob - bk) + $, xiv_d(max_reps) ! wind direction innovation (ob - bk) + $, xiv_s(max_reps) ! wind speed innovation (ob - bk) + integer ichk_t(max_reps) ! NRL QC flag for temperature ob + $, ichk_q(max_reps) ! NRL QC flag for specific humidity ob + $, ichk_d(max_reps) ! NRL QC flag for wind direction ob + $, ichk_s(max_reps) ! NRL QC flag for wind speed ob + character*25 csort(max_reps) ! sort variable +c +c Pointers +c -------- + integer indx(max_reps) ! pointer index for good reports +c +c Functions +c --------- + character*16 c_insty_ob ! function to convert integer instrument + ! type to character instrument type + integer insty_ob_fun ! function to convert character + ! instrument type to integer +c +c Flight statistics +c ----------------- + integer maxflt ! max number of flights allowed + integer nobs_flt(maxflt) ! number of reports per flight + $, iobs_flt(maxflt) ! index for first report in each flight + $, kflight ! number of flights in dataset + integer istart ! index for 1st rep in current flight + $, iistart ! index from pointer array for istart + $, iend ! index for last rep in current flight + $, iiend ! index from pointer array for iend +c +c Tail number statistics +c ---------------------- + integer kreg ! actual number of tail#s in dataset + $, mreg ! index pointing to current tail number + character*8 creg_reg(maxflt) ! tail numbers + integer nwhol_reg(maxflt,5) ! number of reports w. temp in whole deg + integer ntemp_reg(maxflt,5) ! number of reports w. rejected temp + integer nwind_reg(maxflt,5) ! number of reports w. rejected winds +c +c Counters +c -------- + integer nstk_time(5) ! number of reports with stuck time + $, nstk_both(5) ! number of reports with both stuck time and position + $, nstk_posn(5) ! number of reports with stuck position + $, nstk_alat(5) ! number of reports with stuck latitude + $, nstk_alon(5) ! number of reports with stuck longitude + $, nstk_pres(5) ! number of reports with stuck pressure + $, nstk_val(5) ! number of reports with stuck temp and winds + $, nstk_temp(5) ! number of reports with stuck temperature + $, nstk_wdir(5) ! number of reports with stuck direction + $, nstk_wspd(5) ! number of reports with stuck speed + $, nstk_moist(5) ! number of reports with stuck moisture + $, nstk_whol(5) ! number of reports w. temp in whole deg + integer kbad(5) ! counter for number of bad reports + $, kbadt(5) ! counter for number of bad temperatures + $, kbadw(5) ! counter for number of bad winds + $, kbadtot ! counter for total number of bad reports +ccccdak integer nrep_Ac ! number of acars reports considered + integer nrep_Ac ! number of tamdar reports considered + $, nrep_Md ! number of mdcrs reports considered + $, nrep_Ma ! number of manual airep reports considered + $, nrep_Ar ! number of airep reports considered + $, nrep_Am ! number of amdar reports considered +ccccdak integer nstk_Ac ! number of acars reports rejected + integer nstk_Ac ! number of tamdar reports rejected + $, nstk_Md ! number of mdcrs reports rejected + $, nstk_Ma ! number of manual airep reports rejected + $, nstk_Ar ! number of airep reports rejected + $, nstk_Am ! number of amdar reports rejected +c +c Instrument types +c ---------------- +ccccdak integer i_acars ! instrument type for acars + integer i_acars ! instrument type for tamdar +ccccdak $, i_acars_lvl ! instrument type for acars--level flt + $, i_acars_lvl ! instrument type for tamdar--level flt +ccccdak $, i_acars_asc ! instrument type for acars--ascent + $, i_acars_asc ! instrument type for tamdar--ascent +ccccdak $, i_acars_des ! instrument type for acars--descent + $, i_acars_des ! instrument type for tamdar--descent + $, i_mdcrs ! instrument type for mdcrs + $, i_mdcrs_lvl ! instrument type for mdcrs--level flt + $, i_mdcrs_asc ! instrument type for mdcrs--ascent + $, i_mdcrs_des ! instrument type for mdcrs--descent + $, i_man_airep ! instrument type for manual aireps + $, i_man_Yairep ! instrument type for manual aireps (YRXX) + $, i_airep ! instrument type for airep + $, i_airep_lvl ! instrument type for airep--level flt + $, i_airep_asc ! instrument type for airep--ascent + $, i_airep_des ! instrument type for airep--descent + $, i_amdar ! instrument type for amdar + $, i_amdar_lvl ! instrument type for amdar--level flt + $, i_amdar_asc ! instrument type for amdar--ascent + $, i_amdar_des ! instrument type for amdar--descent +c +c Other variables +c --------------- + integer io8 ! i/o unit number for log file + integer io33 ! i/o unit number for stuck check +c + real amiss ! real missing value flag +c + integer iob,kk,mm ! do loop indices + $, ii,jj ! index pointing to current report + $, iim1 ! index pointing to previous report + $, iobfirst ! index for first stuck time + $, ioblast ! index for last stuck time + $, iifirst ! index for first stuck latitude + $, iilast ! index for last stuck latitude +c +ccccdak integer k_ACARS ! number of ACARS/MDCRS reports + integer k_ACARS ! number of TAMDAR/MDCRS reports + $, k_AIREP ! number of AIREP reports + $, k_manAIREP ! number of manual AIREP reports + $, k_AMDAR ! number of AMDAR reports + $, k_stuck ! counter for number of stuck reports + $, ktype ! ob type +c + integer istk_time ! value of stuck clock + real*8 alat_min ! min value of latitude during flight + $, alat_max ! max value of latitude during flight + $, alon_min ! min value of longitude during flight + $, alon_max ! max value of longitude during flight + $, stk_alat ! value of stuck latitude + $, stk_alon ! value of stuck longitude + real ht_max ! max height during flight + $, ht_min ! min height during flight + $, ht_max_stuck ! max height during stuck portion + $, ht_min_stuck ! min height during stuck portion + $, temp_min ! min temperature during flight + $, temp_max ! max tempetature during flight + $, ob_min ! min value of parameter during flight + $, ob_max ! max value of parameter during flight + $, stk_pres ! value of stuck pressure + $, stk_alt ! value of stuck altitude + $, stk_temp ! value of stuck temperature + $, stk_wdir ! value of stuck direction + $, stk_wspd ! value of stuck speed + $, stk_moist ! value of stuck moisture +c +c Switches +c -------- + logical stuck ! true if variable found to be stuck +c + logical l_init ! initialize counters if true + $, l_operational ! run QC in operational mode if true + $, l_ncep ! run QC w/ NCEP preferences if true +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c +c Initialize aircraft data types +c ------------------------------ + i_acars = insty_ob_fun('acars') + i_acars_lvl = insty_ob_fun('acars_lvl') + i_acars_asc = insty_ob_fun('acars_asc') + i_acars_des = insty_ob_fun('acars_des') + i_mdcrs = insty_ob_fun('mdcrs') + i_mdcrs_lvl = insty_ob_fun('mdcrs_lvl') + i_mdcrs_asc = insty_ob_fun('mdcrs_asc') + i_mdcrs_des = insty_ob_fun('mdcrs_des') + i_man_airep = insty_ob_fun('man-airep') + i_man_Yairep = insty_ob_fun('man-Yairep') + i_airep = insty_ob_fun('airep') + i_airep_lvl = insty_ob_fun('airep_lvl') + i_airep_asc = insty_ob_fun('airep_asc') + i_airep_des = insty_ob_fun('airep_des') + i_amdar = insty_ob_fun('amdar') + i_amdar_lvl = insty_ob_fun('amdar_lvl') + i_amdar_asc = insty_ob_fun('amdar_asc') + i_amdar_des = insty_ob_fun('amdar_des') +c +c Initialize counters +c ------------------- + if(l_init) then + nstk_time = 0 + nstk_both = 0 + nstk_posn = 0 + nstk_alat = 0 + nstk_alon = 0 + nstk_pres = 0 + nstk_val = 0 + nstk_temp = 0 + nstk_wdir = 0 + nstk_wspd = 0 + nstk_moist = 0 +c + nstk_whol = 0 + kbadt = 0 + kbadw = 0 + nrep_Ac = 0 + nrep_Md = 0 + nrep_Ma = 0 + nrep_Ar = 0 + nrep_Am = 0 + nstk_Ac = 0 + nstk_Md = 0 + nstk_Ma = 0 + nstk_Ar = 0 + nstk_Am = 0 + endif +c + nwhol_reg = 0 + ntemp_reg = 0 + nwind_reg = 0 +c +c Begin loop over flights +c ----------------------- + do kk = 1,kflight +c +c Initialize variables +c -------------------- + istart = iobs_flt(kk) + iistart = indx(istart) + iend = iobs_flt(kk) + nobs_flt(kk) - 1 + iiend = indx(iend) +c +c Handle case where only one or two reports are present for flight +c ---------------------------------------------------------------- + if(nobs_flt(kk).eq.0) then +c write(io8,*) +c write(io8,*) 'No good obs for flight ',kflight + elseif(nobs_flt(kk).eq.1) then +c write(io8,*) +c write(io8,*) 'Only one report present for flight ',kflight + elseif(nobs_flt(kk).eq.2) then +c write(io8,*) +c write(io8,*) 'Only two reports present for flight ',kflight +c +c Handle case where three or more reports are present for flight +c -------------------------------------------------------------- + else +c +c Check if clock is stuck +c (ignore both single manAIREPs, and whole flights of manAIREPs) +c -------------------------------------------------------------- + k_ACARS = 0 + k_AIREP = 0 + k_manAIREP = 0 + k_AMDAR = 0 + ht_min = ht_ft(iistart) + ht_max = ht_ft(iistart) + temp_min = ob_t(iistart) + temp_max = ob_t(iistart) +c +ccccdak First find first ACARS/MDCRS/AIREP report and count reports by category +c First find first TAMDAR/MDCRS/AIREP report and count reports by category +c ------------------------------------------------------------------------ + do iob=istart,iend + ii = indx(iob) + if(ht_ft(ii).lt.ht_min) ht_min = ht_ft(ii) + if(ht_ft(ii).gt.ht_max) ht_max = ht_ft(ii) + if(ob_t(ii).lt.temp_min) temp_min = ob_t(ii) + if(ob_t(ii).gt.temp_max) temp_max = ob_t(ii) +c + if(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des.or. + $ itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des) then +c + k_ACARS = k_ACARS + 1 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des) then +c + k_AIREP = k_AIREP + 1 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des) then +c + k_AMDAR = k_AMDAR + 1 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then +c + k_manAIREP = k_manAIREP + 1 +c + endif + enddo +c +ccccdak If more than 3 ACARS/MDCRS/AIREP/AMDAR reports are present, look for stuck clock +c If more than 3 TAMDAR/MDCRS/AIREP/AMDAR reports are present, look for stuck clock +c --------------------------------------------------------------------------------- + if((k_ACARS+k_AIREP+k_AMDAR).ge.3) then + stuck = .true. + k_stuck = 0 + istk_time = -999 999 + iobfirst = -999 999 + ioblast = -999 999 + ht_min_stuck = 999 999. + ht_max_stuck = -999 999. +c + do iob=istart+1,iend + ii = indx(iob) + iim1 = indx(iob-1) +c +c Skip over isolated man_airep reports +c ------------------------------------ + if((itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep).and. + $ k_ACARS+k_AIREP+k_AMDAR.gt.0) then +c +c Set "stuck" to false if times not equal and re-initialize stats +c --------------------------------------------------------------- + elseif(idt(iim1).ne.idt(ii)) then +c +c If a portion of the flight is stuck, set QC flags +c ------------------------------------------------- + if(k_stuck.ge.3.and. + $ istk_time.ne.-999 999.and. + $ ((istk_time.eq.0.and. + $ (itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des.or. + $ itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des)).or. + $ ht_max_stuck-ht_min_stuck.lt.100..or. + $ ht_max_stuck-ht_min_stuck.gt.9000.) ) then +c + do jj=iobfirst,ioblast + ii = indx(jj) + c_qc(ii)(2:2) = 'K' + enddo +c + write(io8,*) + write(io8,*) 'Flight with > 3 constant times' + do jj=istart,iend + ii = indx(jj) + write(io8,3002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + enddo + endif +c + stuck = .false. + k_stuck = 0 + istk_time = -999 999 + iobfirst = -999 999 + ioblast = -999 999 + ht_min_stuck = 999 999. + ht_max_stuck = -999 999. +c +c Accumulate statistics for stuck segments +c ---------------------------------------- + else + k_stuck = k_stuck + 1 + istk_time = idt(ii) + if(iobfirst.eq.-999 999) then + iobfirst = iob-1 + if(ht_ft(iim1).lt.ht_min_stuck) + $ ht_min_stuck = ht_ft(iim1) + if(ht_ft(iim1).gt.ht_max_stuck) + $ ht_max_stuck = ht_ft(iim1) + endif + ioblast = iob + if(ht_ft(ii).lt.ht_min_stuck) ht_min_stuck = ht_ft(ii) + if(ht_ft(ii).gt.ht_max_stuck) ht_max_stuck = ht_ft(ii) + endif + enddo +c +c If entire flight is stuck and flight is long enough, set QC flags +c ----------------------------------------------------------------- + if(stuck.and. + $ ((k_ACARS+k_AIREP+k_AMDAR).ge.3.or. + $ (k_ACARS+k_AIREP+k_AMDAR).eq.0).and. + $ (idt(iistart).eq.0.or. + $ ht_max-ht_min.lt.100..or. + $ ht_max-ht_min.gt.9000.)) then +c + do iob=istart,iend + ii = indx(iob) + c_qc(ii)(2:2) = 'K' + enddo +c +c Otherwise, if only a portion of the flight is stuck, set QC flags +c ----------------------------------------------------------------- + elseif(k_stuck.ge.3.and. + $ istk_time.ne.-999 999.and. + $ ((istk_time.eq.0.and. + $ (itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des.or. + $ itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des)).or. + $ ht_max_stuck-ht_min_stuck.lt.100..or. + $ ht_max_stuck-ht_min_stuck.gt.9000.) ) then +c + do iob=iobfirst,ioblast + ii = indx(iob) + c_qc(ii)(2:2) = 'K' + enddo +c + write(io8,*) + write(io8,*) 'Flight with > 3 constant times' + do iob=istart,iend + ii = indx(iob) + write(io8,3002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + enddo + endif + endif +c +c Perform remaining tests only for flights with four or more reports +c ------------------------------------------------------------------ + if(nobs_flt(kk).gt.3) then +c +c Check if position is stuck +c -------------------------- + stuck = .true. + k_stuck = 0 +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + stk_alat = -999 999 + stk_alon = -999 999 + iobfirst = -999 999 + ioblast = -999 999 + iifirst = -999 999 + iilast = -999 999 + alat_min = 999 999 + alat_max = -999 999 + alon_min = 999 999 + alon_max = -999 999 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_min_stuck = 999 999 + ht_max_stuck = -999 999 +c + do iob=istart+1,iend + ii = indx(iob) + iim1 = indx(iob-1) +c +c Skip over isolated man_airep reports +c ------------------------------------ + if((itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep).and. + $ k_ACARS+k_AIREP+k_AMDAR.gt.0) then +c +c Skip over reports with previously averaged positions +c ---------------------------------------------------- + elseif(ichk_t(ii).eq.-4) then +!vvvv^ DAK-future change perhaps to account for incr. lat/lon precision +c +c Set "stuck" to false if lat/lons not equal and re-initialize stats +c ------------------------------------------------------------------ + elseif((abs(alat(iim1)-alat(ii)).gt.0.015.and. + $ alat(iim1).ne.amiss.and. + $ alat(ii).ne.amiss).or. + $ (abs(alon(iim1)-alon(ii)).gt.0.015.and. + $ alon(iim1).ne.amiss.and. + $ alon(ii).ne.amiss)) then +c +c If a portion of the flight is stuck, set QC flags +c ------------------------------------------------- + if(k_stuck.ge.3.and. + $ stk_alat.ne.-999 999.and. + $ stk_alon.ne.-999 999.and. + $ stk_alat.ne.amiss.and. + $ stk_alon.ne.amiss.and. + $ abs(alat_max-alat_min).lt.0.015.and. + $ abs(alon_max-alon_min).lt.0.015.and. + $ (abs(stk_alat).lt.0.005.or. + $ abs(stk_alon).lt.0.005.or. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ ht_max_stuck-ht_min_stuck.lt.100..or. + $ ((itype(ii).ne.i_amdar.and. + $ itype(ii).ne.i_amdar_lvl.and. + $ itype(ii).ne.i_amdar_asc.and. + $ itype(ii).ne.i_amdar_des).and. + $ ht_max_stuck-ht_min_stuck.gt.9000.).or. + $ ((itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des).and. + $ ht_max_stuck-ht_min_stuck.gt.12000.)) ) then +c + do jj=iobfirst,ioblast + ii = indx(jj) + c_qc(ii)(3:4) = 'KK' + enddo +c + write(io8,*) + write(io8,*) 'Flight with > 3 constant positions' + do jj=istart,iend + ii = indx(jj) + write(io8,3002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + enddo + endif +c + stuck = .false. + k_stuck = 0 +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + stk_alat = -999 999 + stk_alon = -999 999 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + iobfirst = -999 999 + ioblast = -999 999 + iifirst = -999 999 + iilast = -999 999 +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + alat_min = 999 999 + alat_max = -999 999 + alon_min = 999 999 + alon_max = -999 999 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_min_stuck = 999 999 + ht_max_stuck = -999 999 +c +c Accumulate statistics for stuck segments +c ---------------------------------------- + else +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + k_stuck = k_stuck + 1 + stk_alat = alat(ii) + stk_alon = alon(ii) + if(iobfirst.eq.-999 999) then + iobfirst = iob-1 + if(alat(iim1).lt.alat_min.and. + $ alat(iim1).ne.amiss) alat_min = alat(iim1) + if(alat(iim1).gt.alat_max.and. + $ alat(iim1).ne.amiss) alat_max = alat(iim1) + if(alon(iim1).lt.alon_min.and. + $ alon(iim1).ne.amiss) alon_min = alon(iim1) + if(alon(iim1).gt.alon_max.and. + $ alon(iim1).ne.amiss) alon_max = alon(iim1) + if(ht_ft(iim1).lt.ht_min_stuck) + $ ht_min_stuck = ht_ft(iim1) + if(ht_ft(iim1).gt.ht_max_stuck) + $ ht_max_stuck = ht_ft(iim1) + endif + ioblast = iob + if(iifirst.eq.-999 999) iifirst = iim1 + iilast = ii + if(alat(ii).lt.alat_min.and. + $ alat(ii).ne.amiss) alat_min = alat(ii) + if(alat(ii).gt.alat_max.and. + $ alat(ii).ne.amiss) alat_max = alat(ii) + if(alon(ii).lt.alon_min.and. + $ alon(ii).ne.amiss) alon_min = alon(ii) + if(alon(ii).gt.alon_max.and. + $ alon(ii).ne.amiss) alon_max = alon(ii) + if(ht_ft(ii).lt.ht_min_stuck) ht_min_stuck = ht_ft(ii) + if(ht_ft(ii).gt.ht_max_stuck) ht_max_stuck = ht_ft(ii) + endif + enddo +c +c If entire flight is stuck and flight is long enough, set QC flags +c ----------------------------------------------------------------- + if(stuck.and. + $ alat(iistart).ne.amiss.and. + $ alon(iistart).ne.amiss.and. + $ abs(alat_max-alat_min).lt.0.015.and. + $ abs(alon_max-alon_min).lt.0.015.and. + $ (k_ACARS+k_AIREP+k_AMDAR.ge.3.or. + $ k_ACARS+k_AIREP+k_AMDAR.eq.0).and. + $ (abs(alat(iistart)).lt.0.005.or. + $ abs(alon(iistart)).lt.0.005.or. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ ht_max-ht_min.lt.100..or. + $ ((itype(ii).ne.i_amdar.and. + $ itype(ii).ne.i_amdar_lvl.and. + $ itype(ii).ne.i_amdar_asc.and. + $ itype(ii).ne.i_amdar_des).and. + $ ht_max-ht_min.gt.9000.).or. + $ ((itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des).and. + $ ht_max-ht_min.gt.12000.)) ) then +c + do iob=istart,iend + ii = indx(iob) + c_qc(ii)(3:4) = 'KK' + enddo +c +c Otherwise, if only a portion of the flight is stuck, set QC flags +c ----------------------------------------------------------------- + elseif(k_stuck.ge.3.and. +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + $ stk_alat.ne.-999 999.and. + $ stk_alon.ne.-999 999.and. + $ stk_alat.ne.amiss.and. + $ stk_alon.ne.amiss.and. + $ abs(alat_max-alat_min).lt.0.015.and. + $ abs(alon_max-alon_min).lt.0.015.and. + $ (abs(stk_alat).lt.0.005.or. + $ abs(stk_alon).lt.0.005.or. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ ht_max_stuck-ht_min_stuck.lt.100..or. + $ ((itype(ii).ne.i_amdar.and. + $ itype(ii).ne.i_amdar_lvl.and. + $ itype(ii).ne.i_amdar_asc.and. + $ itype(ii).ne.i_amdar_des).and. + $ ht_max_stuck-ht_min_stuck.gt.9000.).or. + $ ((itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des).and. + $ ht_max_stuck-ht_min_stuck.gt.12000.)) ) then +c + do iob=iobfirst,ioblast + ii = indx(iob) + c_qc(ii)(3:4) = 'KK' + enddo +c + write(io8,*) + write(io8,*) 'Flight with > 3 constant positions' + do iob=istart,iend + ii = indx(iob) + write(io8,3002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + enddo + endif +c +c Check if latitude is stuck +c -------------------------- + stuck = .true. + k_stuck = 0 +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + stk_alat = -999 999 + iobfirst = -999 999 + ioblast = -999 999 + iifirst = -999 999 + iilast = -999 999 + alat_min = 999 999 + alat_max = -999 999 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_min_stuck = 999 999 + ht_max_stuck = -999 999 +c + do iob=istart+1,iend + ii = indx(iob) + iim1 = indx(iob-1) +c +c Skip over isolated man_airep reports +c ------------------------------------ + if((itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep).and. + $ k_ACARS+k_AIREP+k_AMDAR.gt.0) then +c +c Skip over reports with previously averaged positions +c ---------------------------------------------------- + elseif(ichk_t(ii).eq.-4) then +c +! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c Set "stuck" to false if lats not equal and re-initialize stats +c -------------------------------------------------------------- + elseif(abs(alat(iim1)-alat(ii)).gt.0.005.and. + $ alat(iim1).ne.amiss.and. + $ alat(ii).ne.amiss) then +cc +cc If a portion of the flight is stuck, set QC flags +cc ------------------------------------------------- +c if(k_stuck.ge.3.and. +c $ stk_alat.ne.-999 999.and. +c $ stk_alat.ne.amiss.and. +c $ abs(alat_max-alat_min).lt.0.005.and. +c $ abs(nint(stk_alat)-stk_alat).gt.0.005.and. +c $ abs(idt(iilast)-idt(iifirst)).gt.1800.and. +c $ (abs(stk_alat).lt.0.005.or. +c $ ht_max_stuck-ht_min_stuck.lt.100..or. +c $ ht_max_stuck-ht_min_stuck.gt.9000.) ) then +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +cc +c do jj=iobfirst,ioblast +c ii = indx(jj) +c c_qc(ii)(3:3) = 'K' +c enddo +cc +c write(io8,*) +c write(io8,*) 'Flight with > 3 constant latitudes' +c do jj=istart,iend +c ii = indx(jj) +c write(io8,3002) ii,c_insty_ob(itype(ii)) +c x, c_acftreg(ii),c_acftid(ii) +c x, idt(ii),alat(ii),alon(ii) +c x, pres(ii),ht_ft(ii) +c x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) +c x, ob_q(ii),xiv_q(ii),ichk_q(ii) +c x, ob_dir(ii),xiv_d(ii),ichk_d(ii) +c x, ob_spd(ii),xiv_s(ii),ichk_s(ii) +c x, c_qc(ii) +c enddo +c endif +c + stuck = .false. + k_stuck = 0 +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + stk_alat = -999 999 + iobfirst = -999 999 + ioblast = -999 999 + iifirst = -999 999 + iilast = -999 999 + alat_min = 999 999 + alat_max = -999 999 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_min_stuck = 999 999 + ht_max_stuck = -999 999 +c +c Accumulate statistics for stuck segments +c ---------------------------------------- + elseif(c_qc(ii)(3:3).ne.'K') then + k_stuck = k_stuck + 1 +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + stk_alat = alat(ii) + if(iobfirst.eq.-999 999) then + iobfirst = iob-1 + if(alat(iim1).lt.alat_min.and. + $ alat(iim1).ne.amiss) alat_min = alat(iim1) + if(alat(iim1).gt.alat_max.and. + $ alat(iim1).ne.amiss) alat_max = alat(iim1) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + if(ht_ft(iim1).lt.ht_min_stuck) + $ ht_min_stuck = ht_ft(iim1) + if(ht_ft(iim1).gt.ht_max_stuck) + $ ht_max_stuck = ht_ft(iim1) + endif + ioblast = iob + if(iifirst.eq.-999 999) iifirst = iim1 + iilast = ii +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alat(ii).lt.alat_min.and. + $ alat(ii).ne.amiss) alat_min = alat(ii) + if(alat(ii).gt.alat_max.and. + $ alat(ii).ne.amiss) alat_max = alat(ii) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + if(ht_ft(ii).lt.ht_min_stuck) ht_min_stuck = ht_ft(ii) + if(ht_ft(ii).gt.ht_max_stuck) ht_max_stuck = ht_ft(ii) + endif + enddo +c +c Don't reject flights with constant lat rounded to nearest deg +c or flights with elapsed time less than 30 minutes (1800 seconds) +c -------------------------------------------------------------- + if(stuck.and. +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + $ alat(iistart).ne.amiss.and. + $ abs(alat_max-alat_min).lt.0.005.and. + $ abs(nint(alat(iistart))-alat(iistart)).gt.0.005.and. + $ abs(idt(iiend)-idt(iistart)).gt.1800.and. + $ (k_ACARS+k_AIREP+k_AMDAR.ge.3.or. + $ k_ACARS+k_AIREP+k_AMDAR.eq.0).and. + $ (abs(alat(iistart)).lt.0.005.or. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ ht_max-ht_min.lt.100..or. + $ ht_max-ht_min.gt.9000.)) then +c + do iob=istart,iend + ii = indx(iob) + c_qc(ii)(3:3) = 'K' + enddo +cc +cc Otherwise, if only a portion of the flight is stuck, set QC flags +cc ----------------------------------------------------------------- +c elseif(k_stuck.ge.3.and. +! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c $ stk_alat.ne.-999 999.and. +c $ stk_alat.ne.amiss.and. +c $ abs(alat_max-alat_min).lt.0.005.and. +c $ abs(nint(stk_alat)-stk_alat).gt.0.005.and. +c $ abs(idt(iilast)-idt(iifirst)).gt.1800.and. +c $ (abs(stk_alat).lt.0.005.or. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c $ ht_max_stuck-ht_min_stuck.lt.100..or. +c $ ht_max_stuck-ht_min_stuck.gt.9000.) ) then +cc +c do iob=iobfirst,ioblast +c ii = indx(iob) +c c_qc(ii)(3:3) = 'K' +c enddo +cc +c write(io8,*) +c write(io8,*) 'Flight with > 3 constant latitudes' +c do iob=istart,iend +c ii = indx(iob) +c write(io8,3002) ii,c_insty_ob(itype(ii)) +c x, c_acftreg(ii),c_acftid(ii) +c x, idt(ii),alat(ii),alon(ii) +c x, pres(ii),ht_ft(ii) +c x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) +c x, ob_q(ii),xiv_q(ii),ichk_q(ii) +c x, ob_dir(ii),xiv_d(ii),ichk_d(ii) +c x, ob_spd(ii),xiv_s(ii),ichk_s(ii) +c x, c_qc(ii) +c enddo +c + endif +c +c Check if longitude is stuck +c --------------------------- + stuck = .true. + k_stuck = 0 +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + stk_alon = -999 999 + iobfirst = -999 999 + ioblast = -999 999 + iifirst = -999 999 + iilast = -999 999 + alon_min = 999 999 + alon_max = -999 999 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_min_stuck = 999 999 + ht_max_stuck = -999 999 +c + do iob=istart+1,iend + ii = indx(iob) + iim1 = indx(iob-1) +c +c Skip over isolated man_airep reports +c ------------------------------------ + if((itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep).and. + $ k_ACARS+k_AIREP+k_AMDAR.gt.0) then +c +c Skip over reports with previously averaged positions +c ---------------------------------------------------- + elseif(ichk_t(ii).eq.-4) then +c +c Set "stuck" to false if lons not equal and re-initialize stats +c -------------------------------------------------------------- +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + elseif(abs(alon(iim1)-alon(ii)).gt.0.005.and. + $ alon(iim1).ne.amiss.and. + $ alon(ii).ne.amiss) then +cc +cc If a portion of the flight is stuck, set QC flags +cc ------------------------------------------------- +c if(k_stuck.ge.3.and. +c $ stk_alon.ne.-999 999.and. +c $ stk_alon.ne.amiss.and. +c $ abs(alon_max-alon_min).lt.0.005.and. +c $ abs(nint(stk_alon)-stk_alon).gt.0.005.and. +c $ abs(idt(iilast)-idt(iifirst)).gt.1800.and. +c $ (abs(stk_alon).lt.0.005.or. +c $ ht_max_stuck-ht_min_stuck.lt.100..or. +c $ ht_max_stuck-ht_min_stuck.gt.9000.) ) then +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +cc +c do jj=iobfirst,ioblast +c ii = indx(jj) +c c_qc(ii)(4:4) = 'K' +c enddo +cc +c write(io8,*) +c write(io8,*) 'Flight with > 3 constant longitudes' +c do jj=istart,iend +c ii = indx(jj) +c write(io8,3002) ii,c_insty_ob(itype(ii)) +c x, c_acftreg(ii),c_acftid(ii) +c x, idt(ii),alat(ii),alon(ii) +c x, pres(ii),ht_ft(ii) +c x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) +c x, ob_q(ii),xiv_q(ii),ichk_q(ii) +c x, ob_dir(ii),xiv_d(ii),ichk_d(ii) +c x, ob_spd(ii),xiv_s(ii),ichk_s(ii) +c x, c_qc(ii) +c enddo +c endif +c + stuck = .false. + k_stuck = 0 +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + stk_alon = -999 999 + iobfirst = -999 999 + ioblast = -999 999 + iifirst = -999 999 + iilast = -999 999 + alon_min = 999 999 + alon_max = -999 999 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_min_stuck = 999 999 + ht_max_stuck = -999 999 +c +c Accumulate statistics for stuck segments +c ---------------------------------------- + elseif(c_qc(ii)(4:4).ne.'K') then + k_stuck = k_stuck + 1 + stk_alon = alon(ii) + if(iobfirst.eq.-999 999) then + iobfirst = iob-1 +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alon(iim1).lt.alon_min.and. + $ alon(iim1).ne.amiss) alon_min = alon(iim1) + if(alon(iim1).gt.alon_max.and. + $ alon(iim1).ne.amiss) alon_max = alon(iim1) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + if(ht_ft(iim1).lt.ht_min_stuck) + $ ht_min_stuck = ht_ft(iim1) + if(ht_ft(iim1).gt.ht_max_stuck) + $ ht_max_stuck = ht_ft(iim1) + endif + ioblast = iob + if(iifirst.eq.-999 999) iifirst = iim1 + iilast = ii +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alon(ii).lt.alon_min.and. + $ alon(ii).ne.amiss) alon_min = alon(ii) + if(alon(ii).gt.alon_max.and. + $ alon(ii).ne.amiss) alon_max = alon(ii) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + if(ht_ft(ii).lt.ht_min_stuck) ht_min_stuck = ht_ft(ii) + if(ht_ft(ii).gt.ht_max_stuck) ht_max_stuck = ht_ft(ii) + endif + enddo +c +c Don't reject flights with constant lon rounded to nearest deg +c or flights with elapsed time less than 30 minutes (1800 seconds) +c -------------------------------------------------------------- + if(stuck.and. +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + $ alon(iistart).ne.amiss.and. + $ abs(alon_max-alon_min).lt.0.005.and. + $ abs(nint(alon(iistart))-alon(iistart)).gt.0.005.and. + $ abs(idt(iiend)-idt(iistart)).gt.1800.and. +c $ abs(alon(iiend)-alon(iistart)).lt.0.005.and. + $ (k_ACARS+k_AIREP+k_AMDAR.ge.3.or. + $ k_ACARS+k_AIREP+k_AMDAR.eq.0).and. + $ (abs(alon(iistart)).lt.0.005.or. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ ht_max-ht_min.lt.100..or. + $ ht_max-ht_min.gt.9000.)) then +c + do iob=istart,iend + ii = indx(iob) + c_qc(ii)(4:4) = 'K' + enddo +cc +cc Otherwise, if only a portion of the flight is stuck, set QC flags +cc ----------------------------------------------------------------- +c elseif(k_stuck.ge.3.and. +! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c $ stk_alon.ne.-999 999.and. +c $ stk_alon.ne.amiss.and. +c $ abs(alon_max-alon_min).lt.0.005.and. +c $ abs(nint(stk_alon)-stk_alon).gt.0.005.and. +c $ abs(idt(iilast)-idt(iifirst)).gt.1800.and. +c $ (abs(stk_alon).lt.0.005.or. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c $ ht_max_stuck-ht_min_stuck.lt.100..or. +c $ ht_max_stuck-ht_min_stuck.gt.9000.) ) then +c +c do iob=iobfirst,ioblast +c ii = indx(iob) +c c_qc(ii)(4:4) = 'K' +c enddo +cc +c write(io8,*) +c write(io8,*) 'Flight with > 3 constant longitudes' +c do iob=istart,iend +c ii = indx(iob) +c write(io8,3002) ii,c_insty_ob(itype(ii)) +c x, c_acftreg(ii),c_acftid(ii) +c x, idt(ii),alat(ii),alon(ii) +c x, pres(ii),ht_ft(ii) +c x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) +c x, ob_q(ii),xiv_q(ii),ichk_q(ii) +c x, ob_dir(ii),xiv_d(ii),ichk_d(ii) +c x, ob_spd(ii),xiv_s(ii),ichk_s(ii) +c x, c_qc(ii) +c enddo +c + endif +c +c Check if pressure is stuck +c (constant ok if at upper levels) +c (The check for stuck segments is commented out) +c ----------------------------------------------- + stuck = .true. + k_stuck = 0 + stk_pres = -999 999 + iobfirst = -999 999 + ioblast = -999 999 + iifirst = -999 999 + iilast = -999 999 + ob_min = 999 999 + ob_max = -999 999 +c + do iob=istart+1,iend + ii = indx(iob) + iim1 = indx(iob-1) +c +c Skip over isolated man_airep reports +c ------------------------------------ + if((itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep).and. + $ k_ACARS+k_AIREP+k_AMDAR.gt.0) then +c +c Set "stuck" to false if pressures not equal and re-initialize stats +c ------------------------------------------------------------------- + elseif(abs(pres(iim1)-pres(ii)).gt.0.05.and. + $ pres(iim1).ne.amiss.and. + $ pres(ii).ne.amiss) then + stuck = .false. + k_stuck = 0 + stk_pres = -999 999 + iobfirst = -999 999 + ioblast = -999 999 + iifirst = -999 999 + iilast = -999 999 + ob_min = 999 999 + ob_max = -999 999 +c +c Accumulate statistics for stuck segments +c ---------------------------------------- + else +c k_stuck = k_stuck + 1 +c stk_pres = pres(ii) + if(iobfirst.eq.-999 999) then + iobfirst = iob-1 + if(pres(iim1).lt.ob_min.and. + $ pres(iim1).ne.amiss) ob_min = pres(iim1) + if(pres(iim1).gt.ob_max.and. + $ pres(iim1).ne.amiss) ob_max = pres(iim1) + endif +c ioblast = iob +c if(iifirst.eq.-999 999) iifirst = iim1 +c iilast = ii + if(pres(ii).lt.ob_min.and. + $ pres(ii).ne.amiss) ob_min = pres(ii) + if(pres(ii).gt.ob_max.and. + $ pres(ii).ne.amiss) ob_max = pres(ii) +c + endif + enddo +c +c Don't reject flights with pressure less than 750 mb +c --------------------------------------------------- + if(stuck.and. + $ pres(iistart).gt.750..and. + $ pres(iistart).ne.amiss.and. +c $ abs(pres(iiend)-pres(iistart)).lt.0.05.and. + $ abs(ob_max-ob_min).lt.0.05.and. + $ abs(idt(iiend)-idt(iistart)).gt.1800.and. + $ (k_ACARS+k_AIREP+k_AMDAR.ge.3.or. + $ k_ACARS+k_AIREP+k_AMDAR.eq.0)) then +c + do iob=istart,iend + ii = indx(iob) + c_qc(ii)(5:5) = 'K' + enddo +cc +cc Otherwise, if only a portion of the flight is stuck, set QC flags +cc ----------------------------------------------------------------- +c elseif(k_stuck.ge.3.and. +c $ stk_pres.ne.-999 999.and. +c $ stk_pres.ne.amiss.and. +c $ abs(ob_max-ob_min).lt.0.05.and. +c $ abs(idt(iilast)-idt(iifirst)).gt.1800.and. +c $ stk_pres.gt.750.) then +cc +c do iob=iobfirst,ioblast +c ii = indx(iob) +c c_qc(ii)(5:5) = 'K' +c enddo +cc +c stuck = .true. +cc +c write(io8,*) +c write(io8,*) 'Flight with > 3 constant pressures' +c do iob=istart,iend +c ii = indx(iob) +c write(io8,3002) ii,c_insty_ob(itype(ii)) +c x, c_acftreg(ii),c_acftid(ii) +c x, idt(ii),alat(ii),alon(ii) +c x, pres(ii),ht_ft(ii) +c x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) +c x, ob_q(ii),xiv_q(ii),ichk_q(ii) +c x, ob_dir(ii),xiv_d(ii),ichk_d(ii) +c x, ob_spd(ii),xiv_s(ii),ichk_s(ii) +c x, c_qc(ii) +c enddo +c + endif +c +c Check if altitude is stuck +c (constant ok if at upper levels) +c (The check for stuck segments is commented out) +c ----------------------------------------------- + if(.not.stuck) then +c + stuck = .true. + k_stuck = 0 + stk_alt = -999 999 + iobfirst = -999 999 + ioblast = -999 999 + iifirst = -999 999 + iilast = -999 999 + ob_min = 999 999 + ob_max = -999 999 +c + do iob=istart+1,iend + ii = indx(iob) + iim1 = indx(iob-1) +c +c Skip over isolated man_airep reports +c ------------------------------------ + if((itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep).and. + $ k_ACARS+k_AIREP+k_AMDAR.gt.0) then +c +c Set "stuck" to false if heights not equal and re-initialize stats +c ----------------------------------------------------------------- + elseif(ifix(ht_ft(iim1)/10.).ne. + $ ifix(ht_ft(ii)/10.).and. + $ ht_ft(iim1).ne.amiss.and. + $ ht_ft(ii).ne.amiss) then + stuck = .false. + k_stuck = 0 + stk_alt = -999 999 + iobfirst = -999 999 + ioblast = -999 999 + iifirst = -999 999 + iilast = -999 999 + ob_min = 999 999 + ob_max = -999 999 +c +c Accumulate statistics for stuck segments +c ---------------------------------------- + else +c k_stuck = k_stuck + 1 +c stk_alt = ht_ft(ii) + if(iobfirst.eq.-999 999) then + iobfirst = iob-1 + if(ht_ft(iim1).lt.ob_min.and. + $ ht_ft(iim1).ne.amiss) ob_min = ht_ft(iim1) + if(ht_ft(iim1).gt.ob_max.and. + $ ht_ft(iim1).ne.amiss) ob_max = ht_ft(iim1) + endif +c ioblast = iob +c if(iifirst.eq.-999 999) iifirst = iim1 +c iilast = ii + if(ht_ft(ii).lt.ob_min.and. + $ ht_ft(ii).ne.amiss) ob_min = ht_ft(ii) + if(ht_ft(ii).gt.ob_max.and. + $ ht_ft(ii).ne.amiss) ob_max = ht_ft(ii) +c + endif + enddo +c +c Don't reject flights with altitude greater than 8000' +c ----------------------------------------------------- + if(stuck.and. + $ ht_ft(iistart).lt.8000..and. + $ ht_ft(iistart).ne.amiss.and. +c $ ifix(ht_ft(iiend)/10.).eq.ifix(ht_ft(iistart)/10.).and. + $ ifix(ob_max/10.).eq.ifix(ob_min/10.).and. + $ abs(idt(iiend)-idt(iistart)).gt.1800.and. + $ (k_ACARS+k_AIREP+k_AMDAR.ge.3.or. + $ k_ACARS+k_AIREP+k_AMDAR.eq.0)) then +c + do iob=istart,iend + ii = indx(iob) + c_qc(ii)(5:5) = 'K' + enddo +cc +cc Otherwise, if only a portion of the flight is stuck, set QC flags +cc ----------------------------------------------------------------- +c elseif(k_stuck.ge.3.and. +c $ stk_alt.ne.-999 999.and. +c $ stk_alt.ne.amiss.and. +c $ ifix(ob_max/10.).eq.ifix(ob_min/10.).and. +c $ abs(idt(iilast)-idt(iifirst)).gt.1800.and. +c $ stk_alt.lt.8000.) then +cc +c do iob=iobfirst,ioblast +c ii = indx(iob) +c c_qc(ii)(5:5) = 'K' +c enddo +cc +c write(io8,*) +c write(io8,*) 'Flight with > 3 constant altitudes' +c do iob=istart,iend +c ii = indx(iob) +c write(io8,3002) ii,c_insty_ob(itype(ii)) +c x, c_acftreg(ii),c_acftid(ii) +c x, idt(ii),alat(ii),alon(ii) +c x, pres(ii),ht_ft(ii) +c x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) +c x, ob_q(ii),xiv_q(ii),ichk_q(ii) +c x, ob_dir(ii),xiv_d(ii),ichk_d(ii) +c x, ob_spd(ii),xiv_s(ii),ichk_s(ii) +c x, c_qc(ii) +c enddo +c + endif + endif +c +c Check if temperature is stuck or reported in whole deg +c (The check for stuck segments is commented out) +c ------------------------------------------------------ + stuck = .true. + k_stuck = 0 + stk_temp = -999 999 + iobfirst = -999 999 + ioblast = -999 999 + iifirst = -999 999 + iilast = -999 999 + ob_min = 999 999 + ob_max = -999 999 + ht_min_stuck = 999 999 + ht_max_stuck = -999 999 +c + do iob=istart+1,iend + ii = indx(iob) + iim1 = indx(iob-1) +c +c Skip over isolated man_airep reports +c ------------------------------------ + if((itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep).and. + $ k_ACARS+k_AIREP+k_AMDAR.gt.0) then +c +c Skip over temperatures already rejected +c --------------------------------------- + elseif(c_qc(ii)(6:6).eq.'B'.or. + $ c_qc(ii)(6:6).eq.'b'.or. + $ c_qc(ii)(6:6).eq.'E'.or. + $ c_qc(ii)(6:6).eq.'I') then +c +c Set "stuck" to false if temps not equal and re-initialize stats +c --------------------------------------------------------------- + elseif(abs(ob_t(iim1)-ob_t(ii)).gt.0.05.and. + $ ob_t(iim1).ne.amiss.and. + $ ob_t(ii).ne.amiss) then +c + stuck = .false. + k_stuck = 0 + stk_temp = -999 999 + iobfirst = -999 999 + ioblast = -999 999 + iifirst = -999 999 + iilast = -999 999 + ob_min = 999 999 + ob_max = -999 999 + ht_min_stuck = 999 999 + ht_max_stuck = -999 999 +c +c Accumulate statistics for stuck segments +c ---------------------------------------- + else +c k_stuck = k_stuck + 1 +c stk_temp = ob_t(ii) + if(iobfirst.eq.-999 999.and. + $ ob_t(iim1).ne.amiss) then + iobfirst = iob-1 + ioblast = iob-1 + if(ob_t(iim1).lt.ob_min.and. + $ ob_t(iim1).ne.amiss) ob_min = ob_t(iim1) + if(ob_t(iim1).gt.ob_max.and. + $ ob_t(iim1).ne.amiss) ob_max = ob_t(iim1) +c if(ht_ft(iim1).lt.ht_min_stuck) +c $ ht_min_stuck = ht_ft(iim1) +c if(ht_ft(iim1).gt.ht_max_stuck) +c $ ht_max_stuck = ht_ft(iim1) + endif + if(ob_t(ii).ne.amiss) ioblast = iob +c if(iifirst.eq.-999 999) iifirst = iim1 +c iilast = ii + if(ob_t(ii).lt.ob_min.and. + $ ob_t(ii).ne.amiss) ob_min = ob_t(ii) + if(ob_t(ii).gt.ob_max.and. + $ ob_t(ii).ne.amiss) ob_max = ob_t(ii) +c if(ht_ft(ii).lt.ht_min_stuck) ht_min_stuck = ht_ft(ii) +c if(ht_ft(ii).gt.ht_max_stuck) ht_max_stuck = ht_ft(ii) +c + endif + enddo +c +c Don't reject flights with a height difference of less than 1500' +c -------------------------------------------------------------- + if(stuck.and. + $ k_stuck.gt.0.and. + $ ob_t(iistart).ne.amiss.and. + $ iobfirst.ne.ioblast.and. + $ (ht_max-ht_min.gt.1500..or. + $ ht_max.gt.25000.).and. + $ abs(ob_max-ob_min).lt.0.05.and. + $ (k_ACARS+k_AIREP+k_AMDAR.ge.3.or. + $ k_ACARS+k_AIREP+k_AMDAR.eq.0)) then +c + do iob=istart,iend + ii = indx(iob) + if(c_qc(ii)(6:6).ne.'B'.and. + $ c_qc(ii)(6:6).ne.'b'.and. + $ c_qc(ii)(6:6).ne.'E'.and. + $ c_qc(ii)(6:6).ne.'I') c_qc(ii)(6:6) = 'K' + enddo +cc +cc Otherwise, if only a portion of the flight is stuck, set QC flags +cc ----------------------------------------------------------------- +c elseif(k_stuck.ge.3.and. +c $ stk_temp.ne.-999 999.and. +c $ stk_temp.ne.amiss.and. +c $ abs(ob_max-ob_min).lt.0.05.and. +c $ (ht_max_stuck-ht_min_stuck.gt.1500..or. +c $ ht_max_stuck.gt.25000.)) then +cc +c do iob=iobfirst,ioblast +c ii = indx(iob) +c c_qc(ii)(6:6) = 'K' +c enddo +cc +c write(io8,*) +c write(io8,*) 'Flight with > 3 constant temperatures' +c do iob=istart,iend +c ii = indx(iob) +c write(io8,3002) ii,c_insty_ob(itype(ii)) +c x, c_acftreg(ii),c_acftid(ii) +c x, idt(ii),alat(ii),alon(ii) +c x, pres(ii),ht_ft(ii) +c x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) +c x, ob_q(ii),xiv_q(ii),ichk_q(ii) +c x, ob_dir(ii),xiv_d(ii),ichk_d(ii) +c x, ob_spd(ii),xiv_s(ii),ichk_s(ii) +c x, c_qc(ii) +c enddo +c + endif +c +ccccdak Recompute temperature reported in whole degrees for ACARS/MDCRS +c Recompute temperature reported in whole degrees for TAMDAR/MDCRS +c Mark as bad for other types +c ---------------------------------------------------------------- + if(temp_min.gt.266.0.and. + $ temp_max.lt.278.0.and. + $ (.not.stuck).and. + $ ht_max.gt.25000.) then +c + do mm=1,kreg + if(c_acftreg(iistart).eq.creg_reg(mm)) mreg = mm + enddo +c + do iob=istart,iend + ii = indx(iob) + if(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des.or. + $ itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des) then + ob_t(ii) = (ob_t(ii) - 273.16) * 10. + 273.16 +c write(io8,*) ' temperature recomputed' + c_qc(ii)(6:6) = 'R' + t_prcn(ii) = 1.00 + else +c write(io8,*) ' temperature marked bad' + c_qc(ii)(6:6) = 'b' + endif +c +c Count number of corrected/rejected temperatures +c ----------------------------------------------- + if(c_acftreg(ii).eq.creg_reg(mreg)) then +c + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des) then + nwhol_reg(mreg,1) = nwhol_reg(mreg,1) + 1 +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des) then + nwhol_reg(mreg,2) = nwhol_reg(mreg,2) + 1 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des) then + nwhol_reg(mreg,3) = nwhol_reg(mreg,3) + 1 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des) then + nwhol_reg(mreg,4) = nwhol_reg(mreg,4) + 1 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + nwhol_reg(mreg,5) = nwhol_reg(mreg,5) + 1 + endif +c + else + do mm=1,kreg + if(c_acftreg(ii).eq.creg_reg(mm)) then +c + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des) then + nwhol_reg(mm,1) = nwhol_reg(mm,1) + 1 +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des) then + nwhol_reg(mm,2) = nwhol_reg(mm,2) + 1 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des) then + nwhol_reg(mm,3) = nwhol_reg(mm,3) + 1 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des) then + nwhol_reg(mm,4) = nwhol_reg(mm,4) + 1 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + nwhol_reg(mm,5) = nwhol_reg(mm,5) + 1 + endif + endif + enddo + endif + enddo + endif +c +c Check if wind direction is stuck +c (The check for stuck segments is commented out) +c ----------------------------------------------- + stuck = .true. + k_stuck = 0 + stk_wdir = -999 999 + iobfirst = -999 999 + ioblast = -999 999 + iifirst = -999 999 + iilast = -999 999 + ob_min = 999 999 + ob_max = -999 999 + ht_min_stuck = 999 999 + ht_max_stuck = -999 999 +c + do iob=istart+1,iend + ii = indx(iob) + iim1 = indx(iob-1) +c +c Skip over isolated man_airep reports +c ------------------------------------ + if((itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep).and. + $ k_ACARS+k_AIREP+k_AMDAR.gt.0) then +c +c Skip over winds already rejected +c -------------------------------- + elseif(c_qc(ii)(7:7).eq.'B'.or. + $ c_qc(ii)(7:7).eq.'E'.or. + $ c_qc(ii)(8:8).eq.'E') then +c +c Set "stuck" to false if directions not equal and re-initialize stats +c -------------------------------------------------------------------- + elseif(abs(ob_dir(iim1)-ob_dir(ii)).gt.0.5.and. + $ ob_dir(iim1).ne.amiss.and. + $ ob_dir(ii).ne.amiss) then + stuck = .false. + k_stuck = 0 + stk_wdir = -999 999 + iobfirst = -999 999 + ioblast = -999 999 + iifirst = -999 999 + iilast = -999 999 + ob_min = 999 999 + ob_max = -999 999 + ht_min_stuck = 999 999 + ht_max_stuck = -999 999 +c +c Accumulate statistics for stuck segments +c ---------------------------------------- + else +c k_stuck = k_stuck + 1 +c stk_wdir = ob_dir(ii) + if(iobfirst.eq.-999 999) then + iobfirst = iob-1 + if(ob_dir(iim1).lt.ob_min.and. + $ ob_dir(iim1).ne.amiss) ob_min = ob_dir(iim1) + if(ob_dir(iim1).gt.ob_max.and. + $ ob_dir(iim1).ne.amiss) ob_max = ob_dir(iim1) +c if(ht_ft(iim1).lt.ht_min_stuck) +c $ ht_min_stuck = ht_ft(iim1) +c if(ht_ft(iim1).gt.ht_max_stuck) +c $ ht_max_stuck = ht_ft(iim1) + endif +c ioblast = iob +c if(iifirst.eq.-999 999) iifirst = iim1 +c iilast = ii + if(ob_dir(ii).lt.ob_min.and. + $ ob_dir(ii).ne.amiss) ob_min = ob_dir(ii) + if(ob_dir(ii).gt.ob_max.and. + $ ob_dir(ii).ne.amiss) ob_max = ob_dir(ii) +c if(ht_ft(ii).lt.ht_min_stuck) ht_min_stuck = ht_ft(ii) +c if(ht_ft(ii).gt.ht_max_stuck) ht_max_stuck = ht_ft(ii) +c + endif + enddo +c +c Don't reject flights with constant dir rounded to nearest 10 deg +c -------------------------------------------------------------- + if(stuck.and. + $ ob_dir(iistart).ne.amiss.and. + $ (abs(nint(ob_dir(iistart)/10.)*10 + $ -ob_dir(iistart)).gt.0.5).and. +c $ abs(ob_dir(iiend)-ob_dir(iistart)).lt.0.5.and. + $ abs(ob_max-ob_min).lt.0.5.and. + $ (k_ACARS+k_AIREP+k_AMDAR.ge.3.or. + $ k_ACARS+k_AIREP+k_AMDAR.eq.0).and. + $ (ht_max-ht_min.lt.100..or. + $ ht_max-ht_min.gt.9000.)) then +c + do iob=istart,iend + ii = indx(iob) + c_qc(ii)(7:7) = 'K' + enddo +cc +cc Otherwise, if only a portion of the flight is stuck, set QC flags +cc ----------------------------------------------------------------- +c elseif(k_stuck.ge.3.and. +c $ stk_wdir.ne.-999 999.and. +c $ stk_wdir.ne.amiss.and. +c $ (abs(nint(stk_wdir/10.)*10-stk_wdir).gt.0.5).and. +c $ abs(ob_max-ob_min).lt.0.5.and. +c $ (ht_max_stuck-ht_min_stuck.lt.100..or. +c $ ht_max_stuck-ht_min_stuck.gt.9000.) ) then +cc +c do iob=iobfirst,ioblast +c ii = indx(iob) +c c_qc(ii)(7:7) = 'K' +c enddo +cc +c write(io8,*) +c write(io8,*) 'Flight with > 3 constant wind directions' +c do iob=istart,iend +c ii = indx(iob) +c write(io8,3002) ii,c_insty_ob(itype(ii)) +c x, c_acftreg(ii),c_acftid(ii) +c x, idt(ii),alat(ii),alon(ii) +c x, pres(ii),ht_ft(ii) +c x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) +c x, ob_q(ii),xiv_q(ii),ichk_q(ii) +c x, ob_dir(ii),xiv_d(ii),ichk_d(ii) +c x, ob_spd(ii),xiv_s(ii),ichk_s(ii) +c x, c_qc(ii) +c enddo +c + endif +c +c Check if wind speed is stuck +c (The check for stuck segments is commented out) +c ----------------------------------------------- + stuck = .true. + k_stuck = 0 + stk_wspd = -999 999 + iobfirst = -999 999 + ioblast = -999 999 + iifirst = -999 999 + iilast = -999 999 + ob_min = 999 999 + ob_max = -999 999 + ht_min_stuck = 999 999 + ht_max_stuck = -999 999 +c + do iob=istart+1,iend + ii = indx(iob) + iim1 = indx(iob-1) +c +c Skip over isolated man_airep reports +c ------------------------------------ + if((itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep).and. + $ k_ACARS+k_AIREP+k_AMDAR.gt.0) then +c +c Skip over winds already rejected +c -------------------------------- + elseif(c_qc(ii)(7:7).eq.'B'.or. + $ c_qc(ii)(7:7).eq.'E'.or. + $ c_qc(ii)(7:7).eq.'K'.or. + $ c_qc(ii)(8:8).eq.'E') then +c +c Set "stuck" to false if speeds not equal and re-initialize stats +c ---------------------------------------------------------------- + elseif(abs(ob_spd(iim1)-ob_spd(ii)).gt.0.05.and. + $ ob_spd(iim1).ne.amiss.and. + $ ob_spd(ii).ne.amiss) then + stuck = .false. + k_stuck = 0 + stk_wspd = -999 999 + iobfirst = -999 999 + ioblast = -999 999 + iifirst = -999 999 + iilast = -999 999 + ob_min = 999 999 + ob_max = -999 999 + ht_min_stuck = 999 999 + ht_max_stuck = -999 999 +c +c Accumulate statistics for stuck segments +c ---------------------------------------- + else +c k_stuck = k_stuck + 1 +c stk_wspd = ob_spd(ii) + if(iobfirst.eq.-999 999) then + iobfirst = iob-1 + if(ob_spd(iim1).lt.ob_min.and. + $ ob_spd(iim1).ne.amiss) ob_min = ob_spd(iim1) + if(ob_spd(iim1).gt.ob_max.and. + $ ob_spd(iim1).ne.amiss) ob_max = ob_spd(iim1) +c if(ht_ft(iim1).lt.ht_min_stuck) +c $ ht_min_stuck = ht_ft(iim1) +c if(ht_ft(iim1).gt.ht_max_stuck) +c $ ht_max_stuck = ht_ft(iim1) + endif +c ioblast = iob +c if(iifirst.eq.-999 999) iifirst = iim1 +c iilast = ii + if(ob_spd(ii).lt.ob_min.and. + $ ob_spd(ii).ne.amiss) ob_min = ob_spd(ii) + if(ob_spd(ii).gt.ob_max.and. + $ ob_spd(ii).ne.amiss) ob_max = ob_spd(ii) +c if(ht_ft(ii).lt.ht_min_stuck) ht_min_stuck = ht_ft(ii) +c if(ht_ft(ii).gt.ht_max_stuck) ht_max_stuck = ht_ft(ii) +c + endif + enddo +c +c Don't reject flights with constant direction rounded to the nearest 10 deg +c -------------------------------------------------------------------------- + if(stuck.and. + $ ob_spd(iistart).ne.amiss.and. + $ (ob_dir(iistart).ne.-999 999.and. + $ (ob_dir(iistart).eq.0.0.or. + $ abs(nint(ob_dir(iistart)/10.)*10 + $ -ob_dir(iistart)).gt.0.5).or. + $ ob_dir(iiend).ne.-999 999.and. + $ (ob_dir(iiend).eq.0.0.or. + $ abs(nint(ob_dir(iiend)/10.)*10 + $ -ob_dir(iiend)).gt.0.5)).and. +c $ abs(ob_spd(iiend)-ob_spd(iistart)).lt.0.05.and. + $ abs(ob_max-ob_min).lt.0.05.and. + $ (k_ACARS+k_AIREP+k_AMDAR.ge.3.or. + $ k_ACARS+k_AIREP+k_AMDAR.eq.0).and. + $ (ht_max-ht_min.lt.100..or. + $ ht_max-ht_min.gt.9000.)) then +c + do iob=istart,iend + ii = indx(iob) + c_qc(ii)(8:8) = 'K' + enddo +cc +cc Otherwise, if only a portion of the flight is stuck, set QC flags +cc ----------------------------------------------------------------- +c elseif(k_stuck.ge.3.and. +c $ stk_wspd.ne.-999 999.and. +c $ stk_wspd.ne.amiss.and. +c $ ((ob_dir(iifirst).ne.-999 999.and. +c $ (ob_dir(iifirst).eq.0.0.or. +c $ abs(nint(ob_dir(iifirst)/10.)*10 +c $ -ob_dir(iifirst)).gt.0.5)).or. +c $ (ob_dir(iilast).ne.-999 999.and. +c $ (ob_dir(iilast).eq.0.0.or. +c $ abs(nint(ob_dir(iilast)/10.)*10 +c $ -ob_dir(iilast)).gt.0.5))).and. +c $ abs(ob_max-ob_min).lt.0.05.and. +c $ (ht_max_stuck-ht_min_stuck.lt.100..or. +c $ ht_max_stuck-ht_min_stuck.gt.9000.)) then +cc +c do iob=iobfirst,ioblast +c ii = indx(iob) +c c_qc(ii)(8:8) = 'K' +c enddo +cc +c write(io8,*) +c write(io8,*) 'Flight with > 3 constant wind speeds' +c do iob=istart,iend +c ii = indx(iob) +c write(io8,3002) ii,c_insty_ob(itype(ii)) +c x, c_acftreg(ii),c_acftid(ii) +c x, idt(ii),alat(ii),alon(ii) +c x, pres(ii),ht_ft(ii) +c x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) +c x, ob_q(ii),xiv_q(ii),ichk_q(ii) +c x, ob_dir(ii),xiv_d(ii),ichk_d(ii) +c x, ob_spd(ii),xiv_s(ii),ichk_s(ii) +c x, c_qc(ii) +c enddo +c + endif +c +c Check if moisture is stuck +c (The check for stuck segments is commented out) +c ----------------------------------------------- + stuck = .true. + k_stuck = 0 + stk_moist = -999 999 + iobfirst = -999 999 + ioblast = -999 999 + iifirst = -999 999 + iilast = -999 999 + ob_min = 999 999 + ob_max = -999 999 + ht_min_stuck = 999 999 + ht_max_stuck = -999 999 +c + do iob=istart+1,iend + ii = indx(iob) + iim1 = indx(iob-1) +c +c Skip over isolated man_airep reports +c ------------------------------------ + if((itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep).and. + $ k_ACARS+k_AIREP+k_AMDAR.gt.0) then +c +c Set "stuck" to false if moistures not equal and re-initialize stats +c Exclude missing values +c ------------------------------------------------------------------- + elseif(abs(ob_q(iim1)-ob_q(ii)).gt.0.005.and. + $ ob_q(iim1).ne.amiss.and. + $ ob_q(ii).ne.amiss.and. + $ ichk_q(ii).ne.-9.and. + $ ichk_q(ii).ne.9.and. + $ ichk_q(ii).ne.-1.and. + $ .not.(ob_q(ii).lt.0.005.and.ichk_q(ii).eq.-7)) then +c + stuck = .false. + k_stuck = 0 + stk_moist = -999 999 + iobfirst = -999 999 + ioblast = -999 999 + iifirst = -999 999 + iilast = -999 999 + ob_min = 999 999 + ob_max = -999 999 + ht_min_stuck = 999 999 + ht_max_stuck = -999 999 +c +c Accumulate statistics for stuck segments +c ---------------------------------------- + else +c k_stuck = k_stuck + 1 +c stk_moist = ob_q(ii) + if(iobfirst.eq.-999 999) then + iobfirst = iob-1 + if(ob_q(iim1).lt.ob_min.and. + $ ob_q(iim1).ne.amiss) ob_min = ob_q(iim1) + if(ob_q(iim1).gt.ob_max.and. + $ ob_q(iim1).ne.amiss) ob_max = ob_q(iim1) +c if(ht_ft(iim1).lt.ht_min_stuck) +c $ ht_min_stuck = ht_ft(iim1) +c if(ht_ft(iim1).gt.ht_max_stuck) +c $ ht_max_stuck = ht_ft(iim1) + endif +c ioblast = iob +c if(iifirst.eq.-999 999) iifirst = iim1 +c iilast = ii + if(ob_q(ii).lt.ob_min.and. + $ ob_q(ii).ne.amiss) ob_min = ob_q(ii) + if(ob_q(ii).gt.ob_max.and. + $ ob_q(ii).ne.amiss) ob_max = ob_q(ii) +c if(ht_ft(ii).lt.ht_min_stuck) ht_min_stuck = ht_ft(ii) +c if(ht_ft(ii).gt.ht_max_stuck) ht_max_stuck = ht_ft(ii) +c + endif + enddo +c +c Don't reject flights with moisture = 0 (=> missing) +c --------------------------------------------------- + if(stuck.and. + $ ob_q(iistart).ne.amiss.and. + $ abs(ob_q(iistart)).gt.0.005.and. +c $ abs(ob_q(iiend)-ob_q(iistart)).lt.0.005.and. + $ abs(ob_max-ob_min).lt.0.005.and. + $ (k_ACARS+k_AIREP+k_AMDAR.ge.3.or. + $ k_ACARS+k_AIREP+k_AMDAR.eq.0).and. + $ (ht_max-ht_min.lt.100..or. + $ ht_max-ht_min.gt.9000.)) then + + do iob=istart,iend + ii = indx(iob) + if(c_qc(ii)(9:9).eq.'-') c_qc(ii)(9:9) = 'K' + enddo +cc +cc Otherwise, if only a portion of the flight is stuck, set QC flags +cc ----------------------------------------------------------------- +c elseif(k_stuck.ge.3.and. +c $ stk_moist.ne.-999 999.and. +c $ stk_moist.ne.amiss.and. +c $ stk_moist.gt.0.005.and. +c $ abs(ob_max-ob_min).lt.0.005.and. +c $ (ht_max_stuck-ht_min_stuck.lt.100..or. +c $ ht_max_stuck-ht_min_stuck.gt.9000.)) then +cc +c do iob=iobfirst,ioblast +c ii = indx(iob) +c c_qc(ii)(9:9) = 'K' +c enddo +cc +c write(io8,*) +c write(io8,*) 'Flight with > 3 constant moisture' +c do iob=istart,iend +c ii = indx(iob) +c write(io8,3002) ii,c_insty_ob(itype(ii)) +c x, c_acftreg(ii),c_acftid(ii) +c x, idt(ii),alat(ii),alon(ii) +c x, pres(ii),ht_ft(ii) +c x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) +c x, ob_q(ii),xiv_q(ii),ichk_q(ii) +c x, ob_dir(ii),xiv_d(ii),ichk_d(ii) +c x, ob_spd(ii),xiv_s(ii),ichk_s(ii) +c x, c_qc(ii) +c enddo +c + endif +c + endif + endif + enddo +c +c Write out bad reports +c --------------------- + if(.not.l_operational) then + write(io33,*) + write(io33,*) 'Reports with temperatures in whole degrees' + write(io33,*) '------------------------------------------' + write(io33,3001) + 3001 format(' index type tail num flight time lat' + x, ' lon pres height ' + x, 't-prcn temp innov ichk' + x, ' spec hum innov ichk' + x, ' ob_dir innov ichk' + x, ' ob_spd innov ichk' + x, ' qc flag') + endif +c + do iob = 1,numreps + ii = indx(iob) +c + if(c_qc(ii)(6:6).eq.'R'.or. + $ c_qc(ii)(6:6).eq.'b') then +c + if(.not.l_operational) then + write(io33,3002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + 3002 format(i6,1x,a8,1x,a8,1x,a9,1x,i7,1x,2f11.5,1x,f8.1,1x,f7.0 + x, 1x,f5.2,4(2(1x,f8.2),1x,i5),1x,'!',a11,'!') + endif +c +c Count number of recomputed or marked reports +c -------------------------------------------- + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des) then + nstk_whol(1) = nstk_whol(1) + 1 +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des) then + nstk_whol(2) = nstk_whol(2) + 1 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des) then + nstk_whol(3) = nstk_whol(3) + 1 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des) then + nstk_whol(4) = nstk_whol(4) + 1 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + nstk_whol(5) = nstk_whol(5) + 1 + endif +c + endif + enddo +c + if(.not.l_operational) then + write(io33,*) + write(io33,*) ' Number of MDCRS in whole deg =',nstk_whol(1) +ccccdak write(io33,*) ' Number of ACARS in whole deg =',nstk_whol(2) + write(io33,*) ' Number of TAMDAR in whole deg =',nstk_whol(2) + write(io33,*) ' Number of AMDAR in whole deg =',nstk_whol(3) + write(io33,*) ' Number of AIREP in whole deg =',nstk_whol(4) + write(io33,*) ' Number of manAIREP in whole deg =',nstk_whol(5) +c + write(io33,*) + write(io33,*) 'Reports with stuck values (K)' + write(io33,*) '-----------------------------' + write(io33,3001) + endif +c + kbad = 0 +c + do iob = 1,numreps + ii = indx(iob) +c + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des) then + ktype = 1 +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des) then + ktype = 2 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des) then + ktype = 3 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des) then + ktype = 4 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + ktype = 5 + endif +c + if(ktype.eq.1) then + nrep_Md = nrep_Md + 1 + elseif(ktype.eq.2) then + nrep_Ac = nrep_Ac + 1 + elseif(ktype.eq.3) then + nrep_Am = nrep_Am + 1 + elseif(ktype.eq.4) then + nrep_Ar = nrep_Ar + 1 + elseif(ktype.eq.5) then + nrep_Ma = nrep_Ma + 1 + endif +c + if(c_qc(ii)(2:2).eq.'K'.or. + $ c_qc(ii)(3:3).eq.'K'.or. + $ c_qc(ii)(4:4).eq.'K'.or. + $ c_qc(ii)(5:5).eq.'K'.or. + $ c_qc(ii)(6:6).eq.'K'.or. + $ c_qc(ii)(7:7).eq.'K'.or. + $ c_qc(ii)(8:8).eq.'K'.or. + $ c_qc(ii)(9:9).eq.'K') then +c + if(.not.l_operational) then + write(io33,3002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + endif +c +c Count number of rejects +c ----------------------- + if(c_qc(ii)(2:4).eq.'KKK') then + nstk_both(ktype) = nstk_both(ktype) + 1 + elseif(c_qc(ii)(2:2).eq.'K') then + nstk_time(ktype) = nstk_time(ktype) + 1 + elseif(c_qc(ii)(3:4).eq.'KK') then + nstk_posn(ktype) = nstk_posn(ktype) + 1 + elseif(c_qc(ii)(3:3).eq.'K') then + nstk_alat(ktype) = nstk_alat(ktype) + 1 + elseif(c_qc(ii)(4:4).eq.'K') then + nstk_alon(ktype) = nstk_alon(ktype) + 1 + elseif(c_qc(ii)(5:5).eq.'K') then + nstk_pres(ktype) = nstk_pres(ktype) + 1 + elseif(c_qc(ii)(6:6).eq.'K'.and. + $ (c_qc(ii)(7:7).eq.'K'.or. + $ c_qc(ii)(8:8).eq.'K')) then + nstk_val(ktype) = nstk_val(ktype) + 1 + else + if(c_qc(ii)(6:6).eq.'K') then + nstk_temp(ktype) = nstk_temp(ktype) + 1 + endif + if(c_qc(ii)(7:7).eq.'K') then + nstk_wdir(ktype) = nstk_wdir(ktype) + 1 + endif + if(c_qc(ii)(8:8).eq.'K') then + nstk_wspd(ktype) = nstk_wspd(ktype) + 1 + endif + if(c_qc(ii)(9:9).eq.'K') then + nstk_moist(ktype) = nstk_moist(ktype) + 1 + endif + endif +c +c Count number of rejected temps/winds by tail number +c --------------------------------------------------- + mm = 1 + do while(mm.le.kreg) + if(c_acftreg(ii).eq.creg_reg(mm)) then +c + if(ktype.gt.0.and.ktype.le.5) then + if(c_qc(ii)(6:6).eq.'K'.and. + $ c_qc(ii)(2:2).ne.'K'.and. + $ c_qc(ii)(3:3).ne.'K'.and. + $ c_qc(ii)(4:4).ne.'K'.and. + $ c_qc(ii)(5:5).ne.'K') + $ ntemp_reg(mm,ktype) = ntemp_reg(mm,ktype) + 1 + if((c_qc(ii)(7:7).eq.'K'.or. + $ c_qc(ii)(8:8).eq.'K').and. + $ c_qc(ii)(2:2).ne.'K'.and. + $ c_qc(ii)(3:3).ne.'K'.and. + $ c_qc(ii)(4:4).ne.'K'.and. + $ c_qc(ii)(5:5).ne.'K') + $ nwind_reg(mm,ktype) = nwind_reg(mm,ktype) + 1 + endif + mm = kreg + 1 + endif + mm = mm + 1 + enddo + endif +c +c Reject reports with stuck time, lat, lon, pres +c Also reject report if both temperature and winds are stuck +c ---------------------------------------------------------- + if(c_qc(ii)(2:2).eq.'K'.or. + $ c_qc(ii)(3:3).eq.'K'.or. + $ c_qc(ii)(4:4).eq.'K'.or. + $ c_qc(ii)(5:5).eq.'K'.or. + $ (c_qc(ii)(6:6).eq.'K'.and. + $ (c_qc(ii)(7:7).eq.'K'.or. + $ c_qc(ii)(8:8).eq.'K'))) then +c + csort(ii)(1:5) = 'badob' +c + kbad(ktype) = kbad(ktype) + 1 +c + if(ktype.eq.1) then + nstk_Md = nstk_Md + 1 + elseif(ktype.eq.2) then + nstk_Ac = nstk_Ac + 1 + elseif(ktype.eq.3) then + nstk_Am = nstk_Am + 1 + elseif(ktype.eq.4) then + nstk_Ar = nstk_Ar + 1 + elseif(ktype.eq.5) then + nstk_Ma = nstk_Ma + 1 + endif +c +c Count reports with stuck temperature, wind direction, and wind speed +c -------------------------------------------------------------------- + else + if(c_qc(ii)(6:6).eq.'K') then + kbadt(ktype) = kbadt(ktype) + 1 + endif + if(c_qc(ii)(7:7).eq.'K'.or. + $ c_qc(ii)(8:8).eq.'K') then + kbadw(ktype) = kbadw(ktype) + 1 + endif + endif +c + enddo +c + if(.not.l_operational) then + write(io33,*) + write(io33,*)' Number of stuck MDCRS reps rejected=',kbad(1) +ccccdak write(io33,*)' Number of stuck ACARS reps rejected=',kbad(2) + write(io33,*)' Number of stuck TAMDAR reps rejected=',kbad(2) + write(io33,*)' Number of stuck AMDAR reps rejected=',kbad(3) + write(io33,*)' Number of stuck AIREP reps rejected=',kbad(4) + write(io33,*)' Number of stuck manAIREP reps rejected=',kbad(5) + write(io33,*)' Number of stuck MDCRS temps marked=',kbadt(1) +ccccdak write(io33,*)' Number of stuck ACARS temps marked=',kbadt(2) + write(io33,*)' Number of stuck TAMDAR temps marked=',kbadt(2) + write(io33,*)' Number of stuck AMDAR temps marked=',kbadt(3) + write(io33,*)' Number of stuck AIREP temps marked=',kbadt(4) + write(io33,*)' Number of stuck manAIREP temps marked=',kbadt(5) + write(io33,*)' Number of stuck MDCRS winds marked=',kbadw(1) +ccccdak write(io33,*)' Number of stuck ACARS winds marked=',kbadw(2) + write(io33,*)' Number of stuck TAMDAR winds marked=',kbadw(2) + write(io33,*)' Number of stuck AMDAR winds marked=',kbadw(3) + write(io33,*)' Number of stuck AIREP winds marked=',kbadw(4) + write(io33,*)' Number of stuck manAIREP winds marked=',kbadw(5) + endif +c + write(io8,*) + write(io8,*) ' Reports with stuck values' + write(io8,*) ' -------------------------' + write(io8,*)' Number of stuck MDCRS reps rejected = ',kbad(1) +ccccdak write(io8,*)' Number of stuck ACARS reps rejected = ',kbad(2) + write(io8,*)' Number of stuck TAMDAR reps rejected = ',kbad(2) + write(io8,*)' Number of stuck AMDAR reps rejected = ',kbad(3) + write(io8,*)' Number of stuck AIREP reps rejected = ',kbad(4) + write(io8,*)' Number of stuck manAIREP reps rejected = ',kbad(5) + write(io8,*)' Number of stuck MDCRS temps marked = ',kbadt(1) +ccccdak write(io8,*)' Number of stuck ACARS temps marked = ',kbadt(2) + write(io8,*)' Number of stuck TAMDAR temps marked = ',kbadt(2) + write(io8,*)' Number of stuck AMDAR temps marked = ',kbadt(3) + write(io8,*)' Number of stuck AIREP temps marked = ',kbadt(4) + write(io8,*)' Number of stuck manAIREP temps marked = ',kbadt(5) + write(io8,*)' Number of stuck MDCRS winds marked = ',kbadw(1) +ccccdak write(io8,*)' Number of stuck ACARS winds marked = ',kbadw(2) + write(io8,*)' Number of stuck TAMDAR winds marked = ',kbadw(2) + write(io8,*)' Number of stuck AMDAR winds marked = ',kbadw(3) + write(io8,*)' Number of stuck AIREP winds marked = ',kbadw(4) + write(io8,*)' Number of stuck manAIREP winds marked = ',kbadw(5) +c +c Output reports with good moisture +c --------------------------------- + if(.not.l_operational) then + write(io33,*) + write(io33,*) 'Reports with valid moisture' + write(io33,*) '---------------------------' + write(io33,3001) + endif +c + do iob = 1,numreps + ii = indx(iob) +c + +cc smb 8/18/05 - ichk arrays were declared as reals, should have been integer +cc fixed 8/19/05. +cc if(l_ncep.and.ob_q(ii).eq.amiss) then +cc ichk_q(ii) = -9 +cc endif + + if(ob_q(ii).eq.amiss.and. + $ (ichk_q(ii).eq.-9.or. + $ ichk_q(ii).eq.9)) then +c +c missing moisture and QC flag signals missing data +c + elseif((ifix(ob_q(ii)*100).eq.0.or.ob_q(ii).eq.amiss).and. + $ ichk_q(ii).eq.-7.and. + $ (c_acftreg(ii)(4:5).eq.'WU'.or. + $ c_acftreg(ii)(4:5).eq.'GU')) then +c +c moisture qc flag = -7 means invalid input parameter +c + elseif(.not.l_operational) then + write(io33,3002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + endif + enddo +c +c Output tail number counts +c ------------------------- + write(io8,*) + write(io8,*) ' Tail numbers for reports with temp in whole deg' +ccccdak write(io8,*) ' Tail Num MDCRS ACARS AMDAR AIREP MAN ' + write(io8,*) ' Tail Num MDCRS TAMDAR AMDAR AIREP MAN ' + write(io8,*) ' -------------------------------------------' +c + do mm=1,kreg + if( nwhol_reg(mm,1)+nwhol_reg(mm,2)+nwhol_reg(mm,3) + $ +nwhol_reg(mm,4)+nwhol_reg(mm,5).gt.0) then + write(io8,'(2x,a8,5(1x,i6))') + $ creg_reg(mm),(nwhol_reg(mm,kk),kk=1,5) + endif + enddo +c + write(io8,*) + write(io8,*) ' Tail numbers for reports with stuck temperature' +ccccdak write(io8,*) ' Tail Num MDCRS ACARS AMDAR AIREP MAN ' + write(io8,*) ' Tail Num MDCRS TAMDAR AMDAR AIREP MAN ' + write(io8,*) ' -------------------------------------------' +c + do mm=1,kreg + if( ntemp_reg(mm,1)+ntemp_reg(mm,2)+ntemp_reg(mm,3) + $ +ntemp_reg(mm,4)+ntemp_reg(mm,5).gt.0) then + write(io8,'(2x,a8,5(1x,i6))') + $ creg_reg(mm),(ntemp_reg(mm,kk),kk=1,5) + endif + enddo +c + write(io8,*) + write(io8,*) ' Tail numbers for reports with stuck winds' +ccccdak write(io8,*) ' Tail Num MDCRS ACARS AMDAR AIREP MAN ' + write(io8,*) ' Tail Num MDCRS TAMDAR AMDAR AIREP MAN ' + write(io8,*) ' -------------------------------------------' +c + do mm=1,kreg + if( nwind_reg(mm,1)+nwind_reg(mm,2)+nwind_reg(mm,3) + $ +nwind_reg(mm,4)+nwind_reg(mm,5).gt.0) then + write(io8,'(2x,a8,5(1x,i6))') + $ creg_reg(mm),(nwind_reg(mm,kk),kk=1,5) + endif + enddo +c + write(*,*) + write(*,*) 'Stuck value check data counts--',cdtg_an + write(*,*) '-----------------------------------------' + write(*,'(1x,a55)') +ccccdak $ 'Type of check MDCRS ACARS AMDAR AIREP man' + $ 'Type of check MDCRS TAMDAR AMDAR AIREP man' + write(*,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(*,'('' Num considered '',5(1x,i7))') + $ nrep_Md,nrep_Ac,nrep_Am,nrep_Ar,nrep_Ma + write(*,'('' Total invalid '',5(1x,i7))') + $ nstk_Md,nstk_Ac,nstk_Am,nstk_Ar,nstk_Ma + write(*,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(*,'('' Temps in wh deg'',5(1x,i7))') + $ (nstk_whol(ii),ii=1,5) + write(*,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + write(io8,*) + write(io8,*) 'Stuck value check data counts' + write(io8,*) '-----------------------------' + write(io8,'(1x,a55)') +ccccdak $ 'Type of check MDCRS ACARS AMDAR AIREP man' + $ 'Type of check MDCRS TAMDAR AMDAR AIREP man' + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Num considered '',5(1x,i7))') + $ nrep_Md,nrep_Ac,nrep_Am,nrep_Ar,nrep_Ma + write(io8,'(''Total rejected '',5(1x,i7))') + $ nstk_Md,nstk_Ac,nstk_Am,nstk_Ar,nstk_Ma + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Temps in wh deg'',5(1x,i7))') + $ (nstk_whol(ii),ii=1,5) + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + write(io8,'(''Stuck time '',5(1x,i7))') + $ (nstk_time(ii),ii=1,5) + write(io8,'(''Stuck position '',5(1x,i7))') + $ (nstk_posn(ii),ii=1,5) + write(io8,'(''Stuck time&posn'',5(1x,i7))') + $ (nstk_both(ii),ii=1,5) + write(io8,'(''Stuck latitude '',5(1x,i7))') + $ (nstk_alat(ii),ii=1,5) + write(io8,'(''Stuck longitude'',5(1x,i7))') + $ (nstk_alon(ii),ii=1,5) + write(io8,'(''Stuck pressure '',5(1x,i7))') + $ (nstk_pres(ii),ii=1,5) + write(io8,'(''Stuck values '',5(1x,i7))') + $ (nstk_val(ii),ii=1,5) + write(io8,'(''Stuck temp '',5(1x,i7))') + $ (nstk_temp(ii),ii=1,5) + write(io8,'(''Stuck direction'',5(1x,i7))') + $ (nstk_wdir(ii),ii=1,5) + write(io8,'(''Stuck speed '',5(1x,i7))') + $ (nstk_wspd(ii),ii=1,5) + write(io8,'(''Stuck moisture '',5(1x,i7))') + $ (nstk_moist(ii),ii=1,5) + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + kbadtot = kbad(1) + kbad(2) + kbad(3) + $ + kbad(4) + kbad(5) +c + write(io8,*) + write(io8,*) numreps,' good reports processed' + write(io8,*) kbadtot,' reports failed qc in stuck value check' +c + return + end +c +c ################################################################### +c subroutine grchek_qc +c ################################################################### +c + subroutine grchek_qc(numreps,max_reps,indx,csort,amiss,cdtg_an + $, c_acftreg,c_acftid,c_qc + $, alat,alon,pres,ht_ft,t_prcn,ob_t,ob_q,ob_dir,ob_spd + $, xiv_t,xiv_q,xiv_d,xiv_s + $, idt,itype,ichk_t,ichk_q,ichk_d,ichk_s + $, cbadtemp,nbadtemp + $, cblkwind,nblkwind,cblktemp,nblktemp,kbadtot,io8,io34 + $, maxflt,kreg,creg_reg,nwhol_reg,nwind_reg + $, ft2m,l_operational,l_init) +c +c Perform gross checks on aircraft data +c + implicit none +c +c Declaration statements +c ---------------------- + integer max_reps ! maximum number of reports +c + character*11 c_qc(max_reps) ! internal qc flags +c +c Data arrays +c ----------- + integer numreps ! actual number of reports + character*10 cdtg_an ! date time group for analysis + integer itype(max_reps) ! type of aircraft data + integer idt(max_reps) ! time in seconds to analysis time + character*8 c_acftreg(max_reps) ! aircraft registration (tail) number + character*9 c_acftid(max_reps) ! aircraft flight number + real*8 alat(max_reps) ! latitude + $, alon(max_reps) ! longitude + real pres(max_reps) ! pressure + $, ht_ft(max_reps) ! height in feet + real t_prcn(max_reps) ! temperature precision + real ob_t(max_reps) ! temperature + $, ob_q(max_reps) ! specific humidity + $, ob_dir(max_reps) ! wind direction + $, ob_spd(max_reps) ! wind speed + real xiv_t(max_reps) ! temperature innovation (ob - bk) + $, xiv_q(max_reps) ! specific humidity innovation (ob - bk) + $, xiv_d(max_reps) ! wind direction innovation (ob - bk) + $, xiv_s(max_reps) ! wind speed innovation (ob - bk) + integer ichk_t(max_reps) ! NRL QC flag for temperature ob + $, ichk_q(max_reps) ! NRL QC flag for specific humidity ob + $, ichk_d(max_reps) ! NRL QC flag for wind direction ob + $, ichk_s(max_reps) ! NRL QC flag for wind speed ob + character*25 csort(max_reps) ! sort variable +c +c Pointers +c -------- + integer indx(max_reps) ! pointer index for good reports +c +c Tail number statistics +c ---------------------- + integer kreg ! actual number of tail#s in dataset + $, mm ! index pointing to current tail number + integer maxflt ! max number of flights allowed + character*8 creg_reg(maxflt) ! tail numbers + integer nwhol_reg(maxflt,5) ! number of reports w. temp in whole deg + integer nwind_reg(maxflt,5) ! number of reports w. rejected winds +c +c Functions +c --------- + character*16 c_insty_ob ! function to convert integer instrument + ! type to character instrument type + integer insty_ob_fun ! function to convert character + ! instrument type to integer +c +c Black list arrays +c ----------------- + integer nbadtemp ! # of acft with temps in whole degrees + $, nblkwind ! # of acft blacklisted for wind errors + $, nblktemp ! # of acft blacklisted for temp errors + character*8 cbadtemp(nbadtemp) ! acft reports temp in whole deg C + $, cblkwind(nblkwind) ! winds blacklisted + $, cblktemp(nblktemp) ! temperatures blacklisted +c +c Other variables +c --------------- + integer io8 ! i/o unit number for log file + integer io34 ! i/o unit number for gross errors +c + real amiss ! real missing value flag +c + integer iob ! do loop index + $, ii ! index pointing to current report + $, iim1 ! index pointing to previous report + $, iip1 ! index pointing to following report + integer idt1_00z ! relative time equal to 00Z (pos) + $, idt2_00z ! relative time equal to 00Z (neg) +c + integer nac ! do loop index + integer nrep(5) ! number of reports considered + integer kbad(5) ! counter for number of bad reports + $, n_sus_time(5) ! counter for suspect times + $, n_bad_pos(5) ! counter for bad latitudes or longitudes + $, n_sus_lat(5) ! counter for suspect latitudes + $, n_sus_lon(5) ! counter for suspect longitudes + $, n_sus_alt(5) ! counter for suspect altitudes + $, n_bad_alt(5) ! counter for bad altitudes/pressures + $, n_inc_alt(5) ! counter for inconsistent altitudes + $, n_bad_UAL(5) ! counter for bad UAL surface reports + $, n_list_temp(5) ! counter for black-listed temperatures + $, n_whole_temp(5) ! counter for whole-degree temperatures + $, n_mis_temp(5) ! counter for missing temperatures + $, n_bad_temp(5) ! counter for bad temperatures + $, n_cold_temp(5) ! counter for anomalous cold temperatures + $, n_list_wind(5) ! counter for black-listed winds + $, n_mis_dir(5) ! counter for missing directions + $, n_bad_dir(5) ! counter for bad directions + $, n_inc_dir(5) ! counter for inconsistent directions + $, n_mis_spd(5) ! counter for missing speeds + $, n_inc_spd(5) ! counter for inconsistent speeds + $, n_calm_spd(5) ! counter for rejected calm speeds + $, n_bad_spd(5) ! counter for bad speeds + $, n_mis_moist(5) ! counter for missing moisture + $, n_bad_moist(5) ! counter for bad moisture + $, n_sus_moist(5) ! counter for suspect moisture + $, n_bad_rep(5) ! counter for reports with both bad winds + ! and bad temperatures + $, kbadtot ! counter for total number of bad reps +c + real tmax ! max allowable temperature + $, tmin ! min allowable temperature + $, wmax ! max allowable windspeed + $, ft2m ! ft to meters conversion factor + $, height_ft ! computed height in feet + $, height_m ! computed height in meters + $, t ! temperature in centigrade + $, es ! saturation vapor pressure + $, qs ! saturation specific humidity +c +ccccdak integer i_acars ! instrument type for acars + integer i_acars ! instrument type for tamdar +ccccdak $, i_acars_lvl ! instrument type for acars--level flt + $, i_acars_lvl ! instrument type for tamdar--level flt +ccccdak $, i_acars_asc ! instrument type for acars--ascent + $, i_acars_asc ! instrument type for tamdar--ascent +ccccdak $, i_acars_des ! instrument type for acars--descent + $, i_acars_des ! instrument type for tamdar--descent + $, i_mdcrs ! instrument type for mdcrs + $, i_mdcrs_lvl ! instrument type for mdcrs--level flt + $, i_mdcrs_asc ! instrument type for mdcrs--ascent + $, i_mdcrs_des ! instrument type for mdcrs--descent + $, i_man_airep ! instrument type for manual aireps + $, i_man_Yairep ! instrument type for manual aireps (YRXX) + $, i_airep ! instrument type for airep + $, i_airep_lvl ! instrument type for airep--level flt + $, i_airep_asc ! instrument type for airep--ascent + $, i_airep_des ! instrument type for airep--descent + $, i_amdar ! instrument type for amdar + $, i_amdar_lvl ! instrument type for amdar--level flt + $, i_amdar_asc ! instrument type for amdar--ascent + $, i_amdar_des ! instrument type for amdar--descent + integer ktype ! instrument type index +c +c Switches +c -------- + logical l_print ! print values if true + $, l_init ! initialize counters if true +ccccdak $, l_ii_acars ! true if ii rep is type acars + $, l_ii_acars ! true if ii rep is type tamdar + $, l_ii_mdcrs ! true if ii rep is type mdcrs + $, l_ii_airep ! true if ii rep is type airep + $, l_ii_man ! true if ii rep is type manual airep + $, l_ii_amdar ! true if ii rep is type amdar + $, l_operational ! run QC in operational mode if true +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c +c Initialize variables +c -------------------- + if(l_init) then + nrep = 0 + n_sus_time = 0 + n_bad_pos = 0 + n_sus_lat = 0 + n_sus_lon = 0 + n_sus_alt = 0 + n_bad_alt = 0 + n_inc_alt = 0 + n_bad_UAL = 0 + n_list_temp = 0 + n_mis_temp = 0 + n_bad_temp = 0 + n_cold_temp = 0 + n_list_wind = 0 + n_mis_dir = 0 + n_bad_dir = 0 + n_inc_dir = 0 + n_mis_spd = 0 + n_inc_spd = 0 + n_calm_spd = 0 + n_bad_spd = 0 + n_mis_moist = 0 + n_bad_moist = 0 + n_sus_moist = 0 + n_bad_rep = 0 + n_whole_temp = 0 + kbad = 0 + endif +c + nwhol_reg = 0 + nwind_reg = 0 +c +c Compute relative time equal to 00z +c ---------------------------------- + read(cdtg_an,'(8x,i2)') idt1_00z + idt1_00z = idt1_00z * 3600 + idt2_00z = 0 - idt1_00z +c +c Initialize aircraft data types +c ------------------------------ + i_acars = insty_ob_fun('acars') + i_acars_lvl = insty_ob_fun('acars_lvl') + i_acars_asc = insty_ob_fun('acars_asc') + i_acars_des = insty_ob_fun('acars_des') + i_mdcrs = insty_ob_fun('mdcrs') + i_mdcrs_lvl = insty_ob_fun('mdcrs_lvl') + i_mdcrs_asc = insty_ob_fun('mdcrs_asc') + i_mdcrs_des = insty_ob_fun('mdcrs_des') + i_man_airep = insty_ob_fun('man-airep') + i_man_Yairep = insty_ob_fun('man-Yairep') + i_airep = insty_ob_fun('airep') + i_airep_lvl = insty_ob_fun('airep_lvl') + i_airep_asc = insty_ob_fun('airep_asc') + i_airep_des = insty_ob_fun('airep_des') + i_amdar = insty_ob_fun('amdar') + i_amdar_lvl = insty_ob_fun('amdar_lvl') + i_amdar_asc = insty_ob_fun('amdar_asc') + i_amdar_des = insty_ob_fun('amdar_des') +c +c Loop over reports +c ----------------- + do iob=1,numreps + ii = indx(iob) + l_print = .false. +c +c Set up logical variables used in testing +c ---------------------------------------- + l_ii_mdcrs = .false. + l_ii_acars = .false. + l_ii_amdar = .false. + l_ii_airep = .false. + l_ii_man = .false. +c +c ii report is MDCRS? +c ------------------- + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_des.or. + $ itype(ii).eq.i_mdcrs_asc) then + l_ii_mdcrs = .true. + ktype = 1 +c +ccccdak report is ACARS? +c report is TAMDAR? +c ------------------- + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_des.or. + $ itype(ii).eq.i_acars_asc) then + l_ii_acars = .true. + ktype = 2 +c +c ii report is AMDAR? +c ------------------- + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_des.or. + $ itype(ii).eq.i_amdar_asc) then + l_ii_amdar = .true. + ktype = 3 +c +c ii report is AIREP? +c ------------------- + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_des.or. + $ itype(ii).eq.i_airep_asc) then + l_ii_airep = .true. + ktype = 4 +c +c ii report is manual AIREP? +c -------------------------- + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + l_ii_man = .true. + ktype = 5 + endif +c +c Compute height in feet from pressure for pressure/altitude check +c ---------------------------------------------------------------- + call p2ht_qc(pres(ii),height_m,amiss) + call ht2fl_qc(height_m,height_ft,amiss,ft2m) +c +c write(io8,*) 'p2ht test--tail#,pressure,computed ht,obs ht' +c write(io8,*) c_acftreg(ii),pres(ii),height_ft,ht_ft(ii) +c +c First perform checks that reject the whole report +c ------------------------------------------------- +c +! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c Reject reports with unphysical latitudes +c ---------------------------------------- + if(alat(ii).gt.90.0.or.alat(ii).lt.-90.0) then + l_print = .true. + if(l_print) write(io8,*) 'Latitude bad' + c_qc(ii)(3:3) = 'B' + n_bad_pos(ktype) = n_bad_pos(ktype) + 1 +c +c Reject reports with unphysical longitudes +c ----------------------------------------- + elseif(alon(ii).gt.360.0.or.alon(ii).lt.0.0) then + l_print = .true. + if(l_print) write(io8,*) 'Longitude bad' + c_qc(ii)(4:4) = 'B' + n_bad_pos(ktype) = n_bad_pos(ktype) + 1 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c +c Reject reports with unphysical or inconsistent pressures/altitudes +c ------------------------------------------------------------------ + elseif(pres(ii).gt.1080..or.pres(ii).lt.50.) then + l_print = .true. + if(l_print) write(io8,*) 'Pressure bad' + if(c_qc(ii)(5:5).eq.'R') pres(ii) = amiss + if(c_qc(ii)(5:5).eq.'r') ht_ft(ii) = amiss + c_qc(ii)(5:5) = 'B' + n_bad_alt(ktype) = n_bad_alt(ktype) + 1 +c + elseif(abs(height_ft-ht_ft(ii)).gt.25.0) then + l_print = .true. + if(l_print) write(io8,*) 'Pressure and height inconsistent' + c_qc(ii)(5:5) = 'I' + n_inc_alt(ktype) = n_inc_alt(ktype) + 1 +c +c Reject surface UAL aireps +c (1/27/00) These are actually erroneous reports from UAL Airbus A320/A319 +c aircraft that Tinker has incorrectly re-encoded into AIREP format. +c In these reports, the altitude is divided by 10, temperature is +c missing, the values listed as windspeed are actually wind +c direction, and it's not clear what is listed as wind direction. +c ----------------------------------------------------------------------------- + elseif((l_ii_man.or.l_ii_airep).and. + $ c_acftid(ii)(1:3).eq.'UAL'.and. + $ ht_ft(ii).lt.5000.0.and. + $ ob_t(ii).eq.amiss) then + l_print = .true. + if(l_print) write(io8,*) 'Bad UAL surface report' + c_qc(ii)(1:1) = 'B' + n_bad_UAL(ktype) = n_bad_UAL(ktype) + 1 +c +c Now, perform checks on individual parameters in remaining reports +c ----------------------------------------------------------------- + else +c +c Exclude missing temperatures +c ---------------------------- + if(ob_t(ii).eq.amiss) then +c l_print = .true. + if(l_print) write(io8,*) 'Temperature missing' + c_qc(ii)(6:6) = 'M' + n_mis_temp(ktype) = n_mis_temp(ktype) + 1 +c +c Check list of aircraft reporting temperature in whole deg +c Re-compute temperature to correct +c (Since most of the aircraft were fixed by mid-1999, stop +c doing this check after 1 Oct 1999) +c --------------------------------------------------------- + elseif(cdtg_an.lt.'1999100100') then + do nac = 1,nbadtemp + if(c_acftreg(ii).eq.cbadtemp(nac)) then +c l_print = .true. + if(l_print) write(io8,*)'On list with temp in whole deg' + c_qc(ii)(10:10) = 'C' +c +ccccdak Recompute temperature for ACARS or MDCRS reports +c Recompute temperature for TAMDAR or MDCRS reports +c (Since AIREPs are reported only to nearest degree, +c don't bother to recompute temperature--inadequate precision!) +c --------------------------------------------------------------------- +c +c Don't bother with temperatures already fixed or rejected +c -------------------------------------------------------- + if(c_qc(ii)(6:6).ne.'R'.and. + $ c_qc(ii)(6:6).ne.'b'.and. + $ c_qc(ii)(6:6).ne.'E'.and. + $ c_qc(ii)(6:6).ne.'I'.and. + $ c_qc(ii)(6:6).ne.'K') then +c +c If temperatures are outside of limits, assume that the +c error was corrected on this aircraft +c ------------------------------------------------------ + if(ob_t(ii).lt.266.0.or.ob_t(ii).gt.278.0) then + l_print = .true. + if(l_print) then + write(io8,*) 'On list with temp in whole deg' + write(io8,*) ' Temperature not within bounds!!!' + endif +c +ccccdak If bad temperature occurred in an ACARS, MDCRS, or +c If bad temperature occurred in an TAMDAR, MDCRS, or +c AMDAR report, fix it +c --------------------------------------------------- + elseif(l_ii_acars.or.l_ii_mdcrs.or.l_ii_amdar) then + ob_t(ii) = (ob_t(ii) - 273.16) * 10. + 273.16 + l_print = .true. + if(l_print) write(io8,*) ' temperature recomputed' + t_prcn(ii) = 1.00 + c_qc(ii)(6:6) = 'R' + n_whole_temp(ktype) = n_whole_temp(ktype) + 1 +c +c Count number of whole-degree temps by tail number +c ------------------------------------------------- + mm = 1 + do while(mm.le.kreg) + if(c_acftreg(ii).eq.creg_reg(mm)) then + nwhol_reg(mm,ktype) = nwhol_reg(mm,ktype) + 1 + mm = kreg + 1 + endif + mm = mm + 1 + enddo +c +c If bad temperature occurred in an AIREP, reject it +c -------------------------------------------------- + else + l_print = .true. + if(l_print) then + write(io8,*) 'On list with temp in whole deg' + write(io8,*) ' temperature marked bad' + endif + c_qc(ii)(6:6) = 'b' + n_whole_temp(ktype) = n_whole_temp(ktype) + 1 + endif + endif +c + endif + enddo + endif +c +c QC temperature--Moninger algorithm +c ---------------------------------- + if(c_qc(ii)(6:6).ne.'b'.and. + $ c_qc(ii)(6:6).ne.'E'.and. + $ c_qc(ii)(6:6).ne.'I'.and. + $ c_qc(ii)(6:6).ne.'K'.and. + $ c_qc(ii)(6:6).ne.'B'.and. + $ c_qc(ii)(6:6).ne.'M') then +c +c Check for anomalously cold temperatures accompanied by missing winds +c -------------------------------------------------------------------- + if(ob_t(ii).lt.205.0.and. + $ ob_spd(ii).eq.amiss.and. + $ ob_dir(ii).eq.amiss) then + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Cold temperature with missing winds' + endif + c_qc(ii)(6:6) = 'B' + n_cold_temp(ktype) = n_cold_temp(ktype) + 1 +c +c QC upper-level temperatures +c --------------------------- + else + if(ht_ft(ii).gt.35000.) then + if(ob_t(ii).gt.253.16-0.005.or. + $ ob_t(ii).lt.173.15+0.005) then + l_print = .true. + if(l_print) write(io8,*) 'Temperature bad--173 253' + c_qc(ii)(6:6) = 'B' + n_bad_temp(ktype) = n_bad_temp(ktype) + 1 +c + else + if(c_qc(ii)(6:6).eq.'-') c_qc(ii)(6:6) = '.' + endif +c +c QC lower-level temperatures +c --------------------------- + else + tmax = 60. - 80. * (ht_ft(ii) / 35000.) + tmax = tmax + 273.16 + tmin = -60. - 40. * (ht_ft(ii) - 18000.) / 17000. + tmin = tmin + 273.16 + if(ht_ft(ii).lt.18000.) tmin = 213.16 + if(ob_t(ii).gt.tmax.or.ob_t(ii).lt.tmin) then + l_print = .true. + if(l_print) write(io8,*) 'Temperature bad--',tmin,tmax + c_qc(ii)(6:6) = 'B' + n_bad_temp(ktype) = n_bad_temp(ktype) + 1 +c + else + if(c_qc(ii)(6:6).eq.'-') c_qc(ii)(6:6) = '.' + endif + endif + endif + endif +c +c Check if aircraft is on black list for temp errors +c -------------------------------------------------- + if(c_qc(ii)(10:10).eq.'-') c_qc(ii)(10:10) = '.' +c + do nac = 1,nblktemp + if(c_acftreg(ii).eq.cblktemp(nac)) then +c l_print = .true. + if(l_print) write(io8,*) 'Black-listed for temp errors' + c_qc(ii)(10:10) = 'T' + n_list_temp(ktype) = n_list_temp(ktype) + 1 + endif + enddo +cc +cc QC temperature--RAOB algorithm +cc ------------------------------ +c if(ob_t(ii).ne.amiss) then +cc $ c_qc(ii)(6:6).ne.'b'.and. +cc $ c_qc(ii)(6:6).ne.'E'.and. +cc $ c_qc(ii)(6:6).ne.'I'.and. +cc $ c_qc(ii)(6:6).ne.'K') then +c +c if(pres(ii).le.300.0.or. +! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c $ (pres(ii).le.400.0.and.alat(ii).gt.45.0)) then +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c if(ob_t(ii).le.173.15.or.ob_t(ii).ge.268.15) then +c l_print = .true. +c if(l_print) write(io8,*) 'Temperature bad by RAOB check' +c if(l_print.and.c_qc(ii)(6:6).ne.'B') +c $ write(io8,*) ' Report not rejected by Moninger check' +c endif +cc +! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c elseif(abs(alat(ii)).le.45.0) then +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c if(pres(ii).le.400.) then +c tmax = 268.15 + (pres(ii) - 300.) / 100. * 5.0 +c if(ob_t(ii).le.173.15.or.ob_t(ii).ge.tmax) then +c l_print = .true. +c if(l_print) write(io8,*) 'Temperature bad by RAOB check' +c if(l_print.and.c_qc(ii)(6:6).ne.'B') +c $ write(io8,*) ' Report not rejected by Moninger check' +c endif +c elseif(pres(ii).le.500.0) then +c tmin = 173.16 + (pres(ii) - 400.) / 100. * 5.0 +c tmax = 273.16 + (pres(ii) - 400.) / 100. * 10.0 +c if(ob_t(ii).le.tmin.or.ob_t(ii).ge.tmax) then +c l_print = .true. +c if(l_print) write(io8,*) 'Temperature bad by RAOB check' +c if(l_print.and.c_qc(ii)(6:6).ne.'B') +c $ write(io8,*) ' Report not rejected by Moninger check' +c endif +c elseif(pres(ii).le.700.0) then +c tmin = 178.15 + (pres(ii) - 500.) / 200. * 15.0 +c tmax = 283.15 + (pres(ii) - 500.) / 200. * 20.0 +c if(ob_t(ii).le.tmin.or.ob_t(ii).ge.tmax) then +c l_print = .true. +c if(l_print) write(io8,*) 'Temperature bad by RAOB check' +c if(l_print.and.c_qc(ii)(6:6).ne.'B') +c $ write(io8,*) ' Report not rejected by Moninger check' +c endif +c elseif(pres(ii).le.850.0) then +c tmin = 193.15 + (pres(ii) - 700.) / 150. * 15.0 +c tmax = 303.15 + (pres(ii) - 700.) / 150. * 10.0 +c if(ob_t(ii).le.tmin.or.ob_t(ii).ge.tmax) then +c l_print = .true. +c if(l_print) write(io8,*) 'Temperature bad by RAOB check' +c if(l_print.and.c_qc(ii)(6:6).ne.'B') +c $ write(io8,*) ' Report not rejected by Moninger check' +c endif +c elseif(pres(ii).le.1000.0) then +c tmin = 208.15 + (pres(ii) - 850.) / 150. * 15.0 +c tmax = 313.15 + (pres(ii) - 850.) / 150. * 20.0 +c if(ob_t(ii).le.tmin.or.ob_t(ii).ge.tmax) then +c l_print = .true. +c if(l_print) write(io8,*) 'Temperature bad by RAOB check' +c if(l_print.and.c_qc(ii)(6:6).ne.'B') +c $ write(io8,*) ' Report not rejected by Moninger check' +c endif +c elseif(pres(ii).gt.1000.0) then +c if(ob_t(ii).le.223.15.or.ob_t(ii).ge.333.15) then +c l_print = .true. +c if(l_print) write(io8,*) 'Temperature bad by RAOB check' +c if(l_print.and.c_qc(ii)(6:6).ne.'B') +c $ write(io8,*) ' Report not rejected by Moninger check' +c endif +c endif +cc +c else +c if(pres(ii).le.500.0) then +c tmax = 268.15 + (pres(ii) - 400.) / 100. * 10.0 +c if(ob_t(ii).le.173.15.or.ob_t(ii).ge.tmax) then +c l_print = .true. +c if(l_print) write(io8,*) 'Temperature bad by RAOB check' +c if(l_print.and.c_qc(ii)(6:6).ne.'B') +c $ write(io8,*) ' Report not rejected by Moninger check' +c endif +c elseif(pres(ii).le.700.0) then +c tmin = 173.15 + (pres(ii) - 500.) / 200. * 10.0 +c tmax = 278.15 + (pres(ii) - 500.) / 200. * 15.0 +c if(ob_t(ii).le.tmin.or.ob_t(ii).ge.tmax) then +c l_print = .true. +c if(l_print) write(io8,*) 'Temperature bad by RAOB check' +c if(l_print.and.c_qc(ii)(6:6).ne.'B') +c $ write(io8,*) ' Report not rejected by Moninger check' +c endif +c elseif(pres(ii).le.850.0) then +c tmax = 293.15 + (pres(ii) - 700.) / 150. * 10.0 +c if(ob_t(ii).le.183.15.or.ob_t(ii).ge.tmax) then +c l_print = .true. +c if(l_print) write(io8,*) 'Temperature bad by RAOB check' +c if(l_print.and.c_qc(ii)(6:6).ne.'B') +c $ write(io8,*) ' Report not rejected by Moninger check' +c endif +c elseif(pres(ii).le.1000.0) then +c tmax = 303.15 + (pres(ii) - 850.) / 150. * 20.0 +c if(ob_t(ii).le.183.15.or.ob_t(ii).ge.tmax) then +c l_print = .true. +c if(l_print) write(io8,*) 'Temperature bad by RAOB check' +c if(l_print.and.c_qc(ii)(6:6).ne.'B') +c $ write(io8,*) ' Report not rejected by Moninger check' +c endif +c elseif(pres(ii).gt.1000.0) then +c if(ob_t(ii).le.183.15.or.ob_t(ii).ge.323.15) then +c l_print = .true. +c if(l_print) write(io8,*) 'Temperature bad by RAOB check' +c if(l_print.and.c_qc(ii)(6:6).ne.'B') +c $ write(io8,*) ' Report not rejected by Moninger check' +c endif +c endif +c +c endif +c endif +c +c Perform remaining tests only if temperature not rejected +c -------------------------------------------------------- + if(c_qc(ii)(6:6).ne.'B') then +cc +cc Check list of aircraft flipping winds +cc (Test skipped since list of aircraft used actual tail numbers +cc rather than pseudo-numbers!) +cc ------------------------------------- +c do nac = 1,nbadwind +c if(c_acftreg(ii).eq.cbadwind(nac)) then +c write(io8,*) +c write(io8,*) c_acftreg(ii),' in rep # ',ii, +c $ ' on list of acft with flipped winds' +c c_qc(ii)(10:10) = 'F' +c endif +c enddo +cc +cc Check list of aircraft reporting decimal lat/lons +cc No correction performed at present +cc (Test skipped since list of aircraft used actual tail numbers +cc rather than the pseudo-numbers used currently!) +cc ------------------------------------------------------------- +c do nac = 1,nbadlat +c if(c_acftreg(ii).eq.cbadlat(nac)) then +c write(io8,*) +c write(io8,*) c_acftreg(ii),' in rep # ',ii, +c $ ' on list of acft with decimal lat/lons' +c c_qc(ii)(10:10) = 'L' +c endif +c enddo +c +c QC relative time +c ---------------- + if(idt(ii).eq.idt1_00z.or. + $ idt(ii).eq.idt2_00z) then +c l_print = .true. + if(l_print) write(io8,*) 'Time equal to 00Z' + c_qc(ii)(2:2) = 'S' + n_sus_time(ktype) = n_sus_time(ktype) + 1 + else + if(c_qc(ii)(2:2).eq.'-') c_qc(ii)(2:2) = '.' + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c +c QC latitude +c ----------- + if(abs(alat(ii)).lt.0.005) then + l_print = .false. + if(l_print) write(io8,*) 'Latitude zero' + c_qc(ii)(3:3) = 'S' + n_sus_lat(ktype) = n_sus_lat(ktype) + 1 + else + if(c_qc(ii)(3:3).eq.'-') c_qc(ii)(3:3) = '.' + endif +c +c QC longitude +c ------------ + if(abs(alon(ii)).lt.0.005) then + l_print = .false. + if(l_print) write(io8,*) 'Longitude zero' + c_qc(ii)(4:4) = 'S' + n_sus_lon(ktype) = n_sus_lon(ktype) + 1 + else + if(c_qc(ii)(4:4).eq.'-') c_qc(ii)(4:4) = '.' + endif +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c +c Set zero altitude to suspect +c ---------------------------- + if(abs(ht_ft(ii)).lt.0.5) then + l_print = .true. + if(l_print) write(io8,*) 'Altitude zero' + c_qc(ii)(5:5) = 'S' + n_sus_alt(ktype) = n_sus_alt(ktype) + 1 + else + if(c_qc(ii)(5:5).eq.'-') c_qc(ii)(5:5) = '.' + endif +c +c QC winds--Moninger algorithm +c ---------------------------- +c +c QC direction +c ------------ +c if(ob_dir(ii).eq.0.0) then +c ob_dir(ii) = 360. +c + if(ob_dir(ii).eq.amiss) then +c l_print = .true. + if(l_print) write(io8,*) 'Wind direction missing' + c_qc(ii)(7:7) = 'M' + n_mis_dir(ktype) = n_mis_dir(ktype) + 1 +c + elseif(c_qc(ii)(7:7).ne.'K'.and. + $ c_qc(ii)(7:7).ne.'E'.and. + $ c_qc(ii)(7:7).ne.'B') then + if(ob_dir(ii).lt.0.0.or.ob_dir(ii).gt.360.0) then + l_print = .true. + if(l_print) write(io8,*) 'Wind direction bad',ob_dir(ii) + c_qc(ii)(7:7) = 'B' + n_bad_dir(ktype) = n_bad_dir(ktype) + 1 +c +c Count number of rejected winds by tail number +c --------------------------------------------- + mm = 1 + do while(mm.le.kreg) + if(c_acftreg(ii).eq.creg_reg(mm)) then + nwind_reg(mm,ktype) = nwind_reg(mm,ktype) + 1 + mm = kreg + 1 + endif + mm = mm + 1 + enddo +c + else + if(c_qc(ii)(7:7).eq.'-') c_qc(ii)(7:7) = '.' + endif + endif +c +c QC speed +c -------- +c +c First flag missing wind speeds +c ------------------------------ + if(ob_spd(ii).eq.amiss) then +c l_print = .true. + if(l_print) write(io8,*) 'Wind speed missing' + c_qc(ii)(8:8) = 'M' + n_mis_spd(ktype) = n_mis_spd(ktype) + 1 +c +c Flag inconsistent directions--speed missing, direction not +c ---------------------------------------------------------- + if(c_qc(ii)(7:7).ne.'M'.and. + $ c_qc(ii)(7:7).ne.'B'.and. + $ c_qc(ii)(7:7).ne.'E'.and. + $ c_qc(ii)(7:7).ne.'K') then +c l_print = .true. + if(l_print) write(io8,*) 'Wind direction not missing' + c_qc(ii)(7:7) = 'I' + n_inc_dir(ktype) = n_inc_dir(ktype) + 1 +c +c Count number of rejected winds by tail number +c --------------------------------------------- + mm = 1 + do while(mm.le.kreg) + if(c_acftreg(ii).eq.creg_reg(mm)) then + nwind_reg(mm,ktype) = nwind_reg(mm,ktype) + 1 + mm = kreg + 1 + endif + mm = mm + 1 + enddo +c + endif +c +c Exclude previously rejected wind speeds +c --------------------------------------- + elseif(c_qc(ii)(8:8).ne.'K'.and. + $ c_qc(ii)(8:8).ne.'E') then +c +c Flag inconsistent speeds--direction missing, speed not +c ------------------------------------------------------ + if(ob_dir(ii).eq.amiss) then +c l_print = .true. + if(l_print) write(io8,*) 'Wind speed not missing' + c_qc(ii)(8:8) = 'I' + n_inc_spd(ktype) = n_inc_spd(ktype) + 1 +c +c Count number of rejected winds by tail number +c --------------------------------------------- + mm = 1 + do while(mm.le.kreg) + if(c_acftreg(ii).eq.creg_reg(mm)) then + nwind_reg(mm,ktype) = nwind_reg(mm,ktype) + 1 + mm = kreg + 1 + endif + mm = mm + 1 + enddo +c +c Flag negative winds speeds +c -------------------------- + elseif(ob_spd(ii).lt.0.0) then + l_print = .true. + if(l_print) write(io8,*) 'Wind speed negative' + c_qc(ii)(8:8) = 'B' + n_bad_spd(ktype) = n_bad_spd(ktype) + 1 +c +c Count number of rejected winds by tail number +c --------------------------------------------- + mm = 1 + do while(mm.le.kreg) + if(c_acftreg(ii).eq.creg_reg(mm)) then + nwind_reg(mm,ktype) = nwind_reg(mm,ktype) + 1 + mm = kreg + 1 + endif + mm = mm + 1 + enddo +c +c Reject all calm winds +c --------------------- + elseif(ob_spd(ii).lt.0.05.and. + $ ob_dir(ii).lt.0.05) then +c if(pres(ii).lt.700.) l_print = .true. + l_print = .false. + if(l_print) write(io8,*) 'Wind speed and direction zero' + c_qc(ii)(8:8) = 'B' + n_calm_spd(ktype) = n_calm_spd(ktype) + 1 +c +c Count number of rejected winds by tail number +c --------------------------------------------- + mm = 1 + do while(mm.le.kreg) + if(c_acftreg(ii).eq.creg_reg(mm)) then + nwind_reg(mm,ktype) = nwind_reg(mm,ktype) + 1 + mm = kreg + 1 + endif + mm = mm + 1 + enddo +c +c QC wind speeds +c -------------- + else + if(ht_ft(ii).lt.30000.) then + wmax = 70. + 230. * ht_ft(ii) / 30000. + elseif(ht_ft(ii).lt.40000.) then + wmax = 300. + elseif(ht_ft(ii).lt.45000.) then + wmax = 300. - 100. * (ht_ft(ii) - 40000.) / 5000. + else + wmax = 200. + endif + wmax = wmax * 0.5144 ! convert max from knots to m/s + if(ob_spd(ii).gt.wmax) then + l_print = .true. + if(l_print) write(io8,*) 'Wind speed > wmax = ',wmax + c_qc(ii)(8:8) = 'B' + n_bad_spd(ktype) = n_bad_spd(ktype) + 1 +c +c Count number of rejected winds by tail number +c --------------------------------------------- + mm = 1 + do while(mm.le.kreg) + if(c_acftreg(ii).eq.creg_reg(mm)) then + nwind_reg(mm,ktype) = nwind_reg(mm,ktype) + 1 + mm = kreg + 1 + endif + mm = mm + 1 + enddo +c + else + if(c_qc(ii)(8:8).eq.'-') c_qc(ii)(8:8) = '.' + endif + endif + endif +c +c Check if aircraft is on black list for wind errors +c -------------------------------------------------- + do nac = 1,nblkwind + if(c_acftreg(ii).eq.cblkwind(nac)) then +c l_print = .true. + if(l_print) write(io8,*) 'Black-listed for wind errors' +c + if(c_qc(ii)(10:10).eq.'T') then + c_qc(ii)(10:10) = 'O' + else + c_qc(ii)(10:10) = 'W' + endif + n_list_wind(ktype) = n_list_wind(ktype) + 1 + endif + enddo +cc +cc QC speed--RAOB algorithm +cc ------------------------ +c if(ob_spd(ii).ne.amiss.and. +c $ ob_spd(ii).ne.0.0.and. +c $ c_qc(ii)(8:8).ne.'K'.and. +c $ c_qc(ii)(8:8).ne.'E') then +cc +c if(pres(ii).ge.700.0) then +c if(ob_spd(ii).gt.100.0) then +c l_print = .true. +c if(l_print) write(io8,*) 'Windspeed bad by RAOB check' +c if(l_print.and.c_qc(ii)(8:8).ne.'B') +c $ write(io8,*) ' Report not rejected by Moninger check' +c endif +cc +c elseif(pres(ii).ge.500.0) then +c wmax = 100.0 + (700.0 - pres(ii)) / 200. * 20.0 +c if(ob_spd(ii).ge.wmax) then +c l_print = .true. +c if(l_print) write(io8,*) 'Windspeed bad by RAOB check' +c if(l_print.and.c_qc(ii)(8:8).ne.'B') +c $ write(io8,*) ' Report not rejected by Moninger check' +c endif +cc +c elseif(pres(ii).ge.300.0) then +c wmax = 120.0 + (500.0 - pres(ii)) / 200. * 60.0 +c if(ob_spd(ii).ge.wmax) then +c l_print = .true. +c if(l_print) write(io8,*) 'Windspeed bad by RAOB check' +c if(l_print.and.c_qc(ii)(8:8).ne.'B') +c $ write(io8,*) ' Report not rejected by Moninger check' +c endif +cc +c elseif(pres(ii).ge.200.0) then +c if(ob_spd(ii).ge.180.0) then +c l_print = .true. +c if(l_print) write(io8,*) 'Windspeed bad by RAOB check' +c if(l_print.and.c_qc(ii)(8:8).ne.'B') +c $ write(io8,*) ' Report not rejected by Moninger check' +c endif +cc +c elseif(pres(ii).ge.100.0) then +c if(ob_spd(ii).ge.170.0) then +c l_print = .true. +c if(l_print) write(io8,*) 'Windspeed bad by RAOB check' +c if(l_print.and.c_qc(ii)(8:8).ne.'B') +c $ write(io8,*) ' Report not rejected by Moninger check' +c endif +c endif +c endif +c +c QC moisture +c ----------- +c +c Exclude values already flagged as constant +c ------------------------------------------ + if(c_qc(ii)(9:9).ne.'K') then +c +c Check for missing values +c (treat moisture qc flag = 1 (non-measurement mode) as missing) +c (treat moisture qc flag = 9 (sensor not installed) as missing) +c -------------------------------------------------------------- + if(ob_q(ii).eq.amiss.or. + $ ichk_q(ii).eq.-9.or. + $ ichk_q(ii).eq.9.or. + $ ichk_q(ii).eq.-1) then +c +c l_print = .true. + if(l_print) write(io8,*) 'Moisture not present' + c_qc(ii)(9:9) = 'M' + n_mis_moist(ktype) = n_mis_moist(ktype) + 1 +c +c Assume zero moisture with qc flag of 7 signify missing ob +c --------------------------------------------------------- + elseif(ob_q(ii).lt.0.005.and.ichk_q(ii).eq.-7) then +c +c l_print = .true. + if(l_print) write(io8,*) 'Moisture not present, = 0' + c_qc(ii)(9:9) = 'M' + n_mis_moist(ktype) = n_mis_moist(ktype) + 1 +c +c QC remaining values +c ------------------- + else +c + if(ichk_q(ii).ne. 0.and. + $ ichk_q(ii).ne.-2.and. + $ ichk_q(ii).ne.-3.and. + $ ichk_q(ii).ne.-4.and. + $ ichk_q(ii).ne.-5.and. + $ ichk_q(ii).ne.-6.and. + $ ichk_q(ii).ne.-7.and. + $ ichk_q(ii).ne.-8.and. + $ ichk_q(ii).ne.908) l_print = .true. +c + if(l_print) + $ write(io8,*) 'Moisture qc flag = ',ichk_q(ii),ii +c +c Compute saturation specific humidity to test for supersaturation +c Reference: http://www.ofcm.gov/fmh3/text/appendd.htm +c ---------------------------------------------------------------- + if(c_qc(ii)(6:6).ne.'K'.and. + $ c_qc(ii)(6:6).ne.'E'.and. + $ c_qc(ii)(6:6).ne.'I'.and. + $ c_qc(ii)(6:6).ne.'M'.and. + $ c_qc(ii)(6:6).ne.'B'.and. + $ c_qc(ii)(6:6).ne.'b'.and. + $ c_qc(ii)(10:10).ne.'T'.and. + $ c_qc(ii)(10:10).ne.'O') then +c + t = ob_t(ii) - 273.16 +c temperature in centigrade + es = 6.1121 * exp( (17.502 * t) / (t + 240.97) ) +c saturation vapor pressure + qs = .622 * es / pres(ii) * 1000. +c saturation specific humidity (g/kg) + else + qs = amiss + endif +c +c Examine values of moisture qc flag +c (meaning of flag values is from BUFR table 0 33 26) +c (1 => Normal operations--non-measurement mode) +c (9 => Sensor not installed) +c (10-62 are reserved values; 63 => missing value) +c --------------------------------------------------- + if(ichk_q(ii).eq.-2) then + if(l_print) write(io8,*) ' Small RH' + c_qc(ii)(9:9) = '2' +c + elseif(ichk_q(ii).eq.-3) then + if(l_print) write(io8,*) ' Element wet' + c_qc(ii)(9:9) = '3' +c + elseif(ichk_q(ii).eq.-4) then + if(l_print) write(io8,*) ' Element contaminated' + c_qc(ii)(9:9) = 'B' + n_bad_moist(ktype) = n_bad_moist(ktype) + 1 +c + elseif(ichk_q(ii).eq.-5) then + if(l_print) write(io8,*) ' Heater failed' + c_qc(ii)(9:9) = 'B' + n_bad_moist(ktype) = n_bad_moist(ktype) + 1 +c + elseif(ichk_q(ii).eq.-6) then + if(l_print) + $ write(io8,*) ' Heater failed, wet/contam. element' + c_qc(ii)(9:9) = 'B' + n_bad_moist(ktype) = n_bad_moist(ktype) + 1 +c + elseif(ichk_q(ii).eq.-7) then + if(l_print) write(io8,*) ' Invalid input parameters ' + c_qc(ii)(9:9) = 'B' + n_bad_moist(ktype) = n_bad_moist(ktype) + 1 +c + elseif(ichk_q(ii).eq.-8) then + if(l_print) write(io8,*) ' Numeric error' + c_qc(ii)(9:9) = 'B' + n_bad_moist(ktype) = n_bad_moist(ktype) + 1 +c + elseif(qs.eq.amiss) then + if(l_print) write(io8,*) ' Cannot check supersat.' + c_qc(ii)(9:9) = 'N' +c + elseif(ob_q(ii)-qs.gt.0.01) then + l_print = .true. + if(l_print) + $ write(io8,*) ' Supersaturation present--qs = ',qs + c_qc(ii)(9:9) = 'S' + n_sus_moist(ktype) = n_sus_moist(ktype) + 1 +c + else + if(c_qc(ii)(9:9).eq.'-') c_qc(ii)(9:9) = '.' + endif + endif + endif + endif + endif +c +c Print offending report with neighbors if desired +c ------------------------------------------------ + if(l_print) then +c + if(iob.eq.1) then + iim1 = 0 + else + iim1 = indx(iob-1) + endif +c + if(iob.eq.numreps) then + iip1 = 0 + else + iip1 = indx(iob+1) + endif +c + if(iim1.ne.0) write (io8,8001) iim1,c_insty_ob(itype(iim1)) + x, c_acftreg(iim1),c_acftid(iim1) + x, idt(iim1),alat(iim1),alon(iim1),pres(iim1),ht_ft(iim1) + x, t_prcn(iim1),ob_t(iim1),xiv_t(iim1),ichk_t(iim1) + x, ob_q(iim1),xiv_q(iim1),ichk_q(iim1) + x, ob_dir(iim1),xiv_d(iim1),ichk_d(iim1) + x, ob_spd(iim1),xiv_s(iim1),ichk_s(iim1) + x, c_qc(iim1),csort(iim1) +c + write (io8,8001) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii),pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii),csort(ii) +c + if(iip1.ne.0) write (io8,8001) iip1,c_insty_ob(itype(iip1)) + x, c_acftreg(iip1),c_acftid(iip1) + x, idt(iip1),alat(iip1),alon(iip1),pres(iip1),ht_ft(iip1) + x, t_prcn(iip1),ob_t(iip1),xiv_t(iip1),ichk_t(iip1) + x, ob_q(iip1),xiv_q(iip1),ichk_q(iip1) + x, ob_dir(iip1),xiv_d(iip1),ichk_d(iip1) + x, ob_spd(iip1),xiv_s(iip1),ichk_s(iip1) + x, c_qc(iip1),csort(iip1) +c + 8001 format(i6,1x,a8,1x,a8,1x,a9,1x + x, i7,1x,2f11.5,1x,f8.1,1x,f7.0,1x + x, f5.2,4(2(1x,f8.2),1x,i5) + x, 1x,'!',a11,'!',1x,a25) + write(io8,*) + endif +c +c End loop over reports +c --------------------- + enddo +c +c Write out and count bad data here +c --------------------------------- + write(io34,*) + write(io34,*) 'Data that failed gross checks' + write(io34,*) '(rejected reports not included subsequently' + write(io34,*) '-------------------------------------------' + write(io34,3001) + 3001 format(' index type tail num flight time lat' + x, ' lon pres height ' + x, 't-prcn temp innov ichk' + x, ' spec hum innov ichk' + x, ' ob_dir innov ichk' + x, ' ob_spd innov ichk' + x, ' qc flag') +c +c Loop over obs +c ------------- + do iob=1,numreps + ii = indx(iob) +c + l_print = .false. +c +c Set index +c --------- + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_des) then + ktype = 1 +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_des) then + ktype = 2 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_des) then + ktype = 3 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_des) then + ktype = 4 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + ktype = 5 +c + else + write(io8,*) + write(io8,*) 'Bad itype: ',itype(ii),' for ii = ',ii + ktype = 5 + endif +c +c Add up number of reports considered +c ----------------------------------- + nrep(ktype) = nrep(ktype) + 1 +c +c Rejected reports +c ---------------- + if(c_qc(ii)(3:3).eq.'B'.or. + $ c_qc(ii)(4:4).eq.'B'.or. + $ c_qc(ii)(5:5).eq.'B'.or. + $ c_qc(ii)(5:5).eq.'I'.or. + $ c_qc(ii)(1:1).eq.'B'.or. + $ c_qc(ii)(6:6).eq.'B') then +c + csort(ii)(1:5) = 'badob' +c +c Invalid reports--no data +c ------------------------ + elseif((c_qc(ii)(6:6).eq.'K'.or. + $ c_qc(ii)(10:10).eq.'T'.or. + $ c_qc(ii)(10:10).eq.'O'.or. + $ c_qc(ii)(6:6).eq.'M'.or. + $ c_qc(ii)(6:6).eq.'E'.or. + $ c_qc(ii)(6:6).eq.'I'.or. + $ c_qc(ii)(6:6).eq.'B'.or. + $ c_qc(ii)(6:6).eq.'b').and. +c + $ (c_qc(ii)(7:7).eq.'K'.or. + $ c_qc(ii)(8:8).eq.'K'.or. + $ c_qc(ii)(10:10).eq.'W'.or. + $ c_qc(ii)(10:10).eq.'O'.or. + $ c_qc(ii)(7:7).eq.'M'.or. + $ c_qc(ii)(8:8).eq.'M'.or. + $ c_qc(ii)(7:7).eq.'E'.or. + $ c_qc(ii)(8:8).eq.'E'.or. + $ c_qc(ii)(7:7).eq.'B'.or. + $ c_qc(ii)(8:8).eq.'B'.or. + $ c_qc(ii)(7:7).eq.'I'.or. + $ c_qc(ii)(8:8).eq.'I')) then +c + csort(ii)(1:5) = 'badob' + n_bad_rep(ktype) = n_bad_rep(ktype) + 1 +c + endif +c +c Output and count rejected obs +c ----------------------------- + if(.not.l_operational) then +c + if(csort(ii)(1:5).eq.'badob') then + kbad(ktype) = kbad(ktype) + 1 +c + write(io34,3002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii),pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + 3002 format(i6,1x,a8,1x,a8,1x,a9,1x + x, i7,1x,2f11.5,1x,f8.1,1x,f7.0,1x + x, f5.2,4(2(1x,f8.2),1x,i5) + x, 1x,'!',a11,'!') + endif + endif +c + enddo +c +c Output tail number counts +c ------------------------- + write(io8,*) + write(io8,*) ' Tail numbers for reports with temp in whole deg' +ccccdak write(io8,*) ' Tail Num MDCRS ACARS AMDAR AIREP MAN ' + write(io8,*) ' Tail Num MDCRS TAMDAR AMDAR AIREP MAN ' + write(io8,*) ' -------------------------------------------' +c + do mm=1,kreg + if( nwhol_reg(mm,1)+nwhol_reg(mm,2)+nwhol_reg(mm,3) + $ +nwhol_reg(mm,4)+nwhol_reg(mm,5).gt.0) then + write(io8,'(2x,a8,5(1x,i6))') + $ creg_reg(mm),(nwhol_reg(mm,ii),ii=1,5) + endif + enddo +c + write(io8,*) + write(io8,*) ' Tail numbers for reports with bad winds' +ccccdak write(io8,*) ' Tail Num MDCRS ACARS AMDAR AIREP MAN ' + write(io8,*) ' Tail Num MDCRS TAMDAR AMDAR AIREP MAN ' + write(io8,*) ' -------------------------------------------' +c + do mm=1,kreg + if( nwind_reg(mm,1)+nwind_reg(mm,2)+nwind_reg(mm,3) + $ +nwind_reg(mm,4)+nwind_reg(mm,5).gt.0) then + write(io8,'(2x,a8,5(1x,i6))') + $ creg_reg(mm),(nwind_reg(mm,ii),ii=1,5) + endif + enddo +c + write(*,*) + write(*,*) 'Gross check data counts--',cdtg_an + write(*,*) '-----------------------------------' + write(*,'(1x,a55)') +ccccdak $ 'Type of check MDCRS ACARS AMDAR AIREP man' + $ 'Type of check MDCRS TAMDAR AMDAR AIREP man' + write(*,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(*,'('' Num considered '',5(1x,i7))') + $ (nrep(ii),ii=1,5) + write(*,'('' Total rejected '',5(1x,i7))') + $ (kbad(ii),ii=1,5) + write(*,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + if(.not.l_operational) then + write(io34,*) + write(io34,*) 'Gross check data counts' + write(io34,*) '-----------------------' + write(io34,'(1x,a55)') +ccccdak $ 'Type of check MDCRS ACARS AMDAR AIREP man' + $ 'Type of check MDCRS TAMDAR AMDAR AIREP man' + write(io34,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io34,'(''Num considered '',5(1x,i7))') + $ (nrep(ii),ii=1,5) + write(io34,'(''Total rejected '',5(1x,i7))') + $ (kbad(ii),ii=1,5) + write(io34,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + endif +c + write(io8,*) + write(io8,*) 'Gross check data counts' + write(io8,*) '-----------------------' + write(io8,'(1x,a55)') +ccccdak $ 'Type of check MDCRS ACARS AMDAR AIREP man' + $ 'Type of check MDCRS TAMDAR AMDAR AIREP man' + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Num considered '',5(1x,i7))') + $ (nrep(ii),ii=1,5) + write(io8,'(''Total rejected '',5(1x,i7))') + $ (kbad(ii),ii=1,5) + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + write(io8,'(''Bad lat/lon '',5(1x,i7))') + $ (n_bad_pos(ii),ii=1,5) + write(io8,'(''Bad alt '',5(1x,i7))') + $ (n_bad_alt(ii),ii=1,5) + write(io8,'(''Incons alt '',5(1x,i7))') + $ (n_inc_alt(ii),ii=1,5) + write(io8,'(''Bad sfc UAL '',5(1x,i7))') + $ (n_bad_UAL(ii),ii=1,5) + write(io8,'(''Bad temp '',5(1x,i7))') + $ (n_bad_temp(ii),ii=1,5) + write(io8,'(''Cold temp '',5(1x,i7))') + $ (n_cold_temp(ii),ii=1,5) + write(io8,'(''Report bad '',5(1x,i7))') + $ (n_bad_rep(ii),ii=1,5) + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Wh-deg temp '',5(1x,i7))') + $ (n_whole_temp(ii),ii=1,5) + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Bad dir '',5(1x,i7))') + $ (n_bad_dir(ii),ii=1,5) + write(io8,'(''Incons dir '',5(1x,i7))') + $ (n_inc_dir(ii),ii=1,5) + write(io8,'(''Bad spd '',5(1x,i7))') + $ (n_bad_spd(ii),ii=1,5) + write(io8,'(''Calm spd '',5(1x,i7))') + $ (n_calm_spd(ii),ii=1,5) + write(io8,'(''Incons spd '',5(1x,i7))') + $ (n_inc_spd(ii),ii=1,5) + write(io8,'(''Bad moist '',5(1x,i7))') + $ (n_bad_moist(ii),ii=1,5) + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Listed temp '',5(1x,i7))') + $ (n_list_temp(ii),ii=1,5) + write(io8,'(''Listed wind '',5(1x,i7))') + $ (n_list_wind(ii),ii=1,5) + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Missing temp '',5(1x,i7))') + $ (n_mis_temp(ii),ii=1,5) + write(io8,'(''Missing dir '',5(1x,i7))') + $ (n_mis_dir(ii),ii=1,5) + write(io8,'(''Missing spd '',5(1x,i7))') + $ (n_mis_spd(ii),ii=1,5) + write(io8,'(''Missing moist '',5(1x,i7))') + $ (n_mis_moist(ii),ii=1,5) + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Suspect time '',5(1x,i7))') + $ (n_sus_time(ii),ii=1,5) + write(io8,'(''Suspect lat '',5(1x,i7))') + $ (n_sus_lat(ii),ii=1,5) + write(io8,'(''Suspect lon '',5(1x,i7))') + $ (n_sus_lon(ii),ii=1,5) + write(io8,'(''Suspect alt '',5(1x,i7))') + $ (n_sus_alt(ii),ii=1,5) + write(io8,'(''Suspect moist '',5(1x,i7))') + $ (n_sus_moist(ii),ii=1,5) + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + kbadtot = kbad(1) + kbad(2) + kbad(3) + $ + kbad(4) + kbad(5) +c + write(io8,*) + write(io8,*) numreps,' good reports processed' + write(io8,*) kbadtot,' reports failed qc in gross check' +c + return + end +c +c ################################################################### +c subroutine poschek_qc +c ################################################################### +c + subroutine poschek_qc(numreps,max_reps,indx,csort,imiss,amiss + $, idt_updn,c_acftreg,c_acftid,cidmiss,c_qc,cdtg_an + $, alat,alon,pres,ht_ft,t_prcn,ob_t,ob_q,ob_dir,ob_spd + $, xiv_t,xiv_q,xiv_d,xiv_s + $, idt,itype,ichk_t,ichk_q,ichk_d,ichk_s + $, kflight,maxflt,nobs_flt,iobs_flt,kbadtot,io8,io35 + $, l_operational,l_init) +c +c Check near duplicate reports with different positions/altitudes/times +c and pick the best one +c Also, look for redundant data and reject it +c + implicit none +c +c Declaration statements +c ---------------------- + integer max_reps ! maximum number of reports +c + character*11 c_qc(max_reps) ! internal qc flags +c +c Data arrays +c ----------- + character*10 cdtg_an ! date time group for analysis + integer numreps ! actual number of reports + integer itype(max_reps) ! type of aircraft data + integer idt(max_reps) ! time in seconds to analysis time + character*8 c_acftreg(max_reps) ! aircraft registration (tail) number + character*9 c_acftid(max_reps) ! aircraft flight number + real*8 alat(max_reps) ! latitude + $, alon(max_reps) ! longitude + real pres(max_reps) ! pressure + $, ht_ft(max_reps) ! height in feet + real t_prcn(max_reps) ! temperature precision + real ob_t(max_reps) ! temperature + $, ob_q(max_reps) ! specific humidity + $, ob_dir(max_reps) ! wind direction + $, ob_spd(max_reps) ! wind speed + real xiv_t(max_reps) ! temperature innovation (ob - bk) + $, xiv_q(max_reps) ! specific humidity innovation (ob - bk) + $, xiv_d(max_reps) ! wind direction innovation (ob - bk) + $, xiv_s(max_reps) ! wind speed innovation (ob - bk) + integer ichk_t(max_reps) ! NRL QC flag for temperature ob + $, ichk_q(max_reps) ! NRL QC flag for specific humidity ob + $, ichk_d(max_reps) ! NRL QC flag for wind direction ob + $, ichk_s(max_reps) ! NRL QC flag for wind speed ob + character*25 csort(max_reps) ! sort variable +c +c Pointers +c -------- + integer indx(max_reps) ! pointer index for good reports +c +c Functions +c --------- + character*16 c_insty_ob ! function to convert integer instrument + ! type to character instrument type + integer insty_ob_fun ! function to convert character + ! instrument type to integer + real gcirc_qc ! function to compute great circle distances +c +c Flight statistics +c ----------------- + integer maxflt ! max number of flights allowed + integer nobs_flt(maxflt) ! number of reports per flight + $, iobs_flt(maxflt) ! index for first report in each flight + $, kflight ! number of flights in dataset + integer istart ! index for 1st rep in current flight + $, iistart ! index from pointer array for istart + $, iend ! index for last rep in current flight + $, iiend ! index from pointer array for iend +c +c Counters +c -------- + integer ninc_xtra(5) ! number of redundant reports + $, ninc_way(5) ! number of duplicate reports with waypoint errors + $, ninc_alt(5) ! number of duplicate reports with altitude errors + $, ninc_stk(5) ! number of reports with stuck times + $, ninc_time(5) ! number of reports with stuck times + $, ninc_avg(5) ! number of reports with averaged position or time + $, ninc_bad(5) ! number of reports with inconsistent positions + integer kbad(5) ! counter for number of bad reports + $, kbadtot ! counter for total number of bad reports +ccccdak integer nrep_Ac ! number of acars reports considered + integer nrep_Ac ! number of tamdar reports considered + $, nrep_Md ! number of mdcrs reports considered + $, nrep_Ma ! number of manual airep reports considered + $, nrep_Ar ! number of airep reports considered + $, nrep_Am ! number of amdar reports considered +ccccdak integer ninc_Ac ! number of acars reports rejected + integer ninc_Ac ! number of tamdar reports rejected + $, ninc_Md ! number of mdcrs reports rejected + $, ninc_Ma ! number of manual airep reports rejected + $, ninc_Ar ! number of airep reports rejected + $, ninc_Am ! number of amdar reports rejected +c +c Instrument types +c ---------------- +ccccdak integer i_acars ! instrument type for acars + integer i_acars ! instrument type for tamdar +ccccdak $, i_acars_lvl ! instrument type for acars--level flt + $, i_acars_lvl ! instrument type for tamdar--level flt +ccccdak $, i_acars_asc ! instrument type for acars--ascent + $, i_acars_asc ! instrument type for tamdar--ascent +ccccdak $, i_acars_des ! instrument type for acars--descent + $, i_acars_des ! instrument type for tamdar--descent + $, i_mdcrs ! instrument type for mdcrs + $, i_mdcrs_lvl ! instrument type for mdcrs--level flt + $, i_mdcrs_asc ! instrument type for mdcrs--ascent + $, i_mdcrs_des ! instrument type for mdcrs--descent + $, i_man_airep ! instrument type for manual aireps + $, i_man_Yairep ! instrument type for manual aireps (YRXX) + $, i_airep ! instrument type for airep + $, i_airep_lvl ! instrument type for airep--level flt + $, i_airep_asc ! instrument type for airep--ascent + $, i_airep_des ! instrument type for airep--descent + $, i_amdar ! instrument type for amdar + $, i_amdar_lvl ! instrument type for amdar--level flt + $, i_amdar_asc ! instrument type for amdar--ascent + $, i_amdar_des ! instrument type for amdar--descent +c +c Other variables +c --------------- + integer io8 ! i/o unit number for log file + integer io35 ! i/o unit number for position check +c + real amiss ! real missing value flag +c + integer iob,kk ! do loop indices + $, ii ! index pointing to current report + $, iim1 ! index pointing to previous report + $, iim2 ! index pointing to 2nd report previous + $, iip1 ! index pointing to following report + $, knt1 ! counter used to define iim1 index + $, knt2 ! counter used to define iim2 index + integer iht0 ! integer ht_ft(ii) + $, ihtm1 ! integer ht_ft(iim1) + integer ihtdif0 ! height difference (current - previous) + integer imiss ! integer missing value flag + $, idt_dif ! time difference (current - previous report) + $, idt_difp1 ! time difference (following - current report) + $, idt_tot ! time between iim2 and iip1 points + integer idt_updn ! time difference to check ascents/descents + $, idt_stk ! time clock is stuck at +c + integer ktype ! ob type +c + real*8 alat_dif ! difference in latitude + $, alon0 ! longitude at point ii + $, alonm2 ! longitude at point iim2 + $, alonp1 ! longitude at point iip1 + $, alon_dif ! difference in longitude + real diff0 ! difference between points ii and iim1 + $, diffm1 ! difference between points iim1 and iip1 + $, difdir ! direction difference + real*8 alat_est ! estimated latitude + $, alon_est ! estimated longitude + real time_est ! estimated time + $, dist_tot ! estimated distance between iim2 and iip1 points + $, dist_ii ! estimated distance between "est" and ii points + $, dist_iim1 ! estimated distance between "est" and iim1 points +c + character*8 cidmiss ! missing value flag for flight number +c +c Switches +c -------- + logical l_print ! true for printing two reports used in check +c + logical l_init ! initialize counters if true + $, stuck ! true if stuck clock found + $, l_operational ! true if operational mode used +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c +c Initialize aircraft data types +c ------------------------------ + i_acars = insty_ob_fun('acars') + i_acars_lvl = insty_ob_fun('acars_lvl') + i_acars_asc = insty_ob_fun('acars_asc') + i_acars_des = insty_ob_fun('acars_des') + i_mdcrs = insty_ob_fun('mdcrs') + i_mdcrs_lvl = insty_ob_fun('mdcrs_lvl') + i_mdcrs_asc = insty_ob_fun('mdcrs_asc') + i_mdcrs_des = insty_ob_fun('mdcrs_des') + i_man_airep = insty_ob_fun('man-airep') + i_man_Yairep = insty_ob_fun('man-Yairep') + i_airep = insty_ob_fun('airep') + i_airep_lvl = insty_ob_fun('airep_lvl') + i_airep_asc = insty_ob_fun('airep_asc') + i_airep_des = insty_ob_fun('airep_des') + i_amdar = insty_ob_fun('amdar') + i_amdar_lvl = insty_ob_fun('amdar_lvl') + i_amdar_asc = insty_ob_fun('amdar_asc') + i_amdar_des = insty_ob_fun('amdar_des') +c +c Initialize counters +c ------------------- + if(l_init) then + ninc_xtra = 0 + ninc_way = 0 + ninc_alt = 0 + ninc_stk = 0 + ninc_time = 0 + ninc_avg = 0 + ninc_bad = 0 + nrep_Ac = 0 + nrep_Md = 0 + nrep_Ma = 0 + nrep_Ar = 0 + nrep_Am = 0 + ninc_Ac = 0 + ninc_Md = 0 + ninc_Ma = 0 + ninc_Ar = 0 + ninc_Am = 0 + endif +c +c Begin loop over flights +c ----------------------- + do kk = 1,kflight +c +c Initialize variables +c -------------------- + stuck = .false. + istart = iobs_flt(kk) + iistart = indx(istart) + iend = iobs_flt(kk) + nobs_flt(kk) - 1 + iiend = indx(iend) + l_print = .false. +c +c Check two-report manAIREP flights +c --------------------------------- + if(nobs_flt(kk).eq.2.and. + $ (itype(iistart).eq.i_man_airep.or. + $ itype(iistart).eq.i_man_Yairep).and. + $ (itype(iiend).eq.i_man_airep.or. + $ itype(iiend).eq.i_man_Yairep).and. + $ abs(ob_t(iistart)-ob_t(iiend)).lt.1.25.and. + $ abs(ob_dir(iistart)-ob_dir(iiend)).lt.10.5.and. + $ abs(ob_spd(iistart)-ob_spd(iiend)).lt.1.25) then +! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c +c Check for position discrepancies +c -------------------------------- + if((abs(alat(iistart)-alat(iiend)).gt.0.125.or. + $ abs(alon(iistart)-alon(iiend)).gt.0.125).and. + $ abs(ht_ft(iistart)-ht_ft(iiend)).lt.1.5.and. + $ idt(iistart).eq.idt(iiend)) then +c + dist_tot = gcirc_qc(alat(iistart),alon(iistart), + $ alat(iiend), alon(iiend)) + dist_tot = dist_tot / 1000. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Discrepancy in position for 2-rep flight' + write(io8,*) 'dist_tot = ',dist_tot + endif +c +c If points are close together, average the position +c -------------------------------------------------- + if(dist_tot.lt.115.0) then + if(l_print) then + write(io8,*) 'points close--averaging' + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + alat(iistart) = (alat(iistart)+alat(iiend))/2.0 + alon(iistart) = (alon(iistart)+alon(iiend))/2.0 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + c_qc(iistart)(3:4) = 'RR' + c_qc(iiend)(1:1) = 'W' + c_qc(iiend)(3:4) = 'BB' +c + else + c_qc(iistart)(1:1) = 'W' + c_qc(iistart)(3:4) = 'BB' + c_qc(iiend)(1:1) = 'W' + c_qc(iiend)(3:4) = 'BB' + endif +c +c Check for altitude discrepancies +c -------------------------------- +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + elseif((abs(alat(iistart)-alat(iiend)).lt.0.125.or. + $ abs(alon(iistart)-alon(iiend)).lt.0.125).and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ abs(ht_ft(iistart)-ht_ft(iiend)).gt.1000..and. + $ idt(iistart).eq.idt(iiend)) then +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Discrepancy in altitude for 2-rep flight' + endif +c + c_qc(iistart)(1:1) = 'A' + c_qc(iistart)(5:5) = 'B' + c_qc(iiend)(1:1) = 'A' + c_qc(iiend)(5:5) = 'B' +c +c Check for time discrepancies +c ---------------------------- + elseif(idt(iistart).ne.idt(iiend).and. +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + $ abs(alat(iistart)-alat(iiend)).lt.0.125.and. + $ abs(alon(iistart)-alon(iiend)).lt.0.125.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ abs(ht_ft(iistart)-ht_ft(iiend)).lt.50.5) then +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Discrepancy in time for 2-rep flight' + endif +c +c If points are close in time, average times +c ------------------------------------------ + if(abs(idt(iistart)-idt(iiend)).lt.1800.0) then +c + if(l_print) then + write(io8,*) 'points close--averaging' + endif +c + idt(iiend) = (idt(iiend)+idt(iistart))/2 + c_qc(iiend)(2:2) = 'R' + c_qc(iistart)(1:1) = 't' + c_qc(iistart)(2:2) = 'B' +c +c Otherwise reject both points +c ---------------------------- + else + c_qc(iistart)(1:1) = 't' + c_qc(iistart)(2:2) = 'B' + c_qc(iiend)(1:1) = 't' + c_qc(iiend)(2:2) = 'B' + endif + endif +c +c Print both reports if desired +c ----------------------------- + if(l_print) then + iim1 = iistart + ii = iiend + write(io8,8002) kk,iim1 + x, c_insty_ob(itype(iim1)) + x, c_acftreg(iim1),c_acftid(iim1) + x, idt(iim1),alat(iim1),alon(iim1) + x, pres(iim1),ht_ft(iim1) + x, t_prcn(iim1),ob_t(iim1),xiv_t(iim1),ichk_t(iim1) + x, ob_q(iim1),xiv_q(iim1),ichk_q(iim1) + x, ob_dir(iim1),xiv_d(iim1),ichk_d(iim1) + x, ob_spd(iim1),xiv_s(iim1),ichk_s(iim1) + x, c_qc(iim1) + write(io8,8002) kk,ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + 8002 format(i4,1x,i6,1x,a8,1x,a8,1x,a9,1x,i7,1x,2f11.5,1x + x, f8.1,1x,f7.0 + x, 1x,f5.2,4(2(1x,f8.2),1x,i5),1x,'!',a11,'!') + endif +c +c Otherwise, examine only "real" flights with at least three reports +c ------------------------------------------------------------------ + elseif(c_acftid(iistart)(1:8).ne.cidmiss(1:8).and. + $ nobs_flt(kk).ge.3) then +c +c Begin loop over reports +c ----------------------- + do iob = istart+1,iend + l_print = .false. +c + ii = indx(iob) +c +c Compute ii+1 index +c ------------------ + if(iob.lt.iend) then + iip1 = indx(iob+1) + else + iip1 = 0 + endif +c +c Compute ii-1 index +c ------------------ + knt1 = iob - 1 + 10 if(knt1.ge.istart) then + iim1 = indx(knt1) + if(c_qc(iim1)(1:1).eq.'r'.or. + $ c_qc(iim1)(1:1).eq.'W'.or. + $ c_qc(iim1)(1:1).eq.'A'.or. + $ c_qc(iim1)(1:1).eq.'t'.or. + $ c_qc(iim1)(2:2).eq.'K'.or. + $ c_qc(iim1)(5:5).eq.'B') then + knt1 = knt1 - 1 + goto 10 + endif + else + iim1 = 0 + endif +c +c Compute ii-2 index +c ------------------ + knt2 = knt1 - 1 + 20 if(knt2.ge.istart) then + iim2 = indx(knt2) + if(c_qc(iim2)(1:1).eq.'r'.or. + $ c_qc(iim2)(1:1).eq.'W'.or. + $ c_qc(iim2)(1:1).eq.'A'.or. + $ c_qc(iim2)(2:2).eq.'K'.or. + $ c_qc(iim2)(2:2).eq.'B'.or. + $ c_qc(iim2)(5:5).eq.'B') then + knt2 = knt2 - 1 + goto 20 + endif + else + iim2 = 0 + endif +c +c Continue only if iim1 is valid +c ------------------------------ + if(iim1.ne.0) then +c +c Compute height and time differences for iim1 report +c --------------------------------------------------- + if(ht_ft(ii).ne.amiss) then + iht0 = nint(ht_ft(ii)/100.) * 100 + else + iht0 = imiss + endif +c + if(ht_ft(iim1).ne.amiss) then + ihtm1 = nint(ht_ft(iim1)/100.) * 100 + else + ihtm1 = imiss + endif +c + if(ht_ft(ii).ne.amiss.and.ht_ft(iim1).ne.amiss) then + ihtdif0 = abs(iht0 - ihtm1) + else + ihtdif0 = imiss + endif +c + idt_dif = abs(idt(ii) - idt(iim1)) +c +c Compute magnitude of direction difference +c (constrain to be less than 180 deg +c ----------------------------------------- + if(ob_dir(ii).eq.amiss.or. + $ ob_dir(iim1).eq.amiss) then + difdir = amiss + else + difdir = abs(ob_dir(iim1)-ob_dir(ii)) + if(difdir.gt.180) difdir = 360. - difdir + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c +c Discrepancies in position +c ------------------------- + if(idt_dif.eq.0.and. + $ (abs(alat(ii)-alat(iim1)).ge.0.5.or. + $ abs(alon(ii)-alon(iim1)).ge.0.5) .and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ abs(ht_ft(ii)-ht_ft(iim1)).lt.1.5) then +c +c Check for short segments with stuck clock +c ----------------------------------------- + if(iim2.ne.0) then + if(idt(iim1).eq.idt(ii).and. + $ idt(iim2).eq.idt(ii)) then + c_qc(iim2)(2:2) = 'K' + c_qc(iim1)(2:2) = 'K' + c_qc(ii)(2:2) = 'K' + endif + endif +c + if(iip1.ne.0) then + if(idt(iim1).eq.idt(ii).and. + $ idt(iip1).eq.idt(ii)) then + c_qc(iip1)(2:2) = 'K' + c_qc(iim1)(2:2) = 'K' + c_qc(ii)(2:2) = 'K' + endif + endif +c + if(c_qc(ii)(2:2).eq.'K') then + stuck = .true. + idt_stk = idt(ii) + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Discrepancy in position' + write(io8,*) 'Stuck clock found' + endif + endif + endif +c +c Exclude reports diagnosed as stuck from remaining checks +c -------------------------------------------------------- + if(c_qc(ii)(2:2).eq.'K') then +c +c United flights with 2000' as lowest valid alt +c Pressure/altitude on ground invalid +c Flag if temperatures and altitudes are inconsistent! +c Time-stamp the test so it only applies to the 1996 dataset +c ---------------------------------------------------------- + elseif(cdtg_an.lt.'1998010100'.and. + $ iht0.eq.2000.and. + $ idt_dif.lt.300.and. + $ ihtdif0.gt.6000.and.ihtdif0.ne.imiss.and. + $ ob_t(iim1).gt.ob_t(ii)) then +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad altitude for first point' + write(io8,*) 'ht_ft(',ii,') = ',ht_ft(ii) + write(io8,*) 'ht_ft(',iim1,') = ',ht_ft(iim1) + endif + c_qc(iim1)(5:5) = 'B' +c + elseif(ihtm1.eq.2000.and. + $ idt_dif.lt.300.and. + $ ihtdif0.gt.6000.and.ihtdif0.ne.imiss.and. + $ ob_t(ii).gt.ob_t(iim1)) then + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad altitude for last point' + write(io8,*) 'ht_ft(',ii,') = ',ht_ft(ii) + write(io8,*) 'ht_ft(',iim1,') = ',ht_ft(iim1) + endif + c_qc(ii)(5:5) = 'B' +c +c Multiple values at same altitude at low altitudes +c Save only one +c ------------------------------------------------- + elseif(iht0.lt.8000.and. + $ idt_dif.le.60.and. + $ ihtdif0.lt.2) then +c + if(iip1.ne.0) then + idt_difp1 = abs(idt(ii)-idt(iip1)) + else + idt_difp1 = imiss + endif +c +c Save newer report if at beginning of flight +c ------------------------------------------- + if(idt(iim1).ne.idt(ii).and. + $ (iim1.eq.iistart.or. + $ (idt_difp1.ne.imiss.and.idt_difp1.le.idt_updn)))then + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Multiple values at same altitude' + write(io8,*) 'Saving newer report' + endif + c_qc(iim1)(1:1) = 'r' +c +c Save report nearer to next report, if available +c Otherwise, save report with smallest temperature or +c windspeed difference w.r.t. next report +c --------------------------------------------------- + elseif(iip1.ne.0) then +c +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alat(ii).ne.alat(iim1).or. + $ alon(ii).ne.alon(iim1)) then + diffm1 = gcirc_qc(alat(iim1),alon(iim1), + $ alat(iip1),alon(iip1)) + diffm1 = diffm1 / 1000. + diff0 = gcirc_qc(alat(ii),alon(ii), + $ alat(iip1),alon(iip1)) + diff0 = diff0 / 1000. +c +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + elseif(ob_t(ii).ne.ob_t(iim1)) then + diffm1 = abs(ob_t(iim1)-ob_t(iip1)) + diff0 = abs(ob_t(ii)-ob_t(iip1)) +c + elseif(ob_spd(ii).ne.ob_spd(iim1)) then + diffm1 = abs(ob_spd(iim1)-ob_spd(iip1)) + diff0 = abs(ob_spd(ii)-ob_spd(iip1)) +c + else + diffm1 = 1.0 + diff0 = 0.0 + endif +c + if(diff0.lt.diffm1.or.ichk_s(iim1).eq.-10) then + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Multiple values at same altitude' + write(io8,*) 'Saving ii report' + endif + c_qc(iim1)(1:1) = 'r' +c + elseif(diffm1.lt.diff0) then + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Multiple values at same altitude' + write(io8,*) 'Saving iim1 report' + endif + c_qc(ii)(1:1) = 'r' +c + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Multiple values at same altitude' + write(io8,*) 'Differences should not be equal!' + endif + endif +c +c If following report not available, drop current report +c ------------------------------------------------------ + else + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Multiple values at same altitude' + write(io8,*) 'Following report not available' + endif + c_qc(ii)(1:1) = 'r' + endif +c +c Perform remaining checks only for manAIREP duplicates +c ----------------------------------------------------- + elseif((itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep).and. + $ (itype(iim1).eq.i_man_airep.or. + $ itype(iim1).eq.i_man_Yairep).and. + $ (abs(ob_t(iim1)-ob_t(ii)).lt.1.25.or. + $ (ob_t(iim1).eq.amiss.and.ob_t(ii).ne.amiss).or. + $ (ob_t(iim1).ne.amiss.and.ob_t(ii).eq.amiss)).and. + $ (abs(difdir).lt.10.5.or. + $ (ob_dir(iim1).eq.amiss.and.ob_dir(ii).eq.amiss).or. + $ (ob_dir(iim1).eq.amiss.and.ob_dir(ii).ne.amiss).or. + $ (ob_dir(iim1).ne.amiss.and.ob_dir(ii).eq.amiss).or. + $ (ob_dir(iim1).lt.0.5.and.ob_dir(ii).lt.0.5).or. + $ (ob_dir(iim1).lt.0.5.and.difdir.gt.10.5).or. + $ (difdir.gt.10.5.and.ob_dir(ii).lt.0.5)).and. + $ (abs(ob_spd(iim1)-ob_spd(ii)).lt.1.25.or. + $ (ob_spd(iim1).eq.amiss.and.ob_spd(ii).eq.amiss).or. + $ (ob_spd(iim1).eq.amiss.and.ob_spd(ii).ne.amiss).or. + $ (ob_spd(iim1).ne.amiss.and.ob_spd(ii).eq.amiss).or. + $ (ob_spd(iim1).lt.0.05.and.ob_spd(ii).lt.0.05).or. + $ (ob_spd(iim1).lt.0.05.and.ob_spd(ii).gt.1.25).or. + $ (ob_spd(iim1).gt.1.25.and.ob_spd(ii).lt.0.05)))then +c +c Check for position discrepancies +c -------------------------------- + if(idt_dif.eq.0.and. +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + $ (abs(alat(ii)-alat(iim1)).ge.0.125.or. + $ abs(alon(ii)-alon(iim1)).ge.0.125) .and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ abs(ht_ft(ii)-ht_ft(iim1)).lt.1.5) then +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Discrepancy in position' + write(io8,*) 'Waypoint error found' + endif +c +c If ii and iim1 points are close together, average the position +c -------------------------------------------------------------- + dist_tot = gcirc_qc(alat(ii),alon(ii), + $ alat(iim1),alon(iim1)) + dist_tot = dist_tot / 1000. +c + if(dist_tot.lt.115.0) then + if(l_print) then + write(io8,*) 'points close--averaging' + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + alat(ii) = (alat(ii)+alat(iim1))/2.0 + alon(ii) = (alon(ii)+alon(iim1))/2.0 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + c_qc(ii)(3:4) = 'RR' + c_qc(iim1)(1:1) = 'W' + c_qc(iim1)(3:4) = 'BB' +c +c Otherwise, examine neighboring reports to decide which one to keep +c ------------------------------------------------------------------ + elseif(iim2.ne.0.and.iip1.ne.0) then +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + alat_est = (alat(iip1)-alat(iim2)) + $ / (idt(iip1)-idt(iim2)) + $ * (idt(ii)-idt(iim2)) + $ + alat(iim2) + alon_est = (alon(iip1)-alon(iim2)) + $ / (idt(iip1)-idt(iim2)) + $ * (idt(ii)-idt(iim2)) + $ + alon(iim2) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c + dist_tot = gcirc_qc(alat(iip1),alon(iip1), + $ alat(iim2),alon(iim2)) + dist_tot = dist_tot / 1000. + dist_ii = gcirc_qc(alat_est,alon_est, + $ alat(ii),alon(ii)) + dist_ii = dist_ii / 1000. + dist_iim1= gcirc_qc(alat_est,alon_est, + $ alat(iim1),alon(iim1)) + dist_iim1 = dist_iim1 / 1000. +c + if(l_print) then + write(io8,*) 'Estimated position = ', + $ alat_est,alon_est + write(io8,*) 'Distances: iim2-iip1 = ',dist_tot + write(io8,*) ' est-ii = ',dist_ii + write(io8,*) ' est-iim1 = ',dist_iim1 + endif +c +c If the neighboring reports are close enough together, +c choose the report that is closest to the interpolated point +c ----------------------------------------------------------- + if(dist_tot.lt.2500.0) then + if(dist_ii.lt.dist_iim1) then + c_qc(iim1)(1:1) = 'W' + c_qc(iim1)(3:4) = 'BB' + else + c_qc(ii)(1:1) = 'W' + c_qc(ii)(3:4) = 'BB' + endif +c +c If the neighboring reports are too far apart, +c reject both reports +c --------------------------------------------- + else + c_qc(iim1)(1:1) = 'W' + c_qc(iim1)(3:4) = 'BB' + c_qc(ii)(1:1) = 'W' + c_qc(ii)(3:4) = 'BB' + endif +c +c If only iim2 point is available... +c ---------------------------------- + elseif(iim2.ne.0) then +c + dist_tot = gcirc_qc(alat(iim1),alon(iim1), + $ alat(ii),alon(ii)) + dist_tot = dist_tot / 1000. + dist_ii = gcirc_qc(alat(iim2),alon(iim2), + $ alat(ii),alon(ii)) + dist_ii = dist_ii / 1000. + dist_iim1= gcirc_qc(alat(iim2),alon(iim2), + $ alat(iim1),alon(iim1)) + dist_iim1 = dist_iim1 / 1000. + if(l_print) + $ write(io8,*) 'distances:',dist_ii,dist_iim1 +c +c If ii point is close and iim1 point is far, choose ii point +c ----------------------------------------------------------- + if(abs(idt(ii)-idt(iim2)).le.5400.and. + $ dist_ii.le.1500.0.and.dist_iim1.gt.1500.0) then + if(l_print) then + write(io8,*) 'iim1 point is too far away' + endif + c_qc(iim1)(1:1) = 'W' + c_qc(iim1)(3:4) = 'BB' +c +c If iim1 point is close and ii point is far, choose iim1 point +c ------------------------------------------------------------- + elseif(abs(idt(ii)-idt(iim2)).le.5400.and. + $ dist_ii.gt.1500.0.and.dist_iim1.le.1500.0) then + if(l_print) then + write(io8,*) 'ii point is too far away' + endif + c_qc(ii)(1:1) = 'W' + c_qc(ii)(3:4) = 'BB' +c +c Otherwise reject both points +c ---------------------------- + else + if(l_print) then + write(io8,*) 'cannot decide which point' + endif + c_qc(iim1)(1:1) = 'W' + c_qc(iim1)(3:4) = 'BB' + c_qc(ii)(1:1) = 'W' + c_qc(ii)(3:4) = 'BB' + endif +c +c If only iip1 point is available... +c ---------------------------------- + elseif(iip1.ne.0) then +c + dist_tot = gcirc_qc(alat(iim1),alon(iim1), + $ alat(ii),alon(ii)) + dist_tot = dist_tot / 1000. + dist_ii = gcirc_qc(alat(iip1),alon(iip1), + $ alat(ii),alon(ii)) + dist_ii = dist_ii / 1000. + dist_iim1= gcirc_qc(alat(iip1),alon(iip1), + $ alat(iim1),alon(iim1)) + dist_iim1 = dist_iim1 / 1000. + if(l_print) + $ write(io8,*) 'distances:',dist_ii,dist_iim1 +c +c If ii point is close and iim1 point is far, choose ii point +c ----------------------------------------------------------- + if(abs(idt(ii)-idt(iip1)).le.5400.and. + $ dist_ii.le.1500.0.and.dist_iim1.gt.1500.0) then + if(l_print) then + write(io8,*) 'iim1 point is too far away' + endif + c_qc(iim1)(1:1) = 'W' + c_qc(iim1)(3:4) = 'BB' +c +c If iim1 point is close and ii point is far, choose iim1 point +c ------------------------------------------------------------- + elseif(abs(idt(ii)-idt(iip1)).le.5400.and. + $ dist_ii.gt.1500.0.and.dist_iim1.le.1500.0) then + if(l_print) then + write(io8,*) 'ii point is too far away' + endif + c_qc(ii)(1:1) = 'W' + c_qc(ii)(3:4) = 'BB' +c +c Otherwise reject both points +c ---------------------------- + else + if(l_print) then + write(io8,*) 'cannot decide which point' + endif + c_qc(iim1)(1:1) = 'W' + c_qc(iim1)(3:4) = 'BB' + c_qc(ii)(1:1) = 'W' + c_qc(ii)(3:4) = 'BB' + endif +c +c If both of the neighboring reports are not available +c and points are not close together, reject both reports +c ------------------------------------------------------ + else + if(l_print) then + write(io8,*) 'cannot decide which point' + endif + c_qc(iim1)(1:1) = 'W' + c_qc(iim1)(3:4) = 'BB' + c_qc(ii)(1:1) = 'W' + c_qc(ii)(3:4) = 'BB' + endif +c +c Check for duplicate with altitude error +c --------------------------------------- + elseif(idt_dif.eq.0.and. +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + $ abs(alat(iim1)-alat(ii)).lt.0.125.and. + $ abs(alon(iim1)-alon(ii)).lt.0.125.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ abs(ht_ft(iim1)-ht_ft(ii)).gt.1000.0) then +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Near duplicate with altitude error' + endif +c +c Examine neighboring reports to decide which one to keep +c ------------------------------------------------------- + if(iim2.ne.0.and.iip1.ne.0) then +c + dist_tot = gcirc_qc(alat(iip1),alon(iip1), + $ alat(iim2),alon(iim2)) + dist_tot = dist_tot / 1000. +c + if(l_print) then + write(io8,*) 'Distances: iim2-iip1 = ',dist_tot + endif +c +c Require the neighboring reports to be fairly close together +c ----------------------------------------------------------- + if(dist_tot.lt.2500.0) then +c +c If the neighboring reports have the same altitude, +c choose the report with the same altitude +c -------------------------------------------------- + if(abs(ht_ft(iim2)-ht_ft(iip1)).lt.1.5) then + write(io8,*) 'Neighboring altitudes equal' +c + if(abs(ht_ft(ii)-ht_ft(iim2)).lt.1.5) then + write(io8,*) 'ii altitude equal' + c_qc(iim1)(1:1) = 'A' + c_qc(iim1)(5:5) = 'B' +c + elseif(abs(ht_ft(iim1)-ht_ft(iim2)).lt.1.5) then + write(io8,*) 'iim1 altitude equal' + c_qc(ii)(1:1) = 'A' + c_qc(ii)(5:5) = 'B' +c + else + write(io8,*) 'neither altitude equal' + c_qc(iim1)(1:1) = 'A' + c_qc(iim1)(5:5) = 'B' + c_qc(ii)(1:1) = 'A' + c_qc(ii)(5:5) = 'B' + endif +c +c If points constitute an ascent or a descent, don't reject any +c ------------------------------------------------------------- + elseif((ht_ft(iim2).gt.ht_ft(iim1).and. + $ ht_ft(iim1).gt.ht_ft(ii).and. + $ ht_ft(ii ).gt.ht_ft(iip1)).or. + $ (ht_ft(iim2).lt.ht_ft(iim1).and. + $ ht_ft(iim1).lt.ht_ft(ii).and. + $ ht_ft(ii ).lt.ht_ft(iip1)).or. + $ (ht_ft(iim2).gt.ht_ft(ii).and. + $ ht_ft(ii ).gt.ht_ft(iim1).and. + $ ht_ft(iim1).gt.ht_ft(iip1)).or. + $ (ht_ft(iim2).lt.ht_ft(ii).and. + $ ht_ft(ii ).lt.ht_ft(iim1).and. + $ ht_ft(iim1).lt.ht_ft(iip1))) then +c + if(l_print) + $ write(io8,*) 'ascent/descent found--no rejects' +c +c If the neighboring reports have different altitudes and +c different temperatures, try using temperature to select one +c ----------------------------------------------------------- + elseif(ob_t(iim2).ne.ob_t(iip1)) then + write(io8,*) 'altitudes and temperatures differ' +c + if(abs(ht_ft(ii)-ht_ft(iim2)).lt.1.5.and. + $ abs(ob_t(ii)-ob_t(iim2)).lt.2.005) then + if(l_print) then + write(io8,*) 'ii point matches iim2' + endif + c_qc(iim1)(1:1) = 'A' + c_qc(iim1)(5:5) = 'B' +c + elseif(abs(ht_ft(iim1)-ht_ft(iim2)).lt.1.5.and. + $ abs(ob_t(iim1)-ob_t(iim2)).lt.2.005) then + if(l_print) then + write(io8,*) 'iim1 point matches iim2' + endif + c_qc(ii)(1:1) = 'A' + c_qc(ii)(5:5) = 'B' +c + elseif(abs(ht_ft(ii)-ht_ft(iip1)).lt.1.5.and. + $ abs(ob_t(ii)-ob_t(iip1)).lt.2.005) then + if(l_print) then + write(io8,*) 'ii point matches iip1' + endif + c_qc(iim1)(1:1) = 'A' + c_qc(iim1)(5:5) = 'B' +c + elseif(abs(ht_ft(iim1)-ht_ft(iip1)).lt.1.5.and. + $ abs(ob_t(iim1)-ob_t(iip1)).lt.2.005) then + if(l_print) then + write(io8,*) 'iim1 point matches iip1' + endif + c_qc(ii)(1:1) = 'A' + c_qc(ii)(5:5) = 'B' +c +c Otherwise reject both points +c ---------------------------- + else + if(l_print) + $ write(io8,*) 'neither point matches' + c_qc(iim1)(1:1) = 'A' + c_qc(iim1)(5:5) = 'B' + c_qc(ii)(1:1) = 'A' + c_qc(ii)(5:5) = 'B' + endif +c +c If the neighboring reports have different altitudes +c and the same temperature, reject both reports +c ---------------------------------------------------- + else + if(l_print) write(io8,*) 'cannot select' + c_qc(iim1)(1:1) = 'A' + c_qc(iim1)(5:5) = 'B' + c_qc(ii)(1:1) = 'A' + c_qc(ii)(5:5) = 'B' + endif +c +c If the neighboring reports are too far apart, +c reject both reports +c --------------------------------------------- + else + if(l_print) write(io8,*) 'points too far apart' + c_qc(iim1)(1:1) = 'A' + c_qc(iim1)(5:5) = 'B' + c_qc(ii)(1:1) = 'A' + c_qc(ii)(5:5) = 'B' + endif +c +c If only iim2 point is available... +c ---------------------------------- + elseif(iim2.ne.0) then + dist_ii = gcirc_qc(alat(iim2),alon(iim2), + $ alat(ii ),alon(ii )) + dist_ii = dist_ii / 1000. + dist_iim1= gcirc_qc(alat(iim2),alon(iim2), + $ alat(iim1),alon(iim1)) + dist_iim1 = dist_iim1 / 1000. +c +c If ii point is close, choose it +c ------------------------------- + if(abs(idt(ii)-idt(iim2)).le.5400.and. + $ dist_ii.lt.1500.0.and. + $ abs(ht_ft(ii)-ht_ft(iim2)).lt.1.5.and. + $ abs(ob_t(ii)-ob_t(iim2)).lt.2.005) then + if(l_print) then + write(io8,*) 'ii point matches iim2' + endif + c_qc(iim1)(1:1) = 'A' + c_qc(iim1)(5:5) = 'B' +c +c If iim1 point is close, choose it +c --------------------------------- + elseif(abs(idt(ii)-idt(iim2)).le.5400.and. + $ dist_iim1.lt.1500.0.and. + $ abs(ht_ft(iim1)-ht_ft(iim2)).lt.1.5.and. + $ abs(ob_t(iim1)-ob_t(iim2)).lt.2.005) then + if(l_print) then + write(io8,*) 'iim1 point matches iim2' + endif + c_qc(ii)(1:1) = 'A' + c_qc(ii)(5:5) = 'B' +c +c Otherwise reject both points +c ---------------------------- + else + if(l_print) write(io8,*) 'cannot make match' + c_qc(iim1)(1:1) = 'A' + c_qc(iim1)(5:5) = 'B' + c_qc(ii)(1:1) = 'A' + c_qc(ii)(5:5) = 'B' + endif +c +c If only iip1 point is available... +c ---------------------------------- + elseif(iip1.ne.0) then + dist_ii = gcirc_qc(alat(iip1),alon(iip1), + $ alat(ii ),alon(ii )) + dist_ii = dist_ii / 1000. + dist_iim1= gcirc_qc(alat(iip1),alon(iip1), + $ alat(iim1),alon(iim1)) + dist_iim1 = dist_iim1 / 1000. +c +c If ii point is close, choose it +c ------------------------------- + if(abs(idt(ii)-idt(iip1)).le.5400.and. + $ dist_ii.le.1500.0.and. + $ abs(ht_ft(ii)-ht_ft(iip1)).lt.1.5.and. + $ abs(ob_t(ii)-ob_t(iip1)).lt.2.005) then + if(l_print) then + write(io8,*) 'ii point matches iip1' + endif + c_qc(iim1)(1:1) = 'A' + c_qc(iim1)(5:5) = 'B' +c +c If iim1 point is close, choose it +c --------------------------------- + elseif(abs(idt(ii)-idt(iip1)).le.5400.and. + $ dist_iim1.le.1500.0.and. + $ abs(ht_ft(iim1)-ht_ft(iip1)).lt.1.5.and. + $ abs(ob_t(iim1)-ob_t(iip1)).lt.2.005) then + if(l_print) then + write(io8,*) 'iim1 point matches iip1' + endif + c_qc(ii)(1:1) = 'A' + c_qc(ii)(5:5) = 'B' +c +c Otherwise reject both points +c ---------------------------- + else + if(l_print) write(io8,*) 'cannot make match' + c_qc(iim1)(1:1) = 'A' + c_qc(iim1)(5:5) = 'B' + c_qc(ii)(1:1) = 'A' + c_qc(ii)(5:5) = 'B' + endif +c +c If both of the neighboring reports are not available +c reject both reports +c ---------------------------------------------------- + else + if(l_print) write(io8,*) 'no neighboring points' + c_qc(iim1)(1:1) = 'A' + c_qc(iim1)(5:5) = 'B' + c_qc(ii)(1:1) = 'A' + c_qc(ii)(5:5) = 'B' + endif +c +c Check for duplicate with time error +c ----------------------------------- + elseif(idt(iim1).ne.idt(ii).and. +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + $ abs(alat(iim1)-alat(ii)).lt.0.125.and. + $ abs(alon(iim1)-alon(ii)).lt.0.125.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ abs(ht_ft(iim1)-ht_ft(ii)).lt.50.5) then +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Discrepancy in time' + endif +c +c If points are close in time, average times +c ------------------------------------------ + if(abs(idt(iim1)-idt(ii)).lt.1800.0) then +c + if(l_print) then + write(io8,*) 'points close--averaging' + endif + idt(ii) = (idt(ii)+idt(iim1))/2 + c_qc(ii)(2:2) = 'R' + c_qc(iim1)(1:1) = 't' + c_qc(iim1)(2:2) = 'B' +c +c Otherwise, examine neighboring reports to decide which one to keep +c ------------------------------------------------------------------ + elseif(iim2.ne.0.and.iip1.ne.0) then +c +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + alat_dif = abs(alat(iip1)-alat(iim2)) + alon0 = alon(ii) + alonm2 = alon(iim2) + alonp1 = alon(iip1) + if(alon0.gt.270.0.and.alonm2.lt.90.0) + $ alonm2 = alonm2 + 360.0 + if(alon0.lt.90.0.and.alonm2.gt.270.0) + $ alonm2 = 360.0 - alonm2 + if(alon0.gt.270.0.and.alonp1.lt.90.0) + $ alonp1 = alonp1 + 360.0 + if(alon0.lt.90.0.and.alonp1.gt.270.0) + $ alonp1 = 360.0 - alonp1 + alon_dif = abs(alonp1-alonm2) +c + if(alon_dif.eq.0.0.and. + $ alat_dif.eq.0.0) then + time_est = amiss +c + elseif(alon_dif.ge.alat_dif) then + time_est = (float(idt(iip1)-idt(iim2))) + $ / (alonp1-alonm2) + $ * (alon0-alonm2) + $ + float(idt(iim2)) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + else + time_est = (float(idt(iip1)-idt(iim2))) + $ / (alat(iip1)-alat(iim2)) + $ * (alat(ii)-alat(iim2)) + $ + float(idt(iim2)) + endif +c + idt_tot = abs(idt(iip1) - idt(iim2)) +c + if(l_print) then + write(io8,*) 'Estimated time = ',time_est + write(io8,*) 'Lons = ',alonm2,alon0,alonp1 + endif +c +c If the neighboring reports are close enough together, +c choose the report that is closest to the interpolated point +c ----------------------------------------------------------- + if(idt_tot.lt.9000.and.time_est.ne.amiss) then + if(abs(ifix(time_est)-idt(ii)).lt. + $ abs(ifix(time_est)-idt(iim1))) then + c_qc(iim1)(1:1) = 't' + c_qc(iim1)(2:2) = 'B' +c + else + c_qc(ii)(1:1) = 't' + c_qc(ii)(2:2) = 'B' +c + endif +c +c If the neighboring reports are too far apart, +c reject both reports +c --------------------------------------------- + else + c_qc(iim1)(1:1) = 't' + c_qc(iim1)(2:2) = 'B' + c_qc(ii)(1:1) = 't' + c_qc(ii)(2:2) = 'B' + endif +c +c Otherwise reject both points +c ---------------------------- + else + if(l_print) then + write(io8,*) 'cannot decide which point' + endif + c_qc(iim1)(1:1) = 't' + c_qc(iim1)(2:2) = 'B' + c_qc(ii)(1:1) = 't' + c_qc(ii)(2:2) = 'B' + endif +c +c Write out any other duplicates +c ------------------------------ + else + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Leftover duplicate' + endif + endif +c +c Make sure retained report has all available values +c (ii report is rejected; iim1 report is retained) +c -------------------------------------------------- + if((c_qc(ii)(1:1).eq.'W'.and.c_qc(iim1).ne.'W').or. + $ (c_qc(ii)(1:1).eq.'A'.and.c_qc(iim1).ne.'A').or. + $ (c_qc(ii)(1:1).eq.'t'.and.c_qc(iim1).ne.'t')) then +c + if(ob_t(iim1).eq.amiss.and.ob_t(ii).ne.amiss) then + ob_t(iim1) = ob_t(ii) + c_qc(iim1)(6:6) = c_qc(ii)(6:6) + ob_t(ii) = amiss + c_qc(ii)(6:6) = 'M' + endif + if(ob_dir(iim1).eq.amiss.and.ob_dir(ii).ne.amiss) then + ob_dir(iim1) = ob_dir(ii) + c_qc(iim1)(7:7) = c_qc(ii)(7:7) + ob_dir(ii) = amiss + c_qc(ii)(7:7) = 'M' + endif + if(ob_dir(iim1).lt.0.5.and.difdir.gt.10.5) then + ob_dir(iim1) = ob_dir(ii) + c_qc(iim1)(7:7) = c_qc(ii)(7:7) + ob_dir(ii) = amiss + c_qc(ii)(7:7) = 'M' + endif + if(ob_spd(iim1).eq.amiss.and.ob_spd(ii).ne.amiss) then + ob_spd(iim1) = ob_spd(ii) + c_qc(iim1)(8:8) = c_qc(ii)(8:8) + ob_spd(ii) = amiss + c_qc(ii)(8:8) = 'M' + endif + if(ob_spd(iim1).lt.0.05.and.ob_spd(ii).gt.1.25) then + ob_spd(iim1) = ob_spd(ii) + c_qc(iim1)(8:8) = c_qc(ii)(8:8) + ob_spd(ii) = amiss + c_qc(ii)(8:8) = 'M' + endif +c + if(ob_spd(ii).eq.amiss.and.ob_dir(ii).ne.amiss) + $ c_qc(ii)(7:7) = 'I' + if(ob_dir(ii).eq.amiss.and.ob_spd(ii).ne.amiss) + $ c_qc(ii)(8:8) = 'I' + if(ob_spd(iim1).eq.amiss.and.ob_dir(iim1).ne.amiss) + $ c_qc(iim1)(7:7) = 'I' + if(ob_dir(iim1).eq.amiss.and.ob_spd(iim1).ne.amiss) + $ c_qc(iim1)(8:8) = 'I' +c +c Make sure retained report has all available values +c (iim1 report is rejected; ii report is retained) +c -------------------------------------------------- + elseif((c_qc(iim1)(1:1).eq.'W'.and.c_qc(ii).ne.'W').or. + $ (c_qc(iim1)(1:1).eq.'A'.and.c_qc(ii).ne.'A').or. + $ (c_qc(iim1)(1:1).eq.'t'.and.c_qc(ii).ne.'t'))then +c + if(ob_t(ii).eq.amiss.and.ob_t(iim1).ne.amiss) then + ob_t(ii) = ob_t(iim1) + c_qc(ii)(6:6) = c_qc(iim1)(6:6) + ob_t(iim1) = amiss + c_qc(iim1)(6:6) = 'M' + endif + if(ob_dir(ii).eq.amiss.and.ob_dir(iim1).ne.amiss) then + ob_dir(ii) = ob_dir(iim1) + c_qc(ii)(7:7) = c_qc(iim1)(7:7) + ob_dir(iim1) = amiss + c_qc(iim1)(7:7) = 'M' + endif + if(ob_dir(ii).lt.0.5.and.difdir.gt.10.5) then + ob_dir(ii) = ob_dir(iim1) + c_qc(ii)(7:7) = c_qc(iim1)(7:7) + ob_dir(iim1) = amiss + c_qc(iim1)(7:7) = 'M' + endif + if(ob_spd(ii).eq.amiss.and.ob_spd(iim1).ne.amiss) then + ob_spd(ii) = ob_spd(iim1) + c_qc(ii)(8:8) = c_qc(iim1)(8:8) + ob_spd(iim1) = amiss + c_qc(iim1)(8:8) = 'M' + endif + if(ob_spd(ii).lt.0.05.and.ob_spd(iim1).gt.1.25) then + ob_spd(ii) = ob_spd(iim1) + c_qc(ii)(8:8) = c_qc(iim1)(8:8) + ob_spd(iim1) = amiss + c_qc(iim1)(8:8) = 'M' + endif +c + if(ob_spd(ii).eq.amiss.and.ob_dir(ii).ne.amiss) + $ c_qc(ii)(7:7) = 'I' + if(ob_dir(ii).eq.amiss.and.ob_spd(ii).ne.amiss) + $ c_qc(ii)(8:8) = 'I' + if(ob_spd(iim1).eq.amiss.and.ob_dir(iim1).ne.amiss) + $ c_qc(iim1)(7:7) = 'I' + if(ob_dir(iim1).eq.amiss.and.ob_spd(iim1).ne.amiss) + $ c_qc(iim1)(8:8) = 'I' + endif + endif + endif +c +c Print series of reports if desired +c ---------------------------------- + if(l_print) then + if(iim2.ne.0) write(io8,8002) kk,iim2 + x, c_insty_ob(itype(iim2)) + x, c_acftreg(iim2),c_acftid(iim2) + x, idt(iim2),alat(iim2),alon(iim2) + x, pres(iim2),ht_ft(iim2) + x, t_prcn(iim2),ob_t(iim2),xiv_t(iim2),ichk_t(iim2) + x, ob_q(iim2),xiv_q(iim2),ichk_q(iim2) + x, ob_dir(iim2),xiv_d(iim2),ichk_d(iim2) + x, ob_spd(iim2),xiv_s(iim2),ichk_s(iim2) + x, c_qc(iim2) + if(iim1.ne.0) write(io8,8002) kk,iim1 + x, c_insty_ob(itype(iim1)) + x, c_acftreg(iim1),c_acftid(iim1) + x, idt(iim1),alat(iim1),alon(iim1) + x, pres(iim1),ht_ft(iim1) + x, t_prcn(iim1),ob_t(iim1),xiv_t(iim1),ichk_t(iim1) + x, ob_q(iim1),xiv_q(iim1),ichk_q(iim1) + x, ob_dir(iim1),xiv_d(iim1),ichk_d(iim1) + x, ob_spd(iim1),xiv_s(iim1),ichk_s(iim1) + x, c_qc(iim1) + write(io8,8002) kk,ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + if(iip1.ne.0) write(io8,8002) kk,iip1 + x, c_insty_ob(itype(iip1)) + x, c_acftreg(iip1),c_acftid(iip1) + x, idt(iip1),alat(iip1),alon(iip1) + x, pres(iip1),ht_ft(iip1) + x, t_prcn(iip1),ob_t(iip1),xiv_t(iip1),ichk_t(iip1) + x, ob_q(iip1),xiv_q(iip1),ichk_q(iip1) + x, ob_dir(iip1),xiv_d(iip1),ichk_d(iip1) + x, ob_spd(iip1),xiv_s(iip1),ichk_s(iip1) + x, c_qc(iip1) + endif +c +c End loop over reports +c --------------------- + enddo +c +c Check rest of flight if stuck clock found +c ----------------------------------------- + if(stuck) then + do iob = istart,iend + ii = indx(iob) + if(idt(ii).eq.idt_stk.and. + $ c_qc(ii)(2:2).ne.'K') then + c_qc(ii)(2:2) = 'K' + write(io8,*) + write(io8,*) 'Another stuck clock found' + write(io8,8002) kk,ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + endif + enddo + endif +c +c End if clause for real flights with at least three reports +c ---------------------------------------------------------- + endif +c +c End loop over flights +c --------------------- + enddo +c +c Write out bad reports +c --------------------- + if(.not.l_operational) then + write(io35,*) + write(io35,*) 'Inconsistent positions' + write(io35,*) '----------------------' + write(io35,3001) + 3001 format(' index type tail num flight time lat' + x, ' lon pres height ' + x, 't-prcn temp innov ichk' + x, ' spec hum innov ichk' + x, ' ob_dir innov ichk' + x, ' ob_spd innov ichk' + x, ' qc flag') + endif +c + kbad = 0 +c + do iob = 1,numreps + ii = indx(iob) +c + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des) then + ktype = 1 +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des) then + ktype = 2 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des) then + ktype = 3 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des) then + ktype = 4 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + ktype = 5 + endif +c + if(ktype.eq.1) then + nrep_Md = nrep_Md + 1 + elseif(ktype.eq.2) then + nrep_Ac = nrep_Ac + 1 + elseif(ktype.eq.3) then + nrep_Am = nrep_Am + 1 + elseif(ktype.eq.4) then + nrep_Ar = nrep_Ar + 1 + elseif(ktype.eq.5) then + nrep_Ma = nrep_Ma + 1 + endif +c + if(c_qc(ii)(1:1).eq.'r'.or. + $ c_qc(ii)(1:1).eq.'W'.or. + $ c_qc(ii)(1:1).eq.'A'.or. + $ c_qc(ii)(1:1).eq.'t'.or. + $ c_qc(ii)(2:2).eq.'K'.or. + $ c_qc(ii)(2:2).eq.'R'.or. + $ c_qc(ii)(3:4).eq.'RR'.or. + $ c_qc(ii)(5:5).eq.'B') then +c + if(.not.l_operational) then + write(io35,3002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + 3002 format(i6,1x,a8,1x,a8,1x,a9,1x,i7,1x,2f11.5,1x,f8.1,1x,f7.0 + x, 1x,f5.2,4(2(1x,f8.2),1x,i5),1x,'!',a11,'!') + endif +c +c Count by category +c ----------------- + if(c_qc(ii)(1:1).eq.'r') then + ninc_xtra(ktype) = ninc_xtra(ktype) + 1 + elseif(c_qc(ii)(1:1).eq.'W') then + ninc_way(ktype) = ninc_way(ktype) + 1 + elseif(c_qc(ii)(1:1).eq.'A') then + ninc_alt(ktype) = ninc_alt(ktype) + 1 + elseif(c_qc(ii)(2:2).eq.'K') then + ninc_stk(ktype) = ninc_stk(ktype) + 1 + elseif(c_qc(ii)(2:2).eq.'B') then + ninc_time(ktype) = ninc_time(ktype) + 1 + elseif(c_qc(ii)(3:4).eq.'RR'.or. + $ c_qc(ii)(2:2).eq.'R') then + ninc_avg(ktype) = ninc_avg(ktype) + 1 + elseif(c_qc(ii)(5:5).eq.'B') then + ninc_bad(ktype) = ninc_bad(ktype) + 1 + endif + endif +c +c Reject redundant reports and reports with inconsistent positions +c ---------------------------------------------------------------- + if(c_qc(ii)(1:1).eq.'r'.or. + $ c_qc(ii)(1:1).eq.'W'.or. + $ c_qc(ii)(1:1).eq.'A'.or. + $ c_qc(ii)(1:1).eq.'t'.or. + $ c_qc(ii)(2:2).eq.'K'.or. + $ c_qc(ii)(5:5).eq.'B') then +c + csort(ii)(1:5) = 'badob' +c + kbad(ktype) = kbad(ktype) + 1 +c + if(ktype.eq.1) then + ninc_Md = ninc_Md + 1 + elseif(ktype.eq.2) then + ninc_Ac = ninc_Ac + 1 + elseif(ktype.eq.3) then + ninc_Am = ninc_Am + 1 + elseif(ktype.eq.4) then + ninc_Ar = ninc_Ar + 1 + elseif(ktype.eq.5) then + ninc_Ma = ninc_Ma + 1 + endif + endif +c + enddo +c + if(.not.l_operational) then + write(io35,*) + write(io35,*)' Number of inc MDCRS reps rejected = ',kbad(1) +ccccdak write(io35,*)' Number of inc ACARS reps rejected = ',kbad(2) + write(io35,*)' Number of inc TAMDAR reps rejected = ',kbad(2) + write(io35,*)' Number of inc AMDAR reps rejected = ',kbad(3) + write(io35,*)' Number of inc AIREP reps rejected = ',kbad(4) + write(io35,*)' Number of inc manAIREP reps rejected = ',kbad(5) + endif +c + write(io8,*) + write(io8,*) ' Reports with inconsistent positions--rejected' + write(io8,*) ' ---------------------------------------------' + write(io8,*)' Number of inc MDCRS reps rejected = ',kbad(1) +ccccdak write(io8,*)' Number of inc ACARS reps rejected = ',kbad(2) + write(io8,*)' Number of inc TAMDAR reps rejected = ',kbad(2) + write(io8,*)' Number of inc AMDAR reps rejected = ',kbad(3) + write(io8,*)' Number of inc AIREP reps rejected = ',kbad(4) + write(io8,*)' Number of inc manAIREP reps rejected = ',kbad(5) +c + write(*,*) + write(*,*) 'Inconsistent position check data counts--',cdtg_an + write(*,*) '---------------------------------------------------' + write(*,'(1x,a55)') +ccccdak $ 'Type of check MDCRS ACARS AMDAR AIREP man' + $ 'Type of check MDCRS TAMDAR AMDAR AIREP man' + write(*,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(*,'('' Num considered '',5(1x,i7))') + $ nrep_Md,nrep_Ac,nrep_Am,nrep_Ar,nrep_Ma + write(*,'('' Total rejected '',5(1x,i7))') + $ ninc_Md,ninc_Ac,ninc_Am,ninc_Ar,ninc_Ma + write(*,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + write(io8,*) + write(io8,*) 'Inconsistent position check data counts' + write(io8,*) '---------------------------------------' + write(io8,'(1x,a55)') +ccccdak $ 'Type of check MDCRS ACARS AMDAR AIREP man' + $ 'Type of check MDCRS TAMDAR AMDAR AIREP man' + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Num considered '',5(1x,i7))') + $ nrep_Md,nrep_Ac,nrep_Am,nrep_Ar,nrep_Ma + write(io8,'(''Total rejected '',5(1x,i7))') + $ ninc_Md,ninc_Ac,ninc_Am,ninc_Ar,ninc_Ma + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Redundant reps '',5(1x,i7))') + $ (ninc_xtra(ii),ii=1,5) + write(io8,'(''Bad waypoint '',5(1x,i7))') + $ (ninc_way(ii),ii=1,5) + write(io8,'(''Bad altitude '',5(1x,i7))') + $ (ninc_alt(ii),ii=1,5) + write(io8,'(''Stuck clock '',5(1x,i7))') + $ (ninc_stk(ii),ii=1,5) + write(io8,'(''Bad time '',5(1x,i7))') + $ (ninc_time(ii),ii=1,5) + write(io8,'(''Inconsistent ht'',5(1x,i7))') + $ (ninc_bad(ii),ii=1,5) + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Avg posn/time '',5(1x,i7))') + $ (ninc_avg(ii),ii=1,5) + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + kbadtot = kbad(1) + kbad(2) + kbad(3) + $ + kbad(4) + kbad(5) +c + write(io8,*) + write(io8,*) numreps,' good reports processed' + write(io8,*) kbadtot,' reports failed qc in position check' +c + return + end +c +c ################################################################### +c subroutine orddup_qc +c ################################################################### +c + subroutine orddup_qc(max_reps,indx,isave,ht_ft,idt,alat,alon + $, kflight,maxflt,nobs_flt,iobs_flt + $, c_acftreg,c_acftid,cidmiss,idt_near,io8) +c +c Check the ordering of near-duplicate reports based on heights +c + implicit none +c + integer io8 ! i/o unit number for log file + integer iob ! do loop index + $, max_reps ! max number of observations/reports + $, ii ! index pointing to current report + $, iim1 ! index pointing to previous report + $, iim2 ! index pointing to two reports ago + $, iim3 ! index pointing to three reports ago + $, iip1 ! index pointing to following report + $, iip2 ! index pointing to report after next + integer indx(max_reps) ! pointer array + $, isave(max_reps) ! second pointer array used to reverse order + integer kk ! do loop index + integer knt ! number of reports with the same time + $, kneg ! number of reports with negative heights + ! and with the same time + $, kkk ! do loop index + $, nn ! do loop index + $, nback ! variable used in reversing order + integer idt_dif1 ! first time difference + $, idt_dif2 ! second time difference + integer idt_near ! time difference between "near" neighbors +c +c Work arrays +c ----------- + real ht_ft(max_reps) ! height in feet + integer iht0,iht1 ! integer height in feet + integer idt(max_reps) ! time in seconds to analysis time + real*8 alat(max_reps) ! latitude + $, alon(max_reps) ! longitude + character*9 c_acftid(max_reps) ! acft flight number + character*8 c_acftreg(max_reps) ! acft tail number +c + character*8 cidmiss ! missing value flag for flight number +c + integer maxflt ! max number of flights allowed + integer kflight ! number of flights in dataset + integer nobs_flt(maxflt) ! number of reports per flight + $, iobs_flt(maxflt) ! index for first report in each flight + integer istart ! index for first report in current flight + $, iistart ! index from pointer array for istart + $, iend ! index for last report in current flight + $, iiend ! index from pointer array for iend + $, inow ! iob + 1 + $, inext ! counter + $, iinext ! index from pointer array for inext + $, ilast ! index for last report with same time + $, iilast ! index from pointer array for ilast + $, iilastm1 ! index from pointer array for ilast-1 + $, iilastm2 ! index from pointer array for ilast-2 + $, iilastp1 ! index from pointer array for ilast+1 + $, iibefore ! index from pointer array for previous rep + $, iiafter ! index from pointer array for following rep + $, iii ! index pointer for current report + $, iiim1 ! index pointer for previous report + real*8 alat_dif ! latitude difference used to check ordering + $, alon_dif ! longitude difference used to check ordering + real ht_max ! maximum height in group with same time + $, ht_min ! minimum height in group with same time + $, ht_dif1,ht_dif2 ! height differences +c + logical sameht ! true if altitudes are equal +c + logical l_print ! print diagnostic output if true +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c +c Begin loop over flights +c ----------------------- + do kk = 1,kflight +c +c Initialize variables +c -------------------- + istart = iobs_flt(kk) + iistart = indx(istart) + iend = iobs_flt(kk) + nobs_flt(kk) - 1 + iiend = indx(iend) +c +c Set print switch +c ---------------- + l_print = .false. + if(c_acftreg(iistart)(1:8).eq.'########') l_print = .true. +c + if(l_print) then + write(io8,*) + write(io8,*) 'orddup output for ########' + write(io8,*) '--------------------------' + write(io8,*) 'iistart,iiend = ',iistart,iiend + endif +c +c Don't compare reports with missing flight number +c Perform check only for flights with three or more reports +c ----------------------------------------------------------------- + if(c_acftid(iistart)(1:8).ne.cidmiss(1:8).and. + $ nobs_flt(kk).ge.3) then +c + if(l_print) write(io8,*) 'Valid flight found' +c +c Check ordering of reports with the same time +c -------------------------------------------- +c +c Compute indices +c --------------- + iob = istart +c + do while(iob.lt.iend) + if(iob.gt.istart+2) then + iim3 = indx(iob-3) + else + iim3 = 0 + endif +c + if(iob.gt.istart+1) then + iim2 = indx(iob-2) + else + iim2 = 0 + endif +c + if(iob.gt.istart) then + iim1 = indx(iob-1) + else + iim1 = 0 + endif +c + ii = indx(iob) +c + if(iob.lt.iend) then + iip1 = indx(iob+1) + else + iip1 = 0 + endif +c + if(iob.lt.iend-1) then + iip2 = indx(iob+2) + else + iip2 = 0 + endif +c +c Count number of reports with same time +c -------------------------------------- + if(iip1.ne.0) then + if(idt(ii).eq.idt(iip1)) then + knt = 2 +c write(io8,*) +c write(io8,*) 'Second report with same time--',ii,iip1,knt +c + ht_max = ht_ft(ii) + if(ht_ft(iip1).gt.ht_max) ht_max = ht_ft(iip1) +c + ht_min = ht_ft(ii) + if(ht_ft(iip1).lt.ht_min) ht_min = ht_ft(iip1) +c + if(ht_ft(ii).lt.0) then + kneg = 1 +c write(io8,*) +c write(io8,*) 'Negative height found for ii=',ii + else + kneg = 0 + endif +c + if(ht_ft(iip1).lt.0) then + kneg = kneg + 1 +c write(io8,*) 'A second neg ht found for ii=',iip1 + endif +c + inow = iob + 1 + inext = inow + 1 +c + 10 if(inext.le.iend) then + iinext = indx(inext) + if(idt(ii).eq.idt(iinext)) then + knt = knt + 1 +c write(io8,*) 'Another report with same time--',inext + if(ht_ft(iinext).gt.ht_max) ht_max = ht_ft(iinext) + if(ht_ft(iinext).lt.ht_min) ht_min = ht_ft(iinext) + if(ht_ft(iinext).lt.0) then + kneg = kneg + 1 +c write(io8,*) 'Another neg ht found for ii=',iinext + endif + inext = inext + 1 + goto 10 + endif + endif +c + if(l_print) then + write(io8,*) + write(io8,*) '#obs with same time = ',knt + write(io8,*) '#obs with neg height = ',kneg + write(io8,*) 'ht_max,ht_min = ',ht_max,ht_min + write(io8,*) 'inow,inext = ',inow,inext + write(io8,*) 'iim3,iim2,iim1 = ',iim3,iim2,iim1 + write(io8,*) 'ii,iip1,iip2 = ',ii,iip1,iip2 + endif +c + ilast = inext - 1 + if(ilast.le.iend) then + iilast = indx(ilast) + else + iilast = 0 + endif + if(ilast+1.le.iend) then + iilastp1 = indx(ilast+1) + else + iilastp1 = 0 + endif + if(ilast-1.ge.istart) then + iilastm1 = indx(ilast-1) + else + iilastm1 = 0 + endif + if(ilast-2.ge.istart) then + iilastm2 = indx(ilast-2) + else + iilastm2 = 0 + endif +c + if(l_print) then + write(io8,*) 'iilastm2,iilastm1 = ',iilastm2,iilastm1 + write(io8,*) 'iilast,iilastp1 = ',iilast,iilastp1 + endif +c +c Case with duplicates in middle of flight +c ---------------------------------------- + if(iim1.ne.0.and.iip1.ne.0.and. + $ iilast.ne.0.and.iilastp1.ne.0.and. + $ iilastm1.ne.0) then +c + idt_dif1 = abs(idt(ii) - idt(iim1)) + iibefore = iim1 + if(idt_dif1.ge.idt_near) then + idt_dif1 = abs(idt(iip1) - idt(ii)) + iibefore = ii + endif +c + idt_dif2 = abs(idt(iilastp1) - idt(iilast)) + iiafter = iilastp1 + if(idt_dif2.ge.idt_near) then + idt_dif2 = abs(idt(iilast) - idt(iilastm1)) + iiafter = iilast + endif +c + if(l_print) then + write(io8,*) 'Duplicates in middle of flight' + write(io8,*) 'idt_dif1,idt_dif2= ',idt_dif1,idt_dif2 + write(io8,*) 'iibefore,iiafter = ',iibefore,iiafter + endif +c +c Check if near dups are part of a level flight leg +c ------------------------------------------------- + if(abs(ht_ft(iibefore) - ht_ft(iiafter)).le.100.0.and. + $ abs(ht_ft(iibefore) - ht_max).le.100.0.and. + $ abs(ht_min - ht_ft(iiafter)).le.100.0) then +c + if(l_print) + $ write(io8,*) 'Near dups in smooth level leg--ii=',ii +c +c Or part of a smooth ascent +c -------------------------- + elseif(ht_ft(iibefore).lt.ht_ft(iiafter).and. + $ ht_ft(iibefore).le.ht_min.and. + $ ht_max.le.ht_ft(iiafter)) then +c + if(l_print) + $ write(io8,*) 'Near dups in smooth ascent--ii=',ii +c +c Or part of smooth descent +c ------------------------- + elseif(ht_ft(iibefore).gt.ht_ft(iiafter).and. + $ ht_ft(iibefore).ge.ht_max.and. + $ ht_min.ge.ht_ft(iiafter)) then +c + if(l_print) + $ write(io8,*) 'Near dups in smooth descent--ii=',ii +c +c Or near dups are near max or min altitude +c ----------------------------------------- + else +c + ht_dif1 = abs(ht_ft(iibefore) - ht_ft(ii)) + ht_dif2 = abs(ht_ft(iilast) - ht_ft(iiafter)) +c +c Re-set iibefore or iiafter if appropriate +c ----------------------------------------- + if(idt_dif1.lt.idt_dif2.and. + $ iibefore.ne.ii.and.iiafter.ne.iilast) then +c + idt_dif2 = abs(idt(iilast) - idt(iilastm1)) + iiafter = iilast +c + if(l_print) then + write(io8,*) 'Near dups near peak alt-1-ii=',ii + write(io8,*) 'idt_dif2,iiafter= ',idt_dif2,iiafter + endif +c + elseif(idt_dif1.gt.idt_dif2.and. + $ iibefore.ne.ii.and.iiafter.ne.iilast) then +c + idt_dif1 = abs(idt(iip1) - idt(ii)) + iibefore = ii +c + if(l_print) then + write(io8,*) + write(io8,*)'Near dups near peak alt-2-ii=',ii + write(io8,*)'idt_dif1,iibefore=',idt_dif1,iibefore + endif +c + elseif(idt_dif1.eq.idt_dif2.and. + $ iibefore.ne.ii.and.iiafter.eq.iilast) then +c + if(idt(iip2)-idt(iip1).ge.idt_near) then + idt_dif2 = abs(idt(iilastm1) - idt(iilastm2)) + iiafter = iilastm1 +c + if(l_print) then + write(io8,*)'Dropping last point in descent',ii + write(io8,*)'idt_dif2,iiafter=',idt_dif2,iiafter + endif +c + elseif(ht_dif1.lt.ht_dif2) then + idt_dif2 = abs(idt(iilast) - idt(iilastm1)) + iiafter = iilast +c + if(l_print) then + write(io8,*)'Near dups near peak alt-3-ii=',ii + write(io8,*)'idt_dif2,iiafter=',idt_dif2,iiafter + endif +c + elseif(ht_dif1.gt.ht_dif2) then + idt_dif1 = abs(idt(iip1) - idt(ii)) + iibefore = ii +c + if(l_print) then + write(io8,*)'Near dups near peak alt-4-ii=',ii + write(io8,*)'idt_dif1,iibefr=',idt_dif1,iibefore + endif +c + else + if(l_print) then + write(io8,*)'Near dups near peak alt-5-ii=',ii + write(io8,*)'Neither time nor height check used' + endif + endif +c + else + if(l_print) then + write(io8,*) 'Near dups near peak alt-6-ii=',ii + write(io8,*) 'Indices not reset' + endif + endif + endif +c +c Case with duplicates during whole flight +c ---------------------------------------- + elseif(iob.eq.istart.and.ilast.eq.iend.and. + $ iilastm1.ne.0) then + idt_dif1 = 0 + iibefore = ii + idt_dif2 = abs(idt(iilast) - idt(iilastm1)) + iiafter = iilast +c + if(l_print) then + write(io8,*) 'Near dups found during whole flight' + write(io8,*) knt,' reports found with same time' + write(io8,*) 'idt_dif1,idt_dif2= ',idt_dif1,idt_dif2 + write(io8,*) 'iibefore,iiafter = ',iibefore,iiafter + endif +c +c Case with duplicates at beginning of flight +c ------------------------------------------- + elseif(iob.eq.istart.and.ilast.le.iend.and. + $ iilastm1.ne.0.and.iilastp1.ne.0) then + idt_dif1 = 0 + iibefore = ii + idt_dif2 = abs(idt(iilast) - idt(iilastp1)) + iiafter = iilastp1 + if(idt_dif2.ge.idt_near) then + idt_dif2 = abs(idt(iilast) - idt(iilastm1)) + iiafter = iilast + endif +c + if(l_print) then + write(io8,*)'Near dups found at beginning of flight' + write(io8,*) knt,' reports found with same time' + write(io8,*) 'idt_dif1,idt_dif2= ',idt_dif1,idt_dif2 + write(io8,*) 'iibefore,iiafter = ',iibefore,iiafter + endif +c +c Case with duplicates at end of flight +c ------------------------------------- + elseif(iob.gt.istart.and.ilast.eq.iend.and. + $ iim1.ne.0.and.iip1.ne.0) then + idt_dif1 = abs(idt(ii) - idt(iim1)) + iibefore = iim1 + if(idt_dif1.ge.idt_near) then + idt_dif1 = abs(idt(iip1) - idt(ii)) + iibefore = ii + endif + idt_dif2 = 0 + iiafter = iilast +c + if(l_print) then + write(io8,*) 'Near dups found at end of flight' + write(io8,*) knt,' reports found with same time' + write(io8,*) 'idt_dif1,idt_dif2= ',idt_dif1,idt_dif2 + write(io8,*) 'iibefore,iiafter = ',iibefore,iiafter + endif + endif +c +c Check time differences--compare neighboring reports within idt_near +c ------------------------------------------------------------------- + if(idt_dif1.lt.idt_near.and.idt_dif2.lt.idt_near) then +c + iht0 = nint(ht_ft(iibefore)/100.) + iht1 = nint(ht_ft(iiafter)/100.) +c + if(l_print) then + write(io8,*) 'Time differences within idt_near' + write(io8,*) 'iht0,iht1 = ',iht0,iht1 + endif +c +c Check if all altitudes are equal +c -------------------------------- + sameht = .true. +c + do kkk=iob,iob+knt-1 + if(nint(ht_ft(indx(kkk))/100.).ne. + $ nint(ht_ft(ii)/100.)) + $ sameht = .false. + enddo +c + if(l_print) + $ write(io8,*) 'Altitudes equal?',sameht +c +c Use lat/lon to order obs if altitudes equal +c ------------------------------------------- + if(sameht.and.knt.eq.2) then +c + alat_dif = abs(alat(iiafter) - alat(iibefore)) + alon_dif = abs(alon(iiafter) - alon(iibefore)) + iii = indx(iob+1) + iiim1 = indx(iob) +c + if(l_print) then + write(io8,*) 'Level pair at ii = ',ii + write(io8,*) 'alat_dif = ',alat_dif + write(io8,*) 'alon_dif = ',alon_dif + write(io8,*) 'iii,iiim1 = ',iii,iiim1 + endif +c + if(alat_dif.gt.alon_dif) then + if((alat(iibefore).gt.alat(iiafter).and. + $ alat(iiim1).lt.alat(iii)).or. + $ (alat(iibefore).le.alat(iiafter).and. + $ alat(iiim1).gt.alat(iii))) then +c + if(l_print) then + write(io8,*) 'Reversing pair of obs-1-',iii + write(io8,*) 'lats = ',alat(iiim1),alat(iii) + endif +c + indx(iob) = iii + indx(iob+1) = iiim1 + endif +c + else + if((alon(iibefore).gt.alon(iiafter).and. + $ alon(iiim1).lt.alon(iii)).or. + $ (alon(iibefore).le.alon(iiafter).and. + $ alon(iiim1).gt.alon(iii))) then +c + if(l_print) then + write(io8,*) 'Reversing pair of obs-2-',iii + write(io8,*) 'lons = ',alon(iiim1),alon(iii) + endif +c + indx(iob) = iii + indx(iob+1) = iiim1 + endif + endif +c +c Descent found +c ------------- + elseif(iht0.gt.iht1) then +c + if(l_print) + $ write(io8,*) 'Reversing descent at report',ii +c +c Re-order descending portions of flights with positive heights +c ------------------------------------------------------------- + do nn = iob,ilast + nback = ilast - nn + iob + isave(nn) = indx(nback) + enddo +c + indx(iob:ilast) = isave(iob:ilast) +c +c Ascent found +c ------------ + elseif(iht0.lt.iht1) then +c + if(l_print) + $ write(io8,*) 'Ascent found at ii = ',ii +c +c Reorder portions of flight with negative heights +c ------------------------------------------------ + if(kneg.eq.2.and.ht_ft(ii).lt.0.and. + $ ht_ft(ii).ne.ht_ft(iip1)) then +c +cc 12/01 if(l_print) +cc 12/01 $ write(io8,*) 'Reversing neg alts--ii=',ii, +c +cc 12/01 + ht_ft(ii),ht_ft(iip1) +c +cc 12/01 iiim1 = indx(iob) +cc 12/01 indx(iob) = indx(iob+1) +cc 12/01 indx(iob+1) = iiim1 +c + endif +c +c Level flight found +c ------------------ + elseif(iht0.eq.iht1) then +c sameht = .true. +c + if(l_print) + $ write(io8,*) 'Level flight at ii = ',ii +c +c Slight descent found--reorder +c ----------------------------- +c if(knt.eq.2.and. + if( + $ nint(ht_ft(indx(iob))).gt. + $ nint(ht_ft(iilast))) then +c +c if(l_print) then +c write(io8,*) 'Reordering slight descent--',iii +c write(io8,*) 'alt= ',ht_ft(indx(iob)), +c $ ht_ft(indx(iob+1)) +c endif +cc +c iii = indx(iob+1) +c iiim1 = indx(iob) +c indx(iob) = iii +c indx(iob+1) = iiim1 +c + if(l_print) + $ write(io8,*) 'Reversing descent at report',ii +c +c Re-order descending portions of flights with positive heights +c ------------------------------------------------------------- + do nn = iob,ilast + nback = ilast - nn + iob + isave(nn) = indx(nback) + enddo +c + indx(iob:ilast) = isave(iob:ilast) +c +c Ordering unknown +c ---------------- + else +c +c Try using lat/lon to order obs +c ------------------------------ + if(knt.eq.2) then +c + alat_dif = abs(alat(iiafter) - alat(iibefore)) + alon_dif = abs(alon(iiafter) - alon(iibefore)) + iii = indx(iob+1) + iiim1 = indx(iob) +c + if(l_print) then + write(io8,*) 'Unknown ordering at ii = ',ii + write(io8,*) 'alat_dif = ',alat_dif + write(io8,*) 'alon_dif = ',alon_dif + write(io8,*) 'iii,iiim1 = ',iii,iiim1 + endif +c + if(alat_dif.gt.alon_dif) then + if((alat(iibefore).gt.alat(iiafter).and. + $ alat(iiim1).lt.alat(iii)).or. + $ (alat(iibefore).le.alat(iiafter).and. + $ alat(iiim1).gt.alat(iii))) then +c + if(l_print) then + write(io8,*) 'Reversing unknown order-1-' + $, iii + write(io8,*)'lats= ',alat(iiim1),alat(iii) + endif +c + indx(iob) = iii + indx(iob+1) = iiim1 + endif +c + else + if((alon(iibefore).gt.alon(iiafter).and. + $ alon(iiim1).lt.alon(iii)).or. + $ (alon(iibefore).le.alon(iiafter).and. + $ alon(iiim1).gt.alon(iii))) then +c + if(l_print) then + write(io8,*) 'Reversing unknown order-2-' + $, iii + write(io8,*)'lons =',alon(iiim1),alon(iii) + endif +c + indx(iob) = iii + indx(iob+1) = iiim1 + endif + endif +c + else + write(io8,*) 'Ordering unknown--ii = ',ii + write(io8,*) 'Flight # = ',c_acftid(ii) +c + do kkk=iob-1,iob+knt + write(io8,*) 'ht_ft(',indx(kkk),') = ' + $ ,ht_ft(indx(kkk)) + $ ,' idt = ',idt(indx(kkk)) + enddo + endif + endif + endif +c +c +c Time differences too large for comparison +c ----------------------------------------- + elseif(l_print) then + write(io8,*)'Time diffs too large for comparison!' + write(io8,*)'idt_dif1=',idt_dif1,' iibefore=',iibefore + write(io8,*)'idt_dif2=',idt_dif2,' iiafter =',iiafter + endif +c + iob = ilast + 1 +c + else + iob = iob + 1 + endif +c + else + iob = iob + 1 + endif +c + enddo + endif + enddo +c + return + end +c +c ################################################################### +c subroutine ordchek_qc +c ################################################################### +c + subroutine ordchek_qc(numreps,max_reps,indx,csort,imiss,amiss + $, idt_near,idt_updn,htdif_same,c_acftreg,c_acftid,cidmiss + $, c_qc,alat,alon,pres,ht_ft,t_prcn,ob_t,ob_q,ob_dir + $, ob_spd,xiv_t,xiv_q,xiv_d,xiv_s + $, idt,itype,ichk_t,ichk_q,ichk_d,ichk_s + $, kreg,creg_reg,nwind_reg + $, kflight,maxflt,nobs_flt,ntot_flt,iobs_flt,kbadtot + $, io8,io36,l_operational,l_init) +c +c Check ordering of flights +c +c Modified by P.M. Pauley (3/7/00) +c Problems were found with the great circle distance calculation. +c The calculation formula was changed from the law of cosines +c to the haversine formula, the latter of which works at the small +c distances that gave the former problems. An effort was also made +c to compute the course direction explicitly, since the method used +c was to compute the north-south and east-west distances and use +c them to compute the direction using a plane-geometry approximation. +c However, the formulas for course direction that were tried had +c more computational problems than the plane-geometry approximation, +c so they were abandoned. However, rather than computing the +c airspeed using the north-south and east-west components of the +c groundspeed and wind vectors, a method (again based on plane +c geometry) to compute the magnitude of the airspeed vector as +c the third side of the wind triangle was derived. This method +c yields an airspeed that is more consistent with the computed +c groundspeed and the wind than the previous method, which could +c lead to unrealistic differences between the groundspeed and +c airspeed magnitudes. These methods are not rigorously exact, +c but were deemed sufficiently accurate for the purposes at hand. +c +c Modified by P.M. Pauley 9/21/02 +c As data resolution has increased, some aspects of the track (such +c as deciding a point is going backwards) have become less meaningful. +c Changes were made to reduce the number of false positives. +c + implicit none +c +c Declaration statements +c ---------------------- + integer max_reps ! maximum number of reports +c + character*11 c_qc(max_reps) ! internal qc flags +c +c Data arrays +c ----------- + integer numreps ! actual number of reports + integer itype(max_reps) ! type of aircraft data + integer idt(max_reps) ! time in seconds to analysis time + character*8 c_acftreg(max_reps) ! aircraft registration (tail) number + character*9 c_acftid(max_reps) ! aircraft flight number + real*8 alat(max_reps) ! latitude + $, alon(max_reps) ! longitude + real pres(max_reps) ! pressure + $, ht_ft(max_reps) ! height in feet + real t_prcn(max_reps) ! temperature precision + real ob_t(max_reps) ! temperature + $, ob_q(max_reps) ! specific humidity + $, ob_dir(max_reps) ! wind direction + $, ob_spd(max_reps) ! wind speed + real xiv_t(max_reps) ! temperature innovation (ob - bk) + $, xiv_q(max_reps) ! specific humidity innovation (ob - bk) + $, xiv_d(max_reps) ! wind direction innovation (ob - bk) + $, xiv_s(max_reps) ! wind speed innovation (ob - bk) + integer ichk_t(max_reps) ! NRL QC flag for temperature ob + $, ichk_q(max_reps) ! NRL QC flag for specific humidity ob + $, ichk_d(max_reps) ! NRL QC flag for wind direction ob + $, ichk_s(max_reps) ! NRL QC flag for wind speed ob + character*25 csort(max_reps) ! sort variable +c +c Pointers +c -------- + integer indx(max_reps) ! pointer index for good reports +c +c Functions +c --------- + character*16 c_insty_ob ! function to convert integer instrument + ! type to character instrument type + integer insty_ob_fun ! function to convert character + ! instrument type to integer + real gcirc_qc ! function to compute great circle distances +c +c Flight statistics +c ----------------- + integer maxflt ! max number of flights allowed + integer nobs_flt(maxflt) ! number of reports per flight + $, ntot_flt(maxflt) ! total number of reports per flight + $, iobs_flt(maxflt) ! index for first report in each flight + $, kflight ! number of flights in dataset + integer istart ! index for 1st rep in current flight + $, iistart ! index from pointer array for istart + $, iend ! index for last rep in current flight + $, iiend ! index from pointer array for iend + $, iifirst ! index from pointer array for beginning of first flight segment + $, jjstart ! index for start of flight segment + $, iobfirst ! index for beginning of first flight segment + $, iilast ! index from pointer array for end of first flight segment + $, ioblast ! index for end of first flight segment +c +c Tail number statistics +c ---------------------- + integer kreg ! actual number of tail#s in dataset + character*8 creg_reg(maxflt) ! tail numbers + integer nwind_reg(maxflt,5) ! number of reports w. rejected winds +c +c Counters +c -------- + integer nord_dup(5) ! number of previously undetected near duplicates + $, nord_stk(5) ! number of reports with stuck times + $, nord_time(5) ! number of reports with inconsistent times + $, nord_2nd(5) ! number of reports with in second flights + $, nord_near(5) ! number of reports rejected as closer to last rejected point + $, nord_aspd(5) ! number of reports with excessive airspeed + $, nord_lone(5) ! number of reports rejected as isolated off-track points + $, nord_dble(5) ! number of reports rejected when track doubles back on itself + $, nord_turn(5) ! number of reports rejected when track makes too large a turn + $, nord_alt(5) ! number of reports with inconsistent altitudes + $, nord_wind(5) ! number of reports with anomalous windspeeds + integer kbad(5) ! counter for number of bad reports + $, kbadtot ! counter for total number of bad reports +ccccdak integer nrep_Ac ! number of acars reports considered + integer nrep_Ac ! number of tamdar reports considered + $, nrep_Md ! number of mdcrs reports considered + $, nrep_Ma ! number of manual airep reports considered + $, nrep_Ar ! number of airep reports considered + $, nrep_Am ! number of amdar reports considered +ccccdak integer nord_Ac ! number of acars reports rejected + integer nord_Ac ! number of tamdar reports rejected + $, nord_Md ! number of mdcrs reports rejected + $, nord_Ma ! number of manual airep reports rejected + $, nord_Ar ! number of airep reports rejected + $, nord_Am ! number of amdar reports rejected +c +c Instrument types +c ---------------- +ccccdak integer i_acars ! instrument type for acars + integer i_acars ! instrument type for tamdar +ccccdak $, i_acars_lvl ! instrument type for acars--level flt + $, i_acars_lvl ! instrument type for tamdar--level flt +ccccdak $, i_acars_asc ! instrument type for acars--ascent + $, i_acars_asc ! instrument type for tamdar--ascent +ccccdsk $, i_acars_des ! instrument type for acars--descent + $, i_acars_des ! instrument type for tamdar--descent + $, i_mdcrs ! instrument type for mdcrs + $, i_mdcrs_lvl ! instrument type for mdcrs--level flt + $, i_mdcrs_asc ! instrument type for mdcrs--ascent + $, i_mdcrs_des ! instrument type for mdcrs--descent + $, i_man_airep ! instrument type for manual aireps + $, i_man_Yairep ! instrument type for manual aireps (YRXX) + $, i_airep ! instrument type for airep + $, i_airep_lvl ! instrument type for airep--level flt + $, i_airep_asc ! instrument type for airep--ascent + $, i_airep_des ! instrument type for airep--descent + $, i_amdar ! instrument type for amdar + $, i_amdar_lvl ! instrument type for amdar--level flt + $, i_amdar_asc ! instrument type for amdar--ascent + $, i_amdar_des ! instrument type for amdar--descent +c +c Other variables +c --------------- + integer io8 ! i/o unit number for log file + integer io36 ! i/o unit number for ordering check +c + real amiss ! real missing value flag + real d2r ! conversion factor for degrees to radians +c + integer iob,job,nob,kk ! do loop indices + $, ii,jj,nn ! index pointing to current report + $, mm ! index pointing to current tail number + $, iim1,nnm1 ! index pointing to previous report + $, iim2 ! index pointing to 2nd report previous + $, iim3 ! index pointing to 3rd report previous + $, iip1,jjp1,nnp1 ! index pointing to following report + $, iip2 ! index pointing to 2nd report following + $, iip3 ! index pointing to 3rd report following + $, iobp1 ! index for following report + $, iobp2 ! index for 2nd report following report + $, knt0 ! counter saved from definition of ii index + $, knt1 ! counter used to define iim1 index + $, knt2 ! counter used to define iim2 index + $, knt3 ! counter used to define iip1 index + $, knt4 ! counter used to define iip2 index + $, knt5 ! counter used to define iim3 index + $, knt6 ! counter used to define iip3 index + $, knt_iob ! counter for number of times iob repeated + $, iob_sav ! previous value of iob + $, knt_iip1_bad ! number of times iip1 report is rejected as bad manuever + $, job_alat_min ! index for minimum latitude + $, job_alat_max ! index for maximum latitude + $, job_alon_min ! index for minimum longitude + $, job_alon_max ! index for maximum longitude + $, jj_alat_min ! pointer index for minimum latitude + $, jj_alat_max ! pointer index for maximum latitude + $, jj_alon_min ! pointer index for minimum longitude + $, jj_alon_max ! pointer index for maximum longitude + integer imiss ! integer missing value flag + integer idt_near ! time difference between "near" neighbors + integer idt_updn ! time difference to check ascents/descents + integer idt0 ! time for report ii + $, idtm1 ! time for report iim1 + $, idtm2 ! time for report iim2 + $, idtm3 ! time for report iim3 + $, idtp1 ! time for report iip1 + $, idtp2 ! time for report iip2 + $, idtp3 ! time for report iip3 + $, idt_start ! time for first report of flight + $, idt_end ! time for last report of flight + $, idt_last_bad ! time for last bad report + integer idt_dif0 ! time difference (current - previous report) + $, idt_difm1 ! time difference (two previous reports) + $, idt_difm2 ! time difference (two reports before those) + $, idt_difp1 ! time difference (following - current report) + $, idt_difp2 ! time difference (two following reports) + $, idt_difp3 ! time difference (two reports after those) + $, idt_dif_wo0 ! time difference (iim1 and iip1 points) + $, idt_dif_wop1 ! time difference (ii and iip2 points) + $, idt_dif_wop2 ! time difference (iip1 and iip3 points) + $, idt_dif_bad0 ! time difference (ii and last_bad points) + $, idt_dif_badp1 ! time difference (iip1 and last_bad points) + $, idt_dif_track ! time difference (first and last points) +c + integer ktype ! ob type + $, itype0 ! ob type for ii report + $, itypem1 ! ob type for iim1 report + $, itypep1 ! ob type for iip1 report + $, itypep2 ! ob type for iip2 report +c + real htdif_same ! height difference considered negligible + real*8 alat_dif ! latitude difference (current-previous report) + $, alon_dif ! longitude difference (current-previous report) + $, alat_min ! minimum latitude for flight + $, alat_max ! maximum latitude for flight + $, alon_min ! minimum longitude for flight + $, alon_max ! maximum longitude for flight + $, alat0 ! latitude in current report + $, alatm1 ! latitude in previous report + $, alatm2 ! latitude at 2nd previous report + $, alatm3 ! latitude at 3rd previous report + $, alatp1 ! latitude at following report + $, alatp2 ! latitude at 2nd following report + $, alatp3 ! latitude at 3rd following report + $, alon0 ! longitude in current report + $, alonm1 ! longitude in previous report + $, alonm2 ! longitude at 2nd previous report + $, alonm3 ! longitude at 3rd previous report + $, alonp1 ! longitude at following report + $, alonp2 ! longitude at 2nd following report + $, alonp3 ! longitude at 3rd following report + real ht_dif0 ! height difference (current-previous report) + $, ht_difm1 ! height difference (two previous reports) + $, ht_difm2 ! height difference (two reports before those) + $, ht_difp1 ! height difference (following-current report) + $, ht_difp2 ! height difference (two following reports) + $, ht_difp3 ! height difference (two reports after those) + $, ht_dif_wo0 ! height difference between iim1 and iip1 reports + $, ht_dif_wop1 ! height difference between ii and iip2 reports + $, ht_dif_wop2 ! height difference between iip1 and iip3 reports + $, ht_dif_bad0 ! height difference between ii and last_bad reports + $, ht_dif_badp1 ! height difference between iip1 and last_bad reports + $, ht_dif_track ! height difference between first and last reports + $, dif_t ! temperature difference (current-previous report) + $, dif_dir ! direction difference (current-previous report) + $, dif_spd ! speed difference (current-previous report) + $, ht_ft0 ! height in current report + $, ht_ftm1 ! height in previous report + $, ht_ftm2 ! height at 2nd previous report + $, ht_ftm3 ! height at 3rd previous report + $, ht_ftp1 ! height at following report + $, ht_ftp2 ! height at 2nd following report + $, ht_ftp3 ! height at 3rd following report +c +c real uwind0 ! u component for wind at ii point +c $, vwind0 ! v component for wind at ii point +c $, uwindm1 ! u component for wind at iim1 point +c $, vwindm1 ! v component for wind at iim1 point +c $, uwindm2 ! u component for wind at iim2 point +c $, vwindm2 ! v component for wind at iim2 point +c $, uwindm3 ! u component for wind at iim3 point +c $, vwindm3 ! v component for wind at iim3 point +c $, uwindp1 ! u component for wind at iip1 point +c $, vwindp1 ! v component for wind at iip1 point +c $, uwindp2 ! u component for wind at iip2 point +c $, vwindp2 ! v component for wind at iip2 point +c $, uwindp3 ! u component for wind at iip3 point +c $, vwindp3 ! v component for wind at iip3 point +c $, uwind_start ! u component for wind at first point +c $, vwind_start ! v component for wind at first point +c $, uwind_end ! u component for wind at last point +c $, vwind_end ! v component for wind at last point +c $, uwind_last ! u component for wind at last bad point +c $, vwind_last ! v component for wind at last bad point + real wspd_last ! wind speed at last bad point + $, wdir_last ! wind direction at last bad point + real distm1 ! distance between iim2 and iim1 points + $, distm2 ! distance between iim2 and iim3 points + $, dist0 ! distance between iim1 and ii points + $, distp1 ! distance between iip1 and ii points + $, distp2 ! distance between iip2 and iip1 points + $, distp3 ! distance between iip3 and iip2 points + $, dist_wo0 ! distance between iim1 and iip1 points + $, dist_wop1 ! distance between ii and iip2 points + $, dist_wop2 ! distance between iip1 and iip3 points + $, dist_bad0 ! distance between ii and last_bad points + $, dist_badp1 ! distance between ii and last_bad points + $, dist_track ! distance between first and last points + $, dist_2ndflt ! distance between first and last points of potential 2nd flight + $, udistm1 ! E-W distance between iim2 and iim1 points + $, vdistm1 ! N-S distance between iim2 and iim1 points + $, udistm2 ! E-W distance between iim3 and iim2 points + $, vdistm2 ! N-S distance between iim3 and iim2 points + $, udist0 ! E-W distance between ii and iim1 points + $, vdist0 ! N-S distance between ii and iim1 points + $, udistp1 ! E-W distance between ii and iip1 points + $, vdistp1 ! N-S distance between ii and iip1 points + $, udistp2 ! E-W distance between iip1 and iip2 points + $, vdistp2 ! N-S distance between iip1 and iip2 points + $, udistp3 ! E-W distance between iip2 and iip3 points + $, vdistp3 ! N-S distance between iip2 and iip3 points + $, udist_wo0 ! E-W distance between iim1 and iip1 points + $, vdist_wo0 ! N-S distance between iim1 and iip1 points + $, udist_wop1 ! E-W distance between ii and iip2 points + $, vdist_wop1 ! N-S distance between ii and iip2 points + $, udist_wop2 ! E-W distance between iip1 and iip3 points + $, vdist_wop2 ! N-S distance between iip1 and iip3 points + $, udist_bad0 ! E-W distance between ii and last_bad points + $, vdist_bad0 ! N-S distance between ii and last_bad points + $, udist_badp1 ! E-W distance between iip1 and last_bad points + $, vdist_badp1 ! N-S distance between iip1 and last_bad points + $, udist_track ! E-W distance between first and last points + $, vdist_track ! N-S distance between first and last points + real upspdm1 ! u component of platform speed (iim2 to iim1 points) + $, vpspdm1 ! v component of platform speed (iim2 to iim1 points) + $, upspdm2 ! u component of platform speed (iim3 to iim2 points) + $, vpspdm2 ! v component of platform speed (iim3 to iim2 points) + $, upspd0 ! u component of platform speed (iim1 to ii points) + $, vpspd0 ! v component of platform speed (iim1 to ii points) + $, upspdp1 ! u component of platform speed (ii to iip1 points) + $, vpspdp1 ! v component of platform speed (ii to iip1 points) + $, upspdp2 ! u component of platform speed (iip1 to iip2 points) + $, vpspdp2 ! v component of platform speed (iip1 to iip2 points) + $, upspdp3 ! u component of platform speed (iip2 to iip3 points) + $, vpspdp3 ! v component of platform speed (iip2 to iip3 points) + $, upspd_wo0 ! u component of platform speed (iim1 to iip1 points) + $, vpspd_wo0 ! v component of platform speed (iim1 to iip1 points) + $, upspd_wop1 ! u component of platform speed (ii to iip2 points) + $, vpspd_wop1 ! v component of platform speed (ii to iip2 points) + $, upspd_wop2 ! u component of platform speed (iip1 to iip3 points) + $, vpspd_wop2 ! v component of platform speed (iip1 to iip3 points) + $, upspd_bad0 ! u component of platform speed (ii to last_bad points) + $, vpspd_bad0 ! v component of platform speed (ii to last_bad points) + $, upspd_badp1 ! u component of platform speed (iip1 to last_bad points) + $, vpspd_badp1 ! v component of platform speed (iip1 to last_bad points) + $, upspd_track ! u component of platform speed (first and last points) + $, vpspd_track ! v component of platform speed (first and last points) + $, pdirm1 ! platform direction of aircraft (iim2 to iim1 points) + $, pdirm2 ! platform direction of aircraft (iim3 to iim2 points) + $, pdir0 ! platform direction of aircraft (iim1 to ii points) + $, pdirp1 ! platform direction of aircraft (iip1 to ii points) + $, pdirp2 ! platform direction of aircraft (iip1 to iip2 points) + $, pdirp3 ! platform direction of aircraft (iip2 to iip3 points) + $, pdir_wo0 ! platform direction of aircraft (iim1 to iip1 points) + $, pdir_wop1 ! platform direction of aircraft (ii to iip2 points) + $, pdir_wop2 ! platform direction of aircraft (iip1 to iip3 points) + $, pdir_bad0 ! platform direction of aircraft (ii to last_bad points) + $, pdir_badp1 ! platform direction of aircraft (iip1 to last_bad points) + $, pdir_track ! platform direction of aircraft (first and last points) + $, pspdm1 ! platform speed of aircraft (iim2 to iim1 points) + $, pspdm2 ! platform speed of aircraft (iim3 to iim2 points) + $, pspd0 ! platform speed of aircraft (iip1 to ii points) + $, pspdp1 ! platform speed of aircraft (iip1 to ii points) + $, pspdp2 ! platform speed of aircraft (iip2 to iip1 points) + $, pspdp3 ! platform speed of aircraft (iip3 to iip2 points) + $, pspd_wo0 ! platform speed of aircraft (iip1 to iim1 points) + $, pspd_wop1 ! platform speed of aircraft (iip2 to ii points) + $, pspd_wop2 ! platform speed of aircraft (iip3 to iip1 points) + $, pspd_bad0 ! platform speed of aircraft (ii to last_bad points) + $, pspd_badp1 ! platform speed of aircraft (iip1 to last_bad points) + $, pspd_track ! platform speed of aircraft (first and last points) + real spd_thresh ! threshold speed of aircraft + $, spd_man_thresh ! threshold speed of aircraft for manual aireps +c real uairspdm1 ! u component of airspeed (iim2 to iim1 points) +c $, vairspdm1 ! v component of airspeed (iim2 to iim1 points) +c $, uairspdm2 ! u component of airspeed (iim3 to iim2 points) +c $, vairspdm2 ! v component of airspeed (iim3 to iim2 points) +c $, uairspd0 ! u component of airspeed (iim1 to ii points) +c $, vairspd0 ! v component of airspeed (iim1 to ii points) +c $, uairspdp1 ! u component of airspeed (ii to iip1 points) +c $, vairspdp1 ! v component of airspeed (ii to iip1 points) +c $, uairspdp2 ! u component of airspeed (iip1 to iip2 points) +c $, vairspdp2 ! v component of airspeed (iip1 to iip2 points) +c $, uairspdp3 ! u component of airspeed (iip2 to iip3 points) +c $, vairspdp3 ! v component of airspeed (iip2 to iip3 points) +c $, uairspd_wo0 ! u component of airspeed (iim1 to iip1 points) +c $, vairspd_wo0 ! v component of airspeed (iim1 to iip1 points) +c $, uairspd_wop1 ! u component of airspeed (ii to iip2 points) +c $, vairspd_wop1 ! v component of airspeed (ii to iip2 points) +c $, uairspd_wop2 ! u component of airspeed (iip1 to iip3 points) +c $, vairspd_wop2 ! v component of airspeed (iip1 to iip3 points) +c $, uairspd_bad0 ! u component of airspeed (ii to last_bad points) +c $, vairspd_bad0 ! v component of airspeed (ii to last_bad points) +c $, uairspd_badp1 ! u component of airspeed (iip1 to last_bad points) +c $, vairspd_badp1 ! v component of airspeed (iip1 to last_bad points) +c $, uairspd_track ! u component of airspeed (first and last points) +c $, vairspd_track ! v component of airspeed (first and last points) + real airspdm1 ! airspeed between iim1 and iim2 points +c $, airdirm1 ! airspeed direction between iim1 and iim2 points + $, airspdm2 ! airspeed between iim2 and iim3 points +c $, airdirm2 ! airspeed direction between iim2 and iim3 points + $, airspd0 ! airspeed between ii and iim1 points +c $, airdir0 ! airspeed direction between ii and iim1 points + $, airspdp1 ! airspeed between ii and iip1 points +c $, airdirp1 ! airspeed direction between ii and iip1 points + $, airspdp2 ! airspeed between iip1 and iip2 points +c $, airdirp2 ! airspeed direction between iip1 and iip2 points + $, airspdp3 ! airspeed between iip2 and iip3 points +c $, airdirp3 ! airspeed direction between iip2 and iip3 points + $, airspd_wo0 ! airspeed between iim1 and iip1 points +c $, airdir_wo0 ! airspeed direction between iim1 and iip1 points + $, airspd_wop1 ! airspeed between ii and iip2 points +c $, airdir_wop1 ! airspeed direction between ii and iip2 points + $, airspd_wop2 ! airspeed between iip1 and iip3 points +c $, airdir_wop2 ! airspeed direction between iip1 and iip3 points + $, airspd_bad0 ! airspeed between ii and last_bad points +c $, airdir_bad0 ! airspeed direction between ii and last_bad points + $, airspd_badp1 ! airspeed between iip1 and last_bad points +c $, airdir_badp1 ! airspeed direction between iip1 and last_bad points + $, airspd_track ! airspeed between first and last points +c $, airdir_track ! airspeed direction between first and last points + real vspdm1 ! vertical speed of aircraft (iim1 to iim2 points) + $, vspdm2 ! vertical speed of aircraft (iim2 to iim3 points) + $, vspd0 ! vertical speed of aircraft (ii to iim1 points) + $, vspdp1 ! vertical speed of aircraft (iip1 to ii points) + $, vspdp2 ! vertical speed of aircraft (iip2 to iip1 points) + $, vspdp3 ! vertical speed of aircraft (iip3 to iip2 points) + $, vspd_wo0 ! vertical speed of aircraft (iip1 to iim1 points) + $, vspd_wop1 ! vertical speed of aircraft (iip2 to ii points) + $, vspd_wop2 ! vertical speed of aircraft (iip3 to iip1 points) + $, vspd_bad0 ! vertical speed of aircraft (ii to last_bad points) + $, vspd_badp1 ! vertical speed of aircraft (iip1 to last_bad points) + $, vspd_track ! vertical speed of aircraft (first and last points) + real vspd_thresh ! threshold vertical speed of aircraft + $, vspd_bounce ! threshold vertical speed used in bounce test +c + integer indx_save(200) ! pointer indices for rejected reports + $, ll ! index for indx_save + $, keep ! variable used in saving indices + $, knt_bad ! number of reports in potential second flight + $, last_bad ! pointer index for last rejected report + $, last_bad_m1 ! pointer index for next-to-last rejected report +c + character*8 cidmiss ! missing value flag for flight number +c +c Switches +c -------- + logical l_print ! true for printing reports used in check +c + logical l_retest ! retest track if true +c + logical l_init ! initialize counters if true + $, l_ii_man_airep ! true if ii report is manual airep + $, l_iim1_man_airep ! true if iim1 report is manual airep + $, l_iim2_man_airep ! true if iim2 report is manual airep + $, l_iim3_man_airep ! true if iim3 report is manual airep + $, l_iip1_man_airep ! true if iip1 report is manual airep + $, l_iip2_man_airep ! true if iip2 report is manual airep + $, l_ii_pspd_ok ! true if pspd is ok for point ii + $, l_stuck ! true if stuck clock found + $, l_operational ! true if operational mode used +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c +c Degrees to radians +c ------------------ + d2r = atan(1.0) / 45.0 +c +c Initialize aircraft data types +c ------------------------------ + i_acars = insty_ob_fun('acars') + i_acars_lvl = insty_ob_fun('acars_lvl') + i_acars_asc = insty_ob_fun('acars_asc') + i_acars_des = insty_ob_fun('acars_des') + i_mdcrs = insty_ob_fun('mdcrs') + i_mdcrs_lvl = insty_ob_fun('mdcrs_lvl') + i_mdcrs_asc = insty_ob_fun('mdcrs_asc') + i_mdcrs_des = insty_ob_fun('mdcrs_des') + i_man_airep = insty_ob_fun('man-airep') + i_man_Yairep = insty_ob_fun('man-Yairep') + i_airep = insty_ob_fun('airep') + i_airep_lvl = insty_ob_fun('airep_lvl') + i_airep_asc = insty_ob_fun('airep_asc') + i_airep_des = insty_ob_fun('airep_des') + i_amdar = insty_ob_fun('amdar') + i_amdar_lvl = insty_ob_fun('amdar_lvl') + i_amdar_asc = insty_ob_fun('amdar_asc') + i_amdar_des = insty_ob_fun('amdar_des') +c +c Initialize counters +c ------------------- + if(l_init) then + nord_dup = 0 + nord_stk = 0 + nord_time = 0 + nord_2nd = 0 + nord_near = 0 + nord_aspd = 0 + nord_lone = 0 + nord_dble = 0 + nord_turn = 0 + nord_alt = 0 + nord_wind = 0 + nrep_Ac = 0 + nrep_Md = 0 + nrep_Ma = 0 + nrep_Ar = 0 + nrep_Am = 0 + nord_Ac = 0 + nord_Md = 0 + nord_Ma = 0 + nord_Ar = 0 + nord_Am = 0 + endif +c + nwind_reg = 0 +c +c Begin loop over flights +c ----------------------- + do kk = 1,kflight +c +c Initialize variables +c -------------------- + istart = iobs_flt(kk) + iistart = indx(istart) + iend = iobs_flt(kk) + nobs_flt(kk) - 1 + iiend = indx(iend) +c +c Don't compare reports with missing flight number +c Perform check only for flights with three or more reports +c ----------------------------------------------------------------- + if(c_acftid(iistart)(1:8).ne.cidmiss(1:8).and. + $ nobs_flt(kk).ge.3) then +c +c Determine flight phase of reports +c --------------------------------- + do iob=istart,iend + l_print = .false. +c + ii = indx(iob) +c +c Decide if report is a manual airep +c ---------------------------------- + l_ii_man_airep = .false. + if(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) l_ii_man_airep = .true. +c +c Compute ii-1 index +c if(iob.gt.istart) iim1 = indx(iob-1) +c -------------------------------------- + iim1 = 0 + knt1 = iob - 1 + 10 if(knt1.ge.istart) then + iim1 = indx(knt1) + if(c_qc(iim1)(1:1).eq.'d'.or. + $ c_qc(iim1)(2:2).eq.'I'.or. + $ c_qc(iim1)(2:2).eq.'K'.or. + $ c_qc(iim1)(3:4).eq.'II'.or. + $ c_qc(iim1)(5:5).eq.'I'.or. + $ c_qc(iim1)(5:5).eq.'i') then + knt1 = knt1 - 1 + goto 10 + endif + else + iim1 = 0 + endif +c +c Compute ii-2 index +c if(iob.gt.istart+1) iim2 = indx(iob-2) +c -------------------------------------- + iim2 = 0 + knt2 = knt1 - 1 + 20 if(knt2.ge.istart) then + iim2 = indx(knt2) + if(c_qc(iim2)(1:1).eq.'d'.or. + $ c_qc(iim2)(2:2).eq.'I'.or. + $ c_qc(iim2)(2:2).eq.'K'.or. + $ c_qc(iim2)(3:4).eq.'II'.or. + $ c_qc(iim2)(5:5).eq.'I'.or. + $ c_qc(iim2)(5:5).eq.'i') then + knt2 = knt2 - 1 + goto 20 + endif + else + iim2 = 0 + endif +c +c Compute ii+1 index +c if(iob.lt.iend) iip1 = indx(iob+1) +c ------------------------------------ + iip1 = 0 + knt3 = iob + 1 + 30 if(knt3.le.iend) then + iip1 = indx(knt3) + if(c_qc(iip1)(1:1).eq.'d'.or. + $ c_qc(iip1)(2:2).eq.'I'.or. + $ c_qc(iip1)(2:2).eq.'K'.or. + $ c_qc(iip1)(3:4).eq.'II'.or. + $ c_qc(iip1)(5:5).eq.'I'.or. + $ c_qc(iip1)(5:5).eq.'i') then + knt3 = knt3 + 1 + goto 30 + endif + else + iip1 = 0 + endif +c +c Compute ii+2 index +c if(iob.lt.iend-1) iip2 = indx(iob+2) +c ------------------------------------ + iip2 = 0 + knt4 = knt3 + 1 + 40 if(knt4.le.iend) then + iip2 = indx(knt4) + if(c_qc(iip2)(1:1).eq.'d'.or. + $ c_qc(iip2)(2:2).eq.'I'.or. + $ c_qc(iip2)(2:2).eq.'K'.or. + $ c_qc(iip2)(3:4).eq.'II'.or. + $ c_qc(iip2)(5:5).eq.'I'.or. + $ c_qc(iip2)(5:5).eq.'i') then + knt4 = knt4 + 1 + goto 40 + endif + else + iip2 = 0 + endif +c +c Compute time and height differences +c ----------------------------------- + alat0 = alat(ii) + alon0 = alon(ii) + ht_ft0 = ht_ft(ii) +c + if(iim1.ne.0) then + idt_dif0 = abs(idt(ii) - idt(iim1)) + ht_dif0 = abs(ht_ft(ii) - ht_ft(iim1)) + ht_ftm1 = ht_ft(iim1) + else + idt_dif0 = imiss + ht_dif0 = amiss + ht_ftm1 = amiss + endif +c + if(iim2.ne.0) then + ht_ftm2 = ht_ft(iim2) + else + ht_ftm2 = amiss + endif +c + if(iim1.ne.0.and.iim2.ne.0) then + idt_difm1 = abs(idt(iim1) - idt(iim2)) + ht_difm1 = abs(ht_ft(iim1) - ht_ft(iim2)) + else + idt_difm1 = imiss + ht_difm1 = amiss + endif +c + if(iip1.ne.0) then + idt_difp1 = abs(idt(iip1) - idt(ii)) + ht_difp1 = abs(ht_ft(iip1) - ht_ft(ii)) + ht_ftp1 = ht_ft(iip1) + else + idt_difp1 = imiss + ht_difp1 = amiss + ht_ftp1 = amiss + endif +c + if(iip2.ne.0) then + ht_ftp2 = ht_ft(iip2) + else + ht_ftp2 = amiss + endif +c + if(iip2.ne.0.and.iip1.ne.0) then + idt_difp2 = abs(idt(iip2) - idt(iip1)) + ht_difp2 = abs(ht_ft(iip2) - ht_ft(iip1)) + else + idt_difp2 = imiss + ht_difp2 = amiss + endif +c +c Look for high resolution level legs +c ----------------------------------- +c +c Use iim1, ii, iip1 points +c ----------------------------------- + if(iim1.ne.0.and.iip1.ne.0.and. + $ idt_dif0 .ne.imiss.and.idt_dif0 .le.idt_updn.and. + $ idt_difp1.ne.imiss.and.idt_difp1.le.idt_updn.and. + $ ht_dif0 .lt.htdif_same+0.5.and. + $ ht_difp1.lt.htdif_same+0.5) then +c + c_qc(ii)(11:11) = 'L' +c +c Use iim2, iim1, ii points +c -------------------------- + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ idt_difm1.ne.imiss.and.idt_difm1.le.idt_updn.and. + $ idt_dif0 .ne.imiss.and.idt_dif0 .le.idt_updn.and. + $ ht_difm1.lt.htdif_same+0.5.and. + $ ht_dif0 .lt.htdif_same+0.5) then +c + c_qc(ii)(11:11) = 'L' +c + if(iip1.ne.0.and.idt_difp1.lt.idt_updn.and. + $ ht_difp1.gt.htdif_same+0.5.and. + $ ht_difp1.lt.5000.) then + if(ht_ftp1.gt.ht_ft0) + $ c_qc(ii)(11:11) = 'A' ! Ascending + if(ht_ftp1.lt.ht_ft0) + $ c_qc(ii)(11:11) = 'D' ! Descending + endif +c +c Use ii, iip1, iip2 points +c -------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ idt_difp1.ne.imiss.and.idt_difp1.le.idt_updn.and. + $ idt_difp2.ne.imiss.and.idt_difp2.le.idt_updn.and. + $ ht_difp1.lt.htdif_same+0.5.and. + $ ht_difp2.lt.htdif_same+0.5) then +c + c_qc(ii)(11:11) = 'L' +c + if(iim1.ne.0.and.idt_dif0.lt.idt_updn.and. + $ ht_dif0.gt.htdif_same+0.5.and. + $ ht_dif0.lt.5000.) then + if(ht_ftm1.gt.ht_ft0) + $ c_qc(ii)(11:11) = 'D' ! Descending + if(ht_ftm1.lt.ht_ft0) + $ c_qc(ii)(11:11) = 'A' ! Ascending + endif +c +c Look for high resolution ascents and descents +c --------------------------------------------- +c +c Use iim1, ii, iip1 points +c ----------------------------------- + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ idt_dif0.ne.imiss.and.idt_dif0.le.idt_updn.and. + $ idt_difp1.ne.imiss.and.idt_difp1.le.idt_updn.and. + $ ht_ftm1.lt.ht_ft0 .and. + $ ht_ft0 .lt.ht_ftp1) then +c + c_qc(ii)(11:11) = 'A' +c + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ idt_dif0.ne.imiss.and.idt_dif0.le.idt_updn.and. + $ idt_difp1.ne.imiss.and.idt_difp1.le.idt_updn.and. + $ ht_ftm1.gt.ht_ft0 .and. + $ ht_ft0 .gt.ht_ftp1) then +c + c_qc(ii)(11:11) = 'D' +c +c Use iim2, iim1, ii points +c ----------------------------------- + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ idt_difm1.ne.imiss.and.idt_difm1.le.idt_updn.and. + $ idt_dif0.ne.imiss.and.idt_dif0.le.idt_updn.and. + $ ht_ftm2.lt.ht_ftm1.and. + $ ht_ftm1.lt.ht_ft0) then +c + c_qc(ii)(11:11) = 'A' +c + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ idt_difm1.ne.imiss.and.idt_difm1.le.idt_updn.and. + $ idt_dif0.ne.imiss.and.idt_dif0.le.idt_updn.and. + $ ht_ftm2.gt.ht_ftm1.and. + $ ht_ftm1.gt.ht_ft0 ) then +c + c_qc(ii)(11:11) = 'D' +c +c Use ii, iip1, iip2 points +c ----------------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ idt_difp1.ne.imiss.and.idt_difp1.le.idt_updn.and. + $ idt_difp2.ne.imiss.and.idt_difp2.le.idt_updn.and. + $ ht_ft0 .lt.ht_ftp1.and. + $ ht_ftp1.lt.ht_ftp2) then +c + c_qc(ii)(11:11) = 'A' +c + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ idt_difp1.ne.imiss.and.idt_difp1.le.idt_updn.and. + $ idt_difp2.ne.imiss.and.idt_difp2.le.idt_updn.and. + $ ht_ft0.gt.ht_ftp1.and. + $ ht_ftp1.gt.ht_ftp2) then +c + c_qc(ii)(11:11) = 'D' +c +c Look for other level legs +c ------------------------- +c +c Use iim1, ii, iip1 points +c ------------------------- + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ idt_dif0.ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.idt_dif0 .le.idt_near*3)).and. + $ idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp1.le.idt_near*3)).and. + $ ht_dif0.lt.htdif_same*1.5+0.5.and. + $ ht_difp1.lt.htdif_same*1.5+0.5) then +c + c_qc(ii)(11:11) = 'L' +c +c Use iim2, iim1, ii points +c ------------------------- + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ idt_difm1.ne.imiss.and. + $ (idt_difm1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difm1.le.idt_near*3)).and. + $ idt_dif0 .ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.idt_dif0 .le.idt_near*3)).and. + $ ht_difm1.lt.htdif_same*1.5+0.5.and. + $ ht_dif0 .lt.htdif_same*1.5+0.5) then +c + c_qc(ii)(11:11) = 'L' +c + if(iip1.ne.0.and.idt_difp1.lt.idt_updn.and. + $ ht_difp1.gt.htdif_same+0.5.and. + $ ht_difp1.lt.5000.) then + if(ht_ftp1.gt.ht_ft0) + $ c_qc(ii)(11:11) = 'A' ! Ascending + if(ht_ftp1.lt.ht_ft0) + $ c_qc(ii)(11:11) = 'D' ! Descending + endif +c +c Use ii, iip1, iip2 points +c ------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp1.le.idt_near*3)).and. + $ idt_difp2.ne.imiss.and. + $ (idt_difp2.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp2.le.idt_near*3)).and. + $ ht_difp1.lt.htdif_same*1.5+0.5.and. + $ ht_difp2.lt.htdif_same*1.5+0.5) then +c + c_qc(ii)(11:11) = 'L' +c + if(iim1.ne.0.and.idt_dif0.lt.idt_updn.and. + $ ht_dif0.gt.htdif_same+0.5.and. + $ ht_dif0.lt.5000.) then + if(ht_ftm1.gt.ht_ft0) + $ c_qc(ii)(11:11) = 'D' ! Descending + if(ht_ftm1.lt.ht_ft0) + $ c_qc(ii)(11:11) = 'A' ! Ascending + endif +c +c Look for other ascents and descents +c ----------------------------------- +c +c Use iim1, ii, iip1 points +c -------------------------------- + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ idt_dif0.ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.idt_dif0 .le.idt_near*2)).and. + $ idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp1.le.idt_near*2)).and. + $ ht_ftm1.lt.ht_ft0 .and. + $ ht_ft0 .lt.ht_ftp1) then +c + c_qc(ii)(11:11) = 'a' +c + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ idt_dif0.ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.idt_dif0 .le.idt_near*2)).and. + $ idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp1.le.idt_near*2)).and. + $ ht_ftm1.gt.ht_ft0 .and. + $ ht_ft0 .gt.ht_ftp1) then +c + c_qc(ii)(11:11) = 'd' +c +c Use iim2, iim1, ii points +c ------------------------- + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ idt_difm1.ne.imiss.and. + $ (idt_difm1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difm1.le.idt_near*2)).and. + $ idt_dif0 .ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.idt_dif0 .le.idt_near*2)).and. + $ ht_ftm2.lt.ht_ftm1.and. + $ ht_ftm1.lt.ht_ft0 ) then +c + c_qc(ii)(11:11) = 'a' +c + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ idt_difm1.ne.imiss.and. + $ (idt_difm1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difm1.le.idt_near*2)).and. + $ idt_dif0 .ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.idt_dif0 .le.idt_near*2)).and. + $ ht_ftm2.gt.ht_ftm1.and. + $ ht_ftm1.gt.ht_ft0 ) then +c + c_qc(ii)(11:11) = 'd' +c +c Use ii, iip1, iip2 points +c -------------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp1.le.idt_near*2)).and. + $ idt_difp2.ne.imiss.and. + $ (idt_difp2.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp2.le.idt_near*2)).and. + $ ht_ft0 .lt.ht_ftp1.and. + $ ht_ftp1.lt.ht_ftp2) then +c + c_qc(ii)(11:11) = 'a' +c + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp1.le.idt_near*2)).and. + $ idt_difp2.ne.imiss.and. + $ (idt_difp2.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp2.le.idt_near*2)).and. + $ ht_ft0 .gt.ht_ftp1.and. + $ ht_ftp1.gt.ht_ftp2) then +c + c_qc(ii)(11:11) = 'd' +c +c Look for 2-point level legs +c --------------------------- +c +c Use iim1, ii, iip1 points +c ------------------------- + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ idt_dif0.ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.idt_dif0 .le.idt_near*2)).and. + $ idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp1.le.idt_near*2)).and. + $ ht_dif0.lt.htdif_same*1.5+0.5) then +c + c_qc(ii)(11:11) = 'L' +c + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ idt_dif0.ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.idt_dif0 .le.idt_near*2)).and. + $ idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp1.le.idt_near*2)).and. + $ ht_difp1.lt.htdif_same*1.5+0.5) then +c + c_qc(ii)(11:11) = 'L' +c +c Use iim2, iim1, ii points +c ------------------------- + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ idt_difm1.ne.imiss.and. + $ (idt_difm1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difm1.le.idt_near*2)).and. + $ idt_dif0 .ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.idt_dif0 .le.idt_near*2)).and. + $ ht_dif0 .lt.htdif_same*1.5+0.5) then +c + c_qc(ii)(11:11) = 'L' +c +c Use ii, iip1, iip2 points +c ------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp1.le.idt_near*2)).and. + $ idt_difp2.ne.imiss.and. + $ (idt_difp2.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp2.le.idt_near*2)).and. + $ ht_difp1.lt.htdif_same*1.5+0.5) then +c + c_qc(ii)(11:11) = 'L' +c +c Look for isolated ascending and descending points +c ------------------------------------------------- +c +c Use iim2, iim1, ii points +c ------------------------- + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ idt_difm1.ne.imiss.and. + $ (idt_difm1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difm1.le.idt_near*2)).and. + $ idt_dif0 .ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.idt_dif0 .le.idt_near*2)).and. + $ ht_difm1.lt.htdif_same*1.5+0.5) then +c + if(ht_ft0.lt.ht_ftm1) then + c_qc(ii)(11:11) = 'd' + elseif(ht_ft0.gt.ht_ftm1) then + c_qc(ii)(11:11) = 'a' + else + write(io8,*) + write(io8,*) 'unidentified isolated point found!' + write(io8,*) 'hts:',ht_ftm2,ht_ftm1,ht_ft0 + c_qc(ii)(11:11) = 'U' + endif +c +c Use ii, iip1, iip2 points +c ------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp1.le.idt_near*2)).and. + $ idt_difp2.ne.imiss.and. + $ (idt_difp2.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp2.le.idt_near*2)).and. + $ ht_difp2.lt.htdif_same*1.5+0.5) then +c + if(ht_ft0.gt.ht_ftp1) then + c_qc(ii)(11:11) = 'd' + elseif(ht_ft0.lt.ht_ftp1) then + c_qc(ii)(11:11) = 'a' + else + write(io8,*) + write(io8,*) 'unidentified isolated point found!' + write(io8,*) 'hts:',ht_ft0,ht_ftp1,ht_ftp2 + c_qc(ii)(11:11) = 'U' + endif +c +c Check if time difference is too great to categorize manAIREPs +c ------------------------------------------------------------- + elseif(l_ii_man_airep.and. + $ ((iim1.ne.0.and.iip1.ne.0.and. + $ ((idt_difm1.gt.idt_near*2.and. + $ idt_difp1.gt.idt_near*2).or. + $ (idt_dif0 .gt.idt_near*2.and. + $ idt_difp1.gt.idt_near*2).or. + $ (idt_dif0 .gt.idt_near*2.and. + $ idt_difp2.gt.idt_near*2))).or. + $ (iim1.eq.0.and.idt_difp1.gt.idt_near*2).or. + $ (iim1.eq.0.and.idt_difp2.gt.idt_near*2).or. + $ (iim2.eq.0.and.iim1.ne.0.and. + $ idt_difp1.gt.idt_near*2).or. + $ (iip1.eq.0.and.idt_dif0 .gt.idt_near*2).or. + $ (iip1.eq.0.and.idt_difm1.gt.idt_near*2).or. + $ (iip2.eq.0.and.iip1.ne.0.and. + $ idt_dif0 .gt.idt_near*2)))then +c + c_qc(ii)(11:11) = 'N' +c +c Check if time difference is too great to categorize remaining types +c ------------------------------------------------------------------- + elseif((.not.l_ii_man_airep).and. + $ ((iim1.ne.0.and.iip1.ne.0.and. + $ ((idt_difm1.gt.idt_near*2/3.and. + $ idt_difp1.gt.idt_near*2/3).or. + $ (idt_dif0 .gt.idt_near*2/3.and. + $ idt_difp1.gt.idt_near*2/3).or. + $ (idt_dif0 .gt.idt_near*2/3.and. + $ idt_difp2.gt.idt_near*2/3))).or. + $ (iim1.eq.0.and.idt_difp1.gt.idt_near*2/3).or. + $ (iim1.eq.0.and.idt_difp2.gt.idt_near*2/3).or. + $ (iim2.eq.0.and.iim1.ne.0.and. + $ idt_difp1.gt.idt_near*2/3).or. + $ (iip1.eq.0.and.idt_dif0 .gt.idt_near*2/3).or. + $ (iip1.eq.0.and.idt_difm1.gt.idt_near*2/3).or. + $ (iip2.eq.0.and.iip1.ne.0.and. + $ idt_dif0 .gt.idt_near*2/3)))then +c + c_qc(ii)(11:11) = 'N' +c +c Label everything else as unknown +c -------------------------------- + else + c_qc(ii)(11:11) = 'U' + endif +c + enddo +c +c Check ordering +c Compute platform speed and airspeed between neighboring points +c Check for realistic platform speeds using Moninger's test +c Threshold lowered from 600 m/s to 525 m/s; manAIREPs use 325 m/s +c Compute vertical velocity between neighboring points and do bounce test +c ----------------------------------------------------------------------- + 5500 continue +c +c Initialize variables for track check +c ------------------------------------ + l_ii_pspd_ok = .false. + l_stuck = .false. +c + spd_thresh = 525. + spd_man_thresh = 350. + vspd_thresh = 12000.0/60.0 + vspd_bounce = 6000.0/60.0 +c + iob = istart +c + indx_save = imiss + ll = 0 + knt_bad = 0 + last_bad = 0 + last_bad_m1 = 0 + knt_iob = 1 + iob_sav = 0 +c +c Loop over reports for current flight +c ------------------------------------ + do while(iob.le.iend) + l_print = .false. + l_retest = .false. +c + knt0 = iob + ii = indx(iob) +c + if(iob.eq.iob_sav) then + knt_iob = knt_iob + 1 + else + iob_sav = iob + knt_iob = 1 + endif +c + if(knt_iob.gt.75) then + write(io8,*) + write(io8,*) 'Too many repetitions with the same iob',iob + write(io8,*) ' Sorted index ii = ',ii + write(io8,*) ' Number of repetitions = ',knt_iob + iob = iob + 1 + iob_sav = iob + knt_iob = 1 + endif +c +c Go to next report if ii index is invalid +c ---------------------------------------- + if(c_qc(ii)(1:1).eq.'d'.or. + $ c_qc(ii)(2:2).eq.'I'.or. + $ c_qc(ii)(2:2).eq.'K'.or. + $ c_qc(ii)(3:4).eq.'II'.or. + $ c_qc(ii)(5:5).eq.'I'.or. + $ c_qc(ii)(5:5).eq.'i') then +c + iob = iob + 1 + l_ii_pspd_ok = .false. + l_print = .false. + if(l_print) then + write(io8,*) 'Index invalid: ii = ',ii + endif +c +c Check out ordering etc for valid indices +c ---------------------------------------- + else +c +c Compute ii-1 index +c if(iob.gt.istart) iim1 = indx(iob-1) +c -------------------------------------- + iim1 = 0 + knt1 = iob - 1 + 11 if(knt1.ge.istart) then + iim1 = indx(knt1) + if(c_qc(iim1)(1:1).eq.'d'.or. + $ c_qc(iim1)(2:2).eq.'I'.or. + $ c_qc(iim1)(2:2).eq.'K'.or. + $ c_qc(iim1)(3:4).eq.'II'.or. + $ c_qc(iim1)(5:5).eq.'I'.or. + $ c_qc(iim1)(5:5).eq.'i') then + knt1 = knt1 - 1 + goto 11 + endif + else + iim1 = 0 + endif +c +c Compute ii-2 index +c if(iob.gt.istart+1) iim2 = indx(iob-2) +c -------------------------------------- + iim2 = 0 + knt2 = knt1 - 1 + 21 if(knt2.ge.istart) then + iim2 = indx(knt2) + if(c_qc(iim2)(1:1).eq.'d'.or. + $ c_qc(iim2)(2:2).eq.'I'.or. + $ c_qc(iim2)(2:2).eq.'K'.or. + $ c_qc(iim2)(3:4).eq.'II'.or. + $ c_qc(iim2)(5:5).eq.'I'.or. + $ c_qc(iim2)(5:5).eq.'i') then + knt2 = knt2 - 1 + goto 21 + endif + else + iim2 = 0 + endif +c +c Compute ii+1 index +c if(iob.lt.iend) iip1 = indx(iob+1) +c ------------------------------------ + iip1 = 0 + iobp1 = 0 + knt3 = iob + 1 + 41 if(knt3.le.iend) then + iip1 = indx(knt3) + iobp1 = knt3 + if(c_qc(iip1)(1:1).eq.'d'.or. + $ c_qc(iip1)(2:2).eq.'I'.or. + $ c_qc(iip1)(2:2).eq.'K'.or. + $ c_qc(iip1)(3:4).eq.'II'.or. + $ c_qc(iip1)(5:5).eq.'I'.or. + $ c_qc(iip1)(5:5).eq.'i') then + knt3 = knt3 + 1 + goto 41 + endif + else + iip1 = 0 + iobp1 = 0 + endif +c +c Compute ii+2 index +c if(iob.lt.iend-1) iip2 = indx(iob+2) +c ------------------------------------ + iip2 = 0 + iobp2 = 0 + knt4 = knt3 + 1 + 51 if(knt4.le.iend) then + iip2 = indx(knt4) + iobp2 = knt4 + if(c_qc(iip2)(1:1).eq.'d'.or. + $ c_qc(iip2)(2:2).eq.'I'.or. + $ c_qc(iip2)(2:2).eq.'K'.or. + $ c_qc(iip2)(3:4).eq.'II'.or. + $ c_qc(iip2)(5:5).eq.'I'.or. + $ c_qc(iip2)(5:5).eq.'i') then + knt4 = knt4 + 1 + goto 51 + endif + else + iip2 = 0 + iobp2 = 0 + endif +c +c Determine if reports are manual AIREPs +c -------------------------------------- + l_ii_man_airep = .false. + if(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) l_ii_man_airep = .true. +c + l_iim1_man_airep = .false. + if(iim1.ne.0) then + if(itype(iim1).eq.i_man_airep.or. + $ itype(iim1).eq.i_man_Yairep) l_iim1_man_airep = .true. + endif +c + l_iip1_man_airep = .false. + if(iip1.ne.0) then + if(itype(iip1).eq.i_man_airep.or. + $ itype(iip1).eq.i_man_Yairep) l_iip1_man_airep = .true. + endif +c + l_iip2_man_airep = .false. + if(iip2.ne.0) then + if(itype(iip2).eq.i_man_airep.or. + $ itype(iip2).eq.i_man_Yairep) l_iip2_man_airep = .true. + endif +c +c Set up temporary variables for ii point +c --------------------------------------- + alat0 = alat(ii) + alon0 = alon(ii) + ht_ft0 = ht_ft(ii) + idt0 = idt(ii) +c +c if(c_qc(ii)(7:8).ne.'..') then +c uwind0 = amiss +c vwind0 = amiss +c else +c uwind0 = -sin(ob_dir(ii)*d2r)*ob_spd(ii) +c vwind0 = -cos(ob_dir(ii)*d2r)*ob_spd(ii) +c endif +c +c Set up temporary variables for iim1 point +c ----------------------------------------- + if(iim1.ne.0) then + alatm1 = alat(iim1) + alonm1 = alon(iim1) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alon0.lt.90.0.and.alonm1.gt.270.0) + $ alonm1 = 360.0 - alonm1 + if(alon0.gt.270.0.and.alonm1.lt.90.0) + $ alonm1 = 360.0 + alonm1 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftm1 = ht_ft(iim1) + idtm1 = idt(iim1) +c +c if(c_qc(iim1)(7:8).ne.'..') then +c uwindm1 = amiss +c vwindm1 = amiss +c else +c uwindm1 = -sin(ob_dir(iim1)*d2r)*ob_spd(iim1) +c vwindm1 = -cos(ob_dir(iim1)*d2r)*ob_spd(iim1) +c endif +c +c Compute groundspeed vector components between ii and iim1 points +c ---------------------------------------------------------------- + if(idt0.ne.imiss.and.idtm1.ne.imiss) then + idt_dif0 = abs(idt0 - idtm1) + else + idt_dif0 = imiss + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alat0 .ne.amiss.and.alon0 .ne.amiss.and. + $ alatm1.ne.amiss.and.alonm1.ne.amiss.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ idt_dif0.ne.imiss) then + udist0 = gcirc_qc(alat(iim1),alon(iim1), + $ alat(iim1),alon(ii )) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alon(ii)-alon(iim1))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ udist0 = -udist0 + vdist0 = gcirc_qc(alat(iim1),alon(iim1), + $ alat(ii ),alon(iim1)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alat(ii)-alat(iim1))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ vdist0 = -vdist0 + dist0 = gcirc_qc(alat(iim1),alon(iim1), + $ alat(ii ),alon(ii )) + if(idt_dif0.gt.0) then + upspd0 = udist0 / float(idt_dif0) + vpspd0 = vdist0 / float(idt_dif0) + pspd0 = dist0 / float(idt_dif0) + else + upspd0 = udist0 / float(idt_dif0+60) + vpspd0 = vdist0 / float(idt_dif0+60) + pspd0 = dist0 / float(idt_dif0+60) + endif + if(upspd0.eq.0.0.and.vpspd0.eq.0.0) then + pdir0 = 0.0 + else + pdir0 = atan2(upspd0,vpspd0) / d2r + 180.0 + endif + dist0 = dist0 / 1000.0 + else + udist0 = amiss + vdist0 = amiss + dist0 = amiss + upspd0 = amiss + vpspd0 = amiss + pspd0 = amiss + pdir0 = amiss + endif +c +c Compute airspeed between ii and iim1 points +c ------------------------------------------- +c if(uwind0.ne.amiss.and.upspd0.ne.amiss) then +c uairspd0 = upspd0 - uwind0 +c vairspd0 = vpspd0 - vwind0 +c airspd0 = sqrt(uairspd0**2+vairspd0**2) +c + if(ob_dir(ii).ne.amiss.and.ob_spd(ii).ne.amiss) then + airspd0 = sqrt(pspd0**2 + ob_spd(ii)**2 + $ - 2.0*pspd0*ob_spd(ii)*cos((pdir0-ob_dir(ii))*d2r)) +c +c Make allowances for aircraft that round time to the +c nearest minute--divide by 120 sec rather than 60 sec +c (modified to allow for mixture of reports with time +c rounded to the nearest minute and interpolated time +c to the nearest second in ascents--P.M.Pauley 6/11/01) +c ---------------------------------------------------- + if(airspd0.gt.spd_thresh.and. + $ (abs(idt_dif0).eq.60.or. + $ (abs(idt_dif0).lt.60.and. + $ ((idt(ii )/60)*60.eq.idt(ii ).or. + $ (idt(iim1)/60)*60.eq.idt(iim1))))) then +c + airspd0 = airspd0 / 2.0 +c + endif +c +c if(uairspd0.eq.0.0.and.vairspd0.eq.0.0) then +c airdir0 = 0.0 +c else +c airdir0 = atan2(uairspd0,vairspd0) / d2r + 180.0 +c endif +c + else +c uairspd0 = amiss +c vairspd0 = amiss + airspd0 = pspd0 +c airdir0 = pdir0 + endif +c +c Compute vertical speed between ii and iim1 points +c ------------------------------------------------- + if(ht_ft0.ne.amiss.and.ht_ftm1.ne.amiss) then + ht_dif0 = ht_ft(ii) - ht_ft(iim1) + else + ht_dif0 = amiss + endif + if(ht_dif0.eq.amiss.or.idt_dif0.eq.imiss) then + vspd0 = amiss + elseif(idt_dif0.gt.0) then + vspd0 = ht_dif0 / float(idt_dif0) + else + vspd0 = ht_dif0 / float(idt_dif0+60) + endif +c + else +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + alatm1 = amiss + alonm1 = amiss +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftm1 = amiss + idtm1 = amiss +c uwindm1 = amiss +c vwindm1 = amiss +c + idt_dif0 = imiss + udist0 = amiss + vdist0 = amiss + dist0 = amiss + upspd0 = amiss + vpspd0 = amiss + pspd0 = amiss + pdir0 = amiss +c +c uairspd0 = amiss +c vairspd0 = amiss + airspd0 = amiss +c airdir0 = amiss +c + ht_dif0 = amiss + vspd0 = amiss + endif +c +c Set up temporary variables for iim2 point +c ----------------------------------------- + if(iim2.ne.0.and.iim1.ne.0) then + alatm2 = alat(iim2) + alonm2 = alon(iim2) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alon0.lt.90.0.and.alonm2.gt.270.0) + $ alonm2 = 360.0 - alonm2 + if(alon0.gt.270.0.and.alonm2.lt.90.0) + $ alonm2 = 360.0 + alonm2 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftm2 = ht_ft(iim2) + idtm2 = idt(iim2) +c +c if(c_qc(iim2)(7:8).ne.'..') then +c uwindm2 = amiss +c vwindm2 = amiss +c else +c uwindm2 = -sin(ob_dir(iim2)*d2r)*ob_spd(iim2) +c vwindm2 = -cos(ob_dir(iim2)*d2r)*ob_spd(iim2) +c endif +c +c Compute groundspeed vector components between iim2 and iim1 points +c ------------------------------------------------------------------ + if(idtm1.ne.imiss.and.idtm2.ne.imiss) then + idt_difm1 = abs(idtm1 - idtm2) + else + idt_difm1 = imiss + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alatm2.ne.amiss.and.alonm2.ne.amiss.and. + $ alatm1.ne.amiss.and.alonm1.ne.amiss.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ idt_difm1.ne.imiss) then + udistm1 = gcirc_qc(alat(iim2),alon(iim2), + $ alat(iim2),alon(iim1)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alon(iim1)-alon(iim2))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ udistm1 = -udistm1 + vdistm1 = gcirc_qc(alat(iim2),alon(iim2), + $ alat(iim1),alon(iim2)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alat(iim1)-alat(iim2))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ vdistm1 = -vdistm1 + distm1 = gcirc_qc(alat(iim2),alon(iim2), + $ alat(iim1),alon(iim1)) + if(idt_difm1.gt.0) then + upspdm1 = udistm1 / float(idt_difm1) + vpspdm1 = vdistm1 / float(idt_difm1) + pspdm1 = distm1 / float(idt_difm1) + else + upspdm1 = udistm1 / float(idt_difm1+60) + vpspdm1 = vdistm1 / float(idt_difm1+60) + pspdm1 = distm1 / float(idt_difm1+60) + endif + if(upspdm1.eq.0.0.and.vpspdm1.eq.0.0) then + pdirm1 = 0.0 + else + pdirm1 = atan2(upspdm1,vpspdm1) / d2r + 180.0 + endif + distm1 = distm1 / 1000.0 + else + udistm1 = amiss + vdistm1 = amiss + distm1 = amiss + upspdm1 = amiss + vpspdm1 = amiss + pspdm1 = amiss + pdirm1 = amiss + endif +c +c Compute airspeed between iim2 and iim1 points +c --------------------------------------------- +c if(uwindm1.ne.amiss.and.upspdm1.ne.amiss) then +c uairspdm1 = upspdm1 - uwindm1 +c vairspdm1 = vpspdm1 - vwindm1 +c airspdm1 = sqrt(uairspdm1**2+vairspdm1**2) +c + if(ob_dir(iim1).ne.amiss.and.ob_spd(iim1).ne.amiss) then + airspdm1 = sqrt(pspdm1**2 + ob_spd(iim1)**2 + $ - 2.0*pspdm1*ob_spd(iim1) + $ *cos((pdirm1-ob_dir(iim1))*d2r)) +c +c Make allowances for aircraft that round time to the +c nearest minute--divide by 120 sec rather than 60 sec +c (modified to allow for mixture of reports with time +c rounded to the nearest minute and interpolated time +c to the nearest second in ascents--P.M.Pauley 6/11/01) +c ---------------------------------------------------- + if(airspdm1.gt.spd_thresh.and. + $ (abs(idt_difm1).eq.60.or. + $ (abs(idt_difm1).lt.60.and. + $ ((idt(iim1)/60)*60.eq.idt(iim1).or. + $ (idt(iim2)/60)*60.eq.idt(iim2))))) then +c + airspdm1 = airspdm1 / 2.0 +c + endif +c +c if(uairspdm1.eq.0.0.and.vairspdm1.eq.0.0) then +c airdirm1 = 0.0 +c else +c airdirm1 = atan2(uairspdm1,vairspdm1) / d2r + 180.0 +c endif +c + else +c uairspdm1 = amiss +c vairspdm1 = amiss + airspdm1 = pspdm1 +c airdirm1 = pdirm1 + endif +c +c Compute vertical speed between iim2 and iim1 points +c --------------------------------------------------- + if(ht_ftm2.ne.amiss.and.ht_ftm1.ne.amiss) then + ht_difm1 = ht_ft(iim1) - ht_ft(iim2) + else + ht_difm1 = amiss + endif + if(ht_difm1.eq.amiss.or.idt_difm1.eq.imiss) then + vspdm1 = amiss + elseif(idt_difm1.gt.0) then + vspdm1 = ht_difm1 / float(idt_difm1) + else + vspdm1 = ht_difm1 / float(idt_difm1+60) + endif +c + else +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + alatm2 = amiss + alonm2 = amiss +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftm2 = amiss + idtm2 = amiss +c uwindm2 = amiss +c vwindm2 = amiss +c + idt_difm1 = imiss + udistm1 = amiss + vdistm1 = amiss + distm1 = amiss + upspdm1 = amiss + vpspdm1 = amiss + pspdm1 = amiss + pdirm1 = amiss +c +c uairspdm1 = amiss +c vairspdm1 = amiss + airspdm1 = amiss +c airdirm1 = amiss +c + ht_difm1 = amiss + vspdm1 = amiss + endif +c +c Set other variables to missing +c ------------------------------ +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + alatm3 = amiss + alonm3 = amiss +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftm3 = amiss + idtm3 = amiss +c uwindm3 = amiss +c vwindm3 = amiss +c + idt_difm2 = imiss + udistm2 = amiss + vdistm2 = amiss + distm2 = amiss + upspdm2 = amiss + vpspdm2 = amiss + pspdm2 = amiss + pdirm2 = amiss +c +c uairspdm2 = amiss +c vairspdm2 = amiss + airspdm2 = amiss +c airdirm2 = amiss +c + ht_difm2 = amiss + vspdm2 = amiss +c +c Set up temporary variables for iip1 point +c ----------------------------------------- + if(iip1.ne.0) then + alatp1 = alat(iip1) + alonp1 = alon(iip1) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alon0.lt.90.0.and.alonp1.gt.270.0) + $ alonp1 = 360.0 - alonp1 + if(alon0.gt.270.0.and.alonp1.lt.90.0) + $ alonp1 = 360.0 + alonp1 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftp1 = ht_ft(iip1) + idtp1 = idt(iip1) +c +c if(c_qc(iip1)(7:8).ne.'..') then +c uwindp1 = amiss +c vwindp1 = amiss +c else +c uwindp1 = -sin(ob_dir(iip1)*d2r)*ob_spd(iip1) +c vwindp1 = -cos(ob_dir(iip1)*d2r)*ob_spd(iip1) +c endif +c +c Compute groundspeed vector components between ii and iip1 points +c ---------------------------------------------------------------- + if(idt0.ne.imiss.and.idtp1.ne.imiss) then + idt_difp1 = abs(idt0 - idtp1) + else + idt_difp1 = imiss + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alat0 .ne.amiss.and.alon0 .ne.amiss.and. + $ alatp1.ne.amiss.and.alonp1.ne.amiss.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ idt_difp1.ne.imiss) then + udistp1 = gcirc_qc(alat(ii ),alon(ii ), + $ alat(ii ),alon(iip1)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alon(iip1)-alon(ii))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ udistp1 = -udistp1 + vdistp1 = gcirc_qc(alat(ii ),alon(ii ), + $ alat(iip1),alon(ii )) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alat(iip1)-alat(ii))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ vdistp1 = -vdistp1 + distp1 = gcirc_qc(alat(ii ),alon(ii ), + $ alat(iip1),alon(iip1)) + if(idt_difp1.gt.0) then + upspdp1 = udistp1 / float(idt_difp1) + vpspdp1 = vdistp1 / float(idt_difp1) + pspdp1 = distp1 / float(idt_difp1) + else + upspdp1 = udistp1 / float(idt_difp1+60) + vpspdp1 = vdistp1 / float(idt_difp1+60) + pspdp1 = distp1 / float(idt_difp1+60) + endif + if(upspdp1.eq.0.0.and.vpspdp1.eq.0.0) then + pdirp1 = 0.0 + else + pdirp1 = atan2(upspdp1,vpspdp1) / d2r + 180.0 + endif + distp1 = distp1 / 1000.0 + else + udistp1 = amiss + vdistp1 = amiss + distp1 = amiss + upspdp1 = amiss + vpspdp1 = amiss + pspdp1 = amiss + pdirp1 = amiss + endif +c +c Compute airspeed between ii and iip1 points +c ------------------------------------------- +c if(uwindp1.ne.amiss.and.upspdp1.ne.amiss) then +c uairspdp1 = upspdp1 - uwindp1 +c vairspdp1 = vpspdp1 - vwindp1 +c airspdp1 = sqrt(uairspdp1**2+vairspdp1**2) +c + if(ob_dir(iip1).ne.amiss.and.ob_spd(iip1).ne.amiss) then + airspdp1 = sqrt(pspdp1**2 + ob_spd(iip1)**2 + $ - 2.0*pspdp1*ob_spd(iip1) + $ *cos((pdirp1-ob_dir(iip1))*d2r)) +c +c Make allowances for aircraft that round time to the +c nearest minute--divide by 120 sec rather than 60 sec +c (modified to allow for mixture of reports with time +c rounded to the nearest minute and interpolated time +c to the nearest second in ascents--P.M.Pauley 6/11/01) +c ---------------------------------------------------- + if(airspdp1.gt.spd_thresh.and. + $ (abs(idt_difp1).eq.60.or. + $ (abs(idt_difp1).lt.60.and. + $ ((idt(ii )/60)*60.eq.idt(ii ).or. + $ (idt(iip1)/60)*60.eq.idt(iip1))))) then +c + airspdp1 = airspdp1 / 2.0 +c + endif +c +c if(uairspdp1.eq.0.0.and.vairspdp1.eq.0.0) then +c airdirp1 = 0.0 +c else +c airdirp1 = atan2(uairspdp1,vairspdp1) / d2r + 180.0 +c endif +c + else +c uairspdp1 = amiss +c vairspdp1 = amiss + airspdp1 = pspdp1 +c airdirp1 = pdirp1 + endif +c +c Compute vertical speed between ii and iip1 points +c ------------------------------------------------- + if(ht_ft0.ne.amiss.and.ht_ftp1.ne.amiss) then + ht_difp1 = ht_ft(iip1) - ht_ft(ii) + else + ht_difp1 = amiss + endif + if(ht_difp1.eq.amiss.or.idt_difp1.eq.imiss) then + vspdp1 = amiss + elseif(idt_difp1.gt.0) then + vspdp1 = ht_difp1 / float(idt_difp1) + else + vspdp1 = ht_difp1 / float(idt_difp1+60) + endif +c + else +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + alatp1 = amiss + alonp1 = amiss +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftp1 = amiss + idtp1 = amiss +c uwindp1 = amiss +c vwindp1 = amiss +c + idt_difp1 = imiss + udistp1 = amiss + vdistp1 = amiss + distp1 = amiss + upspdp1 = amiss + vpspdp1 = amiss + pspdp1 = amiss + pdirp1 = amiss +c +c uairspdp1 = amiss +c vairspdp1 = amiss + airspdp1 = amiss +c airdirp1 = amiss +c + ht_difp1 = amiss + vspdp1 = amiss + endif +c +c Set up temporary variables for iip2 point +c ----------------------------------------- + if(iip2.ne.0) then + alatp2 = alat(iip2) + alonp2 = alon(iip2) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alon0.lt.90.0.and.alonp2.gt.270.0) + $ alonp2 = 360.0 - alonp2 + if(alon0.gt.270.0.and.alonp2.lt.90.0) + $ alonp2 = 360.0 + alonp2 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftp2 = ht_ft(iip2) + idtp2 = idt(iip2) +c +c if(c_qc(iip2)(7:8).ne.'..') then +c uwindp2 = amiss +c vwindp2 = amiss +c else +c uwindp2 = -sin(ob_dir(iip2)*d2r)*ob_spd(iip2) +c vwindp2 = -cos(ob_dir(iip2)*d2r)*ob_spd(iip2) +c endif +c + else +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + alatp2 = amiss + alonp2 = amiss +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftp2 = amiss + idtp2 = amiss +c uwindp2 = amiss +c vwindp2 = amiss + endif +c + if(iip2.ne.0.and.iip1.ne.0) then +c +c Compute groundspeed vector components between iip1 and iip2 points +c ------------------------------------------------------------------ + if(idtp1.ne.imiss.and.idtp2.ne.imiss) then + idt_difp2 = abs(idtp1 - idtp2) + else + idt_difp2 = imiss + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alatp1.ne.amiss.and.alonp1.ne.amiss.and. + $ alatp2.ne.amiss.and.alonp2.ne.amiss.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ idt_difp2.ne.imiss) then + udistp2 = gcirc_qc(alat(iip1),alon(iip1), + $ alat(iip1),alon(iip2)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alon(iip2)-alon(iip1))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ udistp2 = -udistp2 + vdistp2 = gcirc_qc(alat(iip1),alon(iip1), + $ alat(iip2),alon(iip1)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alat(iip2)-alat(iip1))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ vdistp2 = -vdistp2 + distp2 = gcirc_qc(alat(iip1),alon(iip1), + $ alat(iip2),alon(iip2)) + if(idt_difp2.gt.0) then + upspdp2 = udistp2 / float(idt_difp2) + vpspdp2 = vdistp2 / float(idt_difp2) + pspdp2 = distp2 / float(idt_difp2) + else + upspdp2 = udistp2 / float(idt_difp2+60) + vpspdp2 = vdistp2 / float(idt_difp2+60) + pspdp2 = distp2 / float(idt_difp2+60) + endif + if(upspdp2.eq.0.0.and.vpspdp2.eq.0.0) then + pdirp2 = 0.0 + else + pdirp2 = atan2(upspdp2,vpspdp2) / d2r + 180.0 + endif + distp2 = distp2 / 1000.0 + else + udistp2 = amiss + vdistp2 = amiss + distp2 = amiss + upspdp2 = amiss + vpspdp2 = amiss + pspdp2 = amiss + pdirp2 = amiss + endif +c +c Compute airspeed between iip1 and iip2 points +c --------------------------------------------- +c if(uwindp2.ne.amiss.and.upspdp2.ne.amiss) then +c uairspdp2 = upspdp2 - uwindp2 +c vairspdp2 = vpspdp2 - vwindp2 +c airspdp2 = sqrt(uairspdp2**2+vairspdp2**2) +c + if(ob_dir(iip2).ne.amiss.and.ob_spd(iip2).ne.amiss) then + airspdp2 = sqrt(pspdp2**2 + ob_spd(iip2)**2 + $ - 2.0*pspdp2*ob_spd(iip2) + $ *cos((pdirp2-ob_dir(iip2))*d2r)) +c +c Make allowances for aircraft that round time to the +c nearest minute--divide by 120 sec rather than 60 sec +c (modified to allow for mixture of reports with time +c rounded to the nearest minute and interpolated time +c to the nearest second in ascents--P.M.Pauley 6/11/01) +c ---------------------------------------------------- + if(airspdp2.gt.spd_thresh.and. + $ (abs(idt_difp2).eq.60.or. + $ (abs(idt_difp2).lt.60.and. + $ ((idt(iip1)/60)*60.eq.idt(iip1).or. + $ (idt(iip2)/60)*60.eq.idt(iip2))))) then +c + airspdp2 = airspdp2 / 2.0 +c + endif +c +c if(uairspdp2.eq.0.0.and.vairspdp2.eq.0.0) then +c airdirp2 = 0.0 +c else +c airdirp2 = atan2(uairspdp2,vairspdp2) / d2r + 180.0 +c endif +c + else +c uairspdp2 = amiss +c vairspdp2 = amiss + airspdp2 = pspdp2 +c airdirp2 = pdirp2 + endif +c +c Compute vertical speed between iip1 and iip2 points +c --------------------------------------------------- + if(ht_ftp1.ne.amiss.and.ht_ftp2.ne.amiss) then + ht_difp2 = ht_ft(iip2) - ht_ft(iip1) + else + ht_difp2 = amiss + endif + if(ht_difp2.eq.amiss.or.idt_difp2.eq.imiss) then + vspdp2 = amiss + elseif(idt_difp2.gt.0) then + vspdp2 = ht_difp2 / float(idt_difp2) + else + vspdp2 = ht_difp2 / float(idt_difp2+60) + endif +c + else + idt_difp2 = imiss + udistp2 = amiss + vdistp2 = amiss + distp2 = amiss + upspdp2 = amiss + vpspdp2 = amiss + pspdp2 = amiss + pdirp2 = amiss +c +c uairspdp2 = amiss +c vairspdp2 = amiss + airspdp2 = amiss +c airdirp2 = amiss +c + ht_difp2 = amiss + vspdp2 = amiss + endif +c +c Set other variables to zero +c --------------------------- +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + alatp3 = amiss + alonp3 = amiss +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftp3 = amiss + idtp3 = amiss +c uwindp3 = amiss +c vwindp3 = amiss +c + idt_difp3 = imiss + udistp3 = amiss + vdistp3 = amiss + distp3 = amiss + upspdp3 = amiss + vpspdp3 = amiss + pspdp3 = amiss + pdirp3 = amiss +c +c uairspdp3 = amiss +c vairspdp3 = amiss + airspdp3 = amiss +c airdirp3 = amiss +c + ht_difp3 = amiss + vspdp3 = amiss +c +c Compute speeds without ii report +c -------------------------------- + if(iim1.ne.0.and.iip1.ne.0.and. + $ idtp1.ne.amiss.and.idtm1.ne.amiss) then +c +c Compute groundspeed vector components between iim1 and iip1 points +c ------------------------------------------------------------------ + if(idtm1.ne.imiss.and.idtp1.ne.imiss) then + idt_dif_wo0 = abs(idtp1 - idtm1) + else + idt_dif_wo0 = imiss + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alatm1.ne.amiss.and.alonm1.ne.amiss.and. + $ alatp1.ne.amiss.and.alonp1.ne.amiss.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ idt_dif_wo0.ne.imiss) then + udist_wo0 = gcirc_qc(alat(iim1),alon(iim1), + $ alat(iim1),alon(iip1)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alon(iip1)-alon(iim1))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ udist_wo0 = -udist_wo0 + vdist_wo0 = gcirc_qc(alat(iim1),alon(iim1), + $ alat(iip1),alon(iim1)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alat(iip1)-alat(iim1))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ vdist_wo0 = -vdist_wo0 + dist_wo0 = gcirc_qc(alat(iim1),alon(iim1), + $ alat(iip1),alon(iip1)) + if(idt_dif_wo0.gt.0) then + upspd_wo0 = udist_wo0 / float(idt_dif_wo0) + vpspd_wo0 = vdist_wo0 / float(idt_dif_wo0) + pspd_wo0 = dist_wo0 / float(idt_dif_wo0) + else + upspd_wo0 = udist_wo0 / float(idt_dif_wo0+60) + vpspd_wo0 = vdist_wo0 / float(idt_dif_wo0+60) + pspd_wo0 = dist_wo0 / float(idt_dif_wo0+60) + endif + if(upspd_wo0.eq.0.0.and.vpspd_wo0.eq.0.0) then + pdir_wo0 = 0.0 + else + pdir_wo0 = atan2(upspd_wo0,vpspd_wo0) + $ / d2r + 180.0 + endif + dist_wo0 = dist_wo0 / 1000.0 + else + udist_wo0 = amiss + vdist_wo0 = amiss + dist_wo0 = amiss + upspd_wo0 = amiss + vpspd_wo0 = amiss + pspd_wo0 = amiss + pdir_wo0 = amiss + endif +c +c Compute airspeed between iim1 and iip1 points +c --------------------------------------------- +c if(uwindp1.ne.amiss.and.upspd_wo0.ne.amiss) then +c uairspd_wo0 = upspd_wo0 - uwindp1 +c vairspd_wo0 = vpspd_wo0 - vwindp1 +c airspd_wo0 = sqrt(uairspd_wo0**2+vairspd_wo0**2) +c + if(ob_dir(iip1).ne.amiss.and.ob_spd(iip1).ne.amiss) then + airspd_wo0 = sqrt(pspd_wo0**2 + ob_spd(iip1)**2 + $ - 2.0*pspd_wo0*ob_spd(iip1) + $ *cos((pdir_wo0-ob_dir(iip1))*d2r)) +c +c Make allowances for aircraft that round time to the +c nearest minute--divide by 120 sec rather than 60 sec +c (modified to allow for mixture of reports with time +c rounded to the nearest minute and interpolated time +c to the nearest second in ascents--P.M.Pauley 6/11/01) +c ---------------------------------------------------- + if(airspd_wo0.gt.spd_thresh.and. + $ (abs(idt_dif_wo0).eq.60.or. + $ (abs(idt_dif_wo0).lt.60.and. + $ ((idt(iim1)/60)*60.eq.idt(iim1).or. + $ (idt(iip1)/60)*60.eq.idt(iip1))))) then +c + airspd_wo0 = airspd_wo0 / 2.0 +c + endif +c +c if(uairspd_wo0.eq.0.0.and.vairspd_wo0.eq.0.0) then +c airdir_wo0 = 0.0 +c else +c airdir_wo0 = atan2(uairspd_wo0,vairspd_wo0) +c $ / d2r + 180.0 +c endif +c + else +c uairspd_wo0 = amiss +c vairspd_wo0 = amiss + airspd_wo0 = pspd_wo0 +c airdir_wo0 = pdir_wo0 + endif +c + else + udist_wo0 = amiss + vdist_wo0 = amiss + dist_wo0 = amiss + upspd_wo0 = amiss + vpspd_wo0 = amiss + pspd_wo0 = amiss + pdir_wo0 = amiss +c +c uairspd_wo0 = amiss +c vairspd_wo0 = amiss + airspd_wo0 = amiss +c airdir_wo0 = amiss + endif +c +c Compute vertical speed between iim1 and iip1 points +c --------------------------------------------------- + if(ht_ftp1.ne.amiss.and.ht_ftm1.ne.amiss) then + ht_dif_wo0 = ht_ftp1 - ht_ftm1 + else + ht_dif_wo0 = amiss + endif + if(ht_dif_wo0.eq.amiss.or.idt_dif_wo0.eq.imiss) then + vspd_wo0 = amiss + elseif(idt_dif_wo0.gt.0) then + vspd_wo0 = ht_dif_wo0 / float(idt_dif_wo0) + else + vspd_wo0 = ht_dif_wo0 / float(idt_dif_wo0+60) + endif +c +c Compute speeds without iip1 report +c ---------------------------------- + if(iip2.ne.0.and. + $ idt0.ne.amiss.and.idtp2.ne.amiss) then +c +c Compute groundspeed vector components between ii and iip2 points +c ---------------------------------------------------------------- + if(idt0.ne.imiss.and.idtp2.ne.imiss) then + idt_dif_wop1 = abs(idtp2 - idt0) + else + idt_dif_wop1 = imiss + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alat0 .ne.amiss.and.alon0 .ne.amiss.and. + $ alatp2.ne.amiss.and.alonp2.ne.amiss.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ idt_dif_wop1.ne.imiss) then + udist_wop1 = gcirc_qc(alat(ii ),alon(ii ), + $ alat(ii ),alon(iip2)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alon(iip2)-alon(ii))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ udist_wop1 = -udist_wop1 + vdist_wop1 = gcirc_qc(alat(ii ),alon(ii ), + $ alat(iip2),alon(ii )) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alat(iip2)-alat(ii))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ vdist_wop1 = -vdist_wop1 + dist_wop1 = gcirc_qc(alat(ii ),alon(ii ), + $ alat(iip2),alon(iip2)) + if(idt_dif_wop1.gt.0) then + upspd_wop1 = udist_wop1 / float(idt_dif_wop1) + vpspd_wop1 = vdist_wop1 / float(idt_dif_wop1) + pspd_wop1 = dist_wop1 / float(idt_dif_wop1) + else + upspd_wop1 = udist_wop1 / float(idt_dif_wop1+60) + vpspd_wop1 = vdist_wop1 / float(idt_dif_wop1+60) + pspd_wop1 = dist_wop1 / float(idt_dif_wop1+60) + endif + if(upspd_wop1.eq.0.0.and.vpspd_wop1.eq.0.0) then + pdir_wop1 = 0.0 + else + pdir_wop1 = atan2(upspd_wop1,vpspd_wop1) + $ / d2r + 180.0 + endif + dist_wop1 = dist_wop1 / 1000.0 + else + udist_wop1 = amiss + vdist_wop1 = amiss + dist_wop1 = amiss + upspd_wop1 = amiss + vpspd_wop1 = amiss + pspd_wop1 = amiss + pdir_wop1 = amiss + endif +c +c Compute airspeed between ii and iip2 points +c ------------------------------------------- +c if(uwindp2.ne.amiss.and.upspd_wop1.ne.amiss) then +c uairspd_wop1 = upspd_wop1 - uwindp2 +c vairspd_wop1 = vpspd_wop1 - vwindp2 +c airspd_wop1 = sqrt(uairspd_wop1**2+vairspd_wop1**2) +c + if(ob_dir(iip2).ne.amiss.and.ob_spd(iip2).ne.amiss) then + airspd_wop1 = sqrt(pspd_wop1**2 + ob_spd(iip2)**2 + $ - 2.0*pspd_wop1*ob_spd(iip2) + $ *cos((pdir_wop1-ob_dir(iip2))*d2r)) +c +c Make allowances for aircraft that round time to the +c nearest minute--divide by 120 sec rather than 60 sec +c (modified to allow for mixture of reports with time +c rounded to the nearest minute and interpolated time +c to the nearest second in ascents--P.M.Pauley 6/11/01) +c ---------------------------------------------------- + if(airspd_wop1.gt.spd_thresh.and. + $ (abs(idt_dif_wop1).eq.60.or. + $ (abs(idt_dif_wop1).lt.60.and. + $ ((idt(ii )/60)*60.eq.idt(ii ).or. + $ (idt(iip2)/60)*60.eq.idt(iip2))))) then +c + airspd_wop1 = airspd_wop1 / 2.0 +c + endif +c +c if(uairspd_wop1.eq.0.0.and.vairspd_wop1.eq.0.0) then +c airdir_wop1 = 0.0 +c else +c airdir_wop1 = atan2(uairspd_wop1,vairspd_wop1) +c $ / d2r + 180.0 +c endif +c + else +c uairspd_wop1 = amiss +c vairspd_wop1 = amiss + airspd_wop1 = pspd_wop1 +c airdir_wop1 = pdir_wop1 + endif +c + else + udist_wop1 = amiss + vdist_wop1 = amiss + dist_wop1 = amiss + upspd_wop1 = amiss + vpspd_wop1 = amiss + pspd_wop1 = amiss + pdir_wop1 = amiss +c +c uairspd_wop1 = amiss +c vairspd_wop1 = amiss + airspd_wop1 = amiss +c airdir_wop1 = amiss + endif +c +c Compute vertical speed between ii and iip2 points +c ------------------------------------------------- + if(ht_ftp2.ne.amiss.and.ht_ft0.ne.amiss) then + ht_dif_wop1 = ht_ftp2 - ht_ft0 + else + ht_dif_wop1 = amiss + endif + if(ht_dif_wop1.eq.amiss.or.idt_dif_wop1.eq.imiss) then + vspd_wop1 = amiss + elseif(idt_dif_wop1.gt.0) then + vspd_wop1 = ht_dif_wop1 / float(idt_dif_wop1) + else + vspd_wop1 = ht_dif_wop1 / float(idt_dif_wop1+60) + endif +c +c Set other variables to zero +c --------------------------- + udist_wop2 = amiss + vdist_wop2 = amiss + dist_wop2 = amiss + upspd_wop2 = amiss + vpspd_wop2 = amiss + pspd_wop2 = amiss + pdir_wop2 = amiss +c +c uairspd_wop2 = amiss +c vairspd_wop2 = amiss + airspd_wop2 = amiss +c airdir_wop2 = amiss +c + ht_dif_wop2 = amiss +c + vspd_wop2 = amiss +c +c Compute speeds between previous two bad points +c ---------------------------------------------- + if(last_bad.ne.0.and.last_bad_m1.ne.0) then +c +c Compute groundspeed vector components between last_bad and last_bad_m1 points +c ----------------------------------------------------------------------------- + if(idt(last_bad_m1).ne.imiss.and. + $ idt(last_bad).ne.imiss) then + idt_dif_bad0 = abs(idt(last_bad) - idt(last_bad_m1)) + else + idt_dif_bad0 = imiss + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alat(last_bad).ne.amiss.and. + $ alon(last_bad).ne.amiss.and. + $ alat(last_bad_m1).ne.amiss.and. + $ alon(last_bad_m1).ne.amiss.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ idt_dif_bad0.ne.imiss) then + udist_bad0 = gcirc_qc(alat(last_bad_m1), + $ alon(last_bad_m1), + $ alat(last_bad_m1), + $ alon(last_bad)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alon(last_bad)-alon(last_bad_m1))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ udist_bad0 = -udist_bad0 + vdist_bad0 = gcirc_qc(alat(last_bad_m1), + $ alon(last_bad_m1), + $ alat(last_bad), + $ alon(last_bad_m1)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alat(last_bad)-alat(last_bad_m1))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ vdist_bad0 = -vdist_bad0 + dist_bad0 = gcirc_qc(alat(last_bad_m1), + $ alon(last_bad_m1), + $ alat(last_bad ), + $ alon(last_bad )) + if(idt_dif_bad0.gt.0) then + upspd_bad0 = udist_bad0 / float(idt_dif_bad0) + vpspd_bad0 = vdist_bad0 / float(idt_dif_bad0) + pspd_bad0 = dist_bad0 / float(idt_dif_bad0) + else + upspd_bad0 = udist_bad0 / float(idt_dif_bad0+60) + vpspd_bad0 = vdist_bad0 / float(idt_dif_bad0+60) + pspd_bad0 = dist_bad0 / float(idt_dif_bad0+60) + endif + if(upspd_bad0.eq.0.0.and.vpspd_bad0.eq.0.0) then + pdir_bad0 = 0.0 + else + pdir_bad0 = atan2(upspd_bad0,vpspd_bad0) + $ / d2r + 180.0 + endif + dist_bad0 = dist_bad0 / 1000.0 + else + udist_bad0 = amiss + vdist_bad0 = amiss + dist_bad0 = amiss + upspd_bad0 = amiss + vpspd_bad0 = amiss + pspd_bad0 = amiss + pdir_bad0 = amiss + endif +c +c Compute airspeed between last_bad and last_bad_m1 points +c -------------------------------------------------------- +c if(uwind_last.ne.amiss.and.upspd_bad0.ne.amiss) then +c uairspd_bad0 = upspd_bad0 - uwind_last +c vairspd_bad0 = vpspd_bad0 - vwind_last +c airspd_bad0 = sqrt(uairspd_bad0**2+vairspd_bad0**2) +c + if(wdir_last.ne.amiss.and.wspd_last.ne.amiss) then + airspd_bad0 = sqrt(pspd_bad0**2 + wspd_last**2 + $ - 2.0*pspd_bad0*wspd_last + $ *cos((pdir_bad0-wdir_last)*d2r)) +c +c Make allowances for aircraft that round time to the +c nearest minute--divide by 120 sec rather than 60 sec +c (modified to allow for mixture of reports with time +c rounded to the nearest minute and interpolated time +c to the nearest second in ascents--P.M.Pauley 6/11/01) +c ---------------------------------------------------- + if(airspd_bad0.gt.spd_thresh.and. + $ (abs(idt_dif_bad0).eq.60.or. + $ (abs(idt_dif_bad0).lt.60.and. + $ ((idt(last_bad_m1)/60)*60.eq.idt(last_bad_m1).or. + $ (idt(last_bad)/60)*60.eq.idt(last_bad))))) then +c + airspd_bad0 = airspd_bad0 / 2.0 +c + endif +c +c if(uairspd_bad0.eq.0.0.and.vairspd_bad0.eq.0.0) then +c airdir_bad0 = 0.0 +c else +c airdir_bad0 = atan2(uairspd_bad0,vairspd_bad0) +c $ / d2r + 180.0 +c endif +c + else +c uairspd_bad0 = amiss +c vairspd_bad0 = amiss + airspd_bad0 = pspd_bad0 +c airdir_bad0 = pspd_bad0 + endif +c +c Compute vertical speed between last_bad and last_bad_m1 points +c -------------------------------------------------------------- + if(ht_ft(last_bad).ne.amiss.and. + $ ht_ft(last_bad_m1).ne.amiss) then + ht_dif_bad0 = ht_ft(last_bad) - ht_ft(last_bad_m1) + else + ht_dif_bad0 = amiss + endif + if(ht_dif_bad0.eq.amiss.or.idt_dif_bad0.eq.imiss) then + vspd_bad0 = amiss + elseif(idt_dif_bad0.gt.0) then + vspd_bad0 = ht_dif_bad0 / float(idt_dif_bad0) + else + vspd_bad0 = ht_dif_bad0 / float(idt_dif_bad0+60) + endif +c + else + udist_bad0 = amiss + vdist_bad0 = amiss + dist_bad0 = amiss + upspd_bad0 = amiss + vpspd_bad0 = amiss + pspd_bad0 = amiss + pdir_bad0 = amiss +c +c uairspd_bad0 = amiss +c vairspd_bad0 = amiss + airspd_bad0 = amiss +c airdir_bad0 = amiss +c + ht_dif_bad0 = amiss + vspd_bad0 = amiss + endif +c +c Compute speeds between last bad point and iip1 point +c ---------------------------------------------------- + if(last_bad.ne.0.and.iip1.ne.0) then +c + idt_last_bad = idt(last_bad) +c +c Compute groundspeed vector components between last_bad and iip1 points +c ---------------------------------------------------------------------- + if(idtp1.ne.imiss.and.idt(last_bad).ne.imiss) then + idt_dif_badp1 = abs(idtp1 - idt(last_bad)) + else + idt_dif_badp1 = imiss + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alatp1.ne.amiss.and.alonp1.ne.amiss.and. + $ alat(last_bad).ne.amiss.and. + $ alon(last_bad).ne.amiss.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ idt_dif_badp1.ne.imiss) then + udist_badp1 = gcirc_qc(alat(last_bad),alon(last_bad), + $ alat(last_bad),alon(iip1)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alon(iip1)-alon(last_bad))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ udist_badp1 = -udist_badp1 + vdist_badp1 = gcirc_qc(alat(last_bad),alon(last_bad), + $ alat(iip1 ),alon(last_bad)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alat(iip1)-alat(last_bad))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ vdist_badp1 = -vdist_badp1 + dist_badp1 = gcirc_qc(alat(last_bad),alon(last_bad), + $ alat(iip1),alon(iip1)) + if(idt_dif_badp1.gt.0) then + upspd_badp1 = udist_badp1 / float(idt_dif_badp1) + vpspd_badp1 = vdist_badp1 / float(idt_dif_badp1) + pspd_badp1 = dist_badp1 / float(idt_dif_badp1) + else + upspd_badp1= udist_badp1 / float(idt_dif_badp1+60) + vpspd_badp1= vdist_badp1 / float(idt_dif_badp1+60) + pspd_badp1 = dist_badp1 / float(idt_dif_badp1+60) + endif + if(upspd_badp1.eq.0.0.and.vpspd_badp1.eq.0.0) then + pdir_badp1 = 0.0 + else + pdir_badp1 = atan2(upspd_badp1,vpspd_badp1) + $ / d2r + 180.0 + endif + dist_badp1 = dist_badp1 / 1000.0 + else + udist_badp1 = amiss + vdist_badp1 = amiss + dist_badp1 = amiss + upspd_badp1 = amiss + vpspd_badp1 = amiss + pspd_badp1 = amiss + pdir_badp1 = amiss + endif +c +c Compute airspeed between last_bad and iip1 points +c ------------------------------------------------- +c if(uwindp1.ne.amiss.and.upspd_badp1.ne.amiss) then +c uairspd_badp1 = upspd_badp1 - uwindp1 +c vairspd_badp1 = vpspd_badp1 - vwindp1 +c airspd_badp1 = +c $ sqrt(uairspd_badp1**2+vairspd_badp1**2) +c + if(ob_dir(iip1).ne.amiss.and.ob_spd(iip1).ne.amiss) then + airspd_badp1 = sqrt(pspd_badp1**2 + ob_spd(iip1)**2 + $ - 2.0*pspd_badp1*ob_spd(iip1) + $ *cos((pdir_badp1-ob_dir(iip1))*d2r)) +c +c Make allowances for aircraft that round time to the +c nearest minute--divide by 120 sec rather than 60 sec +c (modified to allow for mixture of reports with time +c rounded to the nearest minute and interpolated time +c to the nearest second in ascents--P.M.Pauley 6/11/01) +c ---------------------------------------------------- + if(airspd_badp1.gt.spd_thresh.and. + $ (abs(idt_dif_badp1).eq.60.or. + $ (abs(idt_dif_badp1).lt.60.and. + $ ((idt(last_bad)/60)*60.eq.idt(last_bad).or. + $ (idt(iip1)/60)*60.eq.idt(iip1))))) then +c + airspd_badp1 = airspd_badp1 / 2.0 +c + endif +c +c if(uairspd_badp1.eq.0.0.and. +c $ vairspd_badp1.eq.0.0) then +c airdir_badp1 = 0.0 +c else +c airdir_badp1 = atan2(uairspd_badp1,vairspd_badp1) +c $ / d2r + 180.0 +c endif +c + else +c uairspd_badp1 = amiss +c vairspd_badp1 = amiss + airspd_badp1 = pspd_badp1 +c airdir_badp1 = pspd_badp1 + endif +c +c Compute vertical speed between last_bad and iip1 points +c ------------------------------------------------------- + if(ht_ftp1.ne.amiss.and. + $ ht_ft(last_bad).ne.amiss) then + ht_dif_badp1 = ht_ft(iip1) - ht_ft(last_bad) + else + ht_dif_badp1 = amiss + endif + if(ht_dif_badp1.eq.amiss.or.idt_dif_badp1.eq.imiss) then + vspd_badp1 = amiss + elseif(idt_dif_badp1.gt.0) then + vspd_badp1 = ht_dif_badp1 / float(idt_dif_badp1) + else + vspd_badp1 = ht_dif_badp1 / float(idt_dif_badp1+60) + endif +c + else + idt_last_bad = imiss +c + udist_badp1 = amiss + vdist_badp1 = amiss + dist_badp1 = amiss + upspd_badp1 = amiss + vpspd_badp1 = amiss + pspd_badp1 = amiss + pdir_badp1 = amiss +c +c uairspd_badp1 = amiss +c vairspd_badp1 = amiss + airspd_badp1 = amiss +c airdir_badp1 = amiss +c + ht_dif_badp1 = amiss + vspd_badp1 = amiss + endif +c +c Compute magnitude of temperature, direction, and speed differences +c (constrain direction difference to be less than 180 deg) +c ------------------------------------------------------------------ + if(iip1.ne.0) then +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alat0.eq.amiss.or.alatp1.eq.amiss) then + alat_dif = amiss + alon_dif = amiss + else + alat_dif = abs(alat0 - alatp1) + alon_dif = abs(alon0 - alonp1) + if(alon_dif.gt.180.) alon_dif = 360. - alon_dif +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + endif + if(ob_t(ii).eq.amiss.or. + $ ob_t(iip1).eq.amiss) then + dif_t = amiss + else + dif_t = abs(ob_t(iip1)-ob_t(ii)) + endif + if(ob_dir(ii).eq.amiss.or. + $ ob_dir(iip1).eq.amiss) then + dif_dir = amiss + else + dif_dir = abs(ob_dir(iip1)-ob_dir(ii)) + if(dif_dir.gt.180.) dif_dir = 360. - dif_dir + endif + if(ob_spd(ii).eq.amiss.or. + $ ob_spd(iip1).eq.amiss) then + dif_spd = amiss + else + dif_spd = abs(ob_spd(iip1)-ob_spd(ii)) + endif + else + dif_t = amiss + dif_dir = amiss + dif_spd = amiss + endif +c + job = iob + jjstart = ii + iifirst = ii + iobfirst = iob + iilast = iiend + ioblast = iend +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + alat_min = 9999.9 + alat_max = -9999.9 + alon_min = 9999.9 + alon_max = -9999.9 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c + idt_start = imiss + idt_end = imiss +c + udist_track = amiss + vdist_track = amiss + dist_track = amiss + upspd_track = amiss + vpspd_track = amiss + pspd_track = amiss + pdir_track = amiss +c +c uairspd_track = amiss +c vairspd_track = amiss + airspd_track = amiss +c airdir_track = amiss +c + ht_dif_track = amiss + vspd_track = amiss +c +c Check for manAIREP location duplicates +c -------------------------------------- + if(iip1.ne.0.and. + $ l_ii_man_airep.and. + $ l_iip1_man_airep.and. +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + $ alat_dif.ne.amiss.and.alat_dif.lt.0.015.and. + $ alon_dif.ne.amiss.and.alon_dif.lt.0.015.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ ht_ft0.gt.21000.) then +c + if((ht_difp2.ne.amiss.and. + $ abs(ht_difp2).lt.htdif_same).or. + $ (ht_dif_wo0.ne.amiss.and. + $ abs(ht_dif_wo0).lt.htdif_same).or. + $ (airspd_wop1.ne.amiss.and. + $ airspd_wop1.gt.spd_thresh).or. + $ (abs(ht_difp2).lt.3000.0.and. + $ abs(ht_dif_wop1).gt.3000.0).or. + $ (ht_dif0.ne.amiss.and. + $ abs(ht_dif_wo0).lt.3000.0.and. + $ abs(ht_dif0).gt.3000.0)) then +c + c_qc(ii)(1:1) = 'd' + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'manAIREP location duplicate ii',ii + endif +c + elseif((ht_dif0.ne.amiss.and. + $ abs(ht_dif0).lt.htdif_same).or. + $ (ht_dif_wop1.ne.amiss.and. + $ abs(ht_dif_wop1).lt.htdif_same).or. + $ (airspd_wo0.ne.amiss.and. + $ airspd_wo0.gt.spd_thresh).or. + $ (abs(ht_dif_wop1).lt.3000.0.and. + $ abs(ht_difp2).gt.3000.0).or. + $ (abs(ht_dif0).lt.3000.0.and. + $ abs(ht_dif_wo0).gt.3000.0)) then +c + c_qc(iip1)(1:1) = 'd' + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'manAIREP location duplicate iip1',iip1 + endif +c + else +c + c_qc(ii)(1:1) = 'd' + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'manAIREP location duplicate ii?',ii + endif + endif +c +c If previous reject had a stuck clock, check if current +c report has the same time +c ------------------------------------------------------ + elseif(l_stuck.and. + $ idt_last_bad.ne.imiss.and. + $ idt(ii).eq.idt_last_bad) then +c + c_qc(ii)(2:2) = 'K' + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ ii + else + indx_save(ll) = ii + knt_bad = knt_bad + 1 + last_bad = ii + last_bad_m1 = iim1 +c uwind_last = uwind0 +c vwind_last = vwind0 + wspd_last = ob_spd(ii) + wdir_last = ob_dir(ii) + endif +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Another stuck clock found: ii=',ii + endif +c +c If previous reject had a stuck clock, check if iip1 +c report has the same time +c --------------------------------------------------- + elseif(l_stuck.and.iip1.ne.0.and. + $ last_bad.ne.0.and. + $ idt_dif_badp1.eq.0) then +c + c_qc(iip1)(2:2) = 'K' + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ iip1 + else + indx_save(ll) = iip1 + knt_bad = knt_bad + 1 + last_bad = iip1 + last_bad_m1 = ii +c uwind_last = uwindp1 +c vwind_last = vwindp1 + wspd_last = ob_spd(iip1) + wdir_last = ob_dir(iip1) + endif +c + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Another stuck clock found: iip1=',iip1 + endif +c +c If previous reject(s) saved, see if iip1 point is +c closer to previous point or to last rejected point +c ---------------------------------------------------- + elseif(airspd_badp1.ne.amiss.and. + $ airspd_badp1.lt.spd_thresh.and. + $ dist_badp1.ne.amiss.and. + $ distp1.ne.amiss.and. + $ dist_badp1.lt.distp1.and. + $ (dist_badp1.lt.50.0.or. + $ (pdir_bad0.ne.amiss.and. + $ (dist_badp1.lt.100.0.and. + $ cos((pdir_badp1-pdir_bad0)*d2r).gt.0.0).or. + $ cos((pdir_badp1-pdir_bad0)*d2r).gt.0.70710678)) + $ .and.vspd_badp1.ne.amiss.and. + $ abs(vspd_badp1).lt.vspd_thresh*2.0/3.0.and. + $ ht_dif_badp1.ne.amiss.and. + $ ht_dif_wo0.ne.amiss.and. + $ (dist_badp1.gt.250.0.or. + $ abs(ht_dif_badp1).lt.abs(ht_difp1).or. + $ abs(ht_difp1-ht_dif_badp1).lt.1000.0)) then +c + c_qc(iip1)(1:1) = 'p' + c_qc(iip1)(3:4) = 'II' + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ iip1 + else + indx_save(ll) = iip1 + knt_bad = knt_bad + 1 + last_bad = iip1 + last_bad_m1 = ii +c uwind_last = uwindp1 +c vwind_last = vwindp1 + wspd_last = ob_spd(iip1) + wdir_last = ob_dir(iip1) + endif +c + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'iip1 point closer to last bad pt',iip1 + endif +c +c Perform bounce test for ii point +c -------------------------------- + elseif(vspd0.ne.amiss.and.vspdp1.ne.amiss.and. + $ vspd0*vspdp1.lt.0.0.and. + $ abs(vspd0).gt.vspd_bounce.and. + $ abs(vspdp1).gt.vspd_bounce) then +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + if(iim1.ne.0) then + itypem1 = itype(iim1) + else + itypem1 = imiss + endif +c + if(itypem1.ne.imiss.and. + $ ((itypem1.eq.i_mdcrs_asc.or. + $ itypem1.eq.i_mdcrs_des).and. + $ (itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl).and. + $ (itype(iip1).eq.i_mdcrs_asc.or. + $ itype(iip1).eq.i_mdcrs_des)).or. + $ ((itypem1.eq.i_acars_asc.or. + $ itypem1.eq.i_acars_des).and. + $ (itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl).and. + $ (itype(iip1).eq.i_acars_asc.or. + $ itype(iip1).eq.i_acars_des))) then +c + c_qc(ii)(2:2) = 'I' +c + if(c_acftreg(ii)(4:5).eq.'GU'.or. + $ c_acftreg(ii)(4:5).eq.'WU') then + l_print = .false. + else + l_print = .true. + endif +c + elseif((itype(ii).eq.i_mdcrs.and. + $ (itype(iip1).eq.i_mdcrs_asc.or. + $ itype(iip1).eq.i_mdcrs_des.or. + $ itype(iip1).eq.i_mdcrs_lvl)).or. + $ (itype(ii).eq.i_acars.and. + $ (itype(iip1).eq.i_acars_asc.or. + $ itype(iip1).eq.i_acars_des.or. + $ itype(iip1).eq.i_acars_lvl))) then +c + c_qc(ii)(2:2) = 'I' +c + if(c_acftreg(ii)(4:5).eq.'GU'.or. + $ c_acftreg(ii)(4:5).eq.'WU') then + l_print = .false. + else + l_print = .true. + endif +c + else + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ ii + else + indx_save(ll) = ii + knt_bad = knt_bad + 1 + last_bad = ii + last_bad_m1 = iim1 +c uwind_last = uwind0 +c vwind_last = vwind0 + wspd_last = ob_spd(ii) + wdir_last = ob_dir(ii) + endif +c + c_qc(ii)(1:1) = 'v' + if(c_qc(ii)(5:5).eq.'R') then + c_qc(ii)(5:5) = 'i' + else + c_qc(ii)(5:5) = 'I' + endif + l_print = .true. + endif +c + if(l_print) then + write(io8,*) + write(io8,*) 'Bounce test failed in report ii--',ii + endif +c +c Perform bounce test for iip1 point +c ---------------------------------- + elseif(vspdp1.ne.amiss.and.vspdp2.ne.amiss.and. + $ vspdp1*vspdp2.lt.0.0.and. + $ abs(vspdp1).gt.vspd_bounce.and. + $ abs(vspdp2).gt.vspd_bounce) then +c + l_ii_pspd_ok = .false. +c + if(((itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des).and. + $ (itype(iip1).eq.i_mdcrs.or. + $ itype(iip1).eq.i_mdcrs_lvl).and. + $ (itype(iip2).eq.i_mdcrs_asc.or. + $ itype(iip2).eq.i_mdcrs_des)).or. + $ ((itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des).and. + $ (itype(iip1).eq.i_acars.or. + $ itype(iip1).eq.i_acars_lvl).and. + $ (itype(iip2).eq.i_acars_asc.or. + $ itype(iip2).eq.i_acars_des))) then +c + c_qc(iip1)(2:2) = 'I' +c + if(c_acftreg(iip1)(4:5).eq.'GU'.or. + $ c_acftreg(iip1)(4:5).eq.'WU') then + l_print = .false. + else + l_print = .true. + endif +c + elseif((itype(iip1).eq.i_mdcrs.and. + $ (itype(iip2).eq.i_mdcrs_asc.or. + $ itype(iip2).eq.i_mdcrs_des.or. + $ itype(iip2).eq.i_mdcrs_lvl)).or. + $ (itype(iip1).eq.i_acars.and. + $ (itype(iip2).eq.i_acars_asc.or. + $ itype(iip2).eq.i_acars_des.or. + $ itype(iip2).eq.i_acars_lvl))) then +c + c_qc(iip1)(2:2) = 'I' +c + if(c_acftreg(iip1)(4:5).eq.'GU'.or. + $ c_acftreg(iip1)(4:5).eq.'WU') then + l_print = .false. + else + l_print = .true. + endif +c + else + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ iip1 + else + indx_save(ll) = iip1 + knt_bad = knt_bad + 1 + last_bad = iip1 + last_bad_m1 = ii +c uwind_last = uwindp1 +c vwind_last = vwindp1 + wspd_last = ob_spd(iip1) + wdir_last = ob_dir(iip1) + endif +c + c_qc(iip1)(1:1) = 'v' + if(c_qc(iip1)(5:5).eq.'R') then + c_qc(iip1)(5:5) = 'i' + else + c_qc(iip1)(5:5) = 'I' + endif + l_print = .true. + endif +c + if(l_print) then + write(io8,*) + write(io8,*) 'Bounce test failed in rep iip1--',iip1 + endif +c +c Check for discontinuities in ascents +c ------------------------------------ + elseif(vspd0.ne.amiss.and. + $ vspdp1.ne.amiss.and. + $ vspdp2.ne.amiss.and. + $ vspd0.gt.0.0.and. + $ vspdp1.lt.0.0.and. + $ vspdp2.gt.0.0.and. + $ abs(vspdp1).gt.vspd_thresh/2.0.and. + $ abs(vspdp1).lt.vspd_thresh)then +c +c Check if iip1 report is a position report +c ----------------------------------------- + if((itype(iip1).eq.i_mdcrs.and. + $ (itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des.or. + $ itype(ii).eq.i_mdcrs_lvl)).or. + $ (itype(iip1).eq.i_acars.and. + $ (itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des.or. + $ itype(ii).eq.i_acars_lvl))) then +c + c_qc(iip1)(2:2) = 'I' +c + l_ii_pspd_ok = .false. +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Ascent discontinuity in iip1--',iip1 + write(io8,*) 'position report' + endif +c +c Check if ii report is a position report +c --------------------------------------- + elseif((itype(ii).eq.i_mdcrs.and. + $ (itype(iip1).eq.i_mdcrs_asc.or. + $ itype(iip1).eq.i_mdcrs_des.or. + $ itype(iip1).eq.i_mdcrs_lvl)).or. + $ (itype(ii).eq.i_acars.and. + $ (itype(iip1).eq.i_acars_asc.or. + $ itype(iip1).eq.i_acars_des.or. + $ itype(iip1).eq.i_acars_lvl))) then +c + c_qc(ii)(2:2) = 'I' +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Ascent discontinuity in ii--',ii + write(io8,*) 'position report' + endif +c + else + c_qc(iip1)(1:1) = 'V' + if(c_qc(iip1)(5:5).eq.'R') then + c_qc(iip1)(5:5) = 'i' + else + c_qc(iip1)(5:5) = 'I' + endif + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ iip1 + else + indx_save(ll) = iip1 + knt_bad = knt_bad + 1 + last_bad = iip1 + last_bad_m1 = ii +c uwind_last = uwindp1 +c vwind_last = vwindp1 + wspd_last = ob_spd(iip1) + wdir_last = ob_dir(iip1) + endif +c + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Ascent discontinuity in iip1--',iip1 + endif + endif +c +c Check for unrealistic airspeeds between ii and iip1 points +c Check airspeeds greater than spd_thresh +c (or spd_man_thresh if the time difference is greater than 10 min) +c ----------------------------------------------------------------- + elseif(iip1.ne.0.and. + $ ((c_acftid(ii)(1:3).eq.'AFR'.or. + $ c_acftid(ii)(1:3).eq.'BAW').and. + $ airspdp1.gt.2.0*spd_man_thresh).or. + $ ((c_acftid(ii)(1:3).ne.'AFR'.and. + $ c_acftid(ii)(1:3).ne.'BAW').and. + $ (airspdp1.gt.spd_thresh.or. + $ (idt_difp1.gt.600.and. + $ airspdp1.gt.spd_man_thresh))).and. + $ (.not.l_ii_pspd_ok)) then +c +c If neighboring points not available, reject both points +c ------------------------------------------------------- + if(airspd_wo0.eq.amiss.and. + $ airspd_wop1.eq.amiss) then +c + c_qc(ii)(1:1) = 'P' + c_qc(ii)(3:4) = 'II' + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ ii + else + indx_save(ll) = ii + knt_bad = knt_bad + 1 + endif +c + c_qc(iip1)(1:1) = 'P' + c_qc(iip1)(3:4) = 'II' + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ iip1 + else + indx_save(ll) = iip1 + knt_bad = knt_bad + 1 + last_bad = iip1 + last_bad_m1 = ii +c uwind_last = uwindp1 +c vwind_last = vwindp1 + wspd_last = ob_spd(iip1) + wdir_last = ob_dir(iip1) + endif +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'Rejecting both points' + endif +c +c Check if ii report is a position report +c (rejects not saved for second flight check) +c ------------------------------------------- + elseif(idt_difp1.le.60.and. + $ ((itype(ii).eq.i_mdcrs.and. + $ (itype(iip1).eq.i_mdcrs_asc.or. + $ itype(iip1).eq.i_mdcrs_des.or. + $ itype(iip1).eq.i_mdcrs_lvl)).or. + $ (itype(ii).eq.i_acars.and. + $ (itype(iip1).eq.i_acars_asc.or. + $ itype(iip1).eq.i_acars_des.or. + $ itype(iip1).eq.i_acars_lvl)))) then +c + c_qc(ii)(2:2) = 'I' +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + if(c_acftreg(ii)(4:5).eq.'GU'.or. + $ c_acftreg(ii)(4:5).eq.'WU') then + l_print = .false. + else + l_print = .true. + endif +c + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'Is ii a position report?' + endif +c +c Check if iip1 report is a position report +c (rejects not saved for second flight check) +c --------------------------------------------- + elseif(idt_difp1.le.60.and. + $ ((itype(iip1).eq.i_mdcrs.and. + $ (itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des.or. + $ itype(ii).eq.i_mdcrs_lvl)).or. + $ (itype(iip1).eq.i_acars.and. + $ (itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des.or. + $ itype(ii).eq.i_acars_lvl)))) then +c + c_qc(iip1)(2:2) = 'I' +c + l_ii_pspd_ok = .false. +c + if(c_acftreg(iip1)(4:5).eq.'GU'.or. + $ c_acftreg(iip1)(4:5).eq.'WU') then + l_print = .false. + else + l_print = .true. + endif +c + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'Is iip1 a position report?' + endif +c +c Check if ii report is a MDCRS report with zero latitude or longitude +c (rejects not saved for second flight check) +c -------------------------------------------------------------------- +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + elseif((abs(alat(ii)).lt.0.005.or. + $ abs(alon(ii)).lt.0.005).and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ ((itype(ii).eq.i_mdcrs.and. + $ (itype(iip1).eq.i_mdcrs_asc.or. + $ itype(iip1).eq.i_mdcrs_des.or. + $ itype(iip1).eq.i_mdcrs_lvl)).or. + $ (itype(ii).eq.i_acars.and. + $ (itype(iip1).eq.i_acars_asc.or. + $ itype(iip1).eq.i_acars_des.or. + $ itype(iip1).eq.i_acars_lvl)))) then +c +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(abs(alat(ii)).lt.0.005) c_qc(ii)(3:3) = 'B' + if(abs(alon(ii)).lt.0.005) c_qc(ii)(4:4) = 'B' +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .true. +c + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'ii report has zero lat or lon' + endif +c +c Check if iip1 report is a MDCRS report with zero latitude or longitude +c (rejects not saved for second flight check) +c ---------------------------------------------------------------------- +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + elseif((abs(alat(iip1)).lt.0.005.or. + $ abs(alon(iip1)).lt.0.005).and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ ((itype(iip1).eq.i_mdcrs.and. + $ (itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des.or. + $ itype(ii).eq.i_mdcrs_lvl)).or. + $ (itype(iip1).eq.i_acars.and. + $ (itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des.or. + $ itype(ii).eq.i_acars_lvl)))) then +c +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(abs(alat(ii)).lt.0.005) c_qc(ii)(3:3) = 'B' + if(abs(alon(ii)).lt.0.005) c_qc(ii)(4:4) = 'B' +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c + l_ii_pspd_ok = .false. +c + l_print = .true. +c + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'iip1 report has zero lat or lon' + endif +c +c Check if ii report is an AMDAR report with rounded latitude +c (rejects not saved for second flight check) +c ----------------------------------------------------------- +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + elseif(float(int(alat(ii))).eq.alat(ii).and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ (itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des.or. + $ itype(ii).eq.i_amdar_lvl).and. + $ (itype(iip1).eq.i_amdar.or. + $ itype(iip1).eq.i_amdar_asc.or. + $ itype(iip1).eq.i_amdar_des.or. + $ itype(iip1).eq.i_amdar_lvl)) then +c + c_qc(ii)(1:1) = 'P' + c_qc(ii)(3:4) = 'II' +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + if(c_acftreg(ii)(1:2).eq.'IT') then + l_print = .true. + else + l_print = .true. + endif + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'AMDAR rep ii has rounded lat' + endif +c +c Check if iip1 report is an AMDAR report with rounded latitude +c (rejects not saved for second flight check) +c ------------------------------------------------------------- +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + elseif(float(int(alat(iip1))).eq.alat(iip1).and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ (itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des.or. + $ itype(ii).eq.i_amdar_lvl).and. + $ (itype(iip1).eq.i_amdar.or. + $ itype(iip1).eq.i_amdar_asc.or. + $ itype(iip1).eq.i_amdar_des.or. + $ itype(iip1).eq.i_amdar_lvl)) then +c + c_qc(iip1)(1:1) = 'P' + c_qc(iip1)(3:4) = 'II' +c + l_ii_pspd_ok = .false. +c + if(c_acftreg(ii)(1:2).eq.'IT') then + l_print = .true. + else + l_print = .true. + endif + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'AMDAR rep iip1 has rounded lat' + endif +c +c Check if ii report is an AMDAR report with the wrong sign on the longitude +c (rejects not saved for second flight check) +c -------------------------------------------------------------------------- +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + elseif(alon(ii ).lt.25.0.and. + $ alon(iip1).gt.335.0.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ (itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des.or. + $ itype(ii).eq.i_amdar_lvl).and. + $ (itype(iip1).eq.i_amdar.or. + $ itype(iip1).eq.i_amdar_asc.or. + $ itype(iip1).eq.i_amdar_des.or. + $ itype(iip1).eq.i_amdar_lvl)) then +c + c_qc(ii)(1:1) = 'P' + c_qc(ii)(3:4) = 'II' +c +c Search backwards for minimum longitude +c Reject points between min and prime meridian +c -------------------------------------------- + if(iim1.ne.0) then + if(alon(iim1).lt.alon(ii)) then + nob = iob - 1 + do while(nob.gt.istart) + nn = indx(nob) + nnm1 = indx(nob-1) + if(alon(nnm1).lt.alon(nn)) then +c write(io8,*) +c write(io8,*) 'nn not min--',alon(nn),alon(nnm1) + nob = nob - 1 + c_qc(nn)(1:1) = 'P' + c_qc(nn)(3:4) = 'II' + else + nob = istart + endif + enddo + endif + endif +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'AMDAR rep ii has wrong sign on lon' + endif +c +c Go back and recheck flight after printing output +c ------------------------------------------------ + l_retest = .true. +c +c Check if iip1 report is an AMDAR report with the wrong sign on the longitude +c (rejects not saved for second flight check) +c ---------------------------------------------------------------------------- +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + elseif(alon(iip1).lt.25.0.and. + $ alon(ii ).gt.335.0.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ (itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des.or. + $ itype(ii).eq.i_amdar_lvl).and. + $ (itype(iip1).eq.i_amdar.or. + $ itype(iip1).eq.i_amdar_asc.or. + $ itype(iip1).eq.i_amdar_des.or. + $ itype(iip1).eq.i_amdar_lvl)) then +c + c_qc(iip1)(1:1) = 'P' + c_qc(iip1)(3:4) = 'II' +c +c Search forwards for minimum longitude +c ------------------------------------- + if(iip2.ne.0) then + if(alon(iip2).lt.alon(iip1)) then + nob = iob + 2 + do while(nob.lt.iend) + nn = indx(nob) + nnp1 = indx(nob+1) + if(alon(nnp1).lt.alon(nn)) then + write(io8,*) + write(io8,*)'nn not min--',alon(nn),alon(nnp1) + nob = nob + 1 + c_qc(nn)(1:1) = 'P' + c_qc(nn)(3:4) = 'II' + else + write(io8,*) + write(io8,*) 'nn is min--',alon(nn),alon(nnp1) + nob = iend + endif + enddo + endif + endif +c + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'AMDAR rep iip1 has wrong sign on lon' + endif +c +c Go back and recheck flight after printing output +c ------------------------------------------------ + l_retest = .true. +cc +cc Check if ii manAIREP yielded a too-high speed +cc (rejects not saved for second flight check) +cc --------------------------------------------- +c elseif(l_ii_man_airep.and.(.not.l_iip1_man_airep)) then +cc +c c_qc(ii)(1:1) = 'P' +c c_qc(ii)(3:4) = 'II' +c +c iob = iob + 1 +c l_ii_pspd_ok = .false. +cc +c l_print = .true. +c if(l_print) then +c write(io8,*) +c write(io8,*) 'Air speed--',airspdp1, +c $ '--too high in report--',ii +c write(io8,*) 'manAIREP ii does not fit' +c endif +cc +cc Check if iip1 manAIREP yielded a too-high speed +cc (rejects not saved for second flight check) +cc ----------------------------------------------- +c elseif(l_iip1_man_airep.and.(.not.l_ii_man_airep)) then +cc +c c_qc(iip1)(1:1) = 'P' +c c_qc(iip1)(3:4) = 'II' +c +c l_ii_pspd_ok = .false. +cc +c l_print = .false. +c if(l_print) then +c write(io8,*) +c write(io8,*) 'Air speed--',airspdp1, +c $ '--too high in report--',ii +c write(io8,*) 'manAIREP iip1 does not fit' +c endif +c +c Check valid supersonic manAIREP flights +c (rejects not saved for second flight check) +c ------------------------------------------- + elseif(l_ii_man_airep.and.l_iip1_man_airep.and. + $ (l_iim1_man_airep.or.l_iip2_man_airep).and. + $ (c_acftid(ii)(1:3).eq.'AFR'.or. + $ c_acftid(ii)(1:3).eq.'BAW')) then +c +c Print but don't reject speeds from 700 to 750 m/s +c ------------------------------------------------- + if((airspdp1.le.750.0.and. + $ airspd_wo0.ne.amiss.and. + $ airspd_wop1.ne.amiss.and. + $ abs(airspd_wo0-airspd_wop1).lt.50.0).or. + $ (airspd0 .ne.amiss.and.airspd0 .le.750.0.and. + $ airspdp1.ne.amiss.and.airspdp1.le.750.0.and. + $ abs(airspd0-airspdp1).lt.50.0).or. + $ (airspdp1.ne.amiss.and.airspdp1.le.750.0.and. + $ airspdp2.ne.amiss.and.airspdp2.le.750.0.and. + $ abs(airspdp1-airspdp2).lt.50.0)) then + + l_ii_pspd_ok = .true. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Supersonic air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'manAIREP airspeed below 750 m/s ok' + endif +c +c Check if ii report is bad by other airspeeds +c -------------------------------------------- + elseif((l_iim1_man_airep.and.l_iip2_man_airep.and. + $ airspd_wo0.ne.amiss.and. + $ airspd_wop1.ne.amiss.and. + $ airspd_wo0.lt.2.0*spd_man_thresh.and. + $ (airspd_wop1.gt.2.0*spd_man_thresh.or. + $ airspd_wop1-airspd_wo0.gt.60.0).and. + $ cos((pdir0-pdirp1)*d2r).lt.0.0.and. + $ cos((pdirp2-pdir_wo0)*d2r).gt.0.0).or. + $ (l_iim1_man_airep.and. + $ airspd0.ne.amiss.and. + $ airspdp2.eq.amiss.and. + $ airspd0.gt.2.0*spd_man_thresh).or. + $ (l_iip2_man_airep.and. + $ airspdp2.ne.amiss.and. + $ airspd_wo0.eq.amiss.and. + $ airspd_wop1.ne.amiss.and. + $ airspdp2.lt.2.0*spd_man_thresh.and. + $ (airspd_wop1.gt.2.0*spd_man_thresh.or. + $ airspd_wop1.lt.2.0*spd_man_thresh/3.0))) then +c + c_qc(ii)(1:1) = 'P' + c_qc(ii)(3:4) = 'II' +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Supersonic air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'manAIREP ii is bad' + endif +c +c Check if iip1 is bad by other airspeeds +c --------------------------------------- + elseif((l_iim1_man_airep.and.l_iip2_man_airep.and. + $ airspd_wo0.ne.amiss.and. + $ airspd_wop1.ne.amiss.and. + $ airspd_wop1.lt.2.0*spd_man_thresh.and. + $ (airspd_wo0.gt.2.0*spd_man_thresh.or. + $ airspd_wo0-airspd_wop1.gt.60.0).and. + $ cos((pdirp1-pdirp2 )*d2r).lt.0.0.and. + $ cos((pdir0 -pdir_wop1)*d2r).gt.0.0).or. + $ (l_iim1_man_airep.and. + $ airspd0.ne.amiss.and. + $ airspd_wo0.ne.amiss.and. + $ airspd_wop1.eq.amiss.and. + $ airspd0.lt.2.0*spd_man_thresh.and. + $ airspd_wo0.gt.2.0*spd_man_thresh).or. + $ (l_iip2_man_airep.and. + $ airspd0.eq.amiss.and. + $ airspdp2.ne.amiss.and. + $ airspdp2.gt.2.0*spd_man_thresh).or. + $ (airspd0 .ne.amiss.and. + $ airspd0 .lt.2.0*spd_man_thresh.and. + $ airspdp1.ne.amiss.and. + $ airspdp1.gt.2.0*spd_man_thresh.and. + $ airspdp2.ne.amiss.and. + $ airspdp2.gt.2.0*spd_man_thresh.and. + $ airspd_wo0 .ne.amiss.and. + $ airspd_wo0 .lt.2.0*spd_man_thresh.and. + $ airspd_wop1.ne.amiss.and. + $ airspd_wop1.lt.2.0*spd_man_thresh)) then +c + c_qc(iip1)(1:1) = 'P' + c_qc(iip1)(3:4) = 'II' +c + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Supersonic air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'manAIREP iip1 is bad' + endif +c +c Check if first report in flight is bad +c -------------------------------------- + elseif(airspd0.eq.amiss.and. + $ airspdp2.ne.amiss.and. + $ airspd_wop1.ne.amiss.and. + $ airspdp2.lt.2.0*spd_man_thresh.and. + $ airspd_wop1.lt.2.0*spd_man_thresh.and. + $ cos((pdirp1-pdirp2)*d2r).gt.0.0) then +c + c_qc(ii)(1:1) = 'P' + c_qc(ii)(3:4) = 'II' +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Supersonic air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) '1st manAIREP is bad' + endif +c +c Check if last report in flight is bad +c ------------------------------------- + elseif(airspd0.ne.amiss.and. + $ airspdp2.eq.amiss.and. + $ airspd_wo0.ne.amiss.and. + $ airspd0.lt.2.0*spd_man_thresh.and. + $ airspd_wo0.lt.2.0*spd_man_thresh.and. + $ cos((pdir0-pdirp1)*d2r).gt.0.0) then +c + c_qc(iip1)(1:1) = 'P' + c_qc(iip1)(3:4) = 'II' +c + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Supersonic air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'last manAIREP is bad' + endif +c +c Handle remaining points +c ----------------------- + else +c + c_qc(ii)(1:1) = 'P' + c_qc(ii)(3:4) = 'II' +c + c_qc(iip1)(1:1) = 'P' + c_qc(iip1)(3:4) = 'II' +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Supersonic air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'Uncategorized manAIREP' + write(io8,*) 'Rejecting both points' + endif + endif +c +c Check flights with time differences greater than 10 min +c (rejects not saved for second flight check) +c ---------------------------------------------------------------- +c elseif(l_ii_man_airep.and.l_iip1_man_airep.and. +c $ (l_iim1_man_airep.or.l_iip2_man_airep).and. +c $ (c_acftid(ii)(1:3).ne.'AFR'.and. +c + elseif((c_acftid(ii)(1:3).ne.'AFR'.and. + $ c_acftid(ii)(1:3).ne.'BAW').and. + $ idt_difp1.gt.600) then +c +c Print but don't reject speeds from 350 to 375 m/s +c ------------------------------------------------- + if((airspdp1.le.375.0.and. + $ airspd_wo0.ne.amiss.and. + $ airspd_wop1.ne.amiss.and. + $ abs(airspd_wo0-airspd_wop1).lt.50.0).or. + $ (airspd0 .ne.amiss.and.airspd0 .le.375.0.and. + $ airspdp1.ne.amiss.and.airspdp1.le.375.0.and. + $ abs(airspd0-airspdp1).lt.25.0).or. + $ (airspdp1.ne.amiss.and.airspdp1.le.375.0.and. + $ airspdp2.ne.amiss.and.airspdp2.le.375.0.and. + $ abs(airspdp1-airspdp2).lt.25.0)) then + + l_ii_pspd_ok = .true. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'Airspeed below 375 m/s ok' + endif +c +c Check if ii report is bad by other airspeeds +c -------------------------------------------- +c elseif((l_iim1_man_airep.and.l_iip2_man_airep.and. +c $ airspd_wo0.ne.amiss.and. +c + elseif((airspd_wo0.ne.amiss.and. + $ airspd_wop1.ne.amiss.and. + $ airspd_wo0.lt.spd_man_thresh.and. + $ (airspd_wop1.gt.spd_man_thresh.or. + $ airspd_wop1-airspd_wo0.gt.60.0).and. + $ cos((pdir0-pdirp1)*d2r).lt.0.0.and. + $ cos((pdirp2-pdir_wo0)*d2r).gt.0.0).or. +c +c $ (l_iim1_man_airep.and. +c + $ (airspd0.ne.amiss.and. + $ airspdp2.eq.amiss.and. + $ airspd0.gt.spd_man_thresh).or. +c +c $ (l_iip2_man_airep.and. +c + $ (airspdp2.ne.amiss.and. + $ airspd_wo0.eq.amiss.and. + $ airspd_wop1.ne.amiss.and. + $ airspdp2.lt.spd_man_thresh.and. + $ (airspd_wop1.gt.spd_man_thresh.or. + $ airspd_wop1.lt.spd_man_thresh/3.0))) then +c + c_qc(ii)(1:1) = 'P' + c_qc(ii)(3:4) = 'II' +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '-- > 350 m/s in report--',ii + write(io8,*) 'Report ii is bad' + endif +c +c Check if iip1 is bad by other airspeeds +c --------------------------------------- +c elseif((l_iim1_man_airep.and.l_iip2_man_airep.and. +c $ airspd_wo0.ne.amiss.and. +c + elseif((airspd_wo0.ne.amiss.and. + $ airspd_wop1.ne.amiss.and. + $ airspd_wop1.lt.spd_man_thresh.and. + $ (airspd_wo0.gt.spd_man_thresh.or. + $ airspd_wo0-airspd_wop1.gt.60.0).and. + $ cos((pdirp1-pdirp2 )*d2r).lt.0.0.and. + $ cos((pdir0 -pdir_wop1)*d2r).gt.0.0).or. +c +c $ (l_iim1_man_airep.and. +c + $ (airspd0.ne.amiss.and. + $ airspd_wo0.ne.amiss.and. + $ airspd_wop1.eq.amiss.and. + $ airspd0.lt.spd_man_thresh.and. + $ airspd_wo0.gt.spd_man_thresh).or. +c +c $ (l_iip2_man_airep.and. +c + $ (airspd0.eq.amiss.and. + $ airspdp2.ne.amiss.and. + $ airspdp2.gt.spd_man_thresh).or. + $ (airspd0 .ne.amiss.and. + $ airspd0 .lt.spd_man_thresh.and. + $ airspdp1.ne.amiss.and. + $ airspdp1.gt.spd_man_thresh.and. + $ airspdp2.ne.amiss.and. + $ airspdp2.gt.spd_man_thresh.and. + $ airspd_wo0 .ne.amiss.and. + $ airspd_wo0 .lt.spd_man_thresh.and. + $ airspd_wop1.ne.amiss.and. + $ airspd_wop1.lt.spd_man_thresh)) then +c + c_qc(iip1)(1:1) = 'P' + c_qc(iip1)(3:4) = 'II' +c + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '-- > 350 m/s in report--',ii + write(io8,*) 'Report iip1 is bad' + endif +c +c Check if first report in flight is bad +c -------------------------------------- + elseif(airspd0.eq.amiss.and. + $ airspdp2.ne.amiss.and. + $ airspd_wop1.ne.amiss.and. + $ airspdp2.lt.spd_man_thresh.and. + $ airspd_wop1.lt.spd_man_thresh.and. + $ cos((pdirp1-pdirp2)*d2r).gt.0.0) then +c + c_qc(ii)(1:1) = 'P' + c_qc(ii)(3:4) = 'II' +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '-- > 350 m/s in report--',ii + write(io8,*) '1st report is bad' + endif +c +c Check if last report in flight is bad +c ------------------------------------- + elseif(airspd0.ne.amiss.and. + $ airspdp2.eq.amiss.and. + $ airspd_wo0.ne.amiss.and. + $ airspd0.lt.spd_man_thresh.and. + $ airspd_wo0.lt.spd_man_thresh.and. + $ cos((pdir0-pdirp1)*d2r).gt.0.0) then +c + c_qc(iip1)(1:1) = 'P' + c_qc(iip1)(3:4) = 'II' +c + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '-- > 350 m/s in report--',ii + write(io8,*) 'last report is bad' + endif +c +c Handle remaining points +c ----------------------- + else +c + c_qc(ii)(1:1) = 'P' + c_qc(ii)(3:4) = 'II' +c + c_qc(iip1)(1:1) = 'P' + c_qc(iip1)(3:4) = 'II' +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '-- > 350 m/s in report--',ii + write(io8,*) 'Uncategorized report' + write(io8,*) 'Rejecting both points' + endif + endif +c +c Check for previously undetected stuck clocks +c (rejects not saved for second flight check) +c -------------------------------------------- + elseif(idt_difp2.eq.0.and. + $ airspd_wo0.ne.amiss.and. + $ airspd_wo0.gt.spd_thresh.and. + $ airspd_wop1.ne.amiss.and. + $ airspd_wop1.gt.spd_thresh.and. + $ airspdp2.ne.amiss.and. + $ airspdp2.gt.spd_thresh) then +c + c_qc(iip1)(2:2) = 'K' + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ iip1 + else + indx_save(ll) = iip1 + knt_bad = knt_bad + 1 + endif +c + c_qc(iip2)(2:2) = 'K' + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!' + $ ,iip2 + else + indx_save(ll) = iip2 + knt_bad = knt_bad + 1 + last_bad = iip2 + last_bad_m1 = iip1 +c uwind_last = uwindp2 +c vwind_last = vwindp2 + wspd_last = ob_spd(iip2) + wdir_last = ob_dir(iip2) + endif +c + l_ii_pspd_ok = .false. + l_stuck = .true. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'iip1, iip2 reports have same time' + endif +c +c Print but don't reject speeds from 525 to 550 m/s +c ------------------------------------------------- + elseif((airspdp1.le.550.0.and. + $ airspd_wo0.ne.amiss.and. + $ airspd_wop1.ne.amiss.and. + $ abs(airspd_wo0-airspd_wop1).lt.50.0).or. + $ (airspd0 .ne.amiss.and.airspd0 .le.550.0.and. + $ airspdp1.ne.amiss.and.airspdp1.le.550.0.and. + $ abs(airspd0-airspdp1).lt.25.0).or. + $ (airspdp1.ne.amiss.and.airspdp1.le.550.0.and. + $ airspdp2.ne.amiss.and.airspdp2.le.550.0.and. + $ abs(airspdp1-airspdp2).lt.25.0)) then +c + l_ii_pspd_ok = .true. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'Airspeed below 550 m/s ok' + endif +c +c Check if ii is problem point by other airspeeds +c ----------------------------------------------- + elseif((airspd_wo0.ne.amiss.and. + $ airspd_wop1.ne.amiss.and. + $ airspd_wo0.lt.spd_thresh.and. + $ (airspd_wop1.gt.spd_thresh.or. + $ airspd_wop1-airspd_wo0.gt.90.0).and. + $ cos((pdir0-pdirp1)*d2r).lt.0.0.and. + $ cos((pdirp2-pdir_wo0)*d2r).gt.0.0).or. + $ (airspd0.ne.amiss.and. + $ airspdp2.eq.amiss.and. + $ airspd0.gt.spd_thresh).or. + $ (airspdp2.ne.amiss.and. + $ airspd_wo0.eq.amiss.and. + $ airspd_wop1.ne.amiss.and. + $ airspdp2.lt.spd_thresh.and. + $ (airspd_wop1.gt.spd_thresh.or. + $ airspd_wop1.lt.spd_thresh/3.0))) then +c + c_qc(ii)(1:1) = 'P' + c_qc(ii)(3:4) = 'II' +c + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ ii + else + indx_save(ll) = ii + knt_bad = knt_bad + 1 + last_bad = ii + last_bad_m1 = iim1 +c uwind_last = uwind0 +c vwind_last = vwind0 + wspd_last = ob_spd(ii) + wdir_last = ob_dir(ii) + endif +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'ii is problem point' + endif +c +c Check if iip1 is problem point by other airspeeds +c ------------------------------------------------- + elseif((airspd_wo0.ne.amiss.and. + $ airspd_wop1.ne.amiss.and. + $ airspd_wop1.lt.spd_thresh.and. + $ (airspd_wo0.gt.spd_thresh.or. + $ airspd_wo0-airspd_wop1.gt.90.0).and. + $ cos((pdirp1-pdirp2 )*d2r).lt.0.0.and. + $ cos((pdir0 -pdir_wop1)*d2r).gt.0.0).or. + $ (airspd0.ne.amiss.and. + $ airspd_wo0.ne.amiss.and. + $ airspd_wop1.eq.amiss.and. + $ airspd0.lt.spd_thresh.and. + $ airspd_wo0.gt.spd_thresh).or. + $ (airspd0.eq.amiss.and. + $ airspdp2.ne.amiss.and. + $ airspdp2.gt.spd_thresh).or. + $ (airspd0 .ne.amiss.and. + $ airspd0 .lt.spd_thresh.and. + $ airspdp1.ne.amiss.and. + $ airspdp1.gt.spd_thresh.and. + $ airspdp2.ne.amiss.and. + $ airspdp2.gt.spd_thresh.and. + $ airspd_wo0 .ne.amiss.and. + $ airspd_wo0 .lt.spd_thresh.and. + $ airspd_wop1.ne.amiss.and. + $ airspd_wop1.lt.spd_thresh)) then +c + c_qc(iip1)(1:1) = 'P' + c_qc(iip1)(3:4) = 'II' +c + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ iip1 + else + indx_save(ll) = iip1 + knt_bad = knt_bad + 1 + last_bad = iip1 + last_bad_m1 = ii +c uwind_last = uwindp1 +c vwind_last = vwindp1 + wspd_last = ob_spd(iip1) + wdir_last = ob_dir(iip1) + endif +c + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'iip1 is problem point' + endif +c +c Check if first report in flight is bad +c -------------------------------------- + elseif(airspd0.eq.amiss.and. + $ airspdp2.ne.amiss.and. + $ airspd_wop1.ne.amiss.and. + $ airspdp2.lt.spd_thresh.and. + $ airspd_wop1.lt.spd_thresh.and. + $ cos((pdirp1-pdirp2)*d2r).gt.0.0) then +c + c_qc(ii)(1:1) = 'P' + c_qc(ii)(3:4) = 'II' +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) '1st report is bad' + endif +c +c Check if last report in flight is bad +c ------------------------------------- + elseif(airspd0.ne.amiss.and. + $ airspdp2.eq.amiss.and. + $ airspd_wo0.ne.amiss.and. + $ airspd0.lt.spd_thresh.and. + $ airspd_wo0.lt.spd_thresh.and. + $ cos((pdir0-pdirp1)*d2r).gt.0.0) then +c + c_qc(iip1)(1:1) = 'P' + c_qc(iip1)(3:4) = 'II' +c + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'last report is bad' + endif +c +c Check if iip1 and iip2 points are from a different flight +c --------------------------------------------------------- + elseif((vspd0 .ne.amiss.and. + $ abs(vspd0 ).lt.vspd_thresh*2.0/3.0.and. + $ vspdp1.ne.amiss.and. + $ abs(vspdp1).gt.vspd_thresh*2.0/3.0.and. + $ vspdp2.ne.amiss.and. + $ abs(vspdp2).lt.vspd_thresh*2.0/3.0).or. + $ (airspd0 .ne.amiss.and. + $ airspd0 .lt.spd_thresh.and. + $ airspdp1.ne.amiss.and. + $ airspdp1.gt.spd_thresh.and. + $ airspdp2.ne.amiss.and. + $ airspdp2.lt.spd_thresh).or. + $ (airspd0 .ne.amiss.and. + $ airspd0 .lt.spd_thresh.and. + $ airspdp1.ne.amiss.and. + $ airspdp1.gt.spd_thresh.and. + $ airspdp2.ne.amiss.and. + $ airspdp2.gt.spd_thresh.and. + $ airspd_wo0 .ne.amiss.and. + $ airspd_wo0 .gt.spd_thresh.and. + $ airspd_wop1.ne.amiss.and. + $ airspd_wop1.gt.spd_thresh)) then +c + c_qc(iip1)(1:1) = 'P' + c_qc(iip1)(3:4) = 'II' +c + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!' + $ ,iip1 + else + indx_save(ll) = iip1 + knt_bad = knt_bad + 1 + endif +c + c_qc(iip2)(1:1) = 'P' + c_qc(iip2)(3:4) = 'II' + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!' + $ ,iip2 + else + indx_save(ll) = iip2 + knt_bad = knt_bad + 1 + last_bad = iip2 + last_bad_m1 = iip1 +c uwind_last = uwindp2 +c vwind_last = vwindp2 + wspd_last = ob_spd(iip2) + wdir_last = ob_dir(iip2) + endif +c + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'iip1 and iip2 reports from new flight' + endif +c +c Check if iip1 is problem point by other airspeeds--clock problem +c ---------------------------------------------------------------- + elseif(airspd_wo0.ne.amiss.and. + $ airspd_wop1.ne.amiss.and. + $ airspd_wo0.lt.spd_thresh.and. + $ (airspd_wop1.gt.spd_thresh.or. + $ airspd_wop1-airspd_wo0.gt.90.0).and. + $ airspdp2.gt.spd_thresh.and. + $ cos((pdir0-pdirp1)*d2r).gt.0.5.and. + $ cos((pdirp2-pdir_wo0)*d2r).gt.0.5) then +c + c_qc(iip1)(1:1) = 'P' + c_qc(iip1)(3:4) = 'II' +c + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ ii + else + indx_save(ll) = iip1 + knt_bad = knt_bad + 1 + last_bad = iip1 + last_bad_m1 = ii +c uwind_last = uwindp1 +c vwind_last = vwindp1 + wspd_last = ob_spd(iip1) + wdir_last = ob_dir(iip1) + endif +c + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'iip1 has clock problem' + endif +c +c Handle remaining points +c ----------------------- + else +c + c_qc(ii)(1:1) = 'P' + c_qc(ii)(3:4) = 'II' + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ ii + else + indx_save(ll) = ii + knt_bad = knt_bad + 1 + endif +c + c_qc(iip1)(1:1) = 'P' + c_qc(iip1)(3:4) = 'II' + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ iip1 + else + indx_save(ll) = iip1 + knt_bad = knt_bad + 1 + last_bad = iip1 + last_bad_m1 = ii +c uwind_last = uwindp1 +c vwind_last = vwindp1 + wspd_last = ob_spd(iip1) + wdir_last = ob_dir(iip1) + endif +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'Uncategorized report' + write(io8,*) 'Rejecting both points' + endif + endif +c +c Check for unrealistic vertical speeds between ii and iip1 points +c ---------------------------------------------------------------- + elseif(iip1.ne.0.and. + $ vspdp1.ne.amiss.and. + $ (abs(vspdp1).gt.vspd_thresh.or. + $ (idt_difp1.gt.600.and. + $ abs(vspdp1).gt.vspd_thresh*2.0/3.0))) then +c +c If neighboring points not available, reject both points +c ------------------------------------------------------- + if(vspd_wo0.eq.amiss.and.vspd_wop1.eq.amiss) then +c + c_qc(ii)(1:1) = 'V' + if(c_qc(ii)(5:5).eq.'R') then + c_qc(ii)(5:5) = 'i' + else + c_qc(ii)(5:5) = 'I' + endif +c + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ ii + else + indx_save(ll) = ii + knt_bad = knt_bad + 1 + endif +c + c_qc(iip1)(1:1) = 'V' + if(c_qc(iip1)(5:5).eq.'R') then + c_qc(iip1)(5:5) = 'i' + else + c_qc(iip1)(5:5) = 'I' + endif +c + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ iip1 + else + indx_save(ll) = iip1 + knt_bad = knt_bad + 1 + last_bad = iip1 + last_bad_m1 = ii +c uwind_last = uwindp1 +c vwind_last = vwindp1 + wspd_last = ob_spd(iip1) + wdir_last = ob_dir(iip1) + endif +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Vertical speed--',vspdp1, + $ '--too high in report--',ii + write(io8,*) 'Rejecting both points' + endif +c +c Check if ii report is a position report +c (rejects not saved for second flight check) +c ------------------------------------------- + elseif(idt_difp1.le.60.and. + $ ((itype(ii).eq.i_mdcrs.and. + $ (itype(iip1).eq.i_mdcrs_asc.or. + $ itype(iip1).eq.i_mdcrs_des.or. + $ itype(iip1).eq.i_mdcrs_lvl)).or. + $ (itype(ii).eq.i_acars.and. + $ (itype(iip1).eq.i_acars_asc.or. + $ itype(iip1).eq.i_acars_des.or. + $ itype(iip1).eq.i_acars_lvl)))) then +c + c_qc(ii)(2:2) = 'I' +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + if(c_acftreg(ii)(4:5).eq.'GU'.or. + $ c_acftreg(ii)(4:5).eq.'WU') then + l_print = .false. + else + l_print = .true. + endif +c + if(l_print) then + write(io8,*) + write(io8,*) 'Vertical speed--',vspdp1, + $ '--too high in report--',ii + write(io8,*) 'Is ii a position report?' + endif +c +c Check if iip1 report is a position report +c (rejects not saved for second flight check) +c --------------------------------------------- + elseif(idt_difp1.le.60.and. + $ ((itype(iip1).eq.i_mdcrs.and. + $ (itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des.or. + $ itype(ii).eq.i_mdcrs_lvl)).or. + $ (itype(iip1).eq.i_acars.and. + $ (itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des.or. + $ itype(ii).eq.i_acars_lvl)))) then +c + c_qc(iip1)(2:2) = 'I' +c + l_ii_pspd_ok = .false. +c + if(c_acftreg(iip1)(4:5).eq.'GU'.or. + $ c_acftreg(iip1)(4:5).eq.'WU') then + l_print = .false. + else + l_print = .true. + endif +c + if(l_print) then + write(io8,*) + write(io8,*) 'Vertical speed--',vspdp1, + $ '--too high in report--',ii + write(io8,*) 'Is iip1 a position report?' + endif +cc +cc Check if ii manAIREP yielded a too-high speed +cc --------------------------------------------- +c elseif(l_ii_man_airep.and.(.not.l_iip1_man_airep)) then +cc +c c_qc(ii)(1:1) = 'V' +c if(c_qc(ii)(5:5).eq.'R') then +c c_qc(ii)(5:5) = 'i' +c else +c c_qc(ii)(5:5) = 'I' +c endif +c iob = iob + 1 +c l_ii_pspd_ok = .false. +cc +c l_print = .true. +c if(l_print) then +c write(io8,*) +c write(io8,*) 'Vertical speed--',vspdp1, +c $ '--too high in report--',ii +c write(io8,*) 'manAIREP ii does not fit' +c endif +cc +cc Check if iip1 manAIREP yielded a too-high speed +cc ----------------------------------------------- +c elseif(l_iip1_man_airep.and.(.not.l_ii_man_airep)) then +cc +c c_qc(iip1)(1:1) = 'V' +c if(c_qc(iip1)(5:5).eq.'R') then +c c_qc(iip1)(5:5) = 'i' +c else +c c_qc(iip1)(5:5) = 'I' +c endif +c l_ii_pspd_ok = .false. +cc +c l_print = .true. +c if(l_print) then +c write(io8,*) +c write(io8,*) 'Vertical speed--',vspdp1, +c $ '--too high in report--',ii +c write(io8,*) 'manAIREP iip1 does not fit' +c endif +c +c Check if iip1 and iip2 points are from a different flight +c --------------------------------------------------------- + elseif(vspd0.ne.amiss.and.vspdp2.ne.amiss.and. + $ abs(vspd0).lt.vspd_thresh*2.0/3.0.and. + $ abs(vspdp2).lt.vspd_thresh*2.0/3.0.and. + $ abs(vspd_wo0).gt.vspd_thresh*2.0/3.0.and. + $ abs(vspd_wop1).gt.vspd_thresh*2.0/3.0) then +c $ abs(vspd_wo0)-abs(vspd0).gt.50.0.and. +c $ abs(vspd_wop1)-abs(vspdp2).gt.50.0) then +c + c_qc(iip1)(1:1) = 'V' + if(c_qc(iip1)(5:5).eq.'R') then + c_qc(iip1)(5:5) = 'i' + else + c_qc(iip1)(5:5) = 'I' + endif + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ iip1 + else + indx_save(ll) = iip1 + knt_bad = knt_bad + 1 + endif +c + c_qc(iip2)(1:1) = 'V' + if(c_qc(iip2)(5:5).eq.'R') then + c_qc(iip2)(5:5) = 'i' + else + c_qc(iip2)(5:5) = 'I' + endif + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ iip2 + else + indx_save(ll) = iip2 + knt_bad = knt_bad + 1 + last_bad = iip2 + last_bad_m1 = iip1 +c uwind_last = uwindp2 +c vwind_last = vwindp2 + wspd_last = ob_spd(iip2) + wdir_last = ob_dir(iip2) + endif +c + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Vertical speed--',vspdp1, + $ '--too high in report--',ii + write(io8,*) 'iip1 and iip2 reports from new flight' + endif +c +c Check if ii is problem point by other vertical speeds +c ----------------------------------------------------- + elseif((vspd0.ne.amiss.and.vspdp2.ne.amiss.and. + $ vspd_wo0.ne.amiss.and.vspd_wop1.ne.amiss.and. + $ abs(vspdp2).lt.vspd_thresh*2.0/3.0.and. + $ (abs(vspd0).gt.vspd_thresh*2.0/3.0.or. + $ abs(vspd_wop1)-abs(vspd_wo0).gt.50.0)).or. + $ (vspd0.ne.amiss.and.vspd_wo0.ne.amiss.and. + $ abs(vspd0).gt.vspd_thresh*2.0/3.0.and. + $ abs(vspd_wo0).lt.vspd_thresh*2.0/3.0).or. + $ (vspdp2.ne.amiss.and.vspd_wop1.ne.amiss.and. + $ abs(vspdp2).lt.vspd_thresh*2.0/3.0.and. + $ abs(vspd_wop1).gt.vspd_thresh*2.0/3.0)) then +c $ abs(vspdp2).lt.vspd_thresh*2.0/3.0.and. +c $ (abs(vspd0).gt.vspd_thresh*2.0/3.0.or. +c $ abs(abs(vspd_wop1)-abs(vspd_wo0)).gt.50.0)).or. +c $ (vspd0.ne.amiss.and.vspd_wo0.ne.amiss.and. +c $ (abs(vspd0).gt.vspd_thresh*2.0/3.0.or. +c $ abs(abs(vspd0)-abs(vspd_wo0)).gt.50.0)).or. +c $ (vspdp2.ne.amiss.and.vspd_wop1.ne.amiss.and. +c $ abs(vspdp2).lt.vspd_thresh*2.0/3.0.and. +c $ (abs(vspd_wop1).gt.vspd_thresh*2.0/3.0.or. +c $ abs(abs(vspd_wop1)-abs(vspdp2)).gt.50.0))) then +c + c_qc(ii)(1:1) = 'V' + if(c_qc(ii)(5:5).eq.'R') then + c_qc(ii)(5:5) = 'i' + else + c_qc(ii)(5:5) = 'I' + endif + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ ii + else + indx_save(ll) = ii + knt_bad = knt_bad + 1 + last_bad = ii + last_bad_m1 = iim1 +c uwind_last = uwind0 +c vwind_last = vwind0 + wspd_last = ob_spd(ii) + wdir_last = ob_dir(ii) + endif +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Vertical speed--',vspdp1, + $ '--too high in report--',ii + write(io8,*) 'ii is problem point' + endif +c +c Check if iip1 is problem point by other vertical speeds +c ------------------------------------------------------- + elseif((vspd0.ne.amiss.and.vspdp2.ne.amiss.and. + $ vspd_wo0.ne.amiss.and.vspd_wop1.ne.amiss.and. + $ abs(vspd0).lt.vspd_thresh*2.0/3.0.and. + $ (abs(vspdp2).gt.vspd_thresh*2.0/3.0.or. + $ abs(vspd_wo0)-abs(vspd_wop1).gt.50.0)).or. + $ (vspdp2.ne.amiss.and.vspd_wop1.ne.amiss.and. + $ (abs(vspdp2).gt.vspd_thresh*2.0/3.0.and. + $ abs(vspd_wop1).lt.vspd_thresh*2.0/3.0)).or. + $ (vspd0.ne.amiss.and.vspd_wo0.ne.amiss.and. + $ abs(vspd0).lt.vspd_thresh*2.0/3.0.and. + $ abs(vspd_wo0).gt.vspd_thresh*2.0/3.0)) then +c $ abs(vspd0).lt.vspd_thresh*2.0/3.0.and. +c $ (abs(vspdp2).gt.vspd_thresh*2.0/3.0.or. +c $ abs(abs(vspd_wo0)-abs(vspd_wop1)).gt.50.0)).or. +c $ (vspdp2.ne.amiss.and.vspd_wop1.ne.amiss.and. +c $ (abs(vspdp2).gt.vspd_thresh*2.0/3.0.or. +c $ abs(abs(vspdp2)-abs(vspd_wop1)).gt.50.0)).or. +c $ (vspd0.ne.amiss.and.vspd_wo0.ne.amiss.and. +c $ abs(vspd0).lt.vspd_thresh*2.0/3.0.and. +c $ (abs(vspd_wo0).gt.vspd_thresh*2.0/3.0.or. +c $ abs(abs(vspd_wo0)-abs(vspd0)).gt.50.0))) then +c + c_qc(iip1)(1:1) = 'V' + if(c_qc(iip1)(5:5).eq.'R') then + c_qc(iip1)(5:5) = 'i' + else + c_qc(iip1)(5:5) = 'I' + endif + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ iip1 + else + indx_save(ll) = iip1 + knt_bad = knt_bad + 1 + last_bad = iip1 + last_bad_m1 = ii +c uwind_last = uwindp1 +c vwind_last = vwindp1 + wspd_last = ob_spd(iip1) + wdir_last = ob_dir(iip1) + endif +c + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Vertical speed--',vspdp1, + $ '--too high in report--',ii + write(io8,*) 'iip1 is problem point' + endif +c +c Handle remaining points +c ----------------------- + else +c + c_qc(ii)(1:1) = 'V' + if(c_qc(ii)(5:5).eq.'R') then + c_qc(ii)(5:5) = 'i' + else + c_qc(ii)(5:5) = 'I' + endif +c + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ ii + else + indx_save(ll) = ii + knt_bad = knt_bad + 1 + endif +c + c_qc(iip1)(1:1) = 'V' + if(c_qc(iip1)(5:5).eq.'R') then + c_qc(iip1)(5:5) = 'i' + else + c_qc(iip1)(5:5) = 'I' + endif +c + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ iip1 + else + indx_save(ll) = iip1 + knt_bad = knt_bad + 1 + last_bad = iip1 + last_bad_m1 = ii +c uwind_last = uwindp1 +c vwind_last = vwindp1 + wspd_last = ob_spd(iip1) + wdir_last = ob_dir(iip1) + endif +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Vertical speed--',vspdp1, + $ '--too high in report--',ii + write(io8,*) 'Uncategorized report' + write(io8,*) 'Rejecting both points' + endif + endif +c +c Check if neighboring points are not available +c If so, skip remaining tests +c --------------------------------------------------- + elseif(iim1.eq.0.and.iip2.eq.0) then +c + c_qc(ii)(11:11) = 'I' + if(iip1.ne.0) c_qc(iip1)(11:11) = 'I' + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Neighboring points not available',ii + endif +c + elseif(iim2.eq.0.and.iip1.eq.0) then +c + if(iim1.ne.0) c_qc(iim1)(11:11) = 'I' + c_qc(ii)(11:11) = 'I' + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Neighboring points not available',ii + endif +c +c Check for anomalous points at the beginnings of ascents +c ------------------------------------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ (iim1.eq.0.or. + $ (iim1.ne.0.and.idt_dif0.gt.idt_near)).and. + $ idt_difp2.ne.imiss.and.idt_difp2.le.idt_updn.and. + $ idt_difp1.ne.imiss.and.idt_difp1.le.idt_updn.and. + $ ht_ft0.lt.10000.0.and. + $ abs(ht_difp1).gt.htdif_same/2.0.and. + $ ht_ft0 .gt.ht_ftp1.and. + $ ht_ftp1.lt.ht_ftp2) then +c + if(c_qc(ii)(5:5).eq.'R') then + c_qc(ii)(5:5) = 'i' + else + c_qc(ii)(5:5) = 'I' + endif + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Anomalous point before ascent' + endif +c +c Check for anomalous points at the ends of descents +c -------------------------------------------------- + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ (iip1.eq.0.or. + $ (iip1.ne.0.and.idt_difp1.gt.idt_near)).and. + $ idt_difm1.ne.imiss.and.idt_difm1.le.idt_updn.and. + $ idt_dif0.ne.imiss.and.idt_dif0.le.idt_updn.and. + $ ht_ft0.lt.10000.0.and. + $ abs(ht_dif0).gt.htdif_same/2.0.and. + $ ht_ftm2.gt.ht_ftm1.and. + $ ht_ftm1.lt.ht_ft0 ) then +c + if(c_qc(ii)(5:5).eq.'R') then + c_qc(ii)(5:5) = 'i' + else + c_qc(ii)(5:5) = 'I' + endif + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Anomalous point after descent' + endif +c +c Check for isolated off-track points at beginning of track +c Use ii, iip1, iip2 points +c --------------------------------------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ (iim1.eq.0.or. + $ idt_dif0.eq.imiss.or. + $ (idt_dif0.ne.imiss.and. + $ ((.not.(l_ii_man_airep.and.l_iim1_man_airep).and. + $ idt_dif0.gt.idt_near*2).or. + $ (l_ii_man_airep.and.l_iim1_man_airep.and. + $ idt_dif0.gt.idt_near*4)))).and. + $ (idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near*2.or. + $ (l_ii_man_airep.and.l_iip1_man_airep.and. + $ idt_difp1.le.idt_near*4))).and. + $ (idt_difp2.ne.imiss.and. + $ (idt_difp2.le.idt_near*2.or. + $ (l_iip1_man_airep.and.l_iip2_man_airep.and. + $ idt_difp2.le.idt_near*4))).and. + $ pdirp1.ne.amiss.and. + $ pdirp2.ne.amiss.and. + $ pdirp3.ne.amiss.and. + $ pdir_wop2.ne.amiss.and. + $ distp2.gt.50.0.and. + $ distp3.gt.50.0.and. + $ distp2.gt.dist_wop2.and. + $ distp3.gt.dist_wop2.and. + $ cos((pdirp1-pdirp2)*d2r).lt.0.5.and. + $ ((cos((pdirp2-pdirp3 )*d2r).lt.-0.5.and. + $ cos((pdirp1-pdir_wop2)*d2r).gt.0.5).or. +c $ (cos((pdirp2-pdirp3 )*d2r).lt.0.25881904.and. + $ cos((pdirp1-pdir_wop2)*d2r).gt.0.70710678)) then +c + c_qc(iip2)(1:1) = 'O' + c_qc(iip2)(3:4) = 'II' +c + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Isolated off-track pt--iip2 = ',iip2 + endif +c + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ (iim1.eq.0.or. + $ idt_dif0.eq.imiss.or. + $ (idt_dif0.ne.imiss.and. + $ ((.not.(l_ii_man_airep.and.l_iim1_man_airep).and. + $ idt_dif0.gt.idt_near*2).or. + $ (l_ii_man_airep.and.l_iim1_man_airep.and. + $ idt_dif0.gt.idt_near*4)))).and. + $ (idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near*2.or. + $ (l_ii_man_airep.and.l_iip1_man_airep.and. + $ idt_difp1.le.idt_near*4))).and. + $ (idt_difp2.ne.imiss.and. + $ (idt_difp2.le.idt_near*2.or. + $ (l_iip1_man_airep.and.l_iip2_man_airep.and. + $ idt_difp2.le.idt_near*4))).and. + $ pdir0 .ne.amiss.and. + $ pdirp1.ne.amiss.and. + $ pdirp2.ne.amiss.and. + $ pdir_wop1.ne.amiss.and. + $ distp1.gt.50.0.and. + $ distp2.gt.50.0.and. + $ distp1.gt.dist_wop1.and. + $ distp2.gt.dist_wop1.and. + $ ((cos((pdirp1-pdirp2 )*d2r).lt.-0.5.and. + $ cos((pdir0 -pdir_wop1)*d2r).gt.0.5).or. +c $ (cos((pdirp1-pdirp2 )*d2r).lt.0.25881904.and. + $ cos((pdir0 -pdir_wop1)*d2r).gt.0.70710678)) then +c + c_qc(iip1)(1:1) = 'O' + c_qc(iip1)(3:4) = 'II' +c + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Isolated off-track pt--iip1 = ',iip1 + endif +c +c Check for isolated off-track points in middle of track +c Use iim1, ii, iip1 points +c ------------------------------------------------------ + elseif(iim1.ne.0.and.iip1.ne.0.and.iip2.ne.0.and. + $ (idt_dif0.ne.imiss.and. + $ (idt_dif0 .le.idt_near*2.or. + $ (l_ii_man_airep.and.l_iim1_man_airep.and. + $ idt_dif0 .le.idt_near*4))).and. + $ (idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near*2.or. + $ (l_ii_man_airep.and.l_iip1_man_airep.and. + $ idt_difp1.le.idt_near*4))).and. + $ pdir0 .ne.amiss.and. + $ pdirp1.ne.amiss.and. + $ pdirm1.ne.amiss.and. + $ pdir_wo0.ne.amiss.and. + $ dist0.gt.50.0.and. + $ distp1.gt.50.0.and. + $ dist0.gt.dist_wo0.and. + $ distp1.gt.dist_wo0.and. + $ ((cos((pdir0 -pdirp1 )*d2r).lt.-0.5.and. + $ cos((pdirm1-pdir_wo0)*d2r).gt.0.5).or. +c $ (cos((pdir0 -pdirp1 )*d2r).lt.0.25881904.and. + $ cos((pdirm1-pdir_wo0)*d2r).gt.0.70710678)) then +c + c_qc(ii)(1:1) = 'O' + c_qc(ii)(3:4) = 'II' +c + iob = iob - 1 + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Isolated off-track pt--ii = ',ii + endif +c +c Increment counters if no errors are found +c ----------------------------------------- + else + iob = iob + 1 + l_ii_pspd_ok = .false. + endif +c +c Write reports used in testing if desired +c ---------------------------------------- + if(l_print) then + write(io8,'(a18,2i6,a18,2i6)') + $ ' iistart,iiend = ',iistart,iiend, + $ ' iifirst,iilast = ',iifirst,iilast + write(io8,'('' '',12a10)') + $ 'iim2','iim1','ii','wo0', + $ 'iip1','wop1','iip2','wop2','iip3', + $ 'bad0','badp1','track' + write(io8,'(''indices'',3i10,3(10x,i10))') + $ iim2,iim1,ii, + $ iip1,iip2,iip3 + write(io8,'(''dist = '',12f10.2)') + $ distm2,distm1,dist0,dist_wo0, + $ distp1,dist_wop1,distp2,dist_wop2,distp3, + $ dist_bad0,dist_badp1,dist_track +c write(io8,'(''udis = '',12f10.2)') +c $ udistm2/1000.,udistm1/1000.,udist0/1000., +c $ udist_wo0/1000.,udistp1/1000.,udist_wop1/1000., +c $ udistp2/1000.,udist_wop2/1000.,udistp3/1000., +c $ udist_bad0/1000.,udist_badp1/1000.,udist_track/1000. +c write(io8,'(''vdis = '',12f10.2)') +c $ vdistm2/1000.,vdistm1/1000.,vdist0/1000., +c $ vdist_wo0/1000.,vdistp1/1000.,vdist_wop1/1000., +c $ vdistp2/1000.,vdist_wop2/1000.,vdistp3/1000., +c $ vdist_bad0/1000.,vdist_badp1/1000.,vdist_track/1000. + write(io8,'(''ht_d = '',12f10.2)') + $ ht_difm2,ht_difm1,ht_dif0,ht_dif_wo0, + $ ht_difp1,ht_dif_wop1,ht_difp2,ht_dif_wop2,ht_difp3, + $ ht_dif_bad0,ht_dif_badp1,ht_dif_track +c write(io8,'(''uwnd = '',3f10.2,3(10x,f10.2),)') +c $ uwindm2,uwindm1,uwind0, +c $ uwindp1,uwindp2,uwindp3 +c write(io8,'(''vwnd = '',3f10.2,3(10x,f10.2),)') +c $ vwindm2,vwindm1,vwind0, +c $ vwindp1,vwindp2,vwindp3 +c write(io8,'(''upsp = '',12f10.2)') +c $ upspdm2,upspdm1,upspd0,upspd_wo0, +c $ upspdp1,upspd_wop1,upspdp2,upspd_wop2,upspdp3, +c $ upspd_bad0,upspd_badp1,upspd_track +c write(io8,'(''vpsp = '',12f10.2)') +c $ vpspdm2,vpspdm1,vpspd0,vpspd_wo0, +c $ vpspdp1,vpspd_wop1,vpspdp2,vpspd_wop2,vpspdp3, +c $ vpspd_bad0,vpspd_badp1,vpspd_track + write(io8,'(''pspd = '',12f10.2)') + $ pspdm2,pspdm1,pspd0,pspd_wo0, + $ pspdp1,pspd_wop1,pspdp2,pspd_wop2,pspdp3, + $ pspd_bad0,pspd_badp1,pspd_track + write(io8,'(''pdir = '',12f10.2)') + $ pdirm2,pdirm1,pdir0,pdir_wo0, + $ pdirp1,pdir_wop1,pdirp2,pdir_wop2,pdirp3, + $ pdir_bad0,pdir_badp1,pdir_track +c write(io8,'(''uair = '',12f10.2)') +c $ uairspdm2,uairspdm1,uairspd0,uairspd_wo0, +c $ uairspdp1,uairspd_wop1,uairspdp2,uairspd_wop2, +c $ uairspdp3,uairspd_bad0,uairspd_badp1,uairspd_track +c write(io8,'(''vair = '',12f10.2)') +c $ vairspdm2,vairspdm1,vairspd0,vairspd_wo0, +c $ vairspdp1,vairspd_wop1,vairspdp2,vairspd_wop2, +c $ vairspdp3,vairspd_bad0,vairspd_badp1,vairspd_track + write(io8,'(''aspd = '',12f10.2)') + $ airspdm2,airspdm1,airspd0,airspd_wo0, + $ airspdp1,airspd_wop1,airspdp2,airspd_wop2,airspdp3, + $ airspd_bad0,airspd_badp1,airspd_track +c write(io8,'(''adir = '',12f10.2)') +c $ airdirm2,airdirm1,airdir0,airdir_wo0, +c $ airdirp1,airdir_wop1,airdirp2,airdir_wop2,airdirp3, +c $ airdir_bad0,airdir_badp1,airdir_track + write(io8,'(''vspd = '',12f10.2)') + $ vspdm2,vspdm1,vspd0,vspd_wo0, + $ vspdp1,vspd_wop1,vspdp2,vspd_wop2,vspdp3, + $ vspd_bad0,vspd_badp1,vspd_track +c + if(iim2.ne.0) then + write(io8,8002) kk,iim2 + x, c_insty_ob(itype(iim2)) + x, c_acftreg(iim2),c_acftid(iim2) + x, idt(iim2),alat(iim2),alon(iim2) + x, pres(iim2),ht_ft(iim2) + x, t_prcn(iim2),ob_t(iim2),xiv_t(iim2),ichk_t(iim2) + x, ob_q(iim2),xiv_q(iim2),ichk_q(iim2) + x, ob_dir(iim2),xiv_d(iim2),ichk_d(iim2) + x, ob_spd(iim2),xiv_s(iim2),ichk_s(iim2) + x, c_qc(iim2) + endif +c + if(iim1.ne.0) then + write(io8,8002) kk,iim1 + x, c_insty_ob(itype(iim1)) + x, c_acftreg(iim1),c_acftid(iim1) + x, idt(iim1),alat(iim1),alon(iim1) + x, pres(iim1),ht_ft(iim1) + x, t_prcn(iim1),ob_t(iim1),xiv_t(iim1),ichk_t(iim1) + x, ob_q(iim1),xiv_q(iim1),ichk_q(iim1) + x, ob_dir(iim1),xiv_d(iim1),ichk_d(iim1) + x, ob_spd(iim1),xiv_s(iim1),ichk_s(iim1) + x, c_qc(iim1) + endif +c + write(io8,8002) kk,ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) +c + if(iip1.ne.0) then + write(io8,8002) kk,iip1 + x, c_insty_ob(itype(iip1)) + x, c_acftreg(iip1),c_acftid(iip1) + x, idt(iip1),alat(iip1),alon(iip1) + x, pres(iip1),ht_ft(iip1) + x, t_prcn(iip1),ob_t(iip1),xiv_t(iip1),ichk_t(iip1) + x, ob_q(iip1),xiv_q(iip1),ichk_q(iip1) + x, ob_dir(iip1),xiv_d(iip1),ichk_d(iip1) + x, ob_spd(iip1),xiv_s(iip1),ichk_s(iip1) + x, c_qc(iip1) + endif +c + if(iip2.ne.0) then + write(io8,8002) kk,iip2 + x, c_insty_ob(itype(iip2)) + x, c_acftreg(iip2),c_acftid(iip2) + x, idt(iip2),alat(iip2),alon(iip2) + x, pres(iip2),ht_ft(iip2) + x, t_prcn(iip2),ob_t(iip2),xiv_t(iip2),ichk_t(iip2) + x, ob_q(iip2),xiv_q(iip2),ichk_q(iip2) + x, ob_dir(iip2),xiv_d(iip2),ichk_d(iip2) + x, ob_spd(iip2),xiv_s(iip2),ichk_s(iip2) + x, c_qc(iip2) + endif +c + 8002 format(i4,1x,i6,1x,a8,1x,a8,1x,a9,1x,i7,1x,2f11.5,1x + x, f8.1,1x,f7.0 + x, 1x,f5.2,4(2(1x,f8.2),1x,i5),1x,'!',a11,'!') + endif +c +c Retest flight if specified +c -------------------------- + if(l_retest) goto 5500 +c + endif + enddo +c +c If second flight found, save indices +c Don't save indices for stuck clock segments +c Don't redo check +c ------------------------------------------- + ii = indx(istart) +c + if(knt_bad.gt.3.and. + $ .not.l_stuck.and. + $ c_acftid(ii)(9:9).ne.'z') then +c + write(io8,*) + write(io8,*) 'Second flight found--',knt_bad,'--reports' +c +c Consolidate first flight +c ------------------------ + ll = 0 + keep = istart-1 +c + do iob=istart,iend + ii = indx(iob) +c +c If report rejected... +c --------------------- + if(c_qc(ii)(3:4).eq.'II'.or. + $ c_qc(ii)(5:5).eq.'I'.or. + $ c_qc(ii)(5:5).eq.'i') then +c +c write(io8,*) 'Skipping report from 2nd flt',ii + ll = ll + 1 + indx_save(ll) = ii +c +c If report not rejected... +c ------------------------- + else +c write(io8,*) 'Keeping report from 2nd flt',ii + keep = keep + 1 + indx(keep) = indx(iob) +c + endif + enddo +c +c Save second flight +c ------------------ + istart = keep + 1 + knt_bad = ll + do ll=1,knt_bad +c + if(keep.gt.iend) then + write(io8,*) + write(io8,*) 'Keep exceeds iend!' +c + else +c write(io8,*) 'Saving report from 2nd flt', +c $ indx_save(ll) + keep = keep + 1 + indx(keep) = indx_save(ll) + ii = indx(keep) + c_acftid(ii)(9:9) = 'z' + endif + enddo +c +c Compute length of second flight +c ------------------------------- + ii = indx_save(1) + iip1 = indx_save(knt_bad) + dist_2ndflt = gcirc_qc(alat(ii ),alon(ii ), + $ alat(iip1),alon(iip1)) +c + write(io8,*) 'Second flight is ',dist_2ndflt,' m long' !!! units fixed +c +c Save second flight only if it is long enough +c -------------------------------------------- + if(dist_2ndflt.gt.100 000.0.and. +! vvvvvDAK-future change perhaps to account for incr. lat/lon precision + $ alat(ii).ne.0.0.and. + $ alat(iip1).ne.0.0) then +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c + write(io8,*) 'Re-testing second flight' + write(io8,*) +c + do ll=1,knt_bad + ii = indx_save(ll) +c +c Reset QC flags +c -------------- + if(c_qc(ii)(3:4).eq.'II') then + c_qc(ii)(1:1) = '2' + c_qc(ii)(3:4) = '..' +c + elseif(c_qc(ii)(5:5).eq.'I') then + c_qc(ii)(1:1) = '2' + c_qc(ii)(5:5) = '.' +c + elseif(c_qc(ii)(5:5).eq.'i') then + c_qc(ii)(1:1) = '2' + c_qc(ii)(5:5) = 'R' + endif +c + enddo +c +c Reset flight parameters for old flight +c -------------------------------------- + ntot_flt(kk) = ntot_flt(kk) - knt_bad +c +c Go back and re-check flight +c --------------------------- + goto 5500 +c +c Reset 9th character if second flight not saved +c ---------------------------------------------- + else + do ll=1,knt_bad + ii = indx_save(ll) + c_acftid(ii)(9:9) = ' ' + enddo +c + endif + endif +c +c Perform second scan to check for odd manuevers +c ---------------------------------------------- + iob = istart +c + knt_iob = 1 + iob_sav = 0 +c + knt_iip1_bad = 0 +c +c Loop over reports for current flight +c ------------------------------------ + do while(iob.le.iend) + l_print = .false. +c + knt0 = iob + ii = indx(iob) +c + if(iob.eq.iob_sav) then + knt_iob = knt_iob + 1 + else + iob_sav = iob + knt_iob = 1 + endif +c + if(knt_iob.gt.75) then + write(io8,*) + write(io8,*) 'Too many reps with the same iob',iob + write(io8,*) ' Sorted index ii = ',ii + write(io8,*) ' Number of reps = ',knt_iob + iob = iob + 1 + knt_iip1_bad = 0 + iob_sav = iob + knt_iob = 1 +c +c elseif(knt_iob.gt.10) then +c write(io8,*) +c write(io8,*) 'More than 10 reps with same iob',iob +c write(io8,*) 'knt_iob = ',knt_iob +c write(io8,'(a18,2i6,a18,2i6)') +c $ ' iistart,iiend = ',iistart,iiend, +c $ ' iifirst,iilast = ',iifirst,iilast +c write(io8,'(7x,12a10)') +c $ 'iim2','iim1','ii','wo0', +c $ 'iip1','wop1','iip2','wop2','iip3', +c $ 'bad0','badp1','track' +c write(io8,'(''indices'',3i10,3(10x,i10))') +c $ iim2,iim1,ii, +c $ iip1,iip2,iip3 +c write(io8,'(''dist = '',12f10.2)') +c $ distm2,distm1,dist0,dist_wo0, +c $ distp1,dist_wop1,distp2,dist_wop2,distp3, +c $ dist_bad0,dist_badp1,dist_track +c write(io8,'(''ht_d = '',12f10.2)') +c $ ht_difm2,ht_difm1,ht_dif0,ht_dif_wo0, +c $ ht_difp1,ht_dif_wop1,ht_difp2,ht_dif_wop2,ht_difp3, +c $ ht_dif_bad0,ht_dif_badp1,ht_dif_track +c write(io8,'(''pspd = '',12f10.2)') +c $ pspdm2,pspdm1,pspd0,pspd_wo0, +c $ pspdp1,pspd_wop1,pspdp2,pspd_wop2,pspdp3, +c $ pspd_bad0,pspd_badp1,pspd_track +c write(io8,'(''pdir = '',12f10.2)') +c $ pdirm2,pdirm1,pdir0,pdir_wo0, +c $ pdirp1,pdir_wop1,pdirp2,pdir_wop2,pdirp3, +c $ pdir_bad0,pdir_badp1,pdir_track +c +c if(iim2.ne.0) then +c write(io8,8002) kk,iim2 +c x, c_insty_ob(itype(iim2)) +c x, c_acftreg(iim2),c_acftid(iim2) +c x, idt(iim2),alat(iim2),alon(iim2) +c x, pres(iim2),ht_ft(iim2) +c x, t_prcn(iim2),ob_t(iim2),xiv_t(iim2),ichk_t(iim2) +c x, ob_q(iim2),xiv_q(iim2),ichk_q(iim2) +c x, ob_dir(iim2),xiv_d(iim2),ichk_d(iim2) +c x, ob_spd(iim2),xiv_s(iim2),ichk_s(iim2) +c x, c_qc(iim2) +c endif +c +c if(iim1.ne.0) then +c write(io8,8002) kk,iim1 +c x, c_insty_ob(itype(iim1)) +c x, c_acftreg(iim1),c_acftid(iim1) +c x, idt(iim1),alat(iim1),alon(iim1) +c x, pres(iim1),ht_ft(iim1) +c x, t_prcn(iim1),ob_t(iim1),xiv_t(iim1),ichk_t(iim1) +c x, ob_q(iim1),xiv_q(iim1),ichk_q(iim1) +c x, ob_dir(iim1),xiv_d(iim1),ichk_d(iim1) +c x, ob_spd(iim1),xiv_s(iim1),ichk_s(iim1) +c x, c_qc(iim1) +c endif +cc +c write(io8,8002) kk,ii,c_insty_ob(itype(ii)) +c x, c_acftreg(ii),c_acftid(ii) +c x, idt(ii),alat(ii),alon(ii) +c x, pres(ii),ht_ft(ii) +c x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) +c x, ob_q(ii),xiv_q(ii),ichk_q(ii) +c x, ob_dir(ii),xiv_d(ii),ichk_d(ii) +c x, ob_spd(ii),xiv_s(ii),ichk_s(ii) +c x, c_qc(ii) +cc +c if(iip1.ne.0) then +c write(io8,8002) kk,iip1 +c x, c_insty_ob(itype(iip1)) +c x, c_acftreg(iip1),c_acftid(iip1) +c x, idt(iip1),alat(iip1),alon(iip1) +c x, pres(iip1),ht_ft(iip1) +c x, t_prcn(iip1),ob_t(iip1),xiv_t(iip1),ichk_t(iip1) +c x, ob_q(iip1),xiv_q(iip1),ichk_q(iip1) +c x, ob_dir(iip1),xiv_d(iip1),ichk_d(iip1) +c x, ob_spd(iip1),xiv_s(iip1),ichk_s(iip1) +c x, c_qc(iip1) +c endif +cc +c if(iip2.ne.0) then +c write(io8,8002) kk,iip2 +c x, c_insty_ob(itype(iip2)) +c x, c_acftreg(iip2),c_acftid(iip2) +c x, idt(iip2),alat(iip2),alon(iip2) +c x, pres(iip2),ht_ft(iip2) +c x, t_prcn(iip2),ob_t(iip2),xiv_t(iip2),ichk_t(iip2) +c x, ob_q(iip2),xiv_q(iip2),ichk_q(iip2) +c x, ob_dir(iip2),xiv_d(iip2),ichk_d(iip2) +c x, ob_spd(iip2),xiv_s(iip2),ichk_s(iip2) +c x, c_qc(iip2) +c endif +c + endif +c +c Go to next report if ii index is invalid +c ---------------------------------------- + if(c_qc(ii)(1:1).eq.'d'.or. + $ c_qc(ii)(2:2).eq.'I'.or. + $ c_qc(ii)(2:2).eq.'K'.or. + $ c_qc(ii)(3:4).eq.'II'.or. + $ c_qc(ii)(5:5).eq.'I'.or. + $ c_qc(ii)(5:5).eq.'i'.or. + $ c_qc(ii)(11:11).eq.'I') then +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .false. + if(l_print) then + write(io8,*) 'Index invalid: ii = ',ii + endif +c +c Check out ordering etc for valid indices +c ---------------------------------------- + else +c +c Compute ii-1 index +c if(iob.gt.istart) iim1 = indx(iob-1) +c -------------------------------------- + iim1 = 0 + knt1 = iob - 1 +111 if(knt1.ge.istart) then + iim1 = indx(knt1) + if(c_qc(iim1)(1:1).eq.'d'.or. + $ c_qc(iim1)(2:2).eq.'I'.or. + $ c_qc(iim1)(2:2).eq.'K'.or. + $ c_qc(iim1)(3:4).eq.'II'.or. + $ c_qc(iim1)(5:5).eq.'I'.or. + $ c_qc(iim1)(5:5).eq.'i'.or. + $ c_qc(ii)(11:11).eq.'I') then + knt1 = knt1 - 1 + goto 111 + endif + else + iim1 = 0 + endif +c +c Compute ii-2 index +c if(iob.gt.istart+1) iim2 = indx(iob-2) +c -------------------------------------- + iim2 = 0 + knt2 = knt1 - 1 +121 if(knt2.ge.istart) then + iim2 = indx(knt2) + if(c_qc(iim2)(1:1).eq.'d'.or. + $ c_qc(iim2)(2:2).eq.'I'.or. + $ c_qc(iim2)(2:2).eq.'K'.or. + $ c_qc(iim2)(3:4).eq.'II'.or. + $ c_qc(iim2)(5:5).eq.'I'.or. + $ c_qc(iim2)(5:5).eq.'i'.or. + $ c_qc(ii)(11:11).eq.'I') then + knt2 = knt2 - 1 + goto 121 + endif + else + iim2 = 0 + endif +c +c Compute ii-3 index +c if(iob.gt.istart+2) iim3 = indx(iob-3) +c -------------------------------------- + iim3 = 0 + knt5 = knt2 - 1 +131 if(knt5.ge.istart) then + iim3 = indx(knt5) + if(c_qc(iim3)(1:1).eq.'d'.or. + $ c_qc(iim3)(2:2).eq.'I'.or. + $ c_qc(iim3)(2:2).eq.'K'.or. + $ c_qc(iim3)(3:4).eq.'II'.or. + $ c_qc(iim3)(5:5).eq.'I'.or. + $ c_qc(iim3)(5:5).eq.'i'.or. + $ c_qc(ii)(11:11).eq.'I') then + knt5 = knt5 - 1 + goto 131 + endif + else + iim3 = 0 + endif +c +c Compute ii+1 index +c if(iob.lt.iend) iip1 = indx(iob+1) +c ------------------------------------ + iip1 = 0 + iobp1 = 0 + knt3 = iob + 1 +141 if(knt3.le.iend) then + iip1 = indx(knt3) + iobp1 = knt3 + if(c_qc(iip1)(1:1).eq.'d'.or. + $ c_qc(iip1)(2:2).eq.'I'.or. + $ c_qc(iip1)(2:2).eq.'K'.or. + $ c_qc(iip1)(3:4).eq.'II'.or. + $ c_qc(iip1)(5:5).eq.'I'.or. + $ c_qc(iip1)(5:5).eq.'i'.or. + $ c_qc(ii)(11:11).eq.'I') then + knt3 = knt3 + 1 + goto 141 + endif + else + iip1 = 0 + iobp1 = 0 + endif +c +c Compute ii+2 index +c if(iob.lt.iend-1) iip2 = indx(iob+2) +c ------------------------------------ + iip2 = 0 + iobp2 = 0 + knt4 = knt3 + 1 +151 if(knt4.le.iend) then + iip2 = indx(knt4) + iobp2 = knt4 + if(c_qc(iip2)(1:1).eq.'d'.or. + $ c_qc(iip2)(2:2).eq.'I'.or. + $ c_qc(iip2)(2:2).eq.'K'.or. + $ c_qc(iip2)(3:4).eq.'II'.or. + $ c_qc(iip2)(5:5).eq.'I'.or. + $ c_qc(iip2)(5:5).eq.'i'.or. + $ c_qc(ii)(11:11).eq.'I') then + knt4 = knt4 + 1 + goto 151 + endif + else + iip2 = 0 + iobp2 = 0 + endif +c +c Compute ii+3 index +c if(iob.lt.iend-2) iip3 = indx(iob+3) +c ------------------------------------ + iip3 = 0 + knt6 = knt4 + 1 +161 if(knt6.le.iend) then + iip3 = indx(knt6) + if(c_qc(iip3)(1:1).eq.'d'.or. + $ c_qc(iip3)(2:2).eq.'I'.or. + $ c_qc(iip3)(2:2).eq.'K'.or. + $ c_qc(iip3)(3:4).eq.'II'.or. + $ c_qc(iip3)(5:5).eq.'I'.or. + $ c_qc(iip3)(5:5).eq.'i'.or. + $ c_qc(ii)(11:11).eq.'I') then + knt6 = knt6 + 1 + goto 161 + endif + else + iip3 = 0 + endif +c +c Determine if reports are manual AIREPs +c -------------------------------------- + l_ii_man_airep = .false. + if(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) l_ii_man_airep = .true. +c + l_iim1_man_airep = .false. + if(iim1.ne.0) then + if(itype(iim1).eq.i_man_airep.or. + $ itype(iim1).eq.i_man_Yairep) l_iim1_man_airep = .true. + endif +c + l_iim2_man_airep = .false. + if(iim2.ne.0) then + if(itype(iim2).eq.i_man_airep.or. + $ itype(iim2).eq.i_man_Yairep) l_iim2_man_airep = .true. + endif +c + l_iim3_man_airep = .false. + if(iim3.ne.0) then + if(itype(iim3).eq.i_man_airep.or. + $ itype(iim3).eq.i_man_Yairep) l_iim3_man_airep = .true. + endif +c + l_iip1_man_airep = .false. + if(iip1.ne.0) then + if(itype(iip1).eq.i_man_airep.or. + $ itype(iip1).eq.i_man_Yairep) l_iip1_man_airep = .true. + endif +c + l_iip2_man_airep = .false. + if(iip2.ne.0) then + if(itype(iip2).eq.i_man_airep.or. + $ itype(iip2).eq.i_man_Yairep) l_iip2_man_airep = .true. + endif +c +c Set up temporary variables for ii point +c --------------------------------------- + itype0 = itype(ii) + alat0 = alat(ii) + alon0 = alon(ii) + ht_ft0 = ht_ft(ii) + idt0 = idt(ii) +c +c if(c_qc(ii)(7:8).ne.'..') then +c uwind0 = amiss +c vwind0 = amiss +c else +c uwind0 = -sin(ob_dir(ii)*d2r)*ob_spd(ii) +c vwind0 = -cos(ob_dir(ii)*d2r)*ob_spd(ii) +c endif +c +c Set up temporary variables for iim1 point +c ----------------------------------------- + if(iim1.ne.0) then + itypem1 = itype(iim1) + alatm1 = alat(iim1) + alonm1 = alon(iim1) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alon0.lt.90.0.and.alonm1.gt.270.0) + $ alonm1 = 360.0 - alonm1 + if(alon0.gt.270.0.and.alonm1.lt.90.0) + $ alonm1 = 360.0 + alonm1 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftm1 = ht_ft(iim1) + idtm1 = idt(iim1) +c +c if(c_qc(iim1)(7:8).ne.'..') then +c uwindm1 = amiss +c vwindm1 = amiss +c else +c uwindm1 = -sin(ob_dir(iim1)*d2r)*ob_spd(iim1) +c vwindm1 = -cos(ob_dir(iim1)*d2r)*ob_spd(iim1) +c endif +c +c Compute groundspeed vector components between ii and iim1 points +c ---------------------------------------------------------------- + if(idt0.ne.imiss.and.idtm1.ne.imiss) then + idt_dif0 = abs(idt0 - idtm1) + else + idt_dif0 = imiss + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alat0 .ne.amiss.and.alon0 .ne.amiss.and. + $ alatm1.ne.amiss.and.alonm1.ne.amiss.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ idt_dif0.ne.imiss) then + udist0 = gcirc_qc(alat(iim1),alon(iim1), + $ alat(iim1),alon(ii )) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alon(ii)-alon(iim1))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ udist0 = -udist0 + vdist0 = gcirc_qc(alat(iim1),alon(iim1), + $ alat(ii ),alon(iim1)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alat(ii)-alat(iim1))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ vdist0 = -vdist0 + dist0 = gcirc_qc(alat(iim1),alon(iim1), + $ alat(ii ),alon(ii )) + if(idt_dif0.gt.0) then + upspd0 = udist0 / float(idt_dif0) + vpspd0 = vdist0 / float(idt_dif0) + pspd0 = dist0 / float(idt_dif0) + else + upspd0 = udist0 / float(idt_dif0+60) + vpspd0 = vdist0 / float(idt_dif0+60) + pspd0 = dist0 / float(idt_dif0+60) + endif + if(upspd0.eq.0.0.and.vpspd0.eq.0.0) then + pdir0 = 0.0 + else + pdir0 = atan2(upspd0,vpspd0) / d2r + 180.0 + endif + dist0 = dist0 / 1000.0 + else + udist0 = amiss + vdist0 = amiss + dist0 = amiss + upspd0 = amiss + vpspd0 = amiss + pspd0 = amiss + pdir0 = amiss + endif +c + if(ht_ft(ii).ne.amiss.and.ht_ft(iim1).ne.amiss) then + ht_dif0 = ht_ft(ii) - ht_ft(iim1) + else + ht_dif0 = amiss + endif +c + else + itypem1 = imiss +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + alatm1 = amiss + alonm1 = amiss +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftm1 = amiss + idtm1 = amiss +c uwindm1 = amiss +c vwindm1 = amiss +c + idt_dif0 = imiss + udist0 = amiss + vdist0 = amiss + dist0 = amiss + upspd0 = amiss + vpspd0 = amiss + pspd0 = amiss + pdir0 = amiss +c + ht_dif0 = amiss + endif +c +c Set up temporary variables for iim2 point +c ----------------------------------------- + if(iim2.ne.0) then + alatm2 = alat(iim2) + alonm2 = alon(iim2) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alon0.lt.90.0.and.alonm2.gt.270.0) + $ alonm2 = 360.0 - alonm2 + if(alon0.gt.270.0.and.alonm2.lt.90.0) + $ alonm2 = 360.0 + alonm2 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftm2 = ht_ft(iim2) + idtm2 = idt(iim2) +c +c if(c_qc(iim2)(7:8).ne.'..') then +c uwindm2 = amiss +c vwindm2 = amiss +c else +c uwindm2 = -sin(ob_dir(iim2)*d2r)*ob_spd(iim2) +c vwindm2 = -cos(ob_dir(iim2)*d2r)*ob_spd(iim2) +c endif +c +c Compute groundspeed vector components between iim2 and iim1 points +c ------------------------------------------------------------------ + if(idtm1.ne.imiss.and.idtm2.ne.imiss) then + idt_difm1 = abs(idtm1 - idtm2) + else + idt_difm1 = imiss + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alatm2.ne.amiss.and.alonm2.ne.amiss.and. + $ alatm1.ne.amiss.and.alonm1.ne.amiss.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ idt_difm1.ne.imiss) then + udistm1 = gcirc_qc(alat(iim2),alon(iim2), + $ alat(iim2),alon(iim1)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alon(iim1)-alon(iim2))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ udistm1 = -udistm1 + vdistm1 = gcirc_qc(alat(iim2),alon(iim2), + $ alat(iim1),alon(iim2)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alat(iim1)-alat(iim2))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ vdistm1 = -vdistm1 + distm1 = gcirc_qc(alat(iim2),alon(iim2), + $ alat(iim1),alon(iim1)) + if(idt_difm1.gt.0) then + upspdm1 = udistm1 / float(idt_difm1) + vpspdm1 = vdistm1 / float(idt_difm1) + pspdm1 = distm1 / float(idt_difm1) + else + upspdm1 = udistm1 / float(idt_difm1+60) + vpspdm1 = vdistm1 / float(idt_difm1+60) + pspdm1 = distm1 / float(idt_difm1+60) + endif + if(upspdm1.eq.0.0.and.vpspdm1.eq.0.0) then + pdirm1 = 0.0 + else + pdirm1 = atan2(upspdm1,vpspdm1) / d2r + 180.0 + endif + distm1 = distm1 / 1000.0 + else + udistm1 = amiss + vdistm1 = amiss + distm1 = amiss + upspdm1 = amiss + vpspdm1 = amiss + pspdm1 = amiss + pdirm1 = amiss + endif +c + if(ht_ft(iim2).ne.amiss.and.ht_ft(iim1).ne.amiss) then + ht_difm1 = ht_ft(iim1) - ht_ft(iim2) + else + ht_difm1 = amiss + endif +c + else +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + alatm2 = amiss + alonm2 = amiss +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftm2 = amiss + idtm2 = amiss +c uwindm2 = amiss +c vwindm2 = amiss +c + idt_difm1 = imiss + udistm1 = amiss + vdistm1 = amiss + distm1 = amiss + upspdm1 = amiss + vpspdm1 = amiss + pspdm1 = amiss + pdirm1 = amiss +c + ht_difm1 = amiss + endif +c +c Set up temporary variables for iim3 point +c ----------------------------------------- + if(iim3.ne.0) then + alatm3 = alat(iim3) + alonm3 = alon(iim3) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alon0.lt.90.0.and.alonm3.gt.270.0) + $ alonm3 = 360.0 - alonm3 + if(alon0.gt.270.0.and.alonm3.lt.90.0) + $ alonm3 = 360.0 + alonm3 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftm3 = ht_ft(iim3) + idtm3 = idt(iim3) +c +c if(c_qc(iim3)(7:8).ne.'..') then +c uwindm3 = amiss +c vwindm3 = amiss +c else +c uwindm3 = -sin(ob_dir(iim3)*d2r)*ob_spd(iim3) +c vwindm3 = -cos(ob_dir(iim3)*d2r)*ob_spd(iim3) +c endif +c +c Compute groundspeed vector components between iim3 and iim2 points +c ------------------------------------------------------------------ + if(idtm2.ne.imiss.and.idtm3.ne.imiss) then + idt_difm2 = abs(idtm2 - idtm3) + else + idt_difm2 = imiss + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alatm3.ne.amiss.and.alonm3.ne.amiss.and. + $ alatm2.ne.amiss.and.alonm2.ne.amiss.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ idt_difm2.ne.imiss) then + udistm2 = gcirc_qc(alat(iim3),alon(iim3), + $ alat(iim3),alon(iim2)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alon(iim2)-alon(iim3))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ udistm2 = -udistm2 + vdistm2 = gcirc_qc(alat(iim3),alon(iim3), + $ alat(iim2),alon(iim3)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alat(iim2)-alat(iim3))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ vdistm2 = -vdistm2 + distm2 = gcirc_qc(alat(iim3),alon(iim3), + $ alat(iim2),alon(iim2)) + if(idt_difm2.gt.0) then + upspdm2 = udistm2 / float(idt_difm2) + vpspdm2 = vdistm2 / float(idt_difm2) + pspdm2 = distm2 / float(idt_difm2) + else + upspdm2 = udistm2 / float(idt_difm2+60) + vpspdm2 = vdistm2 / float(idt_difm2+60) + pspdm2 = distm2 / float(idt_difm2+60) + endif + if(upspdm2.eq.0.0.and.vpspdm2.eq.0.0) then + pdirm2 = 0.0 + else + pdirm2 = atan2(upspdm2,vpspdm2) / d2r + 180.0 + endif + distm2 = distm2 / 1000.0 + else + udistm2 = amiss + vdistm2 = amiss + distm2 = amiss + upspdm2 = amiss + vpspdm2 = amiss + pspdm2 = amiss + pdirm2 = amiss + endif +c + if(ht_ft(iim3).ne.amiss.and.ht_ft(iim2).ne.amiss) then + ht_difm2 = ht_ft(iim2) - ht_ft(iim3) + else + ht_difm2 = amiss + endif +c + else +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + alatm3 = amiss + alonm3 = amiss +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftm3 = amiss + idtm3 = amiss +c uwindm3 = amiss +c vwindm3 = amiss +c + idt_difm2 = imiss + udistm2 = amiss + vdistm2 = amiss + distm2 = amiss + upspdm2 = amiss + vpspdm2 = amiss + pspdm2 = amiss + pdirm2 = amiss +c + ht_difm2 = amiss + endif +c +c Set up temporary variables for iip1 point +c ----------------------------------------- + if(iip1.ne.0) then + itypep1 = itype(iip1) + alatp1 = alat(iip1) + alonp1 = alon(iip1) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alon0.lt.90.0.and.alonp1.gt.270.0) + $ alonp1 = 360.0 - alonp1 + if(alon0.gt.270.0.and.alonp1.lt.90.0) + $ alonp1 = 360.0 + alonp1 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftp1 = ht_ft(iip1) + idtp1 = idt(iip1) +c +c if(c_qc(iip1)(7:8).ne.'..') then +c uwindp1 = amiss +c vwindp1 = amiss +c else +c uwindp1 = -sin(ob_dir(iip1)*d2r)*ob_spd(iip1) +c vwindp1 = -cos(ob_dir(iip1)*d2r)*ob_spd(iip1) +c endif +c +c Compute groundspeed vector components between ii and iip1 points +c ---------------------------------------------------------------- + if(idt0.ne.imiss.and.idtp1.ne.imiss) then + idt_difp1 = abs(idt0 - idtp1) + else + idt_difp1 = imiss + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alat0 .ne.amiss.and.alon0 .ne.amiss.and. + $ alatp1.ne.amiss.and.alonp1.ne.amiss.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ idt_difp1.ne.imiss) then + udistp1 = gcirc_qc(alat(ii ),alon(ii ), + $ alat(ii ),alon(iip1)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alon(iip1)-alon(ii))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ udistp1 = -udistp1 + vdistp1 = gcirc_qc(alat(ii ),alon(ii ), + $ alat(iip1),alon(ii )) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alat(iip1)-alat(ii))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ vdistp1 = -vdistp1 + distp1 = gcirc_qc(alat(ii ),alon(ii ), + $ alat(iip1),alon(iip1)) + if(idt_difp1.gt.0) then + upspdp1 = udistp1 / float(idt_difp1) + vpspdp1 = vdistp1 / float(idt_difp1) + pspdp1 = distp1 / float(idt_difp1) + else + upspdp1 = udistp1 / float(idt_difp1+60) + vpspdp1 = vdistp1 / float(idt_difp1+60) + pspdp1 = distp1 / float(idt_difp1+60) + endif + if(upspdp1.eq.0.0.and.vpspdp1.eq.0.0) then + pdirp1 = 0.0 + else + pdirp1 = atan2(upspdp1,vpspdp1) / d2r + 180.0 + endif + distp1 = distp1 / 1000.0 + else + udistp1 = amiss + vdistp1 = amiss + distp1 = amiss + upspdp1 = amiss + vpspdp1 = amiss + pspdp1 = amiss + pdirp1 = amiss + endif +c + if(ht_ft(ii).ne.amiss.and.ht_ft(iip1).ne.amiss) then + ht_difp1 = ht_ft(iip1) - ht_ft(ii) + else + ht_difp1 = amiss + endif +c + else + itypep1 = imiss +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + alatp1 = amiss + alonp1 = amiss +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftp1 = amiss + idtp1 = amiss +c uwindp1 = amiss +c vwindp1 = amiss +c + idt_difp1 = imiss + udistp1 = amiss + vdistp1 = amiss + distp1 = amiss + upspdp1 = amiss + vpspdp1 = amiss + pspdp1 = amiss + pdirp1 = amiss +c + ht_difp1 = amiss + endif +c +c Set up temporary variables for iip2 point +c ----------------------------------------- + if(iip2.ne.0) then + itypep2 = itype(iip2) + alatp2 = alat(iip2) + alonp2 = alon(iip2) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alon0.lt.90.0.and.alonp2.gt.270.0) + $ alonp2 = 360.0 - alonp2 + if(alon0.gt.270.0.and.alonp2.lt.90.0) + $ alonp2 = 360.0 + alonp2 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftp2 = ht_ft(iip2) + idtp2 = idt(iip2) +c +c if(c_qc(iip2)(7:8).ne.'..') then +c uwindp2 = amiss +c vwindp2 = amiss +c else +c uwindp2 = -sin(ob_dir(iip2)*d2r)*ob_spd(iip2) +c vwindp2 = -cos(ob_dir(iip2)*d2r)*ob_spd(iip2) +c endif + else +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + alatp2 = amiss + alonp2 = amiss +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftp2 = amiss + idtp2 = amiss +c uwindp2 = amiss +c vwindp2 = amiss + endif +c + if(iip2.ne.0.and.iip1.ne.0) then +c +c Compute groundspeed vector components between iip1 and iip2 points +c ------------------------------------------------------------------ + if(idtp1.ne.imiss.and.idtp2.ne.imiss) then + idt_difp2 = abs(idtp1 - idtp2) + else + idt_difp2 = imiss + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alatp1.ne.amiss.and.alonp1.ne.amiss.and. + $ alatp2.ne.amiss.and.alonp2.ne.amiss.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ idt_difp2.ne.imiss) then + udistp2 = gcirc_qc(alat(iip1),alon(iip1), + $ alat(iip1),alon(iip2)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alon(iip2)-alon(iip1))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ udistp2 = -udistp2 + vdistp2 = gcirc_qc(alat(iip1),alon(iip1), + $ alat(iip2),alon(iip1)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alat(iip2)-alat(iip1))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ vdistp2 = -vdistp2 + distp2 = gcirc_qc(alat(iip1),alon(iip1), + $ alat(iip2),alon(iip2)) + if(idt_difp2.gt.0) then + upspdp2 = udistp2 / float(idt_difp2) + vpspdp2 = vdistp2 / float(idt_difp2) + pspdp2 = distp2 / float(idt_difp2) + else + upspdp2 = udistp2 / float(idt_difp2+60) + vpspdp2 = vdistp2 / float(idt_difp2+60) + pspdp2 = distp2 / float(idt_difp2+60) + endif + if(upspdp2.eq.0.0.and.vpspdp2.eq.0.0) then + pdirp2 = 0.0 + else + pdirp2 = atan2(upspdp2,vpspdp2) / d2r + 180.0 + endif + distp2 = distp2 / 1000.0 + else + udistp2 = amiss + vdistp2 = amiss + distp2 = amiss + upspdp2 = amiss + vpspdp2 = amiss + pspdp2 = amiss + pdirp2 = amiss + endif +c + if(ht_ft(iip1).ne.amiss.and.ht_ft(iip2).ne.amiss) then + ht_difp2 = ht_ft(iip2) - ht_ft(iip1) + else + ht_difp2 = amiss + endif +c + else + idt_difp2 = imiss + udistp2 = amiss + vdistp2 = amiss + distp2 = amiss + upspdp2 = amiss + vpspdp2 = amiss + pspdp2 = amiss + pdirp2 = amiss +c + ht_difp2 = amiss + endif +c +c Set up temporary variables for iip3 point +c ----------------------------------------- + if(iip3.ne.0) then + alatp3 = alat(iip3) + alonp3 = alon(iip3) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alon0.lt.90.0.and.alonp3.gt.270.0) + $ alonp3 = 360.0 - alonp3 + if(alon0.gt.270.0.and.alonp3.lt.90.0) + $ alonp3 = 360.0 + alonp3 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftp3 = ht_ft(iip3) + idtp3 = idt(iip3) +c +c if(c_qc(iip3)(7:8).ne.'..') then +c uwindp3 = amiss +c vwindp3 = amiss +c else +c uwindp3 = -sin(ob_dir(iip3)*d2r)*ob_spd(iip3) +c vwindp3 = -cos(ob_dir(iip3)*d2r)*ob_spd(iip3) +c endif + else +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + alatp3 = amiss + alonp3 = amiss +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftp3 = amiss + idtp3 = amiss +c uwindp3 = amiss +c vwindp3 = amiss + endif +c + if(iip3.ne.0.and.iip2.ne.0) then +c +c Compute groundspeed vector components between iip2 and iip3 points +c ------------------------------------------------------------------ + if(idtp2.ne.imiss.and.idtp3.ne.imiss) then + idt_difp3 = abs(idtp2 - idtp3) + else + idt_difp3 = imiss + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alatp2.ne.amiss.and.alonp2.ne.amiss.and. + $ alatp3.ne.amiss.and.alonp3.ne.amiss.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ idt_difp3.ne.imiss) then + udistp3 = gcirc_qc(alat(iip2),alon(iip2), + $ alat(iip2),alon(iip3)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alon(iip3)-alon(iip2))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ udistp3 = -udistp3 + vdistp3 = gcirc_qc(alat(iip2),alon(iip2), + $ alat(iip3),alon(iip2)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alat(iip3)-alat(iip2))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ vdistp3 = -vdistp3 + distp3 = gcirc_qc(alat(iip2),alon(iip2), + $ alat(iip3),alon(iip3)) + if(idt_difp3.gt.0) then + upspdp3 = udistp3 / float(idt_difp3) + vpspdp3 = vdistp3 / float(idt_difp3) + pspdp3 = distp3 / float(idt_difp3) + else + upspdp3 = udistp3 / float(idt_difp3+60) + vpspdp3 = vdistp3 / float(idt_difp3+60) + pspdp3 = distp3 / float(idt_difp3+60) + endif + if(upspdp3.eq.0.0.and.vpspdp3.eq.0.0) then + pdirp3 = 0.0 + else + pdirp3 = atan2(upspdp3,vpspdp3) / d2r + 180.0 + endif + distp3 = distp3 / 1000.0 + else + udistp3 = amiss + vdistp3 = amiss + distp3 = amiss + upspdp3 = amiss + vpspdp3 = amiss + pspdp3 = amiss + pdirp3 = amiss + endif +c + if(ht_ft(iip2).ne.amiss.and.ht_ft(iip3).ne.amiss) then + ht_difp3 = ht_ft(iip3) - ht_ft(iip2) + else + ht_difp3 = amiss + endif +c + else + idt_difp3 = imiss + udistp3 = amiss + vdistp3 = amiss + distp3 = amiss + upspdp3 = amiss + vpspdp3 = amiss + pspdp3 = amiss + pdirp3 = amiss +c + ht_difp3 = amiss + endif +c +c Compute speeds without ii report +c -------------------------------- + if(iim1.ne.0.and. + $ idtp1.ne.amiss.and.idtm1.ne.amiss) then +c +c Compute groundspeed vector components between iim1 and iip1 points +c ------------------------------------------------------------------ + if(idtm1.ne.imiss.and.idtp1.ne.imiss) then + idt_dif_wo0 = abs(idtp1 - idtm1) + else + idt_dif_wo0 = imiss + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alatm1.ne.amiss.and.alonm1.ne.amiss.and. + $ alatp1.ne.amiss.and.alonp1.ne.amiss.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ idt_dif_wo0.ne.imiss) then + udist_wo0 = gcirc_qc(alat(iim1),alon(iim1), + $ alat(iim1),alon(iip1)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alon(iip1)-alon(iim1))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ udist_wo0 = -udist_wo0 + vdist_wo0 = gcirc_qc(alat(iim1),alon(iim1), + $ alat(iip1),alon(iim1)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alat(iip1)-alat(iim1))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ vdist_wo0 = -vdist_wo0 + dist_wo0 = gcirc_qc(alat(iim1),alon(iim1), + $ alat(iip1),alon(iip1)) + if(idt_dif_wo0.gt.0) then + upspd_wo0 = udist_wo0 / float(idt_dif_wo0) + vpspd_wo0 = vdist_wo0 / float(idt_dif_wo0) + pspd_wo0 = dist_wo0 / float(idt_dif_wo0) + else + upspd_wo0 = udist_wo0 / float(idt_dif_wo0+60) + vpspd_wo0 = vdist_wo0 / float(idt_dif_wo0+60) + pspd_wo0 = dist_wo0 / float(idt_dif_wo0+60) + endif + if(upspd_wo0.eq.0.0.and.vpspd_wo0.eq.0.0) then + pdir_wo0 = 0.0 + else + pdir_wo0 = atan2(upspd_wo0,vpspd_wo0) + $ / d2r + 180.0 + endif + dist_wo0 = dist_wo0 / 1000.0 + else + udist_wo0 = amiss + vdist_wo0 = amiss + dist_wo0 = amiss + upspd_wo0 = amiss + vpspd_wo0 = amiss + pspd_wo0 = amiss + pdir_wo0 = amiss + endif +c + else + udist_wo0 = amiss + vdist_wo0 = amiss + dist_wo0 = amiss + upspd_wo0 = amiss + vpspd_wo0 = amiss + pspd_wo0 = amiss + pdir_wo0 = amiss + endif +c + if(ht_ftp1.ne.amiss.and.ht_ftm1.ne.amiss) then + ht_dif_wo0 = ht_ftp1 - ht_ftm1 + else + ht_dif_wo0 = amiss + endif +c +c Compute speeds without iip1 report +c ---------------------------------- + if(iip2.ne.0.and. + $ idt0.ne.amiss.and.idtp2.ne.amiss) then +c +c Compute groundspeed vector components between ii and iip2 points +c ---------------------------------------------------------------- + if(idt0.ne.imiss.and.idtp2.ne.imiss) then + idt_dif_wop1 = abs(idtp2 - idt0) + else + idt_dif_wop1 = imiss + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alat0 .ne.amiss.and.alon0 .ne.amiss.and. + $ alatp2.ne.amiss.and.alonp2.ne.amiss.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ idt_dif_wop1.ne.imiss) then + udist_wop1 = gcirc_qc(alat(ii ),alon(ii ), + $ alat(ii ),alon(iip2)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alon(iip2)-alon(ii))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ udist_wop1 = -udist_wop1 + vdist_wop1 = gcirc_qc(alat(ii ),alon(ii ), + $ alat(iip2),alon(ii )) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alat(iip2)-alat(ii))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ vdist_wop1 = -vdist_wop1 + dist_wop1 = gcirc_qc(alat(ii ),alon(ii ), + $ alat(iip2),alon(iip2)) + if(idt_dif_wop1.gt.0) then + upspd_wop1 = udist_wop1 / float(idt_dif_wop1) + vpspd_wop1 = vdist_wop1 / float(idt_dif_wop1) + pspd_wop1 = dist_wop1 / float(idt_dif_wop1) + else + upspd_wop1 = udist_wop1 / float(idt_dif_wop1+60) + vpspd_wop1 = vdist_wop1 / float(idt_dif_wop1+60) + pspd_wop1 = dist_wop1 / float(idt_dif_wop1+60) + endif + if(upspd_wop1.eq.0.0.and.vpspd_wop1.eq.0.0) then + pdir_wop1 = 0.0 + else + pdir_wop1 = atan2(upspd_wop1,vpspd_wop1) + $ / d2r + 180.0 + endif + dist_wop1 = dist_wop1 / 1000.0 + else + udist_wop1 = amiss + vdist_wop1 = amiss + dist_wop1 = amiss + upspd_wop1 = amiss + vpspd_wop1 = amiss + pspd_wop1 = amiss + pdir_wop1 = amiss + endif +c + else + udist_wop1 = amiss + vdist_wop1 = amiss + dist_wop1 = amiss + upspd_wop1 = amiss + vpspd_wop1 = amiss + pspd_wop1 = amiss + pdir_wop1 = amiss + endif +c + if(ht_ftp2.ne.amiss.and.ht_ft0.ne.amiss) then + ht_dif_wop1 = ht_ft(iip2) - ht_ft(ii) + else + ht_dif_wop1 = amiss + endif +c +c Compute speeds without iip2 report +c ---------------------------------- + if(iip3.ne.0.and. + $ idtp1.ne.amiss.and.idtp3.ne.amiss) then +c +c Compute groundspeed vector components between iip1 and iip3 points +c ------------------------------------------------------------------ + if(idtp1.ne.imiss.and.idtp3.ne.imiss) then + idt_dif_wop2 = abs(idtp3 - idtp1) + else + idt_dif_wop2 = imiss + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alatp1.ne.amiss.and.alonp1.ne.amiss.and. + $ alatp3.ne.amiss.and.alonp3.ne.amiss.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ idt_dif_wop2.ne.imiss) then + udist_wop2 = gcirc_qc(alat(iip1),alon(iip1), + $ alat(iip1),alon(iip3)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alon(iip3)-alon(iip1))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ udist_wop2 = -udist_wop2 + vdist_wop2 = gcirc_qc(alat(iip1),alon(iip1), + $ alat(iip3),alon(iip1)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alat(iip3)-alat(iip1))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ vdist_wop2 = -vdist_wop2 + dist_wop2 = gcirc_qc(alat(iip1),alon(iip1), + $ alat(iip3),alon(iip3)) + if(idt_dif_wop2.gt.0) then + upspd_wop2 = udist_wop2 / float(idt_dif_wop2) + vpspd_wop2 = vdist_wop2 / float(idt_dif_wop2) + pspd_wop2 = dist_wop2 / float(idt_dif_wop2) + else + upspd_wop2 = udist_wop2 / float(idt_dif_wop2+60) + vpspd_wop2 = vdist_wop2 / float(idt_dif_wop2+60) + pspd_wop2 = dist_wop2 / float(idt_dif_wop2+60) + endif + if(upspd_wop2.eq.0.0.and.vpspd_wop2.eq.0.0) then + pdir_wop2 = 0.0 + else + pdir_wop2 = atan2(upspd_wop2,vpspd_wop2) + $ / d2r + 180.0 + endif + dist_wop2 = dist_wop2 / 1000.0 + else + udist_wop2 = amiss + vdist_wop2 = amiss + dist_wop2 = amiss + upspd_wop2 = amiss + vpspd_wop2 = amiss + pspd_wop2 = amiss + pdir_wop2 = amiss + endif +c + else + udist_wop2 = amiss + vdist_wop2 = amiss + dist_wop2 = amiss + upspd_wop2 = amiss + vpspd_wop2 = amiss + pspd_wop2 = amiss + pdir_wop2 = amiss + endif +c + if(ht_ftp3.ne.amiss.and.ht_ftp1.ne.amiss) then + ht_dif_wop2 = ht_ftp3 - ht_ftp1 + else + ht_dif_wop2 = amiss + endif +c +c Set other variables to missing +c ------------------------------ + udist_bad0 = amiss + vdist_bad0 = amiss + dist_bad0 = amiss + upspd_bad0 = amiss + vpspd_bad0 = amiss + pspd_bad0 = amiss + pdir_bad0 = amiss +c + ht_dif_bad0 = amiss +c + idt_last_bad = imiss +c + udist_badp1 = amiss + vdist_badp1 = amiss + dist_badp1 = amiss + upspd_badp1 = amiss + vpspd_badp1 = amiss + pspd_badp1 = amiss + pdir_badp1 = amiss +c + ht_dif_badp1 = amiss +c +c Compute mean direction for current flight segment +c ------------------------------------------------- + if(iob.eq.istart.or. + $ iob.gt.ioblast.or. + $ ioblast.eq.imiss) then +c + job = iob + jjstart = ii + iifirst = ii + iobfirst = iob + iilast = iiend + ioblast = iend +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + alat_min = 9999.9 + alat_max = -9999.9 + alon_min = 9999.9 + alon_max = -9999.9 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c +c Loop over flight to find end of current segment +c ----------------------------------------------- + do while(job.le.iend) +c + jj = indx(job) + if(job.eq.iend) then + jjp1 = 0 + else + jjp1 = indx(job+1) + endif +c +c Compute distance between jj and jjstart +c --------------------------------------- + dist_track = gcirc_qc(alat(jjstart),alon(jjstart), + $ alat(jj ),alon(jj )) +c + dist_track = dist_track / 1000.0 +c +c Save max/min lat and lon +c ------------------------ + if(c_qc(jj)(1:1).ne.'d'.and. + $ c_qc(jj)(2:2).ne.'I'.and. + $ c_qc(jj)(2:2).ne.'K'.and. + $ c_qc(jj)(3:4).ne.'II'.and. + $ c_qc(jj)(5:5).ne.'I'.and. + $ c_qc(jj)(5:5).ne.'i'.or. + $ c_qc(ii)(11:11).eq.'I') then +c + if(alat(jj).lt.alat_min) then + alat_min = alat(jj) + job_alat_min = job + jj_alat_min = jj + endif +c + if(alat(jj).gt.alat_max) then + alat_max = alat(jj) + job_alat_max = job + jj_alat_max = jj + endif +c + if(alon(jj).lt.alon_min) then + alon_min = alon(jj) + job_alon_min = job + jj_alon_min = jj + endif +c + if(alon(jj).gt.alon_max) then + alon_max = alon(jj) + job_alon_max = job + jj_alon_max = jj + endif + endif +c +c End flight segment if significant time gap found +c ------------------------------------------------ + if(jjp1.ne.0) then + if((((.not.(l_ii_man_airep.and.l_iip1_man_airep).and. + $ (idt(jjp1)-idt(jj)).gt.idt_near).or. + $ (l_ii_man_airep.and.l_iip1_man_airep.and. + $ (idt(jjp1)-idt(jj)).gt.idt_near*2))).and. + $ dist_track.gt.100.0) then +c + iilast = jj + ioblast = job + job = iend + 1 +c + else + job = job + 1 + endif +c + else + job = job + 1 + endif + enddo +c +c End segment if significant turn is present prior to previous end of segment +c --------------------------------------------------------------------------- + if((alat_max.eq.alat(iifirst).or. + $ alat_max.eq.alat(iilast)).and. + $ (alat_min.eq.alat(iifirst).or. + $ alat_min.eq.alat(iilast))) then +c + if((alon_max.eq.alon(iifirst).or. + $ alon_max.eq.alon(iilast)).and. + $ (alon_min.eq.alon(iifirst).or. + $ alon_min.eq.alon(iilast))) then +c +c write(io8,*) +c write(io8,*) 'Latitude max/min at start/end',kk +c write(io8,*) 'Longitude max/min at start/end of flt' +c write(io8,*) 'Segment endpoints not altered' +c + elseif(job_alon_max.ge.iobfirst.and. + $ job_alon_max.le.ioblast) then +c + dist_track = gcirc_qc(alat(iifirst),alon_max, + $ alat(iifirst),alon(iifirst)) + dist_track = dist_track / 1000.0 +c + if(dist_track.gt.100.0) then +c + ioblast = job_alon_max + iilast = jj_alon_max +c write(io8,*) +c write(io8,*) 'Latitude max/min at start/end',kk +c write(io8,*) 'Ending segment at longitude max' +c write(io8,*) 'ioblast = ',ioblast +c +c else +c write(io8,*) +c write(io8,*) 'Latitude max/min at start/end',kk +c write(io8,*) 'Longitude difference too small' +c write(io8,*) 'Segment endpoints not altered' + endif +c + elseif(job_alon_min.ge.iobfirst.and. + $ job_alon_min.le.ioblast) then +c + dist_track = gcirc_qc(alat(iifirst),alon_min, + $ alat(iifirst),alon(iifirst)) + dist_track = dist_track / 1000.0 +c + if(dist_track.gt.100.0) then +c + ioblast = job_alon_min + iilast = jj_alon_min +c write(io8,*) +c write(io8,*) 'Latitude max/min at start/end',kk +c write(io8,*) 'Ending segment at longitude min' +c write(io8,*) 'ioblast = ',ioblast +c +c else +c write(io8,*) +c write(io8,*) 'Latitude max/min at start/end',kk +c write(io8,*) 'Longitude difference too small' +c write(io8,*) 'Segment endpoints not altered' + endif +c + else + write(io8,*) + write(io8,*) 'Latitude max/min at start/end',kk + write(io8,*) 'Longitude min/max not handled' + write(io8,*) 'Segment endpoints not altered' + endif +c + elseif((alon_max.eq.alon(iifirst).or. + $ alon_max.eq.alon(iilast)).and. + $ (alon_min.eq.alon(iifirst).or. + $ alon_min.eq.alon(iilast))) then +c + if((alat_max.eq.alat(iifirst).or. + $ alat_max.eq.alat(iilast)).and. + $ (alat_min.eq.alat(iifirst).or. + $ alat_min.eq.alat(iilast))) then +c +c write(io8,*) +c write(io8,*) 'Lon max/min at start/end',kk +c write(io8,*) 'Latitude max/min at start/end of flt' +c write(io8,*) 'Segment endpoints not altered' +c + elseif(job_alat_max.ge.iobfirst.and. + $ job_alat_max.le.ioblast) then +c + dist_track = gcirc_qc(alat_max ,alon(iifirst), + $ alat(iifirst),alon(iifirst)) + dist_track = dist_track / 1000.0 +c + if(dist_track.gt.100.0) then +c + ioblast = job_alat_max + iilast = jj_alat_max +c write(io8,*) +c write(io8,*) 'Lon max/min at start/end',kk +c write(io8,*) 'Ending segment at latitude max' +c write(io8,*) 'ioblast = ',ioblast +c +c else +c write(io8,*) +c write(io8,*) 'Lon max/min at start/end',kk +c write(io8,*) 'Latitude difference too small' +c write(io8,*) 'Segment endpoints not altered' + endif +c + elseif(job_alat_min.ge.iobfirst.and. + $ job_alat_min.le.ioblast) then +c + dist_track = gcirc_qc(alat_min ,alon(iifirst), + $ alat(iifirst),alon(iifirst)) + dist_track = dist_track / 1000.0 +c + if(dist_track.gt.100.0) then +c + ioblast = job_alat_min + iilast = jj_alat_min +c write(io8,*) +c write(io8,*) 'Lon max/min at start/end',kk +c write(io8,*) 'Ending segment at latitude min' +c write(io8,*) 'ioblast = ',ioblast +c +c else +c write(io8,*) +c write(io8,*) 'Lon max/min at start/end',kk +c write(io8,*) 'Latitude difference too small' +c write(io8,*) 'Segment endpoints not altered' + endif +c + else + write(io8,*) + write(io8,*) 'Lon max/min at start/end',kk + write(io8,*) 'Longitude min/max not handled' + write(io8,*) 'Segment endpoints not altered' + endif +c + else +c + if(job_alat_max.ge.iobfirst.and. + $ job_alat_max.le.ioblast) then +c + dist_track = gcirc_qc(alat_max ,alon(iifirst), + $ alat(iifirst),alon(iifirst)) + dist_track = dist_track / 1000.0 +c + if(dist_track.gt.100.0) then +c + ioblast = job_alat_max + iilast = jj_alat_max +c write(io8,*) +c write(io8,*) 'Ending segment at latitude max',kk +c write(io8,*) 'ioblast = ',ioblast +c +c else +c write(io8,*) +c write(io8,*) 'Latitude difference too small' +c write(io8,*) 'Segment endpoints not altered' + endif + endif +c + if(job_alat_min.ge.iobfirst.and. + $ job_alat_min.le.ioblast) then +c + dist_track = gcirc_qc(alat_min ,alon(iifirst), + $ alat(iifirst),alon(iifirst)) + dist_track = dist_track / 1000.0 +c + if(dist_track.gt.100.0) then +c + ioblast = job_alat_min + iilast = jj_alat_min +c write(io8,*) +c write(io8,*) 'Ending segment at latitude min',kk +c write(io8,*) 'ioblast = ',ioblast +c +c else +c write(io8,*) +c write(io8,*) 'Latitude difference too small' +c write(io8,*) 'Segment endpoints not altered' + endif + endif +c + if(job_alon_max.ge.iobfirst.and. + $ job_alon_max.le.ioblast) then +c + dist_track = gcirc_qc(alat(iifirst),alon_max, + $ alat(iifirst),alon(iifirst)) + dist_track = dist_track / 1000.0 +c + if(dist_track.gt.100.0) then +c + ioblast = job_alon_max + iilast = jj_alon_max +c write(io8,*) +c write(io8,*) 'Ending segment at longitude max',kk +c write(io8,*) 'ioblast = ',ioblast +c +c else +c write(io8,*) +c write(io8,*) 'Longitude difference too small' +c write(io8,*) 'Segment endpoints not altered' + endif + endif +c + if(job_alon_min.ge.iobfirst.and. + $ job_alon_min.le.ioblast) then +c + dist_track = gcirc_qc(alat(iifirst),alon_min, + $ alat(iifirst),alon(iifirst)) + dist_track = dist_track / 1000.0 +c + if(dist_track.gt.100.0) then +c + ioblast = job_alon_min + iilast = jj_alon_min +c write(io8,*) +c write(io8,*) 'Ending segment at longitude min',kk +c write(io8,*) 'ioblast = ',ioblast +c +c else +c write(io8,*) +c write(io8,*) 'Longitude difference too small' +c write(io8,*) 'Segment endpoints not altered' + endif + endif + endif +c +c Compute speeds for current flight segment +c ----------------------------------------- + if(iifirst.ne.0.and.iilast.ne.0) then +c + idt_start = idt(iifirst) + idt_end = idt(iilast) +c +c if(c_qc(iifirst)(7:8).ne.'..') then +c uwind_start = amiss +c vwind_start = amiss +c else +c uwind_start = -sin(ob_dir(iifirst)*d2r) +c $ *ob_spd(iifirst) +c vwind_start = -cos(ob_dir(iifirst)*d2r) +c $ *ob_spd(iifirst) +c endif +c if(c_qc(iilast)(7:8).ne.'..') then +c uwind_end = amiss +c vwind_end = amiss +c else +c uwind_end = -sin(ob_dir(iilast)*d2r)*ob_spd(iilast) +c vwind_end = -cos(ob_dir(iilast)*d2r)*ob_spd(iilast) +c endif +c +c Compute groundspeed vector components for current flight segment +c ---------------------------------------------------------------- + if(idt_start.ne.imiss.and. + $ idt_end .ne.imiss) then + idt_dif_track = abs(idt_end - idt_start) + else + idt_dif_track = imiss + endif +c +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alat(iifirst).ne.amiss.and. + $ alon(iifirst).ne.amiss.and. + $ alat(iilast) .ne.amiss.and. + $ alon(iilast) .ne.amiss.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ idt_dif_track.ne.imiss) then +c + udist_track = gcirc_qc(alat(iilast),alon(iilast), + $ alat(iilast),alon(iifirst)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alon(iilast)-alon(iifirst))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ udist_track = -udist_track + vdist_track = gcirc_qc(alat(iilast),alon(iilast), + $ alat(iifirst),alon(iilast)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alat(iilast)-alat(iifirst))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ vdist_track = -vdist_track + dist_track = gcirc_qc(alat(iilast),alon(iilast), + $ alat(iifirst),alon(iifirst)) + if(idt_dif_track.gt.0) then + upspd_track = udist_track / float(idt_dif_track) + vpspd_track = vdist_track / float(idt_dif_track) + pspd_track = dist_track / float(idt_dif_track) + else + upspd_track= udist_track / float(idt_dif_track+60) + vpspd_track= vdist_track / float(idt_dif_track+60) + pspd_track = dist_track / float(idt_dif_track+60) + endif + if(upspd_track.eq.0.0.and.vpspd_track.eq.0.0) then + pdir_track = 0.0 + else + pdir_track = atan2(upspd_track,vpspd_track) + $ / d2r + 180.0 + endif + dist_track = dist_track / 1000.0 +c + else + udist_track = amiss + vdist_track = amiss + dist_track = amiss + upspd_track = amiss + vpspd_track = amiss + pspd_track = amiss + pdir_track = amiss + endif +c +c Compute vertical speed for current flight segment +c ------------------------------------------------- + if(ht_ft(iilast).ne.amiss.and. + $ ht_ft(iifirst).ne.amiss) then + ht_dif_track = ht_ft(iilast) - ht_ft(iifirst) + else + ht_dif_track = amiss + endif +c + else + idt_start = imiss + idt_end = imiss +c + udist_track = amiss + vdist_track = amiss + dist_track = amiss + upspd_track = amiss + vpspd_track = amiss + pspd_track = amiss + pdir_track = amiss +c + ht_dif_track = amiss + endif + endif +c +c Check if neighboring points are not available +c If so, skip remaining tests +c --------------------------------------------------- + if(iim1.eq.0.and.iip2.eq.0) then +c + c_qc(ii)(11:11) = 'I' + if(iip1.ne.0) c_qc(iip1)(11:11) = 'I' +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Neighboring points not available',ii + endif +c + elseif(iim2.eq.0.and.iip1.eq.0) then +c + if(iim1.ne.0) c_qc(iim1)(11:11) = 'I' + c_qc(ii)(11:11) = 'I' +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Neighboring points not available',ii + endif +c +c Check beginning of ascents and descents with low-level manuevers +c ---------------------------------------------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ (iim1.eq.0.or. + $ idt_dif0.eq.imiss.or. + $ (idt_dif0.ne.imiss.and. + $ ((.not.(l_ii_man_airep.and.l_iim1_man_airep).and. + $ idt_dif0.gt.idt_near).or. + $ (l_ii_man_airep.and.l_iim1_man_airep.and. + $ idt_dif0.gt.idt_near*2)))).and. + $ (idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.l_iip1_man_airep.and. + $ idt_difp1.le.idt_near*2))).and. + $ (idt_difp2.ne.imiss.and. + $ (idt_difp2.le.idt_near.or. + $ (l_iip1_man_airep.and.l_iip2_man_airep.and. + $ idt_difp2.le.idt_near*2))).and. + $ (cos((pdirp1-pdirp2)*d2r).gt.0.0.or. + $ (distp1.lt.55.0.and. + $ distp2.lt.55.0.and. + $ abs(ht_difp1).lt.4000.0.and. + $ abs(ht_difp2).lt.4000.0.and. + $ abs(ht_difp1).ge.htdif_same*1.5.and. + $ abs(ht_difp2).ge.htdif_same*1.5).or. + $ ((distp1.lt.15.0.and. + $ abs(ht_difp1).lt.1500.0.and. + $ abs(ht_difp1).ge.htdif_same*0.5).or. + $ (distp2.lt.15.0.and. + $ abs(ht_difp2).lt.1500.0.and. + $ abs(ht_difp2).ge.htdif_same*0.5))).and. + $ ht_ft0.lt.21000.0.and. + $ ((ht_ft0 .lt.ht_ftp1.and. + $ ht_ftp1.lt.ht_ftp2).or. + $ (ht_ft0 .gt.ht_ftp1.and. + $ ht_ftp1.gt.ht_ftp2).or. + $ ((ht_ft0 .lt.ht_ftp1.or. + $ ht_ft0 .gt.ht_ftp1).and. + $ abs(ht_difp2).lt.htdif_same*1.5).or. + $ (abs(ht_difp1).lt.htdif_same*1.5.and. + $ (ht_ftp1.lt.ht_ftp2.or. + $ ht_ftp1.gt.ht_ftp2)).or. + $ (abs(ht_difp1).lt.htdif_same*1.5.and. + $ abs(ht_difp2).lt.htdif_same*1.5))) then +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Low-level manuever ok at 1st pt',ii + endif +c +c Check middle of ascents and descents with low-level manuevers +c ------------------------------------------------------------- + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ (idt_dif0.ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.l_iim1_man_airep.and. + $ idt_dif0 .le.idt_near*2))).and. + $ (idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.l_iip1_man_airep.and. + $ idt_difp1.le.idt_near*2))).and. + $ (cos((pdir0-pdirp1)*d2r).gt.0.0.or. + $ (dist0 .lt.55.0.and. + $ distp1.lt.55.0.and. + $ abs(ht_dif0) .lt.4000.0.and. + $ abs(ht_difp1).lt.4000.0.and. + $ abs(ht_dif0) .ge.htdif_same*1.5.and. + $ abs(ht_difp1).ge.htdif_same*1.5).or. + $ ((dist0 .lt.15.0.and. + $ abs(ht_dif0) .lt.2000.0.and. + $ abs(ht_dif0) .ge.htdif_same*0.5).or. + $ (distp1.lt.15.0.and. + $ abs(ht_difp1).lt.2000.0.and. + $ abs(ht_difp1).ge.htdif_same*0.5))).and. + $ (ht_ft0 .lt.21000.0.or. + $ ht_ftp1.lt.21000.0).and. + $ ((ht_ftm1.lt.ht_ft0 .and. + $ ht_ft0 .lt.ht_ftp1).or. + $ (ht_ftm1.gt.ht_ft0 .and. + $ ht_ft0 .gt.ht_ftp1).or. + $ ((ht_ftm1.lt.ht_ft0 .or. + $ ht_ftm1.gt.ht_ft0 ).and. + $ abs(ht_difp1).lt.htdif_same*1.5).or. + $ (abs(ht_dif0 ).lt.htdif_same*1.5.and. + $ (ht_ft0 .lt.ht_ftp1.or. + $ ht_ft0 .gt.ht_ftp1)).or. + $ (abs(ht_dif0 ).lt.htdif_same*1.5.and. + $ abs(ht_difp1).lt.htdif_same*1.5))) then +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Low-level manuever ok',ii + endif +c +c Check middle of ascents and descents with low-level manuevers +c ------------------------------------------------------------- + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ iip1.ne.0.and.iip2.ne.0.and. + $ (idt_difm1.ne.imiss.and. + $ (idt_difm1.le.idt_near.or. + $ (l_iim1_man_airep.and.l_iim2_man_airep.and. + $ idt_difm1.le.idt_near*2))).and. + $ (idt_dif0.ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.l_iim1_man_airep.and. + $ idt_dif0 .le.idt_near*2))).and. + $ (idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.l_iip1_man_airep.and. + $ idt_difp1.le.idt_near*2))).and. + $ (idt_difp2.ne.imiss.and. + $ (idt_difp2.le.idt_near.or. + $ (l_iip1_man_airep.and.l_iip2_man_airep.and. + $ idt_difp2.le.idt_near*2))).and. + $ (cos((pdir0-pdirp1)*d2r).gt.0.0.or. + $ (dist0 .lt.55.0.and. + $ distp1.lt.55.0.and. + $ abs(ht_dif0) .lt.4000.0.and. + $ abs(ht_difp1).lt.4000.0.and. + $ abs(ht_dif0) .ge.htdif_same*1.5.and. + $ abs(ht_difp1).ge.htdif_same*1.5).or. + $ ((dist0 .lt.15.0.and. + $ abs(ht_dif0) .lt.2000.0.and. + $ abs(ht_dif0) .ge.htdif_same*0.5).or. + $ (distp1.lt.15.0.and. + $ abs(ht_difp1).lt.2000.0.and. + $ abs(ht_difp1).ge.htdif_same*0.5))).and. + $ (ht_ft0 .lt.21000.0.or. + $ ht_ftp1.lt.21000.0).and. + $ (ht_ftm2.lt.ht_ftm1.and. + $ ht_ftm1.lt.ht_ft0 .and. + $ ht_ft0 .gt.ht_ftp1.and. + $ ht_ftp1.gt.ht_ftp2)) then +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Low-level manuever with alt max ok',ii + endif +c +c Check end of ascents and descents with low-level manuevers +c ---------------------------------------------------------- + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ (iip1.eq.0.or. + $ idt_difp1.eq.imiss.or. + $ (idt_difp1.ne.imiss.and. + $ ((.not.(l_ii_man_airep.and.l_iip1_man_airep).and. + $ idt_difp1.gt.idt_near).or. + $ (l_ii_man_airep.and.l_iip1_man_airep.and. + $ idt_difp1.gt.idt_near*2)))).and. + $ (idt_difm1.ne.imiss.and. + $ (idt_difm1.le.idt_near.or. + $ (l_iim1_man_airep.and.l_iim2_man_airep.and. + $ idt_difm1.le.idt_near*2))).and. + $ (idt_dif0 .ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.l_iim1_man_airep.and. + $ idt_dif0 .le.idt_near*2))).and. + $ (cos((pdirm1-pdir0)*d2r).gt.0.0.or. + $ (distm1.lt.55.0.and. + $ dist0.lt.55.0.and. + $ abs(ht_difm1).lt.4000.0.and. + $ abs(ht_dif0) .lt.4000.0.and. + $ abs(ht_difm1).ge.htdif_same*1.5.and. + $ abs(ht_dif0) .ge.htdif_same*1.5).or. + $ ((dist0 .lt.15.0.and. + $ abs(ht_dif0) .lt.1500.0.and. + $ abs(ht_dif0) .ge.htdif_same*0.5).or. + $ (distm1.lt.15.0.and. + $ abs(ht_difm1).lt.1500.0.and. + $ abs(ht_difm1).ge.htdif_same*0.5))).and. + $ ht_ft0.lt.21000.0.and. + $ ((ht_ftm2.lt.ht_ftm1.and. + $ ht_ftm1.lt.ht_ft0 ).or. + $ (ht_ftm2.gt.ht_ftm1.and. + $ ht_ftm1.gt.ht_ft0 ).or. + $ ((ht_ftm2.lt.ht_ftm1.or. + $ ht_ftm2.gt.ht_ftm1).and. + $ abs(ht_dif0 ).lt.htdif_same*1.5).or. + $ (abs(ht_difm1).lt.htdif_same*1.5.and. + $ (ht_ftm1.lt.ht_ft0 .or. + $ ht_ftm1.gt.ht_ft0 )).or. + $ (abs(ht_difm1).lt.htdif_same*1.5.and. + $ abs(ht_dif0 ).lt.htdif_same*1.5))) then +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Low-level manuever ok at last pt',ii + endif +c +c Check bottom points of ascents/descents with low-level manuevers +c Use iim2, iim1, ii points +c ---------------------------------------------------------------- + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ idt_difm1.ne.imiss.and.idt_difm1.le.idt_near.and. + $ idt_dif0 .ne.imiss.and.idt_dif0 .le.idt_near.and. + $ ht_ftm1.lt.21000.0.and. + $ (((iip1.eq.0.or.idt_difp1.gt.idt_near).and. + $ ht_ftm2.gt.ht_ftm1.and. + $ ht_ftm1.gt.ht_ft0.and. + $ (dist0 .lt.25.0.or. + $ cos((pdirm1-pdir0)*d2r).gt.-0.70710567)).or. + $ ((iim3.eq.0.or.idt_difm2.gt.idt_near).and. + $ ht_ftm2.lt.ht_ftm1.and. + $ ht_ftm1.lt.ht_ft0 .and. + $ (distm1.lt.25.0.or. + $ cos((pdirm1-pdir0)*d2r).gt.-0.70710567)))) then +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Bottom of ascent/descent ok-1-',ii + endif +c +c Check bottom points of ascents/descents with low-level manuevers +c Use iim1, ii, iip1 points +c ---------------------------------------------------------------- + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ idt_dif0 .ne.imiss.and.idt_dif0 .le.idt_near.and. + $ idt_difp1.ne.imiss.and.idt_difp1.le.idt_near.and. + $ ht_ft0.lt.21000.0.and. + $ (((iip2.eq.0.or.idt_difp2.gt.idt_near).and. + $ ht_ftm1.gt.ht_ft0 .and. + $ ht_ft0 .gt.ht_ftp1.and. + $ (distp1.lt.25.0.or. + $ cos((pdir0-pdirp1)*d2r).gt.-0.70710567)).or. + $ ((iim2.eq.0.or.idt_difm1.gt.idt_near).and. + $ ht_ftm1.lt.ht_ft0 .and. + $ ht_ft0 .lt.ht_ftp1.and. + $ (dist0.lt.25.0.or. + $ cos((pdir0-pdirp1)*d2r).gt.-0.70710567)))) then +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Bottom of ascent/descent ok-2-',ii + endif +c +c Check bottom points of ascents/descents with low-level manuevers +c Use ii, iip1, iip2 points +c ---------------------------------------------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ idt_difp1.ne.imiss.and.idt_difp1.le.idt_near.and. + $ idt_difp2.ne.imiss.and.idt_difp2.le.idt_near.and. + $ ht_ftp1.lt.21000.0.and. + $ (((iip3.eq.0.or.idt_difp3.gt.idt_near).and. + $ ht_ft0 .gt.ht_ftp1.and. + $ ht_ftp1.gt.ht_ftp2.and. + $ (distp2.lt.25.0.or. + $ cos((pdirp1-pdirp2)*d2r).gt.-0.70710567)).or. + $ ((iim1.eq.0.or.idt_dif0.gt.idt_near).and. + $ ht_ft0 .lt.ht_ftp1.and. + $ ht_ftp1.lt.ht_ftp2.and. + $ (distp1.lt.25.0.or. + $ cos((pdirp1-pdirp2)*d2r).gt.-0.70710567)))) then +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Bottom of ascent/descent ok-3-',ii + endif +c +c Check if first point in flight/first point in hi-res segment is good +c Use ii, iip1, iip2 points +c -------------------------------------------------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ (iim1.eq.0.or. + $ idt_dif0.ne.imiss.and.idt_dif0.gt.idt_near).and. + $ idt_difp1.ne.imiss.and.idt_difp1.le.idt_updn.and. + $ idt_difp2.ne.imiss.and.idt_difp2.le.idt_updn.and. + $ cos((pdirp1-pdirp2)*d2r).gt.0.8660254.and. + $ ((ht_ft0 .lt.ht_ftp1.and. + $ ht_ftp1.lt.ht_ftp2).or. + $ (ht_ft0 .gt.ht_ftp1.and. + $ ht_ftp1.gt.ht_ftp2).or. + $ ((ht_ft0 .lt.ht_ftp1.or. + $ ht_ft0 .gt.ht_ftp1).and. + $ abs(ht_difp2).lt.htdif_same*1.5).or. + $ (abs(ht_difp1).lt.htdif_same*1.5.and. + $ (ht_ftp1.lt.ht_ftp2.or. + $ ht_ftp1.gt.ht_ftp2)).or. + $ (abs(ht_difp1).lt.htdif_same*1.5.and. + $ abs(ht_difp2).lt.htdif_same*1.5))) then +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Hi-res time,posn agree for 1st point',ii + endif +c +c Check if middle point in hi-res segment is good +c Use iim1, ii, iip1 points +c -------------------------------------------------------------------- + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ idt_dif0 .ne.imiss.and.idt_dif0 .le.idt_updn.and. + $ idt_difp1.ne.imiss.and.idt_difp1.le.idt_updn.and. + $ cos((pdir0-pdirp1)*d2r).gt.0.8660254.and. + $ ((ht_ftm1.lt.ht_ft0 .and. + $ ht_ft0 .lt.ht_ftp1).or. + $ (ht_ftm1.gt.ht_ft0 .and. + $ ht_ft0 .gt.ht_ftp1).or. + $ ((ht_ftm1.lt.ht_ft0 .or. + $ ht_ftm1.gt.ht_ft0 ).and. + $ abs(ht_difp1).lt.htdif_same*1.5).or. + $ (abs(ht_dif0 ).lt.htdif_same*1.5.and. + $ (ht_ft0 .lt.ht_ftp1.or. + $ ht_ft0 .gt.ht_ftp1)).or. + $ (abs(ht_dif0 ).lt.htdif_same*1.5.and. + $ abs(ht_difp1).lt.htdif_same*1.5))) then +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Hi-res time,posn agree',ii + endif +c +c Check if last point in flight/last point of hi-res segment is good +c Use iim2, iim1, ii points +c ------------------------------------------------------------------ + elseif(iim1.ne.0.and.iim2.ne.0.and. + $ (iip1.eq.0.or. + $ idt_difp1.ne.imiss.and.idt_difp1.gt.idt_near).and. + $ idt_difm1.ne.imiss.and.idt_difm1.le.idt_updn.and. + $ idt_dif0.ne.imiss.and.idt_dif0.le.idt_updn.and. + $ cos((pdirm1-pdir0)*d2r).gt.0.8660254.and. + $ ((ht_ftm2.lt.ht_ftm1.and. + $ ht_ftm1.lt.ht_ft0 ).or. + $ (ht_ftm2.gt.ht_ftm1.and. + $ ht_ftm1.gt.ht_ft0 ).or. + $ ((ht_ftm2.lt.ht_ftm1.or. + $ ht_ftm2.gt.ht_ftm1).and. + $ abs(ht_dif0 ).lt.htdif_same*1.5).or. + $ (abs(ht_difm1).lt.htdif_same*1.5.and. + $ (ht_ftm1.lt.ht_ft0 .or. + $ ht_ftm1.gt.ht_ft0 )).or. + $ (abs(ht_difm1).lt.htdif_same*1.5.and. + $ abs(ht_dif0 ).lt.htdif_same*1.5))) then +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Hi-res time,posn agree for last pt',ii + endif +c +c Check if track is doubling back on itself +c Compare direction of first segment with mean direction of track +c Use ii, iip1 points +c --------------------------------------------------------------- + elseif(iip1.ne.0.and.iobp1.le.ioblast.and. + $ (idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near*2.or. + $ (l_ii_man_airep.and.l_iip1_man_airep.and. + $ idt_difp1.le.idt_near*4))).and. + $ pdirp1.ne.amiss.and. +c $ ifix(distp1*10.0).ne.0.and. + $ (.not.(distp1.lt.5.0.or. + $ (distp1.lt.15.0.and.ht_ft0.lt.10000.))).and. + $ pdir_track.ne.amiss.and. + $ dist_track.gt.100.0.and. + $ cos((pdirp1-pdir_track)*d2r).lt.-0.258819) then +c + if(ii.eq.iifirst.or. + $ (itype0.eq.i_mdcrs.and. + $ (itypep1.eq.i_mdcrs_asc.or. + $ itypep1.eq.i_mdcrs_des.or. + $ itypep1.eq.i_mdcrs_lvl)).or. + $ (itype0.eq.i_acars.and. + $ (itypep1.eq.i_acars_asc.or. + $ itypep1.eq.i_acars_des.or. + $ itypep1.eq.i_acars_lvl))) then +c + iob = iob + 1 + knt_iip1_bad = 0 +c + if(c_acftreg(ii)(4:5).eq.'GU'.or. + $ c_acftreg(ii)(4:5).eq.'WU') then + c_qc(ii)(2:2) = 'I' + l_print = .false. + else + c_qc(ii)(1:1) = 'r' + c_qc(ii)(3:4) = 'II' + l_print = .true. + endif +c + if(l_print) then + write(io8,*) + write(io8,*) '1 Pt is headed backwards ii= ',ii + endif +c + else +c + knt_iip1_bad = knt_iip1_bad + 1 +c + if((itypep1.eq.i_mdcrs.and. + $ (itype0.eq.i_mdcrs_asc.or. + $ itype0.eq.i_mdcrs_des.or. + $ itype0.eq.i_mdcrs_lvl)).or. + $ (itypep1.eq.i_acars.and. + $ (itype0.eq.i_acars_asc.or. + $ itype0.eq.i_acars_des.or. + $ itype0.eq.i_acars_lvl))) then +c + c_qc(iip1)(2:2) = 'I' +c + if(c_acftreg(iip1)(4:5).eq.'GU'.or. + $ c_acftreg(iip1)(4:5).eq.'WU') then + l_print = .false. + else + l_print = .true. + endif +c + else + c_qc(iip1)(1:1) = 'r' + c_qc(iip1)(3:4) = 'II' + l_print = .true. + endif +c + if(l_print) then + write(io8,*) + write(io8,*) '2 Pt is headed backwards iip1= ',iip1 + endif + endif +c +c Check if track is doubling back on itself +c Compare direction of first segment with mean direction of track +c Exclude allowed low-level manuevers +c Use iip1, iip2 points +c --------------------------------------------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and.iobp2.le.ioblast.and. + $ (idt_difp2.ne.imiss.and. + $ (idt_difp2.le.idt_near*2.or. + $ (l_ii_man_airep.and.l_iip1_man_airep.and. + $ idt_difp2.le.idt_near*4))).and. + $ pdirp2.ne.amiss.and. +c $ ifix(distp2*10.0).ne.0.and. + $ (.not.(distp2.lt.5.0.or. + $ (distp2.lt.15.0.and.ht_ftp1.lt.10000.))).and. + $ pdir_track.ne.amiss.and. + $ dist_track.gt.100.0.and. + $ cos((pdirp2-pdir_track)*d2r).lt.-0.258819.and. + $ .not. + $ (ht_ft0.lt.21000.0.and. + $ (cos((pdirp1-pdirp2)*d2r).gt.0.0.or. + $ (distp1.lt.55.0.and. + $ distp2.lt.55.0.and. + $ abs(ht_difp1).lt.4000.0.and. + $ abs(ht_difp2).lt.4000.0.and. + $ abs(ht_difp1).ge.htdif_same*1.5.and. + $ abs(ht_difp2).ge.htdif_same*1.5).or. + $ ((distp1.lt.15.0.and. + $ abs(ht_difp1).lt.1500.0.and. + $ abs(ht_difp1).ge.htdif_same*0.5).or. + $ (distp2.lt.15.0.and. + $ abs(ht_difp2).lt.1500.0.and. + $ abs(ht_difp2).ge.htdif_same*0.5))))) then +c + knt_iip1_bad = knt_iip1_bad + 1 +c + if((itypep1.eq.i_mdcrs.and. + $ (itypep2.eq.i_mdcrs_asc.or. + $ itypep2.eq.i_mdcrs_des.or. + $ itypep2.eq.i_mdcrs_lvl)).or. + $ (itypep1.eq.i_acars.and. + $ (itypep2.eq.i_acars_asc.or. + $ itypep2.eq.i_acars_des.or. + $ itypep2.eq.i_acars_lvl))) then +c + c_qc(iip1)(2:2) = 'I' +c + if(c_acftreg(iip1)(4:5).eq.'GU'.or. + $ c_acftreg(iip1)(4:5).eq.'WU') then + l_print = .false. + else + l_print = .true. + endif +c + if(l_print) then + write(io8,*) + write(io8,*) '3 Pt is headed backwards iip1= ',iip1 + endif +c + elseif((itypep2.eq.i_mdcrs.and. + $ (itypep1.eq.i_mdcrs_asc.or. + $ itypep1.eq.i_mdcrs_des.or. + $ itypep1.eq.i_mdcrs_lvl)).or. + $ (itypep2.eq.i_acars.and. + $ (itypep1.eq.i_acars_asc.or. + $ itypep1.eq.i_acars_des.or. + $ itypep1.eq.i_acars_lvl))) then +c + c_qc(iip2)(2:2) = 'I' +c + if(c_acftreg(iip2)(4:5).eq.'GU'.or. + $ c_acftreg(iip2)(4:5).eq.'WU') then + l_print = .false. + else + l_print = .true. + endif +c + if(l_print) then + write(io8,*) + write(io8,*) '4 Pt is headed backwards iip2= ',iip2 + endif +c + else + c_qc(iip2)(1:1) = 'r' + c_qc(iip2)(3:4) = 'II' + l_print = .true. +c + if(l_print) then + write(io8,*) + write(io8,*) '5 Pt is headed backwards iip2= ',iip2 + endif + endif +c +c Check if first point in flight/first point after time gap is good +c Use ii, iip1, iip2 points +c ----------------------------------------------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ (iim1.eq.0.or. + $ idt_dif0.eq.imiss.or. + $ (idt_dif0.ne.imiss.and. + $ ((.not.(l_ii_man_airep.and.l_iim1_man_airep).and. + $ idt_dif0.gt.idt_near).or. + $ (l_ii_man_airep.and.l_iim1_man_airep.and. + $ idt_dif0.gt.idt_near*2)))).and. + $ (idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near*2.or. + $ (l_ii_man_airep.and.l_iip1_man_airep.and. + $ idt_difp1.le.idt_near*4))).and. + $ (idt_difp2.ne.imiss.and. + $ (idt_difp2.le.idt_near*2.or. + $ (l_iip1_man_airep.and.l_iip2_man_airep.and. + $ idt_difp2.le.idt_near*4))).and. + $ (cos((pdirp1-pdirp2)*d2r).gt.0.25881904.or. + $ (distp1.lt.15.0.and.ht_ftp1.lt.10000.0).or. + $ (distp2.lt.15.0.and.ht_ftp2.lt.10000.0).or. + $ (distp1.lt.5.0).or. + $ (distp2.lt.5.0)).and. + $ ((ht_ft0 .lt.ht_ftp1.and. + $ ht_ftp1.lt.ht_ftp2).or. + $ (ht_ft0 .gt.ht_ftp1.and. + $ ht_ftp1.gt.ht_ftp2).or. + $ (ht_ft0 .lt.ht_ftp1.and. + $ ht_ftp1.gt.ht_ftp2.and. + $ (abs(ht_difp1).lt.7000.0.or. + $ abs(ht_difp2).lt.7000.0)).or. + $ (ht_ft0 .gt.ht_ftp1.and. + $ ht_ftp1.lt.ht_ftp2.and. + $ (abs(ht_difp1).lt.3000.0.or. + $ abs(ht_difp2).lt.3000.0)).or. + $ ((ht_ft0 .lt.ht_ftp1.or. + $ ht_ft0 .gt.ht_ftp1).and. + $ abs(ht_difp2).lt.htdif_same*1.5).or. + $ (abs(ht_difp1).lt.htdif_same*1.5.and. + $ (ht_ftp1.lt.ht_ftp2.or. + $ ht_ftp1.gt.ht_ftp2)).or. + $ (abs(ht_difp1).lt.htdif_same*1.5.and. + $ abs(ht_difp2).lt.htdif_same*1.5))) then +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Time, pos, alt agree for 1st pt',ii + endif +c +c Check if middle point in flight is good +c Use iim1, ii, iip1 points +c --------------------------------------- + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ (idt_dif0.ne.imiss.and. + $ (idt_dif0 .le.idt_near*2.or. + $ (l_ii_man_airep.and.l_iim1_man_airep.and. + $ idt_dif0 .le.idt_near*4))).and. + $ (idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near*2.or. + $ (l_ii_man_airep.and.l_iip1_man_airep.and. + $ idt_difp1.le.idt_near*4))).and. + $ (cos((pdir0-pdirp1)*d2r).gt.0.25881904.or. + $ (dist0 .lt.15.0.and.ht_ft0 .lt.10000.0).or. + $ (distp1.lt.15.0.and.ht_ftp1.lt.10000.0).or. + $ (dist0 .lt.5.0).or. + $ (distp1.lt.5.0)).and. + $ ((ht_ftm1.lt.ht_ft0 .and. + $ ht_ft0 .lt.ht_ftp1).or. + $ (ht_ftm1.gt.ht_ft0 .and. + $ ht_ft0 .gt.ht_ftp1).or. + $ (ht_ftm1.lt.ht_ft0 .and. + $ ht_ft0 .gt.ht_ftp1.and. + $ (abs(ht_dif0) .lt.7000.0.or. + $ abs(ht_difp1).lt.7000.0)).or. + $ (ht_ftm1.gt.ht_ft0 .and. + $ ht_ft0 .lt.ht_ftp1.and. + $ (abs(ht_dif0) .lt.3000.0.or. + $ abs(ht_difp1).lt.3000.0)).or. + $ ((ht_ftm1.lt.ht_ft0 .or. + $ ht_ftm1.gt.ht_ft0 ).and. + $ abs(ht_difp1).lt.htdif_same*1.5).or. + $ (abs(ht_dif0 ).lt.htdif_same*1.5.and. + $ (ht_ft0 .lt.ht_ftp1.or. + $ ht_ft0 .gt.ht_ftp1)).or. + $ (abs(ht_dif0 ).lt.htdif_same*1.5.and. + $ abs(ht_difp1).lt.htdif_same*1.5))) then +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Time, pos, alt agree',ii + endif +c +c Use ii, iip1, iip2 points +c ------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ (idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near*2.or. + $ (l_ii_man_airep.and.l_iip1_man_airep.and. + $ idt_difp1.le.idt_near*4))).and. + $ (idt_difp2.ne.imiss.and. + $ (idt_difp2.le.idt_near*2.or. + $ (l_iip1_man_airep.and.l_iip2_man_airep.and. + $ idt_difp2.le.idt_near*4))).and. + $ (distp1.lt.5.0.or. + $ distp2.lt.5.0).and. + $ ((ht_ft0 .lt.ht_ftp1.and. + $ ht_ftp1.lt.ht_ftp2).or. + $ (ht_ft0 .gt.ht_ftp1.and. + $ ht_ftp1.gt.ht_ftp2).or. + $ (ht_ft0 .lt.ht_ftp1.and. + $ ht_ftp1.gt.ht_ftp2.and. + $ (abs(ht_difp1).lt.7000.0.or. + $ abs(ht_difp2).lt.7000.0)).or. + $ (ht_ft0 .gt.ht_ftp1.and. + $ ht_ftp1.lt.ht_ftp2.and. + $ (abs(ht_difp1).lt.3000.0.or. + $ abs(ht_difp2).lt.3000.0)).or. + $ ((ht_ft0 .lt.ht_ftp1.or. + $ ht_ft0 .gt.ht_ftp1).and. + $ abs(ht_difp2).lt.htdif_same*1.5).or. + $ (abs(ht_difp1).lt.htdif_same*1.5.and. + $ (ht_ftp1.lt.ht_ftp2.or. + $ ht_ftp1.gt.ht_ftp2)).or. + $ (abs(ht_difp1).lt.htdif_same*1.5.and. + $ abs(ht_difp2).lt.htdif_same*1.5))) then +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Time, pos, alt agree for near pts',ii + endif +c +c Check if last point in flight/last point before time gap is good +c Use iim2, iim1, ii points +c ---------------------------------------------------------------- + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ (iip1.eq.0.or. + $ idt_difp1.eq.imiss.or. + $ (idt_difp1.ne.imiss.and. + $ ((.not.(l_ii_man_airep.and.l_iip1_man_airep).and. + $ idt_difp1.gt.idt_near).or. + $ (l_ii_man_airep.and.l_iip1_man_airep.and. + $ idt_difp1.gt.idt_near*2)))).and. + $ (idt_difm1.ne.imiss.and. + $ (idt_difm1.le.idt_near*2.or. + $ (l_iim1_man_airep.and.l_iim2_man_airep.and. + $ idt_difm1.le.idt_near*4))).and. + $ (idt_dif0 .ne.imiss.and. + $ (idt_dif0 .le.idt_near*2.or. + $ (l_ii_man_airep.and.l_iim1_man_airep.and. + $ idt_dif0 .le.idt_near*4))).and. + $ (cos((pdirm1-pdir0)*d2r).gt.0.25881904.or. + $ (distm1.lt.15.0.and.ht_ftm1.lt.10000.0).or. + $ (dist0 .lt.15.0.and.ht_ft0 .lt.10000.0).or. + $ (distm1.lt.5.0).or. + $ (dist0 .lt.5.0)).and. + $ ((ht_ftm2.lt.ht_ftm1.and. + $ ht_ftm1.lt.ht_ft0 ).or. + $ (ht_ftm2.gt.ht_ftm1.and. + $ ht_ftm1.gt.ht_ft0 ).or. + $ (ht_ftm2.lt.ht_ftm1.and. + $ ht_ftm1.gt.ht_ft0 .and. + $ (abs(ht_difm1).lt.7000.0.or. + $ abs(ht_dif0) .lt.7000.0)).or. + $ (ht_ftm2.gt.ht_ftm1.and. + $ ht_ftm1.lt.ht_ft0 .and. + $ (abs(ht_difm1).lt.3000.0.or. + $ abs(ht_dif0) .lt.3000.0)).or. + $ ((ht_ftm2.lt.ht_ftm1.or. + $ ht_ftm2.gt.ht_ftm1).and. + $ abs(ht_dif0 ).lt.htdif_same*1.5).or. + $ (abs(ht_difm1).lt.htdif_same*1.5.and. + $ (ht_ftm1.lt.ht_ft0 .or. + $ ht_ftm1.gt.ht_ft0 )).or. + $ (abs(ht_difm1).lt.htdif_same*1.5.and. + $ abs(ht_dif0 ).lt.htdif_same*1.5))) then +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Time, pos, alt agree for last pt',ii + endif +c +c Check for isolated manAIREPs +c ---------------------------- + elseif(l_ii_man_airep.and. + $ ((iim1.ne.0.and.iip1.ne.0.and. + $ ((idt_difm1.gt.idt_near*2.and. + $ idt_difp1.gt.idt_near*2).or. + $ (idt_dif0 .gt.idt_near*2.and. + $ idt_difp1.gt.idt_near*2).or. + $ (idt_dif0 .gt.idt_near*2.and. + $ idt_difp2.gt.idt_near*2))).or. + $ (iim1.eq.0.and.idt_difp1.gt.idt_near*2).or. + $ (iim1.eq.0.and.idt_difp2.gt.idt_near*2).or. + $ (iim2.eq.0.and.iim1.ne.0.and. + $ idt_difp1.gt.idt_near*2).or. + $ (iip1.eq.0.and.idt_dif0 .gt.idt_near*2).or. + $ (iip1.eq.0.and.idt_difm1.gt.idt_near*2).or. + $ (iip2.eq.0.and.iip1.ne.0.and. + $ idt_dif0 .gt.idt_near*2)))then +c + c_qc(ii)(11:11) = 'I' +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Isolated manAIREP(s)',ii + endif +c +c Check for other isolated reports +c -------------------------------- + elseif((.not.l_ii_man_airep).and. + $ ((iim1.ne.0.and.iip1.ne.0.and. + $ ((idt_difm1.gt.idt_near*2/3.and. + $ idt_difp1.gt.idt_near*2/3).or. + $ (idt_dif0 .gt.idt_near*2/3.and. + $ idt_difp1.gt.idt_near*2/3).or. + $ (idt_dif0 .gt.idt_near*2/3.and. + $ idt_difp2.gt.idt_near*2/3))).or. + $ (iim1.eq.0.and.idt_difp1.gt.idt_near*2/3).or. + $ (iim1.eq.0.and.idt_difp2.gt.idt_near*2/3).or. + $ (iim2.eq.0.and.iim1.ne.0.and. + $ idt_difp1.gt.idt_near*2/3).or. + $ (iip1.eq.0.and.idt_dif0 .gt.idt_near*2/3).or. + $ (iip1.eq.0.and.idt_difm1.gt.idt_near*2/3).or. + $ (iip2.eq.0.and.iip1.ne.0.and. + $ idt_dif0 .gt.idt_near*2/3)))then +c + c_qc(ii)(11:11) = 'I' +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Isolated point(s)',ii + endif +c +c Check for position reports +c ------------------------------ + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ idt_dif0 .ne.imiss.and. + $ idt_dif0 .le.idt_near.and. + $ idt_difp1.ne.imiss.and. + $ idt_difp1.le.idt_near.and. + $ (((itypem1.eq.i_mdcrs_asc.or. + $ itypem1.eq.i_mdcrs_des.or. + $ itypem1.eq.i_mdcrs_lvl).and. + $ itype0.eq.i_mdcrs.and. + $ (itypep1.eq.i_mdcrs_asc.or. + $ itypep1.eq.i_mdcrs_des.or. + $ itypep1.eq.i_mdcrs_lvl)).or. + $ (itypem1.eq.i_mdcrs_asc.and. + $ itype0.eq.i_mdcrs.and. + $ itypep1.eq.i_mdcrs.and. + $ ht_ftm1.gt.20000.0).or. + $ (itypem1.eq.i_mdcrs.and. + $ itype0.eq.i_mdcrs.and. + $ itypep1.eq.i_mdcrs_des.and. + $ ht_ftp1.gt.20000.0).or. + $ ((itypem1.eq.i_acars_asc.or. + $ itypem1.eq.i_acars_des.or. + $ itypem1.eq.i_acars_lvl).and. + $ itype0.eq.i_acars.and. + $ (itypep1.eq.i_acars_asc.or. + $ itypep1.eq.i_acars_des.or. + $ itypep1.eq.i_acars_lvl)).or. + $ (itypem1.eq.i_acars_asc.and. + $ itype0.eq.i_acars.and. + $ itypep1.eq.i_acars.and. + $ ht_ftm1.gt.20000.0).or. + $ (itypem1.eq.i_acars.and. + $ itype0.eq.i_acars.and. + $ itypep1.eq.i_acars_des.and. + $ ht_ftp1.gt.20000.0))) then +c + c_qc(ii)(2:2) = 'I' +c + iob = iob + 1 + knt_iip1_bad = 0 +c + if(c_acftreg(ii)(4:5).eq.'GU'.or. + $ c_acftreg(ii)(4:5).eq.'WU') then + l_print = .false. + else + l_print = .true. + endif +c + if(l_print) then + write(io8,*) + write(io8,*) 'ii is position report' + endif +c + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ idt_difp1 .ne.imiss.and. + $ idt_difp1.le.idt_near.and. + $ idt_difp2.ne.imiss.and. + $ idt_difp2.le.idt_near.and. + $ (((itype0.eq.i_mdcrs_asc.or. + $ itype0.eq.i_mdcrs_des.or. + $ itype0.eq.i_mdcrs_lvl).and. + $ itypep1.eq.i_mdcrs.and. + $ (itypep2.eq.i_mdcrs_asc.or. + $ itypep2.eq.i_mdcrs_des.or. + $ itypep2.eq.i_mdcrs_lvl)).or. + $ (itype0.eq.i_mdcrs_asc.and. + $ itypep1.eq.i_mdcrs.and. + $ itypep2.eq.i_mdcrs.and. + $ ht_ft0.gt.20000.0).or. + $ (itype0.eq.i_mdcrs.and. + $ itypep1.eq.i_mdcrs.and. + $ itypep2.eq.i_mdcrs_des.and. + $ ht_ftp2.gt.20000.0).or. + $ ((itype0.eq.i_acars_asc.or. + $ itype0.eq.i_acars_des.or. + $ itype0.eq.i_acars_lvl).and. + $ itypep1.eq.i_acars.and. + $ (itypep2.eq.i_acars_asc.or. + $ itypep2.eq.i_acars_des.or. + $ itypep2.eq.i_acars_lvl)).or. + $ (itype0.eq.i_acars_asc.and. + $ itypep1.eq.i_acars.and. + $ itypep2.eq.i_acars.and. + $ ht_ft0.gt.20000.0).or. + $ (itype0.eq.i_acars.and. + $ itypep1.eq.i_acars.and. + $ itypep2.eq.i_acars_des.and. + $ ht_ftp2.gt.20000.0))) then +c + c_qc(iip1)(2:2) = 'I' +c + knt_iip1_bad = knt_iip1_bad + 1 +c + if(c_acftreg(ii)(4:5).eq.'GU'.or. + $ c_acftreg(ii)(4:5).eq.'WU') then + l_print = .false. + else + l_print = .true. + endif +c + if(l_print) then + write(io8,*) + write(io8,*) 'iip1 is position report' + endif +cc +cc Check for manAIREPs that don't fit the track properly +cc ----------------------------------------------------- +c elseif(iim1.ne.0.and.iip1.ne.0.and. +c $ idt_dif0 .ne.imiss.and. +c $ idt_dif0 .le.idt_near.and. +c $ idt_difp1.ne.imiss.and. +c $ idt_difp1.le.idt_near.and. +c $ ( ((itype(iim1).eq.i_mdcrs_asc.or. +c $ itype(iim1).eq.i_mdcrs_des.or. +c $ itype(iim1).eq.i_mdcrs_lvl.or. +c $ itype(iim1).eq.i_mdcrs).and. +c $ (itype(ii).eq.i_man_airep.or. +c $ itype(ii).eq.i_man_Yairep).and. +c $ (itype(iip1).eq.i_mdcrs_asc.or. +c $ itype(iip1).eq.i_mdcrs_des.or. +c $ itype(iip1).eq.i_mdcrs_lvl.or. +c $ itype(iip1).eq.i_mdcrs)).or. +c $ ((itype(iim1).eq.i_acars_asc.or. +c $ itype(iim1).eq.i_acars_des.or. +c $ itype(iim1).eq.i_acars_lvl.or. +c $ itype(iim1).eq.i_acars).and. +c $ (itype(ii).eq.i_man_airep.or. +c $ itype(ii).eq.i_man_Yairep).and. +c $ (itype(iip1).eq.i_acars_asc.or. +c $ itype(iip1).eq.i_acars_des.or. +c $ itype(iip1).eq.i_acars_lvl.or. +c $ itype(iip1).eq.i_acars)) )) then +cc +c c_qc(ii)(1:1) = 'X' +c c_qc(ii)(3:4) = 'II' +c +c iob = iob + 1 +c knt_iip1_bad = 0 +cc +c l_print = .false. +c if(l_print) then +c write(io8,*) +c write(io8,*) 'manAIREP ii does not fit' +c endif +cc +c elseif(iip1.ne.0.and.iip2.ne.0.and. +c $ idt_difp1 .ne.imiss.and. +c $ idt_difp1.le.idt_near.and. +c $ idt_difp2.ne.imiss.and. +c $ idt_difp2.le.idt_near.and. +c $ (((itype(ii).eq.i_mdcrs_asc.or. +c $ itype(ii).eq.i_mdcrs_des.or. +c $ itype(ii).eq.i_mdcrs_lvl.or. +c $ itype(ii).eq.i_mdcrs).and. +c $ (itype(iip1).eq.i_man_airep.or. +c $ itype(iip1).eq.i_man_Yairep).and. +c $ (itype(iip2).eq.i_mdcrs_asc.or. +c $ itype(iip2).eq.i_mdcrs_des.or. +c $ itype(iip2).eq.i_mdcrs_lvl.or. +c $ itype(iip2).eq.i_mdcrs))).or. +c $ ((itype(ii).eq.i_acars_asc.or. +c $ itype(ii).eq.i_acars_des.or. +c $ itype(ii).eq.i_acars_lvl.or. +c $ itype(ii).eq.i_acars).and. +c $ (itype(iip1).eq.i_man_airep.or. +c $ itype(iip1).eq.i_man_Yairep).and. +c $ (itype(iip2).eq.i_acars_asc.or. +c $ itype(iip2).eq.i_acars_des.or. +c $ itype(iip2).eq.i_acars_lvl.or. +c $ itype(iip2).eq.i_acars))) then +cc +c c_qc(iip1)(1:1) = 'X' +c c_qc(iip1)(3:4) = 'II' +c +c knt_iip1_bad = knt_iip1_bad + 1 +cc +c l_print = .false. +c if(l_print) then +c write(io8,*) +c write(io8,*) 'manAIREP iip1 does not fit' +c endif +c +c Reject isolated altitude maxima +c Use iim1, ii, and iip1 points +c ------------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ (iim1.eq.0.or. + $ idt_dif0.eq.imiss.or. + $ (idt_dif0.ne.imiss.and. + $ ((.not.(l_ii_man_airep.and.l_iim1_man_airep).and. + $ idt_dif0.gt.idt_near*2).or. + $ (l_ii_man_airep.and.l_iim1_man_airep.and. + $ idt_dif0.gt.idt_near*4)))).and. + $ (idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near*2.or. + $ (l_ii_man_airep.and.l_iip1_man_airep.and. + $ idt_difp1.le.idt_near*4))).and. + $ (idt_difp2.ne.imiss.and. + $ (idt_difp2.le.idt_near*2.or. + $ (l_iip1_man_airep.and.l_iip2_man_airep.and. + $ idt_difp2.le.idt_near*4))).and. + $ ((ht_ft0 .lt.ht_ftp1.and. + $ ht_ftp1.gt.ht_ftp2.and. + $ abs(ht_difp1).ge.7000.0.and. + $ abs(ht_difp2).ge.7000.0).or. + $ (ht_ft0 .gt.ht_ftp1.and. + $ ht_ftp1.lt.ht_ftp2.and. + $ abs(ht_difp1).ge.3000.0.and. + $ abs(ht_difp2).ge.3000.0))) then +c + c_qc(iip1)(1:1) = 'X' + c_qc(iip1)(5:5) = 'I' +c + knt_iip1_bad = knt_iip1_bad + 1 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Isolated alt max: iip1 = ',iip1 + endif +c +c Reject isolated altitude maxima +c Use iim1, ii, and iip1 points +c ------------------------------- + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ (idt_dif0.ne.imiss.and. + $ (idt_dif0 .le.idt_near*2.or. + $ (l_ii_man_airep.and.l_iim1_man_airep.and. + $ idt_dif0 .le.idt_near*4))).and. + $ (idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near*2.or. + $ (l_ii_man_airep.and.l_iip1_man_airep.and. + $ idt_difp1.le.idt_near*4))).and. + $ ((ht_ftm1.lt.ht_ft0 .and. + $ ht_ft0 .gt.ht_ftp1.and. + $ abs(ht_dif0) .ge.7000.0.and. + $ abs(ht_difp1).ge.7000.0).or. + $ (ht_ftm1.gt.ht_ft0 .and. + $ ht_ft0 .lt.ht_ftp1.and. + $ abs(ht_dif0) .ge.3000.0.and. + $ abs(ht_difp1).ge.3000.0))) then +c + c_qc(ii)(1:1) = 'X' + c_qc(ii)(5:5) = 'I' +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Isolated alt max: ii = ',ii + endif +c +c Check if first point in flight/first point after time gap is bad +c Use ii, iip1, iip2 points +c ---------------------------------------------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ (iim1.eq.0.or. + $ idt_dif0.eq.imiss.or. + $ (idt_dif0.ne.imiss.and. + $ ((.not.(l_ii_man_airep.and.l_iim1_man_airep).and. + $ idt_dif0.gt.idt_near*2).or. + $ (l_ii_man_airep.and.l_iim1_man_airep.and. + $ idt_dif0.gt.idt_near*4)))).and. + $ (idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near*2.or. + $ (l_ii_man_airep.and.l_iip1_man_airep.and. + $ idt_difp1.le.idt_near*4))).and. + $ (idt_difp2.ne.imiss.and. + $ (idt_difp2.le.idt_near*2.or. + $ (l_iip1_man_airep.and.l_iip2_man_airep.and. + $ idt_difp2.le.idt_near*4))).and. + $ distp1.gt.5.0.and.distp2.gt.5.0.and. ! new + $ cos((pdirp1-pdirp2)*d2r).lt.0.5) then +c +c Reject isolated off-track point at point iip2 +c --------------------------------------------- + if(pdirp1.ne.amiss.and. + $ pdirp2.ne.amiss.and. + $ pdirp3.ne.amiss.and. + $ pdir_wop2.ne.amiss.and. + $ ((cos((pdirp2-pdirp3 )*d2r).lt.-0.5.and. + $ cos((pdirp1-pdir_wop2)*d2r).gt.0.25881904).or. +c $ (cos((pdirp2-pdirp3 )*d2r).lt.0.25881904.and. + $ cos((pdirp1-pdir_wop2)*d2r).gt.0.70710678)) then +c + c_qc(iip2)(1:1) = 'X' + c_qc(iip2)(3:4) = 'II' +c + knt_iip1_bad = knt_iip1_bad + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad manuever for 1st pt--iip2 = ',iip2 + endif +c +c Reject isolated off-track point at point iip1 +c --------------------------------------------- + elseif(pdir0 .ne.amiss.and. + $ pdirp1.ne.amiss.and. + $ pdirp2.ne.amiss.and. + $ pdir_wop1.ne.amiss.and. + $ ((cos((pdirp1-pdirp2 )*d2r).lt.-0.5.and. + $ cos((pdir0 -pdir_wop1)*d2r).gt.0.25881904).or. +c $ (cos((pdirp1-pdirp2 )*d2r).lt.0.25881904.and. + $ cos((pdir0 -pdir_wop1)*d2r).gt.0.70710678) + $ ) then +c + c_qc(iip1)(1:1) = 'X' + c_qc(iip1)(3:4) = 'II' +c + knt_iip1_bad = knt_iip1_bad + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad manuever for 1st pt--iip1 = ',iip1 + endif +c +c Reject beginning of circling manuever at point iip2 +c --------------------------------------------------- + elseif(pdirp1.ne.amiss.and. + $ pdirp2.ne.amiss.and. + $ pdirp3.ne.amiss.and. + $ pdir_wop2.ne.amiss.and. + $ ((cos((pdirp1-pdirp3 )*d2r).lt.-0.5.and. + $ cos((pdirp1-pdir_wop2)*d2r).lt.0.5).or. + $ (cos((pdirp1-pdirp2 )*d2r).lt.-0.5.and. + $ cos((pdirp1-pdir_wop2)*d2r).lt.0.5))) then +c + c_qc(iip2)(1:1) = 'X' + c_qc(iip2)(3:4) = 'II' +c + knt_iip1_bad = knt_iip1_bad + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Circle near 1st pt--iip2 = ',iip2 + endif +c +c Otherwise reject first point +c ---------------------------- + else +c + c_qc(ii)(1:1) = 'X' + c_qc(ii)(3:4) = 'II' +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad manuever for 1st pt--ii = ',ii + endif + endif +c +c Check if middle point in flight is bad +c Use iim1, ii, iip1 points +c -------------------------------------- + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ (idt_dif0.ne.imiss.and. + $ (idt_dif0 .le.idt_near*2.or. + $ (l_ii_man_airep.and.l_iim1_man_airep.and. + $ idt_dif0 .le.idt_near*4))).and. + $ (idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near*2.or. + $ (l_ii_man_airep.and.l_iip1_man_airep.and. + $ idt_difp1.le.idt_near*4))).and. + $ dist0.gt.5.0.and.distp1.gt.5.0.and. ! new + $ cos((pdir0-pdirp1)*d2r).lt.0.5) then +c + if(pdir0 .ne.amiss.and. + $ pdirp1.ne.amiss.and. + $ pdirm1.ne.amiss.and. + $ pdir_wo0.ne.amiss.and. + $ iip2.ne.0.and. + $ ((cos((pdir0 -pdirp1 )*d2r).lt.-0.5.and. + $ cos((pdirm1-pdir_wo0)*d2r).gt.0.25881904).or. +c $ (cos((pdir0 -pdirp1 )*d2r).lt.0.25881904.and. + $ cos((pdirm1-pdir_wo0)*d2r).gt.0.70710678.or. + $ knt_iip1_bad.gt.0)) then +c + c_qc(ii)(1:1) = 'X' + c_qc(ii)(3:4) = 'II' +c + if(iob.gt.istart) then + iob = iob - 1 + else + iob = iob + 1 + endif + knt_iip1_bad = 0 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad manuever--ii = ',ii + endif +c + else +c + c_qc(iip1)(1:1) = 'X' + c_qc(iip1)(3:4) = 'II' +c + knt_iip1_bad = knt_iip1_bad + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad manuever--iip1 = ',iip1 + endif +c + endif +c +c Check if last point in flight/last point before time gap is bad +c Use iim2, iim1, ii points +c --------------------------------------------------------------- + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ (iip1.eq.0.or. + $ idt_difp1.eq.imiss.or. + $ (idt_difp1.ne.imiss.and. + $ ((.not.(l_ii_man_airep.and.l_iip1_man_airep).and. + $ idt_difp1.gt.idt_near*2).or. + $ (l_ii_man_airep.and.l_iip1_man_airep.and. + $ idt_difp1.gt.idt_near*4)))).and. + $ (idt_difm1.ne.imiss.and. + $ (idt_difm1.le.idt_near*2.or. + $ (l_iim1_man_airep.and.l_iim2_man_airep.and. + $ idt_difm1.le.idt_near*4))).and. + $ (idt_dif0 .ne.imiss.and. + $ (idt_dif0 .le.idt_near*2.or. + $ (l_ii_man_airep.and.l_iim1_man_airep.and. + $ idt_dif0 .le.idt_near*4))).and. + $ distm1.gt.5.0.and.dist0.gt.5.0.and. ! new + $ cos((pdirm1-pdir0)*d2r).lt.0.5) then +c + c_qc(ii)(1:1) = 'X' + c_qc(ii)(3:4) = 'II' +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad manuever for last pt--ii = ',ii + endif +c +c Flag points not categorized above +c --------------------------------- + else +c + if(c_qc(ii)(11:11).ne.'N') then +c + c_qc(ii)(2:2) = 'I' +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Cannot categorize report',ii + endif +c + elseif(c_qc(ii)(11:11).eq.'N') then +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Time diff too long to check',ii + endif +c + else + write(io8,*) 'How did I get here?' +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .true. + endif + endif +c +c Check good points one last time +c ------------------------------- + if(c_qc(ii)(1:1).ne.'d' .and. + $ c_qc(ii)(2:2).ne.'I' .and. + $ c_qc(ii)(2:2).ne.'K' .and. + $ c_qc(ii)(3:4).ne.'II'.and. + $ c_qc(ii)(5:5).ne.'I' .and. + $ c_qc(ii)(5:5).ne.'i' ) then +c +c Check winds for anomalies at ends of descents +c --------------------------------------------- + if((iip1.eq.0.or.iip2.eq.0).and.iim1.ne.0) then + if(idt_dif0.le.idt_near.and. + $ ht_ft0.lt.8000.0.and. + $ (ht_ftm1-ht_ft0).gt.0.0.and. + $ (ht_ftm1-ht_ft0).lt.1000.0.and. + $ ob_spd(ii).ne.amiss.and. + $ ob_spd(iim1).ne.amiss.and. + $ ob_spd(ii)-ob_spd(iim1).gt.10.0) then +c + c_qc(ii)(8:8) = 'A' + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Anomalous wind speed found',ii + endif + endif + endif +c +c Reset suspect values if accepted as part of a track +c --------------------------------------------------- + if(c_qc(ii)(11:11).ne.'I') then +c +c Time is ok if time for either neighboring reports is nonzero +c ------------------------------------------------------------ + if(c_qc(ii)(2:2).eq.'S'.and. + $ (idtm1.ne.0.or. + $ idtp1.ne.0.or. + $ ht_ft(ii).lt.8000.0)) then + c_qc(ii)(2:2) = '.' +c write(io8,*) +c write(io8,*) 'Suspect time is ok' +c +! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c Latitude is ok if latitude for both neighboring reports is nonzero +c ------------------------------------------------------------------ + elseif(c_qc(ii)(3:3).eq.'S'.and. + $ (int(alatm1*100.).ne.0.0.and. + $ int(alatp1*100.).ne.0.0)) then +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + c_qc(ii)(3:3) = '.' +c write(io8,*) +c write(io8,*) 'Suspect latitude is ok' +c +! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c Longitude in AMDAR report is ok if longitude for either neighboring +c report is nonzero +c ------------------------------------------------------------------- + elseif(c_qc(ii)(4:4).eq.'S'.and. + $ (itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar).and. + $ (int(alonm1*100.).ne.0.0.or. + $ int(alonp1*100.).ne.0.0)) then +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + c_qc(ii)(4:4) = '.' +c write(io8,*) +c write(io8,*) 'Suspect AMDAR longitude is ok' +c +! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c Longitude in other reports is ok if longitude for both neighboring +c report is nonzero +c ------------------------------------------------------------------ + elseif(c_qc(ii)(4:4).eq.'S'.and. + $ (int(alonm1*100.).ne.0.0.and. + $ int(alonp1*100.).ne.0.0)) then +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + c_qc(ii)(4:4) = '.' +c write(io8,*) +c write(io8,*) 'Suspect longitude is ok' +c +c Altitude is ok if report made it this far +c ----------------------------------------- + elseif(c_qc(ii)(5:5).eq.'S') then + c_qc(ii)(5:5) = '.' +c write(io8,*) +c write(io8,*) 'Suspect altitude is ok' + endif +c + endif + endif +c +c Write reports used in testing if desired +c ---------------------------------------- + if(l_print) then + write(io8,'(a18,2i6,a18,2i6)') + $ ' iistart,iiend = ',iistart,iiend, + $ ' iifirst,iilast = ',iifirst,iilast + write(io8,'(7x,12a10)') + $ 'iim2','iim1','ii','wo0', + $ 'iip1','wop1','iip2','wop2','iip3', + $ 'bad0','badp1','track' + write(io8,'(''indices'',3i10,3(10x,i10))') + $ iim2,iim1,ii, + $ iip1,iip2,iip3 +c write(io8,'(''idt = '',12i10)') +c $ idtm2,idtm1,idt0,imiss, +c $ idtp1,imiss,idtp2,imiss,idtp3, +c $ imiss,imiss,imiss +c write(io8,'(''idtdif='',12i10)') +c $ idt_difm2,idt_difm1,idt_dif0,idt_dif_wo0, +c $ idt_difp1,idt_dif_wop1,idt_difp2,idt_dif_wop2, +c $ idt_difp3,idt_dif_bad0,idt_dif_badp1,idt_dif_track + write(io8,'(''dist = '',12f10.2)') + $ distm2,distm1,dist0,dist_wo0, + $ distp1,dist_wop1,distp2,dist_wop2,distp3, + $ dist_bad0,dist_badp1,dist_track + write(io8,'(''ht_d = '',12f10.2)') + $ ht_difm2,ht_difm1,ht_dif0,ht_dif_wo0, + $ ht_difp1,ht_dif_wop1,ht_difp2,ht_dif_wop2,ht_difp3, + $ ht_dif_bad0,ht_dif_badp1,ht_dif_track + write(io8,'(''pspd = '',12f10.2)') + $ pspdm2,pspdm1,pspd0,pspd_wo0, + $ pspdp1,pspd_wop1,pspdp2,pspd_wop2,pspdp3, + $ pspd_bad0,pspd_badp1,pspd_track + write(io8,'(''pdir = '',12f10.2)') + $ pdirm2,pdirm1,pdir0,pdir_wo0, + $ pdirp1,pdir_wop1,pdirp2,pdir_wop2,pdirp3, + $ pdir_bad0,pdir_badp1,pdir_track +c + if(iim2.ne.0) then + write(io8,8002) kk,iim2 + x, c_insty_ob(itype(iim2)) + x, c_acftreg(iim2),c_acftid(iim2) + x, idt(iim2),alat(iim2),alon(iim2) + x, pres(iim2),ht_ft(iim2) + x, t_prcn(iim2),ob_t(iim2),xiv_t(iim2),ichk_t(iim2) + x, ob_q(iim2),xiv_q(iim2),ichk_q(iim2) + x, ob_dir(iim2),xiv_d(iim2),ichk_d(iim2) + x, ob_spd(iim2),xiv_s(iim2),ichk_s(iim2) + x, c_qc(iim2) + endif +c + if(iim1.ne.0) then + write(io8,8002) kk,iim1 + x, c_insty_ob(itype(iim1)) + x, c_acftreg(iim1),c_acftid(iim1) + x, idt(iim1),alat(iim1),alon(iim1) + x, pres(iim1),ht_ft(iim1) + x, t_prcn(iim1),ob_t(iim1),xiv_t(iim1),ichk_t(iim1) + x, ob_q(iim1),xiv_q(iim1),ichk_q(iim1) + x, ob_dir(iim1),xiv_d(iim1),ichk_d(iim1) + x, ob_spd(iim1),xiv_s(iim1),ichk_s(iim1) + x, c_qc(iim1) + endif +c + write(io8,8002) kk,ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) +c + if(iip1.ne.0) then + write(io8,8002) kk,iip1 + x, c_insty_ob(itype(iip1)) + x, c_acftreg(iip1),c_acftid(iip1) + x, idt(iip1),alat(iip1),alon(iip1) + x, pres(iip1),ht_ft(iip1) + x, t_prcn(iip1),ob_t(iip1),xiv_t(iip1),ichk_t(iip1) + x, ob_q(iip1),xiv_q(iip1),ichk_q(iip1) + x, ob_dir(iip1),xiv_d(iip1),ichk_d(iip1) + x, ob_spd(iip1),xiv_s(iip1),ichk_s(iip1) + x, c_qc(iip1) + endif +c + if(iip2.ne.0) then + write(io8,8002) kk,iip2 + x, c_insty_ob(itype(iip2)) + x, c_acftreg(iip2),c_acftid(iip2) + x, idt(iip2),alat(iip2),alon(iip2) + x, pres(iip2),ht_ft(iip2) + x, t_prcn(iip2),ob_t(iip2),xiv_t(iip2),ichk_t(iip2) + x, ob_q(iip2),xiv_q(iip2),ichk_q(iip2) + x, ob_dir(iip2),xiv_d(iip2),ichk_d(iip2) + x, ob_spd(iip2),xiv_s(iip2),ichk_s(iip2) + x, c_qc(iip2) + endif +c + endif +c +c Check if last point of segment was deleted +c ------------------------------------------ + if((c_qc(ii)(1:1).eq.'d'.or. + $ c_qc(ii)(2:2).eq.'I'.or. + $ c_qc(ii)(2:2).eq.'K'.or. + $ c_qc(ii)(3:4).eq.'II'.or. + $ c_qc(ii)(5:5).eq.'I'.or. + $ c_qc(ii)(5:5).eq.'i').and. + $ ioblast.eq.iob) then +c + ioblast = imiss + iilast = imiss +c + endif +c + if(iip1.ne.0) then + if((c_qc(iip1)(1:1).eq.'d'.or. + $ c_qc(iip1)(2:2).eq.'I'.or. + $ c_qc(iip1)(2:2).eq.'K'.or. + $ c_qc(iip1)(3:4).eq.'II'.or. + $ c_qc(iip1)(5:5).eq.'I'.or. + $ c_qc(iip1)(5:5).eq.'i').and. + $ ioblast.eq.iobp1) then +c + ioblast = imiss + iilast = imiss + endif +c + endif +c + endif +c + enddo +c +c Redo flight phase of reports +c ---------------------------- + do iob=istart,iend + l_print = .false. +c + ii = indx(iob) +c +c Decide if report is a manual airep +c ---------------------------------- + l_ii_man_airep = .false. + if(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) l_ii_man_airep = .true. +c +c Compute ii-1 index +c if(iob.gt.istart) iim1 = indx(iob-1) +c -------------------------------------- + iim1 = 0 + knt1 = iob - 1 + 12 if(knt1.ge.istart) then + iim1 = indx(knt1) + if(c_qc(iim1)(1:1).eq.'d'.or. + $ c_qc(iim1)(2:2).eq.'I'.or. + $ c_qc(iim1)(2:2).eq.'K'.or. + $ c_qc(iim1)(3:4).eq.'II'.or. + $ c_qc(iim1)(5:5).eq.'I'.or. + $ c_qc(iim1)(5:5).eq.'i') then + knt1 = knt1 - 1 + goto 12 + endif + else + iim1 = 0 + endif +c +c Compute ii-2 index +c if(iob.gt.istart+1) iim2 = indx(iob-2) +c -------------------------------------- + iim2 = 0 + knt2 = knt1 - 1 + 22 if(knt2.ge.istart) then + iim2 = indx(knt2) + if(c_qc(iim2)(1:1).eq.'d'.or. + $ c_qc(iim2)(2:2).eq.'I'.or. + $ c_qc(iim2)(2:2).eq.'K'.or. + $ c_qc(iim2)(3:4).eq.'II'.or. + $ c_qc(iim2)(5:5).eq.'I'.or. + $ c_qc(iim2)(5:5).eq.'i') then + knt2 = knt2 - 1 + goto 22 + endif + else + iim2 = 0 + endif +c +c Compute ii+1 index +c if(iob.lt.iend) iip1 = indx(iob+1) +c ------------------------------------ + iip1 = 0 + knt3 = iob + 1 + 32 if(knt3.le.iend) then + iip1 = indx(knt3) + if(c_qc(iip1)(1:1).eq.'d'.or. + $ c_qc(iip1)(2:2).eq.'I'.or. + $ c_qc(iip1)(2:2).eq.'K'.or. + $ c_qc(iip1)(3:4).eq.'II'.or. + $ c_qc(iip1)(5:5).eq.'I'.or. + $ c_qc(iip1)(5:5).eq.'i') then + knt3 = knt3 + 1 + goto 32 + endif + else + iip1 = 0 + endif +c +c Compute ii+2 index +c if(iob.lt.iend-1) iip2 = indx(iob+2) +c ------------------------------------ + iip2 = 0 + knt4 = knt3 + 1 + 42 if(knt4.le.iend) then + iip2 = indx(knt4) + if(c_qc(iip2)(1:1).eq.'d'.or. + $ c_qc(iip2)(2:2).eq.'I'.or. + $ c_qc(iip2)(2:2).eq.'K'.or. + $ c_qc(iip2)(3:4).eq.'II'.or. + $ c_qc(iip2)(5:5).eq.'I'.or. + $ c_qc(iip2)(5:5).eq.'i') then + knt4 = knt4 + 1 + goto 42 + endif + else + iip2 = 0 + endif +c +c Compute time and height differences +c ----------------------------------- + alat0 = alat(ii) + alon0 = alon(ii) + ht_ft0 = ht_ft(ii) +c + if(iim1.ne.0) then + idt_dif0 = abs(idt(ii) - idt(iim1)) + ht_dif0 = abs(ht_ft(ii) - ht_ft(iim1)) + ht_ftm1 = ht_ft(iim1) + else + idt_dif0 = imiss + ht_dif0 = amiss + ht_ftm1 = amiss + endif +c + if(iim2.ne.0) then + ht_ftm2 = ht_ft(iim2) + else + ht_ftm2 = amiss + endif +c + if(iim1.ne.0.and.iim2.ne.0) then + idt_difm1 = abs(idt(iim1) - idt(iim2)) + ht_difm1 = abs(ht_ft(iim1) - ht_ft(iim2)) + else + idt_difm1 = imiss + ht_difm1 = amiss + endif +c + if(iip1.ne.0) then + idt_difp1 = abs(idt(iip1) - idt(ii)) + ht_difp1 = abs(ht_ft(iip1) - ht_ft(ii)) + ht_ftp1 = ht_ft(iip1) + else + idt_difp1 = imiss + ht_difp1 = amiss + ht_ftp1 = amiss + endif +c + if(iip2.ne.0) then + ht_ftp2 = ht_ft(iip2) + else + ht_ftp2 = amiss + endif +c + if(iip2.ne.0.and.iip1.ne.0) then + idt_difp2 = abs(idt(iip2) - idt(iip1)) + ht_difp2 = abs(ht_ft(iip2) - ht_ft(iip1)) + else + idt_difp2 = imiss + ht_difp2 = amiss + endif +c +c Look for high resolution level legs +c ----------------------------------- +c +c Use iim1, ii, iip1 points +c ----------------------------------- + if(iim1.ne.0.and.iip1.ne.0.and. + $ idt_dif0 .ne.imiss.and.idt_dif0 .le.idt_updn.and. + $ idt_difp1.ne.imiss.and.idt_difp1.le.idt_updn.and. + $ ht_dif0 .lt.htdif_same+0.5.and. + $ ht_difp1.lt.htdif_same+0.5) then +c + c_qc(ii)(11:11) = 'L' +c +c Use iim2, iim1, ii points +c -------------------------- + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ idt_difm1.ne.imiss.and.idt_difm1.le.idt_updn.and. + $ idt_dif0 .ne.imiss.and.idt_dif0 .le.idt_updn.and. + $ ht_difm1.lt.htdif_same+0.5.and. + $ ht_dif0 .lt.htdif_same+0.5) then +c + c_qc(ii)(11:11) = 'L' +c + if(iip1.ne.0.and.idt_difp1.lt.idt_updn.and. + $ ht_difp1.gt.htdif_same+0.5.and. + $ ht_difp1.lt.5000.) then + if(ht_ftp1.gt.ht_ft0) + $ c_qc(ii)(11:11) = 'A' ! Ascending + if(ht_ftp1.lt.ht_ft0) + $ c_qc(ii)(11:11) = 'D' ! Descending + endif +c +c Use ii, iip1, iip2 points +c -------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ idt_difp1.ne.imiss.and.idt_difp1.le.idt_updn.and. + $ idt_difp2.ne.imiss.and.idt_difp2.le.idt_updn.and. + $ ht_difp1.lt.htdif_same+0.5.and. + $ ht_difp2.lt.htdif_same+0.5) then +c + c_qc(ii)(11:11) = 'L' +c + if(iim1.ne.0.and.idt_dif0.lt.idt_updn.and. + $ ht_dif0.gt.htdif_same+0.5.and. + $ ht_dif0.lt.5000.) then + if(ht_ftm1.gt.ht_ft0) + $ c_qc(ii)(11:11) = 'D' ! Descending + if(ht_ftm1.lt.ht_ft0) + $ c_qc(ii)(11:11) = 'A' ! Ascending + endif +c +c Look for high resolution ascents and descents +c --------------------------------------------- +c +c Use iim1, ii, iip1 points +c ----------------------------------- + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ idt_dif0.ne.imiss.and.idt_dif0.le.idt_updn.and. + $ idt_difp1.ne.imiss.and.idt_difp1.le.idt_updn.and. + $ ht_ftm1.lt.ht_ft0 .and. + $ ht_ft0 .lt.ht_ftp1) then +c + c_qc(ii)(11:11) = 'A' +c + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ idt_dif0.ne.imiss.and.idt_dif0.le.idt_updn.and. + $ idt_difp1.ne.imiss.and.idt_difp1.le.idt_updn.and. + $ ht_ftm1.gt.ht_ft0 .and. + $ ht_ft0 .gt.ht_ftp1) then +c + c_qc(ii)(11:11) = 'D' +c +c Use iim2, iim1, ii points +c ----------------------------------- + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ idt_difm1.ne.imiss.and.idt_difm1.le.idt_updn.and. + $ idt_dif0.ne.imiss.and.idt_dif0.le.idt_updn.and. + $ ht_ftm2.lt.ht_ftm1.and. + $ ht_ftm1.lt.ht_ft0) then +c + c_qc(ii)(11:11) = 'A' +c + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ idt_difm1.ne.imiss.and.idt_difm1.le.idt_updn.and. + $ idt_dif0.ne.imiss.and.idt_dif0.le.idt_updn.and. + $ ht_ftm2.gt.ht_ftm1.and. + $ ht_ftm1.gt.ht_ft0 ) then +c + c_qc(ii)(11:11) = 'D' +c +c Use ii, iip1, iip2 points +c ----------------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ idt_difp1.ne.imiss.and.idt_difp1.le.idt_updn.and. + $ idt_difp2.ne.imiss.and.idt_difp2.le.idt_updn.and. + $ ht_ft0 .lt.ht_ftp1.and. + $ ht_ftp1.lt.ht_ftp2) then +c + c_qc(ii)(11:11) = 'A' +c + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ idt_difp1.ne.imiss.and.idt_difp1.le.idt_updn.and. + $ idt_difp2.ne.imiss.and.idt_difp2.le.idt_updn.and. + $ ht_ft0.gt.ht_ftp1.and. + $ ht_ftp1.gt.ht_ftp2) then +c + c_qc(ii)(11:11) = 'D' +c +c Look for other level legs +c ------------------------- +c +c Use iim1, ii, iip1 points +c ------------------------- + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ idt_dif0.ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.idt_dif0 .le.idt_near*3)).and. + $ idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp1.le.idt_near*3)).and. + $ ht_dif0.lt.htdif_same*1.5+0.5.and. + $ ht_difp1.lt.htdif_same*1.5+0.5) then +c + c_qc(ii)(11:11) = 'L' +c +c Use iim2, iim1, ii points +c ------------------------- + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ idt_difm1.ne.imiss.and. + $ (idt_difm1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difm1.le.idt_near*3)).and. + $ idt_dif0 .ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.idt_dif0 .le.idt_near*3)).and. + $ ht_difm1.lt.htdif_same*1.5+0.5.and. + $ ht_dif0 .lt.htdif_same*1.5+0.5) then +c + c_qc(ii)(11:11) = 'L' +c + if(iip1.ne.0.and.idt_difp1.lt.idt_updn.and. + $ ht_difp1.gt.htdif_same+0.5.and. + $ ht_difp1.lt.5000.) then + if(ht_ftp1.gt.ht_ft0) + $ c_qc(ii)(11:11) = 'A' ! Ascending + if(ht_ftp1.lt.ht_ft0) + $ c_qc(ii)(11:11) = 'D' ! Descending + endif +c +c Use ii, iip1, iip2 points +c ------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp1.le.idt_near*3)).and. + $ idt_difp2.ne.imiss.and. + $ (idt_difp2.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp2.le.idt_near*3)).and. + $ ht_difp1.lt.htdif_same*1.5+0.5.and. + $ ht_difp2.lt.htdif_same*1.5+0.5) then +c + c_qc(ii)(11:11) = 'L' +c + if(iim1.ne.0.and.idt_dif0.lt.idt_updn.and. + $ ht_dif0.gt.htdif_same+0.5.and. + $ ht_dif0.lt.5000.) then + if(ht_ftm1.gt.ht_ft0) + $ c_qc(ii)(11:11) = 'D' ! Descending + if(ht_ftm1.lt.ht_ft0) + $ c_qc(ii)(11:11) = 'A' ! Ascending + endif +c +c Look for other ascents and descents +c ----------------------------------- +c +c Use iim1, ii, iip1 points +c -------------------------------- + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ idt_dif0.ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.idt_dif0 .le.idt_near*2)).and. + $ idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp1.le.idt_near*2)).and. + $ ht_ftm1.lt.ht_ft0 .and. + $ ht_ft0 .lt.ht_ftp1) then +c + c_qc(ii)(11:11) = 'a' +c + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ idt_dif0.ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.idt_dif0 .le.idt_near*2)).and. + $ idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp1.le.idt_near*2)).and. + $ ht_ftm1.gt.ht_ft0 .and. + $ ht_ft0 .gt.ht_ftp1) then +c + c_qc(ii)(11:11) = 'd' +c +c Use iim2, iim1, ii points +c ------------------------- + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ idt_difm1.ne.imiss.and. + $ (idt_difm1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difm1.le.idt_near*2)).and. + $ idt_dif0 .ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.idt_dif0 .le.idt_near*2)).and. + $ ht_ftm2.lt.ht_ftm1.and. + $ ht_ftm1.lt.ht_ft0 ) then +c + c_qc(ii)(11:11) = 'a' +c + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ idt_difm1.ne.imiss.and. + $ (idt_difm1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difm1.le.idt_near*2)).and. + $ idt_dif0 .ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.idt_dif0 .le.idt_near*2)).and. + $ ht_ftm2.gt.ht_ftm1.and. + $ ht_ftm1.gt.ht_ft0 ) then +c + c_qc(ii)(11:11) = 'd' +c +c Use ii, iip1, iip2 points +c -------------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp1.le.idt_near*2)).and. + $ idt_difp2.ne.imiss.and. + $ (idt_difp2.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp2.le.idt_near*2)).and. + $ ht_ft0 .lt.ht_ftp1.and. + $ ht_ftp1.lt.ht_ftp2) then +c + c_qc(ii)(11:11) = 'a' +c + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp1.le.idt_near*2)).and. + $ idt_difp2.ne.imiss.and. + $ (idt_difp2.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp2.le.idt_near*2)).and. + $ ht_ft0 .gt.ht_ftp1.and. + $ ht_ftp1.gt.ht_ftp2) then +c + c_qc(ii)(11:11) = 'd' +c +c Look for 2-point level legs +c --------------------------- +c +c Use iim1, ii, iip1 points +c ------------------------- + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ idt_dif0.ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.idt_dif0 .le.idt_near*2)).and. + $ idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp1.le.idt_near*2)).and. + $ ht_dif0.lt.htdif_same*1.5+0.5) then +c + c_qc(ii)(11:11) = 'L' +c + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ idt_dif0.ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.idt_dif0 .le.idt_near*2)).and. + $ idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp1.le.idt_near*2)).and. + $ ht_difp1.lt.htdif_same*1.5+0.5) then +c + c_qc(ii)(11:11) = 'L' +c +c Use iim2, iim1, ii points +c ------------------------- + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ idt_difm1.ne.imiss.and. + $ (idt_difm1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difm1.le.idt_near*2)).and. + $ idt_dif0 .ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.idt_dif0 .le.idt_near*2)).and. + $ ht_dif0 .lt.htdif_same*1.5+0.5) then +c + c_qc(ii)(11:11) = 'L' +c +c Use ii, iip1, iip2 points +c ------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp1.le.idt_near*2)).and. + $ idt_difp2.ne.imiss.and. + $ (idt_difp2.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp2.le.idt_near*2)).and. + $ ht_difp1.lt.htdif_same*1.5+0.5) then +c + c_qc(ii)(11:11) = 'L' +c +c Look for isolated ascending and descending points +c ------------------------------------------------- +c +c Use iim2, iim1, ii points +c ------------------------- + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ idt_difm1.ne.imiss.and. + $ (idt_difm1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difm1.le.idt_near*2)).and. + $ idt_dif0 .ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.idt_dif0 .le.idt_near*2)).and. + $ ht_difm1.lt.htdif_same*1.5+0.5) then +c + if(ht_ft0.lt.ht_ftm1) then + c_qc(ii)(11:11) = 'd' + elseif(ht_ft0.gt.ht_ftm1) then + c_qc(ii)(11:11) = 'a' + else + write(io8,*) + write(io8,*) 'unidentified isolated point found!' + write(io8,*) 'hts:',ht_ftm2,ht_ftm1,ht_ft0 + c_qc(ii)(11:11) = 'U' + endif +c +c Use ii, iip1, iip2 points +c ------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp1.le.idt_near*2)).and. + $ idt_difp2.ne.imiss.and. + $ (idt_difp2.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp2.le.idt_near*2)).and. + $ ht_difp2.lt.htdif_same*1.5+0.5) then +c + if(ht_ft0.gt.ht_ftp1) then + c_qc(ii)(11:11) = 'd' + elseif(ht_ft0.lt.ht_ftp1) then + c_qc(ii)(11:11) = 'a' + else + write(io8,*) + write(io8,*) 'unidentified isolated point found!' + write(io8,*) 'hts:',ht_ft0,ht_ftp1,ht_ftp2 + c_qc(ii)(11:11) = 'U' + endif +c +c Check if time difference is too great to categorize manAIREPs +c ------------------------------------------------------------- + elseif(l_ii_man_airep.and. + $ ((iim1.ne.0.and.iip1.ne.0.and. + $ ((idt_difm1.gt.idt_near*2.and. + $ idt_difp1.gt.idt_near*2).or. + $ (idt_dif0 .gt.idt_near*2.and. + $ idt_difp1.gt.idt_near*2).or. + $ (idt_dif0 .gt.idt_near*2.and. + $ idt_difp2.gt.idt_near*2))).or. + $ (iim1.eq.0.and.idt_difp1.gt.idt_near*2).or. + $ (iim1.eq.0.and.idt_difp2.gt.idt_near*2).or. + $ (iim2.eq.0.and.iim1.ne.0.and. + $ idt_difp1.gt.idt_near*2).or. + $ (iip1.eq.0.and.idt_dif0 .gt.idt_near*2).or. + $ (iip1.eq.0.and.idt_difm1.gt.idt_near*2).or. + $ (iip2.eq.0.and.iip1.ne.0.and. + $ idt_dif0 .gt.idt_near*2)))then +c + c_qc(ii)(11:11) = 'I' +c +c Check if time difference is too great to categorize remaining types +c ------------------------------------------------------------------- + elseif((.not.l_ii_man_airep).and. + $ ((iim1.ne.0.and.iip1.ne.0.and. + $ ((idt_difm1.gt.idt_near*2/3.and. + $ idt_difp1.gt.idt_near*2/3).or. + $ (idt_dif0 .gt.idt_near*2/3.and. + $ idt_difp1.gt.idt_near*2/3).or. + $ (idt_dif0 .gt.idt_near*2/3.and. + $ idt_difp2.gt.idt_near*2/3))).or. + $ (iim1.eq.0.and.idt_difp1.gt.idt_near*2/3).or. + $ (iim1.eq.0.and.idt_difp2.gt.idt_near*2/3).or. + $ (iim2.eq.0.and.iim1.ne.0.and. + $ idt_difp1.gt.idt_near*2/3).or. + $ (iip1.eq.0.and.idt_dif0 .gt.idt_near*2/3).or. + $ (iip1.eq.0.and.idt_difm1.gt.idt_near*2/3).or. + $ (iip2.eq.0.and.iip1.ne.0.and. + $ idt_dif0 .gt.idt_near*2/3)))then +c + c_qc(ii)(11:11) = 'I' +c +c Label everything else as unknown +c -------------------------------- + else + c_qc(ii)(11:11) = 'U' + endif +c +c Save flight phase +c ----------------- + l_print = .true. +c + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_des) then +c + if(c_qc(ii)(11:11).eq.'L') then + if(itype(ii).ne.i_mdcrs_lvl.and. + $ l_print) then +c write(io8,*) +c write(io8,*) 'Changing phase at ',ii,' from ', +c $ c_insty_ob(itype(ii)),' to mdcrs_lvl' + endif + itype(ii) = i_mdcrs_lvl +c + elseif(c_qc(ii)(11:11).eq.'a'.or. + $ c_qc(ii)(11:11).eq.'A') then + if(itype(ii).ne.i_mdcrs_asc.and. + $ l_print) then +c write(io8,*) +c write(io8,*) 'Changing phase at ',ii,' from ', +c $ c_insty_ob(itype(ii)),' to mdcrs_asc' + endif + itype(ii) = i_mdcrs_asc +c + elseif(c_qc(ii)(11:11).eq.'d'.or. + $ c_qc(ii)(11:11).eq.'D') then + if(itype(ii).ne.i_mdcrs_des.and. + $ l_print) then +c write(io8,*) +c write(io8,*) 'Changing phase at ',ii,' from ', +c $ c_insty_ob(itype(ii)),' to mdcrs_des' + endif + itype(ii) = i_mdcrs_des +c + else + if(itype(ii).ne.i_mdcrs.and. + $ l_print) then +c write(io8,*) +c write(io8,*) 'Changing phase at ',ii,' from ', +c $ c_insty_ob(itype(ii)),' to mdcrs' + endif + itype(ii) = i_mdcrs +c + endif +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_des) then +c + if(c_qc(ii)(11:11).eq.'L') then + if(itype(ii).ne.i_acars_lvl.and. + $ l_print) then +c write(io8,*) +c write(io8,*) 'Changing phase at ',ii,' from ', +c $ c_insty_ob(itype(ii)),' to acars_lvl' + endif + itype(ii) = i_acars_lvl +c + elseif(c_qc(ii)(11:11).eq.'a'.or. + $ c_qc(ii)(11:11).eq.'A') then + if(itype(ii).ne.i_acars_asc.and. + $ l_print) then +c write(io8,*) +c write(io8,*) 'Changing phase at ',ii,' from ', +c $ c_insty_ob(itype(ii)),' to acars_asc' + endif + itype(ii) = i_acars_asc +c + elseif(c_qc(ii)(11:11).eq.'d'.or. + $ c_qc(ii)(11:11).eq.'D') then + if(itype(ii).ne.i_acars_des.and. + $ l_print) then +c write(io8,*) +c write(io8,*) 'Changing phase at ',ii,' from ', +c $ c_insty_ob(itype(ii)),' to acars_des' + endif + itype(ii) = i_acars_des +c + else + if(itype(ii).ne.i_acars.and. + $ l_print) then +c write(io8,*) +c write(io8,*) 'Changing phase at ',ii,' from ', +c $ c_insty_ob(itype(ii)),' to acars' + endif + itype(ii) = i_acars +c + endif +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_des) then +c + if(c_qc(ii)(11:11).eq.'L') then + if(itype(ii).ne.i_airep_lvl.and. + $ l_print) then +c write(io8,*) +c write(io8,*) 'Changing phase at ',ii,' from ', +c $ c_insty_ob(itype(ii)),' to airep_lvl' + endif + itype(ii) = i_airep_lvl +c + elseif(c_qc(ii)(11:11).eq.'a'.or. + $ c_qc(ii)(11:11).eq.'A') then + if(itype(ii).ne.i_airep_asc.and. + $ l_print) then +c write(io8,*) +c write(io8,*) 'Changing phase at ',ii,' from ', +c $ c_insty_ob(itype(ii)),' to airep_asc' + endif + itype(ii) = i_airep_asc +c + elseif(c_qc(ii)(11:11).eq.'d'.or. + $ c_qc(ii)(11:11).eq.'D') then + if(itype(ii).ne.i_airep_des.and. + $ l_print) then +c write(io8,*) +c write(io8,*) 'Changing phase at ',ii,' from ', +c $ c_insty_ob(itype(ii)),' to airep_des' + endif + itype(ii) = i_airep_des +c + else + if(itype(ii).ne.i_airep.and. + $ l_print) then +c write(io8,*) +c write(io8,*) 'Changing phase at ',ii,' from ', +c $ c_insty_ob(itype(ii)),' to airep' + endif + itype(ii) = i_airep +c + endif +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_des) then +c + if(c_qc(ii)(11:11).eq.'L') then + if(itype(ii).ne.i_amdar_lvl.and. + $ l_print) then +c write(io8,*) +c write(io8,*) 'Changing phase at ',ii,' from ', +c $ c_insty_ob(itype(ii)),' to amdar_lvl' + endif + itype(ii) = i_amdar_lvl +c + elseif(c_qc(ii)(11:11).eq.'a'.or. + $ c_qc(ii)(11:11).eq.'A') then + if(itype(ii).ne.i_amdar_asc.and. + $ l_print) then +c write(io8,*) +c write(io8,*) 'Changing phase at ',ii,' from ', +c $ c_insty_ob(itype(ii)),' to amdar_asc' + endif + itype(ii) = i_amdar_asc +c + elseif(c_qc(ii)(11:11).eq.'d'.or. + $ c_qc(ii)(11:11).eq.'D') then + if(itype(ii).ne.i_amdar_des.and. + $ l_print) then +c write(io8,*) +c write(io8,*) 'Changing phase at ',ii,' from ', +c $ c_insty_ob(itype(ii)),' to amdar_des' + endif + itype(ii) = i_amdar_des +c + else + if(itype(ii).ne.i_amdar.and. + $ l_print) then +c write(io8,*) +c write(io8,*) 'Changing phase at ',ii,' from ', +c $ c_insty_ob(itype(ii)),' to amdar' + endif + itype(ii) = i_amdar +c + endif +c + endif +c + enddo +c +c Mark small flights +c ------------------ + else + do iob=istart,iend + ii = indx(iob) + c_qc(ii)(11:11) = 'N' + enddo + endif +c +c End loop over flights +c --------------------- + enddo +c +c Write out bad reports +c --------------------- + if(.not.l_operational) then + write(io36,*) + write(io36,*)'Ordering errors' + write(io36,*)'---------------' + write(io36,3001) + 3001 format(' index type tail num flight time lat' + x, ' lon pres height ' + x, 't-prcn temp innov ichk' + x, ' spec hum innov ichk' + x, ' ob_dir innov ichk' + x, ' ob_spd innov ichk' + x, ' qc flag') + endif +c + kbad = 0 +c + do iob = 1,numreps + ii = indx(iob) +c + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des) then + ktype = 1 +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des) then + ktype = 2 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des) then + ktype = 3 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des) then + ktype = 4 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + ktype = 5 + endif +c + if(ktype.eq.1) then + nrep_Md = nrep_Md + 1 + elseif(ktype.eq.2) then + nrep_Ac = nrep_Ac + 1 + elseif(ktype.eq.3) then + nrep_Am = nrep_Am + 1 + elseif(ktype.eq.4) then + nrep_Ar = nrep_Ar + 1 + elseif(ktype.eq.5) then + nrep_Ma = nrep_Ma + 1 + endif +c + if(c_qc(ii)(1:1).eq.'d'.or. + $ c_qc(ii)(1:1).eq.'2'.or. + $ c_qc(ii)(2:2).eq.'I'.or. + $ c_qc(ii)(2:2).eq.'K'.or. + $ c_qc(ii)(3:4).eq.'II'.or. + $ c_qc(ii)(5:5).eq.'I'.or. + $ c_qc(ii)(5:5).eq.'i'.or. + $ c_qc(ii)(8:8).eq.'A') then +c + if(.not.l_operational) then + write(io36,3002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + 3002 format(i6,1x,a8,1x,a8,1x,a9,1x,i7,1x,2f11.5,1x,f8.1,1x,f7.0 + x, 1x,f5.2,4(2(1x,f8.2),1x,i5),1x,'!',a11,'!') + endif +c +c Count number of rejected winds by tail number +c --------------------------------------------- + if(c_qc(ii)(8:8).eq.'A') then + mm = 1 + do while(mm.le.kreg) + if(c_acftreg(ii).eq.creg_reg(mm)) then + if(ktype.gt.0.and.ktype.le.5) + $ nwind_reg(mm,ktype) = nwind_reg(mm,ktype) + 1 + mm = kreg + 1 + endif + mm = mm + 1 + enddo + endif +c +c Count by category +c ----------------- + if(c_qc(ii)(1:1).eq.'d') then + nord_dup(ktype) = nord_dup(ktype) + 1 + elseif(c_qc(ii)(2:2).eq.'K') then + nord_stk(ktype) = nord_stk(ktype) + 1 + elseif(c_qc(ii)(2:2).eq.'I') then + nord_time(ktype) = nord_time(ktype) + 1 + elseif(c_qc(ii)(3:4).eq.'II') then + if(c_qc(ii)(1:1).eq.'p') then + nord_near(ktype) = nord_near(ktype) + 1 + elseif(c_qc(ii)(1:1).eq.'P') then + nord_aspd(ktype) = nord_aspd(ktype) + 1 + elseif(c_qc(ii)(1:1).eq.'O') then + nord_lone(ktype) = nord_lone(ktype) + 1 + elseif(c_qc(ii)(1:1).eq.'r') then + nord_dble(ktype) = nord_dble(ktype) + 1 + elseif(c_qc(ii)(1:1).eq.'X') then + nord_turn(ktype) = nord_turn(ktype) + 1 + endif + elseif(c_qc(ii)(5:5).eq.'I'.or. + $ c_qc(ii)(5:5).eq.'i') then + nord_alt(ktype) = nord_alt(ktype) + 1 + elseif(c_qc(ii)(8:8).eq.'A') then + nord_wind(ktype) = nord_wind(ktype) + 1 + elseif(c_qc(ii)(1:1).eq.'2') then + nord_2nd(ktype) = nord_2nd(ktype) + 1 + endif +c +c Reject reports with inconsistent heights and positions +c ------------------------------------------------------ + if(c_qc(ii)(1:1).eq.'d'.or. + $ c_qc(ii)(2:2).eq.'I'.or. + $ c_qc(ii)(2:2).eq.'K'.or. + $ c_qc(ii)(3:4).eq.'II'.or. + $ c_qc(ii)(5:5).eq.'I'.or. + $ c_qc(ii)(5:5).eq.'i') then +c + csort(ii)(1:5) = 'badob' +c + kbad(ktype) = kbad(ktype) + 1 +c + if(ktype.eq.1) then + nord_Md = nord_Md + 1 + elseif(ktype.eq.2) then + nord_Ac = nord_Ac + 1 + elseif(ktype.eq.3) then + nord_Am = nord_Am + 1 + elseif(ktype.eq.4) then + nord_Ar = nord_Ar + 1 + elseif(ktype.eq.5) then + nord_Ma = nord_Ma + 1 + endif + endif +c + endif +c + enddo +c + if(.not.l_operational) then + write(io36,*) + write(io36,*) ' Number of MDCRS reps rej by ord = ',kbad(1) +ccccdak write(io36,*) ' Number of ACARS reps rej by ord = ',kbad(2) + write(io36,*) ' Number of TAMDAR reps rej by ord = ',kbad(2) + write(io36,*) ' Number of AMDAR reps rej by ord = ',kbad(3) + write(io36,*) ' Number of AIREP reps rej by ord = ',kbad(4) + write(io36,*) ' Number of manAIREP reps rej by ord = ',kbad(5) + endif +c + write(io8,*) + write(io8,*) ' Reports with ordering errors--rejected' + write(io8,*) ' --------------------------------------' + write(io8,*) ' Number of MDCRS reps rej by ord = ',kbad(1) +ccccdak write(io8,*) ' Number of ACARS reps rej by ord = ',kbad(2) + write(io8,*) ' Number of TAMDAR reps rej by ord = ',kbad(2) + write(io8,*) ' Number of AMDAR reps rej by ord = ',kbad(3) + write(io8,*) ' Number of AIREP reps rej by ord = ',kbad(4) + write(io8,*) ' Number of manAIREP reps rej by ord = ',kbad(5) +c +c Output tail number counts +c ------------------------- + write(io8,*) + write(io8,*) ' Tail numbers for reports with anomalous winds' +ccccdak write(io8,*) ' Tail Num MDCRS ACARS AMDAR AIREP MAN ' + write(io8,*) ' Tail Num MDCRS TAMDAR AMDAR AIREP MAN ' + write(io8,*) ' ---------------------------------------------' +c + do mm=1,kreg + if( nwind_reg(mm,1)+nwind_reg(mm,2)+nwind_reg(mm,3) + $ +nwind_reg(mm,4)+nwind_reg(mm,5).gt.0) then + write(io8,'(2x,a8,5(1x,i6))') + $ creg_reg(mm),(nwind_reg(mm,kk),kk=1,5) + endif + enddo +c + write(io8,*) + write(io8,*) 'Ordering check data counts' + write(io8,*) '--------------------------' + write(io8,'(1x,a55)') +ccccdak $ 'Type of check MDCRS ACARS AMDAR AIREP man' + $ 'Type of check MDCRS TAMDAR AMDAR AIREP man' + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Num considered '',5(1x,i7))') + $ nrep_Md,nrep_Ac,nrep_Am,nrep_Ar,nrep_Ma + write(io8,'(''Total rejected '',5(1x,i7))') + $ nord_Md,nord_Ac,nord_Am,nord_Ar,nord_Ma + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Near duplicate '',5(1x,i7))') + $ (nord_dup(ii),ii=1,5) + write(io8,'(''Stuck time '',5(1x,i7))') + $ (nord_stk(ii),ii=1,5) + write(io8,'(''Incons. time '',5(1x,i7))') + $ (nord_time(ii),ii=1,5) + write(io8,'(''Close to reject'',5(1x,i7))') + $ (nord_near(ii),ii=1,5) + write(io8,'(''High airspeed '',5(1x,i7))') + $ (nord_aspd(ii),ii=1,5) + write(io8,'(''Off-track pt '',5(1x,i7))') + $ (nord_lone(ii),ii=1,5) + write(io8,'(''Reversed track '',5(1x,i7))') + $ (nord_dble(ii),ii=1,5) + write(io8,'(''Large turn '',5(1x,i7))') + $ (nord_turn(ii),ii=1,5) + write(io8,'(''Bad alt order '',5(1x,i7))') + $ (nord_alt(ii),ii=1,5) + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Second flight '',5(1x,i7))') + $ (nord_2nd(ii),ii=1,5) + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Anomalous winds'',5(1x,i7))') + $ (nord_wind(ii),ii=1,5) + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + kbadtot = kbad(1) + kbad(2) + kbad(3) + $ + kbad(4) + kbad(5) +c + write(io8,*) + write(io8,*) numreps,' good reports processed' + write(io8,*) kbadtot,' reports failed qc in ordering check' +c + return + end +c +c ################################################################### +c subroutine suspect_qc +c ################################################################### +c + subroutine suspect_qc(numreps,max_reps,indx,csort,imiss,idt_near + $, amiss,c_acftreg,c_acftid,c_qc + $, alat,alon,pres,ht_ft,t_prcn,ob_t,ob_q,ob_dir,ob_spd + $, xiv_t,xiv_q,xiv_d,xiv_s + $, idt,itype,ichk_t,ichk_q,ichk_d,ichk_s + $, maxflt,kflight,creg_flt,nobs_flt,ntot_flt + $, nrej_flt,iobs_flt,kreg,creg_reg,nobs_reg,nwind_reg + $, ntot_reg,kbadtot,io8,io37,l_operational,l_init) +c +c Re-examine suspect data points +c Also, mark as suspect reports from flights with only one or two reports +c remainder of reports from flights with excessive rejects +c +c modified by p.m.pauley (4/3/01) to decrease threshold percentage for bad flight +c rejects from 50% to 35% +c + implicit none +c +c Declaration statements +c ---------------------- + integer max_reps ! maximum number of reports +c + character*11 c_qc(max_reps) ! internal qc flags +c +c Data arrays +c ----------- + integer numreps ! actual number of reports + integer itype(max_reps) ! type of aircraft data + integer idt(max_reps) ! time in seconds to analysis time + character*8 c_acftreg(max_reps) ! aircraft registration (tail) number + character*9 c_acftid(max_reps) ! aircraft flight number + real*8 alat(max_reps) ! latitude + $, alon(max_reps) ! longitude + real pres(max_reps) ! pressure + $, ht_ft(max_reps) ! height in feet + real t_prcn(max_reps) ! temperature precision + real ob_t(max_reps) ! temperature + $, ob_q(max_reps) ! specific humidity + $, ob_dir(max_reps) ! wind direction + $, ob_spd(max_reps) ! wind speed + real xiv_t(max_reps) ! temperature innovation (ob - bk) + $, xiv_q(max_reps) ! specific humidity innovation (ob - bk) + $, xiv_d(max_reps) ! wind direction innovation (ob - bk) + $, xiv_s(max_reps) ! wind speed innovation (ob - bk) + integer ichk_t(max_reps) ! NRL QC flag for temperature ob + $, ichk_q(max_reps) ! NRL QC flag for specific humidity ob + $, ichk_d(max_reps) ! NRL QC flag for wind direction ob + $, ichk_s(max_reps) ! NRL QC flag for wind speed ob + character*25 csort(max_reps) ! sort variable +c +c Pointers +c -------- + integer indx(max_reps) ! pointer index for good reports +c +c Functions +c --------- + character*16 c_insty_ob ! function to convert integer instrument + ! type to character instrument type + integer insty_ob_fun ! function to convert character + ! instrument type to integer +c +c Flight statistics +c ----------------- + integer maxflt ! max number of flights allowed + $, kflight ! number of flights in dataset + character*8 creg_flt(maxflt) ! tail number for each flight + integer nobs_flt(maxflt) ! number of reports per flight + $, ntot_flt(maxflt) ! previous value of total number of reports per flight + $, nrej_flt(maxflt) ! number of reports rejected per flight + $, iobs_flt(maxflt) ! index for first report in each flight +c + integer istart ! index for 1st rep in current flight + $, iistart ! index from pointer array for istart + $, iend ! index for last rep in current flight + $, iiend ! index from pointer array for iend +c +c Tail number statistics +c ---------------------- + integer kreg ! actual number of tail#s in dataset + character*8 creg_reg(maxflt) ! tail numbers + integer nobs_reg(maxflt,5) ! number of reports per tail# per type + integer ntot_reg(maxflt,5) ! total number of reports rejected per tail# + integer nwind_reg(maxflt,5) ! number of reports w. rejected winds +c +c Counters +c -------- + integer nsus_small(5) ! number of reports from small flights + $, nsus_perct(5) ! number of reports from bad flights + $, nsus_time(5) ! number of reports with bad times + $, nsus_lat(5) ! number of reports with bad latitudes + $, nsus_lon(5) ! number of reports with bad longitudes + $, nsus_alt(5) ! number of reports with bad altitudes + $, nsus_wind(5) ! number of reports with bad windspeeds + $, nsus_roll(5) ! number of reports with bad roll angles + integer kbad(5) ! counter for number of bad reports + $, kbadtot ! counter for total number of bad reports +ccccdak integer nrep_Ac ! number of acars reports considered + integer nrep_Ac ! number of tamdar reports considered + $, nrep_Md ! number of mdcrs reports considered + $, nrep_Ma ! number of manual airep reports considered + $, nrep_Ar ! number of airep reports considered + $, nrep_Am ! number of amdar reports considered +ccccdak integer nsus_Ac ! number of acars reports rejected + integer nsus_Ac ! number of tamdar reports rejected + $, nsus_Md ! number of mdcrs reports rejected + $, nsus_Ma ! number of manual airep reports rejected + $, nsus_Ar ! number of airep reports rejected + $, nsus_Am ! number of amdar reports rejected +c +c Instrument types +c ---------------- +ccccdak integer i_acars ! instrument type for acars + integer i_acars ! instrument type for tamdar +ccccdak $, i_acars_lvl ! instrument type for acars--level flt + $, i_acars_lvl ! instrument type for tamdar--level flt +ccccdak $, i_acars_asc ! instrument type for acars--ascent + $, i_acars_asc ! instrument type for tamdar--ascent +ccccdak $, i_acars_des ! instrument type for acars--descent + $, i_acars_des ! instrument type for tamdar--descent + $, i_mdcrs ! instrument type for mdcrs + $, i_mdcrs_lvl ! instrument type for mdcrs--level flt + $, i_mdcrs_asc ! instrument type for mdcrs--ascent + $, i_mdcrs_des ! instrument type for mdcrs--descent + $, i_man_airep ! instrument type for manual aireps + $, i_man_Yairep ! instrument type for manual aireps (YRXX) + $, i_airep ! instrument type for airep + $, i_airep_lvl ! instrument type for airep--level flt + $, i_airep_asc ! instrument type for airep--ascent + $, i_airep_des ! instrument type for airep--descent + $, i_amdar ! instrument type for amdar + $, i_amdar_lvl ! instrument type for amdar--level flt + $, i_amdar_asc ! instrument type for amdar--ascent + $, i_amdar_des ! instrument type for amdar--descent + $, ktype ! +c +c Other variables +c --------------- + integer io8 ! i/o unit number for log file + integer io37 ! i/o unit number for suspect data check rejects +c + real perct_flt ! percent of rejected reports for this flight + $, perct_reg ! percent of rejected reports for this aircraft + $, spdm1 ! speed in iim1 report + $, spdp1 ! speed in iip1 report + $, amiss ! real missing value flag +c + integer imiss ! integer missing value + integer iob ! do loop index + $, ii ! index pointing to current report + $, iim1 ! index pointing to previous report + $, iip1 ! index pointing to following report + integer knt ! counter used to define iim1 index + $, knt0 ! counter used to define iip1 index +c + integer kk,mm ! do loop index + $, ntot ! sum over data types of ntot_reg + $, nobs ! sum over data types of nobs_reg + $, idt_dif0 ! time difference (current - previous report) + $, idt_difp1 ! time difference (current - following report) + integer idt_near ! time difference between "near" neighbors +c + logical l_print ! switch for printing + $, l_init ! if true, initialize counters + $, l_operational ! true if operational mode used +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c +c Initialize aircraft data types +c ------------------------------ + i_acars = insty_ob_fun('acars') + i_acars_lvl = insty_ob_fun('acars_lvl') + i_acars_asc = insty_ob_fun('acars_asc') + i_acars_des = insty_ob_fun('acars_des') + i_mdcrs = insty_ob_fun('mdcrs') + i_mdcrs_lvl = insty_ob_fun('mdcrs_lvl') + i_mdcrs_asc = insty_ob_fun('mdcrs_asc') + i_mdcrs_des = insty_ob_fun('mdcrs_des') + i_man_airep = insty_ob_fun('man-airep') + i_man_Yairep = insty_ob_fun('man-Yairep') + i_airep = insty_ob_fun('airep') + i_airep_lvl = insty_ob_fun('airep_lvl') + i_airep_asc = insty_ob_fun('airep_asc') + i_airep_des = insty_ob_fun('airep_des') + i_amdar = insty_ob_fun('amdar') + i_amdar_lvl = insty_ob_fun('amdar_lvl') + i_amdar_asc = insty_ob_fun('amdar_asc') + i_amdar_des = insty_ob_fun('amdar_des') +c +c Initialize counters +c ------------------- + if(l_init) then + nsus_small = 0 + nsus_perct = 0 + nsus_time = 0 + nsus_lat = 0 + nsus_lon = 0 + nsus_alt = 0 + nsus_wind = 0 + nsus_roll = 0 + nrep_Ac = 0 + nrep_Md = 0 + nrep_Ma = 0 + nrep_Ar = 0 + nrep_Am = 0 + nsus_Ac = 0 + nsus_Md = 0 + nsus_Ma = 0 + nsus_Ar = 0 + nsus_Am = 0 + endif +c + nwind_reg = 0 +c +c Begin loop over flights +c ----------------------- + do kk = 1,kflight +c +c Initialize variables +c -------------------- + istart = iobs_flt(kk) + iistart = indx(istart) + iend = iobs_flt(kk) + nobs_flt(kk) - 1 + iiend = indx(iend) +c +c Mark as suspect reports from flights with only one or two reports +c ----------------------------------------------------------------- + if(nobs_flt(kk).eq.1.and. + $ itype(iistart).ne.i_man_airep.and. + $ itype(iistart).ne.i_man_Yairep) then + c_qc(iistart)(1:1) = 's' +c + elseif(nobs_flt(kk).eq.2.and. + $ itype(iistart).ne.i_man_airep.and. + $ itype(iistart).ne.i_man_Yairep) then + c_qc(iistart)(1:1) = 's' + c_qc(iiend)(1:1) = 's' +c +c Do further checks on flights with 3 or more reports +c --------------------------------------------------- + elseif(nobs_flt(kk).ge.3) then +c +c Loop over flights +c ----------------- + do iob=istart,iend + ii = indx(iob) + l_print = .false. +c +c Check suspect time, lat, lon, height, or winds +c ---------------------------------------------- + if(c_qc(ii)(2:2).eq.'S'.or. + $ c_qc(ii)(3:3).eq.'S'.or. + $ c_qc(ii)(4:4).eq.'S'.or. + $ c_qc(ii)(5:5).eq.'S'.or. + $ c_qc(ii)(8:8).eq.'S'.or. + $ ichk_s(ii).eq.-10) then +c +c Compute ii-1 index +c ------------------ + knt = iob - 1 + 10 if(knt.ge.istart) then + iim1 = indx(knt) + if(c_qc(iim1)(1:1).eq.'s'.or. + $ c_qc(iim1)(2:2).eq.'B'.or. + $ c_qc(iim1)(3:3).eq.'B'.or. + $ c_qc(iim1)(4:4).eq.'B'.or. + $ c_qc(iim1)(5:5).eq.'B') then + knt = knt - 1 + goto 10 + endif + else + iim1 = 0 + endif +c +c Compute ii+1 index +c ------------------ + knt0 = iob + 1 + 20 if(knt0.le.iend) then + iip1 = indx(knt0) + if(c_qc(iip1)(1:1).eq.'s'.or. + $ c_qc(iip1)(2:2).eq.'B'.or. + $ c_qc(iip1)(3:3).eq.'B'.or. + $ c_qc(iip1)(4:4).eq.'B'.or. + $ c_qc(iip1)(5:5).eq.'B') then + knt0 = knt0 + 1 + goto 20 + endif + else + iip1 = 0 + endif +c +c Compute time differences +c ------------------------ + if(iim1.ne.0) then + idt_dif0 = abs(idt(ii) - idt(iim1)) + spdm1 = ob_spd(iim1) + else + idt_dif0 = imiss + spdm1 = amiss + endif +c + if(iip1.ne.0) then + idt_difp1 = abs(idt(iip1) - idt(ii)) + spdp1 = ob_spd(iip1) + else + idt_difp1 = imiss + spdp1 = amiss + endif +c +c Check suspect winds +c ------------------- + if(c_qc(ii)(8:8).eq.'S'.and.ob_spd(ii).eq.0.0) then +c + if((idt_dif0 .le.idt_near*2.and.idt_dif0 .ne.imiss.and. + $ idt_difp1.le.idt_near*2.and.idt_difp1.ne.imiss.and. + $ (spdm1.ne.0.0.or.spdp1.ne.0.0).and. + $ ((spdm1.le.5.0.and.spdm1.ne.amiss.and. + $ spdp1.le.5.0.and.spdp1.ne.amiss).or. + $ ht_ft(ii).le.5000.)).or. + $ (idt_dif0 .le.idt_near*2.and.idt_dif0.ne.imiss.and. + $ idt_difp1.gt.idt_near*2.and. + $ spdm1.ne.0.0.and.spdm1.ne.amiss.and. + $ (spdm1.le.5.0.or.ht_ft(ii).le.5000.)).or. + $ (idt_dif0 .gt.idt_near*2.and. + $ idt_difp1.le.idt_near*2.and.idt_difp1.ne.imiss.and. + $ spdp1.ne.0.0.and.spdp1.ne.amiss.and. + $ (spdp1.le.5.0.or.ht_ft(ii).le.5000.))) then +c + c_qc(ii)(8:8) = '.' +c + if(ht_ft(ii).gt.10000.0) then + l_print = .true. + else + l_print = .false. + endif + if(l_print) then + write(io8,*) + write(io8,*) 'Suspect winds are ok at ii = ',ii + endif +c + else + c_qc(ii)(8:8) = 'B' +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Suspect winds are NOT ok at ii = ',ii + endif + endif +c +c Reject remaining suspect times, latitudes, longitudes, altitudes +c (Previously checked in ordchek and ok'ed values reset) +c ------------------------------------------------------ + elseif(c_qc(ii)(2:2).eq.'S') then +c + c_qc(ii)(2:2) = 'B' + nrej_flt(kk) = nrej_flt(kk) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Suspect time is NOT ok at ii =',ii + endif +c + elseif(c_qc(ii)(3:3).eq.'S') then +c + c_qc(ii)(3:3) = 'B' + nrej_flt(kk) = nrej_flt(kk) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Suspect latitude is NOT ok at ii = ',ii + endif +c + elseif(c_qc(ii)(4:4).eq.'S') then +c + c_qc(ii)(4:4) = 'B' + nrej_flt(kk) = nrej_flt(kk) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Suspect longitude is NOT ok at ii = ',ii + endif +c + elseif(c_qc(ii)(5:5).eq.'S') then +c + c_qc(ii)(5:5) = 'B' + nrej_flt(kk) = nrej_flt(kk) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Suspect altitude is NOT ok at ii = ',ii + endif + endif +c +c Check if roll angle qc flag is set +c ---------------------------------- + if(ichk_s(ii).eq.-10) then + if(c_acftreg(ii)(4:5).eq.'WU'.or. + $ c_acftreg(ii)(4:5).eq.'GU'.or. + $ c_acftreg(ii)(4:5).eq.'KJ'.or. + $ c_acftreg(ii)(4:5).eq.'0J'.or. + $ c_acftreg(ii)(4:5).eq.'YC'.or. + $ c_acftreg(ii)(4:5).eq.'IC'.or. + $ c_acftreg(ii)(4:5).eq.'EI'.or. + $ c_acftreg(ii)(4:5).eq.'UI'.or. + $ c_acftreg(ii)(1:2).eq.'AU'.or. + $ c_acftreg(ii)(1:2).eq.'EU') then + l_print = .false. + else + l_print = .true. + endif +c + c_qc(ii)(7:8) = 'ss' +c + if(l_print) then + write(io8,*) + write(io8,*) 'Bad roll angle QC flag on unlisted acft' + endif + endif + endif +c +c Print set of reports if print flag is set +c ----------------------------------------- + if(l_print) then + if(iim1.ne.0) then + write(io8,8002) kk,iim1 + x, c_insty_ob(itype(iim1)) + x, c_acftreg(iim1),c_acftid(iim1) + x, idt(iim1),alat(iim1),alon(iim1) + x, pres(iim1),ht_ft(iim1) + x, t_prcn(iim1),ob_t(iim1),xiv_t(iim1),ichk_t(iim1) + x, ob_q(iim1),xiv_q(iim1),ichk_q(iim1) + x, ob_dir(iim1),xiv_d(iim1),ichk_d(iim1) + x, ob_spd(iim1),xiv_s(iim1),ichk_s(iim1) + x, c_qc(iim1) + endif +c + write(io8,8002) kk,ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) +c + if(iip1.ne.0) then + write(io8,8002) kk,iip1 + x, c_insty_ob(itype(iip1)) + x, c_acftreg(iip1),c_acftid(iip1) + x, idt(iip1),alat(iip1),alon(iip1) + x, pres(iip1),ht_ft(iip1) + x, t_prcn(iip1),ob_t(iip1),xiv_t(iip1),ichk_t(iip1) + x, ob_q(iip1),xiv_q(iip1),ichk_q(iip1) + x, ob_dir(iip1),xiv_d(iip1),ichk_d(iip1) + x, ob_spd(iip1),xiv_s(iip1),ichk_s(iip1) + x, c_qc(iip1) + endif + 8002 format(i4,1x,i6,1x,a8,1x,a8,1x,a9,1x,i7,1x,2f11.5,1x + x, f8.1,1x,f7.0 + x, 1x,f5.2,4(2(1x,f8.2),1x,i5),1x,'!',a11,'!') + endif + enddo +c +c Check if excessive rejects are present for this flight +c ------------------------------------------------------ + if(ntot_flt(kk).eq.0) then + write(io8,*) + write(io8,*) 'ntot_flt(kk) = 0 for kk =',kk,' ',creg_flt(kk) + perct_flt = -9999. + else + perct_flt = 100.0 * float(nrej_flt(kk))/float(ntot_flt(kk)) + endif +c +c Check if excessive rejects are present for this aircraft +c -------------------------------------------------------- + if(nrej_flt(kk).ne.ntot_flt(kk)) then + mm = 1 + perct_reg = 0.0 + do while(mm.le.kreg) + if(creg_flt(kk).eq.creg_reg(mm)) then + ntot = ntot_reg(mm,1) + ntot_reg(mm,2) + $ + ntot_reg(mm,3) + ntot_reg(mm,4) + ntot_reg(mm,5) + nobs = nobs_reg(mm,1) + nobs_reg(mm,2) + $ + nobs_reg(mm,3) + nobs_reg(mm,4) + nobs_reg(mm,5) + if(nobs.eq.0) then + write(io8,*) + write(io8,*) 'nobs_reg(mm) = 0 for mm = ',mm + perct_flt = -9999. + else + perct_reg = 100.0 * float(ntot) / float(nobs) + endif + mm = kreg + 1 + endif + mm = mm + 1 + enddo +c +c Check percentage of reports from flight and percentage of +c reports from non-manAIREP tail numbers +c --------------------------------------------------------- + if((perct_flt.ne.-9999..and.perct_flt.gt.35.0).or. + $ (creg_flt(kk)(5:8).ne.' '.and. + $ (perct_reg.ne.-9999..and.perct_reg.gt.35.0))) then +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Excessive rejects found for flight ',kk + write(io8,*) '% flt = ',perct_flt,' nrej = ', + $ nrej_flt(kk),' nobs = ',ntot_flt(kk) + write(io8,*) '% reg = ',perct_reg,' nrej = ',ntot, + $ ' nobs = ',nobs + endif +c +c Loop over flights +c ----------------- + do iob=istart,iend + ii = indx(iob) + if(c_qc(ii)(1:1).ne.'s'.and. + $ c_qc(ii)(2:2).ne.'B'.and. + $ c_qc(ii)(3:3).ne.'B'.and. + $ c_qc(ii)(4:4).ne.'B'.and. + $ c_qc(ii)(5:5).ne.'B') then +c + c_qc(ii)(1:1) = 'S' + write(io8,8002) kk,ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) +c + endif + enddo + endif + endif + endif +c +c End loop over flights +c --------------------- + enddo +c +c Write out bad reports +c --------------------- + if(.not.l_operational) then + write(io37,*) + write(io37,*) 'Suspect data check' + write(io37,*) '------------------' + write(io37,3001) + 3001 format(' index type tail num flight time lat' + x, ' lon pres height ' + x, 't-prcn temp innov ichk' + x, ' spec hum innov ichk' + x, ' ob_dir innov ichk' + x, ' ob_spd innov ichk' + x, ' qc flag') + endif +c + kbad = 0 +c + do iob = 1,numreps + ii = indx(iob) +c + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des) then + ktype = 1 +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des) then + ktype = 2 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des) then + ktype = 3 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des) then + ktype = 4 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + ktype = 5 + endif +c + if(ktype.eq.1) then + nrep_Md = nrep_Md + 1 + elseif(ktype.eq.2) then + nrep_Ac = nrep_Ac + 1 + elseif(ktype.eq.3) then + nrep_Am = nrep_Am + 1 + elseif(ktype.eq.4) then + nrep_Ar = nrep_Ar + 1 + elseif(ktype.eq.5) then + nrep_Ma = nrep_Ma + 1 + endif +c + if(c_qc(ii)(1:1).eq.'s'.or. + $ c_qc(ii)(1:1).eq.'S'.or. + $ c_qc(ii)(2:2).eq.'B'.or. + $ c_qc(ii)(3:3).eq.'B'.or. + $ c_qc(ii)(4:4).eq.'B'.or. + $ c_qc(ii)(5:5).eq.'B'.or. + $ c_qc(ii)(8:8).eq.'B'.or. + $ c_qc(ii)(7:8).eq.'ss') then +c + if(.not.l_operational) then + write(io37,3002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + 3002 format(i6,1x,a8,1x,a8,1x,a9,1x,i7,1x,2f11.5,1x,f8.1,1x,f7.0 + x, 1x,f5.2,4(2(1x,f8.2),1x,i5),1x,'!',a11,'!') + endif +c +c Count number of rejected temps/winds by tail number +c --------------------------------------------------- + if(c_qc(ii)(8:8).eq.'B') then + mm = 1 + do while(mm.le.kreg) + if(c_acftreg(ii).eq.creg_reg(mm)) then + if(ktype.gt.0.and.ktype.le.5) + $ nwind_reg(mm,ktype) = nwind_reg(mm,ktype) + 1 + mm = kreg + 1 + endif + mm = mm + 1 + enddo + endif +c +c Count by category +c ----------------- + if(c_qc(ii)(1:1).eq.'s') then + nsus_small(ktype) = nsus_small(ktype) + 1 + elseif(c_qc(ii)(1:1).eq.'S') then + nsus_perct(ktype) = nsus_perct(ktype) + 1 + elseif(c_qc(ii)(2:2).eq.'B') then + nsus_time(ktype) = nsus_time(ktype) + 1 + elseif(c_qc(ii)(3:3).eq.'B') then + nsus_lat(ktype) = nsus_lat(ktype) + 1 + elseif(c_qc(ii)(4:4).eq.'B') then + nsus_lon(ktype) = nsus_lon(ktype) + 1 + elseif(c_qc(ii)(5:5).eq.'B') then + nsus_alt(ktype) = nsus_alt(ktype) + 1 + elseif(c_qc(ii)(8:8).eq.'B') then + nsus_wind(ktype) = nsus_wind(ktype) + 1 + elseif(c_qc(ii)(7:8).eq.'ss') then + nsus_roll(ktype) = nsus_roll(ktype) + 1 + endif +c +c Reject reports with inconsistent heights and positions +c ------------------------------------------------------ + if(c_qc(ii)(1:1).eq.'s'.or. + $ c_qc(ii)(1:1).eq.'S'.or. + $ c_qc(ii)(2:2).eq.'B'.or. + $ c_qc(ii)(3:3).eq.'B'.or. + $ c_qc(ii)(4:4).eq.'B'.or. + $ c_qc(ii)(5:5).eq.'B') then +c + csort(ii)(1:5) = 'badob' +c + kbad(ktype) = kbad(ktype) + 1 +c + if(ktype.eq.1) then + nsus_Md = nsus_Md + 1 + elseif(ktype.eq.2) then + nsus_Ac = nsus_Ac + 1 + elseif(ktype.eq.3) then + nsus_Am = nsus_Am + 1 + elseif(ktype.eq.4) then + nsus_Ar = nsus_Ar + 1 + elseif(ktype.eq.5) then + nsus_Ma = nsus_Ma + 1 + endif + endif +c + endif + enddo +c + if(.not.l_operational) then + write(io37,*) + write(io37,*) ' Number of MDCRS reps rej by sus = ',kbad(1) +ccccdak write(io37,*) ' Number of ACARS reps rej by sus = ',kbad(2) + write(io37,*) ' Number of TAMDAR reps rej by sus = ',kbad(2) + write(io37,*) ' Number of AMDAR reps rej by sus = ',kbad(3) + write(io37,*) ' Number of AIREP reps rej by sus = ',kbad(4) + write(io37,*) ' Number of manAIREP reps rej by sus = ',kbad(5) + endif +c + write(io8,*) + write(io8,*) ' Reports with suspect data errors--rejected' + write(io8,*) ' ------------------------------------------' + write(io8,*) ' Number of MDCRS reps rej by sus = ',kbad(1) +ccccdak write(io8,*) ' Number of ACARS reps rej by sus = ',kbad(2) + write(io8,*) ' Number of TAMDAR reps rej by sus = ',kbad(2) + write(io8,*) ' Number of AMDAR reps rej by sus = ',kbad(3) + write(io8,*) ' Number of AIREP reps rej by sus = ',kbad(4) + write(io8,*) ' Number of manAIREP reps rej by sus = ',kbad(5) +c +c Output tail number counts +c ------------------------- + write(io8,*) + write(io8,*) ' Tail numbers for reps with rejected zero winds' +ccccdak write(io8,*) ' Tail Num MDCRS ACARS AMDAR AIREP MAN ' + write(io8,*) ' Tail Num MDCRS TAMDAR AMDAR AIREP MAN ' + write(io8,*) ' ----------------------------------------------' +c + do mm=1,kreg + if( nwind_reg(mm,1)+nwind_reg(mm,2)+nwind_reg(mm,3) + $ +nwind_reg(mm,4)+nwind_reg(mm,5).gt.0) then + write(io8,'(2x,a8,5(1x,i6))') + $ creg_reg(mm),(nwind_reg(mm,kk),kk=1,5) + endif + enddo +c + write(io8,*) + write(io8,*) 'Suspect data check counts' + write(io8,*) '-------------------------' + write(io8,'(1x,a55)') +ccccdak $ 'Type of check MDCRS ACARS AMDAR AIREP man' + $ 'Type of check MDCRS TAMDAR AMDAR AIREP man' + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Num considered '',5(1x,i7))') + $ nrep_Md,nrep_Ac,nrep_Am,nrep_Ar,nrep_Ma + write(io8,'(''Total rejected '',5(1x,i7))') + $ nsus_Md,nsus_Ac,nsus_Am,nsus_Ar,nsus_Ma + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Small flights '',5(1x,i7))') + $ (nsus_small(ii),ii=1,5) + write(io8,'(''Bad flights '',5(1x,i7))') + $ (nsus_perct(ii),ii=1,5) + write(io8,'(''Bad times '',5(1x,i7))') + $ (nsus_time(ii),ii=1,5) + write(io8,'(''Bad lats '',5(1x,i7))') + $ (nsus_lat(ii),ii=1,5) + write(io8,'(''Bad lons '',5(1x,i7))') + $ (nsus_lon(ii),ii=1,5) + write(io8,'(''Bad alts '',5(1x,i7))') + $ (nsus_alt(ii),ii=1,5) + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Bad winds '',5(1x,i7))') + $ (nsus_wind(ii),ii=1,5) + write(io8,'(''Bad roll angle '',5(1x,i7))') + $ (nsus_roll(ii),ii=1,5) + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + kbadtot = kbad(1) + kbad(2) + kbad(3) + $ + kbad(4) + kbad(5) +c + write(io8,*) + write(io8,*) numreps,' good reports processed' + write(io8,*) kbadtot,' reports failed qc in suspect data check' +c + return + end +c +c ################################################################### +c subroutine rejlist_qc +c ################################################################### +c + subroutine rejlist_qc(numreps,max_reps,indx,csort + $, c_acftreg,c_acftid,c_qc + $, alat,alon,pres,ht_ft,t_prcn,ob_t,ob_q,ob_dir,ob_spd + $, xiv_t,xiv_q,xiv_d,xiv_s + $, idt,itype,ichk_t,ichk_q,ichk_d,ichk_s + $, nchk_t,nchk_q,nchk_d,nchk_s + $, maxflt,kreg,creg_reg,nwind_reg,ntemp_reg + $, kbadtot,io8,io38,l_operational,l_init,l_ncep) +c +c Reject temperatures and winds from aircraft on reject list +c +c Just reject manAIREP aircraft for now. Suspect airlines determined +c by Colin Parrett (UKMet) are listed in a data statement. +c +c Written by P.M. Pauley (6/5/02) +c + implicit none +c +c Parameter statements +c -------------------- + integer nwind ! number of aircraft on wind reject list + integer ntemp ! number of aircraft on temperature reject list + parameter(nwind = 12,ntemp = 12) +c +c Declaration statements +c ---------------------- + integer max_reps ! maximum number of reports +c + character*11 c_qc(max_reps) ! internal qc flags +c +c Data arrays +c ----------- + integer numreps ! actual number of reports + integer itype(max_reps) ! type of aircraft data + integer idt(max_reps) ! time in seconds to analysis time + character*8 c_acftreg(max_reps) ! aircraft registration (tail) number + character*9 c_acftid(max_reps) ! aircraft flight number + real*8 alat(max_reps) ! latitude + $, alon(max_reps) ! longitude + real pres(max_reps) ! pressure + $, ht_ft(max_reps) ! height in feet + real t_prcn(max_reps) ! temperature precision + real ob_t(max_reps) ! temperature + $, ob_q(max_reps) ! specific humidity + $, ob_dir(max_reps) ! wind direction + $, ob_spd(max_reps) ! wind speed + real xiv_t(max_reps) ! temperature innovation (ob - bk) + $, xiv_q(max_reps) ! specific humidity innovation (ob - bk) + $, xiv_d(max_reps) ! wind direction innovation (ob - bk) + $, xiv_s(max_reps) ! wind speed innovation (ob - bk) + integer ichk_t(max_reps) ! NRL QC flag for temperature ob + $, ichk_q(max_reps) ! NRL QC flag for specific humidity ob + $, ichk_d(max_reps) ! NRL QC flag for wind direction ob + $, ichk_s(max_reps) ! NRL QC flag for wind speed ob + integer nchk_t(max_reps) ! NCEP QC flag for temperature ob + $, nchk_q(max_reps) ! NCEP QC flag for specific humidity ob + $, nchk_d(max_reps) ! NCEP QC flag for wind direction ob + $, nchk_s(max_reps) ! NCEP QC flag for wind speed ob + character*25 csort(max_reps) ! sort variable +c +c Pointers +c -------- + integer indx(max_reps) ! pointer index for good reports +c +c Functions +c --------- + character*16 c_insty_ob ! function to convert integer instrument + ! type to character instrument type + integer insty_ob_fun ! function to convert character + ! instrument type to integer +c +c Tail number statistics +c ---------------------- + integer maxflt ! max number of flights allowed + integer kreg ! actual number of tail#s in dataset + character*8 creg_reg(maxflt) ! tail numbers + integer nwind_reg(maxflt,5) ! number of reports w. rejected winds + integer ntemp_reg(maxflt,5) ! number of reports w. rejected temperatures +c +c Counters +c -------- + integer kbad(5) ! counter for number of bad reports + $, kbadtot ! counter for total number of bad reports +ccccdak integer nrep_Ac ! number of acars reports considered + integer nrep_Ac ! number of tamdar reports considered + $, nrep_Md ! number of mdcrs reports considered + $, nrep_Ma ! number of manual airep reports considered + $, nrep_Ar ! number of airep reports considered + $, nrep_Am ! number of amdar reports considered +ccccdak integer nlst_Ac ! number of acars reports rejected + integer nlst_Ac ! number of tamdar reports rejected + $, nlst_Md ! number of mdcrs reports rejected + $, nlst_Ma ! number of manual airep reports rejected + $, nlst_Ar ! number of airep reports rejected + $, nlst_Am ! number of amdar reports rejected +c + integer nlst_wind(5) ! number of winds rejected by aircraft type + $, nlst_temp(5) ! number of temperatures rejected by aircraft type + $, nlst_both(5) ! number of both winds/temps by aircraft type +c +c Instrument types +c ---------------- +ccccdak integer i_acars ! instrument type for acars + integer i_acars ! instrument type for tamdar +ccccdak $, i_acars_lvl ! instrument type for acars--level flt + $, i_acars_lvl ! instrument type for tamdar--level flt +ccccdak $, i_acars_asc ! instrument type for acars--ascent + $, i_acars_asc ! instrument type for tamdar--ascent +ccccdak $, i_acars_des ! instrument type for acars--descent + $, i_acars_des ! instrument type for tamdar--descent + $, i_mdcrs ! instrument type for mdcrs + $, i_mdcrs_lvl ! instrument type for mdcrs--level flt + $, i_mdcrs_asc ! instrument type for mdcrs--ascent + $, i_mdcrs_des ! instrument type for mdcrs--descent + $, i_man_airep ! instrument type for manual aireps + $, i_man_Yairep ! instrument type for manual aireps (YRXX) + $, i_airep ! instrument type for airep + $, i_airep_lvl ! instrument type for airep--level flt + $, i_airep_asc ! instrument type for airep--ascent + $, i_airep_des ! instrument type for airep--descent + $, i_amdar ! instrument type for amdar + $, i_amdar_lvl ! instrument type for amdar--level flt + $, i_amdar_asc ! instrument type for amdar--ascent + $, i_amdar_des ! instrument type for amdar--descent + $, ktype ! index for instrument type +c +c Other variables +c --------------- + integer io8 ! i/o unit number for log file + integer io38 ! i/o unit number for reject list rejects +c + integer kwind ! index for wind list + $, ktemp ! index for temperature list +c + integer iob ! index for observations + $, ii ! index for sorted observations + $, mm ! index for tail numbers + $, kk ! index for flight (not used in this way - dak - ??) +c + logical l_print ! switch for printing + $, l_init ! if true, initialize counters + $, l_operational ! true if operational mode used + $, l_ncep ! run QC w/ NCEP preferences if true +c +c Reject list +c ----------- + character*8 c_reg_wind(nwind) ! reject list for wind data + $, c_reg_temp(ntemp) ! reject list for temperature data +c +c Data statements +c Last tail number in each list must be blank +c ------------------------------------------- + +c Per Pat Pauley on 9/27/05, these reject lists are very old and should +c be set to all blanks. +cc data c_reg_wind/'CCA ','EIA ','GCO ','RCH ' +cc $, 'VRG ','WA ',' ',' ' +cc $, ' ',' ',' ',' '/ + data c_reg_wind/' ',' ',' ',' ' + $, ' ',' ',' ',' ' + $, ' ',' ',' ',' '/ +c +cc data c_reg_temp/'RCH ','RZO ','VRG ','AR ' +cc $, 'WA ',' ',' ',' ' +cc $, ' ',' ',' ',' '/ + data c_reg_temp/' ',' ',' ',' ' + $, ' ',' ',' ',' ' + $, ' ',' ',' ',' '/ +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c +c Initialize aircraft data types +c ------------------------------ + i_acars = insty_ob_fun('acars') + i_acars_lvl = insty_ob_fun('acars_lvl') + i_acars_asc = insty_ob_fun('acars_asc') + i_acars_des = insty_ob_fun('acars_des') + i_mdcrs = insty_ob_fun('mdcrs') + i_mdcrs_lvl = insty_ob_fun('mdcrs_lvl') + i_mdcrs_asc = insty_ob_fun('mdcrs_asc') + i_mdcrs_des = insty_ob_fun('mdcrs_des') + i_man_airep = insty_ob_fun('man-airep') + i_man_Yairep = insty_ob_fun('man-Yairep') + i_airep = insty_ob_fun('airep') + i_airep_lvl = insty_ob_fun('airep_lvl') + i_airep_asc = insty_ob_fun('airep_asc') + i_airep_des = insty_ob_fun('airep_des') + i_amdar = insty_ob_fun('amdar') + i_amdar_lvl = insty_ob_fun('amdar_lvl') + i_amdar_asc = insty_ob_fun('amdar_asc') + i_amdar_des = insty_ob_fun('amdar_des') +c +c Initialize counters +c ------------------- + if(l_init) then + nrep_Ac = 0 + nrep_Md = 0 + nrep_Ma = 0 + nrep_Ar = 0 + nrep_Am = 0 +c + nlst_Ac = 0 + nlst_Md = 0 + nlst_Ma = 0 + nlst_Ar = 0 + nlst_Am = 0 + endif +c + nwind_reg = 0 + ntemp_reg = 0 +c DAK: kk was never initialized - set it to -99 (used in several prints below) + kk = -99 + + nlst_wind = 0 + nlst_temp = 0 + nlst_both = 0 + +c +c Begin loop over obs +c ------------------- + do iob=1,numreps + ii = indx(iob) +c +c Check wind reject list +c ---------------------- + if(.not.l_ncep) then + + kwind = 1 + do while(c_reg_wind(kwind)(1:1).ne.' ') +c +c Tail number found on list +c ------------------------- + if(c_acftreg(ii)(1:8).eq.c_reg_wind(kwind)(1:8)) then +c + c_qc(ii)(10:10) = 'W' +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Aircraft found on NRL wind reject list' + write(io8,8002) kk,ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + 8002 format(i4,1x,i6,1x,a8,1x,a8,1x,a9,1x,i7,1x,2f11.5,1x + x, f8.1,1x,f7.0 + x, 1x,f5.2,4(2(1x,f8.2),1x,i5),1x,'!',a11,'!') + endif +c + kwind = nwind +c + else + kwind = kwind + 1 + endif + enddo + else + +c For NCEP runs, if NCEP/PREPBUFR QM of 14 found on wind dir or spd, this report's wind is on +c NCEP's SDMEDIT reject list which is read prior to PREPBUFR processing - set byte 10 to +c 'W" so that this report's wind also fails NRL QC reject data check +c ------------------------------------------------------------------------------------------- + if(nchk_d(ii).eq.14.or.nchk_s(ii).eq.14) then + c_qc(ii)(10:10) = 'W' + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Aircraft found on NCEP wind reject list' + write(io8,8002) kk,ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + endif + endif + endif +c +c Check temperature reject list +c ----------------------------- + if(.not.l_ncep) then + + ktemp = 1 + do while(c_reg_temp(ktemp)(1:1).ne.' ') +c +c Tail number found on list +c ------------------------- + if(c_acftreg(ii)(1:8).eq.c_reg_temp(ktemp)(1:8)) then +c + if(c_qc(ii)(10:10).eq.'W') then + c_qc(ii)(10:10) = 'O' + else + c_qc(ii)(10:10) = 'T' + endif +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Aircraft found on NRL temperature reject list' + write(io8,8002) kk,ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + endif +c + ktemp = ntemp +c + else + ktemp = ktemp + 1 + endif + enddo + else + +c For NCEP runs, if NCEP/PREPBUFR QM of 14 found on temperature, this report's temperature is +c on NCEP's SDMEDIT reject list which is read prior to PREPBUFR processing - set byte 10 to +c 'T" so that this report's temperature fails NRL QC reject data check, or if wind for this +c report is also on NCEP's SDMEDIT reject list set byte 10 to 'O' so that this report's +c wind and temperature fail NRL QC reject data check +c ------------------------------------------------------------------------------------------- + if(nchk_t(ii).eq.14) then + if(c_qc(ii)(10:10).eq.'W') then + c_qc(ii)(10:10) = 'O' + else + c_qc(ii)(10:10) = 'T' + endif + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Aircraft found on NCEP temperature reject list' + write(io8,8002) kk,ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + endif + endif + endif +c + enddo +c +c Write out bad reports +c --------------------- + if(.not.l_operational) then + write(io38,*) + write(io38,*) 'Reject list check' + write(io38,*) '-----------------' + write(io38,3001) + 3001 format(' index type tail num flight time lat' + x, ' lon pres height ' + x, 't-prcn temp innov ichk' + x, ' spec hum innov ichk' + x, ' ob_dir innov ichk' + x, ' ob_spd innov ichk' + x, ' qc flag') + endif +c + kbad = 0 +c + do iob = 1,numreps + ii = indx(iob) +c + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des) then + ktype = 1 +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des) then + ktype = 2 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des) then + ktype = 3 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des) then + ktype = 4 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + ktype = 5 + endif +c + if(ktype.eq.1) then + nrep_Md = nrep_Md + 1 + elseif(ktype.eq.2) then + nrep_Ac = nrep_Ac + 1 + elseif(ktype.eq.3) then + nrep_Am = nrep_Am + 1 + elseif(ktype.eq.4) then + nrep_Ar = nrep_Ar + 1 + elseif(ktype.eq.5) then + nrep_Ma = nrep_Ma + 1 + endif +c + if(c_qc(ii)(10:10).eq.'T'.or. + $ c_qc(ii)(10:10).eq.'W'.or. + $ c_qc(ii)(10:10).eq.'O') then +c + if(.not.l_operational) then + write(io38,3002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + 3002 format(i6,1x,a8,1x,a8,1x,a9,1x,i7,1x,2f11.5,1x,f8.1,1x,f7.0 + x, 1x,f5.2,4(2(1x,f8.2),1x,i5),1x,'!',a11,'!') + endif +c +c Count number of rejected winds by tail number +c --------------------------------------------- + if(c_qc(ii)(10:10).eq.'W'.or. + $ c_qc(ii)(10:10).eq.'O') then + mm = 1 + do while(mm.le.kreg) + if(c_acftreg(ii).eq.creg_reg(mm)) then + if(ktype.gt.0.and.ktype.le.5) + $ nwind_reg(mm,ktype) = nwind_reg(mm,ktype) + 1 + mm = kreg + 1 + endif + mm = mm + 1 + enddo + endif +c +c Count number of rejected temperatures by tail number +c ---------------------------------------------------- + if(c_qc(ii)(10:10).eq.'T'.or. + $ c_qc(ii)(10:10).eq.'O') then + mm = 1 + do while(mm.le.kreg) + if(c_acftreg(ii).eq.creg_reg(mm)) then + if(ktype.gt.0.and.ktype.le.5) + $ ntemp_reg(mm,ktype) = ntemp_reg(mm,ktype) + 1 + mm = kreg + 1 + endif + mm = mm + 1 + enddo + endif +c +c Count by category +c ----------------- + if(c_qc(ii)(10:10).eq.'W') then + nlst_wind(ktype) = nlst_wind(ktype) + 1 + elseif(c_qc(ii)(10:10).eq.'T') then + nlst_temp(ktype) = nlst_temp(ktype) + 1 + elseif(c_qc(ii)(10:10).eq.'O') then + nlst_both(ktype) = nlst_both(ktype) + 1 + endif +c +c Reject reports with inconsistent heights and positions +c ------------------------------------------------------ + if(c_qc(ii)(10:10).eq.'O') then +c + csort(ii)(1:5) = 'badob' +c + kbad(ktype) = kbad(ktype) + 1 +c + if(ktype.eq.1) then + nlst_Md = nlst_Md + 1 + elseif(ktype.eq.2) then + nlst_Ac = nlst_Ac + 1 + elseif(ktype.eq.3) then + nlst_Am = nlst_Am + 1 + elseif(ktype.eq.4) then + nlst_Ar = nlst_Ar + 1 + elseif(ktype.eq.5) then + nlst_Ma = nlst_Ma + 1 + endif + endif +c + endif + enddo +c + if(.not.l_operational) then + write(io38,*) + write(io38,*) ' Number of MDCRS reps rej by lst = ',kbad(1) +ccccdak write(io38,*) ' Number of ACARS reps rej by lst = ',kbad(2) + write(io38,*) ' Number of TAMDAR reps rej by lst = ',kbad(2) + write(io38,*) ' Number of AMDAR reps rej by lst = ',kbad(3) + write(io38,*) ' Number of AIREP reps rej by lst = ',kbad(4) + write(io38,*) ' Number of manAIREP reps rej by lst = ',kbad(5) + endif +c + write(io8,*) + write(io8,*) ' Reports on reject list--rejected' + write(io8,*) ' --------------------------------' + write(io8,*) ' Number of MDCRS reps rej by lst = ',kbad(1) +ccccdak write(io8,*) ' Number of ACARS reps rej by lst = ',kbad(2) + write(io8,*) ' Number of TAMDAR reps rej by lst = ',kbad(2) + write(io8,*) ' Number of AMDAR reps rej by lst = ',kbad(3) + write(io8,*) ' Number of AIREP reps rej by lst = ',kbad(4) + write(io8,*) ' Number of manAIREP reps rej by lst = ',kbad(5) +c +c Output tail number counts +c ------------------------- + write(io8,*) + write(io8,*) ' Tail numbers on reject list for winds' +ccccdak write(io8,*) ' Tail Num MDCRS ACARS AMDAR AIREP MAN ' + write(io8,*) ' Tail Num MDCRS TAMDAR AMDAR AIREP MAN ' + write(io8,*) ' ----------------------------------------------' +c + do mm=1,kreg + if( nwind_reg(mm,1)+nwind_reg(mm,2)+nwind_reg(mm,3) + $ +nwind_reg(mm,4)+nwind_reg(mm,5).gt.0) then + write(io8,'(2x,a8,5(1x,i6))') + $ creg_reg(mm),(nwind_reg(mm,kk),kk=1,5) + endif + enddo +c + write(io8,*) + write(io8,*) ' Tail numbers on reject list for temperatures' +ccccdak write(io8,*) ' Tail Num MDCRS ACARS AMDAR AIREP MAN ' + write(io8,*) ' Tail Num MDCRS TAMDAR AMDAR AIREP MAN ' + write(io8,*) ' ----------------------------------------------' +c + do mm=1,kreg + if( ntemp_reg(mm,1)+ntemp_reg(mm,2)+ntemp_reg(mm,3) + $ +ntemp_reg(mm,4)+ntemp_reg(mm,5).gt.0) then + write(io8,'(2x,a8,5(1x,i6))') + $ creg_reg(mm),(ntemp_reg(mm,kk),kk=1,5) + endif + enddo +c + write(io8,*) + write(io8,*) 'Reject list counts' + write(io8,*) '------------------' + write(io8,'(1x,a55)') +ccccdak $ 'Type of check MDCRS ACARS AMDAR AIREP man' + $ 'Type of check MDCRS TAMDAR AMDAR AIREP man' + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Num considered '',5(1x,i7))') + $ nrep_Md,nrep_Ac,nrep_Am,nrep_Ar,nrep_Ma + write(io8,'(''Total rejected '',5(1x,i7))') + $ nlst_Md,nlst_Ac,nlst_Am,nlst_Ar,nlst_Ma + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Listed winds '',5(1x,i7))') + $ (nlst_wind(ii),ii=1,5) + write(io8,'(''Listed temps '',5(1x,i7))') + $ (nlst_temp(ii),ii=1,5) + write(io8,'(''Listed both '',5(1x,i7))') + $ (nlst_both(ii),ii=1,5) + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + kbadtot = kbad(1) + kbad(2) + kbad(3) + $ + kbad(4) + kbad(5) +c + write(io8,*) + write(io8,*) numreps,' good reports processed' + write(io8,*) kbadtot,' reports failed qc in reject list check' +c + return + end +c +c ################################################################### +c subroutine p2ht_qc +c ################################################################### +c + subroutine p2ht_qc(pressure,height_m,amiss) +c +c Compute height from pressure after checking for gross errors +c + implicit none +c + real pressure ! input pressure (mb) + x, height_m ! output height (m) + x, amiss ! missing value flag +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c +c Check for missing value +c ----------------------- + if(pressure.eq.amiss) then +c write(io8,*) +c write(io8,*) 'Pressure missing' + height_m = amiss +c +c Check for gross errors +c ---------------------- + elseif(pressure.gt.1080..or. + $ pressure.lt.50.) then +c write(io8,*) +c write(io8,*) 'Bad pressure--',pressure + height_m = amiss +c +c Compute height for high pressures +c --------------------------------- + elseif(pressure.ge.226.313) then +c +c Function below is inverse of Dennis Keyser's function +c ----------------------------------------------------- +c height_m = 288.15/.0065 * (1.-(pressure/1013.25)**.190259) +c +c Function below is from Manual of Barometry +c ------------------------------------------ + height_m = 288.15/.0065 * (1.-(pressure/1013.25)**.1902632) +c write(io8,*) +c write(io8,*) 'Computed height',height_m, +c $ ' for high pressure = ',pressure +c +c Compute height for low pressures +c -------------------------------- + elseif(pressure.lt.226.313) then +c +c Function below is inverse of Dennis Keyser's function +c ----------------------------------------------------- + height_m = 11000. - alog(pressure/226.3) / 1.576106E-4 +c write(io8,*) +c write(io8,*) 'Computed height',height_m, +c $ ' for low pressure = ',pressure + endif +c + return + end +c +c ################################################################### +c subroutine ht2fl_qc +c ################################################################### +c + subroutine ht2fl_qc(height_m,height_ft,amiss,ft2m) +c +c Compute height in feet and round to nearest hundred feet +c (This is done to recover original altitudes, which were +c presumably rounded to the nearest hundred feet.) +c + implicit none +c + real height_m ! input height (m) + x, height_ft ! output height (ft) + x, amiss ! missing value flag + x, ft2m ! conversion factor for m to ft +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c + if(height_m.ne.amiss) then + height_ft = height_m * ft2m + else + height_ft = amiss + endif +c + return + end +c +c ################################################################### +c function gcirc_qc +c ################################################################### +c +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + function gcirc_qc(rlat1,rlon1,rlat2,rlon2) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c +c This function computes great circle distances using the Haversine formula. +c Reference: http://www.census.gov/cgi-bin/geo/gisfaq?Q5.1 +c Programmer: P.M. Pauley 2/24/2000 +c + implicit none +c + real pi,deg_rad,radius + parameter (pi = 3.14159274, deg_rad = pi/180.) ! conversion factor + parameter (radius = 6371229.) ! earth's radius in m +c + real gcirc_qc ! great circle distance + real*8 rlat1 ! first latitude (degrees) + $, rlat2 ! second latitude (degrees) + $, rlon1 ! first longitude (degrees) + $, rlon2 ! second longitude (degrees) + real*8 dlon ! difference in longitude / 2 (radians) + $, dlat ! difference in latitude / 2 (radians) + real*8 arg ! argument for the arcsin +c + dlon = (rlon2 - rlon1) * deg_rad * 0.5 + dlat = (rlat2 - rlat1) * deg_rad * 0.5 +c +c What if longitudes are equal? +c ----------------------------- + if(int(rlon1*100.0).eq.int(rlon2*100.0)) then + gcirc_qc = radius * abs(rlat2 - rlat1) * deg_rad +c +c What if latitudes are equal? +c ---------------------------- + elseif(int(rlat1*100.0).eq.int(rlat2*100.0)) then + arg = abs(cos(rlat1*deg_rad) * sin(dlon)) + gcirc_qc = radius * 2.0 * asin(min(1.0,arg)) +c +c What if neither are equal? +c -------------------------- + else + arg = (sin(dlat))**2 + $ + cos(rlat1*deg_rad) * cos(rlat2*deg_rad) * (sin(dlon))**2 + gcirc_qc = radius * 2.0 * asin(min(1.0,sqrt(arg))) + endif +c + return + end +c +c ################################################################### +c subroutine p_ddtg +c ################################################################### +c + subroutine p_ddtg(c_hdg,io8) +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c prints message with the system date and time +c +c by p.pauley +c - Update by D. Keyser 2/7/13: Use GNU standard call +c "date_and_time" instead of calls to "date" and "time" to avoid +c ifort compiler warning on NCEP WCOSS +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + implicit none +c + integer io8 +c + character*(*) c_hdg ! message + character*8 cdate ! system date + character*10 ctime ! system time + character*5 czone ! time zone + character*3 cmonth(13) ! month + integer idat(8) + data cmonth /'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug', + + 'Sep','Oct','Nov','Dec','???'/ +c + call date_and_time(cdate,ctime,czone,idat) + if(idat(2).lt.1 .or. idat(2).gt.12) idat(2) = 13 +c + write(io8,*) + write(io8,*) c_hdg + write(io8,*) ' System date/time: ',cdate(7:8),'-', + + cmonth(idat(2)),'-',cdate(3:4),' ',ctime(1:2),':',ctime(3:4), + + ':',ctime(5:6) +c + return + end +c +c ################################################################### +c subroutine spike_qc +c ################################################################### +c + subroutine spike_qc(numreps,max_reps,c_acftreg,c_acftid,c_qc + $, alat,alon,pres,ht_ft,t_prcn,ob_t,ob_q,ob_dir,ob_spd + $, xiv_t,xiv_q,xiv_d,xiv_s,idt,itype,ichk_t,ichk_q + $, ichk_d,ichk_s,kbadtot,indx,csort,amiss,imiss,io8 + $, io31,cdtg_an,l_operational,l_init) +c +c Check for spikes in the time distribution of data. +c Erroneous AIREPs from Tinker tend to be clustered by minute. +c + implicit none +c +c Parameter statements +c -------------------- + integer max_min ! number of minutes in one file +cc smb parameter(max_min=361) + parameter(max_min=721) + integer min_offset ! offset used to compute index +cc smb parameter(min_offset=181) + parameter(min_offset=361) +c +c Data arrays +c ----------- + character*10 cdtg_an ! date time group for analysis + integer max_reps ! maximum number of reports + integer numreps ! actual number of reports + integer itype(max_reps) ! type of aircraft data + integer idt(max_reps) ! time in seconds to analysis time + character*8 c_acftreg(max_reps) ! aircraft registration (tail) number + character*9 c_acftid(max_reps) ! aircraft flight number + real*8 alat(max_reps) ! latitude + $, alon(max_reps) ! longitude + real pres(max_reps) ! pressure + $, ht_ft(max_reps) ! height in feet + real t_prcn(max_reps) ! temperature precision + real ob_t(max_reps) ! temperature + $, ob_q(max_reps) ! specific humidity + $, ob_dir(max_reps) ! wind direction + $, ob_spd(max_reps) ! wind speed + real xiv_t(max_reps) ! temperature innovation (ob - bk) + $, xiv_q(max_reps) ! specific humidity innovation (ob - bk) + $, xiv_d(max_reps) ! wind direction innovation (ob - bk) + $, xiv_s(max_reps) ! wind speed innovation (ob - bk) + integer ichk_t(max_reps) ! NRL QC flag for temperature ob + $, ichk_q(max_reps) ! NRL QC flag for specific humidity ob + $, ichk_d(max_reps) ! NRL QC flag for wind direction ob + $, ichk_s(max_reps) ! NRL QC flag for wind speed ob + character*25 csort(max_reps) ! sort variable + character*11 c_qc(max_reps) ! internal qc flags +c +c Pointers +c -------- + integer indx(max_reps) ! pointer index for good reports +c +c Functions +c --------- + character*16 c_insty_ob ! function to convert integer instrument + ! type to character instrument type +c + integer insty_ob_fun ! function to convert character + ! instrument type to integer +c +c Other variables +c --------------- + integer io8 ! i/o unit number for log file + integer io31 ! i/o unit number for rejected dups +c + integer imiss ! integer missing value flag + real amiss ! real missing value flag +c + integer n_minute(6,max_min) ! counter for obs by type and minute + $, n_min_avg(6) ! average number of obs per minute by type + $, n_min_knt(6) ! number of minutes with obs by type + $, i_min ! minute index + $, ii_min ! minute index + $, n_thresh ! threshold used to define a spike + $, idiff_before ! difference w.r.t. previous count + $, idiff_after ! difference w.r.t. following count + real xiv_minute(6,max_min) ! average innovation by type and minute +c + integer iob ! do loop index + $, ibeg ! beginning index + integer ii ! do loop index + $, kk ! do loop index + $, kkbeg ! beginning index + integer kbad(6) ! counter for number of bad reports + $, kbadtot ! counter for total number of bad reports +c +ccccdak integer i_acars ! instrument type for acars + integer i_acars ! instrument type for tamdar +ccccdak $, i_acars_lvl ! instrument type for acars--level flt + $, i_acars_lvl ! instrument type for tamdar--level flt +ccccdak $, i_acars_asc ! instrument type for acars--ascent + $, i_acars_asc ! instrument type for tamdar--ascent +ccccdak $, i_acars_des ! instrument type for acars--descent + $, i_acars_des ! instrument type for tamdar--descent + $, i_mdcrs ! instrument type for mdcrs + $, i_mdcrs_lvl ! instrument type for mdcrs--level flt + $, i_mdcrs_asc ! instrument type for mdcrs--ascent + $, i_mdcrs_des ! instrument type for mdcrs--descent + $, i_man_airep ! instrument type for manual aireps + $, i_man_Yairep ! instrument type for manual aireps (YRXX) + $, i_airep ! instrument type for airep + $, i_airep_lvl ! instrument type for airep--level flt + $, i_airep_asc ! instrument type for airep--ascent + $, i_airep_des ! instrument type for airep--descent + $, i_amdar ! instrument type for amdar + $, i_amdar_lvl ! instrument type for amdar--level flt + $, i_amdar_asc ! instrument type for amdar--ascent + $, i_amdar_des ! instrument type for amdar--descent +c +ccccdak integer nrep_Ac ! number of acars reports considered + integer nrep_Ac ! number of tamdar reports considered + $, nrep_Md ! number of mdcrs reports considered + $, nrep_Ma ! number of manual airep reports considered + $, nrep_Ar ! number of airep reports considered + $, nrep_Am ! number of amdar reports considered +ccccdak $, nbad_Ac ! number of bad acars + $, nbad_Ac ! number of bad tamdar + $, nbad_Md ! number of bad mdcrs + $, nbad_Ma ! number of bad manual aireps + $, nbad_Ar ! number of bad aireps + $, nbad_Am ! number of bad amdar +c +c Switches +c -------- + logical l_print ! print values if true + $, l_operational ! run QC in operational mode if true + $, l_init ! initialize counters if true + $, l_all_types ! spike check all types if true +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c +c Initialize aircraft data types +c ------------------------------ + i_acars = insty_ob_fun('acars') + i_acars_lvl = insty_ob_fun('acars_lvl') + i_acars_asc = insty_ob_fun('acars_asc') + i_acars_des = insty_ob_fun('acars_des') + i_mdcrs = insty_ob_fun('mdcrs') + i_mdcrs_lvl = insty_ob_fun('mdcrs_lvl') + i_mdcrs_asc = insty_ob_fun('mdcrs_asc') + i_mdcrs_des = insty_ob_fun('mdcrs_des') + i_man_airep = insty_ob_fun('man-airep') + i_man_Yairep = insty_ob_fun('man-Yairep') + i_airep = insty_ob_fun('airep') + i_airep_lvl = insty_ob_fun('airep_lvl') + i_airep_asc = insty_ob_fun('airep_asc') + i_airep_des = insty_ob_fun('airep_des') + i_amdar = insty_ob_fun('amdar') + i_amdar_lvl = insty_ob_fun('amdar_lvl') + i_amdar_asc = insty_ob_fun('amdar_asc') + i_amdar_des = insty_ob_fun('amdar_des') +c +c Initialize other arrays +c ----------------------- + n_min_avg = 0 + n_min_knt = 0 + kbad = 0 +c + n_minute = 0 + xiv_minute = 0.0 +c +c Initialize counters +c ------------------- + if(l_init) then + nrep_Ac = 0 + nrep_Md = 0 + nrep_Ma = 0 + nrep_Ar = 0 + nrep_Am = 0 + nbad_Ac = 0 + nbad_Md = 0 + nbad_Ma = 0 + nbad_Ar = 0 + nbad_Am = 0 + endif +c +c Loop over reports +c ----------------- + do iob=1,numreps +c + ii = indx(iob) +c +c Compute minute index +c -------------------- + if(idt(ii).ne.imiss) then + i_min = idt(ii)/60 + min_offset + else + i_min = max_min + endif +c + if(i_min.lt.1.or. + $ i_min.gt.max_min) then + write(io8,*) + write(io8,*) 'i_min out of bounds',ii,iob, + + c_acftreg(ii),c_acftid(ii) + write(io8,*) ' i_min = ',i_min + write(io8,*) ' idt = ',idt(ii) + i_min = max_min + endif +c +c Accumulate distribution of obs and speed innovations +c ---------------------------------------------------- + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des) then +c + nrep_Md = nrep_Md + 1 + n_minute(1,i_min) = n_minute(1,i_min) + 1 + if(xiv_s(ii).ne.amiss) then + xiv_minute(1,i_min) = xiv_minute(1,i_min) + abs(xiv_s(ii)) + endif +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des) then +c + nrep_Ac = nrep_Ac + 1 + n_minute(2,i_min) = n_minute(2,i_min) + 1 + if(xiv_s(ii).ne.amiss) then + xiv_minute(2,i_min) = xiv_minute(2,i_min) + abs(xiv_s(ii)) + endif +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des) then +c + nrep_Am = nrep_Am + 1 + n_minute(3,i_min) = n_minute(3,i_min) + 1 + if(xiv_s(ii).ne.amiss) then + xiv_minute(3,i_min) = xiv_minute(3,i_min) + abs(xiv_s(ii)) + endif +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des) then +c + nrep_Ar = nrep_Ar + 1 + n_minute(4,i_min) = n_minute(4,i_min) + 1 + if(xiv_s(ii).ne.amiss) then + xiv_minute(4,i_min) = xiv_minute(4,i_min) + abs(xiv_s(ii)) + endif +c + elseif(itype(ii).eq.i_man_Yairep) then +c + nrep_Ma = nrep_Ma + 1 + n_minute(5,i_min) = n_minute(5,i_min) + 1 + if(xiv_s(ii).ne.amiss) then + xiv_minute(5,i_min) = xiv_minute(5,i_min) + abs(xiv_s(ii)) + endif +c + elseif(itype(ii).eq.i_man_airep) then +c + nrep_Ma = nrep_Ma + 1 + n_minute(6,i_min) = n_minute(6,i_min) + 1 + if(xiv_s(ii).ne.amiss) then + xiv_minute(6,i_min) = xiv_minute(6,i_min) + abs(xiv_s(ii)) + endif + endif + enddo +c + l_print = .true. +c + if(l_print) then + write(io8,*) + write(io8,*) 'Distribution of reports by type and minute' + write(io8,*) '------------------------------------------' + write(io8,*) +ccccdak $ 'min MDCRS ACARS AMDAR AIREP YRXX voice innov' + $ 'min MDCRS TAMDAR AMDAR AIREP YRXX voice innov' + write(io8,*) + $ '---- ------ ------ ------ ------ ------ ------ --------' + endif +c + do i_min=1,max_min + if(n_minute(6,i_min).ne.0) then + xiv_minute(6,i_min) = xiv_minute(6,i_min) + $ / float(n_minute(6,i_min)) + else + xiv_minute(6,i_min) = amiss + endif + if(l_print) write(io8,'(i4,6(1x,i6),1x,f8.2)') + $ i_min,(n_minute(kk,i_min),kk=1,6),xiv_minute(6,i_min) +c + do kk=1,6 + if(n_minute(kk,i_min).gt.0) then + n_min_avg(kk) = n_min_avg(kk) + n_minute(kk,i_min) + n_min_knt(kk) = n_min_knt(kk) + 1 + endif + enddo + enddo +c + do kk=1,6 + if(n_min_knt(kk).gt.0) then + n_min_avg(kk) = n_min_avg(kk) / n_min_knt(kk) + else + n_min_avg(kk) = imiss + endif + enddo +c + if(l_print) then + write(io8,*) + $ '--- ------ ------ ------ ------ ------ ------ --------' + write(io8,'(''avg'',6(1x,i6))') (n_min_avg(kk),kk=1,6) + write(io8,*) + $ '--- ------ ------ ------ ------ ------ ------ --------' + endif +c + if(.not.l_operational) then + write(io31,*) + write(io31,*) 'Spike reports' + write(io31,*) '-------------' + write(io31,3001) + 3001 format(' index type tail num flight time lat' + x, ' lon pres height ' + x, 't-prcn temp innov ichk' + x, ' spec hum innov ichk' + x, ' ob_dir innov ichk' + x, ' ob_spd innov ichk' + x, ' qc flag') + endif +c +c Go back and look for spikes (>3x average number per minute) +c ----------------------------------------------------------- + l_print = .true. +c + l_all_types = .false. + if(l_all_types) then + kkbeg = 1 + else + kkbeg = 6 + endif +c + write(io8,*) + write(io8,*) '---------------------------------------------' + write(io8,*) 'Perform spike check on all types--',l_all_types + write(io8,*) '(If not, just spike check voice AIREP data)' + write(io8,*) '---------------------------------------------' +c + do kk=kkbeg,6 +c + ibeg = 1 +c + if(n_min_avg(kk).le.3) then + n_thresh = 9 + else + n_thresh = n_min_avg(kk) * 3 + endif +c + if(kk.eq.4) n_thresh = ifix(float(n_thresh) * 1.5) +c +c Look for spikes +c --------------- + do i_min=1,max_min +c + if(i_min.eq.1) then + idiff_before = n_minute(kk,i_min)-n_minute(kk,i_min+1) + idiff_after = idiff_before + elseif(i_min.eq.max_min) then + idiff_before = n_minute(kk,i_min)-n_minute(kk,i_min-1) !!!!! + idiff_after = idiff_before + else + idiff_before = n_minute(kk,i_min)-n_minute(kk,i_min-1) !!!!! + idiff_after = n_minute(kk,i_min)-n_minute(kk,i_min+1) + endif +c + if(n_minute(kk,i_min).ge.n_thresh.and. + $ idiff_before.gt.n_thresh/2.and. + $ idiff_after.gt.n_thresh/2) then +c + if(kk.eq.1) then + if(l_print) then + write(io8,*) + write(io8,*) 'Spike in MDCRS data at min = ',i_min + write(io8,*) '----------------------------------' + endif + elseif(kk.eq.2) then + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'Spike in ACARS data at min = ',i_min + write(io8,*) 'Spike in TAMDAR data at min = ',i_min + write(io8,*) '----------------------------------' + endif + elseif(kk.eq.3) then + if(l_print) then + write(io8,*) + write(io8,*) 'Spike in AMDAR data at min = ',i_min + write(io8,*) '----------------------------------' + endif + elseif(kk.eq.4) then + if(l_print) then + write(io8,*) + write(io8,*) 'Spike in autoAIREP data at min = ',i_min + write(io8,*) '----------------------------------' + endif + elseif(kk.eq.5) then + if(l_print) then + write(io8,*) + write(io8,*) 'Spike in YRXX86 data at min = ',i_min + write(io8,*) '----------------------------------' + endif + elseif(kk.eq.6) then + if(l_print) then + write(io8,*) + write(io8,*) 'Spike in voice data at min = ',i_min + write(io8,*) '----------------------------------' + endif + endif +c +c Loop over obs to reject data in spike +c ------------------------------------- + iob = ibeg + do while(iob.le.numreps) + ii = indx(iob) +c + ii_min = idt(ii)/60 + min_offset +c + if(ii_min.lt.1.or. + $ ii_min.gt.max_min) then + write(io8,*) + write(io8,*) 'ii_min out of bounds' + write(io8,*) ' ii_min = ',i_min + write(io8,*) ' idt = ',idt(ii) + ii_min = max_min + endif +c + if(ii_min.eq.i_min) then + if(kk.eq.1.and. + $ (itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des)) then +c + csort(ii)(1:5) = 'badob' + nbad_Md = nbad_Md + 1 +c + elseif(kk.eq.2.and. + $ (itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des)) then +c + csort(ii)(1:5) = 'badob' + nbad_Ac = nbad_Ac + 1 +c + elseif(kk.eq.3.and. + $ (itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des)) then +c + csort(ii)(1:5) = 'badob' + nbad_Am = nbad_Am + 1 +c + elseif(kk.eq.4.and. + $ (itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des)) then +c + csort(ii)(1:5) = 'badob' + nbad_Ar = nbad_Ar + 1 +c + elseif(kk.eq.5.and. + $ (itype(ii).eq.i_man_Yairep)) then +c + csort(ii)(1:5) = 'badob' + nbad_Ma = nbad_Ma + 1 +c + elseif(kk.eq.6.and. + $ (itype(ii).eq.i_man_airep)) then +c + csort(ii)(1:5) = 'badob' + nbad_Ma = nbad_Ma + 1 + endif +c + if(csort(ii)(1:5).eq.'badob') then +c + kbad(kk) = kbad(kk) + 1 + c_qc(ii)(2:2) = 'B' +c + if(l_print) then + write(io8,3002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + endif +c + if(.not.l_operational) then + write(io31,3002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + 3002 format(i6,1x,a8,1x,a8,1x,a9,1x,i7,1x,2f11.5,1x + x, f8.1,1x,f7.0,1x,f5.2,4(2(1x,f8.2),1x,i5),1x + x, '!',a11,'!') + endif + endif +c + elseif(ii_min.gt.i_min) then + ibeg = iob + iob = numreps + 1 + endif + iob = iob + 1 + enddo + endif + enddo + enddo +c + kbad(5) = kbad(5) + kbad(6) +c +c Output statistics +c ----------------- + if(.not.l_operational) then + write(io31,*) + write(io31,*)' Number of spike MDCRS reps rejected = ' +cc smb $, kbad(1) + $, nbad_Md +ccccdak write(io31,*)' Number of spike ACARS reps rejected = ' + write(io31,*)' Number of spike TAMDAR reps rejected = ' +cc smb $, kbad(2) + $, nbad_Ac + write(io31,*)' Number of spike AMDAR reps rejected = ' +cc smb $, kbad(3) + $, nbad_Am + write(io31,*)' Number of spike AIREP reps rejected = ' +cc smb $, kbad(4) + $, nbad_Ar + write(io31,*)' Number of spike manAIREP reps rejected = ' +cc smb $, kbad(5) + $, nbad_Ma + endif +c + write(io8,*) + write(io8,*) ' Spike reports--rejected' + write(io8,*) ' -----------------------' + write(io8,*)' Number of spike MDCRS reps rejected = ' +cc smb $, kbad(1) + $, nbad_Md +ccccdak write(io8,*)' Number of spike ACARS reps rejected = ' + write(io8,*)' Number of spike TAMDAR reps rejected = ' +cc smb $, kbad(2) + $, nbad_Ac + write(io8,*)' Number of spike AMDAR reps rejected = ' +cc smb $, kbad(3) + $, nbad_Am + write(io8,*)' Number of spike AIREP reps rejected = ' +cc smb $, kbad(4) + $, nbad_Ar + write(io8,*)' Number of spike manAIREP reps rejected = ' +cc smb $, kbad(5) + $, nbad_Ma +c +c Output detailed stats +c --------------------- + write(*,*) + write(*,*) 'Spike check data counts--',cdtg_an + write(*,*) '-----------------------------------' + write(*,'(1x,a55)') +ccccdak $ 'Type of check MDCRS ACARS AMDAR AIREP man' + $ 'Type of check MDCRS TAMDAR AMDAR AIREP man' + write(*,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(*,'('' Num considered '',5(1x,i7))') + $ nrep_Md,nrep_Ac,nrep_Am,nrep_Ar,nrep_Ma + write(*,'('' Total rejected '',5(1x,i7))') + $ nbad_Md,nbad_Ac,nbad_Am,nbad_Ar,nbad_Ma + write(*,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + write(io8,*) + write(io8,*) 'Spike check data counts' + write(io8,*) '-----------------------' + write(io8,'(1x,a55)') +ccccdak $ 'Type of check MDCRS ACARS AMDAR AIREP man' + $ 'Type of check MDCRS TAMDAR AMDAR AIREP man' + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Num considered '',5(1x,i7))') + $ nrep_Md,nrep_Ac,nrep_Am,nrep_Ar,nrep_Ma + write(io8,'(''Total rejected '',5(1x,i7))') + $ nbad_Md,nbad_Ac,nbad_Am,nbad_Ar,nbad_Ma + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c +cc smb kbadtot = kbad(1) + kbad(2) + kbad(3) +cc smb $ + kbad(4) + kbad(5) + + kbadtot = nbad_Md + nbad_Ac + nbad_Am + nbad_Ar + nbad_Ma + +c + write(io8,*) + write(io8,*) numreps,' good reports processed' + write(io8,*) kbadtot,' reports failed qc in spike check' +c + return + end + +c ################################################################### +c function c_insty_ob +c ################################################################### +c + character*16 function c_insty_ob(num) +c +c Return character instrument type for number code +c + parameter (mx_nm=42) +c + integer nc(mx_nm) + character*16 c_label(mx_nm),c_rec(mx_nm) +c + data(nc(n),c_rec(n), c_label(n),n=1,mx_nm) + x / 1, 'SMX', 'sfc land' ! Land observations (coastal, manual, automated) + x , 10, 'SHX', 'sfc ship' ! Surface obs from ships, fixed and mobile, drifting buoys + x , 25, 'XRX', 'man-airep' ! Manual AIREP (header XRXX) + x , 26, 'XRX', 'man-Yairep' ! Manual AIREP (header YRXX) + x , 30, 'S0A', 'airep' ! Aircraft data (aireps) + x , 131, 'S0A', 'airep_asc' ! AIREP ascending profile + x , 132, 'S0A', 'airep_des' ! AIREP descending profile + x , 33, 'S0A', 'airep_lvl' ! AIREP level flight + x , 34, 'AIR', 'airep_msg' ! Aircraft data (AIREP)--missing category + x , 35, 'AMD', 'amdar' ! Automated aircraft data (AMDAR) + x , 136, 'AMD', 'amdar_asc' ! AMDAR ascending profile + x , 137, 'AMD', 'amdar_des' ! AMDAR descending profile + x , 38, 'AMD', 'amdar_lvl' ! AMDAR level flight +ccccdak x , 40, 'ACR', 'acars' ! Automated aircraft (ACARS) prior to acars_qc + x , 40, 'ACR', 'acars' ! Automated aircraft (TAMDAR) prior to acars_qc +ccccdak x , 141, 'ACR', 'acars_asc' ! ACARS ascending profile + x , 141, 'ACR', 'acars_asc' ! TAMDAR ascending profile +ccccdak x , 142, 'ACR', 'acars_des' ! ACARS descending profile + x , 142, 'ACR', 'acars_des' ! TAMDAR descending profile +ccccdak x , 43, 'ACR', 'acars_lvl' ! ACARS level flight + x , 43, 'ACR', 'acars_lvl' ! TAMDAR level flight + x , 45, 'MCR', 'mdcrs' ! Automated aircraft (MDCRS) prior to acars_qc + x , 146, 'MCR', 'mdcrs_asc' ! MDCRS ascending profile + x , 147, 'MCR', 'mdcrs_des' ! MDCRS descending profile + x , 48, 'MCR', 'mdcrs_lvl' ! MDCRS level flight + x , 50, 'TSX', 'cld wnds1' ! Satellite-derived wind observations + x , 51, 'TWX', 'cld wnds2' ! Satellite-derived wind observations + x , 54, 'GMT1', 'METEO-7' ! SSEC Satellite-derived wind observations + x , 55, 'GOSW', 'GOES-10' ! SSEC Satellite-derived wind observations + x , 56, 'GOSE', 'GOES-8' ! SSEC Satellite-derived wind observations + x , 57, 'GMSN', 'GMS_NH' ! SSEC Satellite-derived wind observations + x , 58, 'GMSS', 'GMS_SH' ! SSEC Satellite-derived wind observations + x , 60, 'ssmi_', 'ssmi ff1' ! SSM/I wind speed, air-sea EDR + x , 61, 'SS5', 'ssmi ff2' ! SSM/I wind speed, air-sea EDR + x , 70, 'scat_', 'scat winds' ! scatterometer ocean surface winds + x , 90, 'PAB' , 'Aus synth' ! Australian sea-level pres synthetic + x , 101, 'S0X', 'raob' ! Rawinsondes (land,ship,drop,mobil) + x , 110, 'PIB', 'pibal' ! Pilot balloons (land,ship,mobil) + x , 120, 'analytic' , 'analytic' ! synthetic obs derived from analytic conditions + x , 140, 'S0F', 'tovs T' ! tovs retrieved by nesdis + x , 190, 'GTO' , 'TC synth' ! tropical cyclone synthetic observations + x , 210, 'atovs_', 'atovs bT' ! ATOVS brightness temp + x , 220, 'rtovs_', 'rtovs bT' ! RTOVS brightness temp + x , 230, 'ssmt_', 'ssmt1 bT' ! SSM/T1 brightness temp + x , 240, 'ssmt2_', 'ssmt2 bT' ! SSM/T2 brightness temp + x , 250, 'ssmi_', 'ssmi TPPW' / ! ssm/i total precipitable water +c + do n=1,mx_nm + if(num.eq.nc(n))then + c_insty_ob = c_label(n) + return + endif + end do +c +c not found +c + c_insty_ob = 'typ not found' +c + return + end + +c ################################################################### +c function insty_ob_fun +c ################################################################### +c + integer function insty_ob_fun(c_record) +c +c Return number code for character instrument type +c + parameter (mx_nm=42) +c + character*(*) c_record + integer nc(mx_nm) + character*16 c_label(mx_nm),c_rec(mx_nm) +c + data(nc(n),c_rec(n), c_label(n),n=1,mx_nm) + x / 1, 'SMX', 'sfc land' ! Land observations (coastal, manual, automated) + x , 10, 'SHX', 'sfc ship' ! Surface obs from ships, fixed and mobile, drifting buoys + x , 25, 'XRX', 'man-airep' ! Manual AIREP (header XRXX) + x , 26, 'XRX', 'man-Yairep' ! Manual AIREP (header YRXX) + x , 30, 'S0A', 'airep' ! Aircraft data (aireps) + x , 131, 'S0A', 'airep_asc' ! AIREP ascending profile + x , 132, 'S0A', 'airep_des' ! AIREP descending profile + x , 33, 'S0A', 'airep_lvl' ! AIREP level flight + x , 34, 'AIR', 'airep_msg' ! Aircraft data (AIREP)--missing category + x , 35, 'AMD', 'amdar' ! Automated aircraft data (AMDAR) + x , 136, 'AMD', 'amdar_asc' ! AMDAR ascending profile + x , 137, 'AMD', 'amdar_des' ! AMDAR descending profile + x , 38, 'AMD', 'amdar_lvl' ! AMDAR level flight +ccccdak x , 40, 'ACR', 'acars' ! Automated aircraft (ACARS) prior to acars_qc + x , 40, 'ACR', 'acars' ! Automated aircraft (TAMDAR) prior to acars_qc +ccccdak x , 141, 'ACR', 'acars_asc' ! ACARS ascending profile + x , 141, 'ACR', 'acars_asc' ! TAMDAR ascending profile +ccccdak x , 142, 'ACR', 'acars_des' ! ACARS descending profile + x , 142, 'ACR', 'acars_des' ! TAMDAR descending profile +ccccdak x , 43, 'ACR', 'acars_lvl' ! ACARS level flight + x , 43, 'ACR', 'acars_lvl' ! TAMDAR level flight + x , 45, 'MCR', 'mdcrs' ! Automated aircraft (MDCRS) prior to acars_qc + x , 146, 'MCR', 'mdcrs_asc' ! MDCRS ascending profile + x , 147, 'MCR', 'mdcrs_des' ! MDCRS descending profile + x , 48, 'MCR', 'mdcrs_lvl' ! MDCRS level flight + x , 50, 'TSX', 'cld wnds1' ! Satellite-derived wind observations + x , 51, 'TWX', 'cld wnds2' ! Satellite-derived wind observations + x , 54, 'GMT1', 'METEO-7' ! SSEC Satellite-derived wind observations + x , 55, 'GOSW', 'GOES-10' ! SSEC Satellite-derived wind observations + x , 56, 'GOSE', 'GOES-8' ! SSEC Satellite-derived wind observations + x , 57, 'GMSN', 'GMS_NH' ! SSEC Satellite-derived wind observations + x , 58, 'GMSS', 'GMS_SH' ! SSEC Satellite-derived wind observations + x , 60, 'ssmi_', 'ssmi ff1' ! SSM/I wind speed, air-sea EDR + x , 61, 'SS5', 'ssmi ff2' ! SSM/I wind speed, air-sea EDR + x , 70, 'scat_', 'scat winds' ! scatterometer ocean surface winds + x , 90, 'PAB' , 'Aus synth' ! Australian sea-level pres synthetic + x , 101, 'S0X', 'raob' ! Rawinsondes (land,ship,drop,mobil) + x , 110, 'PIB', 'pibal' ! Pilot balloons (land,ship,mobil) + x , 120, 'analytic' , 'analytic' ! synthetic obs derived from analytic conditions + x , 140, 'S0F', 'tovs T' ! tovs retrieved by nesdis + x , 190, 'GTO' , 'TC synth' ! tropical cyclone synthetic observations + x , 210, 'atovs_', 'atovs bT' ! ATOVS brightness temp + x , 220, 'rtovs_', 'rtovs bT' ! RTOVS brightness temp + x , 230, 'ssmt_', 'ssmt1 bT' ! SSM/T1 brightness temp + x , 240, 'ssmt2_', 'ssmt2 bT' ! SSM/T2 brightness temp + x , 250, 'ssmi_', 'ssmi TPPW' / ! ssm/i total precipitable water +C + do n=1,mx_nm + if(c_record.eq.c_label(n))then + insty_ob_fun=nc(n) + return + endif + end do +c +c not found +c + insty_ob_fun=0 + write(*,*) + write(*,*) ' *****VVVVV*****' + write(*,*) ' WARNING: insty_ob_fun could not find c_record=', + + c_record + write(*,*) ' *****^^^^^*****' + write(*,*) +c + return + end +c +c ################################################################### +c subroutine slen +c ################################################################### +c + subroutine slen (cstr,lenc) +c +c#include +c rcs keywords: $RCSfile: slen.F,v $ +c $Revision: 1.1.1.1 $ $Date: 1996/10/01 18:10:37 $ +c + implicit none +c + integer maxlen ! dimension of string cstr + $, lenc ! output length of contents of cstr + $, i ! index +c + character*(*) cstr ! input string + character*1 tab ! contains tab character + $, carriage_return ! contains carriage return character + $, linefeed ! contains linefeed character +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c + tab = char(9) + linefeed = char(10) + carriage_return = char(13) +c +c Get the size of character string +c -------------------------------- + maxlen = len(cstr) +c + lenc = 0 + do 10 i=1,maxlen + if ( (cstr(i:i).eq.' ') .or. (cstr(i:i).eq.tab) .or. + & (cstr(i:i).eq.carriage_return) .or. (cstr(i:i).eq.linefeed) ) + & return +c + lenc = i +c + 10 continue +c + return + end +c diff --git a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/indexc40.f b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/indexc40.f new file mode 100644 index 00000000..a0aed083 --- /dev/null +++ b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/indexc40.f @@ -0,0 +1,103 @@ +c$$$ subprogram documentation block +c +c subprogram: indexc40 +c Programmer: D. Keyser Org: NP22 Date: 2012-05-08 +c +c Abstract: Uses efficient sort algorithm to produce index sort list for a 40-character +c array. Does not rearrange the file. +c +c Program History Log: +c 1993-06-05 R Kistler -- FORTRAN version of C-program +c 1993-07-15 P. Julian -- Modified to sort 12-character array +c 1994-08-25 D. Keyser -- Modified to sort 16-character array +c 1995-05-30 D. Keyser -- Tests for < 2 elements in sort list, if so returns without +c sorting (but fills indx array) +c ????-??-?? P. M. Pauley (NRL) -- Size of carrin changed to character*24 +c 2010-11-15 S. Bender -- Size of carrin changed to character*40 +c 2012-05-08 D. Keyser -- Prepared for operational implementation +c +c Usage: call indexc40(n,carrin,indx) +c +c Input argument list: +c n - Size of array to be sorted +c carrin - 40-character array to be sorted +c +c Output argument list: +c indx - Array of pointers giving sort order of carrin in ascending order {e.g., +c carrin(indx(i)) is sorted in ascending order for original i = 1, ... ,n} +c +c Remarks: Called by main program. +c +c Attributes: +c Language: FORTRAN 90 +c Machine: NCEP WCOSS +c +c$$$ + subroutine indexc40(n,carrin,indx) + + implicit none + + integer n ! dimension of array to be sorted + +, j ! do loop index, sort variable + +, i ! sort variable + +, l ! variable used to decide if sort is finished + +, ir ! " " + +, indx(n) ! pointer array + +, indxt ! pointer used in sort + + character*40 carrin(n) ! input array to be sorted + +, cc ! character variable used in sort + +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # + + do j = 1,n + indx(j) = j + enddo + +c Must be > 1 element in sort list, else return +c --------------------------------------------- + + if(n.le.1) return + + l = n/2 + 1 + ir = n + + 33 continue + if(l.gt.1) then + l = l - 1 + indxt = indx(l) + cc = carrin(indxt) + else + indxt = indx(ir) + cc = carrin(indxt) + indx(ir) = indx(1) + ir = ir - 1 + if(ir.eq.1) then + indx(1) = indxt + return + endif + endif + + i = l + j = l * 2 + + 30 continue + if(j.le.ir) then + if(j.lt.ir) then + if(carrin(indx(j)).lt.carrin(indx(j+1))) j = j + 1 + endif + if(cc.lt.carrin(indx(j))) then + indx(i) = indx(j) + i = j + j = j + i + else + j = ir + 1 + endif + endif + + if(j.le.ir) go to 30 + indx(i) = indxt + go to 33 + + end + diff --git a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/input_acqc.f b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/input_acqc.f new file mode 100644 index 00000000..6b5100f5 --- /dev/null +++ b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/input_acqc.f @@ -0,0 +1,1952 @@ +c$$$ Subprogram Documentation Block +c BEST VIEWED WITH 94-CHARACTER WIDTH WINDOW +c +c Subprogram: input_acqc +c Programmer: D. Keyser Org: NP22 Date: 2016-12-09 +c +c Abstract: Reads aircraft reports (mass and wind pieces) out of the input PREPBUFR file (in +c message types 'AIRCAR' and 'AIRCFT') and stores merged (mass and wind) data into memory +c (e.g., alat, alon, ht_ft, idt, ob_*, xiv_* and ichk_* arrays) for later use by the NRL QC +c kernel (acftobs_qc). Some NCEP data values are translated to NRL standards (e.g., u/v to +c dir/spd, quality information, and report type). Also stores merged input "event" +c information into memory (e.g., nevents, *ob_ev, *qm_ev, *pc_ev, *rc_ev, *pg and *pp +c arrays) for use when later constructing merged (mass and wind) profile reports in +c PREPBUFR-like file (if requested, i.e., l_doprofiles=T). +c +c Program History Log: +c 2010-11-15 S. Bender -- Original Author +c 2012-05-08 D. Keyser -- Prepared for operational implementation +c 2012-11-20 J. Woollen -- Initial port to WCOSS +c 2013-02-07 D. Keyser -- Will now store pressure and pressure-altitude only from the first +c (mass) piece of a mass/wind piece pair rather than re-store it +c again from the second (wind) piece - even though they "should" be +c the same in both pieces (see % below for exception), there can be +c rare cases when at least pressure-altitude is missing in the wind +c piece (due to a bug in PREPDATA where unreasonably-high winds are +c set to missing and an "empty" wind piece is still encoded into +c PREPBUFR, this can lead to floating point exception errors in the +c construction of profiles {note that pressure & pressure-altitude +c from reports with only a wind piece will be read since it is the +c first (only) piece of the report}: % - there can be cases where +c the pressure qualty mark (PQM) is different in the mass piece vs. +c the wind piece (e.g., when it is set to 10 for reports near +c tropical systems by SYNDATA), so it is better to pick up PQM from +c the mass report for use in the merged mass/wind profiles, an added +c benefit of this chg; if the total number of merged (mass + wind +c piece) aircraft-type reports read in from PREPBUFR file is at +c least 90% of maximum allowed, print diagnostic warning message +c to production joblog file prior to returning from this subroutine +c 2013-02-07 D. Keyser -- Final changes to run on WCOSS: use formatted print statements +c where previously unformatted print was > 80 characters +c 2014-09-03 D. Keyser -- If no aircraft reports of any type are read from input PREPBUFR +c file, no further processing is performed other than the usual +c stdout print summary at the end. +c 2013-10-07 Sienkiewicz -- add initialization for 'nmswd' (for gfortran compile) +c 2016-12-09 D. Keyser -- +c - Nomenclature change: replaced "MDCRS/ACARS" with just "MDCRS". +c - New LATAM AMDARs contain an encrypted flight number (in addition to a tail +c number, all other AMDARs have only a tail number which is copied into +c flight number). Read this in and use in QC processing. +c BENEFIT: Improves track-checking and other QC for LATAM AMDARs. +c - Latitude/longitdue arrays "alat" and "alon" passed out of this subroutine +c now double precision. XOB and YOB in PREPBUFR file now scaled to 10**5 +c (was 10**2) to handle new v7 AMDAR and MDCRS reports which have this +c higher precision. +c BENEFIT: Retains exact precison here. Improves QC processing. +c - Note: QC here can be improved further by changing logic to account +c for the increased precision. This needs to be investigated. +c For now, location in code where this seems possible is noted by +c the spanning comments: +c ! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c ! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c +c Usage: call input_acqc(inlun,max_reps,mxnmev,bmiss,imiss,amiss, +c m2ft,mxlv,nrpts4QC,cdtg_an,alat,alon,ht_ft, +c idt,c_dtg,itype,phase,t_prcn,c_acftreg, +c c_acftid,pres,ob_t,ob_q,ob_dir,ob_spd, +c ichk_t,ichk_q,ichk_d,ichk_s, +c nchk_t,nchk_q,nchk_d,nchk_s, +c xiv_t,xiv_q,xiv_d,xiv_s, +c l_minus9C,nevents,hdr,acid,rct,drinfo, +c acft_seq,turb1seq,turb2seq,turb3seq, +c prewxseq,cloudseq,afic_seq,mstq,cat,rolf, +c nnestreps,sqn,procn, +c pob_ev,pqm_ev,ppc_ev,prc_ev,pbg,ppp, +c zob_ev,zqm_ev,zpc_ev,zrc_ev,zbg,zpp, +c tob_ev,tqm_ev,tpc_ev,trc_ev,tbg,tpp, +c qob_ev,qqm_ev,qpc_ev,qrc_ev,qbg,qpp, +c uob_ev,vob_ev,wqm_ev,wpc_ev,wrc_ev,wbg,wpp, +c ddo_ev,ffo_ev,dfq_ev,dfp_ev,dfr_ev, +c l_allev_pf) +c +c Input argument list: +c inlun - Unit number for the input pre-PREPACQC PREPBUFR file containing all data +c (separate mass/wind pieces) +c max_reps - Maximum number of reports accepted by acftobs_qc +c mxnmev - Maximum number of events allowed, per variable type +c bmiss - BUFRLIB missing value (set in main program) +c imiss - NRL integer missing value flag (99999) +c amiss - NRL real missing value flag (-9999.) +c m2ft - NRL conversion factor to convert meters to feet +c mxlv - Maximum number of levels allowed in a report profile +c l_allev_pf - Logical whether to process latest (likely NRLACQC) event plus all prior +c events (TRUE) or only latest event (FALSE) into profiles PREPBUFR-like +c file (if TRUE means read in these pre-existing events here) +c +c Output argument list: +c nrpts4QC - Total number of input merged (mass + wind piece) aircraft-type reports +c read in from PREPBUFR file +c cdtg_an - Date/analysis time (YYYYMMDDCC) +c alat - Array of latitudes for the "merged" reports +c alon - Array of longitudes for the "merged" reports +c ht_ft - Array of altitudes for the "merged" reports +c idt - Array of ob-cycle times for the "merged" reports (in seconds) +c itype - Array of aircraft type for the "merged" reports +c phase - Array of phase of flight for aircraft for the "merged" reports +c t_prcn - Array of temperature precision for the "merged" reports +c c_acftreg - Array of aircraft tail numbers for the "merged" reports to later be used +c in NRL QC processing +c c_acftid - Array of aircraft flight numbers for the "merged" reports to later be +c used in NRL QC processing +c pres - Array of pressure for the "merged" reports +c ob_t - Array of aircraft temperature for the "merged" reports +c ob_q - Array of aircraft moisture (specific humidity) for the "merged" reports +c ob_dir - Array of aircraft wind direction for the "merged" reports +c ob_spd - Array of aircraft wind speed for the "merged" reports +c ichk_t - NRL QC flag for temperature ob +c ichk_q - NRL QC flag for moisture ob +c ichk_d - NRL QC flag for wind direction ob +c ichk_s - NRL QC flag for wind speed ob +c nchk_t - NCEP PREPBUFR QC flag for temperature ob +c nchk_q - NCEP PREPBUFR QC flag for moisture ob +c nchk_d - NCEP PREPBUFR QC flag for wind direction ob +c nchk_s - NCEP PREPBUFR QC flag for wind speed ob +c xiv_t - Array of aircraft temperature innovations (ob-bg) for "merged" reports +c xiv_q - Array of aircraft moisture innovations (ob-bg) for "merged" reports +c xiv_d - Array of aircraft wind direction innovations (ob-bg) for "merged" reports +c xiv_s - Array of aircraft wind speed innovations (ob-bg) for "merged" reports +c l_minus9C - Array of logicals denoting aircraft with -9C temperature for "merged" +c reports +c nevents - Array tracking number of events for all variables (p, q, t, z, u/v, +c dir/spd) for "merged" reports +c hdr - Array of aircraft report headers info for "merged" reports +c acid - Array of aircraft report flight numbers for "merged" MDCRS and AMDAR +c (LATAM only) reports (read in from 'ACID' in input PREPBUFR file) +c rct - Array of aircraft report receipt times for "merged" reports +c drinfo - Array of aircraft "drift" info (just XOB, YOB, DHR right now) for +c "merged" reports +c acft_seq - Array of temperature precision and phase of flight for aircraft for the +c "merged" reports +c turb1seq - Array of type 1 aircraft turbulence for the "merged" reports +c turb2seq - Array of type 2 aircraft turbulence for the "merged" reports +c turb3seq - Array of type 3 aircraft turbulence for the "merged" reports +c prewxseq - Array of present weather info for the "merged" reports +c cloudseq - Array of cloud info for the "merged" reports +c afic_seq - Array of aircraft icing info for the "merged" reports +c mstq - Array of aircraft moisture flags for the "merged" reports +c cat - Array of PREPBUFR level category values ("CAT") for the "merged" reports +c rolf - Aircraft of aircraft roll angle flags for the "merged" reports +c nnestreps - Array containing the Number of "nested replications" for turbulence, +c present weather, cloud and icing for the "merged" reports +c sqn - Array containing the original PREPBUFR mass and wind piece sequence +c numbers ("SQN") for the "merged" reports +c procn - Array containing the original PREPBUFR mass and wind piece poe process +c numbers ("PROCN") for the "merged" reports +c pob_ev - Array of pressure event obs for "merged" reports +c pqm_ev - Array of pressure event quality marks for "merged" reports +c ppc_ev - Array of pressure event program codes for "merged" reports +c prc_ev - Array of pressure event reason codes for "merged" reports +c pbg - Array of pressure background data for "merged" reports +c ppp - Array of pressure post-processing info for "merged" reports +c zob_ev - Array of altitude event obs for "merged" reports +c zqm_ev - Array of altitude event quality marks for "merged" reports +c zpc_ev - Array of altitude event program codes for "merged" reports +c zrc_ev - Array of altitude event reason codes for "merged" reports +c zbg - Array of altitude background data for "merged" reports +c zpp - Array of altitude post-processing info for "merged" reports +c tob_ev - Array of temperature event obs for "merged" reports +c tqm_ev - Array of temperature event quality marks for "merged" reports +c tpc_ev - Array of temperature event program codes for "merged" reports +c trc_ev - Array of temperature event reason codes for "merged" reports +c tbg - Array of temperature background data "merged" reports +c tpp - Array of temperature post-processing info for "merged" reports +c qob_ev - Array of moisture event obs for "merged" reports +c qqm_ev - Array of moisture event quality marks for "merged" reports +c qpc_ev - Array of moisture event program codes for "merged" reports +c qrc_ev - Array of moisture event reason codes for "merged" reports +c qbg - Array of moisture background data for "merged" reports +c qpp - Array of moisture post-processing info for "merged" reports +c uob_ev - Array of wind/u-comp event obs for "merged" reports +c vob_ev - Array of wind/v-comp event obs for "merged" reports +c wqm_ev - Array of wind event quality marks for "merged" reports +c wpc_ev - Array of wind event program codes for "merged" reports +c wrc_ev - Array of wind event reason codes for "merged" reports +c wbg - Array of wind background data for "merged" reports +c wpp - Array of wind post-processing info for "merged" reports +c ddo_ev - Array of wind direction event obs for "merged" reports +c ffo_ev - Array of wind speed event obs for "merged" reports +c dfq_ev - Array of wind direction/speed quality marks for "merged" reports +c dfp_ev - Array of wind direction/speed program codes for "merged" reports +c dfr_ev - Array of wind direction/speed reason codes for "merged" reports +c +c Input files: +c Unit inlun - PREPBUFR file containing all obs, prior to any processing by this program +c +c Output files: +c Unit 06 - Standard output print +c +c Subprograms called: +c Unique: none +c Library: +c SYSTEM: SYSTEM +c W3NCO: ERREXIT W3TAGE W3MOVDAT +c W3EMC: W3FC05 +c BUFRLIB: IREADMG IREADSB UFBINT UFBSEQ UFBEVN READNS IBFMS +c +c Exit States: +c Cond = 0 - successful run +c 23 - unexpected return code from readns; problems reading BUFR file +c +c Remarks: Called by main program. +c +c Attributes: +c Language: FORTRAN 90 +c Machine: NCEP WCOSS +c +c$$$ + subroutine input_acqc(inlun,max_reps,mxnmev,bmiss,imiss,amiss, + + m2ft,mxlv,nrpts4QC,cdtg_an,alat,alon,ht_ft, + + idt,c_dtg,itype,phase,t_prcn,c_acftreg, + + c_acftid,pres,ob_t,ob_q,ob_dir,ob_spd, + + ichk_t,ichk_q,ichk_d,ichk_s, + + nchk_t,nchk_q,nchk_d,nchk_s, + + xiv_t,xiv_q,xiv_d,xiv_s, + + l_minus9C,nevents,hdr,acid,rct,drinfo, + + acft_seq,turb1seq,turb2seq,turb3seq, + + prewxseq,cloudseq,afic_seq,mstq,cat,rolf, + + nnestreps,sqn,procn, + + pob_ev,pqm_ev,ppc_ev,prc_ev,pbg,ppp, + + zob_ev,zqm_ev,zpc_ev,zrc_ev,zbg,zpp, + + tob_ev,tqm_ev,tpc_ev,trc_ev,tbg,tpp, + + qob_ev,qqm_ev,qpc_ev,qrc_ev,qbg,qpp, + + uob_ev,vob_ev,wqm_ev,wpc_ev,wrc_ev,wbg,wpp, + + ddo_ev,ffo_ev,dfq_ev,dfp_ev,dfr_ev, + + l_allev_pf) + + implicit none + +c ------------------------------ +c Parameter statements/constants +c ------------------------------ + integer inlun ! input unit number (for pre-prepacqc PREPBUFR file + ! containing all obs) + integer max_reps ! maximum number of input merged (mass + wind piece) + ! aircraft-type reports allowed +cvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv +c replace above with this in event of future switch to dynamic memory allocation + +calloc integer max_reps ! original number of input merged (mass + wind piece) +calloc ! aircraft-type reports (obtained from first pass through +calloc ! input PREPBUFR file to get total for array +calloc ! allocation should = nrpts4QC) +c^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + character*6 cmax_reps ! character form of max_reps + integer imiss ! NRL integer missing value flag + real amiss ! NRL real missing value flag + real*8 bmiss ! BUFRLIB missing value (set in main program) + real m2ft ! NRL conversion factor to convert m to ft + integer mxlv ! maximum number of report levels allowed in aircraft + ! profiles + +c ---------------------- +c Declaration statements +c ---------------------- + +c Variables for BUFRLIB interface +c ------------------------------- + character*8 mesgtype ! BUFR message type (e.g., 'AIRCFT ') + integer mesgdate ! date time from BUFR message (YYYYMMDDHH) + +c Logicals controlling processing (read in from namelist in main program) +c ----------------------------------------------------------------------- + logical l_allev_pf ! T=process latest (likely NRLACQC) events plus all prior + ! events into profiles PREPBUFR-like file (here means must + ! read in these pre-existing events) + ! **CAUTION: More complete option, but will make code take + ! longer to run!!! + ! F=process ONLY latest (likely NRLACQC) events into profiles + ! PREPBUFR-like file (here means read in only latest events + ! which will likely be written over later by NRLACQC events) + ! + ! Note 1: Hardwired to F if l_doprofiles=F + ! Note 2: All pre-existing events plus latest (likely NRLACQC) + ! events are always encoded into full PREPBUFR file) + +c Indices/counters +c ---------------- + integer i,j ! loop indeces + +, invi ! "inverse" of the i counter + +c for BUFR messages: + integer nACmsg_tot ! number of acft-type BUFR messages in input PREPBUFR file + +c for BUFR subsets/reports: + integer nrptsaircar ! number of AIRCAR BUFR subsets read from PREPBUFR file + ! (should = nmswd(2,1) + nmswd(2,2)) + +, nrptsaircft ! number of AIRCFT BUFR subsets read from PREPBUFR file + ! (should = nmswd(1,1) + nmswd(1,2)) + +, nmswd(2,2) ! number of ((AIRCFT,AIRCAR),(mass,wind)) BUFR subsets + ! read from PREPBUFR file + +, nrpts_rd ! total number of aircraft-type BUFR subsets read from + ! PREPBUFR file (should = + ! nmswd(1,1) + nmswd(1,2) + nmswd(2,1) + nmswd(2,2)) + +, nrpts4QC ! total number of input merged (mass + wind piece) + ! aircraft-type reports read in from PREPBUFR file + ! (should = numpairs + numorph) + + integer numpairs ! number of input merged (mass + wind piece) aircraft- + ! type reports read in from PREPBUFR file where there + ! is BOTH mass and wind data + ! (should = numAIRCFTpairs + numAIRCARpairs) + +, numorph ! number of input merged (mass + wind piece) aircraft- + ! type reports read in from PREPBUFR file where there + ! is either ONLY mass data or only wind data (deemed + ! "orphans", of course in reality there is no merging + ! here) (should = numAIRCFTorph + numAIRCARorph) + +, numAIRCFTpairs ! number of input merged (mass + wind piece) reports + ! read in from AIRCFT BUFR messages in PREPBUFR file + ! where there is BOTH mass and wind data + +, numAIRCARpairs ! number of input merged (mass + wind piece) reports + ! read in from AIRCAR BUFR messages in PREPBUFR file + ! where there is BOTH mass and wind data + +, numAIRCFTorph ! number of input merged (mass + wind piece) reports + ! read in from AIRCFT BUFR messages in PREPBUFR file + ! where there is either ONLY mass data or only wind + ! data (deemed "orphans", of course in reality there + ! is no merging here) + +, numAIRCARorph ! number of input merged (mass + wind piece) reports + ! read in from AIRCAR BUFR messages in PREPBUFR file + ! where there is either ONLY mass data or only wind + ! data (deemed "orphans", of course in reality there + ! is no merging here) + + integer nPIREP ! number of input merged (mass + wind piece) reports + ! read in from AIRCFT BUFR messages in PREPBUFR file + ! that are deemed to be "PIREP" reports + +, nAUTOAIREP ! number of input merged (mass + wind piece) reports + ! read in from AIRCFT BUFR messages in PREPBUFR file + ! that are deemed to be automated AIREP reports + +, nMANAIREP ! number of input merged (mass + wind piece) reports + ! read in from AIRCFT BUFR messages in PREPBUFR file + ! that are deemed to be Manual AIREP (all "voice") + ! reports + +, nAMDAR ! number of input merged (mass + wind piece) reports + ! read in from AIRCFT BUFR messages in PREPBUFR file + ! that are deemed to be AMDAR reports (excluding + ! Canadian AMDAR) + +, nAMDARcan ! number of input merged (mass + wind piece) reports + ! read in from AIRCFT BUFR messages in PREPBUFR file + ! that are deemed to be Canadian AMDAR reports + +, nMDCRS ! number of input merged (mass + wind piece) reports + ! read in from AIRCAR BUFR messages in PREPBUFR file + ! (all are MDCRS reports) + +, nTAMDAR ! number of input merged (mass + wind piece) reports + ! read in from AIRCFT BUFR messages in PREPBUFR file + ! that are deemed to be TAMDAR reports + +c Functions +c --------- + integer ireadmg ! BUFRLIB - for reading messages + +, ireadsb ! BUFRLIB - for reading subsets + +, ibfms ! BUFRLIB - for testing for missing + +c Observation arrays +c ------------------ + character*10 cdtg_an ! date-time group for analysis (YYYYMMDDCC) + character*14 c_dtg(max_reps) ! full date-time group (yyyymmddhhmmss) + character*8 c_acftreg(max_reps) ! aircraft registration (tail) number (used in NRL + ! QC processing) + character*9 c_acftid(max_reps) ! aircraft flight number (used in NRL QC processing) + real*8 alat(max_reps) ! latitude + +, alon(max_reps) ! longitude + real pres(max_reps) ! pressure + +, ht_ft(max_reps) ! altitude in feet + +, t_prcn(max_reps) ! temperature precision + +, ob_t(max_reps) ! temperature + +, ob_q(max_reps) ! moisture (specific humidity) + +, ob_dir(max_reps) ! wind direction + +, ob_spd(max_reps) ! wind speed + +, xiv_t(max_reps) ! temperature innovation/increment (ob-bg) + +, xiv_q(max_reps) ! specific humidity innovation/increment (ob-bg) + +, xiv_d(max_reps) ! wind direction innovation/increment (ob-bg) + +, xiv_s(max_reps) ! wind speed innovation/increment (ob-bg) + integer itype(max_reps) ! instrument (aircraft) type + +, idt(max_reps) ! time in seconds to anal. time (- before, + after) + +, ichk_t(max_reps) ! NRL QC flag for temperature ob + +, ichk_q(max_reps) ! NRL QC flag for specific humidity ob + +, ichk_d(max_reps) ! NRL QC flag for wind direction ob + +, ichk_s(max_reps) ! NRL QC flag for wind speed ob + +, nchk_t(max_reps) ! NCEP QC flag for temperature ob + +, nchk_q(max_reps) ! NCEP QC flag for specific humidity ob + +, nchk_d(max_reps) ! NCEP QC flag for wind direction ob + +, nchk_s(max_reps) ! NCEP QC flag for wind speed ob + +, phase(max_reps) ! phase of flight for aircraft + + logical l_minus9c(max_reps) ! true for MDCRS -9C temperatures + +c Variables for reading numeric data out of BUFR files via BUFRLIB +c ---------------------------------------------------------------- + real*8 arr_8(15,10) ! array holding BUFR subset values from BUFRLIB call to + ! input PREPBUFR file + integer nlev ! number of report levels returned from BUFRLIB call + +, iret ! return code for call to BUFRLIB routine readns + +c Variables for reading character data out of BUFR files w/ BUFRLIB +c ----------------------------------------------------------------- + real*8 c_arr_8 ! real*8 PREPBUFR report id ("SID") + character*8 charstr ! character*8 equivalent of c_arr_8 + + equivalence(charstr,c_arr_8) + +c Variables for reading event values out of BUFR files w/ BUFRLIB +c --------------------------------------- ----------------------- + integer mxevdt ! maximum number of events allowed for each ob type + parameter (mxevdt = 10) + + integer mxnmev ! maximum number of events allowed in stack + +, mxvt ! maximum number of variable types (P, Q, T, Z, U, V) + parameter (mxvt = 6) + + integer qms(4) ! pointers to ichk_[t,q,d,s] + character*1 QM_types(4) ! characters for QM variable types + + /'T','Q','D','S'/ + + real*8 pqtzuvEV(mxevdt,mxlv,mxnmev,mxvt) ! holds values read from PREPBUFR file + ! (according to type,level,event,variable) + + character*80 EVstr(mxvt) ! mnemonic string for populating pqtzuvEV + + /'POB PQM PPC PRC PFC PAN CAT', ! pressure + + 'QOB QQM QPC QRC QFC QAN CAT', ! moisture + + 'TOB TQM TPC TRC TFC TAN CAT', ! temperature + + 'ZOB ZQM ZPC ZRC ZFC ZAN CAT', ! altitude + + 'UOB WQM WPC WRC UFC UAN CAT', ! u-wind + + 'VOB WQM WPC WRC VFC VAN CAT'/ ! v-wind + + real uob ! u-component wind for a single report + +, vob ! v-component wind for a single report + +, ufc ! u-component background wind for a single report + +, vfc ! v-component background wind for a single report + +, dir_fc ! wind direction background for a single report + +, spd_fc ! wind speed background for a single report + + integer evknt ! counter used when determining number of events per + ! variable type + + real*8 df_arr(5,mxlv,mxnmev) ! array used to read out wind (dir/spd) events + +c Variables for determining whether consecutive reports are mass and wind pieces that belong +c together +c ------------------------------------------------------------------------------------------ + logical l_massrpt ! TRUE if report read in from PREPBUFR is a mass piece + +, l_windrpt ! TRUE if report read in from PREPBUFR is a wind piece + +, l_match ! TRUE if mass and wind reports currently being + ! processed match (they are part of the same total + ! aircraft report) + + real sqn_current ! PREPBUFR sequence number ("SQN") of current report + +, sqn_next ! PREPBUFR sequence number ("SQN") of previous report + +, procn_current ! PREPBUFR poes process number ("PROC") of current + ! report + +c Variables for converting idt to YYYYMMDDHHMMSS format (stored in array c_dtg) +c ----------------------------------------------------------------------------- + integer year ! year of analysis time + +, month ! month of analysis time + +, day ! day of analysis time + +, hour ! hour of analysis time + +, idat(8) ! input array for call to w3movdat + +, jdat(8) ! output array for call to w3movdat + real rinc(5) ! array containing time increment for w3movdat + + +c Variables used to hold original aircraft data read from the input PREPBUFR file - necessary +c for carrying data through program so that it can be written to output profiles PREPBUFR- +c like file from memory instead of going back to input PREPBUFR file and re-reading that +c file before adding any QC events resulting from a decision made by the NRL QC routine (not +c applicable for case of single-level QC'd reports written back to full PREPBUFR file) +c -------------------------------------------------------------------------------------------- + integer nevents(max_reps,6) ! array tracking number of events for variables for + ! each report: + ! 1 - number of pressure events + ! 2 - number of specific humidity events + ! 3 - number of temperature events + ! 4 - number of altitude events + ! 5 - number of wind (u/v) events + ! 6 - number of wind (direction/speed) events + + integer nnestreps(4,max_reps) ! number of "nested replications" for TURB3SEQ, + ! PREWXSEQ, CLOUDSEQ, AFIC_SEQ + + integer nrep ! number of "nested replications" for TURB3SEQ + ! PREWXSEQ, CLOUDSEQ, AFIC_SEQ prior to setting to + ! nnestreps + + real*8 pob_ev(max_reps,mxnmev) ! POB values for each report, including all events + +, pqm_ev(max_reps,mxnmev) ! PQM values for each report, including all events + +, ppc_ev(max_reps,mxnmev) ! PPC values for each report, including all events + +, prc_ev(max_reps,mxnmev) ! PRC values for each report, including all events + +, zob_ev(max_reps,mxnmev) ! ZOB values for each report, including all events + +, zqm_ev(max_reps,mxnmev) ! ZQM values for each report, including all events + +, zpc_ev(max_reps,mxnmev) ! ZPC values for each report, including all events + +, zrc_ev(max_reps,mxnmev) ! ZRC values for each report, including all events + +, tob_ev(max_reps,mxnmev) ! TOB values for each report, including all events + +, tqm_ev(max_reps,mxnmev) ! TQM values for each report, including all events + +, tpc_ev(max_reps,mxnmev) ! TPC values for each report, including all events + +, trc_ev(max_reps,mxnmev) ! TRC values for each report, including all events + +, qob_ev(max_reps,mxnmev) ! QOB values for each report, including all events + +, qqm_ev(max_reps,mxnmev) ! QQM values for each report, including all events + +, qpc_ev(max_reps,mxnmev) ! QPC values for each report, including all events + +, qrc_ev(max_reps,mxnmev) ! QRC values for each report, including all events + +, uob_ev(max_reps,mxnmev) ! UOB values for each report, including all events + +, vob_ev(max_reps,mxnmev) ! VOB values for each report, including all events + +, wqm_ev(max_reps,mxnmev) ! WQM values for each report, including all events + +, wpc_ev(max_reps,mxnmev) ! WPC values for each report, including all events + +, wrc_ev(max_reps,mxnmev) ! WRC values for each report, including all events + +, ddo_ev(max_reps,mxnmev) ! DDO values for each report, including all events + +, ffo_ev(max_reps,mxnmev) ! FFO values for each report, including all events + +, dfq_ev(max_reps,mxnmev) ! DFQ values for each report, including all events + +, dfp_ev(max_reps,mxnmev) ! DFP values for each report, including all events + +, dfr_ev(max_reps,mxnmev) ! DFR values for each report, including all events + + +, hdr(max_reps,15) ! SID XOB YOB DHR ELV TYP T29 TSB ITP SQN PROCN RPT + ! TCOR RSRD EXRSRD + +, acid(max_reps) ! ACID + +, rct(max_reps) ! RCT + + +, pbg(max_reps,3) ! POE PFC PFCMOD + +, zbg(max_reps,3) ! ZOE ZFC ZFCMOD + +, tbg(max_reps,3) ! TOE TFC TFCMOD + +, qbg(max_reps,3) ! QOE QFC QFCMOD + +, wbg(max_reps,5) ! WOE UFC VFC UFCMOD VFCMOD + + +, ppp(max_reps,3) ! PAN PCL PCS + +, zpp(max_reps,3) ! ZAN ZCL ZCS + +, tpp(max_reps,3) ! TAN TCL TCS + +, qpp(max_reps,3) ! QAN QCL QCS + +, wpp(max_reps,6) ! UAN VAN UCL VCL UCS VCS + + +, drinfo(max_reps,3) ! XOB YOB DHR + +, acft_seq(max_reps,2) ! PCAT POAF + + +, turb1seq(max_reps) ! TRBX + +, turb2seq(max_reps,4) ! TRBX10 TRBX21 TRBX32 TRBX43 + +, turb3seq(3,max_reps,5) ! DGOT HBOT HTOT + +, prewxseq(1,max_reps,5) ! PRWE + +, cloudseq(5,max_reps,5) ! VSSO CLAM CLTP HOCB HOCT + +, afic_seq(3,max_reps,5) ! AFIC HBOI HTOI + +, mstq(max_reps) ! MSTQ + +, cat(max_reps) ! CAT + +, rolf(max_reps) ! ROLF + + +, sqn(max_reps,2) ! SQN (1=SQN for mass, 2=SQN for wind) + +, procn(max_reps,2) ! PROCN (1=PROCN for mass, 2=PROCN for wind) + +c ******************************************************************* + +c Start subroutine +c ---------------- + write(*,*) + write(*,*) '**********************' + write(*,*) 'Welcome to input_acqc.' + call system('date') + write(*,*) '**********************' + write(*,*) + +c Input PREPBUFR file is open and ready for reading by BUFRLIB +c ------------------------------------------------------------ + + print *, 'Initializing...' + +c Initialize observation arrays +c ----------------------------- + ob_t = amiss + ob_q = amiss + ob_dir = amiss + ob_spd = amiss + xiv_t = amiss + xiv_q = amiss + xiv_d = amiss + xiv_s = amiss + + nchk_t = -9 + nchk_q = -9 + nchk_d = -9 + nchk_s = -9 + +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + alat = amiss + alon = amiss +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + pres = amiss + ht_ft = amiss + itype = imiss + idt = imiss + + c_acftreg = ' ' + c_acftid = ' ' + c_dtg = ' ' + + nevents = 0 + + pob_ev = bmiss + pqm_ev = bmiss + ppc_ev = bmiss + prc_ev = bmiss + + zob_ev = bmiss + zqm_ev = bmiss + zpc_ev = bmiss + zrc_ev = bmiss + + tob_ev = bmiss + tqm_ev = bmiss + tpc_ev = bmiss + trc_ev = bmiss + + qob_ev = bmiss + qqm_ev = bmiss + qpc_ev = bmiss + qrc_ev = bmiss + + uob_ev = bmiss + vob_ev = bmiss + wqm_ev = bmiss + wpc_ev = bmiss + wrc_ev = bmiss + + ddo_ev = bmiss + ffo_ev = bmiss + dfq_ev = bmiss + dfp_ev = bmiss + dfr_ev = bmiss + + hdr = bmiss + rct = bmiss + acid = bmiss + + pbg = bmiss + zbg = bmiss + qbg = bmiss + tbg = bmiss + wbg = bmiss + + ppp = bmiss + zpp = bmiss + qpp = bmiss + tpp = bmiss + wpp = bmiss + + drinfo = bmiss + turb1seq = bmiss + turb2seq = bmiss + turb3seq = bmiss + prewxseq = bmiss + cloudseq = bmiss + afic_seq = bmiss + mstq = bmiss + cat = bmiss + rolf = bmiss + + sqn = 999999 + procn = 999999 + + nnestreps = 0 + + l_minus9C = .false. + + print *, 'Done initializing arrays...' + +c Initialize counters +c ------------------- + nACmsg_tot = 0 + numpairs = 0 + numorph = 0 + + nrptsaircar = 0 + nrptsaircft = 0 + + nrpts_rd = 0 + nrpts4QC = 0 + + numAIRCFTpairs = 0 + numAIRCARpairs = 0 + numAIRCFTorph = 0 + numAIRCARorph = 0 + + nPIREP = 0 + nAUTOAIREP = 0 + nMANAIREP = 0 + nAMDAR = 0 + nAMDARcan = 0 + nMDCRS = 0 + nTAMDAR = 0 + + nmswd = 0 + + print *, 'Done initializing counters...' + +c Initialize logicals +c ------------------- + l_massrpt = .false. + l_windrpt = .false. + + l_match = .false. + + print *, 'Done initializing logicals...' + +c Read data from pre-QC PREPBUFR file +c ----------------------------------- + write(*,*) 'Beginning data read!' + +c Start reading messages +c ---------------------- + loop2: do while(ireadmg(inlun,mesgtype,mesgdate).eq.0) + +c Only consider reports from messages with type 'AIRCFT' or 'AIRCAR' +c ------------------------------------------------------------------ + if(mesgtype.eq.'AIRCFT'.or.mesgtype.eq.'AIRCAR') then + +c Update counters of messages read in and considered +c -------------------------------------------------- + nACmsg_tot = nACmsg_tot + 1 + +c The date in all NCEP PREPBUFR messages is the date/cycle time - use this for the variable +c cdtg_an - no need to read in the cycle time from std input +c ----------------------------------------------------------------------------------------- + if(nACmsg_tot.eq.1) then ! obtain date/cycle from the first PREPBUFR message read + write(cdtg_an,'(i10)') mesgdate ! Convert mesgdate to character + write(*,*) 'Cycle date/time in PREPBUFR messages: ',cdtg_an + endif + +c Using the function ireadsb, read the PREPBUFR subsets/reports, which are separated into +c mass and wind pieces (NCEP convention) - we will need to pull out values and populate the +c following arrays, which will be used by the NRL aircraft QC routine: +c itype, alat, alon, pres, ht_ft,idt, c_dtg, c_acftreg, c_acftid, t_prcn, ob_t, ob_q, +c ob_dir, ob_spd, ichk_t, ichk_q, ichk_d, ichk_s, l_minus9C +c ------------------------------------------------------------------------------------------ + do while(ireadsb(inlun).eq.0) + + 4001 continue + l_match = .false. ! Reset match indicator. second halves of matches are read + ! starting at statement 6001 + + if(mesgtype.eq.'AIRCAR') then + nrptsaircar = nrptsaircar + 1 + elseif (mesgtype.eq.'AIRCFT') then + nrptsaircft = nrptsaircft + 1 + else ! not an aircraft-type message, cycle back to message reading loop & see if + ! there are more in file + print *, '---> MESGTYPE NOT AIRCRAFT TYPE!!!',' "', + + mesgtype,'"' + print *, '---> keep looping through messages in case any', + + ' more are in file' + cycle loop2 + endif + nrpts_rd = nrpts_rd + 1 ! number of aircraft-type BUFR subsets read from + ! PREPBUFR file + + 5001 continue ! will come here if we've just stored the second of a pair or an orphan; + ! need to increment index for the report-oriented arrays + if(nrpts4QC+1.gt.max_reps) then +c....................................................................... +c There are more reports in input file than "max_reps" -- do not process any more reports +c --------------------------------------------------------------------------------------- + print 53, max_reps,max_reps + 53 format(/' #####> WARNING: THERE ARE MORE THAN ',I6,' AIRCRAFT ', + + 'REPORTS IN INPUT FILE -- MUST INCREASE SIZE OF PARAMETER NAME', + + ' "MAX_REPS" - WILL CONTINUE ON PROCESSING ONLY ',I6,' REPORTS'/) + write(cmax_reps,'(i6)') max_reps +! call system('[ -n "$jlogfile" ] && $DATA/postmsg'// +! + ' "$jlogfile" "***WARNING:'//cmax_reps//' AIRCRAFT '// +! + 'REPORT LIMIT EXCEEDED IN PREPOBS_PREPACQC, ONLY '// +! + cmax_reps//' RPTS PROCESSED"') + exit loop2 +c....................................................................... + endif + nrpts4QC = nrpts4QC + 1 ! number of input merged (mass + wind piece) aircraft- + ! type reports read in from PREPBUFR file (for QC code/ + ! index for arrays that will be used by acftobs_qc) + 6001 continue ! will come here if we need to check subset n+1 and see if it matches + ! the one just stored (treat subset n+1 as a new subset n) + +c Pull out the "header" info for subset n, which will either be a mass or wind piece - header +c mnemonics are: YOB XOB ELV DHR POAF TYP PCAT, along w/ SID +c ------------------------------------------------------------------------------------------- + arr_8 = bmiss + + call ufbint(inlun,arr_8,15,10,nlev, + +'YOB XOB ELV DHR TYP T29 TSB ITP SQN PROCN RPT TCOR RSRD EXPRSRD') + +cccccc hdr(nrpts4QC,1) = SID - stored later in code + hdr(nrpts4QC,2) = arr_8(2,1) ! XOB + hdr(nrpts4QC,3) = arr_8(1,1) ! YOB + hdr(nrpts4QC,4) = arr_8(4,1) ! DHR + hdr(nrpts4QC,5) = arr_8(3,1) ! ELV + hdr(nrpts4QC,6:15) = arr_8(5:14,1) ! TYP T29 TSB ITP SQN PROCN RPT TCOR RSRD + ! EXRSRD + +c Drift information +c ----------------- + drinfo(nrpts4QC,1) = arr_8(2,1) ! XOB/XDR + drinfo(nrpts4QC,2) = arr_8(1,1) ! YOB/YDR + drinfo(nrpts4QC,3) = arr_8(4,1) ! DHR/HRDR + +c Arrays used in NRL QC routine itself +c ------------------------------------ + alat(nrpts4QC) = arr_8(1,1) ! YOB + alon(nrpts4QC) = arr_8(2,1) ! XOB + ht_ft(nrpts4QC) = nint(arr_8(3,1)*m2ft) ! ELV in PREPBUFR is in meters NRL QC + ! wants feet + idt(nrpts4QC) = nint(arr_8(4,1)*3600.) ! NRL QC expects idt in sec + +c Determine whether this is a temperature or a wind report +c -------------------------------------------------------- + if(int(arr_8(5,1))/100.eq.1) then + l_massrpt = .true. + l_windrpt = .false. + + if(mesgtype.eq.'AIRCFT') then + nmswd(1,1) = nmswd(1,1) + 1 + elseif(mesgtype.eq.'AIRCAR') then + nmswd(2,1) = nmswd(2,1) + 1 + endif + + elseif(int(arr_8(5,1))/100.eq.2) then + l_massrpt = .false. + l_windrpt = .true. + + if(mesgtype.eq.'AIRCFT') then + nmswd(1,2) = nmswd(1,2) + 1 + elseif(mesgtype.eq.'AIRCAR') then + nmswd(2,2) = nmswd(2,2) + 1 + endif + + endif + + itype(nrpts4QC) = mod(int(hdr(nrpts4QC,6)),100) + ! 30 = NCEP: AIREP (NRL Manual AIREP/voice) + ! 30 = NCEP: PIREP (NRL Manual AIREP/voice) + ! 31 = NCEP: AMDAR (all types except Canadian) (NRL: AMDAR) + ! 32 = NCEP; RECCOs, but these are in ADPUPA msgs + ! 33 = NCEP: MDCRS (NRL: MDCRS) + ! 34 = NCEP: TAMDAR (NRL: ACARS) + ! 35 = NCEP: Canadian AMDAR (NRL: AMDAR) + +c Process SQN/PROCN - they will be used to construct full reports from mass and wind pieces +c ----------------------------------------------------------------------------------------- + sqn_current = hdr(nrpts4QC,10) + procn_current = hdr(nrpts4QC,11) + +c Get turbulence values, present weather (PRWE), cloud data, etc. (these are all nested- +c replicated) +c +c Note: These values, while there may be multiple replications of them, should be present +c only on a single level upon input (aircraft data is organized as single-level data +c upon input to this program - prior step is PREPDATA) +c ---------------------------------------------------------------------------------------- + +c turb3seq values: DGOT HBOT HTOT +c -- since this is not encoded to PREPBUFR-like (profiles) right now, no need to read in +ccccc arr_8 = bmiss +ccccc +ccccc call ufbseq(inlun,arr_8,15,10,nrep,'TURB3SEQ') +ccccc +ccccc nnestreps(1,nrpts4QC) = nrep +ccccc +ccccc if(nrep.ne.0) then ! There is turb3seq data to store +ccccc do i = 1,nrep +ccccc +ccccc if(nrep.le.5) then +ccccc turb3seq(:,nrpts4QC,nnestreps(1,nrpts4QC)-nrep+i) +ccccc+ = arr_8(1:3,i) +ccccc else ! there are more than 5 replications of TURB3SEQ +ccccc print *,'there are more than 5 reps of TURB3SEQ' +ccccc print *,'report #', nrpts4QC +ccccc endif ! if(nrep.le.5) +ccccc +ccccc enddo ! do i = 1,nrep +ccccc endif ! if(nrep.ne.0) + +c prewxseq values: PRWE +c -- since this is not encoded to PREPBUFR-like (profiles) right now, no need to read in +ccccc arr_8 = bmiss +ccccc +ccccc call ufbseq(inlun,arr_8,15,10,nrep,'PREWXSEQ') +ccccc +ccccc nnestreps(2,nrpts4QC) = nrep +ccccc +ccccc if(nrep.gt.0) then +ccccc do i = 1,nrep +ccccc +ccccc if(nrep.le.5) then +ccccc prewxseq(1,nrpts4QC,nnestreps(2,nrpts4QC)-nrep+i) +ccccc+ = arr_8(1,i) +ccccc else ! there are more than 5 replications of PREWXSEQ +ccccc print *,'there are more than 5 reps of PREWXSEQ' +ccccc print *,'report #', nrpts4QC +ccccc endif ! if(nrep.le.5) +ccccc +ccccc enddo ! do i = 1,nrep +ccccc endif ! if(nrep.gt.0) + +c cloudseq values: VSSO CLAM CLTP HOCB HOCT +c -- since this is not encoded to PREPBUFR-like (profiles) right now, no need to read in +ccccc arr_8 = bmiss +ccccc +ccccc call ufbseq(inlun,arr_8,15,10,nrep,'CLOUDSEQ') +ccccc +ccccc nnestreps(3,nrpts4QC) = nrep +ccccc +ccccc if(nrep.gt.0) then +ccccc do i = 1,nrep +ccccc +ccccc if(nrep.le.5) then +ccccc cloudseq(:,nrpts4QC,nnestreps(3,nrpts4QC)-nrep+i) +ccccc+ = arr_8(1:5,i) +ccccc else ! there are more than 5 replications of the cloud data +ccccc print *,'there are more than 5 reps of CLOUDSEQ' +ccccc print *,'report #', nrpts4QC +ccccc endif ! if(nrep.le.5) +ccccc +ccccc enddo ! do i = 1,nrep +ccccc endif ! if(nrep.gt.0) + +c afic_seq values: AFIC HBOI HTOI +c -- since this is not encoded to PREPBUFR-like (profiles) right now, no need to read in +ccccc arr_8 = bmiss +ccccc +ccccc call ufbseq(inlun,arr_8,15,10,nrep,'AFIC_SEQ') +ccccc +ccccc nnestreps(4,nrpts4QC) = nrep +ccccc +ccccc if(nrep.gt.0) then +ccccc do i = 1,nrep +ccccc +ccccc if(nrep.le.5) then +ccccc afic_seq(:,nrpts4QC,nnestreps(4,nrpts4QC)-nrep+i) +ccccc+ = arr_8(1:3,i) +ccccc else ! there are more than 5 replications of the aircraft icing data +ccccc print *,'there are more than 5 reps of AFIC_SEQ' +ccccc print *,'report #', nrpts4QC +ccccc endif ! if(nrep.le.5) +ccccc +ccccc enddo ! do i = 1,nrep +ccccc endif ! if(nrep.gt.0) + +c Start pulling out non-nested-replicated values +c ---------------------------------------------- + +c acft_seq values: PCAT POAF + arr_8 = bmiss + + call ufbint(inlun,arr_8,15,10,nlev,'PCAT POAF') + + acft_seq(nrpts4QC,:) = arr_8(1:2,1) + + if(ibfms(arr_8(2,1)).ne.0 .or. arr_8(2,1).eq.7.) then + phase(nrpts4QC) = 9 ! NRL sets a missing value of + else ! phase of flight = 9 + phase(nrpts4QC) = int(arr_8(2,1)) + endif + + if (ibfms(arr_8(1,1)) .ne. 0 ) then + t_prcn(nrpts4QC) = amiss + else + t_prcn(nrpts4QC) = arr_8(1,1) + endif + +c turb[1,2]seq values: TRBX TRBX10 TRBX21 TRBX32 TRBX43 + arr_8 = bmiss + + call ufbint(inlun,arr_8,15,10,nlev, + + 'TRBX TRBX10 TRBX21 TRBX32 TRBX43') + + turb1seq(nrpts4QC) = arr_8(1,1) + turb2seq(nrpts4QC,:) = arr_8(2:5,1) + +c Other misc. values: RCT, ROLF, MSTQ, CAT + arr_8 = bmiss + + call ufbint(inlun,arr_8,15,10,nlev,'RCT ROLF MSTQ CAT') + + rct(nrpts4QC) = arr_8(1,1) + mstq(nrpts4QC) = arr_8(3,1) + cat(nrpts4QC) = arr_8(4,1) + rolf(nrpts4QC) = arr_8(2,1) + +c ---------------------------------------------------------------------------------------- +c ---------------------------------------------------------------------------------------- +c Populate flight number and tail number arrays (c_acftid and c_acftreg, resp.) +c ---------------------------------------------------------------------------------------- + call ufbint(inlun,c_arr_8,1,1,nlev,'SID') + + hdr(nrpts4QC,1) = c_arr_8 + + if(mesgtype.eq.'AIRCFT') then + if(itype(nrpts4QC).eq.31 .or. + + itype(nrpts4QC).eq.35) then + +c All AMDAR types currently store tail number in 'SID', while flight number is missing or all +c blanks for all types except for LATAM (Chile) - if flight number is missing or all blanks, +c copy 'SID' into BOTH tail number and flight number locations in NRL arrays; if flight +c number is present and nnot all blanks (LATAM), copy flight number (from 'ACID') into flight +c number location in NRL array +c (Note: European AMDARs may have a valid flight number but it is not yet available in +c PREPBUFR, when it is it will be in mnemonic 'ACID' - DAK) +c ------------------------------------------------------------------------------------------ + c_acftreg(nrpts4QC) = charstr ! tail number + c_acftid(nrpts4QC) = charstr ! flight number (default is tail number) + call ufbint(inlun,c_arr_8,1,1,nlev,'ACID') + if(ibfms(c_arr_8).eq.0) then + if(charstr.ne.' ') then + c_acftid(nrpts4QC) = charstr ! flight number ('ACID' if present, always) + acid(nrpts4QC) = c_arr_8 ! the case for LATAM AMDAR + endif + endif + + elseif(itype(nrpts4QC).eq.30 .or. + + itype(nrpts4QC).eq.34) then + +c AIREP currently stores flight number in 'SID', while PIREP and TAMDAR currently store a +c manufactured ID in 'SID' - copy this into ONLY flight number location in NRL array +c (tail number location will store an all blank tail number - missing) +c --------------------------------------------------------------------------------------- + c_acftid(nrpts4QC) = charstr ! flight number + c_acftreg(nrpts4QC) = ' '! tail number + + if(itype(nrpts4QC).eq.34) ! TAMDARs replace '000' in characters 1-3 + + c_acftid(nrpts4QC)(1:3) = 'TAM'! of flight # with 'TAM' so they will pass + ! "invalid data" check in acftobs_qc + endif + + elseif(mesgtype.eq.'AIRCAR') then + +c MDCRS from ARINC currently store tail number in 'SID' and flight number in 'ACID' - copy +c these into tail number and flight number locations in NRL arrays +c (Note: MDCRS from AFWA was a rarely used backup to those from ARINC until it was +c discontinued on 10/30/2009 - it apparently stored flight number in 'SID' and +c in 'ACID' - store flight number in 'SID' as tail number and flight number in +c 'ACID' (if present) as flight number (even those would be the same here) +c --------------------------------------------------------------------------------------- + c_acftreg(nrpts4QC) = charstr ! tail number + call ufbint(inlun,c_arr_8,1,1,nlev,'ACID') + if(ibfms(c_arr_8).eq.0) then + c_acftid(nrpts4QC) = charstr ! flight number ('ACID' if present, always) + acid(nrpts4QC) = c_arr_8 ! the case for MDCRS from ARINC) + else + c_acftid(nrpts4QC) = ' '! store flight number as missing (all blanks) + ! if not present (may be the case for MDCRS + ! from AWFA) + endif + endif +c ---------------------------------------------------------------------------------------- +c ---------------------------------------------------------------------------------------- + +c Pull out obs and events for subset n +c ------------------------------------ + +c ******************************** +c PRES, OB_T, OB_Q, OB_DIR, OB_SPD +c ******************************** + +c If l_allev_pf is TRUE, use ufbevn to get at data values & events - all pre-existing events +c will be encoded into output PREPBUFR-like (profiles) file, (if l_doprofiles=T) along with +c any new NRLQCQC events on top of them (Note: All pre-existing events are always encoded +c into full PREPBUFR file) +c +c |---------> data types (1=ob, 2=qm, 3=pc, 4=rc, 5=fc, 6=an, 7=cat) +c | |-------> number of levels in the rpt (aircraft data is single level data; +c | | set j=1) +c | | |-----> number of events (will store all events, but only use latest event in +c | | | in the top of the stack (k=1) is used by the core NRL QC code) +c | | | |---> variable types (1=p,2=q,3=t,4=z,5=u,6=v) +c pqtzuvEV(i,j,k,l) +c +c example: pqtzuvEV(2,1,1,5) = QM for U in latest (top-of-stack) event on the 1st level + +c OTHERWISE: +c If l_allev_pf is FALSE, use ufbint to get at data values for only latest (top-of-stack) +c event - only latest event will be encoded into output PREPBUFR-like (profiles) file, (if +c l_doprofiles=T) along with any new NRLQCQC events on top of it (runs faster but pre- +c existing events are not recorded in output PREPBUFR-like file) (Note: All pre-existing +c events are always encoded into full PREPBUFR file) +c +c |---------> data types (1=ob, 2=qm, 3=pc, 4=rc, 5=fc, 6=an, 7=cat) +c | |-------> number of levels in the rpt (aircraft data is single level data; +c | | set j=1) +c | | |-----> always 1 since only one (the latest top-of-stack) event is returned +c | | | here +c | | | |---> variable types (1=p,2=q,3=t,4=z,5=u,6=v) +c pqtzuvEV(i,j,1,l) +c +c example: pqtzuvEV(2,1,1,5) = QM for U in latest (top-of-stack) event on the 1st level +c ------------------------------------------------------------------------------------------ + if(.not.l_allev_pf) then + do i = 1,mxvt + call ufbint(inlun,pqtzuvEV(1,1,1,i),mxevdt,mxlv,nlev, + + EVstr(i)) + enddo + else + do i = 1,mxvt + call ufbevn(inlun,pqtzuvEV(1,1,1,i),mxevdt,mxlv,mxnmev, + + nlev,EVstr(i)) + enddo + endif + + if(.not.l_match) then + +c pressure and pressure/altitude will only be read in and stored from the first (mass) piece +c of a mass/wind piece report pair or from the first (only) piece of a wind-only report +c rather than being re-read and re-stored again from the second (wind) piece (if a second +c piece exists) - this not only avoids wasted processing time (since the pressure and +c pressure-altitude should be the same in both pieces), it also prevents this code from +c reading a missing pressure-altitude in the second piece for those rare cases when +c unreasonably-high winds can be set to missing in PREPDATA resulting in an "empty" wind +c piece being encoded into PREPBUFR (and leading to problems in later profile generation in +c this code) (this is a bug in PREPDATA which will eventually be corrected) + +c Count the number of pressure/altitude events in this report +c ----------------------------------------------------------- +c pressure (1) +c ------------ + if(l_allev_pf) then + evknt = 0 + do j = 1,mxnmev +c |---> pressure + if(ibfms(pqtzuvEV(1,1,j,1)).ne.0) then + nevents(nrpts4QC,1) = evknt + exit ! exit j do loop + else + evknt = evknt + 1 + endif + enddo + else + nevents(nrpts4QC,1) = 1 + endif + +c altitude (4) +c ------------ + if(l_allev_pf) then + evknt = 0 + do j = 1,mxnmev +c |---> altitude + if(ibfms(pqtzuvEV(1,1,j,4)).ne.0) then + nevents(nrpts4QC,4) = evknt + exit ! exit j do loop + else + evknt = evknt + 1 + endif + enddo + else + nevents(nrpts4QC,4) = 1 + endif + +c Store pressure in array needed by subroutine acftobs_qc +c ------------------------------------------------------- + if(ibfms(pqtzuvEV(1,1,1,1)).eq.0) then + pres(nrpts4QC) = pqtzuvEV(1,1,1,1) ! POB at top of stack = pressure fed to + ! NRL QC + endif + +c Store pressure events in "corral" arrays to carry through this code +c ------------------------------------------------------------------- + if(nevents(nrpts4QC,1).gt.0) then + do i = 1,nevents(nrpts4QC,1) + invi = nevents(nrpts4QC,1)-i+1 + +c |---> acft data upon input = "single level"/ +c | 1 replication of PRSLVLA +c | |---> pressure + pob_ev(nrpts4QC,i) = pqtzuvEV(1,1,invi,1) + pqm_ev(nrpts4QC,i) = pqtzuvEV(2,1,invi,1) + ppc_ev(nrpts4QC,i) = pqtzuvEV(3,1,invi,1) + prc_ev(nrpts4QC,i) = pqtzuvEV(4,1,invi,1) + enddo + endif + +c Store pressure background info in "corral" arrays to carry through this code +c ---------------------------------------------------------------------------- + call ufbint(inlun,arr_8,15,10,nlev,'POE PFC PFCMOD') ! only one occurence of bg + ! info per report/level + pbg(nrpts4QC,:) = arr_8(1:3,1) + + call ufbint(inlun,arr_8,15,10,nlev,'PAN PCL PCS') ! only one occurence of post-p + ! info per report/level + ppp(nrpts4QC,:) = arr_8(1:3,1) + +c Store altitude events in "corral" arrays to carry through this code - the actual value of +c altitude is pulled from ELV and stored in the ht_ft array (needed by acftobs_qc) when the +c rest of the report header information is pulled +c ------------------------------------------------------------------------------------------ + if(nevents(nrpts4QC,4).gt.0) then + do i = 1,nevents(nrpts4QC,4) + invi = nevents(nrpts4QC,4)-i+1 + +c |---> altitude + zob_ev(nrpts4QC,i) = pqtzuvEV(1,1,invi,4) + zqm_ev(nrpts4QC,i) = pqtzuvEV(2,1,invi,4) + zpc_ev(nrpts4QC,i) = pqtzuvEV(3,1,invi,4) + zrc_ev(nrpts4QC,i) = pqtzuvEV(4,1,invi,4) + enddo + endif + +c Store altitude background info in "corral" arrays to carry through this code +c ---------------------------------------------------------------------------- + call ufbint(inlun,arr_8,15,10,nlev,'ZOE ZFC ZFCMOD') ! only one occurence of bg + ! info per report/level + zbg(nrpts4QC,:) = arr_8(1:3,1) + + call ufbint(inlun,arr_8,15,10,nlev,'ZAN ZCL ZCS') ! only one occurence of post-p + ! info per report/level + zpp(nrpts4QC,:) = arr_8(1:3,1) + + endif + +c Get temperature & moisture obs, increments, quality marks +c --------------------------------------------------------- + if(l_massrpt) then ! pull mass data + + sqn(nrpts4QC,1) = sqn_current ! SQN (sequence number) for mass piece + procn(nrpts4QC,1) = procn_current ! PROCN (process number) for mass piece + +c Count the number of moisture events in this report +c -------------------------------------------------- +c moisture (2) +c ------------ + if(l_allev_pf) then + evknt = 0 + do j = 1,mxnmev +c |---> moisture + if(ibfms(pqtzuvEV(1,1,j,2)).ne.0) then + nevents(nrpts4QC,2) = evknt + exit ! exit j do loop + else + evknt = evknt + 1 + endif + enddo + else + nevents(nrpts4QC,2) = 1 + endif + +c Moisture (specific humidity) - use QOB from the top of event stack (pqtzuvEV(1,1,1,2) +c ------------------------------------------------------------------------------------- + if(ibfms(pqtzuvEV(1,1,1,2)).eq.0) then + ob_q(nrpts4QC) = pqtzuvEV(1,1,1,2)*0.001 ! NRL code requires g/kg; QOB in + ! PREPBUFR file is in mg/kg + xiv_q(nrpts4QC) = (pqtzuvEV(1,1,1,2) - + + pqtzuvEV(5,1,1,2))*0.001 ! use QOB at top of stack; also, there is only + ! one QFC per report + + nchk_q(nrpts4QC) = int(pqtzuvEV(2,1,1,2)) ! QQM from top of event stack + endif + +c Store moisture events in "corral" arrays to carry through this code +c ------------------------------------------------------------------- + if(nevents(nrpts4QC,2).gt.0) then + do i = 1,nevents(nrpts4QC,2) + invi = nevents(nrpts4QC,2)-i+1 + +c |---> moisture + qob_ev(nrpts4QC,i) = pqtzuvEV(1,1,invi,2) + qqm_ev(nrpts4QC,i) = pqtzuvEV(2,1,invi,2) + qpc_ev(nrpts4QC,i) = pqtzuvEV(3,1,invi,2) + qrc_ev(nrpts4QC,i) = pqtzuvEV(4,1,invi,2) + enddo + endif + +c Store moisture background info in "corral" arrays to carry through this code +c ---------------------------------------------------------------------------- + call ufbint(inlun,arr_8,15,10,nlev,'QOE QFC QFCMOD') ! only one occurence of bg + ! info per report/level + qbg(nrpts4QC,:) = arr_8(1:3,1) + + call ufbint(inlun,arr_8,15,10,nlev,'QAN QCL QCS') ! only one occurence of post- + ! p info per report/level + qpp(nrpts4QC,:) = arr_8(1:3,1) + +c Count the number of temperature events in this report +c ----------------------------------------------------- +c temperature (3) +c --------------- + if(l_allev_pf) then + evknt = 0 + do j = 1,mxnmev +c |---> temperature + if(ibfms(pqtzuvEV(1,1,j,3)).ne.0) then + nevents(nrpts4QC,3) = evknt + exit ! exit j do loop + else + evknt = evknt + 1 + endif + enddo + else + nevents(nrpts4QC,3) = 1 + endif + +c Temperature - use TOB from the top of event stack (pqtzuvEV(1,1,1,3) +c -------------------------------------------------------------------- + if(ibfms(pqtzuvEV(1,1,1,3)).eq.0) then + ob_t(nrpts4QC) = pqtzuvEV(1,1,1,3) + 273.16 ! convert to K + xiv_t(nrpts4QC) = pqtzuvEV(1,1,1,3) - pqtzuvEV(5,1,1,3) ! use TOB at top of + ! stack; also, there + ! is only one TFC + ! per report + nchk_t(nrpts4QC) = int(pqtzuvEV(2,1,1,3)) ! TQM from top of event stack + +c Check for -9C temperature (MDCRS only) +c -------------------------------------- + l_minus9C(nrpts4QC) = .false. + + if(itype(nrpts4QC).eq.33) then + if(abs(ob_t(nrpts4QC)-264.16).lt.0.05) then + l_minus9c(nrpts4QC) = .true. + endif + endif ! check for -9C temp in type = 33 + endif ! check for missing + +c Store temperature events in "corral" arrays to carry through this code +c ---------------------------------------------------------------------- + if(nevents(nrpts4QC,3).gt.0) then + do i = 1,nevents(nrpts4QC,3) + invi = nevents(nrpts4QC,3)-i+1 + +c |---> temperature + tob_ev(nrpts4QC,i) = pqtzuvEV(1,1,invi,3) + tqm_ev(nrpts4QC,i) = pqtzuvEV(2,1,invi,3) + tpc_ev(nrpts4QC,i) = pqtzuvEV(3,1,invi,3) + trc_ev(nrpts4QC,i) = pqtzuvEV(4,1,invi,3) + enddo + endif + +c Store temperature background info in "corral" arrays to carry through this code +c ------------------------------------------------------------------------------- + call ufbint(inlun,arr_8,15,10,nlev,'TOE TFC TFCMOD') ! only one occurence of bg + ! info per report/level + + tbg(nrpts4QC,:) = arr_8(1:3,1) + + call ufbint(inlun,arr_8,15,10,nlev,'TAN TCL TCS') ! only one occurence of post- + ! p info per report/level + tpp(nrpts4QC,:) = arr_8(1:3,1) + +c Get u & v obs, increments, quality marks - convert u & v to direction & speed +c ----------------------------------------------------------------------------- + elseif(l_windrpt) then ! pull u, v, convert to direction & speed + + sqn(nrpts4QC,2) = sqn_current ! SQN (sequence number) for wind piece + procn(nrpts4QC,2) = procn_current ! PROCN (process number) for wind piece + +c Count the number of wind events in this report +c ---------------------------------------------- +c Wind (5/6) - use U/VOB from the top of event stack (pqtzuvEV(1,1,1,5) and +c (pqtzuvEV(1,1,1,6) +c ------------------------------------------------------------------------- + if(l_allev_pf) then + evknt = 0 + do j = 1,mxnmev +c |---> 5=u-comp, 6=v-comp + if(ibfms(pqtzuvEV(1,1,j,5)).ne.0 .or. + + ibfms(pqtzuvEV(1,1,j,6)).ne.0) then + nevents(nrpts4QC,5) = evknt + exit ! exit j do loop + else + evknt = evknt + 1 + endif + enddo + else + nevents(nrpts4QC,5) = 1 + endif + + uob = pqtzuvEV(1,1,1,5) + vob = pqtzuvEV(1,1,1,6) + + ufc = pqtzuvEV(5,1,1,5) ! only one UFC per report + vfc = pqtzuvEV(5,1,1,6) ! only one VFC per report + + if(ibfms(pqtzuvEV(1,1,1,5)).eq.0 .and. + + ibfms(pqtzuvEV(1,1,1,6)).eq.0 ) then + +c Calculate speed & direction from U & V components (for both obs and forecast values) +c +c Per Dennis Keyser on 8/29/05, w3fc05 returns a wind direction of true meteorological nature +c (e.g., a wind w/ dir =270 is a wind from the west) +c +c ALSO NOTE: w3fc05 adds 0.001 to the direction - in order to get around this (without +c immediately changing this routine in W3EMC), set any wind directions between +c 360.000 and 360.002 back to 360.00 - might be a good idea to remove the addition +c of 0.001 to the wind direction in the W3EMC routine w3fc05 some day +c ------------------------------------------------------------------------------------------- + call w3fc05(uob,vob,ob_dir(nrpts4QC),ob_spd(nrpts4QC)) + +c If-statement below is used to negate effect of 0.001 being added to the wind direction in +c the W3EMC routine w3fc05 +c ----------------------------------------------------------------------------------------- + + if(ob_dir(nrpts4QC).gt.360.000 .and. + + ob_dir(nrpts4QC).lt.360.002) then + + ob_dir(nrpts4QC) = 360.00 + + endif + + call w3fc05(ufc,vfc,dir_fc,spd_fc) ! similar to cqcbufr/incrw +c increments +c --------- + xiv_s(nrpts4QC) = ob_spd(nrpts4QC) - spd_fc + xiv_d(nrpts4QC) = ob_dir(nrpts4QC) - dir_fc +c quality marks +c ------------- + nchk_s(nrpts4QC)= + + int(pqtzuvEV(2,1,1,5)) ! use u-component QM + nchk_d(nrpts4QC)= + + int(pqtzuvEV(2,1,1,5)) ! use u-component QM + + endif ! Check for missings + +c Store wind events in "corral" arrays to carry through this code +c --------------------------------------------------------------- + if(nevents(nrpts4QC,5).gt.0) then + do i = 1,nevents(nrpts4QC,5) + invi = nevents(nrpts4QC,5)-i+1 + +c |---> wind + uob_ev(nrpts4QC,i) = pqtzuvEV(1,1,invi,5) + vob_ev(nrpts4QC,i) = pqtzuvEV(1,1,invi,6) + wqm_ev(nrpts4QC,i) = pqtzuvEV(2,1,invi,5) + wpc_ev(nrpts4QC,i) = pqtzuvEV(3,1,invi,5) + wrc_ev(nrpts4QC,i) = pqtzuvEV(4,1,invi,5) + enddo + endif + +c Store wind background info in "corral" arrays to carry through this code +c ------------------------------------------------------------------------ + call ufbint(inlun,arr_8,15,10,nlev, + + 'WOE UFC VFC UFCMOD VFCMOD') ! only one occurence of bg info per + ! report/level + wbg(nrpts4QC,:) = arr_8(1:5,1) + + call ufbint(inlun,arr_8,15,10,nlev, + + 'UAN VAN UCL VCL UCS VCS') ! only one occurence of post-p info per + ! report/level + wpp(nrpts4QC,:) = arr_8(1:6,1) + +c Pull wind (direction/speed) events +c ---------------------------------- + if(.not.l_allev_pf) then + call ufbint(inlun,df_arr,5,mxlv,nlev, + + 'DDO FFO DFQ DFP DFR') + else + call ufbevn(inlun,df_arr,5,mxlv,mxnmev,nlev, + + 'DDO FFO DFQ DFP DFR') + endif + +c Count the number of wind events (dir/speed) events in this report +c ----------------------------------------------------------------- + if(l_allev_pf) then + ddo_ev(nrpts4QC,:) = df_arr(1,1,:) + ffo_ev(nrpts4QC,:) = df_arr(2,1,:) + dfq_ev(nrpts4QC,:) = df_arr(3,1,:) + dfp_ev(nrpts4QC,:) = df_arr(4,1,:) + dfr_ev(nrpts4QC,:) = df_arr(5,1,:) + evknt = 0 + do j = 1,mxnmev + if(ibfms(df_arr(1,1,j)).ne.0 .or. + + ibfms(df_arr(2,1,j)).ne.0) then + nevents(nrpts4QC,6) = evknt + exit ! exit j do loop + else + evknt = evknt + 1 + endif + enddo + else + ddo_ev(nrpts4QC,1) = df_arr(1,1,1) + ffo_ev(nrpts4QC,1) = df_arr(2,1,1) + dfq_ev(nrpts4QC,1) = df_arr(3,1,1) + dfp_ev(nrpts4QC,1) = df_arr(4,1,1) + dfr_ev(nrpts4QC,1) = df_arr(5,1,1) + nevents(nrpts4QC,6) = 1 + endif + + endif ! Check for mass or wind report + + if(l_match) then ! report just stored was the second half + call readns(inlun,mesgtype,mesgdate,iret) ! Advance pointer to next subset + if(iret.eq.-1) then ! there are no more subsets to read in the PREPBUFR file + print *, 'READNS: NO MORE SUBSETS TO READ IN THE BUFR'// + + ' FILE' + exit + elseif(iret.eq.0) then ! there are still subsets to read; pull the next one + go to 4001 + else + print *, 'Unexpected return code(iret=',iret,') from ', + + 'readns!' + call w3tage('PREPOBS_PREPACQC') + call errexit(23) ! Problems reading BUFR file + endif + endif + +c At this point, we are done reading in subset n - call readns to get subset n+1 - see if it +c is the wind part for subset n - store in same report in local arrays if so - if subset n+1 +c is not the second piece of subset n, pull its header along with the data values and +c events, and store it in its own report +c ------------------------------------------------------------------------------------------- + call readns(inlun,mesgtype,mesgdate,iret) + if(iret.eq.-1) then ! there are no more subsets to read in the PREPBUFR file + print *, 'READNS: NO MORE SUBSETS TO READ IN THE BUFR '// + + 'FILE' + exit + elseif(iret.eq.0) then ! there are still subsets to read; pull the next one + +c Update counters +c --------------- + if(mesgtype.eq.'AIRCFT') then + nrptsaircft = nrptsaircft + 1 + elseif(mesgtype.eq.'AIRCAR') then + nrptsaircar = nrptsaircar + 1 + else ! We're done reading the aircraft-type messages out of this file + print *, '---> MESGTYPE NOT AIRCRAFT TYPE!!!',' "', + + mesgtype,'"' + print *, '---> keep looping through messages in case', + + ' any more are in file' + cycle loop2 + endif + nrpts_rd = nrpts_rd + 1 + +c Pull out the value of SQN for subset n+1, which will wither be a mass piece or a wind piece +c (most likely a wind piece for subset n). +c ------------------------------------------------------------------------------------------- + call ufbint(inlun,arr_8,15,10,nlev,'SQN') + sqn_next = arr_8(1,1) + +c Check and see if the report pulled by readns (subset n+1) is the second part for the report +c pulled by an iteration of do ireadsb (subset n) +c ------------------------------------------------------------------------------------------- + if(sqn_next.eq.sqn_current) then ! subset n+1 is the second part of subset n. + ! alat,alon,ht_ft,c_acftid (or c_acftreg) + ! and idt have already been populated; no + ! need to pull these twice + numpairs = numpairs + 1 + + if(mesgtype.eq.'AIRCFT') then + numAIRCFTpairs = numAIRCFTpairs + 1 + elseif(mesgtype.eq.'AIRCAR') then + numAIRCARpairs = numAIRCARpairs + 1 + endif + + l_match = .true. + + go to 6001 ! SQN will be read again but nrpts4QC won't be incremented - + ! we've just found the 2nd half of the report previously read + else ! subset n+1 is NOT the second part of subset n (n is an orphan) + +c If we get here, we know that subsets n and n+1 are not parts of a pair - subset n is an +c "orphan" and has already been stored - at this point, we don't yet know whether subset +c n+1 is another orphan or whether it is the second half of a match - whether subset n+1 is +c an orphan or part of a pair will be determined on the next iteration of this loop +c +c However, we do know that subset n+1 doesn't belong with subset n because their values of +c SQN are different - so, we need to increment nrpts4QC before storing subset n+1 in the +c report-oriented arrays (do so by sending the program to statement 5001) +c +c Send subset n+1 back through the program, treating subset n+1 as the new n +c ------------------------------------------------------------------------------------------ + numorph = numorph + 1 + + if(mesgtype.eq.'AIRCFT') then + numAIRCFTorph = numAIRCFTorph + 1 + elseif(mesgtype.eq.'AIRCAR') then + numAIRCARorph = numAIRCARorph + 1 + endif + + l_match = .false. + +c Leave BUFRLIB pointers where they are and treat subset n+1 as a new n +c --------------------------------------------------------------------- + go to 5001 + + endif ! check to see if subset n+1 is the second part of subset n + else + print *, 'Unexpected return code(iret=',iret,') from ', + + 'readns!' + call w3tage('PREPOBS_PREPACQC') + call errexit(23) ! Problems reading BUFR file + endif ! if(iret.eq.-1) then + + enddo ! do loop for reading BUFR subsets/reports (ireadsb) + endif ! check for message type + enddo loop2 ! do loop for reading messages + print *, '---> DONE READING FROM THIS FILE!!!' + print *, '---> nrpts_rd = ', nrpts_rd + + if(nrpts_rd.gt.0) then + +c Determine ITYPE, C_DTG, etc. +c ---------------------------- + do i=1,nrpts4QC + +c nevents can never be zero, otherwise array out-of-bounds issues will occur downstream - +c make sure nevents is always at least 1 for all variables and all reports +c --------------------------------------------------------------------------------------- + nevents(i,:) = max(nevents(i,:),1) + +c ******************************************** +c ITYPE --> REMAP FROM NCEP VALUE TO NRL VALUE +c ******************************************** + +c Determine type of aircraft report (itype) +c +c Need to check phase of flight and PREPBUFR report type +c PREPBUFR report types (mnemonic = TYP) where x is either: 1=mass, 2=wind part: +c x30 = NCEP: AIREP (NRL Manual AIREP/voice) +c x30 = NCEP: PIREP (NRL Manual AIREP/voice) +c x31 = NCEP: AMDAR (all types except Canadian) (NRL: AMDAR) +c x33 = NCEP: MDCRS (NRL: MDCRS) +c x34 = NCEP: TAMDAR (NRL: ACARS) +c x35 = NCEP: Canadian AMDAR (NRL: AMDAR) +c +c NCEP BUFR MNEMONIC POAF (phase of flight)/BUFR desc. 0-08-004: +c 0-1 = reserved +c 2 = Unsteady +c 3 = Level flight, routine observation +c 4 = Level flight, highest wind encountered +c 5 = Ascending +c 6 = Descending +c 7 = missing (set to 9 prior to this to match NRL's missing value) +c bmiss = missing (set to 9 prior to this to match NRL's missing value) +c +c ############################################################## +c NRL settings for itype (see function insty_ob_fun): +c --> Use value of POAF to determine whether ob was taken while the aircraft was ascending, +c descending, etc. +c +c Below * means used by NCEP +c +c -------------------------------------------------------------- +c ---> NRL AIREPs +c * 25/'man-airep' = Manual AIREP (header XRXX)/"typical voice AIREP" +c -- NOTE: Assign PIREPs (used at NCEP but not at NRL) to this "typical voice +c AIREP" category +c -- NOTE: Assign all AIREPs (for now) to this "typical voice AIREP" category +c 26/'man-Yairep' = Manual AIREP (header YRXX)/keypad AIREP +c -- NOTE: NCEP does not assign anything to this at the current time +c 30/'airep' = automated "AIREPs" (AMDAR or UAL MDCRS re-encoded as AIREPs by AFWA) +c -- NOTE: NCEP does not assign anything to this at the current time +c AFWA stopped re-encoding AMDAR and MDCRS into AIREP in Oct 2009 +c 131/'airep_asc' = AIREP ascending profile +c -- NOTE: NCEP does not assign anything to this at the current time +c 132/'airep_des' = AIREP descending profile +c -- NOTE: NCEP does not assign anything to this at the current time +c 33/'airep_lvl' = AIREP level flight +c -- NOTE: NCEP does not assign anything to this at the current time +C 34/'airep_msg' = AIREP w/ missing category (if rpt is not 25, 26, or 30) +c -- NOTE: NCEP does not assign anything to this at the current time +c -------------------------------------------------------------- +c ---> NRL AMDARs +c * 35/'amdar' = Automated aircraft data (AMDAR) (POAF cannot be determined) +c *136/'amdar_asc' = AMDAR ascending profile +c *137/'amdar_des' = AMDAR descending profile +c * 38/'amdar_lvl' = AMDAR level flight +c -------------------------------------------------------------- +c ---> NRL ACARS {NOTE: Originally deemed "ACARS" by NRL, but this is currently not used by +c NRL (per email from Pat Pauley 1/12/05); NCEP will use them to provide +c a separate category for TAMDARs and rename them as TAMDAR in all +c printouts from acftobs_qc.f} +c 40/'acars' = Automated aircraft (TAMDAR) (POAF cannot be determined) +c 141/'acars_asc' = TAMDAR ascending profile +c 142/'acars_des' = TAMDAR descending profile +c 43/'acars_lvl' = TAMDAR level flight +c -------------------------------------------------------------- +c ---> NRL MDCRS +c * 45/'mdcrs' = Automated aircraft (MDCRS) (POAF cannot be determined) +c *146/'mdcrs_asc' = MDCRS ascending profile +c *147/'mdcrs_des' = MDCRS descending profile +c * 48/'mdcrs_lvl' = MDCRS level flight +c ############################################################## + + if(itype(i).eq.30) then ! NCEP: AIREP (NRL Manual AIREP/voice) or + ! NCEP: PIREP (NRL Manual AIREP/voice) + phase(i) = 9 ! NRL leaves phase of flight as missing for all + ! AIREP/PIREP types (fine since NCEP does not have + ! phase of flight info for AIREPs or PIREPs) + + if(c_acftid(i)(1:1).eq.'P'.and.c_acftid(i)(6:6).eq.'P') then ! NCEP PIREPs (BUFR + ! tank b004/xx002) + +c SMB: Data type label changed from 34 -> 25 on 5/5/05. PIREPs are probably more along the +c lines of "typical voice reports" than AIREPs with a "missing" category +c DAK: Agreed, if we are still going to use PIREPs lump them into Manual AIREP/voice category + itype(i) = 25 + nPIREP = nPIREP + 1 + + else ! NCEP AIREPs (BUFR tank b004/xx001) +c SMB: Originally set these to 30 (reformatted something else's/"automated AIREPs") +c DAK: Changed these to 25 on 3/23/12 (30 is reserved for AFWA re-encoded AIREPS, orig. AMDAR +c or MDCRS - there are none of these after Oct. 2009 per Eric Wise/AFWA) +c We may want to try to isolate ADS's in N. Atlantic as type 30 (NRL does this) but not +c at this point (right now ADS's go into NCO's airep decoder and come out in b004/xx001 +c tank) +ccccccccc itype(i) = 30 +ccccccccc nAUTOAIREP = nAUTOAIREP + 1 + itype(i) = 25 + nMANAIREP = nMANAIREP + 1 + endif + + elseif(itype(i).eq.31) then ! NCEP: AMDAR (all types except Canadian) (NRL: AMDAR) + ! (BUFR tanks b004/xx003, b004/xx006, b004/xx011, b004/xx103) + nAMDAR = nAMDAR + 1 + if(phase(i).eq.3 .or. phase(i).eq.4) then + itype(i) = 38 ! level flight + elseif(phase(i).eq.5) then + itype(i) = 136 ! ascending flight + elseif(phase(i).eq.6) then + itype(i) = 137 ! descending flight + else + itype(i) = 35 ! unknown phase of flight + endif + + elseif(itype(i).eq.33) then ! NCEP: MDCRS (NRL: MDCRS) (BUFR tank b004/xx004) + nMDCRS = nMDCRS + 1 + if(phase(i).eq.3 .or. phase(i).eq.4) then + itype(i) = 48 ! level flight + elseif(phase(i).eq.5) then + itype(i) = 146 ! ascending flight + elseif(phase(i).eq.6) then + itype(i) = 147 ! descending flight + else + itype(i) = 45 ! unknown phase of flight + endif + + elseif(itype(i).eq.34) then ! NCEP: TAMDAR (NRL: ACARS) + ! (BUFR tanks b004/xx008, b004/xx010, b004/xx012, b004/xx013) +c DAK: Changed these from NRL AMDAR to NRL ACARS at suggestion of P. Pauley (3/2012), (to hold +c NCEP TAMDARs) - allows them to be treated in a separate category for stratifying +c statistics - also seems to flag more AMDARs as bad which is a good thing since there +c are so many anyway + nTAMDAR = nTAMDAR + 1 + ! NOTE: MADIS-feed TAMDARs currently have missing phase of flight and will + ! get set to unknown value initially (may later change) + ! AirDAT/Panasonic BUFR-feed TAMDARs do contain phase of flight) + if(phase(i).eq.3 .or. phase(i).eq.4) then +ccccccccccc itype(i) = 38 ! level flight + itype(i) = 43 ! level flight + elseif(phase(i).eq.5) then +ccccccccccc itype(i) = 136 ! ascending flight + itype(i) = 141 ! ascending flight + elseif(phase(i).eq.6) then +ccccccccccc itype(i) = 137 ! descending flight + itype(i) = 142 ! descending flight + else +ccccccccccc itype(i) = 35 ! unknown phase of flight + itype(i) = 40 ! unknown phase of flight + endif + + elseif(itype(i).eq.35) then ! Canadian AMDAR (NRL: AMDAR) (BUFR tank b004/xx009) + nAMDARcan = nAMDARcan + 1 + if(phase(i).eq.3 .or. phase(i).eq.4) then + itype(i) = 38 ! level flight + elseif(phase(i).eq.5) then + itype(i) = 136 ! ascending flight + elseif(phase(i).eq.6) then + itype(i) = 137 ! descending flight + else + itype(i) = 35 ! unknown phase of flight + endif + + else + print'(" Unexpected value for PREPBUFR report type! (itype=", + + I0," & should be 30, 31, 33, 34, or 35)")', itype(i) + print *, 'i=',i + + endif + +c ***** +c C_DTG +c ***** + +c Convert idt to YYYYMMDDHHMMSS format +c ------------------------------------ + read(cdtg_an(1:4),'(i4.4)') year + read(cdtg_an(5:6),'(i2.2)') month + read(cdtg_an(7:8),'(i2.2)') day + read(cdtg_an(9:10),'(i2.2)') hour + +c Time increment (offset from cycle time) +c --------------------------------------- + rinc(1) = 0. ! days + rinc(2) = 0. ! hours + rinc(3) = 0. ! mins + rinc(4) = idt(i) ! seconds + rinc(5) = 0. ! milliseconds + +c Date/time for cycle time +c ------------------------ + idat(1) = year + idat(2) = month + idat(3) = day + idat(4) = 0 ! time zone + idat(5) = hour + idat(6) = 0 ! mins + idat(7) = 0 ! secs + idat(8) = 0 ! millisecs + +c Use W3NCO routine w3movdat to get date/time of actual observation +c ----------------------------------------------------------------- + call w3movdat(rinc,idat,jdat) + +c Convert jdat values to date/time string in yyyymmddhhmmss format +c ----------------------------------------------------------------- + write(c_dtg(i)(1:4),'(i4.4)') jdat(1) + write(c_dtg(i)(5:6),'(i2.2)') jdat(2) + write(c_dtg(i)(7:8),'(i2.2)') jdat(3) + write(c_dtg(i)(9:10),'(i2.2)') jdat(5) + write(c_dtg(i)(11:12),'(i2.2)') jdat(6) + write(c_dtg(i)(13:14),'(i2.2)') jdat(7) + +c **************************************** +c TRANSLATE NCEP QC FLAGS TO NRL STANDARDS +c (Store in arrays ichk_[t,q,d,s]) +c **************************************** + +c QM type: NCEP values: NRL values: +c nchk_* ichk_*h +c Not checked/neutral 2 0 +c Good 1 -1 +c Suspect 3 -2 +c Bad 4-15 -3 +c Initial/missing value -9 -9 +c --------------------------------------------------- + qms(1) = nchk_t(i) + qms(2) = nchk_q(i) + qms(3) = nchk_d(i) + qms(4) = nchk_s(i) + +c DAK: this could be coded up more efficiently! + do J=1,4 + if(qms(j).eq.2) then + qms(j) = 0 + elseif(qms(j).eq.1) then + qms(j) = -1 + elseif(qms(j).eq.3) then + qms(j) = -2 + elseif(qms(j).ge.4 .and. qms(j).le.15) then + qms(j) = -3 + +cc smb 8/19/05 +c For now, let qms(j)/ichk_q = 0 for non-missing q - this is to bypass ichk_q checks in +c grchek_qc +c ------------------------------------------------------------------------------------- + if(ob_q(i).ne.amiss) then + qms(j) = 0 + endif + + elseif(qms(j).eq.-9) then ! leave it as is + qms(j) = -9 + else ! Store QM = NRL's missing value + qms(j) = -9 + print'(" Unexpected value of NCEP j=",I0,"/",A," QM (",I0, + + ") for report number",I0,"!")',j,QM_types(j),qms(j),i + endif + +c If ob is missing, then store NRL quality mark as -9 +c --------------------------------------------------- +c DAK: this could be coded up more efficiently! + if(j.eq.1 .and. ob_t(i).eq.amiss) then + qms(j) = -9 + elseif(j.eq.2 .and. ob_q(i).eq.amiss) then + qms(j) = -9 + elseif(j.eq.3 .and. ob_dir(i).eq.amiss) then + qms(j) = -9 + elseif(j.eq.4 .and. ob_spd(i).eq.amiss) then + qms(j) = -9 + endif + +c Store altered quality marks into NRL QM arrays +c ---------------------------------------------- +c DAK: this could be coded up more efficiently! + if(j.eq.1) then + ichk_t(i) = qms(j) + elseif(j.eq.2) then + ichk_q(i) = qms(j) + elseif(j.eq.3) then + ichk_d(i) = qms(j) + elseif(j.eq.4) then + ichk_s(i) = qms(j) + endif + + enddo ! over j + enddo ! over i + endif ! nrpts_rd.gt.0 + +c Output counts +c ------------- + write(*,*) 'NUMBER OF "AIRCFT" RPTS: ',nrptsaircft + write(*,*) ' --> MASS: ', nmswd(1,1) + write(*,*) ' --> WIND: ', nmswd(1,2) + write(*,*) 'NUMBER OF "AIRCAR" RPTS: ',nrptsaircar + write(*,*) ' --> MASS: ', nmswd(2,1) + write(*,*) ' --> WIND: ', nmswd(2,2) + write(*,*) 'TOTAL NUMBER OF MASS AND WIND REPORTS READ: ', + + nrpts_rd + write(*,*) 'TOTAL NUMBER OF PAIRS (merged mass+wind): ',numpairs + write(*,*) 'TOTAL NUMBER OF ORPHANS (only mass or only wind ', + + 'present): ', numorph + write(*,*) 'NUMBER OF "AIRCFT" PAIRS/ORPHANS: ', numAIRCFTpairs, + + '/', numAIRCFTorph + write(*,*) 'NUMBER OF "AIRCAR" PAIRS/ORPHANS: ', numAIRCARpairs, + + '/', numAIRCARorph + + + write(*,*) + write(*,*) 'TOTAL NUMBER OF REPORTS FOR QC CODE: ', nrpts4QC + + write(*,*) + write(*,*) 'NUMBER OF PIREPS (MANUAL AIREP/voice): ',nPIREP + write(*,*) 'NUMBER OF AUTO AIREPS: ',nAUTOAIREP + write(*,*) 'NUMBER OF AIREPS (MANUAL AIREPS/voice): ',nMANAIREP + write(*,*) 'NUMBER OF AMDAR (excl. Canadian): ',nAMDAR + write(*,*) 'NUMBER OF CANADIAN AMDAR: ',nAMDARcan + write(*,*) 'NUMBER OF MDCRS: ',nMDCRS + write(*,*) 'NUMBER OF TAMDAR: ',nTAMDAR + +c End program +c ----------- + + if(nrpts4QC/.90.gt.max_reps .and. nrpts4QC.lt.max_reps ) then + +c If the total number of merged (mass + wind piece) aircraft-type reports read in from +c PREPBUFR file is at least 90% of the maximum allowed ("max_reps"), print diagnostic +c warning message to production joblog file +c ------------------------------------------------------------------------------------ + + print 153, nrpts4QC,max_reps + 153 format(/' #####> WARNING: THE ',I6,' AIRCRAFT RPTS IN INPUT ', + + 'FILE ARE > 90% OF UPPER LIMIT OF ',I6,' -- INCREASE SIZE OF ', + + '"MAX_REPS" SOON!'/) + write(cmax_reps,'(i6)') max_reps +! call system('[ -n "$jlogfile" ] && $DATA/postmsg "$jlogfile" '// +! + '"***WARNING: HIT 90% OF '//cmax_reps//' AIRCRAFT REPORT '// +! + 'LIMIT IN PREPOBS_PREPACQC, INCREASE SIZE OF PARM MAX_REPS"') + endif + + write(*,*) + write(*,*) '********************' + write(*,*) 'input_acqc has ended' + call system('date') + write(*,*) '--> # reports = ',nrpts4QC + write(*,*) '********************' + write(*,*) + + return + + end + diff --git a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/output_acqc_noprof.f b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/output_acqc_noprof.f new file mode 100644 index 00000000..06d18bf0 --- /dev/null +++ b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/output_acqc_noprof.f @@ -0,0 +1,1581 @@ +c$$$ Subprogram Documentation Block +c BEST VIEWED WITH 94-CHARACTER WIDTH WINDOW +c +c Subprogram: output_acqc_noprof +c Programmer: D. Keyser Org: NP22 Date: 2015-12-09 +c +c Abstract: Reads an input, pre-PREPACQC PREPBUFR file and matches the subsets within to the +c "merged" reports contained within the arrays output by the NRL aircraft QC subroutine +c acftobs_qc. Calls subroutine tranQCflags to translate the QC information (for each +c variable: pressure, altitude, temperature and moisture for the mass piece; and pressure, +c altitude and wind for the wind piece) from NRL standards (c_qc array) to their NCEP +c counterparts and to establish event reason codes for each variable. All of this QC +c information is then encoded as event stacks in the output PREPBUFR file which will be +c identical to the input PREPBUFR file except for the new events added by this program and +c aircraft reports that are removed (possibly) for being outside the requested time window +c or geographical domain). +c +c Program History Log: +c 2010-11-15 S. Bender -- Original Author +c 2012-05-08 D. Keyser -- Prepared for operational implementation +c 2012-11-20 J. Woollen -- Initial port to WCOSS +c 2013-02-07 D. Keyser -- If the maximum number of merged reports that can be processed +c ("max_reps") is exceeded when updating reports in PREPBUFR file +c with QC changes, program will no longer stop with r.c. 31, as +c though there is an indexing error, instead all original reports +c above "max_reps" will be written out without any QC and a message +c will be printed to stdout (a diagnostic will have already been +c sent to the production joblog file in this case when reports were +c first read in by subroutine INPUT_ACQC) +c 2013-02-07 D. Keyser -- Final changes to run on WCOSS: use formatted print statements +c where previously unformatted print was > 80 characters +c 2014-03-06 D. Keyser -- Moved BUFRLIB routine OPENMB call to after time window and +c geographic domain checks to prevent creation of an empty, but +c open, BUFR message (type AIRCAR) in (rare) cases where absolutely +c no aircraft reports pass these checks (would cause a BUFRLIB +c abort due to previous message being open when attempting to copy +c first non-aircraft message from input to output PREPBUFR file +c 2013-10-07 Sienkiewicz -- Initialize some uninitialized variables for 'gfortran' compile +c 2015-03-16 D. Keyser -- Fixed a bug which, for cases where the maximum number of merged +c reports that can be processed ("max_reps") is exceeded, prevented +c any original reports above "max_reps" from being written out +c (without any QC). +c 2015-12-09 D. Keyser -- +c - Variables holding latitude and longitude data (including input +c arguments "alat" and "alon") now double precision. XOB and YOB in +c PREPBUFR file now scaled to 10**5 (was 10**2) to handle new v7 AMDAR +c and MDCRS reports which have this higher precision. +c BENEFIT: Retains exact precison here. Improves QC processing. +c - The format for all print statements containing latitude and longitude +c changed to print to 5 decimal places. +c +c Usage: call output_acqc_noprof(inlun,outlun,nrpts4QC_pre,max_reps, +c bmiss,alat,alon,ht_ft,idt,c_qc, +c trad,l_otw,l_nhonly, +c ncep_qm_p,ncep_rc_p, +c ncep_qm_z,ncep_rc_z, +c ncep_qm_t,ncep_rc_t, +c ncep_qm_q,ncep_rc_q, +c ncep_qm_w,ncep_rc_w, +c ncep_rej, +c nrlacqc_pc) +c +c Input argument list: +c inlun - Unit number for the input pre-PREPACQC PREPBUFR file containing all data +c (separate mass/wind pieces) +c outlun - Unit number for the output PREPBUFR file containing all data plus now +c with NRLACQC events (separate mass/wind pieces) +c nrpts4QC_pre - Number of reports in the "merged" single-level aircraft report arrays +c max_reps - Maximum number of reports accepted by acftobs_qc +c bmiss - BUFRLIB missing value (set in main program) +c alat - Array of latitudes for the "merged" reports +c alon - Array of longitudes for the "merged" reports +c ht_ft - Array of altitudes for the "merged" reports +c idt - Array of ob-cycle times for the "merged" reports (in seconds) +c c_qc - Array of NRLACQC quality information (11 char. string) ("merged" reports) +c trad - Time window radius for outputting reports (if l_otw=T) (read in via +c namelist) +c l_otw - Logical whether or not to eliminate reports outside the time window +c radius (trad) (read in via namelist) +c l_nhonly - Logical Whether or not to eliminate reports south of 20S latitude (i.e, +c outside the tropics and N. Hemisphere) (read in via namelist) +c nrlacqc_pc - PREPBUFR program code for the NRLACQC step +c +c Output argument list: +c ncep_qm_p - Array of NCEP PREPBUFR quality marks on pressure for the "merged" reports +c ncep_rc_p - Array of NCEP PREPBUFR reason codes on pressure for the "merged" reports +c ncep_qm_z - Array of NCEP PREPBUFR quality marks on altitude for the "merged" rpts +c ncep_rc_z - Array of NCEP PREPBUFR reason codes on altitude for the "merged" rpts +c ncep_qm_t - Array of NCEP PREPBUFR quality marks on temperature for the "merged" rpts +c ncep_rc_t - Array of NCEP PREPBUFR reason codes on temperature for the "merged" rpts +c ncep_qm_q - Array of NCEP PREPBUFR quality marks on moisture for the "merged" reports +c ncep_rc_q - Array of NCEP PREPBUFR reason codes on moisture for the "merged" reports +c ncep_qm_w - Array of NCEP PREPBUFR quality marks on wind for the "merged" reports +c ncep_rc_w - Array of NCEP PREPBUFR reason codes on wind for the "merged" reports +c ncep_rej - Array indicating if "merged" report is (=0) or is not (=1) to be written +c to output PREPBUFR file +c Input files: +c Unit inlun - PREPBUFR file containing all obs, prior to any processing by this program +c +c Output files: +c Unit 06 - Standard output print +c Unit outlun - PREPBUFR file identical to input except containing NRLACQC events +c +c Subprograms called: +c Unique: TRANQCFLAGS +c Library: +c SYSTEM: SYSTEM +c W3NCO: ERREXIT W3TAGE +c BUFRLIB: IREADMG COPYMG OPENMB IREADSB UFBINT UFBCPY WRITSB +c WRITLC CLOSMG IBFMS +c +c Exit States: +c Cond = 0 - successful run +c 31 - indexing problem encountered when trying to match QC'd data in arrays to +c mass and wind pieces in original PREPBUFR file +c +c Remarks: Called by main program. +c +c Attributes: +c Language: FORTRAN 90 +c Machine: NCEP WCOSS +c +c$$$ + subroutine output_acqc_noprof(inlun,outlun,nrpts4QC_pre,max_reps, + + bmiss,alat,alon,ht_ft,idt,c_qc, + + trad,l_otw,l_nhonly,l_qmwrite, + + ncep_qm_p,ncep_rc_p, + + ncep_qm_z,ncep_rc_z, + + ncep_qm_t,ncep_rc_t, + + ncep_qm_q,ncep_rc_q, + + ncep_qm_w,ncep_rc_w, + + ncep_rej, + + nrlacqc_pc) + + implicit none + +c ------------------------------ +c Parameter statements/constants +c ------------------------------ + integer inlun ! input unit number for pre-PREPACQC PREPBUFR file to + ! which we are adding NRLACQC events + +, outlun ! output unit number for post-PREPACQC PREPBUFR file + ! with added NRLACQC events + +, max_reps ! maximum number of input merged (mass + wind piece) + ! aircraft-type reports allowed + real m2ft + parameter (m2ft = 3.28084) ! conversion factor to convert m to ft +cvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv +c replace above with this in event of future switch to dynamic memory allocation + +calloc integer max_reps ! original number of input reports obtained from +calloc ! first pass through to get total for array allocation +c^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + real*8 bmiss ! BUFRLIB missing value (set in main program) + + +c ---------------------- +c Declaration statements +c ---------------------- + +c Variables for BUFRLIB interface +c ------------------------------- + character*8 mesgtype ! BUFR message type (e.g., 'AIRCFT ') + integer mesgdate ! date time from BUFR message (YYYYMMDDHH) + +c Indices/counters +c ---------------- + integer i,j ! loop indices + + integer nrpts4QC_pre ! original number of input merged (mass + wind piece) + ! aircraft-type reports (read in from PREPBUFR file) + +c Functions +c --------- + integer ireadmg ! BUFRLIB - for reading messages + +, ireadsb ! BUFRLIB - for reading subsets + +, ibfms ! BUFRLIB - for testing for missing + + character*11 c_qc(max_reps) ! character QC flags output from NRL QC code + ! 1st char - info about reject (if ob was rejected) + ! 2nd char - reason why time was rejected + ! 3rd char - reason why latitude was rejected + ! 4th char - reason why longitude was rejected + ! 5th char - reason why pressure/atitude was rejected + ! 6th char - readon why temperature was rejected + ! 7th char - reason why wind direction was rejected + ! 8th char - reason why wind speed was rejected + ! 9th char - reason why mixing ratio was rejected + ! 10th char - reason for blacklisting the aircraft + ! 11th char - info about flight phase + + real*8 alat(max_reps) ! latitude + +, alon(max_reps) ! longitude + real ht_ft(max_reps) ! altitude in feet + integer idt(max_reps) ! time in seconds to anal. time (- before, + after) + integer ncep_qm_p(max_reps) ! NCEP PREPBUFR quality mark pressure (PQM) + +, ncep_rc_p(max_reps) ! NCEP PREPBUFR NRLACQC pressure event reason code(PRC) + +, ncep_qm_z(max_reps) ! NCEP PREPBUFR quality mark on altitude (ZQM) + +, ncep_rc_z(max_reps) ! NCEP PREPBUFR NRLACQC alt/hght event reason code(ZRC) + +, ncep_qm_t(max_reps) ! NCEP PREPBUFR quality mark on temperature (TQM) + +, ncep_rc_t(max_reps) ! NCEP PREPBUFR NRLACQC temperature evnt rea. code(TRC) + +, ncep_qm_q(max_reps) ! NCEP PREPBUFR quality mark on moisture (QQM) + +, ncep_rc_q(max_reps) ! NCEP PREPBUFR NRLACQC moisture reason code (QRC) + +, ncep_qm_w(max_reps) ! NCEP PREPBUFR quality mark on wind (WQM) + +, ncep_rc_w(max_reps) ! NCEP PREPBUFR NRLACQC wind event reason code (WRC) + +, ncep_rej(max_reps) ! NCEP PREPBUFR rejection indicator + +c Variables for reading (writing) numeric data out of (in to) BUFR files via BUFRLIB +c ---------------------------------------------------------------------------------- + real*8 arr_8(10,10) ! array holding BUFR subset values from BUFRLIB call to + ! input PREPBUFR file + +, dhr_corr(2) ! array holding rehabilitated time (DHR TCOR) + +, yob_corr(3) ! array holding rehabilitated latitude (YOB YCOR YORG) + +, xob_corr(3) ! array holding rehabilitated longitude (XOB XCOR XORG) + + integer nlev ! number of report levels returned from BUFRLIB call + ! (should always be 1 !) + integer iret ! return code for call to BUFRLIB routine ufbint when + ! writing to PREPBUFR file + +c Variables for updating input PREPBUFR reports with QC results/events from NRLACQC +c --------------------------------------------------------------------------------- + integer ninssrd ! number of subsets read in from the input PREPBUFR file + +, QCdrptsidx ! index for report-oriented arrays that are output from + ! acftobs_qc + + real*8 p_event(4) ! array used to update a pressure event stack + +, z_event(4) ! array used to update an altitude event stack + +, t_event(4) ! array used to update a temperature event stack + +, q_event(4) ! array used to update a moisture event stack + +, w_event(5) ! array used to update a wind event stack + + logical l_eventupdate ! T = event was added for the last PREPBUFR report read + ! F = no events were added to the last PREPBUFR rpt read + + integer input_sqn ! sequence number of input PREPBUFR report for which we + ! are attempting to add events + +, input_sqn_last ! sequence number of previous PREPBUFR report for which + ! we had attempted to add events + real*8 input_alat ! latitude of input PREPBUFR report for which we are + ! attempting to add events + +, input_alon ! longitude of input PREPBUFR report for which we are + ! attempting to add events + real input_ht_ft ! altitude of input PREPBUFR report for which we are + ! attempting to add events + +, input_dhr ! ob time - cycle time in decimal hours + + integer input_idt ! ob time - cycle time in seconds of input PREPBUFR + ! report for which we are attempting to add events + +, input_typ ! PREPBUFR report type for input report for which we are + ! attempting to add events + logical l_badrpt_p ! T = pressure/altitude is bad per NRLACQC info (c_qc) + +, l_badrpt_z ! T = pressure/altitude is bad per NRLACQC info (c_qc) + +, l_badrpt_t ! T = temperature is bad per NRLACQC info (c_qc) + +, l_badrpt_q ! T = moisture is bad per NRLACQC info (c_qc) + +, l_badrpt_w ! T = wind is bad per NRLACQC info (c_qc) + + logical l_duprpt ! T = report is marked as a duplicate per NRLACQC info + ! (c_qc(1:1)=D/d) + + integer ipqm_topstk ! event PQM at top of stack before adding any events + ! containing info from NRLACQC + +, izqm_topstk ! event ZQM at top of stack before adding any events + ! containing info from NRLACQC + +, itqm_topstk ! event TQM at top of stack before adding any events + ! containing info from NRLACQC + +, iqqm_topstk ! event QQM at top of stack before adding any events + ! containing info from NRLACQC + +, iwqm_topstk ! event WQM at top of stack before adding any events + ! containing info from NRLACQC + + integer ipqm_nrlacqc ! value for pressure q.m. (PQM) returned from tranQCflags + +, iprc_nrlacqc ! value for pressure r.c. (PRC) returned from tranQCflags + +, izqm_nrlacqc ! value for altitude q.m. (ZQM) returned from tranQCflags + +, izrc_nrlacqc ! value for altitude r.c. (ZRC) returned from tranQCflags + +, itqm_nrlacqc ! value for temperature q.m. (TQM) returned from tranQCflags + +, itrc_nrlacqc ! value for temperature r.c. (TRC) returned from tranQCflags + +, iqqm_nrlacqc ! value for moisture q.m. (QQM) returned from tranQCflags + +, iqrc_nrlacqc ! value for moisture r.c. (QRC) returned from tranQCflags + +, iwqm_nrlacqc ! value for wind q.m. (WQM) returned from tranQCflags + +, iwrc_nrlacqc ! value for wind r.c. (WRC) returned from tranQCflags + +c Event counters +c -------------- + integer nevrd(5) + integer nevwrt(5) ! number of [p,z,t,q,w] events written to output PREPBUFR + ! file + integer nev_noupd(5) ! number of subsets from input PREPBUFR file with no + ! updated [p,z,t,q,w] event + integer qm_knt(5,0:15,0:15) ! count of [p,z,t,q,w] NCEP quality marks changed from i + ! (input PREPBUFR value) to j (output PREPBUFR value) + ! by NRLACQC + integer p_qm_knt_tot ! total number of pressure QMs (and therefore events) + ! added to the output PREPBUFR file + +, z_qm_knt_tot ! total number of altitude QMs (and therefore events) + ! added to the output PREPBUFR file + +, t_qm_knt_tot ! total number of temperature QMs (and therefore events) + ! added to the output PREPBUFR file + +, q_qm_knt_tot ! total number of moisture QMs (and therefore events) + ! added to the output PREPBUFR file + +, w_qm_knt_tot ! total number of wind QMs (and therefore events) + ! added to the output PREPBUFR file + + integer npqm_msg_in ! number of PQM that are missing in input PREPBUFR file + +, npqm_msg_out ! number of PQM that are missing in output PREPBUFR file + +, nzqm_msg_in ! number of ZQM that are missing in input PREPBUFR file + +, nzqm_msg_out ! number of ZQM that are missing in output PREPBUFR file + +, ntqm_msg_in ! number of TQM that are missing in input PREPBUFR file + +, ntqm_msg_out ! number of TQM that are missing in output PREPBUFR file + +, nqqm_msg_in ! number of QQM that are missing in input PREPBUFR file + +, nqqm_msg_out ! number of QQM that are missing in output PREPBUFR file + +, nwqm_msg_in ! number of WQM that are missing in input PREPBUFR file + +, nwqm_msg_out ! number of WQM that are missing in output PREPBUFR file + +c Switches controlling processing (read in from namelist in main program) +c ----------------------------------------------------------------------- + real trad ! Time window radius for outputting reports (if l_otw=T) + logical l_otw ! T=eliminate reports outside cycle time window radius (trad) + +, l_nhonly ! T=filter out obs outside tropics and Northern Hemisphere + +, l_qmwrite ! T=write NRL quality marks F=skip it (use with old BUFR formats) + +c Counters + integer elim_knt(2,3) ! Count of input PREPBUFR reports (subsets) eliminated from + ! write to output PREPBUFR file, and those kept for write to + ! output PREPBUFR file - + ! first index, message type: 1 - AIRCFT, 2 - AIRCAR + ! second index: + ! 1 - # of reports (subsets) eliminated due to being + ! outside time window radius (prior to any + ! geographical domain checking) + ! 2 - # of reports (subsets) eliminated due to being + ! outside geographical domain (had passed time window + ! radius check) + ! 3 - # of reports (subsets) passing both time window + ! radius and geographical domain checks and thus + ! retained for processing into output PREPBUFR file + + +c Variables to add NRLACQC quality marks to reports +c ------------------------------------------------- + character*11 c_nrlqm ! variable used to store NRLACQC quality marks + ! in output PREPBUFR file + +c MISC +c ---- + real nrlacqc_pc ! PREPBUFR program code for the NRLACQC step + + logical l_skip ! If true, skip block of code, otherwise exectute block of code + logical l_hit_limit! If true, hit limit for number of reports that can be QC'd + + integer i_hit_limit_first ! flag indicating whether l_hit_limit has occurred prior + ! to this point (if yes, = 1; if no, = 0) + +c ******************************************************************* + +c Initialize variables +c -------------------- + nevwrt = 0 + ninssrd = 0 + ncep_qm_p = 9999 + ncep_rc_p = 9999 + ncep_qm_z = 9999 + ncep_rc_z = 9999 + ncep_qm_t = 9999 + ncep_rc_t = 9999 + ncep_qm_q = 9999 + ncep_rc_q = 9999 + ncep_qm_w = 9999 + ncep_rc_w = 9999 + ncep_rej = 0 + elim_knt = 0 + + i_hit_limit_first = 0 + + npqm_msg_in = 0 + npqm_msg_out = 0 + nzqm_msg_in = 0 + nzqm_msg_out = 0 + ntqm_msg_in = 0 + ntqm_msg_out = 0 + nqqm_msg_in = 0 + nqqm_msg_out = 0 + nwqm_msg_in = 0 + nwqm_msg_out = 0 + + p_qm_knt_tot = 0 + z_qm_knt_tot = 0 + t_qm_knt_tot = 0 + q_qm_knt_tot = 0 + w_qm_knt_tot = 0 + + nevrd = 0 + nev_noupd = 0 + qm_knt = 0 + +c Start subroutine +c ---------------- + write(*,*) + write(*,*) '******************************' + write(*,*) 'Welcome to output_acqc_noprof.' + call system('date') + write(*,*) '******************************' + write(*,*) + +c ---------------------------------------------------------------------- +c Translate NRLACQC flags to NCEP events and add events to PREPBUFR file +c ---------------------------------------------------------------------- + l_eventupdate = .false. + + print * + print *, 'Input/Output PREPBUFR files are open.' + print * + print *, 'Reading input PREPBUFR file...' + print *, 'Applying NRLACQC events to reports...' + + QCdrptsidx = 0 ! starting point for QC'd data arrays' index + input_sqn_last = -99 ! initial value for last report's sequence number (ensures no + ! match for first report read in) + + l_hit_limit = .false. + + do while(ireadmg(inlun,mesgtype,mesgdate).eq.0) + + if(mesgtype.ne.'AIRCFT'.and.mesgtype.ne.'AIRCAR') then + if(l_eventupdate) then ! need to close leftover AIRCAR or AIRCFT message originally + ! opened by openmb before copymg can copy over an entire + ! message from input to output + call closmg(outlun) + l_eventupdate = .false. + endif + + call copymg(inlun,outlun) ! for non-aircraft BUFR messages, just copy to output + else + do while(ireadsb(inlun).eq.0) + +c Initialize variables +c -------------------- + ipqm_topstk = 9999 + izqm_topstk = 9999 + itqm_topstk = 9999 + iqqm_topstk = 9999 + iwqm_topstk = 9999 + + ninssrd = ninssrd + 1 ! number of input subsets read + +c Unpack lat/lon, altitude, ob time, report type and sequence number - will be used to make +c sure PREPBUFR and QC'd obs are lining up OK +c ----------------------------------------------------------------------------------------- + call ufbint(inlun,arr_8,10,10,nlev, + + 'YOB XOB ELV DHR TYP SQN SID') + + input_alat = arr_8(1,1) + input_alon = arr_8(2,1) + input_ht_ft = nint(arr_8(3,1)*m2ft) + input_dhr = arr_8(4,1) + input_idt = nint(arr_8(4,1)*3600.) + input_typ = nint(arr_8(5,1)) + input_sqn = nint(arr_8(6,1)) + if(input_sqn.ne.input_sqn_last) then + +c This input report's sequence number is different that that for the previous report read in +c - we are at the next report in the QC'd data arrays so increment index QCdrptsidx by 1 + QCdrptsidx = QCdrptsidx + 1 +ccccc if(QCdrptsidx.eq.47955) print *,'WE ARE AT ',QCdrptsidx,'!' + + if(QCdrptsidx.gt.nrpts4QC_pre) then + +c .... the number of merged mass + wind reports read in from the input (non-QC'd) PREPBUFR +c file exceeds the number of reports QC'd in acftobs_qc - likely due to there being more +c than "max_reps" merged aircraft reports in the input PREPBUFR file -- in this case no +c more input PREPBUFR aircraft reports can be QC'd - all remaining reports in input +c PREPBUFR file will be copied to output PREPBUFR file but they will not be QC'd + if(i_hit_limit_first.eq.0) then + print * + print *, '#####VVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVV' + print *, 'WARNING: QD''d data array index exceeds ', + + 'the limit of ', nrpts4QC_pre,' - no more reports ', + + 'can be QC''d' + print *, '#####^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^' + print * + endif + i_hit_limit_first = 1 + l_hit_limit = .true. + go to 3400 + endif + + if(QCdrptsidx.gt.1) then + if(c_qc(QCdrptsidx-1)(2:2).eq.'R'.or. ! time rehabilitated + + c_qc(QCdrptsidx-1)(3:3).eq.'R'.or. ! latitude rehabilitated + + c_qc(QCdrptsidx-1)(4:4).eq.'R'.or. ! longitude rehabilitated + + c_qc(QCdrptsidx-1)(5:5).eq.'R'.or. ! pressure/altitude rehabilitated + + c_qc(QCdrptsidx-1)(6:6).eq.'R'.or. ! temperature rehabilitated + + c_qc(QCdrptsidx-1)(5:5).eq.'r') print 65 ! pressure/altitude rehabilitated + 65 format(131('^')) ! print ^^^ at end of report + endif + if(c_qc(QCdrptsidx)(2:2).eq.'R'.or. ! time rehabilitated + + c_qc(QCdrptsidx)(3:3).eq.'R'.or. ! latitude rehabilitated + + c_qc(QCdrptsidx)(4:4).eq.'R'.or. ! longitude rehabilitated + + c_qc(QCdrptsidx)(5:5).eq.'R'.or. ! pressure/altitude rehabilitated + + c_qc(QCdrptsidx)(6:6).eq.'R'.or. ! temperature rehabilitated + + c_qc(QCdrptsidx)(5:5).eq.'r') then ! pressure/altitude rehabilitated + print 61 ! print ^^^ at beginning of report + 61 format(131('v')) + if(c_qc(QCdrptsidx)(2:2).eq.'R') then + +c Case where time was rehabiltated by NRLACQC, make note of it +c ------------------------------------------------------------ + print 62, QCdrptsidx,arr_8(7,1),input_alat, + + input_alon,input_dhr,nint(arr_8(3,1)), + + c_qc(QCdrptsidx) + 62 format(' TIME rehabilitated: input rpt # ',i6,': id ',A8, + + ', lat ',f9.5,', lon ',f9.5,', dhr ',f10.5,', hght(m)',i6, + + ', NRLQMS "',A11,'"') + print 63, input_dhr,input_idt + 63 format(' INPUT time from PRE-QC PREPBUFR file [DHR,idt(sec)] ', + + 'is: ',f10.5,i8) + print 64, idt(QCdrptsidx)/3600.,idt(QCdrptsidx) + 64 format(' REHABILITATED time from acftobs_qc [DHR,idt(sec)] ', + + 'is: ',f10.5,i8) + endif + if(c_qc(QCdrptsidx)(3:3).eq.'R') then + +c Case where latitude was rehabiltated by NRLACQC, make note of it +c ---------------------------------------------------------------- + print 72, QCdrptsidx,arr_8(7,1),input_alat, + + input_alon,input_dhr,nint(arr_8(3,1)), + + c_qc(QCdrptsidx) + 72 format(' LAT rehabilitated: input rpt # ',i6,': id ',A8, + + ', lat ',f9.5,', lon ',f9.5,', dhr ',f10.5,', hght(m)',i6, + + ', NRLQMS "',A11,'"') + print 73, input_alat + 73 format(' INPUT latitude from PRE-QC PREPBUFR file (YOB) is: ', + + f9.5) + print 74, alat(QCdrptsidx) + 74 format(' REHABILITATED latitude from acftobs_qc (YOB) is: ', + + f9.5) + endif + if(c_qc(QCdrptsidx)(4:4).eq.'R') then + +c Case where longitude was rehabiltated by NRLACQC, make note of it +c ----------------------------------------------------------------- + print 82, QCdrptsidx,arr_8(7,1),input_alat, + + input_alon,input_dhr,nint(arr_8(3,1)), + + c_qc(QCdrptsidx) + 82 format(' LON rehabilitated: input rpt # ',i6,': id ',A8, + + ', lat ',f9.5,', lon ',f9.5,', dhr ',f10.5,', hght(m)',i6, + + ', NRLQMS "',A11,'"') + print 83, input_alon + 83 format(' INPUT longitude from PRE-QC PREPBUFR file (XOB) is: ', + + f9.5) + print 84, alon(QCdrptsidx) + 84 format(' REHABILITATED longitude from acftobs_qc (XOB) is: ', + + f9.5) + endif + if(c_qc(QCdrptsidx)(5:5).eq.'R'.or. + + c_qc(QCdrptsidx)(5:5).eq.'r') then + +c Case where pressure/altitude was rehabiltated by NRLACQC, make note of it +c ------------------------------------------------------------------------- + print 92, QCdrptsidx,arr_8(7,1),input_alat, + + input_alon,input_dhr,nint(arr_8(3,1)), + + c_qc(QCdrptsidx) + 92 format(' P/A rehabilitated: input rpt # ',i6,': id ',A8, + + ', lat ',f9.5,', lon ',f9.5,', dhr ',f10.5,', hght(m)',i6, + + ', NRLQMS "',A11,'"') + print 93 + 93 format(' %%%%%%%%%%'/' %%%%% WARNING: Currently not accounted ', + + 'for in output PREPBUFR file'/' %%%%%%%%%%') + endif + if(c_qc(QCdrptsidx)(6:6).eq.'R') then + +c Case where temperature was rehabiltated by NRLACQC, make note of it +c ------------------------------------------------------------------- + print 102, QCdrptsidx,arr_8(7,1),input_alat, + + input_alon,input_dhr,nint(arr_8(3,1)), + + c_qc(QCdrptsidx) + 102 format(' TMP rehabilitated: input rpt # ',i6,': id ',A8, + + ', lat ',f9.5,', lon ',f9.5,', dhr ',f10.5,', hght(m)',i6, + + ', NRLQMS "',A11,'"') + print 93 + endif + endif ! if any rehabilitated + endif ! if(input_sqn.ne.input_sqn_last) + + dhr_corr = bmiss + yob_corr = bmiss + xob_corr = bmiss + if(c_qc(QCdrptsidx)(2:2).eq.'R') then ! Rehabilitated time + dhr_corr(1) = idt(QCdrptsidx)/3600. ! Store updated d-time (DHR) + dhr_corr(2) = 3 ! Set correction indicator (TCOR) to 3 + ! Original time already stored in RPT + input_idt = idt(QCdrptsidx) ! Prevents match check below from failing + input_dhr = idt(QCdrptsidx)/3600. ! Allows time window check below to use + ! rehabilitated time + endif + if(c_qc(QCdrptsidx)(3:3).eq.'R') then ! Rehabilitated latitude + yob_corr(1) = alat(QCdrptsidx) ! Store updated latitude (YOB) + yob_corr(2) = 3 ! Set correction indicator (YCOR) to 3 + yob_corr(3) = input_alat ! Store original latitude (YORG) + input_alat = alat(QCdrptsidx) ! Prevents match check below from failing + ! and allows geographic domain check below + ! to use rehabilitated latitude + endif + if(c_qc(QCdrptsidx)(4:4).eq.'R') then ! Rehabilitated longitude + xob_corr(1) = alon(QCdrptsidx) ! Store updated longitude (XOB) + xob_corr(2) = 3 ! Set correction indicator (XCOR) to 3 + xob_corr(3) = input_alon ! Store original longitude (XORG) + input_alon = alon(QCdrptsidx) ! Prevents match check below from failing + ! and allows geographic domain check below + ! to use rehabilitated longitude + endif + + input_sqn_last = input_sqn + +c At every 10,000'th QC'd (merged mass + wind) aircraft-type report and at last report, test +c its lat/lon, time and altitude against corresponding PREPBUFR report values - if values DO +c NOT match, PROBLEM!!! +c ------------------------------------------------------------------------------------------- + if(mod(QCdrptsidx,10000).eq.0.or. + + QCdrptsidx.eq.nrpts4QC_pre) then + print *, 'ipoint match check at report # ',QCdrptsidx + if(alat(QCdrptsidx).ne.input_alat .or. + + alon(QCdrptsidx).ne.input_alon .or. + + ht_ft(QCdrptsidx).ne.input_ht_ft .or. + + idt(QCdrptsidx).ne. input_idt) then + print *, 'NO MATCH AT QCdrptsidx = ',QCdrptsidx + print'(" Indexing problem... could not find the ", + + "current input PREPBUFR report in the report-", + + "oriented arrays.")' + print *, 'EXITING PROGRAM.' + + call w3tage('PREPOBS_PREPACQC') + call errexit(31) + endif + print *, 'MATCH AT QCdrptsidx = ',QCdrptsidx + endif + + 3400 continue + +c Before processing this input PREPBUFR report (subset) any further, make sure it is within +c the requested time window (defined by namelist switch trad) and it is within the requested +c geographical domain (here north of 20S latitude, if namelist switch l_nhonly is true) +c ------------------------------------------------------------------------------------------- + + if(l_otw) then ! check if report (subset) is outside time window (prior to any + ! geographical domain checking) + if(input_dhr.lt.-trad.or.input_dhr.gt.trad) then + if(mesgtype.eq.'AIRCFT') then + elim_knt(1,1) = elim_knt(1,1) + 1 + elseif(mesgtype.eq.'AIRCAR') then + elim_knt(2,1) = elim_knt(2,1) + 1 + endif + if(.not.l_hit_limit) then + ncep_rej(QCdrptsidx) = 1 + endif + cycle ! don't write this subset to output file, move on to next subset + endif + endif + + if(l_nhonly) then ! if report (subset) passed time window radius check, then + ! check to see if it is outside geographical domain (i.e., + ! south of 20S) + if(input_alat.lt.-20.0) then + if(mesgtype.eq.'AIRCFT') then + elim_knt(1,2) = elim_knt(1,2) + 1 + elseif(mesgtype.eq.'AIRCAR') then + elim_knt(2,2) = elim_knt(2,2) + 1 + endif + if(.not.l_hit_limit) then + ncep_rej(QCdrptsidx) = 1 + endif + cycle ! don't write this subset to output file, move on to next subset + endif + endif + +c Counter for number of PREPBUFR reports (subsets) kept +c ----------------------------------------------------- + if(mesgtype.eq.'AIRCFT') then + elim_knt(1,3) = elim_knt(1,3) + 1 + elseif(mesgtype.eq.'AIRCAR') then + elim_knt(2,3) = elim_knt(2,3) + 1 + endif + +c If the report passes the time window and geographic domain checks, copy the subset to the +c output PREPBUFR file in anticipation of adding events +c ----------------------------------------------------------------------------------------- + call openmb(outlun,mesgtype,mesgdate) + + call ufbcpy(inlun,outlun) + + if(l_hit_limit) then + +c If this subset exceeds the "max_rep" limit, don't attempt to add QC to it because there is +c none, instead just write subset to the output PREPBUFR file and move on to next subset +c (which won't be QC'd either) +c------------------------------------------------------------------------------------------- + + call writsb(outlun) + cycle + endif + + if(c_qc(QCdrptsidx)(2:2).eq.'R') then + +c Encode rehabilitated time and time correction indicator +c ------------------------------------------------------- + print 66, dhr_corr,input_typ,QCdrptsidx + 66 format(' ENCODE REHABILITATED time ',f10.5, ' as DHR with TCOR=', + + f3.0,' into PREPBUFR file, rtyp = ',i3,', for input report # ', + + i8) + call ufbint(outlun,dhr_corr,2,1,iret,'DHR TCOR') + endif + if(c_qc(QCdrptsidx)(3:3).eq.'R') then + +c Encode rehabilitated latitude, latitude correction indicator and original latitude +c ---------------------------------------------------------------------------------- + print 76, yob_corr,input_typ,QCdrptsidx + 76 format(' ENCODE REHABILITATED latitude ',f9.5, ' as YOB with ', + + 'YCOR=',f3.0,' and YORG=',f9.5,' into PREPBUFR file, rtyp = ',i3, + + ', for input rpt # ',i8) + call ufbint(outlun,yob_corr,3,1,iret,'YOB YCOR YORG') + endif + if(c_qc(QCdrptsidx)(4:4).eq.'R') then + +c Encode rehabilitated longitude, longitude correction indicator and original longitude +c ------------------------------------------------------------------------------------- + print 86, xob_corr,input_typ,QCdrptsidx + 86 format(' ENCODE REHABILITATED longitude ',f9.5, ' as XOB with ', + + 'XCOR=',f3.0,' and XORG=',f9.5,' into PREPBUFR file, rtyp = ',i3, + + ', for input rpt # ',i8) + call ufbint(outlun,xob_corr,3,1,iret,'XOB XCOR XORG') + endif + +c If the input PREPBUFR report is a mass report, update the event stack with mass events +c +c If the input PREPBUFR report is a wind rpt, update the event stack with wind events +c +c Also, first initialize the "bad report", "suspect report", and "duplicate report" flags as +c false - these flags will be set to true if the NRLACQC quality information (array c_qc) +c indicates that the report or any part of it is bad, suspect or a duplicate +c ------------------------------------------------------------------------------------------ + l_badrpt_p = .false. + l_badrpt_z = .false. + l_badrpt_t = .false. + l_badrpt_q = .false. + l_badrpt_w = .false. + + l_duprpt = .false. + +c Pressure +c -------- + +c Get POB and PQM at top of stack coming in and store in array p_event, translate NRLACQC +c quality flags in c_qc to NCEP standards for pressure and store in ipqm_nrlacqc, also store +c reason code in iprc_nrlacqc (pressure data apply to both mass and wind obs) +c ------------------------------------------------------------------------------------------- + call ufbint(inlun,p_event,4,1,nlev,'POB PQM') +ccccc if(QCdrptsidx.eq.47955) print *,'input p_event = ',p_event + nevrd(1) = nevrd(1) + 1 + + if(ibfms(p_event(2)).eq.0) then + if(nint(p_event(2)).ge.0.and.nint(p_event(2)).le.15) then +c PQM for event at top of stack (prior to adding any NRLACQC events) + ipqm_topstk = nint(p_event(2)) + else + npqm_msg_in = npqm_msg_in + 1 + endif + else + npqm_msg_in = npqm_msg_in + 1 + endif + +ccccc if(QCdrptsidx.eq.47955) +ccccc+ print *,'prior to tranQCflags p_event = ',p_event + call tranQCflags(c_qc(QCdrptsidx),'p',ipqm_nrlacqc, + + iprc_nrlacqc,l_badrpt_p,l_duprpt) + +c if PQM = 2 and PRC = 099 returned from tranQCflags, then can't translate! + if(ipqm_nrlacqc.eq.2 .and. iprc_nrlacqc.eq.099) then + print * + print *, 'Unknown c_qc flag on pressure/altitude:', + + c_qc(QCdrptsidx)(5:5) + print *, 'PREPBUFR aircraft report number: ',ninssrd + print *, 'QC ob array index: ',QCdrptsidx + print * + endif +ccccc if(QCdrptsidx.eq.47955) +ccccc+ print *,'after call to tranQCflags PQM, PRC = ', +ccccc+ ipqm_nrlacqc,iprc_nrlacqc + +c Altitude +c -------- + +c Get ZOB and ZQM at top of stack coming in and store in array z_event, translate NRLACQC +c quality flags in c_qc to NCEP standards for altitude and store in izqm_nrlacqc, also store +c reason code in izrc_nrlacqc (altitude applies to both mass and wind obs) +c +c Use same quality marks for altitude as were used for pressure - NRLACQC has one flag for +c both (c_qc(5:5)) +c ------------------------------------------------------------------------------------------- + call ufbint(inlun,z_event,4,1,nlev,'ZOB ZQM') + nevrd(2) = nevrd(2) + 1 + + if(ibfms(z_event(2)).eq.0) then + if(nint(z_event(2)).ge.0.and.nint(z_event(2)).le.15) then +c ZQM for event at top of stack (prior to adding any NRLACQC events) + izqm_topstk = nint(z_event(2)) + else + nzqm_msg_in = nzqm_msg_in + 1 + endif + else + nzqm_msg_in = nzqm_msg_in + 1 + endif + + call tranQCflags(c_qc(QCdrptsidx),'z',izqm_nrlacqc, + + izrc_nrlacqc,l_badrpt_z,l_duprpt) + +c if ZQM = 2 and ZRC = 099 returned from tranQCflags, then can't translate! + if(izqm_nrlacqc.eq.2 .and. izrc_nrlacqc.eq.099) then + print * + print *, 'Unknown c_qc flag on pressure/altitude:', + + c_qc(QCdrptsidx)(5:5) + print *, 'PREPBUFR aircraft report number: ',ninssrd + print *, 'QC ob array index: ',QCdrptsidx + print * + endif + +c If the input PREPBUFR report is a mass report, then see if we need to add an event for +c temperature and moisture - if the input PREPBUFR report is a wind report, then see if we +c need to add an event for wind +c ----------------------------------------------------------------------------------------- + + if(int(input_typ/100).eq.1) then + +c ----------- +c MASS REPORT +c ----------- + +c Temperature +c ----------- + +c Get TOB and TQM at top of stack coming in and store in array t_event, translate NRLACQC +c quality flags in c_qc to NCEP standards for temperature and store in itqm_nrlacqc, also +c store reason code in itrc_nrlacqc +c ---------------------------------------------------------------------------------------- + call ufbint(inlun,t_event,4,1,nlev,'TOB TQM') +ccccc if(QCdrptsidx.eq.47955) print *,'input t_event = ',t_event + nevrd(3) = nevrd(3) + 1 + + if(ibfms(t_event(2)).eq.0) then + if(nint(t_event(2)).ge.0.and.nint(t_event(2)).le.15)then +c TQM for event at top of stack (prior to adding any NRLACQC events) + itqm_topstk = nint(t_event(2)) + else + ntqm_msg_in = ntqm_msg_in + 1 + endif + else + ntqm_msg_in = ntqm_msg_in + 1 + endif + +ccccc if(QCdrptsidx.eq.47955) +ccccc+ print *,'prior to tranQCflags t_event = ',t_event + call tranQCflags(c_qc(QCdrptsidx),'t',itqm_nrlacqc, + + itrc_nrlacqc,l_badrpt_t,l_duprpt) + +c if TQM = 2 and TRC = 099 returned from tranQCflags, then can't translate! + if(itqm_nrlacqc.eq.2 .and. itrc_nrlacqc.eq.099) then + print * + print *, 'Unknown c_qc flag on temperature:', + + c_qc(QCdrptsidx)(6:6) + print *, 'PREPBUFR aircraft report number: ',ninssrd + print *, 'QC ob array index: ',QCdrptsidx + print * + endif +ccccc if(QCdrptsidx.eq.47955) +ccccc+ print *,'after call to tranQCflags TQM, TRC = ', +ccccc+ itqm_nrlacqc,itrc_nrlacqc + + +c Moisture +c -------- + +c Get QOB and QQM at top of stack coming in and store in array q_event, translate NRLACQC +c quality flags in c_qc to NCEP standards for moisture and store in iqqm_nrlacqc, also store +c reason code in iqrc_nrlacqc +c ------------------------------------------------------------------------------------------- + call ufbint(inlun,q_event,4,1,nlev,'QOB QQM') + nevrd(4) = nevrd(4) + 1 + + if(ibfms(q_event(2)).eq.0) then + if(nint(q_event(2)).ge.0.and.nint(q_event(2)).le.15)then +c QQM for event at top of stack (prior to adding any NRLACQC events) + iqqm_topstk = nint(q_event(2)) + else + nqqm_msg_in = nqqm_msg_in + 1 + endif + else + nqqm_msg_in = nqqm_msg_in + 1 + endif + + call tranQCflags(c_qc(QCdrptsidx),'q',iqqm_nrlacqc, + + iqrc_nrlacqc,l_badrpt_q,l_duprpt) + +c if QQM = 2 and QRC = 099 returned from tranQCflags, then can't translate! + if(iqqm_nrlacqc.eq.2 .and. iqrc_nrlacqc.eq.099) then + print * + print *, 'Unknown c_qc flag on moisture:', + + c_qc(QCdrptsidx)(9:9) + print *, 'PREPBUFR aircraft report number: ',ninssrd + print *, 'QC ob array index: ',QCdrptsidx + print * + endif + + elseif(int(input_typ/100).eq.2) then + +c ----------- +c WIND REPORT +c ----------- + +c Wind +c ---- + +c Get UOB, VOB and WQM at top of stack coming in and store in array w_event, translate +c NRLACQC quality flags in c_qc to NCEP standards for wind and store in iwqm_nrlacqc, also +c store reason code in iwrc_nrlacqc +c ----------------------------------------------------------------------------------------- + call ufbint(inlun,w_event,5,1,nlev,'UOB VOB WQM') + nevrd(5) = nevrd(5) + 1 + + if(ibfms(w_event(3)).eq.0) then + if(nint(w_event(3)).ge.0.and.nint(w_event(3)).le.15)then +c WQM for event at top of stack (prior to adding any NRLACQC events) + iwqm_topstk = nint(w_event(3)) + else + nwqm_msg_in = nwqm_msg_in + 1 + endif + else + nwqm_msg_in = nwqm_msg_in + 1 + endif + + call tranQCflags(c_qc(QCdrptsidx),'w',iwqm_nrlacqc, + + iwrc_nrlacqc,l_badrpt_w,l_duprpt) + +c if WQM = 2 and WRC = 099 returned from tranQCflags, then can't translate! + if(iwqm_nrlacqc.eq.2 .and. iwrc_nrlacqc.eq.099) then + print * + print *, 'Unknown c_qc flag on wind:', + + c_qc(QCdrptsidx)(7:7),'/',c_qc(QCdrptsidx)(8:8) + print *, 'PREPBUFR aircraft report number: ',ninssrd + print *, 'QC ob array index: ',QCdrptsidx + print * + endif + + endif ! int(input_typ/100) = 1 or 2 + +ccccc if(QCdrptsidx.eq.47955) +ccccc+ print *,'prior to entire rpt rej PQM, PRC = ', +ccccc+ ipqm_nrlacqc,iprc_nrlacqc + +c If entire report is to be rejected, put reject flags (QM=13) on pressure, altitude, +c temperature, moisture, and wind +c ----------------------------------------------------------------------------------- + if(l_badrpt_p .or. l_badrpt_z .or. + + l_badrpt_t .or. l_badrpt_q .or. l_badrpt_w) then + +ccccc if(QCdrptsidx.eq.47955) +ccccc+ print *, 'we are in reject report logic' + + ipqm_nrlacqc = 13 ! PQM + ! PRC already encoded into iprc_nrlacqc in subr. tranQCflags + + izqm_nrlacqc = 13 ! ZQM + ! ZRC already encoded into izrc_nrlacqc in subr. tranQCflags + + if(int(input_typ/100).eq.1) then + itqm_nrlacqc = 13 ! TQM + ! TRC already encoded into itrc_nrlacqc in subr. tranQCflags + + iqqm_nrlacqc = 13 ! QQM + ! QRC already encoded into iqrc_nrlacqc in subr. tranQCflags + + elseif(int(input_typ/100).eq.2) then + + iwqm_nrlacqc = 13 ! WQM + ! WRC already encoded into iwrc_nrlacqc in subr. tranQCflags + + endif ! int(input_typ/100) = 1 or 2 + endif ! l_badrpt_[p,z,t,q,w] + +ccccc if(QCdrptsidx.eq.47955) +ccccc+ print *,'after entire rpt rej PQM, PRC = ', +ccccc+ ipqm_nrlacqc,iprc_nrlacqc + +c If report is marked as a duplicate (c_qc(1:1) = d or D), then mark the entire report with +c a bad NCEP quality mark (=13) +c ----------------------------------------------------------------------------------------- + if(l_duprpt) then + ipqm_nrlacqc = 13 ! PQM + ! PRC already encoded into iprc_nrlacqc in subr. tranQCflags + + izqm_nrlacqc = 13 ! ZQM + ! ZRC already encoded into izrc_nrlacqc in subr. tranQCflags + + if(int(input_typ/100).eq.1) then + itqm_nrlacqc = 13 ! TQM + ! TRC already encoded into itrc_nrlacqc in subr. tranQCflags + + iqqm_nrlacqc = 13 ! QQM + ! QRC already encoded into iqrc_nrlacqc in subr. tranQCflags + + elseif(int(input_typ/100).eq.2) then + + iwqm_nrlacqc = 13 ! WQM + ! WRC already encoded into iwrc_nrlacqc in subr. tranQCflags + + endif ! int(input_typ/100) = 1 or 2 + endif ! l_duprpt + +c Update pressure, altitude, temperature, moisture and wind stacks with new event in output +c PREPBUFR file when there has been a qualty mark change by NRLACQC (don't need to write out +c an event if quality mark has not been changed by this program) +c +c EXCEPTION: Retain (honor) the incoming quality mark at the top of the stack (i.e., do not +c write event) when: +c +c (1) The incoming quality mark at the top of the stack is 0 (keep flag) +c (2) The incoming quality mark at the top of the stack is between 4 and 15 (bad) - +c except when NRLACQC itself generates a BAD quality mark (translated to NCEP +c value of 13), allows reason code to denote why action taken by NRLACQC to mark +c obs as bad +c (3) The incoming quality mark at the top of the stack is not between 0 and 15 +c (i.e.,missing) +c (4) The incoming quality mark at the top of the stack is 3 (suspect) and the NRLACQC +c generates a GOOD or NEUTRAL or SUSPECT quality mark (translated to NCEP values of +c 1, 2 and 3 resp.) {in other words, unless an ob previously marked as suspect was +c marked bad by NRLACQC, don't change a suspect quality mark assigned by a PREPBUFR +c processing step prior to the NRLACQC step} +c (5) The quality mark translated to its NCEP value is 2 (neutral) and the reason code +c is returned from tranQCflags is 099 - this indicates that the NRLACQC quality +c flags in c_qc pertaining to this ob are unknown to transQCflags (the routine +c tranQCflags may need to be updated to account for the c_qc flags that is coming +c out of the NRLACQC QC routine for this ob - this would probably only happen if +c NRL provides an updated/upgraded acftobs_qc module to NCEP) +c (6) The NCEP equivalent of the NRLACQC is the same as the incoming quality mark of +c the stack - if there is no change in the quality mark, then do not add a new +c event and leave the event at the top of the event stack as is with TWO +c exceptions: +c a) NRLACQC itself generates a GOOD quality mark (translated to NCEP value of +c 1) +c b) NRLACQC itself generates a BAD quality mark (translated to NCEP value of +c 13) (see 2 above for more on this) +c ------------------------------------------------------------------------------------------- + +c Pressure +c -------- +ccccc if(QCdrptsidx.eq.47955) +ccccc+ print *,'prior to writing ? event p_event = ',p_event(1), +ccccc+ ipqm_nrlacqc,p_event(3),iprc_nrlacqc + + l_skip = .true. ! SKIP LOGIC TO WRITE PRESSURE EVENTS - there is no need to do so + ! since pressure is a vertical coordinate and it is not analyzed, + ! in addition, adding pressure events complicates reason code + ! logic + + if(.not.l_skip) then + +c .... if here, include logic to write pressure events + if(ipqm_topstk.eq.0 .or. + + (ipqm_topstk.ge.4 .and. ipqm_topstk.le.15) .or. ! ob has already been marked + ! bad by NCEP codes + + ipqm_topstk.eq.9999 .or. + + (ipqm_topstk.eq.3.and.ipqm_nrlacqc.le.3) .or. + + (ipqm_nrlacqc.eq.2.and.iprc_nrlacqc.eq.099) .or. + + (ipqm_topstk.eq.ipqm_nrlacqc.and.ipqm_nrlacqc.ne.1) + + ) then ! no event needed; leave PQM as is + + ipqm_nrlacqc = ipqm_topstk + + nev_noupd(1) = nev_noupd(1) + 1 + else ! NRL QC produced an event; add this event to top of stack in output + ! PREPBUFR file + p_event(2) = ipqm_nrlacqc + p_event(3) = nrlacqc_pc + p_event(4) = iprc_nrlacqc + call ufbint(outlun,p_event,4,1,iret,'POB PQM PPC PRC') ! pressure & altitude + ! apply to both mass + ! & wind + nevwrt(1) = nevwrt(1) + 1 + ncep_rc_p(QCdrptsidx) = iprc_nrlacqc +ccccc if(QCdrptsidx.eq.47955) +ccccc+ print *,'after writing event p_event = ',p_event +ccccc if(QCdrptsidx.eq.47955) print *,'after writing event ', +ccccc+ ncep_rc_p = ',ncep_rc_p(QCdrptsidx) + endif +ccccc if(QCdrptsidx.eq.47955) print *,'after writing event ', +ccccc+ ncep_qm_p = 'ncep_qm_p(QCdrptsidx) + + if((ipqm_nrlacqc.ge.0.and.ipqm_nrlacqc.le.15).and. + + (ipqm_topstk.ge.0.and.ipqm_topstk.le.15)) then + ncep_qm_p(QCdrptsidx) = ipqm_nrlacqc + qm_knt(1,ipqm_topstk,ipqm_nrlacqc) = + + qm_knt(1,ipqm_topstk,ipqm_nrlacqc) + 1 + else + npqm_msg_out = npqm_msg_out + 1 + endif + + else + +c .... if here, SKIP logic to write pressure events + ipqm_nrlacqc = ipqm_topstk + nev_noupd(1) = nev_noupd(1) + 1 + if((ipqm_nrlacqc.ge.0.and.ipqm_nrlacqc.le.15).and. + + (ipqm_topstk.ge.0.and.ipqm_topstk.le.15)) then + ncep_qm_p(QCdrptsidx) = ipqm_nrlacqc + qm_knt(1,ipqm_topstk,ipqm_nrlacqc) = + + qm_knt(1,ipqm_topstk,ipqm_nrlacqc) + 1 + else + npqm_msg_out = npqm_msg_out + 1 + endif + + endif + +c Altitude +c -------- + + l_skip = .true. ! SKIP LOGIC TO WRITE ALTITUDE EVENTS - there is no need to do so + ! since altitude is a vertical coordinate and it is not analyzed, + ! in addition, adding altitude events complicates reason code + ! logic + + if(.not.l_skip) then + +c .... if here, include logic to write altitude events + if(izqm_topstk.eq.0 .or. + + (izqm_topstk.ge.4 .and. izqm_topstk.le.15) .or. ! ob has already been marked + ! bad by NCEP codes + + izqm_topstk.eq.9999 .or. + + (izqm_topstk.eq.3.and.izqm_nrlacqc.le.3) .or. + + (izqm_nrlacqc.eq.2.and.izrc_nrlacqc.eq.099) .or. + + (izqm_topstk.eq.izqm_nrlacqc.and.izqm_nrlacqc.ne.1) + + ) then ! no event needed; leave ZQM as is + izqm_nrlacqc = izqm_topstk + + nev_noupd(2) = nev_noupd(2) + 1 + else ! NRL QC produced an event; add this event to top of stack in output + ! PREPBUFR file + z_event(2) = izqm_nrlacqc + z_event(3) = nrlacqc_pc + z_event(4) = izrc_nrlacqc + call ufbint(outlun,z_event,4,1,iret,'ZOB ZQM ZPC ZRC') ! pressure & altitude + ! apply to both mass + ! & wind + nevwrt(2) = nevwrt(2) + 1 + ncep_rc_z(QCdrptsidx) = izrc_nrlacqc + endif + + if((izqm_nrlacqc.ge.0.and.izqm_nrlacqc.le.15).and. + + (izqm_topstk.ge.0.and.izqm_topstk.le.15)) then + ncep_qm_z(QCdrptsidx) = izqm_nrlacqc + qm_knt(2,izqm_topstk,izqm_nrlacqc) = + + qm_knt(2,izqm_topstk,izqm_nrlacqc) + 1 + else + nzqm_msg_out = nzqm_msg_out + 1 + endif + + else + +c .... if here, SKIP logic to write altitude events + izqm_nrlacqc = izqm_topstk + nev_noupd(2) = nev_noupd(2) + 1 + if((izqm_nrlacqc.ge.0.and.izqm_nrlacqc.le.15).and. + + (izqm_topstk.ge.0.and.izqm_topstk.le.15)) then + ncep_qm_z(QCdrptsidx) = izqm_nrlacqc + qm_knt(2,izqm_topstk,izqm_nrlacqc) = + + qm_knt(2,izqm_topstk,izqm_nrlacqc) + 1 + else + nzqm_msg_out = nzqm_msg_out + 1 + endif + + endif + + if(int(input_typ/100).eq.1) then + +c Temperature +c ----------- + +c Obs/Events + if((itqm_topstk.eq.0 .or. + + (itqm_topstk.ge.4 .and. itqm_topstk.le.15) .or. ! ob has already been marked + ! bad by NCEP codes + + itqm_topstk.eq.9999 .or. + + (itqm_topstk.eq.3.and.itqm_nrlacqc.le.3) .or. + + (itqm_nrlacqc.eq.2.and.itrc_nrlacqc.eq.099) .or. + + (itqm_topstk.eq.itqm_nrlacqc.and.itqm_nrlacqc.ne.1) + + ) .and. (itqm_nrlacqc.ne.13.or. + + itqm_topstk.eq.9999)) then ! no event needed; leave TQM as is +ccccc if(QCdrptsidx.eq.47955) +ccccc+ print *,'no t_event written for ',QCdrptsidx + itqm_nrlacqc = itqm_topstk + + nev_noupd(3) = nev_noupd(3) + 1 + + else ! NRL QC produced an event; add this event to top of stack in output + ! PREPBUFR file +ccccc if(QCdrptsidx.eq.47955) +ccccc+ print *,'new t_event written for ',QCdrptsidx + if(int(itrc_nrlacqc/100).eq.9 .and. + + itqm_nrlacqc.eq.13) itqm_nrlacqc = 14 ! if temperature marked bad here + ! due to it being on reject list, + ! reset TQM to 14 + t_event(2) = itqm_nrlacqc + t_event(3) = nrlacqc_pc + t_event(4) = itrc_nrlacqc + call ufbint(outlun,t_event,4,1,iret,'TOB TQM TPC TRC') + nevwrt(3) = nevwrt(3) + 1 + ncep_rc_t(QCdrptsidx) = itrc_nrlacqc + endif + + if((itqm_nrlacqc.ge.0.and.itqm_nrlacqc.le.15).and. + + (itqm_topstk.ge.0.and.itqm_topstk.le.15)) then + ncep_qm_t(QCdrptsidx) = itqm_nrlacqc + qm_knt(3,itqm_topstk,itqm_nrlacqc) = + + qm_knt(3,itqm_topstk,itqm_nrlacqc) + 1 + else + ntqm_msg_out = ntqm_msg_out + 1 + endif + +c Moisture +c -------- + +c Obs/Events + if((iqqm_topstk.eq.0 .or. + + (iqqm_topstk.ge.4 .and. iqqm_topstk.le.15) .or. ! ob has already been marked + ! bad by NCEP codes + + iqqm_topstk.eq.9999 .or. + + (iqqm_topstk.eq.3 .and. iqqm_nrlacqc.le.3) .or. + + (iqqm_nrlacqc.eq.2.and.iqrc_nrlacqc.eq.099) .or. + + (iqqm_topstk.eq.iqqm_nrlacqc.and.iqqm_nrlacqc.ne.1) + + ) .and. (iqqm_nrlacqc.ne.13.or. + + iqqm_topstk.eq.9999)) then ! no event needed; leave QQM as is + iqqm_nrlacqc = iqqm_topstk + + nev_noupd(4) = nev_noupd(4) + 1 + + else ! NRL QC produced a new event; add this event to top of stack in output + ! PREPBUFR file + if(int(iqrc_nrlacqc/100).eq.9 .and. + + iqqm_nrlacqc.eq.13) iqqm_nrlacqc = 14 ! if moisture marked bad here due + ! to temperature being on reject + ! list, reset QQM to 14 + q_event(2) = iqqm_nrlacqc + q_event(3) = nrlacqc_pc + q_event(4) = iqrc_nrlacqc + call ufbint(outlun,q_event,4,1,iret,'QOB QQM QPC QRC') + nevwrt(4) = nevwrt(4) + 1 + ncep_rc_q(QCdrptsidx) = iqrc_nrlacqc + endif + + if((iqqm_nrlacqc.ge.0.and.iqqm_nrlacqc.le.15).and. + + (iqqm_topstk.ge.0.and.iqqm_topstk.le.15))then + ncep_qm_q(QCdrptsidx) = iqqm_nrlacqc + qm_knt(4,iqqm_topstk,iqqm_nrlacqc) = + + qm_knt(4,iqqm_topstk,iqqm_nrlacqc) + 1 + else + nqqm_msg_out = nqqm_msg_out + 1 + endif + + elseif(int(input_typ/100).eq.2) then + +c Wind +C ---- + +c Obs/Events + if((iwqm_topstk.eq.0 .or. + + (iwqm_topstk.ge.4 .and. iwqm_topstk.le.15) .or. ! ob has already been marked + ! bad by NCEP codes + + iwqm_topstk.eq.9999 .or. + + (iwqm_topstk.eq.3 .and. iwqm_nrlacqc.le.3) .or. + + (iwqm_nrlacqc.eq.2.and.iwrc_nrlacqc.eq.099) .or. + + (iwqm_topstk.eq.iwqm_nrlacqc.and.iwqm_nrlacqc.ne.1) + + ) .and. (iwqm_nrlacqc.ne.13.or. + + iwqm_topstk.eq.9999)) then ! no event needed; leave WQM as is + iwqm_nrlacqc = iwqm_topstk + + nev_noupd(5) = nev_noupd(5) + 1 + + else ! NRL QC produced a new event; add this event to top of stack in output + ! PREPBUFR file + if(int(iwrc_nrlacqc/100).eq.9 .and. + + iwqm_nrlacqc.eq.13) iwqm_nrlacqc = 14 ! if wind marked bad here due to it + ! being on reject list, reset WQM + ! to 14 + w_event(3) = iwqm_nrlacqc + w_event(4) = nrlacqc_pc + w_event(5) = iwrc_nrlacqc + call ufbint(outlun,w_event,5,1,iret,'UOB VOB WQM WPC WRC') + nevwrt(5) = nevwrt(5) + 1 + ncep_rc_w(QCdrptsidx) = iwrc_nrlacqc + endif + + if((iwqm_nrlacqc.ge.0.and.iwqm_nrlacqc.le.15).and. + + (iwqm_topstk.ge.0.and.iwqm_topstk.le.15))then + ncep_qm_w(QCdrptsidx) = iwqm_nrlacqc + qm_knt(5,iwqm_topstk,iwqm_nrlacqc) = + + qm_knt(5,iwqm_topstk,iwqm_nrlacqc) + 1 + else + nwqm_msg_out = nwqm_msg_out + 1 + endif + + endif + + l_eventupdate = .true. + +c After updating all event stacks {pressure (maybe), altitude (maybe), temperature, moisture +c and wind), write subset to the output PREPBUFR file - also add NRLACQC quality string to +c this subset, since the string is of length 11 characters, must call WRITLC after call to +c WRITSB +c ------------------------------------------------------------------------------------------ + call writsb(outlun) + +c ***** ----> BUFRLIB routine WRITLC trims the string that is stored, cutting off any blank +c (" ") characters - since blank characters have meaning in the originally- +c defined NRLACQC quality string (usually indicating passed all tests and thus +c good), we earlier (in subroutine acftobs_qc) replaced blank characters with dot +c (".") characters so these would be retained by WRITLC +c ------------------------------------------------------------------------------------------- + c_nrlqm = c_qc(QCdrptsidx) + +ccccc print *, 'in *noprof.f, writing c_nrlqm=', c_nrlqm + + if (l_qmwrite) then + call writlc(outlun,c_nrlqm,'NRLQMS') + end if +c Close loops here +c ---------------- + enddo ! ireadsb + endif ! check for AIRCFT and AIRCAR messages + enddo ! ireadmg + +c Output counts +c ------------- + +c Detailed counts of reports eliminated from final PREPBUFR file +c -------------------------------------------------------------- + print * + print *, '----------------------------------------------------' + print *, 'Info about reports tossed from final PREPBUFR file: ' + print *, '----------------------------------------------------' + print * + if(l_otw) then + print 96, trad,elim_knt(1,1) + 96 format(' Subsets from AIRCFT msgs tossed because outside req. ', + + 'time window radius of',F6.2,'hrs (prior to geographical domain', + + ' chking):',i6) + print 97, trad,elim_knt(2,1) + 97 format(' Subsets from AIRCAR msgs tossed because outside req. ', + + 'time window radius of',F6.2,'hrs (prior to geographical domain', + + ' chking):',i6) + else + print *, 'Time window radius check NOT performed, l_otw=',l_otw, + + ' (ZERO reports tossed)' + endif + print * + if(l_nhonly) then + print'(" Subsets from AIRCFT messages passing time window ", + + "radius check but outside geographical domain (i.e., S ", + + "of 20S lat): ",I0)', elim_knt(1,2) + print'(" Subsets from AIRCAR messages passing time window ", + + "radius check but outside geographical domain (i.e., S ", + + "of 20S lat): ",I0)', elim_knt(2,2) + else + print'(" Geographical domain check not performed, l_nhonly=",L, + + " (ZERO reports tossed)")', l_nhonly + endif + print * + print'(" Number of subsets from AIRCFT messages passing checks ", + + "and kept: ",I0)', elim_knt(1,3) + print'(" Number of subsets from AIRCAR messages passing checks ", + + "and kept: ",I0)', elim_knt(2,3) + print * + print'(" TOTAL NUMBER OF SUBSETS WRITTEN BACK OUT: ",I0)', + + elim_knt(1,3)+elim_knt(2,3) + +c Pressure details +c ---------------- + print * + print *, '***********************' + print *, 'PQM changes/status quo: ' + + print * + print *, 'Input PQM info:' + print *, 'PQMs read from PREPBUFR:',nevrd(1) + print *, 'Obs with MISSING PQMs upon input:',npqm_msg_in + print * + + print *, 'Output PQM info:' + print *, 'PQMs written to output PREPBUFR:',nevwrt(1) + print *, 'Obs with MISSING PQMs (not written to output):', + + npqm_msg_out + print *, 'Obs with NRLACQC QM equal to previous QM (no new ', + + 'event): ',nev_noupd(1) + + print * + print *, 'Non-missing PQM Breakdown:' + do i=0,15 + do j=0,15 + if(qm_knt(1,i,j).ne.0) then + print 50, 'PQM:',i,'->',j,':',qm_knt(1,i,j) + p_qm_knt_tot = p_qm_knt_tot + qm_knt(1,i,j) + endif + enddo + enddo + + if(p_qm_knt_tot.eq.0) then + print *, 'NO PQM RESULTS!' + else + print 51 + print 52,'TOTAL:',p_qm_knt_tot + endif + + 50 format(1x,a4,1x,i2,1x,a2,1x,i2,a1,1x,i6) + 51 format(1x,'---------------------') + 52 format(1x,a6,9x,i6) + +c Altitude details +c ---------------- + print * + print *, '***********************' + print *, 'ZQM changes/status quo: ' + + print * + print *, 'Input ZQM info:' + print *, 'ZQMs read from PREPBUFR:',nevrd(2) + print *, 'Obs with MISSING ZQMs upon input:',nzqm_msg_in + print * + + print *, 'Output ZQM info:' + print *, 'ZQMs written to output PREPBUFR:',nevwrt(2) + print *, 'Obs with MISSING ZQMs (not written to output):', + + nzqm_msg_out + print *, 'Obs with NRLACQC QM equal to previous QM (no new ', + + 'event): ',nev_noupd(2) + + print * + print *, 'Non-missing ZQM Breakdown:' + do i=0,15 + do j=0,15 + if(qm_knt(2,i,j).ne.0) then + print 50, 'ZQM:',i,'->',j,':',qm_knt(2,i,j) + z_qm_knt_tot = z_qm_knt_tot + qm_knt(2,i,j) + endif + enddo + enddo + + if(z_qm_knt_tot.eq.0) then + print *, 'NO ZQM RESULTS!' + else + print 51 + print 52,'TOTAL:',z_qm_knt_tot + endif + +c Temperature details +c ------------------- + print * + print *, '***********************' + print *, 'TQM changes/status quo: ' + + print * + print *, 'Input TQM info:' + print *, 'TQMs read from PREPBUFR:',nevrd(3) + print *, 'Obs with MISSING TQMs upon input:',ntqm_msg_in + print * + + print *, 'Output TQM info:' + print *, 'TQMs written to output PREPBUFR:',nevwrt(3) + print *, 'Obs with MISSING TQMs (not written to output):', + + ntqm_msg_out + print *, 'Obs with NRLACQC QM equal to previous QM (no new ', + + 'event): ',nev_noupd(3) + + print * + print *, 'Non-missing TQM Breakdown:' + do i=0,15 + do j=0,15 + if(qm_knt(3,i,j).ne.0) then + print 50, 'TQM:',i,'->',j,':',qm_knt(3,i,j) + t_qm_knt_tot = t_qm_knt_tot + qm_knt(3,i,j) + endif + enddo + enddo + + if(t_qm_knt_tot.eq.0) then + print *, 'NO TQM RESULTS!' + else + print 51 + print 52,'TOTAL:',t_qm_knt_tot + endif + +c Moisture details +c ---------------- + print * + print *, '***********************' + print *, 'QQM changes/status quo: ' + + print * + print *, 'Input QQM info:' + print *, 'QQMs read from PREPBUFR:',nevrd(4) + print *, 'Obs with MISSING QQMs upon input:',nqqm_msg_in + print * + + print *, 'Output QQM info:' + print *, 'QQMs written to output PREPBUFR:',nevwrt(4) + print *, 'Obs with MISSING QQMs (not written to output):', + + nqqm_msg_out + print *, 'Obs with NRLACQC QM equal to previous QM (no new ', + + 'event): ',nev_noupd(4) + + print * + print *, 'Non-missing QQM Breakdown:' + do i=0,15 + do j=0,15 + if(qm_knt(4,i,j).ne.0) then + print 50, 'QQM:',i,'->',j,':',qm_knt(4,i,j) + q_qm_knt_tot = q_qm_knt_tot + qm_knt(4,i,j) + endif + enddo + enddo + + if(q_qm_knt_tot.eq.0) then + print *, 'NO QQM RESULTS!' + else + print 51 + print 52,'TOTAL:',q_qm_knt_tot + endif + +c Wind details +c ------------ + print * + print *, '***********************' + print *, 'WQM changes/status quo: ' + + print * + print *, 'Input WQM info:' + print *, 'WQMs read from PREPBUFR:',nevrd(5) + print *, 'Obs with MISSING WQMs upon input:',nwqm_msg_in + print * + + print *, 'Output WQM info:' + print *, 'WQMs written to output PREPBUFR:',nevwrt(5) + print *, 'Obs with MISSING WQMs (not written to output):', + + nwqm_msg_out + print *, 'Obs with NRLACQC QM equal to previous QM (no new ', + + 'event): ',nev_noupd(5) + + print * + print *, 'Non-missing WQM Breakdown:' + do i=0,15 + do j=0,15 + if(qm_knt(5,i,j).ne.0) then + print 50, 'WQM:',i,'->',j,':',qm_knt(5,i,j) + w_qm_knt_tot = w_qm_knt_tot + qm_knt(5,i,j) + endif + enddo + enddo + + if(w_qm_knt_tot.eq.0) then + print *, 'NO WQM RESULTS!' + else + print 51 + print 52,'TOTAL:',w_qm_knt_tot + endif + + + write(*,*) + write(*,*) '****************************' + write(*,*) 'output_acqc_noprof has ended' + call system('date') + write(*,*) '****************************' + write(*,*) + + return + + end diff --git a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/output_acqc_prof.f b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/output_acqc_prof.f new file mode 100644 index 00000000..a2e56d5c --- /dev/null +++ b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/output_acqc_prof.f @@ -0,0 +1,1441 @@ +c$$$ Subprogram Documentation Block +c BEST VIEWED WITH 94-CHARACTER WIDTH WINDOW +c +c Subprogram: output_acqc_prof +c Programmer: D. Keyser Org: NP22 Date: 2016-12-09 +c +c Abstract: Reads in sorted NRLACQC quality controlled single-level aircraft reports and +c constructs profiles from ascending or descending flights. Encodes these profiles as +c merged (mass and wind) reports (subsets) along with (when l_prof1lvl=T) merged +c single(flight)-level aircraft reports not part of any profile into a PREPBUFR-like file +c containing only these data. Single-level reports get PREPBUFR report type 3xx (where xx +c is original type in 1xx mass and 2xx wind reports), ascending profile reports get +c PREPBUFR report type 4xx, and descending profile reports get PREPBUFR report type 5xx. +c +c Program History Log: +c 2010-11-15 S. Bender -- Original Author +c 2012-05-08 D. Keyser -- Prepared for operational implementation +c 2012-11-20 J. Woollen -- Initial port to WCOSS +c 2013-02-07 D. Keyser -- Final changes to run on WCOSS: use formatted print statements +c where previously unformatted print was > 80 characters +c 2016-12-09 D. Keyser -- +c - Nomenclature change: replaced "MDCRS/ACARS" with just "MDCRS". +c - Latitude/longitdue arrays "alat" and "alon" passed into of this subroutine +c now double precision. XOB and YOB in PREPBUFR file now scaled to 10**5 +c (was 10**2) to handle new v7 AMDAR and MDCRS reports which have this +c higher precision. +c BENEFIT: Retains exact precison here. Improves QC processing. +c - The format for all print statements containing latitude and longitude +c changed to print to 5 decimal places. +c +c Usage: call output_acqc_prof(proflun,nrpts4QC_pre,max_reps,mxnmev, +c mxlv,bmiss,cdtg_an,alat,alon,ht_ft, +c idt,c_qc,trad,l_otw,l_nhonly,sortidx, +c c_acftreg,c_acftid,ob_t,nevents,hdr, +c acid,rct,drinfo,acft_seq,mstq,cat, +c pob_ev,pqm_ev,ppc_ev,prc_ev,pbg,ppp, +c zob_ev,zqm_ev,zpc_ev,zrc_ev,zbg,zpp, +c tob_ev,tqm_ev,tpc_ev,trc_ev,tbg,tpp, +c qob_ev,qqm_ev,qpc_ev,qrc_ev,qbg,qpp, +c uob_ev,vob_ev,wqm_ev,wpc_ev,wrc_ev, +c wbg,wpp,ddo_ev,ffo_ev,dfq_ev,dfp_ev, +c dfr_ev,nrlacqc_pc,l_allev_pf, +c l_prof1lvl,l_mandlvl,tsplines,l_operational,lwr) +c +c Input argument list: +c proflun - Unit number for the output post-PREPACQC PREPBUFR-like file containing +c merged profile reports (always) and single(flight)-level reports not +c part of any profile (when l_prof1lvl=T) with added NRLACQC events +c (aircraft data only) +c nrpts4QC_pre - Number of reports in the "merged" single-level aircraft report arrays +c max_reps - Maximum number of reports accepted by acftobs_qc +c mxnmev - Maximum number of events allowed, per variable type +c mxlv - Maximum number of levels allowed in a report profile +c bmiss - BUFRLIB missing value (set in main program) +c cdtg_an - Date/analysis time (YYYYMMDDCC) +c alat - Array of latitudes for the "merged" reports +c alon - Array of longitudes for the "merged" reports +c ht_ft - Array of altitudes for the "merged" reports +c idt - Array of ob-cycle times for the "merged" reports (in seconds) +c c_qc - Array of NRLACQC quality information (11 char. string) ("merged" reports) +c trad - Time window radius for outputting reports (if l_otw=T) (read in via +c namelist) +c l_otw - Logical whether or not to eliminate reports outside the time window +c radius (trad) (read in via namelist) +c l_nhonly - Logical Whether or not to eliminate reports south of 20S latitude (i.e, +c outside the tropics and N. Hemisphere) (read in via namelist) +c sortidx - Sort index that specifies the order in which the reports should be +c written to the output PREPBUFR-like profiles file +c c_acftreg - Array of aircraft tail numbers for the "merged" reports as used in +c NRL QC processing +c c_acftid - Array of aircraft flight numbers for the "merged" reports as used in +c NRL QC processing +c ob_t - Array of aircraft temperatures for the "merged" reports +c nevents - Array tracking number of events for variables for each report +c hdr - Array containing header information for the "merged" reports {word 1 is +c flight number for AIREPs, tail number for AMDARs (all types) and MDCRS, +c and manfactured id for PIREPs and TAMDARs - this will be later be +c encoded into 'SID' for aircraft reports in output PREPBUFR-like file) +c acid - Array containing flight numbers for the "merged" MDCRS and AMDAR (LATAM +c only) reports {this will be encoded into 'ACID' for MDCRS and AMDAR +c (LATAM only) reports in output PREPBUFR-like profiles file} +c rct - Array containing receipt times for the "merged" reports +c drinfo - Array containing drift information for the "merged" reports +c acft_seq - Array containing temperature precision and phase of flight for the +c "merged" reports +c mstq - Array containing moisture quality flags for the "merged" reports +c cat - Array containing level category for the "merged" reports +c pob_ev - Pressure event obs +c pqm_ev - Pressure event quality marks +c ppc_ev - Pressure event program codes +c prc_ev - Pressure event reason codes +c pbg - Pressure background data (POE PFC PFCMOD) +c ppp - Pressure post-processing info (PAN PCL PCS) +c zob_ev - Altitude event obs +c zqm_ev - Altitude event quality marks +c zpc_ev - Altitude event program codes +c zrc_ev - Altitude event reason codes +c zbg - Altitude background data (ZOE ZFC ZFCMOD) +c zpp - Altitude post-processing info (ZAN ZCL ZCS) +c tob_ev - Temperature event obs +c tqm_ev - Temperature event quality marks +c tpc_ev - Temperature event program codes +c trc_ev - Temperature event reason codes +c tbg - Temperature background data (TOE TFC TFCMOD) +c tpp - Temperature post-processing info (TAN TCL TCS) +c qob_ev - Moisture event obs +c qqm_ev - Moisture event quality marks +c qpc_ev - Moisture event program codes +c qrc_ev - Moisture event reason codes +c qbg - Moisture background data (QOE QFC QFCMOD) +c qpp - Moisture post-processing info (QAN QCL QCS) +c uob_ev - Wind/u-comp event obs +c vob_ev - Wind/v-comp event obs +c wqm_ev - Wind event quality marks +c wpc_ev - Wind event program codes +c wrc_ev - Wind event reason codes +c wbg - Wind background data (WOE UFC VFC UFCMOD VFCMOD) +c wpp - Wind post-processing info (UAN VAN UCL VCL UCS VCS) +c ddo_ev - Wind direction event obs +c ffo_ev - Wind speed event obs +c dfq_ev - Wind direction/speed quality mark +c dfp_ev - Wind direction/speed program code +c dfr_ev - Wind direction/speed reason code +c nrlacqc_pc - PREPBUFR program code for the NRLACQC step +c l_allev_pf - Logical whether to process latest (likely NRLACQC) event plus all prior +c events (TRUE) or only latest event (FALSE) into profiles PREPBUFR-like +c file +c l_prof1lvl - Logical whether to encode merged single(flight)-level aircraft reports +c with NRLACQC events that are not part of any profile into PREPBUFR-like +c file (along with, always, merged profiles from aircraft ascents and +c descents) +c l_mandlvl - Logical whether to interpolate to mandatory levels in profile generation +c tsplines - Logical whether to use tension-splines for aircraft vertical velocity +c calculation +c l_operational- Run program in operational mode if true +c lwr - Machine word length in bytes (either 4 or 8) +c +c Output files: +c Unit proflun - PREPBUFR-like file containing merged (mass and wind) profile reports +c (always) and single(flight)-level reports not part of any profile (when +c l_prof1lvl=T) with NRLACQC events +c Unit 06 - Standard output print +c Unit 52 - Text file containing listing of all QC'd merged aircraft reports written +c to profiles PREPBUFR-like file +c +c Subprograms called: +c Unique: SUB2MEM_MER SUB2MEM_UM +c Library: +c SYSTEM: SYSTEM +c BUFRLIB: OPENMB WRITSB +c +c Exit States: +c Cond = 0 - successful run +c +c Remarks: Called by main program. +c +c Attributes: +c Language: FORTRAN 90 +c Machine: NCEP WCOSS +c +c$$$ + subroutine output_acqc_prof(proflun,nrpts4QC_pre,max_reps,mxnmev, + + mxlv,bmiss,cdtg_an,alat,alon,ht_ft, + + idt,c_qc,trad,l_otw,l_nhonly,sortidx, + + c_acftreg,c_acftid,ob_t,nevents,hdr, + + acid,rct,drinfo,acft_seq,mstq,cat, + + pob_ev,pqm_ev,ppc_ev,prc_ev,pbg,ppp, + + zob_ev,zqm_ev,zpc_ev,zrc_ev,zbg,zpp, + + tob_ev,tqm_ev,tpc_ev,trc_ev,tbg,tpp, + + qob_ev,qqm_ev,qpc_ev,qrc_ev,qbg,qpp, + + uob_ev,vob_ev,wqm_ev,wpc_ev,wrc_ev, + + wbg,wpp,ddo_ev,ffo_ev,dfq_ev,dfp_ev, + + dfr_ev,nrlacqc_pc,l_allev_pf, + + l_prof1lvl,l_mandlvl,tsplines, + + l_operational,lwr) + + implicit none + integer mevwrt(1) ! DAK: This is a "dummy" variable, not used anywhere. For some + ! reason if one removes this, moves it to any other place in + ! this subr., changes the dimension, or does not initialize it + ! as zero (look below) the compiler can fail under -O3 with + ! debugging turned on ("An error occurred during code + ! generation. The code generation return code was 40." + ! "Compilation failed for file output_acqc_prof.f." + +c ------------------------------ +c Parameter statements/constants +c ------------------------------ + integer proflun ! output unit number for post-PREPACQC PREPBUFR-like + ! file containing merged profile reports (always) and + ! single(flight)-level reports not part of any profile + ! (when l_prof1lvl=T) with added NRLACQC events + + integer max_reps ! maximum number of input merged (mass + wind piece) + ! aircraft-type reports allowed +cvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv +c replace above with this in event of future switch to dynamic memory allocation + +calloc integer max_reps ! original number of input reports obtained from +calloc ! first pass through to get total for array allocation +c^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + real*8 bmiss ! BUFRLIB missing value (set in main program) + +c ---------------------- +c Declaration statements +c ---------------------- + +c Variables for BUFRLIB interface +c ------------------------------- + character*10 cdtg_an ! date-time group for analysis (YYYYMMDDCC) + ! (all messages in a PREPBUFR-like file should have + integer icdtg_an ! same YYYYMMDDCC) + +c Indices/counters +c ---------------- + integer i,j,k,ii ! loop indices + + integer nrpts4QC_pre ! original number of input merged (mass + wind piece) + ! aircraft-type reports (read in from PREPBUFR file) + + integer sortidx(max_reps) ! index if reports are to be written back out in a + ! certain order (determined by calling routine) + + character*11 c_qc(max_reps) ! character QC flags output from NRL QC code + ! 1st char - info about reject (if ob was rejected) + ! 2nd char - reason why time was rejected + ! 3rd char - reason why latitude was rejected + ! 4th char - reason why longitude was rejected + ! 5th char - reason why pressure/atitude was rejected + ! 6th char - readon why temperature was rejected + ! 7th char - reason why wind direction was rejected + ! 8th char - reason why wind speed was rejected + ! 9th char - reason why mixing ratio was rejected + ! 10th char - reason for blacklisting the aircraft + ! 11th char - info about flight phase + + real*8 alat(max_reps) ! latitude + +, alon(max_reps) ! longitude + real ht_ft(max_reps) ! altitude in feet + + integer idt(max_reps) ! time in seconds to anal. time (- before, + after) + character*8 c_acftreg(max_reps)! aircraft registration (tail) number as used in NRL + ! QC processing + character*9 c_acftid(max_reps) ! aircraft flight number as used in NRL QC processing + + real ob_t(max_reps) ! temperature + +c Logicals controlling processing (read in from namelist in main program) +c ----------------------------------------------------------------------- + real trad ! Time window radius for outputting reports (if l_otw=T) + logical l_otw ! T=eliminate reports outside cycle time window radius (trad) + +, l_nhonly ! T=filter out obs outside tropics and Northern Hemisphere + +, l_allev_pf ! T=process latest (likely NRLACQC) events plus all prior + ! events into profiles PREPBUFR-like file + ! **CAUTION: More complete option, but will make code take + ! longer to run!!! + ! F=process ONLY latest (likely NRLACQC) events into profiles + ! PREPBUFR-like file + ! + ! Note : All pre-existing events plus latest (likely NRLACQC) + ! events are always encoded into full PREPBUFR file) + + +, l_prof1lvl ! T=encode merged single(flight)-level aircraft reports with + ! NRLACQC events that are not part of any profile into + ! PREPBUFR-like file, along with merged profiles from + ! aircraft ascents and descents + ! **CAUTION: Will make code take a bit longer to run!! + ! F=do not encode merged single(flight)-level aircraft + ! reports with NRLACQC events into PREPBUFR-like file - + ! only merged profiles from aircraft ascents and descents + ! will be encoded into this file + +, l_mandlvl ! T=interpolate to mandatory levels in profile generation + ! F=do not interpolate to mandatory levels in profile + ! generation + +, tsplines ! T=use tension-splines for aircraft vertical velocity + ! calculation + ! F=use finite-differencing for aircraft vertical velocity + ! calculation + + +c Logicals controlling processing (not read in from namelist in main program) +c --------------------------------------------------------------------------- + logical l_operational ! Run program in operational mode if true + +c Counters +c -------- + integer elim_knt(3) ! Count of reports eliminated and kept + ! 1 - # of merged reports outside time radius (prior to any + ! geographical domain checking) + ! 2 - # of merged reports outside geographical domain (had + ! passed time window radius check) + ! 3 - # of merged reports passing both time window radius + ! and geographical domain checks and thus retained + ! for eventual processing into PREPBUFR-like profiles + ! file + +c Variables used to write data to output PREPBUFR-like file in sorted order +c ------------------------------------------------------------------------- + character*8 msgtyp2wrt ! BUFR message type to write to output PREPBUFR-like file + + integer mxlv ! maximum number of report levels allowed in aircraft + ! profiles + character*6 cmxlv ! character form of mxlv + + integer mxnmev ! maximum number of events allowed in stack + + integer lvlsinprof(mxlv) ! array containing a list of pressure levels that are + ! present in the current profile + + logical l_newprofile ! T = start a new profile + + integer nprofiles ! number of "profile" reports identified + +, nprofiles_encoded ! number of "profile" reports actually encoded into + ! PREPBUFR-like file + +, mxe4prof ! maximum number of events in a single-level merged report + ! (i.e., the maximum amongst the number of pressure, + ! moisture, temperature, altitude, u/v wind and dir/speed + ! wind events) + +, nlvinprof ! number of levels in a profile + +, nlvinprof_last ! index for level number of last level (for duplicate + ! pressure level removal option #1) + +, nlvinprof_temp ! temporary level number index needed for duplicate + ! pressure level removal + + character*8 tail_curr, ! aircraft registration (tail) number of current report + + tail_prev ! aircraft registration (tail) number of previous report + + character*9 flt_curr, ! flight number of current report + + flt_prev ! flight number of previous report + + real elv_curr, ! elevation of current report + + elv_prev ! elevation of previous report + + integer idt_curr, ! time of current report + + idt_prev ! time of previous report + + integer idz_curr, ! altitude of current report + + idz_prev ! altitude of previous report + + real*8 hdr2wrt(15) ! array used to pass header info to subroutine + ! sub2mem_mer + character*8 c_sid ! SID from PREPBUFR file = Site ID + equivalence(c_sid,hdr2wrt(1)) + + real*8 drinfo_accum(3,mxlv) ! array used to accumulate drift info across profile + ! levels + + real*8 acft_seq_accum(2,mxlv) ! array used to accumulate ACFT_SEQ (PCAT - + ! temperature precision, POAF - phase of flight) + ! info across profile levels + +, mstq_accum(1,mxlv) ! array used to accumulate moisture QC marks across + ! profile levels + +, cat_accum(1,mxlv) ! array used to accumulate level category markers + ! across profile levels + +, elv_accum(1,mxlv) ! array used to accumulate elevation across profile + ! levels + +, rpt_accum(1,mxlv) ! array used to accumulate reported obs time across + ! profile levels + +, tcor_accum(1,mxlv) ! array used to accumulate time correction indicator + ! across profile levels + +, rct_accum(1,mxlv) ! array used to accumulate receipt time across + ! profile levels + + real*8 pevn_accum(4,mxlv,mxnmev)! array used to accumulate pressure data/events for a + ! single profile, across profile levels + +, pbg_accum(3,mxlv) ! array used to accumulate pressure background info + ! (POE, PFC, PFCMOD) for a single profile, across + ! profile levels + +, ppp_accum(3,mxlv) ! array used to accumulate pressure post-processing + ! info (PAN, PCL, PCS) for a single profile, across + ! profile levels + + real*8 qevn_accum(4,mxlv,mxnmev)! array used to accumulate moisture data/events for a + ! single profile, across profile levels + +, qbg_accum(3,mxlv) ! array used to accumulate moisture background info + ! (QOE, QFC, QFCMOD) for a single profile, across + ! profile levels + +, qpp_accum(3,mxlv) ! array used to accumulate moisture post-processing + ! info (QAN, QCL, QCS) for a single profile, across + ! profile levels + + real*8 tevn_accum(4,mxlv,mxnmev)! array used to accumulate temperature data/events + ! for a single profile, across profile levels + +, tbg_accum(3,mxlv) ! array used to accumulate temperature background + ! info (TOE, TFC, TFCMOD) for a single profile, + ! across profile levels + +, tpp_accum(3,mxlv) ! array used to accumulate temperature post- + ! processing info (TAN, TCL, TCS) for a single + ! profile, across profile levels + + real*8 zevn_accum(4,mxlv,mxnmev)! array used to accumulate altitude data/events for a + ! single profile, across profile levels + +, zbg_accum(3,mxlv) ! array used to accumulate altitude background info + ! (ZOE, ZFC, ZFCMOD) for a single profile, across + ! profile levels + +, zpp_accum(3,mxlv) ! array used to accumulate altitude post-processing + ! info (ZAN, ZCL, ZCS) for a single profile, across + ! profile levels + + real*8 wuvevn_accum(5,mxlv,mxnmev)! array used to accumulate wind data/events (u/v + ! components) for a single profile, across profile + ! levels + +, wuvbg_accum(5,mxlv) ! array used to accumulate wind background info (WOE, + ! UFC, VFC, UFCMOD, VFCMOD) for a single profile, + ! across profile levels + +, wuvpp_accum(6,mxlv) ! array used to accumulate wind post-processing info + ! (UAN, VAN, UCL, VCL, UCS, VCS) for a single + ! profile, across profile levels + + real*8 wdsevn_accum(5,mxlv,mxnmev)! array used to accumulate wind data/events + ! (direction/speed) for a single profile, across + ! profile levels + + character*11 c_qc_accum(mxlv) ! array used to accumulate NRLACQC quality information + ! on individual obs in a profile, across profile + ! levels + +c Summary counters +c ---------------- + integer num_events_prof ! total number of events on an ob, across all levels, + ! across all reports, written in the PREPBUFR-like + ! (profiles) file (this value is the same for each + ! ob type) + +c Mandatory levels settings +c ------------------------- + integer maxmandlvls ! maxmum number of mandatory pressure levels to + ! consider for aircraft profiles + parameter(maxmandlvls = 9) + + integer mandlvls(maxmandlvls) ! list of mandatory pressure levels to consider for + ! aircraft profiles + + data mandlvls/1000,1500,2000,3000,4000,5000,7000,8500,10000/ + +c Variables used to hold original aircraft data read from input PREPBUFR file - necessary for +c carrying data through program so that it can be later written to output PREPBUFR-like +c profiles file from memory instead of going back to input PREPBUFR file and re-reading that +c file before adding any NRLACQC events +c ------------------------------------------------------------------------------------------- + integer nevents(max_reps,6) ! array tracking number of events for variables for + ! each report: + ! 1 - number of pressure events + ! 2 - number of moisture events + ! 3 - number of temperature events + ! 4 - number of altitude events + ! 5 - number of wind (u/v) events + ! 6 - number of wind (direction/speed) events + + real*8 pob_ev(max_reps,mxnmev) ! POB values for each report, including all events + +, pqm_ev(max_reps,mxnmev) ! PQM values for each report, including all events + +, ppc_ev(max_reps,mxnmev) ! PPC values for each report, including all events + +, prc_ev(max_reps,mxnmev) ! PRC values for each report, including all events + +, zob_ev(max_reps,mxnmev) ! ZOB values for each report, including all events + +, zqm_ev(max_reps,mxnmev) ! ZQM values for each report, including all events + +, zpc_ev(max_reps,mxnmev) ! ZPC values for each report, including all events + +, zrc_ev(max_reps,mxnmev) ! ZRC values for each report, including all events + +, tob_ev(max_reps,mxnmev) ! TOB values for each report, including all events + +, tqm_ev(max_reps,mxnmev) ! TQM values for each report, including all events + +, tpc_ev(max_reps,mxnmev) ! TPC values for each report, including all events + +, trc_ev(max_reps,mxnmev) ! TRC values for each report, including all events + +, qob_ev(max_reps,mxnmev) ! QOB values for each report, including all events + +, qqm_ev(max_reps,mxnmev) ! QQM values for each report, including all events + +, qpc_ev(max_reps,mxnmev) ! QPC values for each report, including all events + +, qrc_ev(max_reps,mxnmev) ! QRC values for each report, including all events + +, uob_ev(max_reps,mxnmev) ! UOB values for each report, including all events + +, vob_ev(max_reps,mxnmev) ! VOB values for each report, including all events + +, wqm_ev(max_reps,mxnmev) ! WQM values for each report, including all events + +, wpc_ev(max_reps,mxnmev) ! WPC values for each report, including all events + +, wrc_ev(max_reps,mxnmev) ! WRC values for each report, including all events + +, ddo_ev(max_reps,mxnmev) ! DDO values for each report, including all events + +, ffo_ev(max_reps,mxnmev) ! FFO values for each report, including all events + +, dfq_ev(max_reps,mxnmev) ! DFQ values for each report, including all events + +, dfp_ev(max_reps,mxnmev) ! DFP values for each report, including all events + +, dfr_ev(max_reps,mxnmev) ! DFR values for each report, including all events + + +, hdr(max_reps,15) ! SID XOB YOB DHR ELV TYP T29 TSB ITP SQN PROCN RPT + ! TCOR RSRD EXRSRD + +, acid(max_reps) ! ACID + +, rct(max_reps) ! RCT + +, mstq(max_reps) ! MSTQ + +, cat(max_reps) ! CAT + + +, pbg(max_reps,3) ! POE PFC PFCMOD + +, zbg(max_reps,3) ! ZOE ZFC ZFCMOD + +, tbg(max_reps,3) ! TOE TFC TFCMOD + +, qbg(max_reps,3) ! QOE QFC QFCMOD + +, wbg(max_reps,5) ! WOE UFC VFC UFCMOD VFCMOD + + +, ppp(max_reps,3) ! PAN PCL PCS + +, zpp(max_reps,3) ! ZAN ZCL ZCS + +, tpp(max_reps,3) ! TAN TCL TCS + +, qpp(max_reps,3) ! QAN QCL QCS + +, wpp(max_reps,6) ! UAN VAN UCL VCL UCS VCS + + +, drinfo(max_reps,3) ! XOB YOB DHR + +, acft_seq(max_reps,2) ! PCAT POAF + + real*8 acid_last_profile ! ACID (aircraft flight number) for last (or only) + ! MDCRS or AMDAR (LATAM only) report in profile (passed + ! into subroutine sub2mem_mer) + + character*9 c_acftid_last_profile ! aircraft flight number (as processed by NRL QC + ! procesing) for last (or only) report in profile + ! (passed into subroutine sub2mem_mer for printing + ! purposes only) + + character*8 c_acftreg_last_profile ! aircraft tail number (as processed by NRL QC + ! procesing) for last (or only) report in profile + ! (passed into subroutine sub2mem_mer for printing + ! purposes only) + + real del_time ! report time difference between two levels, used by + ! profile gross check + +, del_hght ! report time difference between two levels, used by + ! profile gross check + +, vvel ! vertical velocity between two levels, used by profile + ! gross check + +c Misc. +c ----- + integer i_option ! Duplicate pressure removal option (1 or 2) + +, lwr ! machine word length in bytes (either 4 or 8) + + real nrlacqc_pc ! PREPBUFR program code for the NRLACQC step + +ccccc integer iprint ! Switch controlling extra diagnostic printout + +c ******************************************************************* + +c Initialize variables +c -------------------- + + tail_prev = 'XXXXXXXX' + flt_prev = 'XXXXXXXXX' + elv_prev = 99999 + idt_prev = 99999 + idz_prev = 99999 + + mxe4prof = 0 + nlvinprof = 0 + nlvinprof_last = 0 + + lvlsinprof = 99999 + + pevn_accum = bmiss + pbg_accum = bmiss + ppp_accum = bmiss + + tevn_accum = bmiss + tbg_accum = bmiss + tpp_accum = bmiss + + qevn_accum = bmiss + qbg_accum = bmiss + qpp_accum = bmiss + + zevn_accum = bmiss + zbg_accum = bmiss + zpp_accum = bmiss + + wuvevn_accum = bmiss + wuvbg_accum = bmiss + wuvpp_accum = bmiss + + wdsevn_accum = bmiss + + drinfo_accum = bmiss + acft_seq_accum = bmiss + mstq_accum = bmiss + cat_accum = bmiss + elv_accum = bmiss + rpt_accum = bmiss + tcor_accum = bmiss + rct_accum = bmiss + + c_qc_accum = 'XXXXXXXXXXX' + + hdr2wrt = bmiss + + acid_last_profile = bmiss + c_acftid_last_profile = ' ' + c_acftreg_last_profile = ' ' + + nprofiles = 0 + nprofiles_encoded = 0 + mevwrt = 0 ! DAK: This is a "dummy" variable, not used anywhere. For some + ! reason if one removes this, moves its declaration (look + ! above) to any other place in this subr., changes the + ! dimension, or does not initialize it as zero (here) the + ! CCS XLF compiler can fail under -O3 with debugging turned + ! on ("An error occurred during code generation. The code + ! generation return code was 40." "Compilation failed for + ! file output_acqc_prof.f." -- Not sure what might happen + ! with ifort compiler on WCOSS + + elim_knt = 0 + num_events_prof = 0 + + +c Start subroutine +c ---------------- + write(*,*) + write(*,*) '***************************' + write(*,*) 'Welcome to output_acqc_prof' + call system('date') + write(*,*) '***************************' + write(*,*) + + write(*,*) + write(*,'(" --> Output to PREPBUFR-like file (holding merged QCd", + + " aircraft profile rpts & when l_prof1lvl=T single", + + "(flight)-level aircraft rpts)")') + write(*,*) + + if(.not.l_operational) then ! this is currently invoked because l_operational + ! is hardwired to F for l_ncep=T + +c Write merged profile reports and resulting QC decisions to an output file for later perusal +c ------------------------------------------------------------------------------------------- + + open(52,file='merged.profile_reports.post_acftobs_qc.sorted', + + form='formatted') + write(52,*) + write(52,'(" Final listing of all aircraft profile reports in ", + + "pseudo-PREPBUFR file after NRLACQC")') + write(52,'(" -------------------------------------------------", + + "----------------------------------")') + write(52,*) + write(52,'(" TAMDAR reports here replace characters 1-3 of ", + + "manufactured flight # (''000'') with (''TAM'') in ", + + "order to create truncated tail # ''TAM'' for ", + + "NRLACQC sorting - the PREPBUFR file continues to ", + + "encode ''000'' in")') + write(52,'(" characters 1-3 of manufactured flight # for ", + + "TAMDAR (stored as both ''SID'' and ''ACID'')")') + + write(52,*) + write(52,'(" AIREP and PIREP reports report only a flight # ", + + "(manufactured for PIREPs) - a tail # for NRLACQC ", + + "sorting is created by truncating the flight # - ", + + "the PREPBUFR file will not encode these truncated ", + + "tail #''s")') + + write(52,*) + write(52,'(" All AMDAR reports except LATAM report only a tail", + + " # - this is stored as both flight # and tail # for", + + " NRLACQC sorting - the PREPBUFR file continues to ", + + "encode only tail # (stored in ''SID'')")') + write(52,*) + write(52,'(" AMDAR reports from LATAM report both a tail # and", + + " a flight # - these are used as reported for ", + + "NRLACQC sorting - the PREPBUFR file continues to ", + + "encode both tail # and flight # (as ''SID'' and ", + + "''ACID'',")') + write(52,*) 'resp.)' + write(52,*) + write(52,'(" MDCRS reports from ARINC report both a tail # and", + + " a flight # - these are used as reported for", + + " NRLACQC sorting - the PREPBUFR file continues to ", + + "encode both tail # and flight # (as ''SID'' and ", + + "''ACID'',")') + write(52,*) 'resp.)' + + write(52,*) + write(52,3001) + 3001 format(172x,'! _PREPBUFR_QMs_!NRLACQC_REASON_CODE'/ + + 'index flight tail num itp pf lat lon', + + ' time hght pres temp/evnt spec_h/evnt uwnd ', + + 'vwnd/evnt t-prec !__qc_flag__!rcptm mstq cat wspd ', + + 'wdir rtyp ! Pq Zq Tq Qq Wq!Prc Zrc Trc Qrc ', + + 'Wrc'/ + + '----- --------- -------- --- -- -------- --------', + + '- ------ ----- ------ --------- ----------- ------ ', + + '--------- ------ -----------!----- ---- --- ----- ', + + '---- ---- ! -- -- -- -- --!--- --- --- --- ', + + '---') + endif +C-------------------------------------------------------------------------------------------- +C Options for handling duplicate pressures read in for a profile: +C Option 1: For duplicate pressures read in for a profile, the first duplicate read in is +C tossed and the second one is kept. Note: This is how the code originally +C performed this duplicate check. Updated logic to make code run faster may cause +C this option to not always work as expected - not sure. Also, when debugging is +C turned on, this option may not compile unless -qhot is added to FFLAGS in +C makefile (not always the case, however). +C Option 2: For duplicate pressures read in for a profile, the second duplicate read in is +C tossed. This appears to be less problematic than option 1. +C Currently Option 2 is selected in this code. + i_option = 2 +C-------------------------------------------------------------------------------------------- + +c Now, loop over NRLACQC arrays and write aircraft type reports to output file in sorted +c order as specified by sortidx +c -------------------------------------------------------------------------------------- + loop1: do i = 1,nrpts4QC_pre + j = sortidx(i) + +ccccc print 4077, j,acid(j),rct(j) +c4077 format(1x,'for j = ',i6,', acid(j) = ',a8,', rct(j) = ',f10.3) + +c Check to be sure the report is within the requested time window (defined by namelist switch +c trad) and it is within the requested geographical domain (here north of 20S latitude, if +c namelist switch l_nhonly is true) +c {Note: alat(j) and idt(j) will have already been updated with rehabilitated values if +c NRLACQC performed this task, so these checks will be more precise ...} +c ------------------------------------------------------------------------------------------- + + if(l_otw) then ! check if report is outside time window (prior to any geographical + ! domain checking) + if(idt(j).lt.-trad*3600..or.idt(j).gt.trad*3600.) then + elim_knt(1) = elim_knt(1) + 1 + cycle ! skip processing of this report, move on to next report + endif + endif + + if(l_nhonly) then ! if report passed time window radius check, then check to see if + ! it is outside geographical domain (i.e., south of 20S) + if(alat(j).lt.-20.0) then + elim_knt(2) = elim_knt(2) + 1 + cycle ! skip processing of this report, move on to next report + endif + endif + +c If this point is reached, the report is not to be eliminated +c ------------------------------------------------------------ +ccccc print *, 'keep this report!' + +c Counter for number of merged reports kept + elim_knt(3) = elim_knt(3) + 1 + +c Check if this ob should be included in current profile +c ------------------------------------------------------ + l_newprofile = .false. + + tail_curr = c_acftreg(j) + flt_curr = c_acftid(j) + elv_curr = ht_ft(j) + idt_curr = idt(j) + idz_curr = zob_ev(j,nevents(j,4)) + + if(tail_curr.eq.tail_prev .and.flt_curr.eq.flt_prev) then ! report may be part of current profile; need to make + ! sure it's not the start of a separate profile from + ! the same aircraft and flight + +ccccc iprint=0 +ccccc if(tail_curr.eq.'MSHWUURA ') iprint=1 +ccccc if(flt_curr.eq.'AFZA41 ') iprint=1 + +c By this point, reports have been sorted with a sort key of: +c +c type//phase-of-flight//tail//flight//time//elevation//lat//lon +c +c (see csort_wbad in main program) - phase-of-flight in c_qc(11:11) indicates that the +c report is indeed part of an ascent or descent - if tail and flight number are equal, check +c for elev(n)<= for ascents (c_qc(11:11) = a or A) and for elev(n) >=elev(n-1) for descents +c (c_qc(11:11) = d or D) -- reaching these elevation criteria will signal the start of a new +c profile +c ------------------------------------------------------------------------------------------- + if( + + ((c_qc(j)(11:11).eq.'a' .or. + + c_qc(j)(11:11).eq.'A') .and. + + (elv_curr .lt. elv_prev)) .or. ! new profile from the same aircraft/flight + + c_qc(j)(11:11).eq.'I' .or. ! perhaps the aircraft made a stop + + c_qc(j)(11:11).eq.'L' .or. ! somewhere and the flight number didn't + + c_qc(j)(11:11).eq.'N' .or. ! change - or, this report is isolated (I), + + c_qc(j)(11:11).eq.'U' .or. ! level (L), or its ascent/descent status is + + c_qc(j)(11:11).eq.'-' .or. ! unknown (U). Need to close off the + + ((c_qc(j)(11:11).eq.'d' .or. ! current profile, write it to output, + + c_qc(j)(11:11).eq.'D') .and. ! and start a new one + + (elv_curr .gt. elv_prev)) + + ) then + +ccccc if(iprint.eq.1) print *,'new profile - same flight number' + + l_newprofile = .true. + nprofiles = nprofiles + 1 + + else + +ccccc if(iprint.eq.1) print *,'keep accumulating' + + ! keep accumulating data into the current profile + +c Perform a gross check on the report times of adjacent levels in the "profile" ... +C Stop accumulating levels and start a new profile on this level if either: +C 1) The report time difference between this level and the previous level is > 1500 sec +C 2) The report time difference between this level and the previous level is > 1000 sec +C and 1 + ! still come back as single-level + ! reports - this check keeps them + ! out of PREPBUFR-like file when + ! l_prof1lvl=F + nprofiles_encoded = nprofiles_encoded + 1 + +ccccc if(iprint.eq.1) print *,'call writsb - 1st location' + + call writsb(proflun) + endif + endif + +c Clear out accumulation arrays and start over with clear arrays for next profile +c ------------------------------------------------------------------------------- + nlvinprof = 0 + nlvinprof_last = 0 + + lvlsinprof = 99999 + + pevn_accum = bmiss + pbg_accum = bmiss + ppp_accum = bmiss + + qevn_accum = bmiss + qbg_accum = bmiss + qpp_accum = bmiss + + tevn_accum = bmiss + tbg_accum = bmiss + tpp_accum = bmiss + + zevn_accum = bmiss + zbg_accum = bmiss + zpp_accum = bmiss + + wuvevn_accum = bmiss + wuvbg_accum = bmiss + wuvpp_accum = bmiss + + wdsevn_accum = bmiss + + drinfo_accum = bmiss + acft_seq_accum = bmiss + mstq_accum = bmiss + cat_accum = bmiss + elv_accum = bmiss + rpt_accum = bmiss + tcor_accum = bmiss + rct_accum = bmiss + + c_qc_accum = 'XXXXXXXXXXX' + + hdr2wrt = bmiss + + mxe4prof = 0 + + endif ! l_newprofile + +c Determine message date and type for output PREPBUFR-like file +c ------------------------------------------------------------- + read(cdtg_an,'(i10.10)') icdtg_an + if(mod(int(hdr(j,6)),100).eq.33) then + msgtyp2wrt = 'AIRCAR' + else + msgtyp2wrt = 'AIRCFT' + endif + + if(i_option.eq.1) then + nlvinprof = nlvinprof_last + 1 + else + nlvinprof = nlvinprof + 1 + endif + + if(nlvinprof.gt.mxlv) then +C....................................................................... +C There are more levels in profile than "mxlv" -- do not process any more levels +C ------------------------------------------------------------------------------ + print 53, mxlv,mxlv + 53 format(/' #####> WARNING: THERE ARE MORE THAN ',I6,' LEVELS IN ', + + 'THIS PROFILE -- WILL CONTINUE ON PROCESSING ONLY ',I6,' LEVELS', + + ' FOR THIS PROFILE'/) + write(cmxlv,'(i6)') mxlv + call system('[ -n "$jlogfile" ] && $DATA/postmsg'// + + ' "$jlogfile" "***WARNING:'//cmxlv//' AIRCRAFT PROFILE '// + + 'LEVEL LIMIT EXCEEDED IN PREPOBS_PREPACQC, ONLY '// + + cmxlv//' LEVELS PROCESSED"') + exit loop1 +C....................................................................... + endif + +c Subroutine sub2mem_um will update events in memory for this single-level "merged" report - +c upon output the *_ev arrays will contain the events generated from the NRLACQC decisions +c ------------------------------------------------------------------------------------------ + +ccccc if(iprint.eq.1) print *,'call sub2mem_um' + + call sub2mem_um(c_qc(j),max_reps,mxnmev,j,nevents, + + pob_ev,pqm_ev,ppc_ev,prc_ev, + + zob_ev,zqm_ev,zpc_ev,zrc_ev, + + tob_ev,tqm_ev,tpc_ev,trc_ev, + + qob_ev,qqm_ev,qpc_ev,qrc_ev, + + uob_ev,vob_ev,wqm_ev,wpc_ev,wrc_ev, + + nrlacqc_pc,l_allev_pf) + + mxe4prof = max(mxe4prof,nevents(j,1),nevents(j,2),nevents(j,3), + + nevents(j,4),nevents(j,5),nevents(j,6)) + + +c Gather data into profile arrays before actually writing profile to output file +c ------------------------------------------------------------------------------ + +c Get header data +c --------------- + hdr2wrt(:) = hdr(j,:) + +ccccc if(iprint.eq.1) print *,'HDR2WRT: ',hdr2wrt + +c ------------------------------------------------------------ +c Store pressure events, background data, analysis, climo data +c ------------------------------------------------------------ + lvlsinprof(nlvinprof) = int(pob_ev(j,nevents(j,1))*10) + if(i_option.eq.1) nlvinprof_last = nlvinprof + nlvinprof_temp = 0 + +ccccc if(iprint.eq.1) print *,'nlvinprof = ',nlvinprof + + if(nlvinprof.gt.1) then + do ii=1,nlvinprof-1 + +ccccc if(iprint.eq.1) print *,'new ii: lvlsinprof(nlvinprof), ', +ccccc+ 'lvlsinprof(ii): ', +ccccc+ lvlsinprof(nlvinprof), +ccccc+ lvlsinprof(ii) + + if(lvlsinprof(nlvinprof).eq.lvlsinprof(ii)) then + +ccccc if(i_option.eq.1) then +ccccc print'(" WARNING: Pressure level ",I0," was previously", +ccccc+ " filled for this report - index ",I0," refill ", +ccccc+ "with this one !!")', lvlsinprof(nlvinprof),ii +ccccc else +ccccc print'(" WARNING: Pressure level ",I0," was previously", +ccccc+ " filled for this report - index ',I0,'keep it,", +ccccc+ " toss this one !!")', lvlsinprof(nlvinprof),ii +ccccc endif +ccccc print *, hdr2wrt + + nlvinprof_temp = ii + exit + endif + enddo + endif + if(nlvinprof_temp.gt.0) then + if(i_option.eq.1) then + nlvinprof_last = nlvinprof - 1 + nlvinprof = nlvinprof_temp ! DAK: W/ DEBUG ON **MAY** NOT COMPFILE UNLESS ADD + ! -qhot + else + nlvinprof = nlvinprof - 1 + cycle ! skip processing + endif + endif + + if(l_prof1lvl.or.nlvinprof.gt.1) then + acid_last_profile = acid(j) + c_acftid_last_profile = c_acftid(j) + c_acftreg_last_profile = c_acftreg(j) + endif + +c Store non-NRLACQC events in the "profile" arrays before adding any new events (done later +c in subroutine sub2mem_mer) +c ----------------------------------------------------------------------------------------- + pevn_accum(1,nlvinprof,1:nevents(j,1))= pob_ev(j,1:nevents(j,1)) + pevn_accum(2,nlvinprof,1:nevents(j,1))= pqm_ev(j,1:nevents(j,1)) + pevn_accum(3,nlvinprof,1:nevents(j,1))= ppc_ev(j,1:nevents(j,1)) + pevn_accum(4,nlvinprof,1:nevents(j,1))= prc_ev(j,1:nevents(j,1)) + +c Background info +c --------------- + pbg_accum(:,nlvinprof) = pbg(j,:) ! single-level upon input + +c Post processing info +c -------------------- + ppp_accum(:,nlvinprof) = ppp(j,:) ! single-level upon input + +c ------------------------------------------------------------ +c Store altitude events, background data, analysis, climo data +c ------------------------------------------------------------ + +c Store non-NRLACQC events in the "profile" arrays before adding any new events (done later +c in subroutine sub2mem_mer) +c ----------------------------------------------------------------------------------------- + zevn_accum(1,nlvinprof,1:nevents(j,4))= zob_ev(j,1:nevents(j,4)) + zevn_accum(2,nlvinprof,1:nevents(j,4))= zqm_ev(j,1:nevents(j,4)) + zevn_accum(3,nlvinprof,1:nevents(j,4))= zpc_ev(j,1:nevents(j,4)) + zevn_accum(4,nlvinprof,1:nevents(j,4))= zrc_ev(j,1:nevents(j,4)) + +c Background info +c --------------- + zbg_accum(:,nlvinprof) = zbg(j,:) ! single-level upon input + +c Post processing info +c -------------------- + zpp_accum(:,nlvinprof) = zpp(j,:) ! single-level upon input + +c Get drift data - use XOB YOB DHR for drift coordinates when accumulating data into profiles +c ------------------------------------------------------------------------------------------- + drinfo_accum(:,nlvinprof) = drinfo(j,:) + +c Get time correction factor +c -------------------------- + tcor_accum(1,nlvinprof) = hdr(j,13) + +c ------------------------------------------------------------------------- +c ------------------------------------------------------------------------- +c Take into account possible rehabilitation of certain paramters by NRLACQC +c - these will be written into profiles rather than original values +c - Note: Right now we do not encode updates to XORG, XCOR, YORG or YCOR +c into PREPBUFR-like profiles file!! +c ------------------------------------------------------------------------- + + + if(c_qc(j)(2:2).eq.'R'.or. ! time reabilitated + + c_qc(j)(3:3).eq.'R'.or. ! latitude reabilitated + + c_qc(j)(4:4).eq.'R'.or. ! longitude reabilitated + + c_qc(j)(5:5).eq.'R'.or. ! pressure/altitude reabilitated + + c_qc(j)(6:6).eq.'R'.or. ! temperature reabilitated + + c_qc(j)(5:5).eq.'r') then ! pressure/altitude reabilitated + print 61 + 61 format(131('v')) + + if(c_qc(j)(2:2).eq.'R') then + +c Case where time was rehabiltated by NRLACQC, make note of it +c ------------------------------------------------------------ + print 62, j,hdr(j,1),hdr(j,3),hdr(j,2),hdr(j,4), + + nint(hdr(j,5)),c_qc(j) + 62 format(' TIME rehab. (prof): input rpt # ',i6,': id ',a8,', lat ', + + f9.5,', lon ',f9.5,', dhr ',f10.5,', hght(m)',i6,', NRLQMS "', + + A11,'"') + print 63, hdr(j,4),nint(hdr(j,4)*3600.) + 63 format(' INPUT time from PRE-QC PREPBUFR file [DHR,idt(sec)] ', + + 'is: ',f10.5,i8) + print 64, idt(j)/3600.,idt(j) + 64 format(' REHAB. (prof) time from acftobs_qc [DHR,idt(sec)] ', + + 'is: ',f10.5,i8,' use this in profile if created') + hdr2wrt(4) = idt(j)/3600. + drinfo_accum(3,nlvinprof) = idt(j)/3600. + hdr2wrt(13) = 3 + tcor_accum(1,nlvinprof) = 3 ! Set time correction indicator (TCOR) to 3 + print 44, tcor_accum(1,nlvinprof) + 44 format(' --> Time correction indicator (TCOR) changed to ',f3.0) + endif + if(c_qc(j)(3:3).eq.'R') then + +c Case where latitude was rehabiltated by NRLACQC, make note of it +c ---------------------------------------------------------------- + print 72, j,hdr(j,1),hdr(j,3),hdr(j,2),hdr(j,4), + + nint(hdr(j,5)),c_qc(j) + 72 format(' LAT rehab. (prof): input rpt # ',i6,': id ',A8,', lat ', + + f9.5,', lon ',f9.5,', dhr ',f10.5,', hght(m)',i6,', NRLQMS "', + + A11,'"') + print 73, hdr(j,3) + 73 format(' INPUT latitude from PRE-QC PREPBUFR file (YOB) is: ', + + f9.5) + print 74, alat(j) + 74 format(' REHAB. (prof) latitude from acftobs_qc (YOB) is: ', + + f9.5,' use this in profile if created') + hdr2wrt(3) = alat(j) + drinfo_accum(2,nlvinprof) = alat(j) + endif + if(c_qc(j)(4:4).eq.'R') then + +c Case where longitude was rehabiltated by NRLACQC, make note of it +c ----------------------------------------------------------------- + print 82, j,hdr(j,1),hdr(j,3),hdr(j,2),hdr(j,4), + + nint(hdr(j,5)),c_qc(j) + 82 format(' LON rehab. (prof): input rpt # ',i6,': id ',A8,', lat ', + + f9.5,', lon ',f9.5,', dhr ',f10.5,', hght(m)',i6,', NRLQMS "', + + A11,'"') + print 83, hdr(j,2) + 83 format(' INPUT longitude from PRE-QC PREPBUFR file (XOB) is: ', + + f9.5) + print 84, alon(j) + 84 format(' REHAB. (prof) longitude from acftobs_qc (XOB) is: ', + + f9.5,' use this in profile if created') + hdr2wrt(2) = alon(j) + drinfo_accum(1,nlvinprof) = alon(j) + endif + if(c_qc(j)(5:5).eq.'R'.or.c_qc(j)(5:5).eq.'r') then + +c Case where pressure/altitude was rehabiltated by NRLACQC, make note of it +c ------------------------------------------------------------------------- + print 92, j,hdr(j,1),hdr(j,3),hdr(j,2),hdr(j,4), + + nint(hdr(j,5)),c_qc(j) + 92 format(' P/A rehab. (prof): input rpt # ',i6,': id ',A8,', lat ', + + f9.5,', lon ',f9.5,', dhr ',f10.5,', hght(m)',i6,', NRLQMS "', + + A11,'"') + print 93 + 93 format(' %%%%%%%%%%'/' %%%%% Currently not accounted for in ', + + 'output PREPBUFR-like profiles file'/' %%%%%%%%%%') + endif + if(c_qc(j)(6:6).eq.'R') then + +c Case where temperature was rehabiltated by NRLACQC, make note of it +c ------------------------------------------------------------------- + print 102, j,hdr(j,1),hdr(j,3),hdr(j,2),hdr(j,4), + + nint(hdr(j,5)),c_qc(j) + 102 format(' TMP rehabilitated: input rpt # ',i6,': id ',A8,', lat ', + + f9.5,', lon ',f9.5,', dhr ',f10.5,', hght(m)',i6,', NRLQMS "', + + A11,'"') + print 93 + endif + print 65 + 65 format(131('^')) + endif +c ------------------------------------------------------------------------- +c ------------------------------------------------------------------------- + +c Get ACFT_SEQ data +c ----------------- + acft_seq_accum(:,nlvinprof) = acft_seq(j,:) + +c Get MSTQ +c -------- + mstq_accum(1,nlvinprof) = mstq(j) + +c Get level category, elevation, reported observation time +c -------------------------------------------------------- + cat_accum(1,nlvinprof) = cat(j) + elv_accum(1,nlvinprof) = hdr(j,5) + rpt_accum(1,nlvinprof) = hdr(j,12) + rct_accum(1,nlvinprof) = rct(j) + +c Check for mandatory levels (CAT = 1), present temperatures (CAT = 2), missing temperatures +c (CAT = 3) + + if(ob_t(j).eq.-9999.) then ! temperature is missing + cat_accum(1,nlvinprof) = 3 + else + cat_accum(1,nlvinprof) = 2 + endif + +c Mandatory level can override other CAT settings + + do k = 1,maxmandlvls + if(lvlsinprof(nlvinprof).eq.mandlvls(k)) then + cat_accum(1,nlvinprof) = 1 + exit ! exit do loop + endif + enddo + +c Get NRLACQC quality string for this ob in the profile +c ----------------------------------------------------- + c_qc_accum(nlvinprof) = c_qc(j) + +c ---------------------------------------------------------- +c Get moisture events, background data, analysis, climo data +c ---------------------------------------------------------- + +c Store non-NRLACQC events in the "profile" arrays before adding any new events (done later +c in subroutine sub2mem_mer) +c ----------------------------------------------------------------------------------------- + qevn_accum(1,nlvinprof,1:nevents(j,2))= qob_ev(j,1:nevents(j,2)) + qevn_accum(2,nlvinprof,1:nevents(j,2))= qqm_ev(j,1:nevents(j,2)) + qevn_accum(3,nlvinprof,1:nevents(j,2))= qpc_ev(j,1:nevents(j,2)) + qevn_accum(4,nlvinprof,1:nevents(j,2))= qrc_ev(j,1:nevents(j,2)) + +c Background info +c --------------- + qbg_accum(:,nlvinprof) = qbg(j,:) ! single-level upon input + +c Post processing info +c -------------------- + qpp_accum(:,nlvinprof) = qpp(j,:) ! single-level upon input + +c ------------------------------------------------------------- +c Get temperature events, background data, analysis, climo data +c ------------------------------------------------------------- + +c Store non-NRLACQC events in the "profile" arrays before adding any new events (done later +c in subroutine sub2mem_mer) +c ----------------------------------------------------------------------------------------- + tevn_accum(1,nlvinprof,1:nevents(j,3))= tob_ev(j,1:nevents(j,3)) + tevn_accum(2,nlvinprof,1:nevents(j,3))= tqm_ev(j,1:nevents(j,3)) + tevn_accum(3,nlvinprof,1:nevents(j,3))= tpc_ev(j,1:nevents(j,3)) + tevn_accum(4,nlvinprof,1:nevents(j,3))= trc_ev(j,1:nevents(j,3)) + +c Background info +c --------------- + tbg_accum(:,nlvinprof) = tbg(j,:) ! single-level upon input + +c Post processing info +c -------------------- + tpp_accum(:,nlvinprof) = tpp(j,:) ! single-level upon input + +c ----------------------------------------------------------------------- +c Get wind (u/v components) events, background data, analysis, climo data +c ----------------------------------------------------------------------- + +c Store non-NRLACQC events in the "profile" arrays before adding any new events (done later +c in subroutine sub2mem_mer) +c ----------------------------------------------------------------------------------------- + wuvevn_accum(1,nlvinprof,1:nevents(j,5)) = + + uob_ev(j,1:nevents(j,5)) + wuvevn_accum(2,nlvinprof,1:nevents(j,5)) = + + vob_ev(j,1:nevents(j,5)) + wuvevn_accum(3,nlvinprof,1:nevents(j,5)) = + + wqm_ev(j,1:nevents(j,5)) + wuvevn_accum(4,nlvinprof,1:nevents(j,5)) = + + wpc_ev(j,1:nevents(j,5)) + wuvevn_accum(5,nlvinprof,1:nevents(j,5)) = + + wrc_ev(j,1:nevents(j,5)) + +c Background info +c --------------- + wuvbg_accum(:,nlvinprof) = wbg(j,:) ! single-level upon input + +c Post Processing info +c -------------------- + wuvpp_accum(:,nlvinprof) = wpp(j,:) ! single-level upon input + +c --------------------------- +c Get wind (dir/speed) events +c --------------------------- + wdsevn_accum(1,nlvinprof,1:nevents(j,6)) = + + ddo_ev(j,1:nevents(j,6)) + wdsevn_accum(2,nlvinprof,1:nevents(j,6)) = + + ffo_ev(j,1:nevents(j,6)) + wdsevn_accum(3,nlvinprof,1:nevents(j,6)) = + + dfq_ev(j,1:nevents(j,6)) + wdsevn_accum(4,nlvinprof,1:nevents(j,6)) = + + dfp_ev(j,1:nevents(j,6)) + wdsevn_accum(5,nlvinprof,1:nevents(j,6)) = + + dfr_ev(j,1:nevents(j,6)) + +c Set tail_prev, flt_prev, elv_prev, idt_prev for comparison to next report to see if we need +c to start a new profile - also set idz_prev for possible gross check +c ------------------------------------------------------------------------------------------- + tail_prev = c_acftreg(j) + flt_prev = c_acftid(j) + elv_prev = ht_ft(j) + idt_prev = idt(j) + idz_prev = zob_ev(j,nevents(j,4)) + +c Close loops here +c ---------------- + enddo loop1 ! i=1,nrpts4QC_pre + + if(l_prof1lvl.or.nlvinprof.gt.1) then + +c Close out last remaining profile and write it to output - open message if necessary +c ----------------------------------------------------------------------------------- + call openmb(proflun,msgtyp2wrt,icdtg_an) + +c Store contents of the current observation (profile or single/flight-level) into BUFRLIB +c memory via subroutine sub2mem_mer +c --------------------------------------------------------------------------------------- + +ccccc print 4079, sortidx(i-1),acid(sortidx(i-1)),acid_last_profile +c4079 format(1x,'2-call sub2mem_mer, last report j-1 = ',i6, +ccccc+ ', acid(j-1) = ',a8,', acid_last_profile = ',a8) + + call sub2mem_mer(proflun,bmiss,mxlv,mxnmev,maxmandlvls,mandlvls, + + msgtyp2wrt,hdr2wrt, + + acid_last_profile, ! use ACID of last (or only) report in profile + + c_acftid_last_profile, ! use aircraft flight # (from NRLACQC) of + ! last (or only) report in profile + + c_acftreg_last_profile,! use aircraft tail # (from NRLACQC) of last + ! (or only) report in profile + + rct_accum,drinfo_accum,acft_seq_accum, + + mstq_accum,cat_accum,elv_accum,rpt_accum, + + tcor_accum, + + pevn_accum,pbg_accum,ppp_accum, + + qevn_accum,qbg_accum,qpp_accum, + + tevn_accum,tbg_accum,tpp_accum, + + zevn_accum,zbg_accum,zpp_accum, + + wuvevn_accum,wuvbg_accum,wuvpp_accum, + + wdsevn_accum,mxe4prof,c_qc_accum, + + num_events_prof,lvlsinprof,nlvinprof, + + nrlacqc_pc,l_mandlvl,tsplines, + + l_operational,lwr) + +c Write the current profile to output +c ----------------------------------- + if(hdr2wrt(6).gt.399.or.l_prof1lvl) then ! sometimes reports with nlvinprof > 1 + ! still come back as single-level reports + ! - this check keeps them out of PREPBUFR- + ! like file when when l_prof1lvl=F + nprofiles_encoded = nprofiles_encoded + 1 + call writsb(proflun) + endif + endif + + if(.not.l_operational) close(52) + +c Output counts +c ------------- + +c Detailed counts of reports eliminated from final PREPBUFR-like file +c ------------------------------------------------------------------- + print * + print *, '----------------------------------------------------' + print *, 'Info about merged aircraft reports not encoded into ' + print *, 'output PREPBUFR-like (profiles) file:' + print *, '----------------------------------------------------' + print * + if(l_otw) then + print 76, trad,elim_knt(1) + 76 format(' Number of merged reports tossed because outside req. ', + + 'time window radius of',F6.2,'hrs (prior to geographical ', + + 'domain checking):',i6/) + else + print *, 'Time window radius check NOT performed, l_otw=',l_otw, + + ' (ZERO reports tossed)' + endif + print * + if(l_nhonly) then + print'(" Number of merged reports passing time window radius ", + + "chk but tossed because outside geographical domain ", + + "(i.e., S of 20S lat): ",I0)', elim_knt(2) + else + print *, 'Geographical domain check not performed, l_nhonly=', + + l_nhonly,' (ZERO reports tossed)' + endif + print * + print *, 'Number of merged reports passing checks and kept: ', + + elim_knt(3) + print * + +c Info about PREPBUFR-like files containing merged profile and (maybe) single(flight)-level +c reports +c ----------------------------------------------------------------------------------------- + print * + print'(" -------------------------------------------------------", + + "-------------------------")' + print'(" Info about QMs applied to merged mass and wind reports", + + " in the PREPBUFR-like file")' + print'(" -------------------------------------------------------", + + "-------------------------")' + print * + print'(" Number of merged ""profile"" reports written to output ", + + "PREPBUFR-like file = "I0)', nprofiles_encoded + print * +! DAK: num_events_prof does not seem to be the right number when single level reports are not +! encoded... + print'(" Total number of events for an ob type, across all ", + + "levels, across all reports, written to output PREPBUFR-", + + "like")' + print'(" (profiles) file = ",I0," (this value is the same for ", + + "each ob type)")', num_events_prof + print * + + write(*,*) + write(*,*) '**************************' + write(*,*) 'output_acqc_prof has ended' + call system('date') + write(*,*) '**************************' + write(*,*) + + return + + end diff --git a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/pietc.f90 b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/pietc.f90 new file mode 100644 index 00000000..c3d56d9e --- /dev/null +++ b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/pietc.f90 @@ -0,0 +1,95 @@ +! +!============================================================================= +module pietc +!============================================================================= +! R. J. Purser (jim.purser@noaa.gov) 2014 +! Some of the commonly used constants (pi etc) mainly for double-precision +! subroutines. +! ms10 etc are needed to satisfy the some (eg., gnu fortran) compilers' +! more rigorous standards regarding the way "data" statements are initialized. +! Zero and the first few units are u0,u1,u2, etc., their reciprocals being, +! o2,o3 etc and their square roots, r2,r3. Reciprocal roots are or2,or3 etc. +!============================================================================= +use pkind, only: dp,dpc +implicit none +logical ,parameter:: T=.true.,F=.false. !<- for pain-relief in logical ops +real(dp),parameter:: & + u0=0,u1=1,mu1=-u1,u2=2,mu2=-u2,u3=3,mu3=-u3,u4=4,mu4=-u4,u5=5,mu5=-u5, & + u6=6,mu6=-u6,o2=u1/2,o3=u1/3,o4=u1/4,o5=u1/5,o6=u1/6, & + pi =3.1415926535897932384626433832795028841971693993751058209749e0_dp, & + pi2=6.2831853071795864769252867665590057683943387987502116419498e0_dp, & + pih=1.5707963267948966192313216916397514420985846996875529104874e0_dp, & + rpi=1.7724538509055160272981674833411451827975494561223871282138e0_dp, & +! Important square-roots + r2 =1.4142135623730950488016887242096980785696718753769480731766e0_dp, & + r3 =1.7320508075688772935274463415058723669428052538103806280558e0_dp, & + r5 =2.2360679774997896964091736687312762354406183596115257242708e0_dp, & + or2=u1/r2,or3=u1/r3,or5=u1/r5, & +! Golden number: + phi=1.6180339887498948482045868343656381177203091798057628621354e0_dp, & +! Euler-Mascheroni constant: + euler=0.57721566490153286060651209008240243104215933593992359880e0_dp, & +! Degree to radians; radians to degrees: + dtor=pi/180,rtod=180/pi, & +! Sines of all main fractions of 90 degrees (down to ninths): + s10=.173648177666930348851716626769314796000375677184069387236241e0_dp,& + s11=.195090322016128267848284868477022240927691617751954807754502e0_dp,& + s13=.222520933956314404288902564496794759466355568764544955311987e0_dp,& + s15=.258819045102520762348898837624048328349068901319930513814003e0_dp,& + s18=.309016994374947424102293417182819058860154589902881431067724e0_dp,& + s20=.342020143325668733044099614682259580763083367514160628465048e0_dp,& + s22=.382683432365089771728459984030398866761344562485627041433800e0_dp,& + s26=.433883739117558120475768332848358754609990727787459876444547e0_dp,& + s30=o2, & + s34=.555570233019602224742830813948532874374937190754804045924153e0_dp,& + s36=.587785252292473129168705954639072768597652437643145991072272e0_dp,& + s39=.623489801858733530525004884004239810632274730896402105365549e0_dp,& + s40=.642787609686539326322643409907263432907559884205681790324977e0_dp,& + s45=or2, & + s50=.766044443118978035202392650555416673935832457080395245854045e0_dp,& + s51=.781831482468029808708444526674057750232334518708687528980634e0_dp,& + s54=.809016994374947424102293417182819058860154589902881431067724e0_dp,& + s56=.831469612302545237078788377617905756738560811987249963446124e0_dp,& + s60=r3*o2, & + s64=.900968867902419126236102319507445051165919162131857150053562e0_dp,& + s68=.923879532511286756128183189396788286822416625863642486115097e0_dp,& + s70=.939692620785908384054109277324731469936208134264464633090286e0_dp,& + s72=.951056516295153572116439333379382143405698634125750222447305e0_dp,& + s75=.965925826289068286749743199728897367633904839008404550402343e0_dp,& + s77=.974927912181823607018131682993931217232785800619997437648079e0_dp,& + s79=.980785280403230449126182236134239036973933730893336095002916e0_dp,& + s80=.984807753012208059366743024589523013670643251719842418790025e0_dp,& +! ... and their minuses: + ms10=-s10,ms11=-s11,ms13=-s13,ms15=-s15,ms18=-s18,ms20=-s20,ms22=-s22,& + ms26=-s26,ms30=-s30,ms34=-s34,ms36=-s36,ms39=-s39,ms40=-s40,ms45=-s45,& + ms50=-s50,ms51=-s51,ms54=-s54,ms56=-s56,ms60=-s60,ms64=-s64,ms68=-s68,& + ms70=-s70,ms72=-s72,ms75=-s75,ms77=-s77,ms79=-s79,ms80=-s80 + +complex(dpc),parameter:: & + c0=(u0,u0),c1=(u1,u0),mc1=-c1,ci=(u0,u1),mci=-ci,cipi=ci*pi, & +! Main fractional rotations, as unimodualr complex numbers: + z000=c1 ,z010=( s80,s10),z011=( s79,s11),z013=( s77,s13),& + z015=( s75,s15),z018=( s72,s18),z020=( s70,s20),z022=( s68,s22),& + z026=( s64,s26),z030=( s60,s30),z034=( s56,s34),z036=( s54,s36),& + z039=( s51,s39),z040=( s50,s40),z045=( s45,s45),z050=( s40,s50),& + z051=( s39,s51),z054=( s36,s54),z056=( s34,s56),z060=( s30,s60),& + z064=( s26,s64),z068=( s22,s68),z070=( s20,s70),z072=( s18,s72),& + z075=( s15,s75),z077=( s13,s77),z079=( s11,s79),z080=( s10,s80),& + z090=ci, z100=(ms10,s80),z101=(ms11,s79),z103=(ms13,s77),& + z105=(ms15,s75),z108=(ms18,s72),z110=(ms20,s70),z112=(ms22,s68),& + z116=(ms26,s64),z120=(ms30,s60),z124=(ms34,s56),z126=(ms36,s54),& + z129=(ms39,s51),z130=(ms40,s50),z135=(ms45,s45),z140=(ms50,s40),& + z141=(ms51,s39),z144=(ms54,s36),z146=(ms56,s34),z150=(ms60,s30),& + z154=(ms64,s26),z158=(ms68,s22),z160=(ms70,s20),z162=(ms72,s18),& + z165=(ms75,s15),z167=(ms77,s13),z169=(ms79,s11),z170=(ms80,s10),& + z180=-z000,z190=-z010,z191=-z011,z193=-z013,z195=-z015,z198=-z018,& + z200=-z020,z202=-z022,z206=-z026,z210=-z030,z214=-z034,z216=-z036,& + z219=-z039,z220=-z040,z225=-z045,z230=-z050,z231=-z051,z234=-z054,& + z236=-z056,z240=-z060,z244=-z064,z248=-z068,z250=-z070,z252=-z072,& + z255=-z075,z257=-z077,z259=-z079,z260=-z080,z270=-z090,z280=-z100,& + z281=-z101,z283=-z103,z285=-z105,z288=-z108,z290=-z110,z292=-z112,& + z296=-z116,z300=-z120,z304=-z124,z306=-z126,z309=-z129,z310=-z130,& + z315=-z135,z320=-z140,z321=-z141,z324=-z144,z326=-z146,z330=-z150,& + z334=-z154,z338=-z158,z340=-z160,z342=-z162,z345=-z165,z347=-z167,& + z349=-z169,z350=-z170 +end module pietc diff --git a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/pkind.f90 b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/pkind.f90 new file mode 100644 index 00000000..8c0124fe --- /dev/null +++ b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/pkind.f90 @@ -0,0 +1,8 @@ +module pkind +private:: one_dpi; integer(8),parameter:: one_dpi=1 +integer,parameter:: dpi=kind(one_dpi) +integer,parameter:: sp=kind(1.0) +integer,parameter:: dp=kind(1.0d0) +integer,parameter:: spc=kind((1.0,1.0)) +integer,parameter:: dpc=kind((1.0d0,1.0d0)) +end module pkind diff --git a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/pmat.f90 b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/pmat.f90 new file mode 100644 index 00000000..3f65fd36 --- /dev/null +++ b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/pmat.f90 @@ -0,0 +1,1086 @@ +! +! ********************************************** +! * MODULE pmat * +! * R. J. Purser, NOAA/NCEP/EMC 1993 * +! * and Tsukasa Fujita, visiting scientist * +! * from JMA. * +! * Major modifications: 2002, 2009, 2012 * +! * jim.purser@noaa.gov * +! * * +! ********************************************** +! +! Utility routines for various linear inversions and Cholesky. +! Dependency: modules pkind, pietc +! Originally, these routines were copies of the purely "inversion" members +! of pmat1.f90 (a most extensive collection of matrix routines -- not just +! inversions). As well as having both single and double precision versions +! of each routine, these versions also make provision for a more graceful +! termination in cases where the system matrix is detected to be +! essentially singular (and therefore noninvertible). This provision takes +! the form of an optional "failure flag", FF, which is normally returned +! as .FALSE., but is returned as .TRUE. when inversion fails. +! In Sep 2012, these routines were collected together into pmat.f90 so +! that all the main matrix routines could be in the same library, pmat.a. +! +! Last modified: +! Keyser (2014-12-12) - print written to unit 41 rather than stdout (for use in +! prepobs_prepacqc program - limits amount of stdout) +! +! DIRECT DEPENDENCIES: +! Modules: pietc, pkind +! +!============================================================================= +module pmat +!============================================================================= +use pkind, only: sp,dp,spc,dpc +use pietc, only: t,f +implicit none +private +public:: ldum,udlmm,inv,L1Lm,LdLm,invl,invu +interface swpvv; module procedure sswpvv,dswpvv,cswpvv; end interface +interface ldum + module procedure sldum,dldum,cldum,sldumf,dldumf,cldumf; end interface +interface udlmm + module procedure sudlmm,dudlmm,cudlmm,sudlmv,dudlmv,cudlmv; end interface +interface inv + module procedure & +sinvmt, dinvmt, cinvmt, slinmmt, dlinmmt, clinmmt, slinmvt, dlinmvt, clinmvt, & +sinvmtf,dinvmtf,cinvmtf,slinmmtf,dlinmmtf,clinmmtf,slinmvtf,dlinmvtf,clinmvtf,& +iinvf + end interface +interface L1Lm; module procedure sL1Lm,dL1Lm,sL1Lmf,dL1Lmf; end interface +interface LdLm; module procedure sLdLm,dLdLm,sLdLmf,dLdLmf; end interface +interface invl; module procedure sinvl,dinvl,slinlv,dlinlv; end interface +interface invu; module procedure sinvu,dinvu,slinuv,dlinuv; end interface + +contains + +!============================================================================= +subroutine sswpvv(d,e)! [swpvv] +!============================================================================= +! Swap vectors +!------------- +real(sp), intent(inout) :: d(:), e(:) +real(sp) :: tv(size(d)) +!============================================================================= +tv = d; d = e; e = tv +end subroutine sswpvv +!============================================================================= +subroutine dswpvv(d,e)! [swpvv] +!============================================================================= +real(dp), intent(inout) :: d(:), e(:) +real(dp) :: tv(size(d)) +!============================================================================= +tv = d; d = e; e = tv +end subroutine dswpvv +!============================================================================= +subroutine cswpvv(d,e)! [swpvv] +!============================================================================= +complex(dpc),intent(inout) :: d(:), e(:) +complex(dpc) :: tv(size(d)) +!============================================================================= +tv = d; d = e; e = tv +end subroutine cswpvv + +!============================================================================= +subroutine sinvmt(a)! [inv] +!============================================================================= +real(sp),dimension(:,:),intent(INOUT):: a +logical :: ff +call sinvmtf(a,ff) +if(ff)stop 'In sinvmt; Unable to invert matrix' +end subroutine sinvmt +!============================================================================= +subroutine dinvmt(a)! [inv] +!============================================================================= +real(dp),dimension(:,:),intent(inout):: a +logical :: ff +call dinvmtf(a,ff) +if(ff)stop 'In dinvmt; Unable to invert matrix' +end subroutine dinvmt +!============================================================================= +subroutine cinvmt(a)! [inv] +!============================================================================= +complex(dpc),dimension(:,:),intent(inout):: a +logical :: ff +call cinvmtf(a,ff) +if(ff)stop 'In cinvmt; Unable to invert matrix' +end subroutine cinvmt +!============================================================================= +subroutine sinvmtf(a,ff)! [inv] +!============================================================================= +! Invert matrix (or flag if can't) +!---------------- +real(sp),dimension(:,:),intent(inout):: a +logical, intent( out):: ff +integer :: m,i,j,jp,l +real(sp) :: d +integer,dimension(size(a,1)) :: ipiv +!============================================================================= +m=size(a,1) +if(m /= size(a,2))stop 'In sinvmtf; matrix passed to sinvmtf is not square' +! Perform a pivoted L-D-U decomposition on matrix a: +call sldumf(a,ipiv,d,ff) +if(ff)then + write(41,'(" In sinvmtf; failed call to sldumf")') + return +endif + +! Invert upper triangular portion U in place: +do i=1,m; a(i,i)=1./a(i,i); enddo +do i=1,m-1 + do j=i+1,m; a(i,j)=-a(j,j)*dot_product(a(i:j-1,j),a(i,i:j-1)); enddo +enddo + +! Invert lower triangular portion L in place: +do j=1,m-1; jp=j+1 + do i=jp,m; a(i,j)=-a(i,j)-dot_product(a(jp:i-1,j),a(i,jp:i-1)); enddo +enddo + +! Form the product of U**-1 and L**-1 in place +do j=1,m-1; jp=j+1 + do i=1,j; a(i,j)=a(i,j)+dot_product(a(jp:m,j),a(i,jp:m)); enddo + do i=jp,m; a(i,j)=dot_product(a(i:m,j),a(i,i:m)); enddo +enddo + +! Permute columns according to ipiv +do j=m-1,1,-1; l=ipiv(j); call sswpvv(a(:,j),a(:,l)); enddo +end subroutine sinvmtf +!============================================================================= +subroutine dinvmtf(a,ff)! [inv] +!============================================================================= +real(DP),dimension(:,:),intent(INOUT):: a +logical, intent( OUT):: ff +integer :: m,i,j,jp,l +real(DP) :: d +integer, dimension(size(a,1)) :: ipiv +!============================================================================= +m=size(a,1) +if(m /= size(a,2))stop 'In inv; matrix passed to dinvmtf is not square' +! Perform a pivoted L-D-U decomposition on matrix a: +call dldumf(a,ipiv,d,ff) +if(ff)then + write(41,'(" In dinvmtf; failed call to dldumf")') + return +endif + +! Invert upper triangular portion U in place: +do i=1,m; a(i,i)=1/a(i,i); enddo +do i=1,m-1 + do j=i+1,m; a(i,j)=-a(j,j)*dot_product(a(i:j-1,j),a(i,i:j-1)); enddo +enddo + +! Invert lower triangular portion L in place: +do j=1,m-1; jp=j+1 + do i=jp,m; a(i,j)=-a(i,j)-dot_product(a(jp:i-1,j),a(i,jp:i-1)); enddo +enddo + +! Form the product of U**-1 and L**-1 in place +do j=1,m-1; jp=j+1 + do i=1,j; a(i,j)=a(i,j)+dot_product(a(jp:m,j),a(i,jp:m)); enddo + do i=jp,m; a(i,j)=dot_product(a(i:m,j),a(i,i:m)); enddo +enddo + +! Permute columns according to ipiv +do j=m-1,1,-1; l=ipiv(j); call dswpvv(a(:,j),a(:,l)); enddo +end subroutine dinvmtf +!============================================================================= +subroutine cinvmtf(a,ff)! [inv] +!============================================================================= +complex(dpc),dimension(:,:),intent(INOUT):: a +logical, intent( OUT):: ff +integer :: m,i,j,jp,l +complex(dpc) :: d +integer, dimension(size(a,1)) :: ipiv +!============================================================================= +m=size(a,1) +if(m /= size(a,2))stop 'In inv; matrix passed to cinvmtf is not square' +! Perform a pivoted L-D-U decomposition on matrix a: +call cldumf(a,ipiv,d,ff) +if(ff)then + write(41,'(" In cinvmtf; failed call to cldumf")') + return +endif + +! Invert upper triangular portion U in place: +do i=1,m; a(i,i)=1/a(i,i); enddo +do i=1,m-1 + do j=i+1,m; a(i,j)=-a(j,j)*sum(a(i:j-1,j)*a(i,i:j-1)); enddo +enddo + +! Invert lower triangular portion L in place: +do j=1,m-1; jp=j+1 + do i=jp,m; a(i,j)=-a(i,j)-sum(a(jp:i-1,j)*a(i,jp:i-1)); enddo +enddo + +! Form the product of U**-1 and L**-1 in place +do j=1,m-1; jp=j+1 + do i=1,j; a(i,j)=a(i,j)+sum(a(jp:m,j)*a(i,jp:m)); enddo + do i=jp,m; a(i,j)=sum(a(i:m,j)*a(i,i:m)); enddo +enddo + +! Permute columns according to ipiv +do j=m-1,1,-1; l=ipiv(j); call cswpvv(a(:,j),a(:,l)); enddo +end subroutine cinvmtf + +!============================================================================= +subroutine slinmmt(a,b)! [inv] +!============================================================================= +real(sp),dimension(:,:),intent(inout):: a,b +logical :: ff +call slinmmtf(a,b,ff) +if(ff)stop 'In slinmmt; unable to invert linear system' +end subroutine slinmmt +!============================================================================= +subroutine dlinmmt(a,b)! [inv] +!============================================================================= +real(dp),dimension(:,:),intent(inout):: a,b +logical :: ff +call dlinmmtf(a,b,ff) +if(ff)stop 'In dlinmmt; unable to invert linear system' +end subroutine dlinmmt +!============================================================================= +subroutine clinmmt(a,b)! [inv] +!============================================================================= +complex(dpc),dimension(:,:),intent(inout):: a,b +logical :: ff +call clinmmtf(a,b,ff) +if(ff)stop 'In clinmmt; unable to invert linear system' +end subroutine clinmmt +!============================================================================= +subroutine slinmmtf(a,b,ff)! [inv] +!============================================================================= +real(SP), dimension(:,:),intent(INOUT):: a,b +logical, intent( OUT):: ff +integer,dimension(size(a,1)) :: ipiv +integer :: m +real(sp) :: d +!============================================================================= +m=size(a,1) +if(m /= size(a,2))stop 'In inv; matrix passed to slinmmtf is not square' +if(m /= size(b,1))& + stop 'In inv; matrix and vectors in slinmmtf have unmatched sizes' +call sldumf(a,ipiv,d,ff) +if(ff)then + write(41,'("In slinmmtf; failed call to sldumf")') + return +endif +call sudlmm(a,b,ipiv) +end subroutine slinmmtf +!============================================================================= +subroutine dlinmmtf(a,b,ff)! [inv] +!============================================================================= +real(dp),dimension(:,:), intent(inout):: a,b +logical, intent( out):: ff +integer, dimension(size(a,1)) :: ipiv +integer :: m +real(dp) :: d +!============================================================================= +m=size(a,1) +if(m /= size(a,2))stop 'In inv; matrix passed to dlinmmtf is not square' +if(m /= size(b,1))& + stop 'In inv; matrix and vectors in dlinmmtf have unmatched sizes' +call dldumf(a,ipiv,d,ff) +if(ff)then + write(41,'("In dlinmmtf; failed call to dldumf")') + return +endif +call dudlmm(a,b,ipiv) +end subroutine dlinmmtf +!============================================================================= +subroutine clinmmtf(a,b,ff)! [inv] +!============================================================================= +complex(dpc),dimension(:,:),intent(INOUT):: a,b +logical, intent( OUT):: ff +integer, dimension(size(a,1)) :: ipiv +integer :: m +complex(dpc) :: d +!============================================================================= +m=size(a,1) +if(m /= size(a,2))stop 'In inv; matrix passed to dlinmmtf is not square' +if(m /= size(b,1))& + stop 'In inv; matrix and vectors in dlinmmtf have unmatched sizes' +call cldumf(a,ipiv,d,ff) +if(ff)then + write(41,'("In clinmmtf; failed call to cldumf")') + return +endif +call cudlmm(a,b,ipiv) +end subroutine clinmmtf + +!============================================================================= +subroutine slinmvt(a,b)! [inv] +!============================================================================= +real(sp), dimension(:,:),intent(inout):: a +real(sp), dimension(:), intent(inout):: b +logical :: ff +call slinmvtf(a,b,ff) +if(ff)stop 'In slinmvt; matrix singular, unable to continue' +end subroutine slinmvt +!============================================================================= +subroutine dlinmvt(a,b)! [inv] +!============================================================================= +real(dp), dimension(:,:),intent(inout):: a +real(dp), dimension(:), intent(inout):: b +logical :: ff +call dlinmvtf(a,b,ff) +if(ff)stop 'In dlinmvt; matrix singular, unable to continue' +end subroutine dlinmvt +!============================================================================= +subroutine clinmvt(a,b)! [inv] +!============================================================================= +complex(dpc), dimension(:,:),intent(inout):: a +complex(dpc), dimension(:), intent(inout):: b +logical :: ff +call clinmvtf(a,b,ff) +if(ff)stop 'In clinmvt; matrix singular, unable to continue' +end subroutine clinmvt +!============================================================================= +subroutine slinmvtf(a,b,ff)! [inv] +!============================================================================= +real(sp),dimension(:,:),intent(inout):: a +real(sp),dimension(:), intent(inout):: b +logical, intent( out):: ff +integer,dimension(size(a,1)) :: ipiv +real(sp) :: d +!============================================================================= +if(size(a,1) /= size(a,2).or. size(a,1) /= size(b))& + stop 'In inv; In slinmvtf; incompatible array dimensions' +call sldumf(a,ipiv,d,ff) +if(ff)then + write(41,'("In slinmvtf; failed call to sldumf")') + return +endif +call sudlmv(a,b,ipiv) +end subroutine slinmvtf +!============================================================================= +subroutine dlinmvtf(a,b,ff)! [inv] +!============================================================================= +real(dp),dimension(:,:),intent(inout):: a +real(dp),dimension(:), intent(inout):: b +logical, intent( out):: ff +integer, dimension(size(a,1)) :: ipiv +real(dp) :: d +!============================================================================= +if(size(a,1) /= size(a,2).or. size(a,1) /= size(b))& + stop 'In inv; incompatible array dimensions passed to dlinmvtf' +call dldumf(a,ipiv,d,ff) +if(ff)then + write(41,'("In dlinmvtf; failed call to dldumf")') + return +endif +call dudlmv(a,b,ipiv) +end subroutine dlinmvtf +!============================================================================= +subroutine clinmvtf(a,b,ff)! [inv] +!============================================================================= +complex(dpc),dimension(:,:),intent(inout):: a +complex(dpc),dimension(:), intent(inout):: b +logical, intent( out):: ff +integer, dimension(size(a,1)) :: ipiv +complex(dpc) :: d +!============================================================================= +if(size(a,1) /= size(a,2).or. size(a,1) /= size(b))& + stop 'In inv; incompatible array dimensions passed to clinmvtf' +call cldumf(a,ipiv,d,ff) +if(ff)then + write(41,'("In clinmvtf; failed call to cldumf")') + return +endif +call cudlmv(a,b,ipiv) +end subroutine clinmvtf + +!============================================================================= +subroutine iinvf(imat,ff)! [inv] +!============================================================================= +! Invert integer square array, imat, if possible, but flag ff=.true. +! if not possible. (Determinant of imat must be +1 or -1 +!============================================================================= +integer,dimension(:,:),intent(INOUT):: imat +logical, intent( OUT):: ff +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-1_dp +real(dp),dimension(size(imat,1),size(imat,1)):: dmat +integer :: m,i,j +!============================================================================= +m=size(imat,1) +if(m /= size(imat,2))stop 'In inv; matrix passed to iinvf is not square' +dmat=imat; call inv(dmat,ff) +if(.not.ff)then + do j=1,m + do i=1,m + imat(i,j)=nint(dmat(i,j)); if(abs(dmat(i,j)-imat(i,j))>eps)ff=t + enddo + enddo +endif +end subroutine iinvf + +!============================================================================= +subroutine sldum(a,ipiv,d)! [ldum] +!============================================================================= +real(sp),intent(inout) :: a(:,:) +real(sp),intent(out ) :: d +integer, intent(out ) :: ipiv(:) +logical:: ff +call sldumf(a,ipiv,d,ff) +if(ff)stop 'In sldum; matrix singular, unable to continue' +end subroutine sldum +!============================================================================= +subroutine dldum(a,ipiv,d)! [ldum] +!============================================================================= +real(dp),intent(inout) :: a(:,:) +real(dp),intent(out ) :: d +integer, intent(out ) :: ipiv(:) +logical:: ff +call dldumf(a,ipiv,d,ff) +if(ff)stop 'In dldum; matrix singular, unable to continue' +end subroutine dldum +!============================================================================= +subroutine cldum(a,ipiv,d)! [ldum] +!============================================================================= +complex(dpc),intent(inout) :: a(:,:) +complex(dpc),intent(out ) :: d +integer, intent(out ) :: ipiv(:) +logical:: ff +call cldumf(a,ipiv,d,ff) +if(ff)stop 'In cldum; matrix singular, unable to continue' +end subroutine cldum +!============================================================================= +subroutine sldumf(a,ipiv,d,ff)! [ldum] +!============================================================================= +! R.J.Purser, NCEP, Washington D.C. 1996 +! SUBROUTINE LDUM +! perform l-d-u decomposition of square matrix a in place with +! pivoting. +! +! <-> a square matrix to be factorized +! <-- ipiv array encoding the pivoting sequence +! <-- d indicator for possible sign change of determinant +! <-- ff: failure flag, set to .true. when determinant of a vanishes. +!============================================================================= +real(SP),intent(INOUT) :: a(:,:) +real(SP),intent(OUT ) :: d +integer, intent(OUT ) :: ipiv(:) +logical, intent(OUT ) :: ff +integer :: m,i, j, jp, ibig, jm +real(SP) :: s(size(a,1)), aam, aa, abig, ajj, ajji, aij +!============================================================================= +ff=f +m=size(a,1) +do i=1,m + aam=0 + do j=1,m + aa=abs(a(i,j)) + if(aa > aam)aam=aa + enddo + if(aam == 0)then + write(41,'("In sldumf; row ",i6," of matrix vanishes")'),i + ff=t + return + endif + s(i)=1/aam +enddo +d=1. +ipiv(m)=m +do j=1,m-1 + jp=j+1 + abig=s(j)*abs(a(j,j)) + ibig=j + do i=jp,m + aa=s(i)*abs(a(i,j)) + if(aa > abig)then + ibig=i + abig=aa + endif + enddo +! swap rows, recording changed sign of determinant + ipiv(j)=ibig + if(ibig /= j)then + d=-d + call sswpvv(a(j,:),a(ibig,:)) + s(ibig)=s(j) + endif + ajj=a(j,j) + if(ajj == 0)then + jm=j-1 + write(41,'(" failure in sldumf:"/" matrix singular, rank=",i3)'),jm + ff=t + return + endif + ajji=1/ajj + do i=jp,m + aij=ajji*a(i,j) + a(i,j)=aij + a(i,jp:m) = a(i,jp:m) - aij*a(j,jp:m) + enddo +enddo +end subroutine sldumf +!============================================================================= +subroutine DLDUMf(A,IPIV,D,ff)! [ldum] +!============================================================================= +real(DP), intent(INOUT) :: a(:,:) +real(DP), intent(OUT ) :: d +integer, intent(OUT ) :: ipiv(:) +logical, intent(OUT ) :: ff +integer :: m,i, j, jp, ibig, jm +real(DP) :: s(size(a,1)), aam, aa, abig, ajj, ajji, aij +!============================================================================= +ff=f +m=size(a,1) +do i=1,m + aam=0 + do j=1,m + aa=abs(a(i,j)) + if(aa > aam)aam=aa + enddo + if(aam == 0)then + write(41,'("In dldumf; row ",i6," of matrix vanishes")'),i + ff=t + return + endif + s(i)=1/aam +enddo +d=1. +ipiv(m)=m +do j=1,m-1 + jp=j+1 + abig=s(j)*abs(a(j,j)) + ibig=j + do i=jp,m + aa=s(i)*abs(a(i,j)) + if(aa > abig)then + ibig=i + abig=aa + endif + enddo +! swap rows, recording changed sign of determinant + ipiv(j)=ibig + if(ibig /= j)then + d=-d + call dswpvv(a(j,:),a(ibig,:)) + s(ibig)=s(j) + endif + ajj=a(j,j) + if(ajj == 0)then + jm=j-1 + write(41,'(" Failure in dldumf:"/" matrix singular, rank=",i3)'),jm + ff=t + return + endif + ajji=1/ajj + do i=jp,m + aij=ajji*a(i,j) + a(i,j)=aij + a(i,jp:m) = a(i,jp:m) - aij*a(j,jp:m) + enddo +enddo +end subroutine DLDUMf +!============================================================================= +subroutine cldumf(a,ipiv,d,ff)! [ldum] +!============================================================================= +use pietc, only: c0 +complex(dpc), intent(INOUT) :: a(:,:) +complex(dpc), intent(OUT ) :: d +integer, intent(OUT ) :: ipiv(:) +logical, intent(OUT ) :: ff +integer :: m,i, j, jp, ibig, jm +complex(dpc) :: ajj, ajji, aij +real(dp) :: aam,aa,abig +real(dp),dimension(size(a,1)):: s +!============================================================================= +ff=f +m=size(a,1) +do i=1,m + aam=0 + do j=1,m + aa=abs(a(i,j)) + if(aa > aam)aam=aa + enddo + if(aam == 0)then + write(41,'("In cldumf; row ",i6," of matrix vanishes")'),i + ff=t + return + endif + s(i)=1/aam +enddo +d=1. +ipiv(m)=m +do j=1,m-1 + jp=j+1 + abig=s(j)*abs(a(j,j)) + ibig=j + do i=jp,m + aa=s(i)*abs(a(i,j)) + if(aa > abig)then + ibig=i + abig=aa + endif + enddo +! swap rows, recording changed sign of determinant + ipiv(j)=ibig + if(ibig /= j)then + d=-d + call cswpvv(a(j,:),a(ibig,:)) + s(ibig)=s(j) + endif + ajj=a(j,j) + if(ajj == c0)then + jm=j-1 + write(41,'(" Failure in cldumf:"/" matrix singular, rank=",i3)'),jm + ff=t + return + endif + ajji=1/ajj + do i=jp,m + aij=ajji*a(i,j) + a(i,j)=aij + a(i,jp:m) = a(i,jp:m) - aij*a(j,jp:m) + enddo +enddo +end subroutine cldumf + +!============================================================================= +subroutine sudlmm(a,b,ipiv)! [udlmm] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1993 +! SUBROUTINE UDLMM +! use l-u factors in A to back-substitute for several rhs in B, using ipiv to +! define the pivoting permutation used in the l-u decomposition. +! +! --> A L-D-U factorization of linear system matrux +! <-> B rt-hand-sides vectors on input, corresponding solutions on return +! --> IPIV array encoding the pivoting sequence +!============================================================================= +integer, dimension(:), intent(in) :: ipiv +real(sp),dimension(:,:),intent(in) :: a +real(sp),dimension(:,:),intent(inout) :: b +integer :: m,i, k, l +real(sp) :: s,aiii +!============================================================================= +m=size(a,1) +do k=1,size(b,2) !loop over columns of b + do i=1,m + l=ipiv(i) + s=b(l,k) + b(l,k)=b(i,k) + s = s - sum(b(1:i-1,k)*a(i,1:i-1)) + b(i,k)=s + enddo + b(m,k)=b(m,k)/a(m,m) + do i=m-1,1,-1 + aiii=1/a(i,i) + b(i,k) = b(i,k) - sum(b(i+1:m,k)*a(i,i+1:m)) + b(i,k)=b(i,k)*aiii + enddo +enddo +end subroutine sudlmm +!============================================================================= +subroutine dudlmm(a,b,ipiv)! [udlmm] +!============================================================================= +integer, dimension(:), intent(in ) :: ipiv +real(dp), dimension(:,:),intent(in ) :: a +real(dp), dimension(:,:),intent(inout) :: b +integer :: m,i, k, l +real(dp) :: s,aiii +!============================================================================= +m=size(a,1) +do k=1, size(b,2)!loop over columns of b + do i=1,m + l=ipiv(i) + s=b(l,k) + b(l,k)=b(i,k) + s = s - sum(b(1:i-1,k)*a(i,1:i-1)) + b(i,k)=s + enddo + b(m,k)=b(m,k)/a(m,m) + do i=m-1,1,-1 + aiii=1/a(i,i) + b(i,k) = b(i,k) - sum(b(i+1:m,k)*a(i,i+1:m)) + b(i,k)=b(i,k)*aiii + enddo +enddo +end subroutine dudlmm +!============================================================================= +subroutine cudlmm(a,b,ipiv)! [udlmm] +!============================================================================= +integer, dimension(:), intent(in ) :: ipiv +complex(dpc),dimension(:,:),intent(in ) :: a +complex(dpc),dimension(:,:),intent(inout) :: b +integer :: m,i, k, l +complex(dpc) :: s,aiii +!============================================================================= +m=size(a,1) +do k=1, size(b,2)!loop over columns of b + do i=1,m + l=ipiv(i) + s=b(l,k) + b(l,k)=b(i,k) + s = s - sum(b(1:i-1,k)*a(i,1:i-1)) + b(i,k)=s + enddo + b(m,k)=b(m,k)/a(m,m) + do i=m-1,1,-1 + aiii=1/a(i,i) + b(i,k) = b(i,k) - sum(b(i+1:m,k)*a(i,i+1:m)) + b(i,k)=b(i,k)*aiii + enddo +enddo +end subroutine cudlmm + +!============================================================================= +subroutine sudlmv(a,b,ipiv)! [udlmv] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1993 +! SUBROUTINE UDLMV +! use l-u factors in A to back-substitute for 1 rhs in B, using ipiv to +! define the pivoting permutation used in the l-u decomposition. +! +! --> A L-D-U factorization of linear system matrix +! <-> B right-hand-side vector on input, corresponding solution on return +! --> IPIV array encoding the pivoting sequence +!============================================================================= +integer, dimension(:), intent(in) :: ipiv +real(sp),dimension(:,:),intent(in) :: a +real(sp),dimension(:), intent(inout) :: b +integer :: m,i, l +real(sp) :: s,aiii +!============================================================================= +m=size(a,1) +do i=1,m + l=ipiv(i) + s=b(l) + b(l)=b(i) + s = s - sum(b(1:i-1)*a(i,1:i-1)) + b(i)=s +enddo +b(m)=b(m)/a(m,m) +do i=m-1,1,-1 + aiii=1/a(i,i) + b(i) = b(i) - sum(b(i+1:m)*a(i,i+1:m)) + b(i)=b(i)*aiii +enddo +end subroutine sudlmv +!============================================================================= +subroutine dudlmv(a,b,ipiv)! [udlmv] +!============================================================================= +integer, dimension(:), intent(in ) :: ipiv(:) +real(dp), dimension(:,:),intent(in ) :: a(:,:) +real(dp), dimension(:), intent(inout) :: b(:) +integer :: m,i, l +real(dp) :: s,aiii +!============================================================================= +m=size(a,1) +do i=1,m + l=ipiv(i) + s=b(l) + b(l)=b(i) + s = s - sum(b(1:i-1)*a(i,1:i-1)) + b(i)=s +enddo +b(m)=b(m)/a(m,m) +do i=m-1,1,-1 + aiii=1/a(i,i) + b(i) = b(i) - sum(b(i+1:m)*a(i,i+1:m)) + b(i)=b(i)*aiii +enddo +end subroutine dudlmv +!============================================================================= +subroutine cudlmv(a,b,ipiv)! [udlmv] +!============================================================================= +integer, dimension(:), intent(in ) :: ipiv(:) +complex(dpc),dimension(:,:),intent(in ) :: a(:,:) +complex(dpc),dimension(:), intent(inout) :: b(:) +integer :: m,i, l +complex(dpc) :: s,aiii +!============================================================================= +m=size(a,1) +do i=1,m + l=ipiv(i) + s=b(l) + b(l)=b(i) + s = s - sum(b(1:i-1)*a(i,1:i-1)) + b(i)=s +enddo +b(m)=b(m)/a(m,m) +do i=m-1,1,-1 + aiii=1/a(i,i) + b(i) = b(i) - sum(b(i+1:m)*a(i,i+1:m)) + b(i)=b(i)*aiii +enddo +end subroutine cudlmv + +!============================================================================= +subroutine sl1lm(a,b) ! [l1lm] +!============================================================================= +! Cholesky, M -> L*U, U(i,j)=L(j,i) +!============================================================================= +real(sp), intent(in ) :: a(:,:) +real(sp), intent(inout) :: b(:,:) +!----------------------------------------------------------------------------- +logical:: ff +call sl1lmf(a,b,ff) +if(ff)stop 'In sl1lm; matrix singular, unable to continue' +end subroutine sl1lm +!============================================================================= +subroutine dl1lm(a,b) ! [l1lm] +!============================================================================= +! Cholesky, M -> L*U, U(i,j)=L(j,i) +!============================================================================= +real(dp), intent(in ) :: a(:,:) +real(dp), intent(inout) :: b(:,:) +!----------------------------------------------------------------------------- +logical:: ff +call dl1lmf(a,b,ff) +if(ff)stop 'In dl1lm; matrix singular, unable to continue' +end subroutine dl1lm + +!============================================================================= +subroutine sl1lmf(a,b,ff)! [L1Lm] +!============================================================================= +! Cholesky, M -> L*U, U(i,j)=L(j,i) +!============================================================================= +real(sp), intent(IN ) :: a(:,:) +real(sp), intent(INOUT) :: b(:,:) +logical :: ff +!----------------------------------------------------------------------------- +integer :: m,j, jm, jp, i +real(sp) :: s, bjji +!============================================================================= +m=size(a,1) +ff=f +do j=1,m + jm=j-1 + jp=j+1 + s = a(j,j) - sum(b(j,1:jm)*b(j,1:jm)) + ff=(S <= 0) + if(ff)then + write(41,'("sL1Lmf detects nonpositive a, rank=",i6)'),jm + return + endif + b(j,j)=sqrt(s) + bjji=1/b(j,j) + do i=jp,m + s = a(i,j) - sum(b(i,1:jm)*b(j,1:jm)) + b(i,j)=s*bjji + enddo + b(1:jm,j) = 0 +enddo +end subroutine sl1lmf +!============================================================================= +subroutine dl1lmf(a,b,ff) ! [L1Lm] +!============================================================================= +real(dp), intent(IN ) :: a(:,:) +real(dp), intent(INOUT) :: b(:,:) +logical :: ff +!----------------------------------------------------------------------------- +integer :: m,j, jm, jp, i +real(dp) :: s, bjji +!============================================================================= +m=size(a,1) +ff=f +do j=1,m + jm=j-1 + jp=j+1 + s = a(j,j) - sum(b(j,1:jm)*b(j,1:jm)) + ff=(s <= 0) + if(ff)then + write(41,'("dL1LMF detects nonpositive A, rank=",i6)'),jm + return + endif + b(j,j)=sqrt(s) + bjji=1/b(j,j) + do i=jp,m + s = a(i,j) - sum(b(i,1:jm)*b(j,1:jm)) + b(i,j)=s*bjji + enddo + b(1:jm,j) = 0 +enddo +return +end subroutine dl1lmf + +!============================================================================= +subroutine sldlm(a,b,d)! [LdLm] +!============================================================================= +! Modified Cholesky decompose Q --> L*D*U, U(i,j)=L(j,i) +!============================================================================= +real(sp), intent(IN ):: a(:,:) +real(sp), intent(INOUT):: b(:,:) +real(sp), intent( OUT):: d(:) +!----------------------------------------------------------------------------- +logical:: ff +call sldlmf(a,b,d,ff) +if(ff)stop 'In sldlm; matrix singular, unable to continue' +end subroutine sldlm +!============================================================================= +subroutine dldlm(a,b,d)! [LdLm] +!============================================================================= +real(dp), intent(IN ):: a(:,:) +real(dp), intent(INOUT):: b(:,:) +real(dp), intent( OUT):: d(:) +!----------------------------------------------------------------------------- +logical:: ff +call dldlmf(a,b,d,ff) +if(ff)stop 'In dldlm; matrix singular, unable to continue' +end subroutine dldlm + +!============================================================================= +subroutine sldlmf(a,b,d,ff) ! [LDLM] +!============================================================================= +! Modified Cholesky decompose Q --> L*D*U +!============================================================================= +real(sp), intent(IN ):: a(:,:) +real(sp), intent(INOUT):: b(:,:) +real(sp), intent( OUT):: d(:) +logical, intent( OUT):: ff +!----------------------------------------------------------------------------- +integer :: m,j, jm, jp, i +real(sp) :: bjji +!============================================================================= +m=size(a,1) +ff=f +do j=1,m + jm=j-1 + jp=j+1 + d(j)=a(j,j) - sum(b(1:jm,j)*b(j,1:jm)) + b(j,j) = 1 + ff=(d(j) == 0) + if(ff)then + write(41,'("In sldlmf; singularity of matrix detected")') + write(41,'("Rank of matrix: ",i6)'),jm + return + endif + bjji=1/d(j) + do i=jp,m + b(j,i)=a(i,j) - dot_product(b(1:jm,j),b(i,1:jm)) + b(i,j)=b(j,i)*bjji + enddo + b(1:jm,j)=0 +enddo +end subroutine sldlmf +!============================================================================= +subroutine dldlmf(a,b,d,ff) ! [LDLM] +!============================================================================= +! Modified Cholesky Q --> L*D*U, U(i,j)=L(j,i) +!============================================================================= +real(dp), intent(IN ) :: a(:,:) +real(dp), intent(INOUT) :: b(:,:) +real(dp), intent( OUT) :: d(:) +logical, intent( OUT) :: ff +!----------------------------------------------------------------------------- +integer :: m,j, jm, jp, i +real(dp) :: bjji +!============================================================================= +m=size(a,1) +ff=f +do j=1,m; jm=j-1; jp=j+1 + d(j)=a(j,j) - sum(b(1:jm,j)*b(j,1:jm)) + b(j,j) = 1 + ff=(d(j) == 0) + if(ff)then + write(41,'("In dldlmf; singularity of matrix detected")') + write(41,'("Rank of matrix: ",i6)'),jm + return + endif + bjji=1/d(j) + do i=jp,m + b(j,i)=a(i,j) - dot_product(b(1:jm,j),b(i,1:jm)) + b(i,j)=b(j,i)*bjji + enddo + b(1:jm,j)=0 +enddo +end subroutine dldlmf + +!============================================================================== +subroutine sinvu(a)! [invu] +!============================================================================== +! Invert the upper triangular matrix in place by transposing, calling +! invl, and transposing again. +!============================================================================== +real,dimension(:,:),intent(inout):: a +a=transpose(a); call sinvl(a); a=transpose(a) +end subroutine sinvu +!============================================================================== +subroutine dinvu(a)! [invu] +!============================================================================== +real(dp),dimension(:,:),intent(inout):: a +a=transpose(a); call dinvl(a); a=transpose(a) +end subroutine dinvu +!============================================================================== +subroutine sinvl(a)! [invl] +!============================================================================== +! Invert lower triangular matrix in place +!============================================================================== +real(sp), intent(inout) :: a(:,:) +integer :: m,j, i +m=size(a,1) +do j=m,1,-1 + a(1:j-1,j) = 0.0 + a(j,j)=1./a(j,j) + do i=j+1,m + a(i,j)=-a(i,i)*sum(a(j:i-1,j)*a(i,j:i-1)) + enddo +enddo +end subroutine sinvl +!============================================================================== +subroutine dinvl(a)! [invl] +!============================================================================== +real(dp), intent(inout) :: a(:,:) +integer :: m,j, i +m=size(a,1) +do j=m,1,-1 + a(1:j-1,j) = 0.0 + a(j,j)=1./a(j,j) + do i=j+1,m + a(i,j)=-a(i,i)*sum(a(j:i-1,j)*a(i,j:i-1)) + enddo +enddo +end subroutine dinvl + +!============================================================================== +subroutine slinlv(a,u)! [invl] +!============================================================================== +! Solve linear system involving lower triangular system matrix. +!============================================================================== +real, intent(in ) :: a(:,:) +real, intent(inout) :: u(:) +integer :: i +if(size(a,1) /= size(a,2) .or. size(a,1) /= size(u))& + stop 'In slinlv; incompatible array dimensions' +do i=1,size(u); u(i)=(u(i) - sum(u(:i-1)*a(i,:i-1)))/a(i,i); enddo +end subroutine slinlv +!============================================================================== +subroutine dlinlv(a,u)! [invl] +!============================================================================== +real(dp), intent(in ) :: a(:,:) +real(dp), intent(inout) :: u(:) +integer :: i +if(size(a,1) /= size(a,2) .or. size(a,1) /= size(u))& + stop 'In dlinlv; incompatible array dimensions' +do i=1,size(u); u(i)=(u(i) - sum(u(:i-1)*a(i,:i-1)))/a(i,i); enddo +end subroutine dlinlv + +!============================================================================== +subroutine slinuv(a,u)! [invu] +!============================================================================== +! Solve linear system involving upper triangular system matrix. +!============================================================================== +real, intent(in ) :: a(:,:) +real, intent(inout) :: u(:) +integer :: i +if(size(a,1) /= size(a,2) .or. size(a,1) /= size(u))& + stop 'In linuv; incompatible array dimensions' +do i=size(u),1,-1; u(i)=(u(i) - sum(a(i+1:,i)*u(i+1:)))/a(i,i); enddo +end subroutine slinuv +!============================================================================== +subroutine dlinuv(a,u)! [invu] +!============================================================================== +real(dp), intent(in ) :: a(:,:) +real(dp), intent(inout) :: u(:) +integer :: i +if(size(a,1) /= size(a,2) .or. size(a,1) /= size(u))& + stop 'In dlinuv; incompatible array dimensions' +do i=size(u),1,-1; u(i)=(u(i) - sum(a(i+1:,i)*u(i+1:)))/a(i,i); enddo +end subroutine dlinuv + +end module pmat + diff --git a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/pmat2.f90 b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/pmat2.f90 new file mode 100644 index 00000000..a315fc67 --- /dev/null +++ b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/pmat2.f90 @@ -0,0 +1,1231 @@ +! +! ********************************************** +! * MODULE pmat2 * +! * R. J. Purser, NOAA/NCEP/EMC 1994/1999 * +! * jim.purser@noaa.gov * +! * Tsukasa Fujita (JMA) 1999 * +! * * +! ********************************************** +! +! Routines dealing with the operations of banded matrices +! The three special routines allow the construction of compact or +! conventional interpolation and differencing stencils to a general +! order of accuracy. These are: +! AVCO: Averaging, or interpolating; +! DFCO: Differentiating (once); +! DFCO2: Differentiating (twice). +! +! Other routines provide the tools for applying compact schemes, and for +! the construction and application of recursive filters. +! +! Programmers: R. J. Purser and T. Fujita +! National Centers for Environmental Prediction. +! Last modified (Purser): January 6th 2005 +! added nonredundant ldltb and ltdlbv routines for symmetric matrices, +! and remove obsolescent routines. +! Keyser (2014-12-12) - print written to unit 41 rather than stdout (for use in +! prepobs_prepacqc program - limits amount of stdout) +! +! DIRECT DEPENDENCIES +! Libraries[their modules]: pmat[pmat] +! Additional Modules : pkind +! +!============================================================================= +module pmat2 +!============================================================================ +use pkind +implicit none +private +public:: avco,dfco,dfco2, clipb,cad1b,csb1b,cad2b,csb2b, & + ldub,ldltb,udlb,l1ubb,l1ueb,ltdlbv, & + udlbv,udlbx,udlby,udlvb,udlxb,udlyb,u1lbv,u1lbx,u1lby,u1lvb,u1lxb, & + u1lyb,linbv,wrtb +real(dp),parameter:: zero=0 + +interface AVCO; module procedure AVCO, DAVCO, TAVCO; end interface +interface DFCO; module procedure DFCO, DDFCO, TDFCO; end interface +interface DFCO2; module procedure DFCO2, DDFCO2, TDFCO2; end interface +interface CLIPB; module procedure clib, clib_d, clib_c; end interface +interface CAD1B; module procedure CAD1B; end interface +interface CSB1B; module procedure CSB1B; end interface +interface CAD2B; module procedure CAD2B; end interface +interface CSB2B; module procedure CSB2B; end interface +interface LDUB; module procedure LDUB, DLDUB; end interface +interface LDLTB; module procedure LDLTB, DLDLTB; end interface +interface L1UBB; module procedure L1UBB, DL1UBB; end interface +interface L1UEB; module procedure L1UEB, DL1UEB; end interface +interface ltDLBV; module procedure ltdlbv,dltdlbv; end interface +interface UDLB; module procedure UDLB, DUDLB; end interface +interface UDLBV; module procedure UDLBV, dudlbv; end interface +interface UDLBX; module procedure UDLBX; end interface +interface UDLBY; module procedure UDLBY; end interface +interface UDLVB; module procedure UDLVB; end interface +interface UDLXB; module procedure UDLXB; end interface +interface UDLYB; module procedure UDLYB; end interface +interface U1LBV; module procedure U1LBV; end interface +interface U1LBX; module procedure U1LBX; end interface +interface U1LBY; module procedure U1LBY; end interface +interface U1LVB; module procedure U1LVB; end interface +interface U1LXB; module procedure U1LXB; end interface +interface U1LYB; module procedure U1LYB; end interface +interface LINBV; module procedure LINBV; end interface +interface WRTB; module procedure WRTB; end interface +contains + +!============================================================================= +subroutine AVCO(na,nb,za,zb,z0,a,b) ! [AVCO] +!============================================================================= +! SUBROUTINE AVCO +! R.J.Purser, National Centers for Environmental Prediction, Washington D.C. +! jim.purser@noaa.gov 1999 +! +! Compute one row of the coefficients for the compact mid-interval +! interpolation scheme characterized by matrix equation of the form, +! A.t = B.s (*) +! Where s is the vector of "source" values, t the staggered "target" values. +! +! --> NA: number of t-points operated on by this row of the A of (*) +! --> NB: number of s-points operated on by this row of the B of (*) +! --> ZA: coordinates of t-points used in this row of (*) +! --> ZB: coordinates of s-points used in this row of (*) +! --> Z0: nominal point of application of this row of (*) +! <-- A: the NA coefficients A for this scheme +! <-- B: the NB coefficients B for this scheme +!============================================================================= +use pmat, only: inv +integer, intent(IN ) :: na,nb +real, intent(IN ) :: za(na),zb(nb),z0 +real, intent(OUT) :: a(na),b(nb) +!----------------------------------------------------------------------------- +integer :: na1,nab,i +real, dimension(na+nb,na+nb):: w +real, dimension(na) :: za0,pa +real, dimension(nb) :: zb0,pb +real, dimension(na+nb) :: ab +!============================================================================= +na1=na+1; nab=na+nb +za0=za-z0; zb0=zb-z0 +pa=1.; pb=-1. +w=0.; ab=0. +w(1,1:na)=1.; ab(1)=1. +do i=2,nab; w(i,1:na)=pa; pa=pa*za0; w(i,na1:nab)=pb; pb=pb*zb0; enddo +call INV(w,ab) +a=ab(1:na); b=ab(na1:nab) +end subroutine AVCO +!============================================================================= +subroutine DAVCO(na,nb,za,zb,z0,a,b) ! [AVCO] +!============================================================================= +use pmat, only: inv +integer, intent(IN ) :: na,nb +real(dp), intent(IN ) :: za(na),zb(nb),z0 +real(dp), intent(OUT) :: a(na),b(nb) +!----------------------------------------------------------------------------- +integer :: na1,nab,i +real(dp),dimension(na+nb,na+nb):: w +real(dp),dimension(na) :: za0,pa +real(dp),dimension(nb) :: zb0,pb +real(dp),dimension(na+nb) :: ab +!============================================================================= +na1=na+1; nab=na+nb +za0=za-z0; zb0=zb-z0 +pa=1.; pb=-1. +w=0.; ab=0. +w(1,1:na)=1.; ab(1)=1. +do i=2,nab; w(i,1:na)=pa; pa=pa*za0; w(i,na1:nab)=pb; pb=pb*zb0; enddo +call INV(w,ab) +a=ab(1:na); b=ab(na1:nab) +end subroutine DAVCO +!============================================================================= +subroutine TAVCO(xa,xb,a,b)! [AVCO] +!============================================================================= +real(dp),dimension(:),intent(IN ):: xa,xb +real(dp),dimension(:),intent(OUT):: a,b +!----------------------------------------------------------------------------- +integer:: na,nb +!============================================================================= +na=size(xa); if(na /= size(a))stop 'In tavco; sizes of a and xa different' +nb=size(xb); if(nb /= size(b))stop 'In tavco; sizes of b and xb different' +call DAVCO(na,nb,xa,xb,zero,a,b) +end subroutine TAVCO + +!============================================================================= +subroutine DFCO(na,nb,za,zb,z0,a,b)! [DFCO] +!============================================================================= +! R.J.Purser, National Centers for Environmental Prediction, Washington D.C. +! jim.purser@noaa.gov 1999 +! SUBROUTINE DFCO +! +! Compute one row of the coefficients for either the compact differencing or +! quadrature scheme characterized by matrix equation of the form, +! A.d = B.c (*) +! In either case, d is the derivative of c. +! +! --> NA: number of d-points operated on by this row of the A of (*) +! --> NB: number of c-points operated on by this row of the B of (*) +! --> ZA: coordinates of d-points used in this row of (*) +! --> ZB: coordinates of c-points used in this row of (*) +! --> Z0: nominal point of application of this row of (*) +! <-- A: the A-coefficients for this scheme +! <-- B: the B-coefficients for this scheme +!============================================================================= +use pmat, only: inv +integer, intent(IN ) :: na,nb +real, intent(IN ) :: za(na),zb(nb),z0 +real, intent(OUT) :: a(na),b(nb) +!----------------------------------------------------------------------------- +integer:: na1,nab,i +real, dimension(na+nb,na+nb):: w +real, dimension(na) :: za0,pa +real, dimension(nb) :: zb0,pb +real, dimension(na+nb) :: ab +!============================================================================= +na1=na+1; nab=na+nb +za0=za-z0; zb0=zb-z0 +pa=1.; pb=-1. +w=0.; ab=0. +w(1,1:na)=1.; ab(1)=1. +do i=3,nab; w(i,1:na) =pa*(i-2); pa=pa*za0; enddo +do i=2,nab; w(i,na1:nab)=pb; pb=pb*zb0; enddo +call INV(w,ab) +a=ab(1:na); b=ab(na1:nab) +end subroutine DFCO +!============================================================================= +subroutine DDFCO(na,nb,za,zb,z0,a,b) ! Real(dp) version of [DFCO] +!============================================================================= +use pmat, only: inv +integer, intent(IN) :: na,nb +real(dp), intent(IN) :: za(na),zb(nb),z0 +real(dp), intent(OUT) :: a(na),b(nb) +!----------------------------------------------------------------------------- +integer :: na1,nab,i +real(dp), dimension(na+nb,na+nb):: w +real(dp), dimension(na) :: za0,pa +real(dp), dimension(nb) :: zb0,pb +real(dp), dimension(na+nb) :: ab +!============================================================================= +na1=na+1; nab=na+nb +za0=za-z0; zb0=zb-z0 +pa=1.; pb=-1. +w=0.; ab=0. +w(1,1:na)=1.; ab(1)=1. +do i=3,nab; w(i,1:na) =pa*(i-2); pa=pa*za0; enddo +do i=2,nab; w(i,na1:nab)=pb; pb=pb*zb0; enddo +call INV(w,ab) +a=ab(1:na); b=ab(na1:nab) +end subroutine DDFCO +!============================================================================= +subroutine TDFCO(xa,xb,a,b)! [DFCO] +!============================================================================= +real(dp),dimension(:),intent(IN ):: xa,xb +real(dp),dimension(:),intent(OUT):: a,b +!----------------------------------------------------------------------------- +integer:: na,nb +!============================================================================= +na=size(xa); if(na /= size(a))stop 'In tdfco; sizes of a and xa different' +nb=size(xb); if(nb /= size(b))stop 'In tdfco; sizes of b and xb different' +call DDFCO(na,nb,xa,xb,zero,a,b) +end subroutine TDFCO + + +!============================================================================= +subroutine DFCO2(na,nb,za,zb,z0,a,b)! [DFCO2] +!============================================================================= +! SUBROUTINE DFCO2 +! R.J.Purser, National Centers for Environmental Prediction, Washington D.C. +! jim.purser@noaa.gov 1999 +! +! Compute one row of the coefficients for either the compact second- +! differencing scheme characterized by matrix equation of the form, +! A.d = B.c (*) +! Where d is the second-derivative of c. +! +! --> NA: number of d-points operated on by this row of the A of (*) +! --> NB: number of c-points operated on by this row of the B of (*) +! --> ZA: coordinates of d-points used in this row of (*) +! --> ZB: coordinates of c-points used in this row of (*) +! --> Z0: nominal point of application of this row of (*) +! <-- A: the NA coefficients A for this scheme +! <-- B: the NB coefficients B for this scheme +!============================================================================= +use pmat, only: inv +integer, intent(IN ) :: na,nb +real, intent(IN ) :: za(na),zb(nb),z0 +real, intent(OUT) :: a(na),b(nb) +!----------------------------------------------------------------------------- +integer:: na1,nab,i +real, dimension(na+nb,na+nb):: w +real, dimension(na) :: za0,pa +real, dimension(nb) :: zb0,pb +real, dimension(na+nb) :: ab +!============================================================================= +na1=na+1; nab=na+nb +za0=za-z0; zb0=zb-z0 +pa=1.; pb=-1. +w=0.; ab=0. +w(1,1:na)=1.; ab(1)=1. +do i=4,nab; w(i,1:na) =pa*(i-2)*(i-3); pa=pa*za0; enddo +do i=2,nab; w(i,na1:nab)=pb; pb=pb*zb0; enddo +call INV(w,ab) +a=ab(1:na); b=ab(na1:nab) +end subroutine DFCO2 +!============================================================================= +subroutine DDFCO2(na,nb,za,zb,z0,a,b) ! Real(dp) version of [DFCO2] +!============================================================================= +use pmat, only: inv +integer, intent(IN ) :: na,nb +real(dp), intent(IN ) :: za(na),zb(nb),z0 +real(dp), intent(OUT) :: a(na),b(nb) +!----------------------------------------------------------------------------- +integer :: na1,nab,i +real(dp), dimension(na+nb,na+nb):: w +real(dp), dimension(na) :: za0,pa +real(dp), dimension(nb) :: zb0,pb +real(dp), dimension(na+nb) :: ab +!============================================================================= +na1=na+1; nab=na+nb +za0=za-z0; zb0=zb-z0 +pa=1.; pb=-1. +w=0.; ab=0. +w(1,1:na)=1.; ab(1)=1. +do i=4,nab; w(i,1:na) =pa*(i-2)*(i-3); pa=pa*za0; enddo +do i=2,nab; w(i,na1:nab)=pb; pb=pb*zb0; enddo +call INV(w,ab) +a=ab(1:na); b=ab(na1:nab) +end subroutine ddfco2 +!============================================================================= +subroutine TDFCO2(xa,xb,a,b)! [DFCO2] +!============================================================================= +real(dp),dimension(:),intent(IN ):: xa,xb +real(dp),dimension(:),intent(OUT):: a,b +!----------------------------------------------------------------------------- +integer:: na,nb +!============================================================================= +na=size(xa); if(na /= size(a))stop 'In tdfco2; sizes of a and xa different' +nb=size(xb); if(nb /= size(b))stop 'In tdfco2; sizes of b and xb different' +call DDFCO2(na,nb,xa,xb,zero,a,b) +end subroutine TDFCO2 + + +!============================================================================= +pure subroutine CLIB(m1,m2,mah1,mah2,a)! [CLIPB] +!============================================================================= +integer, intent(IN ) :: m1, m2, mah1, mah2 +real, intent(INOUT) :: a(m1,-mah1:mah2) +integer :: j +do j=1,mah1; a(1:min(m1,j),-j)=0.; enddo +do j=m2-m1+1,mah2; a(max(1,m2-j+1):m1,j)=0.; enddo +end subroutine CLIB +!============================================================================= +pure subroutine clib_d(m1,m2,mah1,mah2,a)! [CLIPB] +!============================================================================= +integer, intent(IN ) :: m1, m2, mah1, mah2 +real(dp), intent(INOUT) :: a(m1,-mah1:mah2) +integer :: j +do j=1,mah1; a(1:min(m1,j),-j)=0; enddo +do j=m2-m1+1,mah2; a(max(1,m2-j+1):m1,j)=0; enddo +end subroutine clib_d +!============================================================================= +pure subroutine clib_c(m1,m2,mah1,mah2,a)! [CLIPB] +!============================================================================= +integer, intent(IN ) :: m1, m2, mah1, mah2 +complex(dpc), intent(INOUT) :: a(m1,-mah1:mah2) +integer :: j +do j=1,mah1; a(1:min(m1,j),-j)=0; enddo +do j=m2-m1+1,mah2; a(max(1,m2-j+1):m1,j)=0; enddo +end subroutine clib_c + +!============================================================================= +subroutine CAD1B(m1,mah1,mah2,mirror2,a)! [CAD1B] +!============================================================================= +! Incorporate operand symmetry near end-1 of a band matrix operator +! +! <-> A: Input as unclipped operator, output as symmetrized and clipped. +! m1, m2: Sizes of implied full matrix +! mah1, mah2: Left and right semi-bandwidths of A. +! mirror2: 2*location of symmetry axis relative to end-1 operand element. +! Note: although m2 is not used here, it IS used in companion routines +! cad2b and csb2b; it is retained in the interests of uniformity. +!============================================================================= +integer, intent(IN ):: m1,mah1,mah2,mirror2 +real, intent(INOUT):: a(0:m1-1,-mah1:mah2) +!----------------------------------------------------------------------------- +integer :: i,i2,jm,jp,jpmax +!============================================================================= +if(mirror2+mah1 > mah2)stop 'In CAD1B; mah2 insufficient' +do i=0,m1-1; i2=i*2; jpmax=mirror2+mah1-i2; if(jpmax <= -mah1)exit + do jm=-mah1,mah2; jp=mirror2-jm-i2; if(jp <= jm)exit + a(i,jp)=a(i,jp)+a(i,jm) ! Reflect and add + a(i,jm)=0. ! zero the exterior part + enddo +enddo +end subroutine CAD1B + +!============================================================================= +subroutine CSB1B(m1,mah1,mah2,mirror2,a)! [CSB1B] +!============================================================================= +! Like cad1b, but for antisymmetric operand +!============================================================================= +integer, intent(IN ):: m1,mah1,mah2,mirror2 +real, intent(INOUT):: a(0:m1-1,-mah1:mah2) +!----------------------------------------------------------------------------- +integer :: i,i2,jm,jp,jpmax +!============================================================================= +if(mirror2+mah1 > mah2)stop 'In CSB1B; mah2 insufficient' +do i=0,m1-1; i2=i*2; jpmax=mirror2+mah1-i2; if(jpmax < -mah1)exit + do jm=-mah1,mah2; jp=mirror2-jm-i2; if(jp < jm)exit + a(i,jp)=a(i,jp)-a(i,jm) ! Reflect and subtract + a(i,jm)=0. ! zero the exterior part + enddo +enddo +end subroutine CSB1B + +!============================================================================= +subroutine CAD2B(m1,m2,mah1,mah2,mirror2,a)! [CAD2B] +!============================================================================= +! Incorporate operand symmetry near end-2 of a band matrix operator +! +! <-> A: Input as unclipped operator, output as symmetrized and clipped. +! m1, m2: Sizes of implied full matrix +! mah1, mah2: Left and right semi-bandwidths of A. +! mirror2: 2*location of symmetry axis relative to end-2 operand element. +!============================================================================= +integer, intent(IN ):: m1,m2,mah1,mah2,mirror2 +real, intent(INOUT):: a(1-m1:0,m1-m2-mah1:m1-m2+mah2) +!----------------------------------------------------------------------------- +integer :: i,i2,jm,jp,jmmin,nah1,nah2 +!============================================================================= +nah1=mah1+m2-m1; nah2=mah2+m1-m2 ! Effective 2nd-index bounds of A +if(mirror2-nah1 > -nah2)stop 'In CAD2B; mah1 insufficient' +do i=0,1-m1,-1; i2=i*2; jmmin=mirror2-nah2-i2; if(jmmin >= nah2)exit + do jp=nah2,nah1,-1; jm=mirror2-jp-i2; if(jm >= jp)exit + a(i,jm)=a(i,jm)+a(i,jp) ! Reflect and add + a(i,jp)=0. ! zero the exterior part + enddo +enddo +end subroutine CAD2B + +!============================================================================= +subroutine CSB2B(m1,m2,mah1,mah2,mirror2,a)! [CSB2B] +!============================================================================= +integer, intent(IN ):: m1,m2,mah1,mah2,mirror2 +real, intent(INOUT):: a(1-m1:0,m1-m2-mah1:m1-m2+mah2) +!----------------------------------------------------------------------------- +integer :: i,i2,jm,jp,jmmin,nah1,nah2 +!============================================================================= +nah1=mah1+m2-m1; nah2=mah2+m1-m2 ! Effective 2nd-index bounds of A +if(mirror2-nah1 > -nah2)stop 'In CSB2B; mah1 insufficient' +do i=0,1-m1,-1; i2=i*2; jmmin=mirror2-nah2-i2; if(jmmin > nah2)exit + do jp=nah2,nah1,-1; jm=mirror2-jp-i2; if(jm > jp)exit + a(i,jm)=a(i,jm)-a(i,jp) ! Reflect and subtract + a(i,jp)=0. ! zero the exterior part + enddo +enddo +end subroutine CSB2B + +!============================================================================= +!SUBROUTINE CEX2B(a,m1,m2,mah1,mah2,mirror2) +!============================================================================= +!INTEGER, INTENT(IN) :: m1,m2,mah1,mah2,mirror2 +!REAL, INTENT(INOUT):: a(1-m1:0,m1-m2-mah1:m1-m2+mah2) +!----------------------------------------------------------------------------- +!INTEGER :: i,i2,jm,jp,jmmin,nah1,nah2,mirror,j0 +!============================================================================= +!nah1=mah1+m2-m1; nah2=mah2+m1-m2 ! Effective 2nd-index bounds of A +!IF(mirror2-nah1 > -nah2)STOP 'In CEX2B; mah1 insufficient' +!mirror=mirror2/2 +!IF(mirror*2 /= mirror2)STOP 'In CEX2B; mirror2 is not even' +!DO i=0,1-m1,-1; i2=i*2; jmmin=mirror2-nah2-i2; IF(jmmin >= nah2)EXIT +! j0=mirror-i +! DO jp=nah2,nah1,-1; jm=mirror2-jp-i2; IF(jm >= jp)EXIT +! a(i,jm)=a(i,jm)-a(i,jp) ! Reflect and subtract +! a(i,j0)=a(i,j0)+2.*a(i,jp) ! Apply double the coefficient to end +! a(i,jp)=0. ! zero the exterior part +! ENDDO +!ENDDO +!END SUBROUTINE CEX2B + +!============================================================================= +subroutine LDUB(m,mah1,mah2,a)! [LDUB] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1994 +! SUBROUTINE LDUB +! Compute [L]*[D**-1]*[U] decomposition of asymmetric band-matrix +! +! <-> A: input as the asymmetric band matrix. On output, it contains +! the [L]*[D**-1]*[U] factorization of the input matrix, where +! [L] is lower triangular with unit main diagonal +! [D] is a diagonal matrix +! [U] is upper triangular with unit main diagonal +! --> M: The number of rows of array A +! --> MAH1: the left half-bandwidth of fortran array A +! --> MAH2: the right half-bandwidth of fortran array A +!============================================================================= +integer, intent(IN ) :: m,mah1, mah2 +real, intent(INOUT) :: a(m,-mah1:mah2) +!----------------------------------------------------------------------------- +integer :: j, imost, jmost, jp, i +real :: ajj, ajji, aij +!============================================================================= +do j=1,m + imost=min(m,j+mah1) + jmost=min(m,j+mah2) + jp=j+1 + ajj=a(j,0) + if(ajj == 0.)then + write(41,'(" Failure in LDUB:"/" Matrix requires pivoting or is singular")') + stop + endif + ajji=1./ajj + a(j,0)=ajji + do i=jp,imost + aij=ajji*a(i,j-i) + a(i,j-i)=aij + a(i,jp-i:jmost-i)=a(i,jp-i:jmost-i)-aij*a(j,1:jmost-j) + enddo + a(j,1:jmost-j)=ajji*a(j,1:jmost-j) +enddo +end subroutine LDUB +!============================================================================= +subroutine DLDUB(m,mah1,mah2,a) ! Real(dp) version of [LDUB] +!============================================================================= +integer, intent(IN ) :: m,mah1, mah2 +real(dp), intent(INOUT) :: a(m,-mah1:mah2) +!----------------------------------------------------------------------------- +integer :: j, imost, jmost, jp, i +real(dp) :: ajj, ajji, aij +!============================================================================= +do j=1,m + imost=min(m,j+mah1) + jmost=min(m,j+mah2) + jp=j+1 + ajj=a(j,0) + if(ajj == 0)then + write(41,'(" Fails in LDUB_d:"/" Matrix requires pivoting or is singular")') + stop + endif + ajji=1./ajj + a(j,0)=ajji + do i=jp,imost + aij=ajji*a(i,j-i) + a(i,j-i)=aij + a(i,jp-i:jmost-i)=a(i,jp-i:jmost-i)-aij*a(j,1:jmost-j) + enddo + a(j,1:jmost-j)=ajji*a(j,1:jmost-j) +enddo +end subroutine DLDUB + +!============================================================================= +subroutine LDLTB(m,mah1,a) ! Real(sp) version of [LDLTB] +!============================================================================= +integer, intent(IN ) :: m,mah1 +real(sp), intent(INOUT) :: a(m,-mah1:0) +!----------------------------------------------------------------------------- +integer :: j, imost, jp, i,k +real(sp) :: ajj, ajji, aij +!============================================================================= +do j=1,m + imost=min(m,j+mah1) + jp=j+1 + ajj=a(j,0) + if(ajj == 0)then + write(41,'(" Fails in LDLTB:"/" Matrix requires pivoting or is singular")') + stop + endif + ajji=1./ajj + a(j,0)=ajji + do i=jp,imost + aij=a(i,j-i) + a(i,j-i)=ajji*aij + do k=jp,i + a(i,k-i)=a(i,k-i)-aij*a(k,j-k) + enddo + enddo +enddo +end subroutine LDLTB +!============================================================================= +subroutine DLDLTB(m,mah1,a) ! Real(dp) version of [LDLTB] +!============================================================================= +integer, intent(IN ) :: m,mah1 +real(dp), intent(INOUT) :: a(m,-mah1:0) +!----------------------------------------------------------------------------- +integer :: j, imost, jp, i,k +real(dp) :: ajj, ajji, aij +!============================================================================= +do j=1,m + imost=min(m,j+mah1) + jp=j+1 + ajj=a(j,0) + if(ajj == 0)then + write(41,'(" Fails in LDLTB_d:"/" Matrix requires pivoting or is singular")') + stop + endif + ajji=1./ajj + a(j,0)=ajji + do i=jp,imost + aij=a(i,j-i) + a(i,j-i)=ajji*aij + do k=jp,i + a(i,k-i)=a(i,k-i)-aij*a(k,j-k) + enddo + enddo +enddo +end subroutine DLDLTB + + +!============================================================================= +subroutine UDLB(m,mah1,mah2,a) ! Reversed-index version of ldub [UDLB] +!============================================================================= +integer, intent(IN ) :: m,mah1,mah2 +real, dimension(m,-mah1:mah2),intent(INOUT) :: a(m,-mah1:mah2) +!----------------------------------------------------------------------------- +real, dimension(m,-mah2:mah1) :: at +!============================================================================= +at=a(m:1:-1,mah2:-mah1:-1); call LDUB(m,mah2,mah1,at) +a=at(m:1:-1,mah1:-mah2:-1) +end subroutine UDLB +!============================================================================= +subroutine DUDLB(m,mah1,mah2,a) ! real(dp) version of udlb [UDLB] +!============================================================================= +integer, intent(IN ) :: m,mah1,mah2 +real(dp),dimension(m,-mah1:mah2),intent(INOUT) :: a(m,-mah1:mah2) +!----------------------------------------------------------------------------- +real(dp),dimension(m,-mah2:mah1) :: at +!============================================================================= +at=a(m:1:-1,mah2:-mah1:-1); call DLDUB(m,mah2,mah1,at) +a=at(m:1:-1,mah1:-mah2:-1) +end subroutine DUDLB + +!============================================================================= +subroutine L1UBB(m,mah1,mah2,mbh1,mbh2,a,b)! [L1UBB] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1996 +! SUBROUTINE L1UBB +! Form the [L]*[D]*[U] decomposition of asymmetric band-matrix [A] replace +! lower triangular elements of [A] by [D**-1]*[L]*[D], the upper by [U], +! replace matrix [B] by [D**-1]*[B]. +! +! <-> A input as band matrix, output as lower and upper triangulars with 1s +! implicitly assumed to lie on the main diagonal. The product of these +! triangular matrices is [D**-1]*[A], where [D] is a diagonal matrix. +! <-> B in as band matrix, out as same but premultiplied by diagonal [D**-1] +! --> M Number of rows of A and B +! --> MAH1 left half-width of fortran array A +! --> MAH2 right half-width of fortran array A +! --> MBH1 left half-width of fortran array B +! --> MBH2 right half-width of fortran array B +!============================================================================= +integer, intent(IN ) :: m,mah1, mah2, mbh1, mbh2 +real, intent(INOUT) :: a(m,-mah1:mah2), b(m,-mbh1:mbh2) +!----------------------------------------------------------------------------- +integer :: j, imost, jmost, jleast, jp, i +real :: ajj, ajji, aij +!============================================================================= +do j=1,m + imost=min(m,j+mah1) + jmost=min(m,j+mah2) + jleast=max(1,j-mah1) + jp=j+1 + ajj=a(j,0) + if(ajj == 0.)stop 'In L1UBB; zero element found in diagonal factor' + ajji=1./ajj + a(j,jleast-j:jmost-j) = ajji * a(j,jleast-j:jmost-j) + do i=jp,imost + aij=a(i,j-i) + a(i,jp-i:jmost-i) = a(i,jp-i:jmost-i) - aij*a(j,jp-j:jmost-j) + enddo + a(j,0)=1. + b(j,-mbh1:mbh2) = ajji * b(j,-mbh1:mbh2) +enddo +end subroutine L1UBB +!============================================================================= +subroutine DL1UBB(m,mah1,mah2,mbh1,mbh2,a,b) ! Real(dp) version of [L1UBB] +!============================================================================= +integer, intent(IN ) :: m,mah1, mah2, mbh1, mbh2 +real(dp), intent(INOUT) :: a(m,-mah1:mah2), b(m,-mbh1:mbh2) +!----------------------------------------------------------------------------- +integer :: j, imost, jmost, jleast, jp, i +real(dp) :: ajj, ajji, aij +!============================================================================= +do j=1,m + imost=min(m,j+mah1) + jmost=min(m,j+mah2) + jleast=max(1,j-mah1) + jp=j+1 + ajj=a(j,0) + if(ajj == 0)stop 'In L1UBB_d; zero element found in diagonal factor' + ajji=1./ajj + a(j,jleast-j:jmost-j) = ajji * a(j,jleast-j:jmost-j) + do i=jp,imost + aij=a(i,j-i) + a(i,jp-i:jmost-i) = a(i,jp-i:jmost-i) - aij*a(j,jp-j:jmost-j) + enddo + a(j,0)=1. + b(j,-mbh1:mbh2) = ajji * b(j,-mbh1:mbh2) +enddo +end subroutine DL1UBB + +!============================================================================= +subroutine L1UEB(m,mah1,mah2,mbh1,mbh2,a,b)! [L1UEB] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1998 +! SUBROUTINE L1UEB +! Form the [L]*[D]*[U] decomposition of asymmetric band-matrix [A] replace +! all but row zero of the +! lower triangular elements of [A] by [D**-1]*[L]*[D], the upper by [U], +! replace matrix [B] by [D**-1]*[B]. +! This is a special adaptation of L1UBB used to process quadarature weights +! for QEDBV etc in which the initial quadrature value is provided as input +! instead of being implicitly assumed zero (which is the case for QZDBV etc). +! +! <-> A input as band matrix, output as lower and upper triangulars with 1s +! implicitly assumed to lie on the main diagonal. The product of these +! triangular matrices is [D**-1]*[A], where [D] is a diagonal matrix. +! <-> B in as band matrix, out as same but premultiplied by diagonal [D**-1] +! --> M number of rows of B, one less than the rows of A (which has "row 0") +! --> MAH1 left half-width of fortran array A +! --> MAH2 right half-width of fortran array A +! --> MBH1 left half-width of fortran array B +! --> MBH2 right half-width of fortran array B +!============================================================================= +integer, intent(IN ) :: m,mah1, mah2, mbh1, mbh2 +real, intent(INOUT) :: a(0:m,-mah1:mah2), b(m,-mbh1:mbh2) +!----------------------------------------------------------------------------- +integer :: j, imost, jmost, jleast, jp, i +real :: ajj, ajji, aij +!============================================================================= +do j=1,m + imost=min(m,j+mah1) + jmost=min(m,j+mah2) + jleast=max(0,j-mah1) + jp=j+1 + ajj=a(j,0) + if(ajj == 0.)stop 'In L1UEB; zero element found in diagonal factor' + ajji=1./ajj + a(j,jleast-j:jmost-j) = ajji * a(j,jleast-j:jmost-j) + do i=jp,imost + aij=a(i,j-i) + a(i,jp-i:jmost-i) = a(i,jp-i:jmost-i) - aij*a(j,jp-j:jmost-j) + enddo + a(j,0)=1. + b(j,-mbh1:mbh2) = ajji * b(j,-mbh1:mbh2) +enddo +end subroutine L1UEB +!============================================================================= +subroutine DL1UEB(m,mah1,mah2,mbh1,mbh2,a,b) ! Real(dp) version of [L1UEB] +!============================================================================= +integer, intent(IN ):: m,mah1, mah2, mbh1, mbh2 +real(dp), intent(INOUT):: a(0:,-mah1:), b(:,-mbh1:) +!----------------------------------------------------------------------------- +integer :: j, imost, jmost, jleast, jp, i +real(dp) :: ajj, ajji, aij +!============================================================================= +do j=1,m + imost=min(m,j+mah1) + jmost=min(m,j+mah2) + jleast=max(0,j-mah1) + jp=j+1 + ajj=a(j,0) + if(ajj == 0)stop 'In L1UEB_D; zero element found in diagonal factor' + ajji=1./ajj + a(j,jleast-j:jmost-j) = ajji * a(j,jleast-j:jmost-j) + do i=jp,imost + aij=a(i,j-i) + a(i,jp-i:jmost-i) = a(i,jp-i:jmost-i) - aij*a(j,jp-j:jmost-j) + enddo + a(j,0)=1. + b(j,-mbh1:mbh2) = ajji * b(j,-mbh1:mbh2) +enddo +end subroutine DL1UEB + +!============================================================================= +subroutine UDLBV(m,mah1,mah2,a,v)! [UDLBV] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1994 +! SUBROUTINE UDLBV +! BACk-substitution step of linear inversion involving +! Banded matrix and Vector. +! +! --> A encodes the (L)*(D**-1)*(U) factorization of the linear-system +! matrix, as supplied by subroutine LDUB +! <-> V input as right-hand-side vector, output as solution vector +! --> M the number of rows assumed for A and for V +! --> MAH1 the left half-bandwidth of fortran array A +! --> MAH2 the right half-bandwidth of fortran array A +!============================================================================= +integer, intent(IN ) :: m, mah1, mah2 +real, intent(IN ) :: a(m,-mah1:mah2) +real, intent(INOUT) :: v(m) +!----------------------------------------------------------------------------- +integer :: i, j +real :: vj +!============================================================================= +do j=1,m + vj=v(j) + do i=j+1,min(m,j+mah1); v(i)=v(i)-a(i,j-i)*vj; enddo; v(j)=a(j,0)*vj +enddo +do j=m,2,-1 + vj=v(j) + do i=max(1,j-mah2),j-1; v(i)=v(i)-a(i,j-i)*vj; enddo +enddo +end subroutine UDLBV +!============================================================================= +subroutine dudlbv(m,mah1,mah2,a,v)! [udlbv] +!============================================================================= +integer, intent(IN ) :: m, mah1, mah2 +real(dp), intent(IN ) :: a(m,-mah1:mah2) +real(dp), intent(INOUT) :: v(m) +!----------------------------------------------------------------------------- +integer :: i, j +real(dp) :: vj +!============================================================================= +do j=1,m + vj=v(j) + do i=j+1,min(m,j+mah1); v(i)=v(i)-a(i,j-i)*vj; enddo; v(j)=a(j,0)*vj +enddo +do j=m,2,-1 + vj=v(j) + do i=max(1,j-mah2),j-1; v(i)=v(i)-a(i,j-i)*vj; enddo +enddo +end subroutine dudlbv + +!============================================================================= +subroutine ltdlbv(m,mah1,a,v)! [ltdlbv] +!============================================================================= +! Like udlbv, except assuming a is the ltdl decomposition of a SYMMETRIC +! banded matrix, with only the non-upper part provided (to avoid redundancy) +!============================================================================= +integer, intent(IN ) :: m, mah1 +real(sp), intent(IN ) :: a(m,-mah1:0) +real(sp), intent(INOUT) :: v(m) +!----------------------------------------------------------------------------- +integer :: i, j +real(sp) :: vj +!============================================================================= +do j=1,m + vj=v(j) + do i=j+1,min(m,j+mah1); v(i)=v(i)-a(i,j-i)*vj; enddo; v(j)=a(j,0)*vj +enddo +do j=m,2,-1 + vj=v(j) + do i=max(1,j-mah1),j-1; v(i)=v(i)-a(j,i-j)*vj; enddo +enddo +end subroutine ltdlbv +!============================================================================= +subroutine dltdlbv(m,mah1,a,v)! [ltdlbv] +!============================================================================= +! Like udlbv, except assuming a is the ltdl decomposition of a SYMMETRIC +! banded matrix, with only the non-upper part provided (to avoid redundancy) +!============================================================================= +integer, intent(IN ) :: m, mah1 +real(dp), intent(IN ) :: a(m,-mah1:0) +real(dp), intent(INOUT) :: v(m) +!----------------------------------------------------------------------------- +integer :: i, j +real(dp) :: vj +!============================================================================= +do j=1,m + vj=v(j) + do i=j+1,min(m,j+mah1); v(i)=v(i)-a(i,j-i)*vj; enddo; v(j)=a(j,0)*vj +enddo +do j=m,2,-1 + vj=v(j) + do i=max(1,j-mah1),j-1; v(i)=v(i)-a(j,i-j)*vj; enddo +enddo +end subroutine dltdlbv + +!============================================================================= +subroutine UDLBX(mx,mah1,mah2,my,a,v)! [UDLBX] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1994 +! SUBROUTINE UDLBX +! BACk-substitution step of parallel linear inversion involving +! Banded matrix and X-Vectors. +! +! --> A encodes the (L)*(D**-1)*(U) factorization of the linear-system +! matrix, as supplied by subroutine LDUB or, if N=NA, by LDUB +! <-> V input as right-hand-side vectors, output as solution vectors +! --> MX the number of rows assumed for A and length of +! X-vectors stored in V +! --> MAH1 the left half-bandwidth of fortran array A +! --> MAH2 the right half-bandwidth of fortran array A +! --> MY number of parallel X-vectors inverted +!============================================================================= +integer, intent(IN ) :: mx, mah1, mah2, my +real, intent(IN ) :: a(mx,-mah1:mah2) +real, intent(INOUT) :: v(mx,my) +!----------------------------------------------------------------------------- +integer :: jx, ix +!============================================================================= +do jx=1,mx + do ix=jx+1,min(mx,jx+mah1); v(ix,:) = v(ix,:) - a(ix,jx-ix)*v(jx,:); enddo + v(jx,:) = a(jx,0) * v(jx,:) +enddo +do jx=mx,2,-1 + do ix=max(1,jx-mah2),jx-1; v(ix,:) = v(ix,:) - a(ix,jx-ix)*v(jx,:); enddo +enddo +end subroutine UDLBX + +!============================================================================= +subroutine UDLBY(my,mah1,mah2,mx,a,v)! [UDLBY] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1994 +! SUBROUTINE UDLBY +! BACk-substitution step of parallel linear inversion involving +! Banded matrix and Y-Vectors. +! +! --> A encodes the (L)*(D**-1)*(U) factorization of the linear-system +! matrix, as supplied by subroutine LDUB or, if N=NA, by LDUB +! <-> V input as right-hand-side vectors, output as solution vectors +! --> MY the number of rows assumed for A and length of +! Y-vectors stored in V +! --> MAH1 the left half-bandwidth of fortran array A +! --> MAH2 the right half-bandwidth of fortran array A +! --> MX number of parallel Y-vectors inverted +!============================================================================= +integer, intent(IN ) :: my, mah1, mah2, mx +real, intent(IN ) :: a(my,-mah1:mah2) +real, intent(INOUT) :: v(mx,my) +!----------------------------------------------------------------------------- +integer :: iy, jy +!============================================================================= +do jy=1,my + do iy=jy+1,min(my,jy+mah1); v(:,iy) = v(:,iy)-a(iy,jy-iy)*v(:,jy); enddo + v(:,jy)=a(jy,0)*v(:,jy) +enddo +do jy=my,2,-1 + do iy=max(1,jy-mah2),jy-1; v(:,iy)=v(:,iy)-a(iy,jy-iy)*v(:,jy); enddo +enddo +end subroutine UDLBY + +!============================================================================= +subroutine UDLVB(m,mah1,mah2,v,a)! [UDLVB] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1994 +! SUBROUTINE UDLVB +! BACk-substitution step of linear inversion involving +! row-Vector and Banded matrix. +! +! <-> V input as right-hand-side row-vector, output as solution vector +! --> A encodes the (L)*(D**-1)*(U) factorization of the linear-system +! matrix, as supplied by subroutine LDUB +! --> M the number of rows assumed for A and columns for V +! --> MAH1 the left half-bandwidth of fortran array A +! --> MAH2 the right half-bandwidth of fortran array A +!============================================================================= +integer, intent(IN ) :: m, mah1, mah2 +real, intent(IN ) :: a(m,-mah1:mah2) +real, intent(INOUT) :: v(m) +!----------------------------------------------------------------------------- +integer :: i, j +real :: vi +!============================================================================= +do i=1,m + vi=v(i) + do j=i+1,min(m,i+mah2); v(j)=v(j)-vi*a(i,j-i); enddo + v(i)=vi*a(i,0) +enddo +do i=m,2,-1 + vi=v(i) + do j=max(1,i-mah1),i-1; v(j)=v(j)-vi*a(i,j-i); enddo +enddo +end subroutine UDLVB + +!============================================================================= +subroutine UDLXB(mx,mah1,mah2,my,v,a)! [UDLXB] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1994 +! SUBROUTINE UDLXB +! BACk-substitution step of parallel linear inversion involving +! Banded matrix and row-X-Vectors. +! +! <-> V input as right-hand-side vectors, output as solution vectors +! --> A encodes the (L)*(D**-1)*(U) factorization of the linear-system +! matrix, as supplied by subroutine LDUB +! --> MX the number of rows assumed for A and length of +! X-vectors stored in V +! --> MAH1 the left half-bandwidth of fortran array A +! --> MAH2 the right half-bandwidth of fortran array A +! --> MY number of parallel X-vectors inverted +!============================================================================= +integer, intent(IN ) :: mx, mah1, mah2, my +real, intent(IN ) :: a(mx,-mah1:mah2) +real, intent(INOUT) :: v(mx,my) +!----------------------------------------------------------------------------- +integer :: ix, jx +!============================================================================= +do ix=1,mx + do jx=ix+1,min(mx,ix+mah2); v(jx,:)=v(jx,:)-v(ix,:)*a(ix,jx-ix); enddo + v(ix,:)=v(ix,:)*a(ix,0) +enddo +do ix=mx,2,-1 + do jx=max(1,ix-mah1),ix-1; v(jx,:)=v(jx,:)-v(ix,:)*a(ix,jx-ix); enddo +enddo +end subroutine UDLXB + +!============================================================================= +subroutine UDLYB(my,mah1,mah2,mx,v,a)! [UDLYB] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1994 +! SUBROUTINE UDLYB +! BACk-substitution step of parallel linear inversion involving +! Banded matrix and row-Y-Vectors. +! +! <-> V input as right-hand-side vectors, output as solution vectors +! --> A encodes the (L)*(D**-1)*(U) factorization of the linear-system +! matrix, as supplied by subroutine LDUB +! --> MY the number of rows assumed for A and length of +! Y-vectors stored in V +! --> MAH1 the left half-bandwidth of fortran array A +! --> MAH2 the right half-bandwidth of fortran array A +! --> MX number of parallel Y-vectors inverted +!============================================================================= +integer, intent(IN ) :: my, mah1, mah2, mx +real, intent(IN ) :: a(my,-mah1:mah2) +real, intent(INOUT) :: v(mx,my) +!----------------------------------------------------------------------------- +integer :: iy, jy +!============================================================================= +do iy=1,my + do jy=iy+1,min(my,iy+mah2); v(:,jy)=v(:,jy)-v(:,iy)*a(iy,jy-iy); enddo + v(:,iy)=v(:,iy)*a(iy,0) +enddo +do iy=my,2,-1 + do jy=max(1,iy-mah1),iy-1; v(:,jy)=v(:,jy)-v(:,iy)*a(iy,jy-iy); enddo +enddo +end subroutine UDLYB + +!============================================================================= +subroutine U1LBV(m,mah1,mah2,a,v)! [U1LBV] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1996 +! SUBROUTINE U1LBV +! BACk-substitution step ((U**-1)*(L**-1)) of linear inversion involving +! special Banded matrix and right-Vector. +! +! --> A encodes the [L]*[U] factorization of the linear-system +! matrix, as supplied by subroutine L1UBB +! <-> V input as right-hand-side vector, output as solution vector +! --> M the number of rows assumed for A and for V +! --> MAH1 the left half-bandwidth of fortran array A +! --> MAH2 the right half-bandwidth of fortran array A +!============================================================================= +integer, intent(IN ) :: m, mah1, mah2 +real, intent(IN ) :: a(m,-mah1:mah2) +real, intent(INOUT) :: v(m) +!----------------------------------------------------------------------------- +integer :: i, j +real :: vj +!============================================================================= +do j=1,m + vj=v(j) + do i=j+1,min(m,j+mah1); v(i)=v(i)-a(i,j-i)*vj; enddo +enddo +do j=m,2,-1 + vj=v(j) + do i=max(1,j-mah2),j-1; v(i)=v(i)-a(i,j-i)*vj; enddo +enddo +end subroutine U1LBV + +!============================================================================= +subroutine U1LBX(mx,mah1,mah2,my,a,v)! [U1LBX] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1996 +! SUBROUTINE U1LBX +! Special BaCk-substitution step of parallel linear inversion involving +! Banded matrix and X-right-Vectors. +! +! --> A encodes the [L]*[U] factorization of the linear-system +! matrix, as supplied by subroutine L1UBB +! <-> V input as right-hand-side vectors, output as solution vectors +! --> MX the number of rows assumed for A and length of +! X-vectors stored in V +! --> MAH1 the left half-bandwidth of fortran array A +! --> MAH2 the right half-bandwidth of fortran array A +! --> MY number of parallel X-vectors inverted +!============================================================================= +integer, intent(IN ) :: mx, mah1, mah2, my +real, intent(IN ) :: a(mx,-mah1:mah2) +real, intent(INOUT) :: v(mx,my) +!----------------------------------------------------------------------------- +integer :: ix, jx +!============================================================================= +do jx=1,mx + do ix=jx+1,min(mx,jx+mah1); v(ix,:)=v(ix,:)-a(ix,jx-ix)*v(jx,:); enddo +enddo +do jx=mx,2,-1 + do ix=max(1,jx-mah2),jx-1; v(ix,:)=v(ix,:)-a(ix,jx-ix)*v(jx,:); enddo +enddo +end subroutine U1LBX + +!============================================================================= +subroutine U1LBY(my,mah1,mah2,mx,a,v)! [U1LBY] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1996 +! SUBROUTINE U1LBY +! Special BaCk-substitution step of parallel linear inversion involving +! Banded matrix and Y-right-Vectors. +! +! --> A encodes the [L]*[U] factorization of the linear-system +! matrix, as supplied by subroutine L1UBB +! <-> V input as right-hand-side vectors, output as solution vectors +! --> MY the number of rows assumed for A and length of +! Y-vectors stored in V +! --> MAH1 the left half-bandwidth of fortran array A +! --> MAH2 the right half-bandwidth of fortran array A +! --> MX number of parallel Y-vectors inverted +!============================================================================= +integer, intent(IN ) :: my, mah1, mah2, mx +real, intent(IN ) :: a(my,-mah1:mah2) +real, intent(INOUT) :: v(mx,my) +!----------------------------------------------------------------------------- +integer :: iy, jy +!============================================================================= +do jy=1,my + do iy=jy+1,min(my,jy+mah1); v(:,iy)=v(:,iy)-a(iy,jy-iy)*v(:,jy); enddo +enddo +do jy=my,2,-1 + do iy=max(1,jy-mah2),jy-1; v(:,iy)=v(:,iy)-a(iy,jy-iy)*v(:,jy); enddo +enddo +end subroutine U1LBY + +!============================================================================= +subroutine U1LVB(m,mah1,mah2,v,a)! [U1LVB] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1996 +! SUBROUTINE U1LVB +! Special BaCk-substitution step of linear inversion involving +! left-Vector and Banded matrix. +! +! <-> V input as right-hand-side row-vector, output as solution vector +! --> A encodes the special [L]*[U] factorization of the linear-system +! matrix, as supplied by subroutine L1UBB +! --> M the number of rows assumed for A and columns for V +! --> MAH1 the left half-bandwidth of fortran array A +! --> MAH2 the right half-bandwidth of fortran array A +!============================================================================= +integer, intent(IN ) :: m, mah1, mah2 +real, intent(IN ) :: a(m,-mah1:mah2) +real, intent(INOUT) :: v(m) +!----------------------------------------------------------------------------- +integer :: i, j +real :: vi +!============================================================================= +do i=1,m + vi=v(i) + do j=i+1,min(m,i+mah2); v(j)=v(j)-vi*a(i,j-i); enddo +enddo +do i=m,2,-1 + vi=v(i) + do j=max(1,i-mah1),i-1; v(j)=v(j)-vi*a(i,j-i); enddo +enddo +end subroutine U1LVB + +!============================================================================= +subroutine U1LXB(mx,mah1,mah2,my,v,a)! [U1LXB] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1996 +! SUBROUTINE U1LXB +! Special BaCk-substitution step of parallel linear inversion involving +! Banded matrix and X-left-Vectors. +! +! <-> V input as right-hand-side vectors, output as solution vectors +! --> A encodes the special [L]*[U] factorization of the linear-system +! matrix, as supplied by subroutine L1UBB +! --> MX the number of rows assumed for A and length of +! X-vectors stored in V +! --> MAH1 the left half-bandwidth of fortran array A +! --> MAH2 the right half-bandwidth of fortran array A +! --> MY number of parallel X-vectors inverted +!============================================================================= +integer, intent(IN ) :: mx, mah1, mah2, my +real, intent(IN ) :: a(mx,-mah1:mah2) +real, intent(INOUT) :: v(mx,my) +!----------------------------------------------------------------------------- +integer :: ix, jx +!============================================================================= +do ix=1,mx + do jx=ix+1,min(mx,ix+mah2); v(jx,:)=v(jx,:)-v(ix,:)*a(ix,jx-ix); enddo +enddo +do ix=mx,2,-1 + do jx=max(1,ix-mah1),ix-1; v(jx,:)=v(jx,:)-v(ix,:)*a(ix,jx-ix); enddo +enddo +end subroutine U1LXB + +!============================================================================= +subroutine U1LYB(my,mah1,mah2,mx,v,a)! [U1LYB] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1996 +! SUBROUTINE U1LYB +! Special BaCk-substitution step of parallel linear inversion involving +! special Banded matrix and Y-left-Vectors. +! +! <-> V input as right-hand-side vectors, output as solution vectors +! --> A encodes the [L]*[U] factorization of the linear-system +! matrix, as supplied by subroutine L1UBB +! --> MY the number of rows assumed for A and length of +! Y-vectors stored in V +! --> MAH1 the left half-bandwidth of fortran array A +! --> MAH2 the right half-bandwidth of fortran array A +! --> MX number of parallel Y-vectors inverted +!============================================================================= +integer, intent(IN ) :: my, mah1, mah2, mx +real, intent(IN ) :: a(my,-mah1:mah2) +real, intent(INOUT) :: v(mx,my) +!----------------------------------------------------------------------------- +integer :: iy, jy +!============================================================================= +do iy=1,my + do jy=iy+1,min(my,iy+mah2); v(:,jy)=v(:,jy)-v(:,iy)*a(iy,jy-iy); enddo +enddo +do iy=my,2,-1 + do jy=max(1,iy-mah1),iy-1; v(:,jy)=v(:,jy)-v(:,iy)*a(iy,jy-iy); enddo +enddo +end subroutine U1LYB + +!============================================================================= +subroutine LINBV(m,mah1,mah2,a,v)! [LINBV] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1994 +! SUBROUTINE LINBV +! Solve LINear system with square Banded-matrix and vector V +! +! <-> A system matrix on input, its [L]*[D**-1]*[U] factorization on exit +! <-> V vector of right-hand-sides on input, solution vector on exit +! --> M order of matrix A +! --> MAH1 left half-bandwidth of A +! --> MAH2 right half-bandwidth of A +!============================================================================= +integer, intent(IN ) :: m, mah1, mah2 +real, intent(INOUT) :: a(m,-mah1:mah2), v(m) +!============================================================================= +call LDUB(m,mah1,mah2,a) +call UDLBV(m,mah1,mah2,a,v) +end subroutine LINBV + +!============================================================================= +subroutine WRTB(m1,m2,mah1,mah2,a)! [WRTB] +!============================================================================= +integer, intent(IN) :: m1, m2, mah1, mah2 +real, intent(IN) :: a(m1,-mah1:mah2) +!----------------------------------------------------------------------------- +integer :: i1, i2, i, j1, j2, j, nj1 +!============================================================================= +do i1=1,m1,20 + i2=min(i1+19,m1) + write(41,'(7x,6(i2,10x))'),(j,j=-mah1,mah2) + do i=i1,i2 + j1=max(-mah1,1-i) + j2=min(mah2,m2-i) + nj1=j1+mah1 + if(nj1==0) write(41,'(1x,i3,6(1x,e12.5))'), i,(a(i,j),j=j1,j2) + if(nj1==1) write(41,'(1x,i3,12x,5(1x,e12.5))'),i,(a(i,j),j=j1,j2) + if(nj1==2) write(41,'(1x,i3,24x,4(1x,e12.5))'),i,(a(i,j),j=j1,j2) + if(nj1==3) write(41,'(1x,i3,36x,3(1x,e12.5))'),i,(a(i,j),j=j1,j2) + if(nj1==4) write(41,'(1x,i3,48x,2(1x,e12.5))'),i,(a(i,j),j=j1,j2) + if(nj1==5) write(41,'(1x,i3,60x,1(1x,e12.5))'),i,(a(i,j),j=j1,j2) + enddo + read(*,*) +enddo +end subroutine WRTB + +end module pmat2 diff --git a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/pmat3.f90 b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/pmat3.f90 new file mode 100644 index 00000000..93099d9e --- /dev/null +++ b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/pmat3.f90 @@ -0,0 +1,912 @@ +! +! ********************************************** +! * MODULE pmat3 * +! * R. J. Purser, NOAA/NCEP/EMC Oct 2012 * +! * jim.purser@noaa.gov * +! * * +! ********************************************** +! +! Basic generic matrix routines that can each be expressed conveniently as a +! fortran PURE FUNCTION, or, where matrix inversion is involved, as a +! fortran FUNCTION at least +! +! Single precision real and complex routines are not accommodated here. +! Where it generally makes sense to include an integer version, this is +! included and signified by a function name ending "_i". +! The real functions have names ending "_d". +! The complex functions have names ending "_c". +! +! Last modified: +! Keyser (2014-12-12) - print written to unit 41 rather than stdout (for use in +! prepobs_prepacqc program - limits amount of stdout) +! +! DIRECT DEPENDENCIES +! Libraries[their Modules]: pmat[pmat,pmat2] +! Additional Modules : pietc, pkind +! +!============================================================================= +module pmat3 +!============================================================================= +use pkind, only: dp,dpc +implicit none +private +public:: norv,mulmd,muldm,diag,inv,mulpp,difp,intp,invp,powp,polps,polpp, & + copbm,copmb,transposeb,mulbb,mulbd,muldb,mulbv,mulbx,mulby, & + mulvb,mulxb,mulyb,L1Lb,u1ub,LdLb,udub + +interface norv; module procedure norv_d,norv_c; end interface +interface mulmd; module procedure mulmd_i,mulmd_d,mulmd_c; end interface +interface muldm; module procedure muldm_i,muldm_d,muldm_c; end interface +interface diag + module procedure diagmofd_i,diagmofd_d,diagmofd_c, & + diagdofm_i,diagdofm_d,diagdofm_c + end interface +interface inv; module procedure invm_d,invm_c, finvm_d,finvm_c, & + invmv_d,invmv_c,finvmv_d,finvmv_c + end interface +interface mulpp; module procedure mulpp_i,mulpp_d,mulpp_c; end interface +interface difp; module procedure difp_d,difp_c,ndifp_d,ndifp_c; end interface +interface intp; module procedure intp_d,intp_c,nintp_d,nintp_c; end interface +interface invp; module procedure ninvp_d,ninvp_c; end interface +interface powp; module procedure npowp_d,npowp_c; end interface +interface polps; module procedure polps_d,polps_c, & + npolps_d,npolps_c; end interface +interface polpp; module procedure npolpp_d,npolpp_c; end interface +!----------------------------------------------------------------------------- +! Banded matrix functions: +interface copbm; module procedure copbm_d,copbm_c; end interface +interface copmb; module procedure copmb_d,copmb_c; end interface +interface transposeb; module procedure transposeb_d,transposeb_c; end interface +interface mulbb; module procedure mulbb_d; end interface +interface mulbd; module procedure mulbd_d; end interface +interface muldb; module procedure muldb_d; end interface +interface mulbv; module procedure mulbv_d; end interface +interface mulbx; module procedure mulbx_d; end interface +interface mulby; module procedure mulby_d; end interface +interface mulvb; module procedure mulvb_d; end interface +interface mulxb; module procedure mulxb_d; end interface +interface mulyb; module procedure mulyb_d; end interface +interface L1Lb; module procedure L1Lb_d,fL1Lb_d; end interface +interface u1ub; module procedure u1ub_d,fu1ub_d; end interface +interface LdLb; module procedure LdLb_d,fLdLb_d; end interface +interface udub; module procedure udub_d,fudub_d; end interface + +contains +!============================================================================= +pure function norv_d(a)result(b)! [norv] +!============================================================================= +! Norm of vector a +!------------------------------ +real(dp),dimension(:),intent(in):: a +real(dp) :: b +b=sqrt(dot_product(a,a)) +end function norv_d +!============================================================================= +pure function norv_c(a)result(b)! [norv] +!============================================================================= +! Norm of vector a +!------------------------------ +complex(dpc),dimension(:),intent(in):: a +real(dp) :: b +b=sqrt(real(dot_product(a,a))) +end function norv_c + +!============================================================================= +pure function mulmd_i(a,d)result(b)! [mulmd] +!============================================================================= +! matrix times diagonal +!------------------------------ +integer,dimension(:,:), intent(in):: a +integer,dimension(:) , intent(in):: d +integer,dimension(size(a,1),size(a,2)):: b +integer :: i +forall(i=1:size(a,2))b(:,i)=a(:,i)*d(i) +end function mulmd_i +!============================================================================= +pure function mulmd_d(a,d)result(b)! [mulmd] +!============================================================================= +! matrix times diagonal +!------------------------------ +real(dp),dimension(:,:), intent(in):: a +real(dp),dimension(:) , intent(in):: d +real(dp),dimension(size(a,1),size(a,2)):: b +integer :: i +forall(i=1:size(a,2))b(:,i)=a(:,i)*d(i) +end function mulmd_d +!============================================================================= +pure function mulmd_c(a,d)result(b)! [mulmd] +!============================================================================= +! matrix times diagonal +!------------------------------ +complex(dpc),dimension(:,:), intent(in):: a +complex(dpc),dimension(:) , intent(in):: d +complex(dpc),dimension(size(a,1),size(a,2)):: b +integer :: i +forall(i=1:size(a,2))b(:,i)=a(:,i)*d(i) +end function mulmd_c + +!============================================================================= +pure function muldm_i(d,a)result(b)! [muldm] +!============================================================================= +! matrix times diagonal +!------------------------------ +integer,dimension(:) , intent(in):: d +integer,dimension(:,:), intent(in):: a +integer,dimension(size(a,1),size(a,2)):: b +integer :: i +forall(i=1:size(a,1))b(i,:)=d(i)*a(i,:) +end function muldm_i +!============================================================================= +pure function muldm_d(d,a)result(b)! [muldm] +!============================================================================= +! matrix times diagonal +!------------------------------ +real(dp),dimension(:) , intent(in):: d +real(dp),dimension(:,:), intent(in):: a +real(dp),dimension(size(a,1),size(a,2)):: b +integer :: i +forall(i=1:size(a,1))b(i,:)=d(i)*a(i,:) +end function muldm_d +!============================================================================= +pure function muldm_c(d,a)result(b)! [muldm] +!============================================================================= +! matrix times diagonal +!------------------------------ +complex(dpc),dimension(:) , intent(in):: d +complex(dpc),dimension(:,:), intent(in):: a +complex(dpc),dimension(size(a,1),size(a,2)):: b +integer :: i +forall(i=1:size(a,1))b(i,:)=d(i)*a(i,:) +end function muldm_c + +!============================================================================= +pure function diagmofd_i(d)result(a)! [diag] +!============================================================================= +! Diagonal matrix possessing given diagonal elements +!------------------------------ +integer,dimension(:), intent(in):: d +integer,dimension(size(d),size(d)):: a +integer :: i +a=0; forall(i=1:size(d))a(i,i)=d(i) +end function diagmofd_i +!============================================================================= +pure function diagmofd_d(d)result(a)! [diag] +!============================================================================= +! Diagonal matrix possessing given diagonal elements +!------------------------------ +real(dp),dimension(:), intent(in):: d +real(dp),dimension(size(d),size(d)):: a +integer :: i +a=0; forall(i=1:size(d))a(i,i)=d(i) +end function diagmofd_d +!============================================================================= +pure function diagmofd_c(d)result(a)! [diag] +!============================================================================= +! Diagonal matrix possessing given diagonal elements +!------------------------------ +complex(dpc),dimension(:), intent(in):: d +complex(dpc),dimension(size(d),size(d)):: a +integer :: i +a=0; forall(i=1:size(d))a(i,i)=d(i) +end function diagmofd_c + +!============================================================================= +pure function diagdofm_i(a)result(d)! [diag] +!============================================================================= +! Diagonal vector of principal diagonal elements of square matrix +!------------------------------ +integer,dimension(:,:),intent(in):: a +integer,dimension(size(a,1)) :: d +integer :: i +forall(i=1:size(a,1))d(i)=a(i,i) +end function diagdofm_i +!============================================================================= +pure function diagdofm_d(a)result(d)! [diag] +!============================================================================= +! Diagonal vector of principal diagonal elements of square matrix +!------------------------------ +real(dp),dimension(:,:),intent(in):: a +real(dp),dimension(size(a,1)) :: d +integer :: i +forall(i=1:size(a,1))d(i)=a(i,i) +end function diagdofm_d +!============================================================================= +pure function diagdofm_c(a)result(d)! [diag] +!============================================================================= +! Diagonal vector of principal diagonal elements of square matrix +!------------------------------ +complex(dpc),dimension(:,:),intent(in):: a +complex(dpc),dimension(size(a,1)) :: d +integer :: i +forall(i=1:size(a,1))d(i)=a(i,i) +end function diagdofm_c + +!============================================================================= +function invm_d(a)result(b)! [inv] +!============================================================================= +use pmat, only: sinv=>inv +real(dp),dimension(:,:), intent(in):: a +real(dp),dimension(size(a,1),size(a,1)):: b +logical :: ff +b=a; call sinv(b,ff) +if(ff)stop 'In function invm_d; matrix singular, unable to continue' +end function invm_d +!============================================================================= +function invm_c(a)result(b)! [inv] +!============================================================================= +use pmat, only: sinv=>inv +complex(dpc),dimension(:,:), intent(in):: a +complex(dpc),dimension(size(a,1),size(a,1)):: b +logical :: ff +b=a; call sinv(b,ff) +if(ff)stop 'In function invm_c; matrix singular, unable to continue' +end function invm_c +!============================================================================= +function finvm_d(a,ff)result(b)! [inv] +!============================================================================= +use pmat, only: sinv=>inv +real(dp),dimension(:,:), intent(in ):: a +logical, intent(out):: ff +real(dp),dimension(size(a,1),size(a,1)) :: b +b=a; call sinv(b,ff) +if(ff) write(41,'("In function finvm_d; singular matrix")') +end function finvm_d +!============================================================================= +function finvm_c(a,ff)result(b)! [inv] +!============================================================================= +use pmat, only: sinv=>inv +complex(dpc),dimension(:,:), intent(in ):: a +logical, intent(out):: ff +complex(dpc),dimension(size(a,1),size(a,1)) :: b +b=a; call sinv(b,ff) +if(ff) write(41,'("In function finvm_c; singular matrix")') +end function finvm_c + +!============================================================================= +function invmv_d(a,v)result(u)! [inv] +!============================================================================= +use pmat, only: sinv=>inv +real(dp),dimension(:,:), intent(in):: a +real(dp),dimension(:) , intent(in):: v +real(dp),dimension(size(a,1),size(a,1)):: b +real(dp),dimension(size(a,1)) :: u +logical :: ff +b=a; u=v; call sinv(b,u,ff) +if(ff)stop 'IN function invmv_d; matrix singular, unable to continue' +end function invmv_d +!============================================================================= +function invmv_c(a,v)result(u)! [inv] +!============================================================================= +use pmat, only: sinv=>inv +complex(dpc),dimension(:,:), intent(in):: a +complex(dpc),dimension(:) , intent(in):: v +complex(dpc),dimension(size(a,1),size(a,1)):: b +complex(dpc),dimension(size(a,1)) :: u +logical :: ff +b=a; u=v; call sinv(b,u,ff) +if(ff)stop 'IN function invmv_c; matrix singular, unable to continue' +end function invmv_c +!============================================================================= +function finvmv_d(a,v,ff)result(u)! [inv] +!============================================================================= +use pmat, only: sinv=>inv +real(dp),dimension(:,:), intent(in):: a +real(dp),dimension(:) , intent(in):: v +logical, intent(out):: ff +real(dp),dimension(size(a,1),size(a,1)) :: b +real(dp),dimension(size(a,1)) :: u +b=a; u=v; call sinv(b,u,ff) +if(ff) write(41,'("In function finvmv_d; singular matrix")') +end function finvmv_d +!============================================================================= +function finvmv_c(a,v,ff)result(u)! [inv] +!============================================================================= +use pmat, only: sinv=>inv +complex(dpc),dimension(:,:), intent(in ):: a +complex(dpc),dimension(:) , intent(in ):: v +logical, intent(out):: ff +complex(dpc),dimension(size(a,1),size(a,1)) :: b +complex(dpc),dimension(size(a,1)) :: u +b=a; u=v; call sinv(b,u,ff) +if(ff) write(41,'("In function finvmv_c; singular matrix")') +end function finvmv_c + +!============================================================================= +pure function mulpp_i(a,b)result(c)! [mulpp] +!============================================================================= +! Multiply two polynomials expressed by their coefficients, or convolve +! two one-sided discrete distributions of not necessarily equal size. +!============================================================================= +integer,dimension(0:),intent(in) :: a,b +integer,dimension(0:size(a)+size(b)-2):: c +integer :: i,j +integer :: ai +c=0;do i=0,size(a)-1;ai=a(i);forall(j=0:size(b)-1)c(i+j)=c(i+j)+ai*b(j); enddo +end function mulpp_i +!============================================================================= +pure function mulpp_d(a,b)result(c)! [mulpp] +!============================================================================= +real(dp),dimension(0:),intent(in) :: a,b +real(dp),dimension(0:size(a)+size(b)-2):: c +integer :: i,j +real(dp) :: ai +c=0;do i=0,size(a)-1;ai=a(i);forall(j=0:size(b)-1)c(i+j)=c(i+j)+ai*b(j); enddo +end function mulpp_d +!============================================================================= +pure function mulpp_c(a,b)result(c)! [mulpp] +!============================================================================= +complex(dpc),dimension(0:),intent(in) :: a,b +complex(dpc),dimension(0:size(a)+size(b)-2):: c +integer :: i,j +complex(dpc) :: ai +c=0;do i=0,size(a)-1;ai=a(i);forall(j=0:size(b)-1)c(i+j)=c(i+j)+ai*b(j); enddo +end function mulpp_c + +!============================================================================= +pure function nmulpp_i(n,a,b)result(c)! [mulpp] +!============================================================================= +! Multiply two polynomials expressed by their coefficients, or convolve +! two one-sided discrete distributions of fixed size, truncating the result +! to the same size. +!============================================================================= +integer, intent(in):: n +integer,dimension(0:n),intent(in):: a,b +integer,dimension(0:n) :: c +integer :: i,j +integer :: ai +c=0; do i=0,n; ai=a(i);forall(j=0:n-i)c(i+j)=c(i+j)+ai*b(j); enddo +end function nmulpp_i +!============================================================================= +pure function nmulpp_d(n,a,b)result(c)! [mulpp] +!============================================================================= +integer, intent(in):: n +real(dp),dimension(0:n),intent(in):: a,b +real(dp),dimension(0:n) :: c +integer :: i,j +real(dp) :: ai +c=0; do i=0,n; ai=a(i);forall(j=0:n-i)c(i+j)=c(i+j)+ai*b(j); enddo +end function nmulpp_d +!============================================================================= +pure function nmulpp_c(n,a,b)result(c)! [mulpp] +!============================================================================= +integer, intent(in):: n +complex(dpc),dimension(0:n),intent(in):: a,b +complex(dpc),dimension(0:n) :: c +integer :: i,j +complex(dpc) :: ai +c=0; do i=0,n; ai=a(i);forall(j=0:n-i)c(i+j)=c(i+j)+ai*b(j); enddo +end function nmulpp_c + +!============================================================================= +pure function difp_d(a)result(b)! [difp] +!============================================================================= +! Differentiate the polynomial, result being of degree one less. +!============================================================================= +real(dp),dimension(0:),intent(in):: a +real(dp),dimension(0:size(a)-2) :: b +integer :: i +forall(i=1:size(a)-1)b(i-1)=i*a(i) +end function difp_d +!============================================================================= +pure function difp_c(a)result(b)! [difp] +!============================================================================= +complex(dpc),dimension(0:),intent(in):: a +complex(dpc),dimension(0:size(a)-2) :: b +integer :: i +forall(i=1:size(a)-1)b(i-1)=i*a(i) +end function difp_c +!============================================================================= +pure function ndifp_d(n,a)result(b)! [difp] +!============================================================================= +! Differentiate the polynomial of fixed degree, force result to be same degree +!============================================================================= +integer, intent(in):: n +real(dp),dimension(0:n),intent(in):: a +real(dp),dimension(0:n) :: b +integer :: i +b(n)=0; forall(i=1:n)b(i-1)=i*a(i) +end function ndifp_d +!============================================================================= +pure function ndifp_c(n,a)result(b)! [difp] +!============================================================================= +integer, intent(in):: n +complex(dpc),dimension(0:n),intent(in):: a +complex(dpc),dimension(0:n) :: b +integer :: i +b(n)=0; forall(i=1:n)b(i-1)=i*a(i) +end function ndifp_c + +!============================================================================= +pure function intp_d(a)result(b)! [intp] +!============================================================================= +! Integrate the polynomial, result being of degree one greater. +!============================================================================= +real(dp),dimension(0:),intent(in):: a +real(dp),dimension(0:size(a)) :: b +integer :: i +b(0)=0; forall(i=1:size(a))b(i)=a(i-1)/i +end function intp_d +!============================================================================= +pure function intp_c(a)result(b)! [intp] +!============================================================================= +complex(dpc),dimension(0:),intent(in):: a +complex(dpc),dimension(0:size(a)) :: b +integer :: i +b(0)=0; forall(i=1:size(a))b(i)=a(i-1)/i +end function intp_c +!============================================================================= +pure function nintp_d(n,a)result(b)! [intp] +!============================================================================= +! Integrate the polynomial of fixed degree, force result to be same degree +!============================================================================= +integer, intent(in):: n +real(dp),dimension(0:n),intent(in):: a +real(dp),dimension(0:n) :: b +integer :: i +b(0)=0; forall(i=1:n)b(i)=a(i-1)/i +end function nintp_d +!============================================================================= +pure function nintp_c(n,a)result(b)! [intp] +!============================================================================= +integer, intent(in):: n +complex(dpc),dimension(0:n),intent(in):: a +complex(dpc),dimension(0:n) :: b +integer :: i +b(0)=0; forall(i=1:n)b(i)=a(i-1)/i +end function nintp_c + +!============================================================================= +pure function ninvp_d(n,a)result(b)! [invp] +!============================================================================= +integer, intent(in):: n +real(dp),dimension(0:n),intent(in):: a +real(dp),dimension(0:n) :: b +integer :: i +real(dp) :: b0 +b0=1/a(0); b(0)=b0; do i=1,n; b(i)=-b0*sum(b(i-1:0:-1)*a(1:i)); enddo +end function ninvp_d +!============================================================================= +pure function ninvp_c(n,a)result(b)! [invp] +!============================================================================= +integer, intent(in):: n +complex(dpc),dimension(0:n),intent(in):: a +complex(dpc),dimension(0:n) :: b +integer :: i +complex(dpc) :: b0 +b0=1/a(0); b(0)=b0; do i=1,n; b(i)=-b0*sum(b(i-1:0:-1)*a(1:i)); enddo +end function ninvp_c + +!============================================================================= +pure function npowp_d(n,a,m)result(b)! [powp] +!============================================================================= +integer, intent(in):: n,m +real(dp),dimension(0:n),intent(in):: a +real(dp),dimension(0:n) :: b +integer :: i +b=0; b(0)=1; do i=1,m; b=nmulpp_d(n,a,b); enddo +end function npowp_d +!============================================================================= +pure function npowp_c(n,a,m)result(b)! [powp] +!============================================================================= +integer, intent(in):: n,m +complex(dpc),dimension(0:n),intent(in):: a +complex(dpc),dimension(0:n) :: b +integer :: i +b=0; b(0)=1; do i=1,m; b=nmulpp_c(n,a,b); enddo +end function npowp_c + +!============================================================================= +pure function polps_d(a,s1)result(s2) ! [polps] +!============================================================================= +real(dp),dimension(0:),intent(in):: a +real(dp), intent(in):: s1 +real(dp) :: s2 +integer :: i,n +n=size(a)-1; s2=a(n); do i=n-1,0,-1; s2=s2*s1+a(i); enddo +end function polps_d +!============================================================================= +pure function polps_c(a,s1)result(s2) ! [polps] +!============================================================================= +complex(dpc),dimension(0:),intent(in):: a +complex(dpc), intent(in):: s1 +complex(dpc) :: s2 +integer :: i,n +n=size(a)-1; s2=a(n); do i=n-1,0,-1; s2=s2*s1+a(i); enddo +end function polps_c +!============================================================================= +pure function npolps_d(n,a,s1)result(s2) ! [polps] +!============================================================================= +integer, intent(in):: n +real(dp),dimension(0:n),intent(in):: a +real(dp), intent(in):: s1 +real(dp) :: s2 +integer :: i +s2=a(n); do i=n-1,0,-1; s2=s2*s1+a(i); enddo +end function npolps_d +!============================================================================= +pure function npolps_c(n,a,s1)result(s2) ! [polps] +!============================================================================= +integer, intent(in):: n +complex(dpc),dimension(0:n),intent(in):: a +complex(dpc), intent(in):: s1 +complex(dpc) :: s2 +integer :: i +s2=a(n); do i=n-1,0,-1; s2=s2*s1+a(i); enddo +end function npolps_c + +!============================================================================= +pure function npolpp_d(n,a,b)result(c)! [polpp] +!============================================================================= +! Up to degree n, get polynomial series c(x)=a(b(x)) +!-------------------------------- +integer, intent(in):: n +real(dp),dimension(0:n),intent(in):: a,b +real(dp),dimension(0:n) :: c +integer :: i +c=a(n); do i=n-1,0,-1; c=nmulpp_d(n,c,b)+a(i); enddo +end function npolpp_d +!============================================================================= +pure function npolpp_c(n,a,b)result(c)! [polpp] +!============================================================================= +integer, intent(in):: n +complex(dpc),dimension(0:n),intent(in):: a,b +complex(dpc),dimension(0:n) :: c +integer :: i +c=a(n); do i=n-1,0,-1; c=nmulpp_c(n,c,b)+a(i); enddo +end function npolpp_c + +!----------------------------------------------------------------------------- +! Banded matrix functions begin here: + +!============================================================================= +pure function copbm_d(m1,m2,mah1,mah2,aband)result(afull)! [copbm] +!============================================================================= +integer, intent(IN ) :: m1, m2, mah1, mah2 +real(dp),dimension(m1,-mah1:mah2),intent(IN ) :: aband +real(dp),dimension(m1,m2) :: afull +integer :: i1,i2, i, j +!============================================================================= +afull=0. +do j=1,m1; i1=max(1,1-j); i2=min(m1,m2-j) + do i=i1,i2; afull(i,j+i)= aband(i,j); enddo +enddo +end function copbm_d +!============================================================================= +pure function copbm_c(m1,m2,mah1,mah2,aband)result(afull)! [copbm] +!============================================================================= +integer, intent(IN ) :: m1, m2, mah1, mah2 +complex(dpc),dimension(m1,-mah1:mah2),intent(IN ) :: aband +complex(dpc),dimension(m1,m2) :: afull +integer :: i1,i2, i, j +!============================================================================= +afull=0. +do j=1,m1; i1=max(1,1-j); i2=min(m1,m2-j) + do i=i1,i2; afull(i,j+i)= aband(i,j); enddo +enddo +end function copbm_c + +!============================================================================= +pure function copmb_d(m1,m2,mah1,mah2,afull)result(aband)! [copmb] +!============================================================================= +use pmat2, only: clipb +integer, intent(IN ):: m1, m2, mah1, mah2 +real(dp),dimension(m1,m2), intent(IN ):: afull +real(dp),dimension(m1,-mah1:mah2) :: aband +integer :: i1,i2, i, j +!============================================================================= +call clipb(m1,m2,mah1,mah2,aband) +do j=1,m1; i1=max(1,1-j); i2=min(m1,m2-j) + do i=i1,i2; aband(i,j)= afull(i,j+i); enddo +enddo +end function copmb_d +!============================================================================= +pure function copmb_c(m1,m2,mah1,mah2,afull)result(aband)! [copmb] +!============================================================================= +use pmat2, only: clipb +integer, intent(IN ):: m1, m2, mah1, mah2 +complex(dpc),dimension(m1,m2), intent(IN ):: afull +complex(dpc),dimension(m1,-mah1:mah2) :: aband +integer :: i1,i2, i, j +!============================================================================= +call clipb(m1,m2,mah1,mah2,aband) +do j=1,m1; i1=max(1,1-j); i2=min(m1,m2-j) + do i=i1,i2; aband(i,j)= afull(i,j+i); enddo +enddo +end function copmb_c + +!============================================================================= +pure function transposeb_d(m1,m2,mah1,mah2,a)result(b)! [transposeb] +!============================================================================= +use pmat2, only: clipb +integer, intent(IN):: m1, m2, mah1, mah2 +real(dp),dimension(m1,-mah1:mah2),intent(IN):: a +real(dp),dimension(m2,-mah2:mah1) :: b +integer :: j, i +!============================================================================= +call CLIPB(m2,m1,mah2,mah1,b) +do j=-mah1,mah2 + forall(i = max(1,1-j) : min(m1,m2-j))b(j+i,-j)=a(i,j) +enddo +end function transposeb_d +!============================================================================= +pure function transposeb_c(m1,m2,mah1,mah2,a)result(b)! [transposeb] +!============================================================================= +use pmat2, only: clipb +integer, intent(IN):: m1, m2, mah1, mah2 +complex(dpc),dimension(m1,-mah1:mah2),intent(IN):: a +complex(dpc),dimension(m2,-mah2:mah1) :: b +integer :: j, i +!============================================================================= +call CLIPB(m2,m1,mah2,mah1,b) +do j=-mah1,mah2 + forall(i = max(1,1-j) : min(m1,m2-j))b(j+i,-j)=a(i,j) +enddo +end function transposeb_c + +!============================================================================= +pure function mulbb_d(m1,m2,mah1,mah2,mbh1,mbh2, a,b)result(c)! [mulbb] +!============================================================================= +integer, intent(IN):: m1,m2,mah1,mah2,mbh1,mbh2 +real(dp),dimension(m1,-mah1:mah2),intent(in):: a +real(dp),dimension(m2,-mbh1:mbh2),intent(in):: b +real(dp) :: c(m1,-mah1-mbh1:mah2+mbh2) +integer:: j,k,jpk,i1,i2 +c=0 +do j=-mah1,mah2; do k=-mbh1,mbh2; jpk=j+k; i1=max(1,1-j); i2=min(m1,m2-j) + c(i1:i2,jpk)=c(i1:i2,jpk)+a(i1:i2,j)*b(j+i1:j+i2,k) +enddo; enddo +end function mulbb_d + +!============================================================================= +pure function mulbd_d(m1,m2,mah1,mah2,a,d)result(b)! [mulbd] +!============================================================================= +use pmat2, only: clipb +integer, intent(IN):: m1, m2, mah1, mah2 +real(dp),dimension(m1,-mah1:mah2),intent(in):: a +real(dp),dimension(m2) ,intent(in):: d +real(dp),dimension(m1,-mah1:mah2) :: b +integer :: j, i1,i2 +!============================================================================= +call CLIPB(m1,m2,mah1,mah2,b) +do j=-mah1,mah2; i1=max(1,1-j); i2=min(m1,m2-j) + b(i1:i2,j)=a(i1:i2,j)*d(j+i1:j+i2) +enddo +end function mulbd_d + +!============================================================================= +pure function muldb_d(m1,m2,mah1,mah2,d,a)result(b)! [muldb] +!============================================================================= +use pmat2, only: clipb +integer, intent(IN):: m1, m2, mah1, mah2 +real(dp),dimension(m1) ,intent(in):: d +real(dp),dimension(m1,-mah1:mah2),intent(in):: a +real(dp),dimension(m1,-mah1:mah2) :: b +integer :: j +call CLIPB(m1,m2,mah1,mah2,b) +do j=-mah1,mah2; b(:,j)=d(:)*a(:,j); enddo +forall(j=-mah1:mah2)b(:,j)=d(:)*a(:,j) +end function muldb_d + +!============================================================================= +pure function mulbv_d(m1,m2,mah1,mah2,a,v1)result(v2)! [mulbv] +!============================================================================= +integer, intent(IN ) :: m1, m2, mah1, mah2 +real(dp),dimension(m1,-mah1:mah2),intent(in):: a +real(dp),dimension(m2), intent(in):: v1 +real(dp),dimension(m1) :: v2 +integer :: j, i1,i2 +v2=0 +do j=-mah1,mah2; i1=max(1,1-j); i2=min(m1,m2-j) + v2(i1:i2) = v2(i1:i2) + a(i1:i2,j)*v1(j+i1:j+i2) +enddo +end function mulbv_d + +!============================================================================= +pure function mulbx_d(m1,m2,mah1,mah2,my,a,v1)result(v2)! [mulbx] +!============================================================================= +integer, intent(IN) :: m1, m2, mah1, mah2, my +real(dp),dimension(m1,-mah1:mah2),intent(in):: a +real(dp),dimension(m2,my), intent(in):: v1 +real(dp),dimension(m1,my) :: v2 +integer :: i,j +v2=0 +do j=-mah1,mah2 + do i=max(1,1-j),min(m1,m2-j); v2(i,:)=v2(i,:)+a(i,j)*v1(i+j,:); enddo + forall(i=max(1,1-j):min(m1,m2-j))v2(i,:)=v2(i,:)+a(i,j)*v1(i+j,:) +enddo +end function mulbx_d + +!============================================================================= +pure function mulby_d(m1,m2,mah1,mah2,mx,a,v1)result(v2)! [mulby] +!============================================================================= +integer, intent(IN ) :: m1, m2, mah1, mah2, mx +real(dp),dimension(m1,-mah1:mah2),intent(in):: a +real(dp),dimension(mx,m2), intent(in):: v1 +real(dp),dimension(mx,m1) :: v2 +integer :: i,j +v2=0 +do j=-mah1,mah2 + forall(i=max(1,1-j):min(m1,m2-j))v2(:,i)=v2(:,i)+a(i,j)*v1(:,i+j) +enddo +end function mulby_d + +!============================================================================= +pure function mulvb_d(m1,m2,mah1,mah2,v1,a)result(v2)! [mulvb] +!============================================================================= +integer, intent(IN) :: m1, m2, mah1, mah2 +real(dp),dimension(m1), intent(in):: v1 +real(dp),dimension(m1,-mah1:mah2),intent(in):: a +real(dp),dimension(m2) :: v2 +integer :: j, i1,i2 +v2=0 +do j=-mah1,mah2; i1=max(1,1-j); i2=min(m1,m2-j) + v2(j+i1:j+i2)=v2(j+i1:j+i2)+v1(i1:i2)*a(i1:i2,j) +enddo +end function mulvb_d + +!============================================================================= +pure function mulxb_d(m1,m2,mah1,mah2,my,v1,a)result(v2)! [mulxb] +!============================================================================= +integer, intent(IN) :: m1, m2, mah1, mah2, my +real(dp),dimension(m1,my), intent(in):: v1 +real(dp),dimension(m1,-mah1:mah2),intent(in):: a +real(dp),dimension(m2,my) :: v2 +integer :: i,j +v2=0 +do j=-mah1,mah2 + forall(i=max(1,1-j):min(m1,m2-j))v2(j+i,:)=v2(j+i,:)+v1(i,:)*a(i,j) +enddo +end function mulxb_d + +!============================================================================= +pure function mulyb_d(m1,m2,mah1,mah2,mx,v1,a)result(v2)! [mulyb] +!============================================================================= +integer, intent(IN):: m1, m2, mah1, mah2, mx +real(dp),dimension(mx,m1), intent(in):: v1 +real(dp),dimension(m1,-mah1:mah2),intent(in):: a +real(dp),dimension(mx,m2) :: v2 +integer :: i,j +v2=0 +do j=-mah1,mah2 + forall(i=max(1,1-j):min(m1,m2-j))v2(:,j+i)=v2(:,j+i)+v1(:,i)*a(i,j) +enddo +end function mulyb_d + +!============================================================================= +function L1Lb_d(m,mah,a)result(b)! [L1Lb] +!============================================================================= +integer, intent(IN ):: m, mah +real(dp),dimension(m,-mah:mah), intent(IN ):: a +real(dp),dimension(m,-mah:0) :: b +logical :: ff +b=fL1Lb_d(m,mah,a,ff) +if(ff)stop 'In L1Lb_d; matrix non-positive, cannot continue' +end function L1Lb_d +!============================================================================= +function fL1Lb_d(m,mah,a,ff)result(b)! [L1Lb] +!============================================================================= +use pietc, only: T,F +use pmat2, only: clipb +integer, intent(IN ):: m, mah +real(dp),dimension(m,-mah:mah), intent(IN ):: a +logical, intent(out):: ff ! <- failure flag +real(dp),dimension(m,-mah:0) :: b +integer :: i, j,jmi +real(dp) :: s +!============================================================================= +ff=F +call CLIPB(m,m,mah,0,b) +do j=1,m + s=a(j,0)-dot_product(b(j,-mah:-1),b(j,-mah:-1)) + if(s <= 0)then + ff=T + write(41,'("In fL1LB_d; non-positivity at diagonal index",i5)'),j + return + endif + s=sqrt(s); b(j,0)=s; s=1/s + do i=j+1,min(m,j+mah); jmi=j-i + b(i,jmi)=s*(a(i,jmi)-dot_product(b(i,-mah:jmi-1),b(j,-mah-jmi:-1))) + enddo +enddo +end function fL1Lb_d + +!============================================================================= +function u1ub_d(m,mah,a)result(b)! [u1ub] +!============================================================================= +integer, intent(IN ):: m, mah +real(dp),dimension(m,-mah:mah), intent(IN ):: a +real(dp),dimension(m,-mah:0) :: b +real(dp),dimension(m,-mah:mah) :: at +real(dp),dimension(m,-mah:0 ) :: bt +!============================================================================= +at=a(m:1:-1,mah:-mah:-1); bt=l1lb_d(m,mah,at); b=bt(m:1:-1,0:-mah:-1) +end function u1ub_d +!============================================================================= +function fu1ub_d(m,mah,a,ff)result(b)! [u1ub] +!============================================================================= +integer, intent(IN ):: m, mah +real(dp),dimension(m,-mah:mah), intent(IN ):: a +logical, intent(out):: ff ! <- failure flag +real(dp),dimension(m,-mah:0) :: b +real(dp),dimension(m,-mah:mah) :: at +real(dp),dimension(m,-mah:0 ) :: bt +!============================================================================= +at=a(m:1:-1,mah:-mah:-1); bt=fl1lb_d(m,mah,at,ff) +if(ff)then; write(41,'("In fulub_d; non-positive matrix")'); return; endif +b=bt(m:1:-1,0:-mah:-1) +end function fu1ub_d + +!============================================================================= +function LdLb_d(m,mah,a)result(b)! [LdLb] +!============================================================================= +integer, intent(IN):: m, mah +real(dp),dimension(m,-mah:mah),intent(IN):: a +real(dp),dimension(m,-mah:0) :: b +logical :: ff +b=fLdLb_d(m,mah,a,ff) +if(ff)stop 'In LdLb_d; matrix non-positive, unable to continue' +end function LdLb_d +!============================================================================= +function fLdLb_d(m,mah,a,ff)result(b)! [LdLb] +!============================================================================= +use pietc, only: T,F +use pmat2, only: clipb +integer, intent(IN ):: m, mah +real(dp),dimension(m,-mah:mah),intent(IN ):: a +logical, intent(out):: ff ! <- failure flag +real(dp),dimension(m,-mah:0) :: b +integer :: i, j,k,jmi,lj,li +real(dp) :: s,te +!============================================================================= +ff=F +call clipb(m,m,mah,0,b); b(:,0)=1 +do j=1,m; lj=max(-mah,1-j) + s=a(j,0) + do k=lj,-1 + s=s-b(j,k)**2*b(k+j,0) + enddo + if(s <= 0)then + ff=T + write(41,'(" In fLDLB_d; non-positivity at diagonal index",i5)'),j + return + endif + b(j,0)=s; s=1/s + do i=j+1,min(m,j+mah); jmi=j-i + li=max(-mah,1-i); + lj=li-jmi; + te=a(i,jmi) + do k=li,jmi-1 + te=te-b(i,k)*b(j,k-jmi)*b(i+k,0) + enddo + b(i,jmi)=s*te + enddo +enddo +b(:,0)=1/b(:,0) +end function fLdLb_d + +!============================================================================= +function udub_d(m,mah,a)result(b)! [udub] +!============================================================================= +integer, intent(in):: m, mah +real(dp),dimension(m,-mah:mah),intent(in):: a +real(dp),dimension(m,0:mah) :: b +real(dp),dimension(m,-mah:mah) :: at +real(dp),dimension(m,-mah:0) :: bt +at=a(m:1:-1,mah:-mah:-1);bt=LdLb_d(m,mah,at); b=bt(m:1:-1, 0:-mah:-1) +end function udub_d +!============================================================================= +function fudub_d(m,mah,a,ff)result(b)! [udub] +!============================================================================= +integer, intent(in ):: m, mah +real(dp),dimension(m,-mah:mah),intent(in ):: a +logical, intent(out):: ff ! <- failure flag +real(dp),dimension(m,0:mah) :: b +real(dp),dimension(m,-mah:mah) :: at +real(dp),dimension(m,-mah:0) :: bt +at=a(m:1:-1,mah:-mah:-1);bt=fLdLb_d(m,mah,at,ff) +if(ff)then; write(41,'("In fudub_d; matrix non-positive")'); return; endif +b=bt(m:1:-1, 0:-mah:-1) +end function fudub_d + + +end module pmat3 diff --git a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/prepacqc.f b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/prepacqc.f index 53bd62b1..e9f9e9d9 100755 --- a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/prepacqc.f +++ b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/prepacqc.f @@ -1,7862 +1,1691 @@ -C$$$ MAIN PROGRAM DOCUMENTATION BLOCK -C -C MAIN PROGRAM: PREPOBS_PREPACQC -C PRGMMR: KEYSER ORG: NP22 DATE: 2008-07-30 -C -C ABSTRACT: READS IN PREPBUFR FILE CONTAINING ALL PREPROCESSED DATA -C TYPES. {ONLY BUFR TABLE A ENTRY MESSAGES "AIRCFT " ARE OPERATED -C ON.} SORTS BY STATION ID, DOES TRACK CHECKING, AND AGGRAGATES OBS -C BY POSITION (CALLED A 'STACK'). DOES QUALITY CONTROL BY MAKING -C TRACK CHECKS ON FLIGHTS, REMOVING DUPLICATES, COMPARING COLOCATED -C OBSERVATIONS, AND, IF REQUESTED, FORMING SUPEROBS OF THOSE WINDS -C PASSING THE QUALITY CHECKS. A SERIES OF NEW PREPBUFR QUALITY MARKS -C ARE ATTACHED TO EACH OBSERVATION (SEE REMARKS). FINALLY: WRITES -C STACKED EVENTS (CONSISTING OF THE UPDATED PREPBUFR QUALITY MARKS) -C ONTO THE EXISTING PREPBUFR DATA FOR THOSE OBS WHICH ARE NOT -C ORIGINALLY "BAD". IN ALL CASES, THE NEW FILE CONTAINS ALL OF THE -C ORIGINAL OBSERVATIONAL DATA (P-ALT, TEMP, WIND) MINUS THE -C DUPLICATES AND THOSE OUTSIDE THE DESIRED TIME WINDOW. IF -C APPLICABLE, ADDITIONAL SUPEROBS WILL BE ADDED. OBSERVATIONS THAT -C ARE USED TO GENERATE A SUPEROB ARE FLAGGED IN THE WIND AND -C TEMPERATURE QUALITY MARKERS TO ENSURE THAT THEY ARE OMITTED FROM -C THE ANALYSIS SCHEME. AIREP/PIREP AND SUPEROB REPORTS OVER -C CONTINENTAL U.S. AND SURROUNDING ENVIRONS MAY ALSO BE FLAGGED AND -C EXCLUDED FROM ANALYSIS SCHEME IF REQUESTED. -C -C PROGRAM HISTORY LOG: -C 1989-04-01 P. JULIAN (W/NMC00) -- ORIGINAL AUTHOR -C 1990-03-29 P. JULIAN -- MODIFIED TO HONOR SDM/QCAIRCFT PURGE FOR -C STACKED OBSERVATIONS (OBS. INCRMENT CHECK) -C 1990-04-16 P. JULIAN -- MODIFIED TO PACK SUPEROBS ONE AT A -C TIME ON SINGLE LEVELS ONLY -C 1990-06-14 D. A. KEYSER -- INCLUDED PROCESSING OF TEMP; CORRECTED -C ERROR LEADING TO LOSS OF SOME OBS. IN REPACKING; COR- -C RECTED TO HONOR ALL SDM/QCAIRCFT PURGES FOR STACKED -C OBS. AND ALL SDM KEEPS FOR ISOLATED OBS.; CORRECTED -C SLIGHT ERROR IN LAT/LON IN OUTPUT FILE FOR SOME OBS. -C 1990-07-03 D. A. KEYSER -- SOME OMIT Q.M. INCORRECTLY CHGED, FIXED; -C ALT. CORRESP. TO PRESS. OF 300 & 200 MB FOR REGRESS. -C CALC. OF SUPEROBS OFF SLIGHTLY, FIXED; ADDED 1 TO -C OUTPUT TIME FOR MULT. SUPEROBS IN SAME STACK W/ SAME -C ORIG. TIME (SO OI WON'T TOSS AS DUPLICATES) -C 1990-09-18 D. A. KEYSER -- MINOR ERROR IN LOGIC CORRECTED, SOME ORIG. -C REPORTS WERE BEING GIVEN 'O' Q. MARK BY MISTAKE -C 1990-11-08 D. A. KEYSER -- INCREASED ARRAY SIZES FROM 2000 TO 8000 -C TO ALLOW FOR ACARS REPORTS WHICH CAN HAVE .GT. 2000 -C REPORTS IN THE 'AIRCAR' FILE ***OVER-RIDDEN** -C 1991-02-26 G. J. DIMEGO -- ADDED FT05 INPUT FOR VARIABLE WINDOW -C AND A VARIABLE TIME-INCREMENT FOR MULTI-LEVEL SUPROBS -C AND ADDED CALL TO QSORT TO ENSURE ASCENDING LATITUDE -C 1991-12-04 D. A. KEYSER -- ALL ASDAR REPORTS NOW CONSIDERED ISO- -C LATED OBS. AND CANNOT BE USED TO FORM A SUPEROB, -C PRIOR TO CHANGE ASDAR REPORTS COULD BE SUPEROBED -C 1992-09-02 D. A. KEYSER -- THE SDM/QCAIRCFT PURGE FLAG IS NOW -C OBTAINED IN THE FIRST POSITION OF THE Q. M. WORD RATHER -C THAN THE FOURTH POSITION -C 1993-01-05 P. JULIAN-- THIS VERSION CONSIDERABLY REVISED OVER THAT -C ABOVE. NEW SUBPROGRAMS ADDED TO DO TRACK CHECK. TEMPS -C ARE NOW QC'D WITH NEW SUBPROGRAM. ENTIRE NEW SET OF -C ON29(REVISED) Q MARKS USED. SEE OFFICE NOTE XXX FOR -C DETAILS-ALSO DOCBLOCKS IN SUBPROGRAMS -C 1993-06-05 P. JULIAN-- THIS VERSION REVISED TO PRODUCE CODE FOR -C EITHER HDS OR CRAY. SORT ROUTINES ARE LOCAL. -C 1994-01-01 P. JULIAN-- THIS VERSION REVISED TO PRODUCE CODE FOR -C OPERATIONAL USE. QUAL MARKS REVISED ONCE AGAIN -C 1994-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND -C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT; ADDED -C REPACKING OF ORIGINAL RESERVE CHARACTER INFO PLUS OTHER -C META-DATA IN ON29 CATEGORY 8 FOR NON-SUPEROBED REPORTS; -C ADDED ABILITY TO I/O A PREPBUFR FILE AND ADD STACKED -C EVENTS CONSISTING OF UPDATED WIND AND TEMPERATURE -C QUALITY MARKERS; SEVERAL ERRORS DETECTED AND CORRECTED -C 1995-02-10 D. A. KEYSER -- MINOR CHANGE TO ALLOW WAYPOINT CORRECTED -C LAT/LON TO BE CARRIED BACK TO CALLING SUBROUTINE FOR -C WAYPOINT CALL REASON # 3 (WASN'T BEING DONE BEFORE); -C WAYPOINT CALL IN MAIN FOR ISOLATED REPORTS ALSO WAS NOT -C RESETTING LAT/LON AND TAGS WHEN WAYPOINT CORR. MADE; -C ADDED COND. CODE 24 IF NO. RPTS. IN A TRACK EXCEEDS -C PARAMETER "ITMX", THIS IS BUMPED UP FROM 40 TO 500; -C PARAMETER "ISMX" IS BUMPED UP FROM 64 TO 128 -C 1995-03-27 D. A. KEYSER -- ASDAR/AMDAR TMP/WND RPTS NOT FLAGGED BY -C OTHER CHKS NOW GET "GOOD" Q.M. (& FOR INIDST=2, NEW RSN. -C CODE 28) REGARDLESS OF SCALED VECTOR INCR. (BEFORE Q.M. -C BASED ON S.V. INCR.); ALL ASDAR/AMDAR RPTS IN A TRACK W/ -C AVG. INCR. > 70 KTS AMONGST > 14 RPTS. GET FLAGGED WIND -C (& LATER TEMP) (& FOR INIDST=2, NEW RSN. CODE 27); ADDED -C NEW SUBR. CMDDFF (WIND U/V TO SPD/DIR); FOR INIDST=2, -C STORES FORECAST(GUESS) P-ALT, WIND DIR, WIND SPEED & TEMP -C FOR EACH DECODED RPT (DIR/SPEED OBTAINED FROM FCST U/V); -C FOR INIDST=2 & DOSPOB=T: SUPEROBS NOW CONTAIN S-OBED FCST -C P-ALT, WIND DIR, WIND SPEED & TEMP (IF AVAIL. FROM INDIV. -C RPTS MAKING UP SUPEROBS), FCST INFO. THEN ENCODED IN BUFR -C ALONG W/ REST OF S-OB DATA (FCST DIR/SPEED CONV. TO U/V); -C N-LIST SWITCHES "JAMASS" & "JAWIND" NOW 6-WORD ARRAYS, -C REPORTS CAN NOW BE EXCLUDED FROM OUTPUT ACCORDING TO -C LAT. BAND; N-LIST SWITCH "FLAGUS"(LOGICAL) REPLACED BY -C "IFLGUS"(INTEGER), WHERE IFLGUS=0(1) EQUATES TO -C FLAGUS=F(T) AND NEW CHOICE IFLGUS=2 MEANS EXCLUDE RPTS -C OVER U.S. FROM OUTPUT RATHER THAN JUST FLAGGING -C 1995-04-26 D. A. KEYSER -- CORRECTED PROBLEM IN SUPEROBING GUESS -C (OCCASIONALLY OCCURRED); ALL ASDAR/AMDAR RPTS IN A TRACK -C W/ > 14 RPTS GET FLAGGED WIND (& LATER TEMP) IF > 9 RPTS -C HAVE WIND INCR. > 50 KNOTS (CHANGE FROM PREVIOUS TEST, -C SEE PREVIOUS HISTORY LOG); ADDED 300 TO REASON CODES -C TO PREPARE FOR NEW BUFR USER TABLE, ORIGINAL REASON -C CODE VALUES ARE STILL ENCODED INTO BUFR DUE TO 8-BIT -C LIMIT IN CURRENT USER TABLE; PROGRAM CODE STILL ENCODED -C INTO BUFR BUT ITS VALUE HARDWIRED TO 7 (IN PREP. FOR -C NEW BUFR USER TABLE WHICH WILL NO LONGER HAVE PGM CODE) -C 1995-05-30 D. A. KEYSER -- ADDED PARAMETER NAME "LSIZE" FOR MAX. -C NO. OF LAT/LON CORRECTIONS IN WAYPOINT FILE, ADDED -C COND. CODE 25 IF PARAMETER NAME "LSIZE" IS EXCEEDED; -C IN SUBR. INDEXF/INDEXC, TESTS FOR < 2 ELEMENTS IN SORT -C LIST, IF SO RETURNS W/O SORTING (BUT FILLS INDX ARRAY); -C THE INPUT TIME WINDOW IS NOW SET TO THE LARGER OF 3-HRS -C 15-MIN OR INPUT NAMELIST SWITCH "WINDOW" PLUS 15-MIN, -C ALLOWING THE TRACK CHECKING TO DE DONE PROPERLY -C (PREVIOUSLY THIS WAS SET TO "WINDOW" PLUS 15-MIN., BUT -C THIS COULD ADVERSELY AFFECT THE TRACK CHECK FOR SMALL -C OUTPUT TIME WINDOWS); RECEIPT TIME TEST CHANGED TO CHECK -C FOR DATA WITH RECEIPT TIME OUTSIDE THE RANGE OF REPORT -C TIME MINUS 1-HOUR TO REPORT TIME PLUS 11.99 HOURS (SUCH -C REPORTS ARE SKIPPED), BEFORE ONLY TESTED FOR RECEIPT -C TIME OUTSIDE RANGE OF REPORT TIME MINUS 1-HOUR; ADDED -C NAMELIST SWITCH "RCPTST", IF FALSE THEN THE RECEIPT TIME -C TEST IS NOT PERFORMED -C 1995-07-06 D. A. KEYSER -- ADDED CHECK FOR ALL REPORTS WITH -C ALTITUDE BETWEEN 2000 & 5000 FT., IF TEMPERATURE DIFFERS -C FROM GUESS BY > 25 DEG. C THE WIND AND TEMPERATURE ARE -C FLAGGED AS BAD (AND ARE ASSIGNED THE NEW REASON CODE -C "302" FOR OUTPUT TO PREPBUFR FILE) {REPORT IS FLAGGED -C HERE BECAUSE A "0" DIGIT HAS PROBABLY BEEN DROPPED FROM -C THE TRUE ALTITUDE BETWEEN 20,000 & 50,000 FT.}; FIXED -C TIME WINDOW CHECK TO HANDLE REPORTS IN FILES THAT HAVE -C A TIME OF 0100 TO 0500 UTC (SIMILAR TO WHAT OCCURS FOR -C 0000 UTC FILE TIME); REPORTS IN A STACK OF TWO NOW GET -C TEMPERATURE AND WIND FLAGGED AS BAD (AND ARE ASSIGNED -C THE NEW REASON CODE "329" FOR OUTPUT TO PREPBUFR -C FILE) IF THE SCALED VECTOR WIND INCREMENT IS LARGE -C (IN THE RANGE 'V' TO 'Z'), A SUPEROB IS NEVER STORED; -C IN SUBR. IDSORT, NO LONGER SETS CHAR. ' ' TO '0' IN -C WORKING STNID ARRAY PRIOR TO IDSORT (WAS BREAKING-UP -C SOME TRACKS AND WAS NEVER NEEDED FOR ANY OTHER REASON); -C ASDAR/AMDAR REPORTS NOW GET TEMPERATURE AND WIND Q. -C MARKS SET TO "SUSPECT" (AND ARE ASSIGNED THE NEW REASON -C CODE "330" FOR OUTPUT TO PREPBUFR FILE) IF THE -C PHASE OF FLIGHT INDICATOR IS MISSING (INDICATES A -C PROBABLE "BANKING" AIRCRAFT WITH SUSPECT DATA QUALITY) -C 1995-11-08 D. A. KEYSER -- INCREASED THE SIZE OF PARAMETER "LSIZE" -C FROM 26 TO 50 -C 1996-01-26 D. A. KEYSER -- CORRECTED DIVIDE-BY-ZERO POSSIBILITY IN -C THE CALCULATION OF MULTIPLE CORRELATIONS IN SUBROUTINE -C 'SUPROB' -C 1996-10-18 D. A. KEYSER -- NOW CLOSES INPUT BUFR DATA SET AFTER ALL -C REPORTS HAVE BEEN READ IN BY SUBR. IBUFR, UPDATED BUFRLIB -C CAUSES PGM TO ABORT WITH CALL TO OPENBF IN SUBR. OBUFR -C W/O THIS FIX -C 1996-12-10 D. A. KEYSER -- INCREASED THE SIZE OF PARAMETERS "IRMX" -C FROM 5000 TO 10000, "ISMX" FROM 500 TO 1000, "ISUP" FROM -C 250 TO 500, AND "ITMX" FROM 500 TO 1000 - ALL TO -C ACCOUNT FOR INCREASED NUMBER OF REPORTS PROCESSED BY NEW -C UNIX DECODERS -C 1997-06-03 D. A. KEYSER -- FOR INPUT PREPBUFR FORMAT, ASDAR/AMDAR -C REPORTS ARE NOW IDENTIFIED BY "TYP" OF 131/231 RATHER -C THAN BY A 'Z' IN 6'TH POSITION OF STNID SINCE STNID IN -C PREPBUFR NOW CONTAINS ACTUAL ASDAR/AMDAR STNID (UP TO -C 8-CHARACTERS, NO LONGER 'Z' IN 6'TH POS. OF STNID) -C 1998-02-17 D. A. KEYSER -- REMOVED LOGIC PERTAINING TO INPUT AND -C OUTPUT IN OFFICE NOTE 29 FORMAT (OBSOLETE); IMPROVED -C PRINT IN SDMACQC FILE IN UNIT 52 -C 1998-10-07 D.A. KEYSER -- PROGRAM NOW Y2K AND FORTRAN 90 COMPLIANT -C 1999-08-23 D.A. KEYSER -- MODIFIED TO RUN ON IBM SP MACHINE; ADDED -C HIGHER ORDERS IN CHARACTER SORTS TO HOPEFULLY ALWAYS -C GIVE SAME SORT ORDER REGARDLESS OF INPUT REPORT ORDER; -C CHANGED ALL TAGS AND QMARKS THAT WERE BLANK (' ') TO '-' -C TO IMPROVE STDOUT PRINT APPEARANCE -C 1999-09-23 D. A. KEYSER -- INCREASED THE SIZE OF PARAMETERS "IRMX" -C FROM 10000 TO 20000, "ISMX" FROM 1000 TO 2000, "ISUP" -C FROM 500 TO 1000, AND "ITMX" FROM 1000 TO 2000 - ALL TO -C ACCOUNT FOR INCREASED NUMBER OF AMDAR/ASDAR REPORTS -C NOW BEING DECODED -C 1999-09-26 D. A. KEYSER -- CHANGES TO MAKE CODE MORE PORTABLE -C 2002-11-20 D. A. KEYSER -- REMOVED ASSUMPTION THAT AN SDM PURGE ON -C TEMP ONLY ALSO RESULTS IN AN SDM PURGE ON WIND, BUT STILL -C ASSUMES THAT AN SDM PURGE ON WIND ONLY ALSO MEANS AN SDM -C PURGE ON TEMP (VIA ACTIONS TAKEN BY PREVIOUS -C PREPOBS_PREPDATA PROGRAM), ONLY REPORTS WITH SDM PURGE ON -C WIND ARE REMOVED FROM ANY SUBSEQUENT Q.C.; THERE IS ALSO -C NO LONGER ANY RELATIONSHIP BETWEEN AN SDM KEEP ON WIND -C VS. A KEEP ON TEMP - THEY ARE INDENDENDENT OF EACH OTHER -C AND FULL Q.C. IS STILL PERFORMED ON REPORTS WITH A KEEP -C FLAG ON EITHER, ALTHOUGH THE ORIGINAL KEEP FLAGS ARE -C STILL HONORED -C 2004-11-16 D. A. KEYSER -- MAXIMUM TEMPERATURE OVER WHICH TEMP IS -C FLAGGED FOR NON-USE BY ASSIMILATION IS CHANGED FROM 12 -C TO 32 DEG. C (EVENT REASON CODE 303), THIS WILL ALLOW -C REASONABLE LOW-LEVEL TEMPS TO BE ASSIMILATED; NOW CALLS -C BUFRLIB ROUTINE "UFBQCD" TO GET PROGRAM CODE FOR THIS -C Q.C. STEP ("PREPACQC") RATHER THAN HARDWIRING IT TO 7 -C AS BEFORE -C 2005-01-25 D. A. KEYSER -- INCREASED THE SIZE OF PARAMETERS "IRMX" -C FROM 20000 TO 40000, "ISMX" FROM 2000 TO 4000, "ISUP" -C FROM 1000 TO 2000, AND "ITMX" FROM 2000 TO 4000 - ALL TO -C ACCOUNT FOR INCREASED NUMBER OF AMDAR/ASDAR REPORTS -C NOW BEING DECODED AND TO ACCOUNT FOR THE NEW INCLUSION -C OF E-ADAS REPORTS -C 2007-08-16 D. A. KEYSER -- INCREASED THE SIZE OF PARAMETERS "IRMX" -C FROM 40000 TO 80000, "ISMX" FROM 4000 TO 8000, "ISUP" -C FROM 2000 TO 4000, AND "ITMX" FROM 4000 TO 8000 - ALL TO -C ACCOUNT FOR INCREASED NUMBER OF REPORTS NOW BEING DECODED -C DUE TO THE NEW INCLUSION OF TAMDAR AND CANADIAN AMDAR -C REPORTS -C 2007-10-17 D. A. KEYSER -- CHECKS TO SEE IF PARAMETER "ITRKL" IS -C EXCEEDED IN A NUMBER OF TRACK CHECK TESTS, IF SO STOPS -C ABNORMALLY WITH CONDITION CODES 26-30 (DEPENDING ON WHAT -C CAUSES "ITRKL" TO BE EXCEEDED), BEFORE COULD RUN TO -C COMPLETION BUT CLOBBER MEMORY OR MAYBE SEG FAULT; -C INCREASED THE SIZE OF PARAMETER "ITRKL" FROM 20 TO 500 - -C TO PREVENT ARRAYS OVERFLOWS IN NEARLY EVERY PRODUCTION -C RUN; INCREASED SIZE OF ARRAY "IPTTRK" FROM 5 TO PARAMETER -C "ITRKL" (NOW 500) (THIS HOLDS POINTER TO REPORTS IN A -C TRACK WITH LARGE POSITION ERRORS), BEFORE THE VALUE OF 5 -C WAS OFTEN EXCEEDED AND MEMORY WAS UNKNOWINGLY BEING -C CLOBBERED; ANY REPORTS WITH ID "UNKNOWN" ARE NOT -C CONSIDERED FOR TRACK CHECKING (THIS WAS PLACED ON SOME -C REPORTS IN REANALYSIS WHEN NO ID WAS PRESENT - SINCE -C THESE ARE NOT NORMALLY PART OF THE SAME FLIGHT THEY -C CANNOT BE TRACK CHECKED); CHANGES TO TREAT TAMDAR AND -C CANADIAN AMDAR REPORTS THE SAME AS ASDAR/AMDAR REPORTS -C 2008-07-30 D. A. KEYSER -- RECEIPT TIME TEST IS NO LONGER DONE FOR -C TAMDAR REPORTS (REGARDLESS OF SWITCH "RCPTST" BECAUSE -C TAMDAR REPORTS CAN BE RESENT MANY TIMES OVER AND THE -C RECEIPT TIME FOR VERY LATE (E.G., T-12 NDAS) RUNS MAY -C INCORRECTLY DISPLAY WHAT LOOKS LIKE A "STRANGE" RECEIPT -C TIME); IN RESPONSE TO CHANGE FROM SINGLE LEVEL TO -C DELAYED REPLICATION FOR "AIRCFT" REPORT LEVEL DATA NOW IN -C PREPBUFR FILE (IN PREPARATION FOR NRL AIRCRAFT QC PROGRAM -C WHICH WILL REPLACE THIS PROGRAM AND CAN GENERATE AIRCRAFT -C "PROFILES"), RECEIPT TIME (RCT) (WHICH IS NOW PART OF -C LEVEL DATA) IS NO LONGER RETRIEVED IN SAME CALL TO UFBINT -C AS REMAINING SINGLE-LEVEL HEADER DATA (TO AVOID BUFRLIB -C ERROR) (ALL LEVEL DATA HERE STILL HAS JUST ONE -C REPLICATION AT THIS POINT); PRIOR TO WRITING OUT EVENT, -C TESTS ORIG. T & W QM'S - IF > 3, WILL NOT WRITE OUT EVENT -C (HONORS ORIGINAL T & W QM'S IF BAD), THIS NEEDED BECAUSE -C TAMDAR AND CANADIAN AMDAR CURRENTLY HAVE T & W QM=9 -C COMING IN (MISSING OBS ERROR) WHICH CODE WAS IGNORING -C (AND WRITING OUT EVENT WITH GOOD QM MOST OF THE TIME - -C THIS CAUSED OIQC TO USE THESE OBS IN ITS DECISION MAKING -C PROCESS - THESE OBS ARE CURRENTLY ONLY MONITORED BY GSI -C AND SHOULD NOT BE CONSIDERED BY OIQC) -C -C -C USAGE: -C INPUT FILES: -C UNIT 05 - NAMELIST INPUT -C UNIT 14 - PREPBUFR FILE CONTAINING ALL DATA -C UNIT 15 - SEQUENTIAL FILE HOLDING FIXED FIELDS: N.H. 1 DEG. -C LAT/LON GRID LAND/SEA INDICATOR; S.H. 2.5 DEG. -C LAT/LON GRID LAND/SEA INDICATOR; N.H. CONUS 1 DEG -C LAT/LON YES/NO INDICATOR -C UNIT 23 - TEXT FILE CONTAINING WAYPOINT CORRECTIONS -C (READ IN WHEN NAMELIST SWITCH WAYPIN=.TRUE.) -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C UNIT 52 - TEXT FILE FOR SDM PERUSAL (LIST OF ISOLATED REPORTS -C - THAT ARE FLAGGED FOR NON-USE BY THIS PROGRAM AS WELL -C - AS THOSE WITH LARGE INCREMENTS) -C UNIT 53 - TEXT FILE FOR SDM PERUSAL (LIST OF STACKED REPORTS -C - WITH AVERAGE VECTOR WIND INCREMENT .GT. NAMELIST -C - VARIABLE 'STCLIM', ALSO LIST OF STACKED REPORTS WITH -C - AT LEAST ONE REPORT IN STACK CONTAINING SDM KEEP FLAG -C ON WIND AND/OR TEMP) -C UNIT 61 - PREPBUFR FILE CONTAINING ALL DATA (NOW WITH ACFT QC) -C -C SUBPROGRAMS CALLED: -C UNIQUE: - SUPROB SHEAR AVEROB RPACKR STATS -C - INDEXF LAPSE INDEXC TRKCHK WAYPT -C - ACOUNT PRELIM IDSORT FORSDM NOEQ2 -C - CHOOSE AVEDIR DBUFR IBUFR OBUFR -C SUBFR CMDDFF +c$$$ Main Program Documentation Block +c BEST VIEWED WITH 94-CHARACTER WIDTH WINDOW +c +c Main Program: PREPOBS_PREPACQC +c Programmer: D. Keyser Org: NP22 Date: 2016-12-09 +c +c Abstract: Performs the NRL aircraft data quality control on all types of reports (AIREP, +c PIREP, AMDAR, TAMDAR, MDCRS). Replaces the previous routine of the same name originally +c written by Paul Julian (which was less comprehensive and did not handle MDCRS reports). +c It reads in a PREPBUFR file containing all reports, pulls out "AIRCAR" and "AIRCFT" +c reports, merges the mass and wind pieces, translates information into NRL "standards" and +c stores in internal memory. These are then passed into the NRL quality control kernel +c (acftqc_obs). Once the NRL quality control is completed, translates information back to +c NCEP/PREPBUFR "standards" and encodes the updated information into the full PREPBUFR file +c as "events" with new NRLACQC reason codes. The events consist of quality mark changes, +c although NRLACQC can also remove duplicate reports and rehabilitate (update) the report +c time, latitude and longitude for some AIREP reports. An option is to also generate a +c PREPBUFR-like profiles file containing only aircraft reports in "raob-lookalike" +c profiles (merged mass and wind data). These can be used for air quality and verification +c codes. +c +c Program History Log: +c 2010-11-15 S. Bender -- Original Author +c 2012-05-08 D. Keyser -- Prepared for operational implementation +c 2012-11-20 J. Woollen -- Initial port to WCOSS +c 2012-12-11 S. Hsiao -- Increased maximum number of merged reports that can be processed +c "max_reps" from 150K to 155K to handle increase in MDCRS reports +c 2013-02-07 D. Keyser -- Interface with input PREPBUFR file will now store pressure and +c pressure-altitude only from the first (mass) piece of a mass/wind +c piece pair rather than re-store it again from the second (wind) +c piece - even though they "should" be the same in both pieces (see +c % below for exception), there can be rare cases when at least +c pressure-altitude is missing in the wind piece (due to a bug in +c PREPDATA where unreasonably-high winds are set to missing and an +c "empty" wind piece is still encoded into PREPBUFR, this can lead +c to floating point exception errors in construction of profiles +c {note that pressure & pressure-altitude from reports with only a +c wind piece will be read since it is the first (only) piece of the +c report}: % - there can be cases where the pressure qualty mark +c (PQM) is different in the mass piece vs. the wind piece (e.g., +c when it is set to 10 for reports near tropical systems by +c SYNDATA), so it is better to pick up PQM from the mass report for +c use in the merged mass/wind profiles, an added benefit of this +c change; increased maximum number of merged reports that can be +c processed "max_reps" from 155K to 185K to handle future increase +c all types of aircraft rpts; if the total number of merged (mass +c + wind piece) aircraft-type reports read in from PREPBUFR file is +c at least 90% of the maximum allowed, print diagnostic warning +c message to production joblog file prior to returning from +c subroutine INPUT_ACQC; if the maximum number of merged reports +c that can be processed ("max_reps") is exceeded when updating +c reports in PREPBUFR file with QC changes in subroutine +c OUTPUT_ACQC_NOPROF, program will no longer stop with r.c. 31, as +c though there is an indexing error, instead all original reports +c above "max_reps" will be written out without any QC and a message +c will be printed to stdout (a diagnostic will have already been +c sent to the production joblog file in this case when reports were +c first read in by subroutine INPUT_ACQC) +c 2013-02-07 D. Keyser -- Final changes to run on WCOSS: Set BUFRLIB missing (BMISS) to +c 10E8 rather than 10E10 to avoid integer overflow; use formatted +c print statements where previously unformatted print was > 80 +c characters +c 2014-03-06 D. Keyser -- Moved BUFRLIB routine OPENMB call in subroutine +c output_acqc_noprof to after time window and geographic domain +c checks to prevent creation of an empty, but open, BUFR message +c (type AIRCAR) in (rare) cases where absolutely no aircraft +c reports pass these checks (would cause a BUFRLIB abort due to +c previous message being open when attempting to copy first non- +c aircraft message from input to output PREPBUFR file +c 2014-07-18 D. Keyser -- +c - Increased maximum number of flights that can be processed "maxflt" from +c 5000 to 7500 to account for increase in aircraft reports. +c - Increased maximum number of merged reports that can be processed +c "max_reps" from 185K to 220K to handle future increase in all types of +c aircraft reports. +c - If subroutine acftobs_qc returns abnormally to main program due to the +c maximum value for number of flights calculated at some point during its +c processing exceeding the allowed limit ("maxflt"), no longer stop with +c r.c. 98. Instead continue on with processing and post a diagnostic +c warning message to the production joblog file. The assumption is that +c the resultant PREPBUFR file may not contain fully QC'd aircraft data, +c especially if the actual number of flights calculated greatly exceeds +c "maxflt" (since obs in flights above the "maxflt" limit may partially be +c skipped over in the QC process), but the vast majority should be QC'd, +c and all reports originally in the PREPBUFR file will be at least be +c retained. (Note that a gradual increase will trigger a warning in the +c production joblog now when numbers get too close to the limit - see +c change to subroutine acftobs_qc below). +c - Increased format width from I5 to I6 in all places where aircraft obs +c index is listed out (since there now can be > 99999 reports). +c - Subroutine acftobs_qc and its child subroutines: +c - Keep track of maximum value for number of flights calculated at some +c point during the processing of subroutine acftobs_qc. If, at the end +c of acftobs_qc, this value is at least 90% of the allowed limit +c ("maxflt", set in the main program), post a diagnostic warning message +c to the production joblog file prior to exiting from acftobs_qc. +c - In subr. do_flt and do_reg, return (abnormally) immediately if +c "maxflt" is exceeded rather than waiting to test for this at end of +c do_flt and do_reg and then return (abnormally). Prior to return +c subtract 1 from number of flights so it will remain at "maxflt". The +c immediate return avoids clobbering of memory in these cases. +c - In subr. reorder, where any new flight exceeding "maxflt" replaces the +c previous flight at index "maxflt" in the arrays to avoid an array +c overflow (done in two places in original NRL version), post diagnostic +c warning message to the production joblog file (found a third instance +c where this needs to be done in subr. reorder - original NRL version +c did not trap it and arrays limited to length "maxflt" would have +c overflowed). +c - If "maxflt" is exceeded in subr. dupchk (1 place possible) or in subr. +c do_flt (2 places possible), the abnormal return back to subr. +c acftobs_qc results in subr. acftobs_qc now continuing on but setting a +c flag for "maxflt_exceeded". Prior to this, subr. acftobs_qc itself +c immediately performed an abnormal return back to main program in such +c cases resulting in no more NRL QC processing. Now NRL QC processing +c will continue on to the end of subr. acftobs_qc where the abnormal +c return back to the main program will be triggered by the +c "maxflt_exceeded" flag. +c - There is one, apparently rare, condition where "maxflt" could be +c exceeded in subr. acft_obs itself (within logic which generates master +c list of tail numbers and counts). Since it can't be determined if +c continuing on without processing (QC'ing) any more data would yield +c acceptable results, the program now immediately stops with condition +c code 98 and a diagnostic warning message is posted to the production +c joblog file noting that "maxflt" needs to be increased. Prior to this +c it returned to the main program where it also immediately stopped with +c condition code 98 (so no real change in what happens here, just where +c it happens). +c 2014-09-03 D. Keyser -- If no aircraft reports of any type are read from input PREPBUFR +c file by subr. input_acqc, no further processing is performed in this +c subr. other than the usual stdout print summary at its end. After its +c return back to the calling main program, the main program also, in +c this case, does no further processing. Instead the main program stops +c with condition code 4 (to alert executing script prepobs_prepacqc.sh) +c after printing a diagnostic message to stdout. +c 2014-12-09 J. Purser/Y. Zhu -- Added new namelist switches "l_mandlvl" and "tsplines", +c used by subroutine sub2mem_mer to modify the calculation of vertical +c velocity rate in the profiles {l_mandlvl=F excludes interpolation to +c mandatory levels; tsplines=T calculates vertical velocity rate using +c Jim Purser's tension-spline interpolation utility (source in-lined in +c this program at this time) to get continuous gradient results in a +c profile and mitigate missing time information; tsplines=F uses finite- +c difference method to obtain vertical velocity rate, calculated for +c both ascents and descents using the nearest neighboring pair which are +c at least one minute apart (before, only finite-difference method was +c used to obtain vertical velocity rate and it could only be calculated +c for descents). +c 2014-12-12 D. Keyser -- Printout from vertical velocity rate calculation information for +c QC'd merged aircraft reports written to profiles PREPBUFR-like file is +c written to unit 41 rather than stdout. +c 2015-03-16 D. Keyser -- +c - Increased maximum number of merged reports that can be processed +c "max_reps" from 220K to 300K to handle future increase in all types of +c aircraft reports. +c - In subr. output_acqc_prof, fixed a bug which, for cases where the maximum +c number of merged reports that can be processed ("max_reps") is exceeded, +c prevented any original reports above "max_reps" from being written out +c (without any QC). +c 2015-04-17 J. Purser -- Updates to tension-spline interpolation utility pspl: +c In April 2015 some significant changes were made to pspl.f90 to improve +c the robustness of the algorithm and the usefulness of the energy +c diagnostic: +c 1) The allowance of B iterations was increased from 40 to 80 owing to +c a single failure in a parallel run (where 43 iterations were +c required) (and the halfgate parameter was increased to 30 for all +c data in the parallels, which also increases robustness). +c 2) There was included an explicit energy check at each A iteration to +c force an exit when this energy fails to decrease. This change was +c prompted by a single failure in a parallel run (courtesy Russ +c Treadon) in which the A and B iterations flip-flopped at zero +c energy change in a case of grazing contact with a gatepost. +c 3) The energy is now normalized by the energy that would be computed +c from a spline that fits only the first and last gateposts. The +c renormalized energy diagnostic tells how sinuous the final profile +c is -- very large values are indiciative of a halfgate chosen to be +c too narrow for the given profile data. +c 4) The normalized time data are now handled as integer arrays instead +c of reals in those parts of the code dealing with the combinatorics +c of routes. This is just better coding practice. +c 2015-04-17 Y. Zhu -- Updates to subroutine sub2mem_mer: +c 1) Subroutine is more robust. If there is an error in the generation +c of vertical velocity rate in the tension-spline interpolation +c utility pspl (called in this subroutine), this subroutine (and thus +c the program itself) will no longer abort (with either c. code 62, +c 63 or 64 depending upon which routine inside pspl generated the +c error) but will instead revert to the finite difference method for +c calculating vertical velocity rate. +c 2) Previously, halfgate was set to be 30 for the data profiles that +c don't have second information in time, but a tighter value of 10 +c for the data profiles that do have second information in time. Now +c halfgate is relaxed to be 30 for the data profiles that do have +c complete time information. +c 2016-10-11 M.Sienkiewicz Added a namelist variable and additional code to allow use of an +c alternate BUFR table definition file when generating the profile file. +c (Solves a problem with mixed BUFR files used for input.) +c 2016-11-09 C. Hill ----- +c - Increased the maximum number of flights that can be processed, "MAXFLT", +c from 7500 to 12500 to resolve >90% warning. +c 2016-12-09 D. Keyser -- +c - Nomenclature change: replaced "MDCRS/ACARS" with just "MDCRS". +c - New LATAM AMDARs contain an encrypted flight number (in addition to a tail +c number, all other AMDARs have only a tail number which is copied into +c flight number). Read this in and use in QC processing. +c BENEFIT: Improves track-checking and other QC for LATAM AMDARs. +c - Since "ACARS" as referred to in NRL QC kernal (acftobs_qc.f) is not used +c there and we earlier decided to use this to provide a separate category +c for TAMDARs in the NRL QC kernal (for stratifying statistics), all +c printout in acftobs_qc.f changes the term "ACARS" to "TAMDAR". In +c addition, all comments now refer to "TAMDAR" instead of "ACARS". +c - Variables holding latitude and longitude data (including arrays "alat" and +c "alon" passed between subroutines) now double precision. XOB and YOB in +c PREPBUFR file now scaled to 10**5 (was 10**2) to handle new v7 AMDAR and +c MDCRS reports which have this higher precision. +c BENEFIT: Retains exact precison here. Improves QC processing. +c - Note: QC here can be improved further by changing logic in many +c places to account for the increased precision. This needs to be +c investigated. For now, locations in code where this seems +c possible are noted by the spanning comments: +c ! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c ! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c - The format for all print statements containing latitude and longitude +c changed to print to 5 decimal places. +c +c Usage: +c Input files: +c Unit 05 - Standard input (namelist) +c Unit 11 - PREPBUFR file containing all obs, prior to any processing by this program +c Unit 12 - file with external table for profile output (if needed) +c +c Output files: +c Unit 06 - Standard output print +c Unit 08 - Text file containing full log of all NRL QC information +c Unit 30 - Text file containing duplicate data check information +c Unit 31 - Text file containing spike data check information +c Unit 32 - Text file containing invalid data check information +c Unit 33 - Text file containing stuck data check information +c Unit 34 - Text file containing gross check information +c Unit 35 - Text file containing position check information +c Unit 36 - Text file containing ordering check information +c Unit 37 - Text file containing suspect data check information +c Unit 38 - Text file containing reject list information +c Unit 41 - Text file containing vertical velocity rate calculation information for QC'd +c merged aircraft reports written to profiles PREPBUFR-like file +c Unit 51 - Text file containing sorted listing of all single-level QC'd aircraft +c reports written back to full PREPBUFR file +c Unit 52 - Text file containing sorted listing of all QC'd merged aircraft reports +c written to profiles PREPBUFR-like file +c Unit 61 - PREPBUFR file identical to input except containing NRLACQC events +c Unit 62 - PREPBUFR-like file containing merged (mass and wind) profile reports +c (always) and single(flight)-level reports not part of any profile (when +c l_prof1lvl=T) with NRLACQC events +c +c Subprograms called: +c Unique: - ACFTOBS_QC PR_WORKDATA INDEXC DUPCHEK_QC +c - REORDER DO_FLT DO_REG INNOV_QC +c - BENFORD_QC INVALID_QC STK_VAL_QC GRCHEK_QC +c - POSCHEK_QC ORDDUP_QC ORDCHEK_QC SUSPECT_QC +c - REJLIST_QC P2HT_QC HT2FL_QC P_DDTG +c - SPIKE_QC SLEN INSTY_OB_FUN C_INSTY_OB +c - GCIRC_QC INDEXC40 INPUT_ACQC OUTPUT_ACQC_NOPROF +c - OUTPUT_ACQC_PROF SUB2MEM_MER SUB2MEM_UM TRANQCFLAGS C LIBRARY: -C W3LIB : - W3FI04 ERREXIT -C BUFRLIB: - DATELEN OPENBF READMG READSB UFBINT -C - CLOSBF OPENMB UFBCPY WRITSB UFBCNT -C - COPYMG UFBQCD CLOSMG -C -C EXIT STATES: -C COND = 0 - SUCCESSFUL RUN -C COND = 04 - NO REPORTS WERE PROCESSED (NO "AIRCFT" TABLE A -C MESSAGES FOUND) -C COND = 20 - THE NUMBER OF AIRCRAFT REPORTS IN THE INPUT FILE -C - EXCEEDS THE MAXIMUM LIMIT SET BY THIS PROGRAM, -C - MUST INCREASE THE SIZE OF PARAMETER NAME "IRMX" -C COND = 21 - THE NUMBER OF AIRCRAFT REPORTS IN A STACK OF CO- -C - LOCATED OBSERVATIONS EXCEEDS THE MAXIMUM LIMIT -C - SET BY THIS PROGRAM, MUST INCREASE THE SIZE OF -C - PARAMETER NAME "ISMX" -C COND = 22 - CHARACTERS ON THIS MACHINE ARE NEITHER ASCII NOR -C - EBCDIC -C COND = 23 - THE NUMBER OF SUPEROBED AIRCRAFT REPORTS GENERATED -C - EXCEEDS THE MAXIMUM LIMIT SET BY THIS PROGRAM, -C - MUST INCREASE THE SIZE OF PARAMETER NAME "ISUP" -C - (ONLY APPL. FOR NAMELIST SWITCH DOSPOB = TRUE) -C COND = 24 - THE NUMBER OF AIRCRAFT REPORTS IN A SINGLE TRACK -C - (FOR CHECKING) EXCEEDS THE MAXIMUM LIMIT SET BY -C - THIS PROGRAM, MUST INCREASE THE SIZE OF PARAMETER -C - NAME "ITMX" -C COND = 25 - THE NUMBER OF LATITUDE/LONGITUDE CORRECTIONS IN -C - THE EXTERNAL WAYPOINT CORRECTION FILE EXCEEDS THE -C - MAXIMUM LIMIT SET BY THIS PROGRAM, MUST INCREASE -C - THE SIZE OF PARAMETER NAME "LSIZE" -C COND = 26 - THE NUMBER OF REPORTS IN THE POINTER SUMMARY FOR A -C - TRACK EXCEEDS THE MAXIMUM LIMIT SET BY THIS PROGRAM, -C - MUST INCREASE THE SIZE OF PARAMETER NAME "ITRKL" -C COND = 27 - THE NUMBER OF REPORTS WITH ADJUSTABLE CONSTANTS FOR -C - AIRCRAFT GROUND SPEED LIMITS IN A TRACK EXCEEDS THE -C - MAXIMUM LIMIT SET BY THIS PROGRAM, MUST INCREASE THE -C - SIZE OF PARAMETER NAME "ITRKL" -C COND = 28 - THE NUMBER OF POINTERS FOR NON-ADJACENT REPORTS IN A -C - TRACK EXCEEDS THE MAXIMUM LIMIT SET BY THIS PROGRAM, -C - MUST INCREASE THE SIZE OF PARAMETER NAME "ITRKL" -C COND = 29 - THE NUMBER OF DUPLICATE TYPES IN A TRACK EXCEEDS THE -C - MAXIMUM LIMIT SET BY THIS PROGRAM, MUST INCREASE THE -C - SIZE OF PARAMETER NAME "ITRKL" -C COND = 30 - THE NUMBER OF REPORTS IN A TRACK WITH LARGE POSTION -C - ERRORS EXCEEDS THE MAXIMUM LIMIT SET BY THIS -C - PROGRAM, MUST INCREASE THE SIZE OF PARAMETER NAME -C - "ITRKL" -C COND = 70 - THE NUMBER OF LEVELS IN A DECODED REPORT'S HEADER -C - AND/OR OBS. AND/OR FCST LVL IS NOT 1 -C -C REMARKS: SEE COMMENT CARDS FOLLOWING DOCBLOCK. -C COMPLETE WRITE-UP CAN BE FOUND IN OFFICE NOTE 358. NOTE THAT -C ALL WIND SPEEDS HERE ARE IN KNOTS??. THE FOLLOWING DESCRIBE -C THE COMMON BLOCKS IN THIS PROGRAM: -C /ALLDAT/ -- CONTAINS ARRAYS FOR ALL AIRCRAFT OBSERVATIONS -C /SUMDAT/ -- CONTAINS ARRAYS FOR ONLY GROUP OF STACKED OBS. -C ARRAY ISTCPT: -C -- KEEPS SERIAL COUNT OF OBS. IN STACK, WITH THE -C -- INTEGER COUNT REPLACED BY 0 FOR A REJECTED -C -- REPORT AND -1 FOR A REPORT NOT TREATED BECAUSE -C -- OF ALTITUDE OR OTHER REASONS. ARRAY IFLEPT DOES -C -- THE SAME THING HOWEVER THE INDEXING IS WITH -C -- RESPECT TO THE NUMBER IN THE STACK FOR ISTCPT -C -C THE POSSIBLE OUTPUT QUALITY MARKERS ARE DEFINED AS FOLLOWS: -C (WHERE: 'T' IS TEMPERATURE, 'W' IS WIND) -C -C PREPBUFR -C ORIGINAL SDM KEEP FLAG MAINTAINED (T/W) ......... 0 -C CHECKED BY THIS PROGRAM AND GOOD (T/W) .......... 1 -C ORIGINAL DATA NOT CHECKED BY THIS PROGRAM (T/W) . 2 -C ORIGINAL DATA MISSING (T/W) ..................... 15 -C CHECKED BY THIS PROGRAM AND SUSPECT (T/W) ....... 3 -C CHECKED BY THIS PROGRAM AND BAD/FAILED (T/W) .... 13 -C OMIT FLAG -- USED TO GENERATE SUPEROB (T/W) ..... 10 -C ORIGINAL SDM PURGE FLAG MAINTAINED (T/W) ........ 14 -C NEW SUPEROBED REPORT (STNID IS 'SUPROB') (T/W) .. 1 -C FLAGGED REPORT OVER CONTINENTAL U.S. (T/W) ...... 15 -C -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ -CC -C ***** VARIABLES IN NAMELIST INPUT READ IN MAIN PROGRAM ***** -CC -C INIDST - TYPE OF INPUT FILE -C INIDST = 2 ---> PREPBUFR FILE IN UNIT 14 (ONLY CHOICE!) -C DOSPOB - SWITCH TO FORM SUPEROBS -C DOSPOB=.TRUE. ---> FORM SUPEROBS (DEFAULT) -C DOSPOB=.FALSE. --> DO NOT FORM SUPEROBS -C DOACRS - RUN WITH ACARS AIRCRAFT FILE -C DOACRS=.TRUE. ---> RUN WITH ACARS FILE -C DOACRS=.FALSE. --> DO NOT RUN WITH ACARS FILE (DEFAULT) -C (NOTE: THIS SWITCH NOT INVOKED -- CAN NOT RUN W/ ACARS FILE) -C WINDOW - TIME WINDOW FOR REPORTS TO BE OUTPUT BY THIS PROGRAM (IF -C WINDOW=X, TIME WINDOW IS +/- X HOURS OF CYCLE TIME) -C (DEFAULT=3.00, 6-HOUR TOTAL WINDOW) -C {NOTE: THE MAXIMUM VALUE FOR WINDOW IS 5.75 (5-HOURS, -C 45-MINUTES; ANYTHING LARGER WILL RESULT IN ERROR!} -C (NOTE: FOR INPUT, THE TIME WINDOW IS SET TO THE LARGER OF -C 3-HOURS 15-MINUTES OR "WINDOW" PLUS 15-MINUTES. -C THIS ALLOWS THE TRACK CHECKING TO BE DONE PROPERLY. -C ON OUTPUT, THE VALUE OF "WINDOW" IS USED - ALL -C REPORTS OUTSIDE WINDOW ARE OMITTED FROM OUTPUT) -C TIMINC - TIME INCREMENT (IN HOURS/100) ADDED TO EACH OCCURRENCE -C OF A MULTI-LEVEL SUPEROB (STARTING WITH ORIGINAL TIME) -C TO PREVENT RGL/OI FROM TOSSING AS DUPLICATES -C (NOTE: IF TIMINC=10., PREVENTS UNIFIED FERR CODE FROM RE- -C CONSTRUCTING A PROFILE) -C (DEFAULT=1.00, ADD ONE-HUNDREDTH OF AN HOUR TO EACH) -C RCPTST - SWITCH TO PERFORM THE RECEIPT-TIME TEST -C RCPTST=.TRUE. ---> PERFORM THE TEST (DEFAULT) -C RCPTST=.FALSE. --> DO NOT PERFORM THE TEST -C (NOTE 1: THE RECEIPT TIME TEST CHECKS FOR REPORTS WITH A -C STRANGE RECEIPT TIME COMPARED TO THE REPORT TIME - -C MAY BE YESTERDAY'S REPORT PROCESSED TODAY -- -C IF THE RECEIPT TIME IS OUTSIDE THE RANGE OF REPORT -C TIME MINUS 1-HOUR TO REPORT TIME PLUS 11.99 HOURS, -C THE REPORT IS SKIPPED SINCE ITS VALIDITY IS IN -C QUESTION) -C (NOTE 2: THIS TEST IS NOT DONE FOR TAMDAR REPORTS BECAUSE -C THEY ARE RESENT MANY TIMES OVER AND THE RECEIPT TIME -C FOR VERY LATE (E.G., T-12 NDAS) RUNS MAY INCORRECTLY -C DISPLAY WHAT LOOKS LIKE A STRANGE RECEIPT TIME) -C STCLIM - LIMIT FOR THE AVERAGE VECTOR WIND INCREMENT IN STACK FOR -C WHICH SDM PRINT TO UNIT 53 OCCURS (KNOTS) (DEFAULT=41.9) -C WAYPIN - SWITCH FOR INPUT WAYPOINT CORRECTION INFORMATION -C WAYPIN=.TRUE. ---> FROM EXTERNAL FILE (UNIT 23) -C WAYPIN=.FALSE. --> FROM INTERNAL DATA STATEMNTS (DEFAULT) -CC -C N O T E -- THE FOLLOWING 6-WORD ARRAYS REFER TO SIX LATITUDE -C BANDS: -90 TO -70, -70 TO -20, -20 TO 0, 0 TO 20, -C 20 TO 70, 70 TO 90 DEGREES (N +) -CC -C JAMASS - PROCESS AIRCRAFT MASS REPORTS ON OUTPUT? -C JAMASS = 0 ---> YES, PROCESS MASS REPORTS -C JAMASS = 9999 ---> NO, DO NOT PROCESS MASS REPORTS -C (DEFAULT = JAMASS(6)/6*0/) -C JAWIND - PROCESS AIRCRAFT WIND REPORTS ON OUTPUT? -C JAWIND = 0 ---> YES, PROCESS WIND REPORTS -C JAWIND = 9999 ---> NO, DO NOT PROCESS WIND REPORTS -C (DEFAULT = JAWIND(6)/6*0/) -CC -C IFLGUS - WHEN IFLGUS = 1 OR 2 ---> WILL DO THE FOLLOWING TO -C CONVENTIONAL AIREP/PIREP AIRCRAFT REPORTS OVER CONUS: -C IF THERE ARE AT LEAST TWO TABLE A ENTRY 'AIRCAR' BUFR -C MESSAGES READ IN PRIOR TO READING IN THE FIRST "AIRCFT" -C BUFR MESSAGE: -C 1) WILL EXCLUDE SUCH RPTS FROM SDM LISTING IN UNIT 52 -C 2) IF IFLGUS = 1: WILL FLAG SUCH RPTS FOR NON-USE BY -C ANALYSIS BY SETTING TEMPERATURE AND WIND QUALITY -C MARKERS TO 15 -C IF IFLGUS = 2; WILL EXCLUDE SUCH RPTS FROM BEING -C OUTPUT -C - WHEN IFLGUS = 0 ---> REPORTS ARE NOT CHECKED FOR -C GEOGRAPHICAL LOCATION -C (DEFAULT: IFLGUS = 1) -C FWRITE - SWITCH TO GET STANDARD OUTPUT PRINTOUT OF FINAL LISTING -C OF ORIGINAL REPORTS IN AIRCFT FILE WITH NEW Q. MARKS -C FWRITE=.TRUE. ---> PRODUCE PRINTOUT -C FWRITE=.FALSE. --> NO PRINTOUT (DEFAULT) -C SWRITE - SWITCH TO GET STANDARD OUTPUT PRINTOUT FOR STATISTICS -C SWRITE=.TRUE. ---> PRODUCE PRINTOUT -C SWRITE=.FALSE. --> NO PRINTOUT (DEFAULT) -C IWRITE - SWITCH TO GET STANDARD OUTPUT PRINTOUT OF INPUT LISTING -C OF ORIGINAL REPORTS IN AIRCFT FILE BEFORE IDSORT, AFTER -C IDSORT, AND AFTER TRACK CHECK -C IWRITE=.TRUE. ---> PRODUCE PRINTOUT -C IWRITE=.FALSE. --> NO PRINTOUT (DEFAULT) -C EWRITE - SWITCH TO GET STANDARD OUTPUT PRINTOUT OF "EVENTS" -C (WHEN A BUFR EVENT OCCURS, I.E. CHANGING A QUALITY MARK) -C EWRITE=.TRUE. ---> PRODUCE PRINTOUT -C EWRITE=.FALSE. --> NO PRINTOUT (DEFAULT) -CCCCC - PROGRAM PREPOBS_PREPACQC -C -C PARAMETER NAME "IRMX" THROUGHOUT THIS PROGRAM SETS THE MAXIMUM -C NUMBER OF ACFT RPTS THAN CAN BE UNPACKED FROM THE INPUT FILE CHOSEN -C PARAMETER NAME "ISMX" THROUGHOUT THIS PROGRAM SETS THE MAXIMUM -C NUMBER OF ACFT RPTS THAT CAN BE TREATED IN A STACK - PARAMETER (IRMX= 80000, ISMX= 8000) -C PARAMETER NAME "ISUP" THROUGHOUT THIS PROGRAM SETS THE MAXIMUM -C NUMBER OF SUPEROBED REPORTS THAT CAN BE PROCESSED - PARAMETER (ISUP= 4000) -C PARAMETER NAME "ISIZE" THROUGHOUT THIS PROGRAM SETS THE NUMBER OF -C VARIABLES THAT ARE AFFECTED BY THE SORTS ID IDSORT AND TRKCHK -C (EXCLUDING STATION ID AND THE TAGS WHICH ARE IN SEPARATE ARRAYS) - PARAMETER (ISIZE= 16) - LOGICAL FWRITE,SWRITE,IWRITE,EWRITE,DOSPOB,DOACRS,WAYPIN,RCPTST - CHARACTER*1 CF,QCACMK(15),PF - CHARACTER*4 SSMARK - CHARACTER*5 SPEC5,SPEC6,QMARKI - CHARACTER*8 ACID,SAID,IDENT,AAID(IRMX) - CHARACTER*14 TAG,CTAG(IRMX),STAG(IRMX) - INTEGER IDATA(1608),NNQM(15),IDSTR(400,2) - REAL RDATA(1608) - COMMON/OUTPUT/KNTOUT(5) - COMMON/SUMDAT/ISTCPT(ISMX),SAID(ISMX),SLAT(ISMX),SLON(ISMX), - $ SHGT(ISMX),STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX), - $ KBAD(ISMX),NUMORG,SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX) - COMMON/ALLDAT/IFLEPT(IRMX),ACID(IRMX),ALAT(IRMX),ALON(IRMX), - $ AALT(IRMX),TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE, - $ ATMP(IRMX),TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX), - $ ITEVNT(IRMX),IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX), - $ ADIRF(IRMX) - COMMON/CMPNTS/U(ISMX),V(ISMX),UF(ISMX),VF(ISMX) - COMMON/ACCONT/KQM2F(15),KISO(15),KNQM(15),KSDM(2),KT,KTYPS(9) - COMMON/INPT/DOSPOB,DOACRS,TMAXO,TMINO,TIMINC,WAYPIN,INIDST,IFLGUS, - $ JAMASS(6),JAWIND(6),RCPTST - COMMON/TSTACAR/KTACAR - COMMON/STWRIT/SWRITE,EWRITE,IWRITE - COMMON/MASK/GDNH(362,91),GDSH(145,37),GDUS(362,91) - COMMON/XXXXX/AAID,JARRAY(IRMX,ISIZE),CTAG,KARRAY(IRMX,ISIZE),STAG - COMMON/CBUFR/IDENT,IRCTME,RDATA,KIX,QMARKI,CF,PF - COMMON/SUPOBS/SSLAT(ISUP),SSLON(ISUP),SSTIM(ISUP),SSHGT(ISUP), - $ SSTMP(ISUP),SSDIR(ISUP),SSSPD(ISUP),SSHGTF(ISUP),SSTMPF(ISUP), - $ SSDIRF(ISUP),SSSPDF(ISUP),SSMARK(ISUP) - COMMON/STDATE/IDATE(5) - COMMON/WORD/ICHTP - NAMELIST/INPUT/DOSPOB,DOACRS,WINDOW,TIMINC,STCLIM,WAYPIN,INIDST, - $ FWRITE,SWRITE,IWRITE,EWRITE,IFLGUS,JAMASS,JAWIND,RCPTST - EQUIVALENCE (RDATA,IDATA) - DATA XMSG/99999./,ITOL/55/,QCACMK/'Q','R','S','T','U','V','W', - $ 'X','Y','Z','C','P','H','-','D'/ - CALL W3TAGB('PREPOBS_PREPACQC',2008,0212,0087,'NP22') - - PRINT 2111 - 2111 FORMAT('1',19X,'***** WELCOME TO THE AIRCRAFT QUALITY CONTROL ', - $'PROGRAM PREPACQC -- VERSION 30 JUL 2008 *****'/) -C CALL W3FI04 TO DETERMINE MACHINE WORD LENGTH (BYTES) -C AND TO TEST FOR ASCII(ICHTP=0) OR EBCDIC(ICHTP=1) CHARACTERS - CALL W3FI04(IENDN,ICHTP,LW) - PRINT 2213, LW, ICHTP, IENDN - 2213 FORMAT(/' ---> CALL TO W3FI04 RETURNS: LW = ',I3,', ICHTP = ',I3, - $ ', IENDN = ',I3/) - IF(ICHTP.GT.1) THEN -C----------------------------------------------------------------------- -C CHARACTERS ON THIS MACHINE ARE NEITHER ASCII OR EBCDIC!! -- STOP 22 - PRINT 217 - 217 FORMAT(/5X,'++ CHARACTERS ON THIS MACHINE ARE NEITHER ASCII', - $ ' NOR EBCDIC - STOP 22'/) - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(22) -C----------------------------------------------------------------------- - END IF - RAD = 3.14159/180. -C INITIALIZE CONSTANTS FOR ACCOUNTING - KT = 0 - KSDM = 0 - ICNT1 = 0 - ICNT2 = 0 - ICNT3 = 0 - ICNT45 = 0 - ICNT69 = 0 - ICNTX = 0 - KDUP = 0 - KTACAR = 0 - KQM2F = 0 - KISO = 0 - KNQM = 0 - NNQM = 0 - KTYPS = 0 - CALL SETBMISS(10E8_8) -C READ IN NAMELIST, FIRST SET-UP ANY DEFAULTS - WINDOW = 3.00 - TIMINC = 1.00 - RCPTST = .TRUE. - STCLIM = 41.9 - DOSPOB = .TRUE. - DOACRS = .FALSE. - WAYPIN = .FALSE. - IFLGUS = 1 - FWRITE = .FALSE. - SWRITE = .FALSE. - IWRITE = .FALSE. - EWRITE = .FALSE. - JAMASS = 0 - JAWIND = 0 - READ(5,INPUT,END=9222) - INIDST = 2 - 9222 CONTINUE - IF(DOSPOB) PRINT 2112 - 2112 FORMAT(40X,'> > > > > SUPEROBS WILL BE GENERATED < < < < <'/) - IF(.NOT.DOSPOB) PRINT 2113 - 2113 FORMAT(38X,'> > > > > SUPEROBS WILL NOT BE GENERATED ', - $ '< < < < <'/) - CALL DBUFR(IDATEP) - IDATE(1) = IDATEP/1000000 - IDATE(2) = MOD((IDATEP/10000),100) - IDATE(3) = MOD((IDATEP/100),100) - IDATE(4) = MOD(IDATEP,100) - LATEST = 9999 - IDATE(5) = 0 - KOUNT = 0 - KNTIN = 0 - KNTOUT = 0 - TBASE = REAL(IDATE(4) * 100.) - IF(NINT(TBASE).LT.600) TBASE = TBASE + 2400. -C THE TIME WINDOW UPON INPUT IS SET TO THE LARGER OF 3-HRS 15-MIN OR -C "WINDOW" PLUS 15-MINUTES. REMOVE ALL REPORTS OUTSIDE THIS TIME -C WINDOW. (THE LARGER INPUT TIME WINDOW ALLOWS THE TRACK CHECKING TO -C BE DONE PROPERLY.) - TWNDOW = AMAX1(((WINDOW*100.)+25.0),325.) - TMAX = TBASE + TWNDOW - TMIN = TBASE - TWNDOW - TMAXO = TBASE + (WINDOW * 100.) - TMINO = TBASE - (WINDOW * 100.) - PRINT 1111, IDATE,TBASE,TMIN,TMAX,TMINO,TMAXO,TIMINC,LATEST - 1111 FORMAT(39X,'===> OPERATIONAL AIRCFT FILE HAS DATE: ',I6,4I4,/, - $ 41X,'===> TIME BASE IS ',F8.0,/, - $ 41X,'===> INPUT TIME WINDOW IS ',F8.0,' TO ',F8.0,/, - $ 41X,'===> OUTPUT TIME WINDOW IS ',F8.0,' TO ',F8.0,/, - $ 41X,'===> TIME INCREMENT IS ',F5.2,' HOURS/100',/, - $ 41X,'===> LATEST AIRCRAFT REPORT AT',I5,' HOURS',//) - WRITE(6,INPUT) -C READ IN N.H. CONUS MASK (1 DEG GRID); IF MASK > 0 THEN GRID LOCATED -C HERE -- THIS IS NEEDED LATER IN PROGRAM - PRINT 101 - 101 FORMAT(/1X,'**** OPEN UNIT 15 TO GET CONUS GRID FOR LOCATION ', - $ 'CHECKS ****'/) - READ(15,ERR=8814) GDNH - READ(15,ERR=8814) GDSH - READ(15,ERR=8814) GDUS - GO TO 8812 -C----------------------------------------------------------------------- - 8814 CONTINUE -C PROBLEM W/ READ; INIT. GDUS ARRAY TO 0 - (HAVE TO ASSUME ALL N.H. OBS. -C ARE OUTSIDE OF CONUS REGION) - GDUS = 0.0 - PRINT 102 - 102 FORMAT(/' +++> TROUBLE READING U.S. MASK FILE; ASSUME ALL N.H. ', - $ 'DATA OUTSIDE CONUS REGION IN ANY CONUS TEST'/) -C----------------------------------------------------------------------- - 8812 CONTINUE - IF(IWRITE) PRINT 6176 - 6176 FORMAT(/' LISTING OF ORIGINAL DATA BEFORE IDSORT----'/9X,'ACID', - $ 8X,'LAT WLON UTC ALT TEMP WDIR WSPD -----TAGS', - $ '----- ITYPE RPTIME KNTINI GALT GTEMP GDIR GSPD'/) - 5 CONTINUE - ALTF = XMSG - DIRF = XMSG - SPDF = XMSG - TMPF = XMSG -C*********************************************************************** -C READ IN NEXT AIRCRAFT REPORT -C*********************************************************************** - IY = 43 - SPEC5 = '----' - SPEC6 = '----' - CALL IBUFR(ALTF,DIRF,SPDF,TMPF,*2) - SPEC5(3:3) = PF - SPEC6(3:3) = CF - KOUNT = KOUNT + 1 - KNTIN = KNTIN + 1 - KNTINI(KOUNT) = KNTIN - IF(KOUNT.GT.IRMX) THEN -C*********************************************************************** -C FATAL ERROR: THERE ARE MORE RPTS IN INPUT FILE THAN "IRMX" -- STOP 20 - PRINT 53, IRMX - 53 FORMAT(/' THERE ARE MORE THAN',I5,' AIRCRAFT REPORTS IN INPUT ', - $ 'FILE -- MUST INCREASE SIZE OF PARAMETER NAME "IRMX" - STOP 20'/) - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(20) -C*********************************************************************** - END IF - TAG(KOUNT)(12:12) = '-' - ALAT(KOUNT) = RDATA(1) - ALON(KOUNT) = RDATA(2) - INTP(KOUNT) = IDATA(8) - IF(NINT(ALON(KOUNT)).EQ.36000) ALON(KOUNT) = 0.0 -C IF MISSING OR UNREASONABLE LAT/LON (SET LATTER TO MISSING), SET POS. -C 12 OF TAG TO '@' TO MARK THEM (AT END OF SORT, ISOLATED) - IF(NINT(ALAT(KOUNT)).GT.9000.OR.NINT(ALAT(KOUNT)).LT.-9000) THEN -CVVVVV%%%%% - PRINT *,'~~~~~ HERE IS A MISSING/UNREASONABLE LAT SET TO MSG!!' -CAAAAA%%%%% - ALAT(KOUNT) = XMSG - TAG(KOUNT)(12:12) = '@' - ELSE - ALAT(KOUNT) = ALAT(KOUNT) * .01 - END IF - IF(NINT(ALON(KOUNT)).GT.36000.OR.NINT(ALON(KOUNT)).LT.0) THEN -CVVVVV%%%%% - PRINT *,'~~~~~ HERE IS A MISSING/UNREASONABLE LON SET TO MSG!!' -CAAAAA%%%%% - ALON(KOUNT) = XMSG - TAG(KOUNT)(12:12) = '@' - ELSE - ALON(KOUNT) = ALON(KOUNT) * .01 - END IF - ACID(KOUNT) = IDENT - TIME(KOUNT) = RDATA(4) -CVVVVV%%%%% - IF(NINT(TIME(KOUNT)).GT.2400.OR.NINT(TIME(KOUNT)).LT.0) - $ PRINT *,'~~~~~ HERE IS A MISSING/UNREASONABLE TIME, TOSSED?' -CAAAAA%%%%% - IRTM(KOUNT) = IRCTME -C DO A TIME CHECK ON REPORT -- IF OUTSIDE EXPANDED INPUT WINDOW TOSS IT - ITIME = NINT(TIME(KOUNT)) - IF(NINT(TBASE).GT.2300.AND.NINT(TIME(KOUNT)).LE. - $ (IDATE(4)*100)+600) TIME(KOUNT) = TIME(KOUNT) + 2400. - IF(TIME(KOUNT).LT.TMIN.OR.TIME(KOUNT).GT.TMAX) THEN -C SKIP REPORTS OUTSIDE REQUESTED TIME WINDOW -CCCCCC PRINT 9002,KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT),TIME(KOUNT) -C9002 FORMAT(/' ##########: MAIN; REPORTS OUTSIDE TIME WINDOW SKIPPED.', -CCCCC$ I5,2X,A8,2F8.2,F6.0) - KOUNT = KOUNT - 1 - GO TO 5 - END IF - IF(RCPTST.AND.IRCTME.LE.2400.AND.MOD(KIX,10).NE.4) THEN -C FOR ALL TYPES EXCEPT TAMDAR, CHECK FOR DATA WITH STRANGE RECEIPT TIME -C COMPARED TO REPORT TIME - MAY BE YESTERDAY'S REPORT PROCESSED TODAY -C -- IF THE RECEIPT TIME IS OUTSIDE THE RANGE OF REPORT TIME MINUS -C 1-HOUR TO REPORT TIME PLUS 11.99 HOURS, SKIP THE REPORT AS WE CAN'T -C DETERMINE ITS VALIDITY {THIS TEST IS NOT DONE FOR TAMDAR REPORTS -C BECAUSE THEY ARE RESENT MANY TIMES OVER AND THE RECEIPT TIME FOR -C VERY LATE (E.G., T-12 NDAS) RUNS MAY INCORRECTLY DISPLAY WHAT LOOKS -C LIKE A STRANGE RECEIPT TIME} - IF(ITIME.LT.100) ITIME = ITIME + 2400 - IETIME = ITIME - 100 - ILTIME = ITIME + 1199 - IF(IRCTME.LT.IETIME.OR.IRCTME.GT.ILTIME) THEN -C RECEIPT TIME IS OUTSIDE EXPECTED RANGE, BUT MAY BE AROUND 00Z SO ADD -C 2400 TO RECEIPT TIME AND TEST AGAIN - IRCTMN = IRCTME + 2400 - IF(IRCTMN.LT.IETIME.OR.IRCTMN.GT.ILTIME) THEN -C RECEIPT TIME IS STILL OUTSIDE EXPECTED RANGE, SKIP REPORT -CVVVVV%%%%% - PRINT *,'~~~~~ THE STRANGE RECEIPT TIME DIFF. HAS OCCURRED!!' -CAAAAA%%%%% - PRINT 9393, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), - $ TIME(KOUNT),IRCTME,SPEC6(3:3) - 9393 FORMAT(/' ##########: SKIP RPTS WHERE OBS. & RCPT. TIME ARE INCON' - $,'SISTENT ',I5,2X,A8,2F8.2,F6.0,'; REC. TIME',I5,'; CAFB? ',A1) - KOUNT = KOUNT - 1 - GO TO 5 - END IF - END IF - END IF - AALT(KOUNT) = RDATA(IY) - ADIR(KOUNT) = RDATA(IY+3) - ASPD(KOUNT) = RDATA(IY+4) - ATMP(KOUNT) = RDATA(IY+1) -C FILL IN FCST VALUES FOR ALT, DIR, SPD & TMP - AALTF(KOUNT) = ALTF - ADIRF(KOUNT) = DIRF - ASPDF(KOUNT) = SPDF - ATMPF(KOUNT) = TMPF - ITEVNT(KOUNT) = 0 - IWEVNT(KOUNT) = 0 -C*********************************************************************** -C*********************************************************************** -C INPUT AIRCFT TABLE A ENTRY MESSAGE QUALITY MARKER SITUATION - -C (P-ALTITUDE, TEMPERATURE. MOISTURE AND WIND) -C -C WILL CONTAIN VALUE OF 14 IF SDM HAS PURGED -C ELSE WILL CONTAIN VALUE OF 0 IF SDM KEEPS -C ELSE WILL CONTAIN DEFAULT VALUE OF 2 -C ELSE WILL CONTAIN A VALUE OF 15 IF DATA ARE MISSING -C -C OTHER INPUT REPORT INFORMATION AS INDICATED: -C -C +++ CONTAINS PROPER AIRCRAFT FLIGHT NUMBER (UP TO EIGHT CHARACTERS) -C +++ CONTAINS SCALED VECTOR WIND INCREMENT (USES ASSIMILATING -C FORECAST DIRECTLY, ASSUMING FCST U AND V ARE IN BUFR DATA) -C +++ CONTAINS CARSWELL-TINKER INDICATOR (AS REPORT SUBTYPE) -C +++ CONTAINS RECEIPT TIME (HOURS) -C +++ CONTAINS INSTRUMENT TYPE -C -C -C OUTPUT QUALITY MARKER SITUATION - SEE DOCBLOCK REMARKS -C (P-ALTITUDE, TEMPERATURE. MOISTURE AND WIND) -C -C -C EVENTS WRITTEN BY THIS PROGRAM INTO OUTPUT PREPBUFR FILE: -C NOTE: AN EVENT CAN ONLY CHANGE A VARIABLE'S QUALITY MARKER, -C THE OBSERVED VARIABLE ITSELF IS NEVER CHANGED. -C IF THE OBSERVED VARIABLE IS MISSING, THE EVENT IS -C NOT ACTIVE. -C VARIABLE -C EVENT SUBR. MEANING QUAL. MARK -C ----- ------ -------------------------------------------- ---------- -C 301 MAIN CARSWELL/TINKER CONVERTED PIREP REPORT TEMP = 13 -C (ID=XX999). TEMPERATURE AND/OR WIND WIND = 13 -C CONSIDERED BAD. -C 302 MAIN REPORT WITH ALTITUDE BETWEEN 2000 & 5000 FT. TEMP = 13 -C WITH TEMPERATURE THAT DIFFERS FROM GUESS WIND = 13 -C BY > 25 DEG. C {PROBABLY DUE TO "0" DIGIT -C DROPPED FROM REPORTED ALTITUDE (TRUE -C ALTITUDE BETWEEN 20,000 & 50,000 FT.)} -C TEMPERATURE AND/OR WIND CONSIDERED BAD. -C 303 MAIN REPORT WITH NON-MISSING TEMPERATURE GREATER TEMP = 13 -C THAN MAXIMUM LIMIT (12 DEG. C PRIOR TO -C ??/??/2005, 32 DEG. C AFTER THIS DATE). -C TEMPERATURE CONSIDERED BAD. -C 304 MAIN REPORT WITH CALM WIND NOT FROM A DIRECTION WIND = 13 -C OF 360 DEG. WIND CONSIDERED BAD. -C 305 MAIN PIREP REPORT (ID=P...P) WITH VECTOR WIND TEMP = 13 -C INCREMENT GREATER THAN 20 KNOTS, OR WITH WIND = 13 -C UNKNOWN VECTOR WIND INCREMENT. TEMPERATURE -C AND/OR WIND CONSIDERED BAD. -C 306 MAIN REPORT WITH A CALM WIND IN A STACK OF LESS WIND = 13 -C THAN 7 CO-LOCATED REPORTS WITH LESS THAN 4 -C REPORTS HAVING A CALM WIND. WIND CONSIDERED -C BAD. -C 307 TRKCHK MID- OR HIGH-LEVEL ASDAR/AMDAR/TAMDAR REPORT WIND = 13 -C IN A TRACK WITH AN UNREASONABLE GROUND SPEED -C AND VECTOR WIND INCREMENT GREATER THAN 70 -C KNOTS. WIND CONSIDERED BAD. -C 308 TRKCHK THIS ONE OF A PAIR OF AIREP/PIREP REPORTS WIND = 13 -C IN A TRACK IS DETERMINED TO BE A TYPE 2A -C DUPLICATE. WIND CONSIDERED BAD. -C 309 TRKCHK THIS ONE OF A PAIR OF AIREP/PIREP REPORTS WIND = 13 -C IN A TRACK IS DETERMINED TO HAVE A TYPE 3 -C ERROR. WIND CONSIDERED BAD. -C 310 TRKCHK THIS ONE OF SEVERAL (> 2) AIREP/PIREP WIND = 13 -C REPORTS IN A TRACK IS DETERMINED TO HAVE A -C TYPE 3 ERROR. WIND CONSIDERED BAD. -C 311 TRKCHK THIS ONE OF SEVERAL (> 2) AIREP/PIREP WIND = 13 -C REPORTS IN A TRACK IS DETERMINED TO BE A -C TYPE 2B DUPLICATE. WIND CONSIDERED BAD. -C 312 TRKCHK THIS ONE OF SEVERAL (> 2) AIREP/PIREP WIND = 13 -C REPORTS IN A TRACK IS DETERMINED TO BE A -C TYPE 2A DUPLICATE. WIND CONSIDERED BAD. -C 313 TRKCHK THIS LAST OF SEVERAL (> 2) AIREP/PIREP WIND = 13 -C REPORTS IN A TRACK IS DETERMINED TO IN -C ERROR. WIND CONSIDERED BAD. -C 314 TRKCHK THIS ONE OF SEVERAL (> 2) AIREP/PIREP WIND = 13 -C REPORTS IN A TRACK IS DETERMINED TO BE A -C TYPE 3 DUPLICATE. WIND CONSIDERED BAD. -C 315 AVEROB, REPORT IS USED TO GENERATE A SUPEROB TEMP = 10 -C SUPROB, REPORT. TEMPERATURE AND/OR WIND ARE FLAGGED WIND = 10 -C NOEQ2 FOR NON-USE BY ANALYSIS. -C 316 RPACKR ISOLATED AIREP/PIREP REPORT WITH VECTOR WIND TEMP = 13 -C INCREMENT GREATER THAN 50 KNOTS. TEMPERATURE WIND = 13 -C AND/OR WIND CONSIDERED BAD. -C 317 RPACKR ISOLATED AIREP/PIREP REPORT WITH VECTOR WIND TEMP = 1 -C INCREMENT LESS THAN 21 KNOTS. TEMPERATURE WIND = 1 -C AND/OR WIND CONSIDERED GOOD. -C 318 RPACKR ISOLATED AIREP/PIREP REPORT WITH VECTOR WIND TEMP = 3 -C INCREMENT GREATER THAN 20 KNOTS BUT LESS WIND = 3 -C THAN 51 KNOTS. TEMPERATURE AND/OR WIND -C CONSIDERED SUSPECT. -C 319 RPACKR, REPORT (ISOLATED OR STACKED) WITH A WIND TEMP = 13 -C PRELIM THAT HAS FAILED ONE OR MORE CHECKS AND IS -C CONSIDERED BAD. TEMPERATURE CONSIDERED BAD. -C 320 RPACKR REPORT IN A STACK OF CO-LOCATED REPORTS WITH TEMP = 1 -C A TEMPERATURE AND/OR WIND THAT HAS PASSED WIND = 1 -C ALL CHECKS. TEMPERATURE AND/OR WIND -C CONSIDERED GOOD. -C 321 PRELIM REPORT IN A STACK OF CO-LOCATED REPORTS WITH WIND = 13 -C A WIND THAT HAS FAILED THE WIND SHEAR CHECK. -C WIND CONSIDERED BAD. -C 322 PRELIM REPORT IN A STACK OF CO-LOCATED REPORTS WITH TEMP = 13 -C A TEMPERATURE THAT HAS FAILED THE LAPSE -C CHECK. TEMPERATURE CONSIDERED BAD. -C 323 SUPROB REPORT IN A STACK OF CO-LOCATED REPORTS THAT TEMP = 13 -C IS AVAILABLE TO BE USED TO GENERATE A WIND = 13 -C SUPEROB REPORT. HOWEVER, IT'S WIND HAS -C FAILED ONE OR MORE CHECKS AND IT IS NOT USED -C TO GENERATE A SUPEROB. TEMPERATURE AND/OR -C WIND CONSIDERED BAD. -C 324 NOEQ2 THIS ONE OF A PAIR OF CO-LOCATED REPORTS HAS TEMP = 13 -C A VECTOR WIND INCREMENT GREATER THAN 50 WIND = 13 -C KNOTS AND CONTAINS A SUSPECTED TRACK CHECK -C ERROR. TEMPERATURE AND/OR WIND CONSIDERED -C BAD. -C 325 OBUFR, AIREP/PIREP OR SUPEROB REPORT OVER THE TEMP = 15 -C SBUFR CONTINENTAL U.S. OR SURROUNDING ENVIRONS WIND = 15 -C WHEN NAMELIST SWITCH IFLGUS = 1 AND THERE -C ARE AT LEAST TWO "AIRCAR" TABLE A BUFR -C MESSAGES READ IN PREVIOUSLY. TEMPERATURE -C AND/OR WIND ARE FLAGGED FOR NON-USE BY -C ANALYSIS. -C 326 SBUFR SUPEROB REPORT THAT HAS BEEN GENERATED BY TEMP = 1 -C THIS PROGRAM. TEMPERATURE AND/OR WIND WIND = 1 -C CONSIDERED GOOD. -C 327 TRKCHK IN A TRACK CONTAINING AT LEAST 15 ASDAR/ WIND = 13 -C AMDAR/TAMDAR REPORTS, THERE ARE AT LEAST 10 -C REPORTS WITH A VECTOR WIND INCREMENT GREATER -C THAN 50 KNOTS. WIND CONSIDERED BAD. -C 328 RPACKR ISOLATED ASDAR/AMDAR/TAMDAR REPORT WITH A TEMP = 1 -C TEMPERATURE AND/OR WIND THAT HAS PASSED ALL WIND = 1 -C CHECKS. TEMPERATURE AND/OR WIND CONSIDERED -C GOOD. -C 329 RPACKR AIREP/PIREP REPORT IN A STACK OF ONLY TWO TEMP = 13 -C CO-LOCATED REPORTS WITH VECTOR WIND WIND = 13 -C INCREMENT GREATER THAN 50 KNOTS. -C TEMPERATURE AND/OR WIND CONSIDERED BAD. -C 330 RPACKR ISOLATED ASDAR/AMDAR/TAMDAR REPORT WITH A TEMP = 3 -C MISSING PHASE OF FLIGHT INDICATOR WIND = 3 -C (PROBABLY BANKING). TEMPERATURE AND/OR -C WIND CONSIDERED SUSPECT. -C -C -C*********************************************************************** -C -C EACH REPORT CARRIES WITH IT IN THIS PROGRAM THE FOLLOWING 'TAG' INFO: -C -C BYTE 1 : WILL CONTAIN 'P' IF SDM HAS PURGED WIND (IN WHICH CASE -C PREVIOUS PREPDATA CODE HAS ALSO PURGED TEMP) -C (NOTE: NO LONGER SET TO 'P' IF SDM HAS PURGED TEMP BUT -C NOT WIND) -C ** NO LONGER!! : ELSE WILL CONTAIN 'H' IF SDM KEEPS -C : ELSE WILL CONTAIN THE ON29 FORM OF SCALED OBSERVED -C VECTOR INCREMENT ('Q' - 'Z') IF INCREMENT COULD BE -C PRODUCED -C : ELSE WILL CONTAIN 'C' (OLD ON29 MARKER FOR -C 'INSTANTANEOUS SPOT WIND USED') -C : ELSE WILL CONTAIN '-' IF WAYPOINT CORRECTION IS MADE -C : ELSE WILL CONTAIN 'D' IF THIS REPORT IS A DUPLICATE -C BYTE 2 : +++ FINAL TEMPERATURE QUALITY MARKER (ON29 FORM) -C (NOTE: ON29 MARKER " " CHANGED TO "-" HERE) -C BYTE 3 : +++ TRACK CHECK INDICATOR -C : WILL CONTAIN 'E' IF SUSPECTED TRACK CHECK ERROR -C : ELSE WILL BE '-' -C BYTE 4 : +++ FINAL WIND QUALITY MARKER (ON29 FORM) -C (NOTE: ON29 MARKER " " CHANGED TO "-" HERE) -C BYTE 5 : +++ ON29 FORM OF ORIGINAL SCALED VECTOR INCREMENT VALUE -C : WILL CONTAIN 'Q' - 'Z' IF INCREMENT COULD BE PRODUCED -C : ELSE WILL CONTAIN 'N' IF NOT CALUCLATED -C BYTE 6 : +++ ASDAR/AMDAR/TAMDAR TEMPERATURE PRECISION -C : WILL CONTAIN '0' IF LOW PRECISION -C : WILL CONTAIN '1' IF HIGH PRECISION -C : ELSE WILL BE '-' IF ASDAR/AMDAR/TAMDAR T. PRECISION NOT -C REPORTED, OR IF NOT AN ASDAR/AMDAR/TAMDAR REPORT -C BYTE 7 : +++ ASDAR/AMDAR/TAMDAR/CARSWELL-TINKER INDICATOR -C : WILL CONTAIN 'Z' IF ASDAR/AMDAR/TAMDAR REPORT -C : ELSE WILL CONTAIN 'C' IF CARSWELL-TINKER REPORT -C : ELSE WILL BE '-' IF NONE OF THE ABOVE -C BYTE 8 : +++ ASDAR/AMDAR/TAMDAR TURBULENCE INDICATOR -C : WILL CONTAIN '0' IF NO TURBULENCE -C : WILL CONTAIN '1' IF LIGHT TURBULENCE -C : WILL CONTAIN '2' IF MODERATE TURBULENCE -C : WILL CONTAIN '3' IF SEVERE TURBULENCE -C : ELSE WILL BE '-' IF NONE OF ABOVE OR AIREP/PIREP REPORT -C BYTE 9 : +++ CORRECTED WAYPOINT LOCATION INDICATOR -C : WILL CONTAIN 'C' IF LAT/LON CHANGED (CORRECTED) -C : ELSE WILL BE '-' -C BYTE 10 : +++ ASDAR/AMDAR/TAMDAR PHASE OF FLIGHT INDICATOR -C : WILL CONTAIN '0' - '2' IF RESERVED -C : WILL CONTAIN '3' IF LEVEL FLIGHT, ROUTINE OBSERVATION -C : WILL CONTAIN '4' IF LEVEL FLIGHT, HIGHEST WND ENCOUNTERED -C : WILL CONTAIN '5' IF ASCENDING -C : WILL CONTAIN '6' IF DESCENDING -C : WILL CONTAIN '7' IF MISSING (PROBABLY BANKING) -C : ELSE WILL CONTAIN '9' IF AIREP/PIREP REPORT -C BYTE 11 : +++ CURRENTLY NOT USED AND SET TO '-' -C BYTE 12 : +++ ISOLATED REPORT INDICATOR -C : WILL CONTAIN 'I' IF AN ISOLATED REPORT -C : ELSE WILL BE '-' -C BYTE 13 : +++ NUMERICAL VALUE FOR TEMPERATURE QUALITY MARKER -C : LOWER NUMBER ALWAYS SUPERCEDES HIGHER NUMBER (SEE && ) -C BYTE 14 : +++ NUMERICAL VALUE FOR WIND QUALITY MARKER -C : LOWER NUMBER ALWAYS SUPERCEDES HIGHER NUMBER (SEE && ) -C -C && - '0' -- DUPLICATE ('D') ('D' IS ONLY STORED IN POS. 1 OF TAG) -C '1' -- PURGE ('P') -- OR -- -C KEEP ('H') -C '2' -- DATA ARE MISSING -C '3' -- BAD ('F') -C '4' -- OMIT ('O') -C '5' -- SUSPECT ('Q') -C '6' -- GOOD ('A') -C '7' -- CANNOT BE CHECKED/UNTREATABLE OR NOT CHECKED (' ' OR -C '-') -C '8' -- INITIAL VALUE -C -C - TAG(KOUNT)(2:4) = '---' - TAG(KOUNT)(6:9) = '----' - TAG(KOUNT)(11:11) = '-' - TAG(KOUNT)(10:10) = SPEC5(3:3) - - IF((MOD(KIX,10).EQ.1.OR.MOD(KIX,10).EQ.4.OR.MOD(KIX,10).EQ.5))THEN - -C AMDAR/ASDAR/TAMDAR - - TAG(KOUNT)(3:3) = 'Z' - TAG(KOUNT)(6:6) = SPEC5(4:4) - TAG(KOUNT)(7:7) = 'Z' - TAG(KOUNT)(8:8) = QMARKI(3:3) - ELSE IF(SPEC6(3:3).EQ.'C') THEN - -C TINKER (CARSWELL) - - TAG(KOUNT)(7:7) = 'C' - END IF - - TAG(KOUNT)(13:14) = '88' - TAG(KOUNT)(5:5) = 'N' - IF(QMARKI(4:4).GE.'Q'.AND.QMARKI(4:4).LE.'Z') - $ TAG(KOUNT)(5:5) = QMARKI(4:4) - TAG(KOUNT)(1:1) = QMARKI(4:4) - IF(QMARKI(1:1).EQ.'P') THEN - TAG(KOUNT)(1:1) = 'P' -C IF SDM PURGE FLAG ON WIND, WIND Q.M. IS 'P' -C (NOTE: IN THIS CASE PREVIOUS PREPOBS_PREPDATA PROGRAM HAS ALSO -C PURGED TEMP, SO ITS Q.M. WILL ALSO BE SET TO 'P' FURTHER DOWN) - IF(QMARKI(5:5).NE.'P') THEN !shouldn't happen (see NOTE above) - PRINT 9029, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), - $ TIME(KOUNT),TAG(KOUNT) - 9029 FORMAT(/' ##########: SDM PURGE FLAG ON WIND, WIND Q.M. IS "P".', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - ELSE ! should ALWAYS happen (see NOTE above) - PRINT 90291, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), - $ TIME(KOUNT),TAG(KOUNT) -90291 FORMAT(/' ##########: SDM PURGE FLAG ON WIND & TEMP, Q.M.s "P".', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - END IF -C SET POS. 12 OF TAG TO '@' TO MARK PURGE FLAG - TAG(KOUNT)(12:12) = '@' - TAG(KOUNT)(4:4) = 'P' - TAG(KOUNT)(14:14) = '1' - ELSE IF(QMARKI(1:1).EQ.'H') THEN -C IF SDM KEEP FLAG ON WIND, WIND Q.M. IS 'H' - PRINT 9027, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), - $ TIME(KOUNT),TAG(KOUNT) - 9027 FORMAT(/' ##########: SDM KEEP FLAG ON WIND, WIND Q.M. IS "H".', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KOUNT)(4:4) = 'H' - TAG(KOUNT)(14:14) = '1' - END IF - IF(QMARKI(5:5).EQ.'P') THEN -C IF SDM PURGE FLAG ON TEMP, TEMP Q.M. IS 'P' -C (NOTE: IF ONLY SDM PURGE FLAG ON WIND, PREVIOUS PREPOBS_PREPDATA -C PROGRAM WILL ALSO SET TEMP Q.M. AS SDM PURGE) - IF(QMARKI(1:1).NE.'P') PRINT 90292, KOUNT,ACID(KOUNT), - $ ALAT(KOUNT),ALON(KOUNT),TIME(KOUNT),TAG(KOUNT) -90292 FORMAT(/' ##########: SDM PURGE FLAG ON TEMP, TEMP Q.M. IS "P".', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KOUNT)(2:2) = 'P' - TAG(KOUNT)(13:13) = '1' - ELSE IF(QMARKI(5:5).EQ.'H') THEN -C IF SDM KEEP FLAG ON TEMP, TEMP Q.M. IS 'H' - PRINT 90271, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), - $ TIME(KOUNT),TAG(KOUNT) -90271 FORMAT(/' ##########: SDM KEEP FLAG ON TEMP, TEMP Q.M. IS "H".', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KOUNT)(2:2) = 'H' - TAG(KOUNT)(13:13) = '1' - END IF - IF(TAG(KOUNT)(1:1).NE.'P') THEN - IF(ATMP(KOUNT).GE.XMSG) THEN -C IF TEMPERATURE OR WIND IS MISSING KEEP QUALITY MARKERS EQUAL TO '-' - IF(TAG(KOUNT)(13:13).GT.'2') TAG(KOUNT)(13:13) = '2' - ELSE IF(ATMPF(KOUNT).LT.XMSG) THEN -C IF GUESS TEMP. AVAILABLE, CHECK TEMP. OF RPTS WITH ALT. BETWEEN 2000 -C AND 5000 FT. - IF NOT W/I 25 DEG. C OF GUESS TEMP. FLAG THE RPT; SET -C POS. 12 OF TAG TO '@' TO MARK THEM -C (NOTE: DONE TO FLAG RPTS THAT ARE ACTUALLY AT AN ALT. BETWEEN 20,000 -C AND 50,000 FT. BUT ARE REPORTED WITH A '0' DIGIT DROPPED) - IF((AALT(KOUNT).GT.609..AND.AALT(KOUNT).LT.1524.).AND. - $ (ABS(ATMP(KOUNT)-ATMPF(KOUNT)).GT.250.)) THEN - TAG(KOUNT)(12:12) = '@' -CVVVVV%%%%% - PRINT *,'~~~~~ HERE IS A RPT WITH INCORRECT? ALTITUDE!!' -CAAAAA%%%%% - IF(TAG(KOUNT)(13:13).GT.'3') THEN - IF(EWRITE) PRINT 9902, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT) - 9902 FORMAT(/' #EVENT 302: "0" DIGIT DROPPED FROM ALT.?, TEMP QM "F" ', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KOUNT)(2:2) = 'F' - TAG(KOUNT)(13:13) = '3' - ITEVNT(KOUNT) = 302 - END IF - IF(TAG(KOUNT)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 8902, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT) - 8902 FORMAT(/' #EVENT 302: "0" DIGIT DROPPED FROM ALT.?, WIND QM "F" ', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KOUNT)(4:4) = 'F' - TAG(KOUNT)(14:14) = '3' - IWEVNT(KOUNT) = 302 - END IF - END IF - END IF - IF(ASPD(KOUNT).GE.XMSG.OR.ADIR(KOUNT).GE.XMSG) THEN - IF(TAG(KOUNT)(14:14).GT.'2') TAG(KOUNT)(14:14) = '2' - END IF - IF(TAG(KOUNT)(13:13).GT.'3'.AND.ATMP(KOUNT).GT.320.) THEN -C FLAG TEMPERATURES GREATER THAN MAXIMUM LIMIT (GROSS CLIMATOLOGICAL -C CHECK - LIMIT CHANGED FROM 12 TO 32 DEG. C ON ??/??/2005) - IF(EWRITE) PRINT 9004, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT) - 9004 FORMAT(/' #EVENT 303: TEMPERATURE > 32.0 C, TEMP Q.M. SET TO "F"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KOUNT)(2:2) = 'F' - TAG(KOUNT)(13:13) = '3' - ITEVNT(KOUNT) = 303 - END IF - IF(TAG(KOUNT)(14:14).GT.'3'.AND.ASPD(KOUNT).EQ.0..AND. - $ ADIR(KOUNT).NE.360.) THEN -C FLAG CALM WINDS THAT ARE NOT ASSIGNED A DIRECTION OF 360 DEGREES - IF(EWRITE) PRINT 9005, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT) - 9005 FORMAT(/' #EVENT 304: CALM WIND NOT FROM 360, WIND Q.M. SET "F".', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KOUNT)(4:4) = 'F' - TAG(KOUNT)(14:14) = '3' - IWEVNT(KOUNT) = 304 - END IF - IF(ACID(KOUNT).EQ.'XX999 ') THEN -C FLAG CARSWELL-TINKER CONVERTED PIREPS; SET POS. 12 OF TAG TO '@' TO -C MARK THEM - TAG(KOUNT)(12:12) = '@' - IF(TAG(KOUNT)(13:13).GT.'3') THEN - IF(EWRITE) PRINT 9001, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT) - 9001 FORMAT(/' #EVENT 301: CARSWELL-TINKER PIREP(XX999), TEMP QM "F" ', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KOUNT)(2:2) = 'F' - TAG(KOUNT)(13:13) = '3' - ITEVNT(KOUNT) = 301 - END IF - IF(TAG(KOUNT)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 8001, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT) - 8001 FORMAT(/' #EVENT 301: CARSWELL-TINKER PIREP(XX999), WIND QM "F" ', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KOUNT)(4:4) = 'F' - TAG(KOUNT)(14:14) = '3' - IWEVNT(KOUNT) = 301 - END IF - ELSE IF(ACID(KOUNT)(1:1).EQ.'P'.AND.ACID(KOUNT)(6:8).EQ. - $ 'P '.AND.((TAG(KOUNT)(5:5).GE.'S'.AND.TAG(KOUNT)(5:5).LE.'Z') - $ .OR.TAG(KOUNT)(5:5).EQ.'N')) THEN -C FLAG OTHER PIREPS IF INCR. MARKER 'S-Z' OR 'N'; SET POS. 12 OF TAG TO -C '@' TO MARK THEM - TAG(KOUNT)(12:12) = '@' - IF(TAG(KOUNT)(13:13).GT.'3') THEN - IF(EWRITE) PRINT 9006, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT) - 9006 FORMAT(/' #EVENT 305: PIREP W/ LG OR N/A INCR., TEMP Q.M. IS "F"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KOUNT)(2:2) = 'F' - TAG(KOUNT)(13:13) = '3' - ITEVNT(KOUNT) = 305 - END IF - IF(TAG(KOUNT)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 8006, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT) - 8006 FORMAT(/' #EVENT 305: PIREP W/ LG OR N/A INCR., WIND Q.M. IS "F"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KOUNT)(4:4) = 'F' - TAG(KOUNT)(14:14) = '3' - IWEVNT(KOUNT) = 305 - END IF - END IF - END IF - IF(IWRITE) THEN - PRINT 6177, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), - $ NINT(TIME(KOUNT)),NINT(AALT(KOUNT)),NINT(ATMP(KOUNT)), - $ NINT(ADIR(KOUNT)),NINT(ASPD(KOUNT)),TAG(KOUNT),INTP(KOUNT), - $ IRTM(KOUNT),KNTINI(KOUNT),NINT(AALTF(KOUNT)),NINT(ATMPF(KOUNT)), - $ NINT(ADIRF(KOUNT)),NINT(ASPDF(KOUNT)) - 6177 FORMAT(' ',I5,2X,A8,1X,2F8.2,I6,I7,3I6,3X,'"',A14,'"',I6,2I8, - $ I7,3I6) - END IF -C NOW GO BACK AND READ IN NEXT REPORT - GO TO 5 -C*********************************************************************** - 2 CONTINUE -C ALL MESSAGES READ IN -- FINISHED READING IN REPORTS - PRINT 812, KOUNT - 812 FORMAT(/' ALL MESSAGES READ IN PREPBUFR FILE -- KOUNT= ',I9) - NFILE = KOUNT - IF(KOUNT.EQ.0) GO TO 6000 -C*********************************************************************** -C SORT BY AIRCRAFT STATION ID -C*********************************************************************** - CALL IDSORT(NFILE,NASDAR,NEXCLD) - IF(IWRITE) THEN - PRINT 2177 - 2177 FORMAT(/' LISTING OF ORIGINAL DATA AFTER IDSORT----'/9X,'ACID', - $ 8X,'LAT WLON UTC ALT TEMP WDIR WSPD -----TAGS', - $ '----- ITYPE RPTIME KNTINI GALT GTEMP GDIR GSPD'/) - DO K = 1,KOUNT - PRINT 6177, K,ACID(K),ALAT(K),ALON(K),NINT(TIME(K)),NINT(AALT(K)), - $ NINT(ATMP(K)),NINT(ADIR(K)),NINT(ASPD(K)),TAG(K),INTP(K),IRTM(K), - $ KNTINI(K),NINT(AALTF(K)),NINT(ATMPF(K)),NINT(ADIRF(K)), - $ NINT(ASPDF(K)) - ENDDO - END IF - PRINT 6122, KOUNT,NFILE,NASDAR,NEXCLD - 6122 FORMAT(/' AFTER ID SORT- KOUNT=',I7,', NFILE=',I7,', NASDAR=',I7, - $ ', NEXCLD=',I7/) -C*********************************************************************** -C TRACK CHECK -C*********************************************************************** -C CALL TRACK CHECK WITH NASDAR, NEXCLD (ASDAR/AMDAR/TAMDAR ARE NEXT TO -C LAST IN SORTED ARRAY, REPORTS EXCLUDED FROM ALL CHECKS ARE LAST -C SORTED ARRAY) -C CALL TRACK CHECK WITH NFILE=KOUNT, RETURNS NEW KOUNT (NO DUPS) - CALL TRKCHK(KOUNT,NASDAR,NEXCLD) -C*********************************************************************** -C HERE, TAG(KOUNT)(3:3) NOW CONTAINS '-' OR 'E' FOR SUSPECTED TRKCHK ERR -C DO CENSUS ON INCREMENTS - DO K = 1,KOUNT - IF(TIME(K).GE.TMINO.AND.TIME(K).LE.TMAXO) THEN - DO M = 1,15 - IF(TAG(K)(1:1).EQ.QCACMK(M)) THEN - NNQM(M) = NNQM(M) + 1 - GO TO 618 - END IF - ENDDO - END IF - 618 CONTINUE - ENDDO -C INITIALIZE SDM LOOKAT FILE FOR FLAGGED ISOLATED REPORTS -- UNIT 52 - WRITE(52,15) (IDATE(I),I=1,4) - 15 FORMAT(/' SDM AIRCRAFT QC CHECK FILE FOR ',I6,3I4) - WRITE(52,45) LATEST - 45 FORMAT(' LATEST A/C REPORT AT ',I4/) - WRITE(52,16) - 16 FORMAT(' ISOLATED REPORTS TOSSED (WIND QM=F), OR WITH LARGE ', - $ 'INCREMENTS (.GE. 50 KNOTS)'/ - $ ' (SUSPECT QM=Q, GOOD QM=A)'/ - $ ' (NOTE1: AMDAR/ASDAR/TAMDAR ARE NEVER FLAGGED AS BAD DUE ONLY ', - $ ' TO LARGE INCREMENTS)'/ - $ ' (NOTE2: DOES NOT INCLUDE REPORTS MARKED FOR EXCLUSION BY ', - $ 'THIS PROGRAM - THESE ARE'/ - $ ' NOT CONSIDERED CANDIDATES FOR RETENTION)'/ - $ ' (NOTE3: REPORTS WITH BAD TEMP QM BUT NON-BAD WIND QM ARE NOT', - $ ' LISTED HERE UNLESS'/ - $ ' THEY HAVE A LARGE INCREMENT (.GE. 50 KNOTS))'// - $ ' SDMEDIT CAN BE USED TO MARK THESE FOR RETENTION (KEEP FLAG) ', - $ 'IN LATER RUNS'//) - WRITE(52,17) - 17 FORMAT(/' AC',8X,'LAT LON UTC ALT TEMP WDIR ', - $ ' WSPD INCR SDM WND TMP'/' IDENT',30X,'(MB) (C)',8X, - $ '(KNTS) (KNTS) FLAG? QM QM'/' -------- ----- ------- ', - $ '----- ----- ----- ----- ----- ---- --- --- ---'/) -C INITIALIZE SDM LOOKAT FILE FOR STACKED REPORTS W/ AVERAGE VECTOR WIND -C INCREMENT EXCEEDING 'STCLIM' VALUE AND FOR STACKED REPORTS WITH AT -C LEAST ONE REPORT CONTAINING SDM KEEP FLAG ON WIND AMD/OR TEMP -- -C UNIT 53 - WRITE(53,15) (IDATE(I),I=1,4) - WRITE(53,6) - 6 FORMAT(' ??? STACK, EVALUATE AND USE SDMEDIT -'/' STACKS WITH ', - $ 'AT LEAST ONE REPORT CONTAINING SDM KEEP FLAG ON WIND AND/OR ', - $ 'TEMP ALSO HERE') - WRITE(53,17) -C INITIALIZE FOR STACK DETERMINATION -C NOTE: THE FINAL SORT IS SET-UP S. T. AIREPS/PIREPS ARE FIRST, FOLLOWED -C BY ASDARS/AMDARS/TAMDARS, AND THEN AT THE END ALL EXLCUDED REPORTS -C -- ONLY THE NON-EXCLUDED AIREP/PIREP REPORTS ARE CHECKED FOR STACKS - K = 1 - INDX = 2 - NCUM = 2 - IFLEPT(1) = 1 - IFLEPT(KOUNT+1) = 1 - KDUP = NFILE - KOUNT - 94 CONTINUE -C FIND COLOCATED OBS- THRU ENTIRE FILE (TOLERANCE IS .55 DEG. LAT/LON) - IQ1 = NINT(ABS(ALAT(INDX)-ALAT(INDX-1)) * 100.) - IQ2 = NINT(ABS(ALON(INDX)-ALON(INDX-1)) * 100.) - IF(IQ1.LE.ITOL.AND.(IQ2.LE.ITOL.OR.IQ2.GE.36000-ITOL)) THEN -C THIS IS A STACK - IF(NCUM.GT.ISMX) THEN -C*********************************************************************** -C FATAL ERROR: THERE ARE MORE REPORTS IN A STACK THAN "ISMX" -- STOP 21 - PRINT 63, ISMX - 63 FORMAT(/' THERE ARE MORE THAN',I5,' AIRCRAFT REPORTS IN A STACK', - $ ' -- MUST INCREASE SIZE OF PARAMETER NAME "ISMX" - STOP 21'/) - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(21) -C*********************************************************************** - END IF - IFLEPT(INDX) = NCUM - NCUM = NCUM + 1 - ELSE -C THIS IS NOT A STACK - IFLEPT(INDX) = 1 - NCUM = 2 - END IF - IF(INDX.LT.KOUNT-NASDAR-NEXCLD) THEN - INDX = INDX + 1 - GO TO 94 - END IF -C ALL ASDAR/AMDAR/TAMDAR AND EXCLUDED REPORTS ARE TREATED AS ISOLATED - IFLEPT(INDX+1:INDX+NASDAR+NEXCLD) = 1 -C ARRANGE STACK - INDX RUNS FROM 1 TO KOUNT WHILE COUNTER FOR -C ISTCPT RUNS FROM 1 TO NUM FOR EACH COLOCATED SET - NUM = 1 - JARRAY = 0 - CTAG = '--------------' - AAID = ' ' - DO INDX = 1,KOUNT - IF(IFLEPT(INDX).EQ.1.AND.IFLEPT(INDX+1).EQ.1) THEN -C----------------------------------------------------------------------- -C THIS IS AN ISOLATED OBSERVATION -C (NOTE: NO FLAGGING IS DONE FOR CALM WINDS WHEN OBS. IS ISOLATED) -C----------------------------------------------------------------------- - TAG(INDX)(12:12) = 'I' - SLAT(1) = ALAT(INDX) - SLON(1) = ALON(INDX) - SAID(1) = ACID(INDX) - SHGT(1) = AALT(INDX) - STIM(1) = TIME(INDX) - SDIR(1) = ADIR(INDX) - SSPD(1) = ASPD(INDX) - STMP(1) = ATMP(INDX) - SHGTF(1) = AALTF(INDX) - SDIRF(1) = ADIRF(INDX) - SSPDF(1) = ASPDF(INDX) - STMPF(1) = ATMPF(INDX) - ISTCPT(1) = 1 - IF(TAG(INDX)(1:1).GE.'W'.AND.TAG(INDX)(1:1).LE.'Z'.AND. - $ INDX.LE.KOUNT-NASDAR-NEXCLD) THEN -C IF LARGE VECTOR WIND INCREMENT (W - Z) AND NON-EXCLUDED AIREP/PIREP -C REPORT, CALL WAYPOINT TO SEE IF LOCATION NEEDS TO BE CHANGED - JARRAY(INDX,1) = NINT(ALAT(INDX)*100.) - JARRAY(INDX,2) = NINT(ALON(INDX)*100.) - CTAG(INDX) = TAG(INDX) - AAID(INDX) = ACID(INDX) - CALL WAYPT(INDX,INDX,NCHNGD) - IF(NCHNGD.EQ.1) THEN - ALAT(INDX) = JARRAY(INDX,1) * .01 - ALON(INDX) = JARRAY(INDX,2) * .01 - TAG(INDX) = CTAG(INDX) -CVVVVV%%%%% - PRINT *,'~~~~~ WAYPT ERROR FROM CALL IN MAIN' -CAAAAA%%%%% -C SUBR. WAYPT HAS CHANGED LOCATION OF THIS REPORT AND HAS UPGRADED THE -C INCREMENT MARKER TO " " (SUSPECT) - PRINT 5768,INDX,ACID(INDX),ALAT(INDX),ALON(INDX), - $ ADIR(INDX),ASPD(INDX),TAG(INDX),INDX - 5768 FORMAT(' IN MAIN: WAYPT CALL ',I5,2X,A8,2F8.2,F6.0,F6.1,2X,'"', - $ A14,'"'/5X,' -- TAG(',I5,')(1:1) CHANGED TO "-"'/) - END IF - END IF -C CALL RPACKR - CALL RPACKR(1,1,INDX) -C CALL FORSDM TO ALERT SDM TO FLAGGED ISOLATED REPORTS OR ISOLATED -C REPORTS WITH LARGE INCREMENTS (SKIP EXCLUDED REPORTS AT END OF THE -C LIST, BUT INCLUDE ASDARS/AMDARS/TAMDARS) - IF(INDX.LE.KOUNT-NEXCLD) CALL FORSDM(INDX) - ICNT1 = ICNT1 + 1 -C----------------------------------------------------------------------- - ELSE IF(IFLEPT(INDX).EQ.1.AND.IFLEPT(INDX+1).EQ.2) THEN -C CONTINUE, THERE ARE AT LEAST TWO - U(1) = -SIN(ADIR(INDX)*RAD) * ASPD(INDX) - V(1) = -COS(ADIR(INDX)*RAD) * ASPD(INDX) - UF(1) = XMSG - VF(1) = XMSG - IF(AMAX1(ADIRF(INDX),ASPDF(INDX)).LE.XMSG) THEN - UF(1) = -SIN(ADIRF(INDX)*RAD) * ASPDF(INDX) - VF(1) = -COS(ADIRF(INDX)*RAD) * ASPDF(INDX) - END IF -C JNDX SAVES THE STARTING POINT OF THE STAC - JNDX = INDX -C----------------------------------------------------------------------- - ELSE IF(IFLEPT(INDX).GT.1.AND.IFLEPT(INDX+1).GT.1) THEN -C CONTINUE, THERE ARE STILL MORE - NUM = IFLEPT(INDX) - U(NUM) = -SIN(ADIR(INDX)*RAD) * ASPD(INDX) - V(NUM) = -COS(ADIR(INDX)*RAD) * ASPD(INDX) - UF(NUM) = XMSG - VF(NUM) = XMSG - IF(AMAX1(ADIRF(INDX),ASPDF(INDX)).LE.XMSG) THEN - UF(NUM) = -SIN(ADIRF(INDX)*RAD) * ASPDF(INDX) - VF(NUM) = -COS(ADIRF(INDX)*RAD) * ASPDF(INDX) - END IF - ELSE IF(IFLEPT(INDX).GT.1.AND.IFLEPT(INDX+1).EQ.1) THEN -C THERE IT IS FINISHED --- -C----------------------------------------------------------------------- -C THIS IS A STACK OF 'NUM' OBSERVATIONS -C----------------------------------------------------------------------- - NUM = IFLEPT(INDX) - NUMORG = NUM - U(NUM) = -SIN(ADIR(INDX)*RAD) * ASPD(INDX) - V(NUM) = -COS(ADIR(INDX)*RAD) * ASPD(INDX) - UF(NUM) = XMSG - VF(NUM) = XMSG - IF(AMAX1(ADIRF(INDX),ASPDF(INDX)).LE.XMSG) THEN - UF(NUM) = -SIN(ADIRF(INDX)*RAD) * ASPDF(INDX) - VF(NUM) = -COS(ADIRF(INDX)*RAD) * ASPDF(INDX) - END IF - DO K = 1,NUM - KNDX = JNDX - 1 + K - SLAT(K) = ALAT(KNDX) - SLON(K) = ALON(KNDX) - SAID(K) = ACID(KNDX) - SHGT(K) = AALT(KNDX) - STIM(K) = TIME(KNDX) - SDIR(K) = ADIR(KNDX) - SSPD(K) = ASPD(KNDX) - STMP(K) = ATMP(KNDX) - SHGTF(K) = AALTF(KNDX) - SDIRF(K) = ADIRF(KNDX) - SSPDF(K) = ASPDF(KNDX) - STMPF(K) = ATMPF(KNDX) - ISTCPT(K) = K - KBAD(K) = K - ENDDO -C NOTE THAT AT THIS POINT ISTCPT ARRAY IS JUST DIGITAL COUNT -C -C CHECK FOR DUPLICATE REPORTS IN THE STACK MISSED BY DECODER -C AND TRKCHK ROUTINE - IK = 0 - KNUM = NUM - DO I = 1,NUM-1 - DO J = I+1,NUM - IF(SAID(I).EQ.SAID(J)) THEN - IK = IK + 1 - IDSTR(IK,1) = I - IDSTR(IK,2) = J - IF(IK.GE.400) THEN - PRINT 445 - 445 FORMAT(/' ** IN DUPL. CHECK A STACK W/ .GT. 400 DUPL. ACID"S ', - $ 'FOUND -- MUST BUMP-UP ARRAY -- NO MORE DUPL. CAN BE CHECKED!!'/) - GO TO 1191 - END IF - END IF - ENDDO - ENDDO - 1191 CONTINUE - IF(IK.GT.0) THEN - DO K = 1,IK - KNDX = JNDX - 1 + IDSTR(K,1) - LNDX = JNDX - 1 + IDSTR(K,2) - IHGT1 = AALT(KNDX) - IHGT2 = AALT(LNDX) - ISPD1 = ASPD(KNDX) - ISPD2 = ASPD(LNDX) - IDIR1 = ADIR(KNDX) - IDIR2 = ADIR(LNDX) - IF(IHGT1.EQ.IHGT2.AND.ISPD1.EQ.ISPD2.AND.IDIR1.EQ.IDIR2) THEN - L = IDSTR(K,1) - M = IDSTR(K,2) - IFLEPT(KNDX) = 0 - ISTCPT(L) = 0 - KDUP = KDUP + 1 - IF(EWRITE) PRINT 9003, KNDX,ACID(KNDX), - $ ALAT(KNDX),ALON(KNDX),TIME(KNDX),TAG(KNDX) - 9003 FORMAT(/' #EVENT ###: STACK DUPLICATE, TEMP/WIND Q.M. SET TO "D"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') -C ASSIGN 'D' TO POS. 1 OF TAG TO INDICATE DUPLICATE (RPACKR WILL DELETE) - TAG(KNDX)(1:1) = 'D' - TAG(KNDX)(13:13) = '0' - TAG(KNDX)(14:14) = '0' - KNUM = KNUM - 1 - PRINT 5382, L,KNDX,SAID(L),SHGT(L),STIM(L), - $ SDIR(L),SSPD(L),ALAT(KNDX),ALON(KNDX),NUM - PRINT 5383, M,LNDX,SAID(M),SHGT(M),STIM(M), - $ SDIR(M),SSPD(M),ALAT(LNDX),ALON(LNDX),KNUM - 5382 FORMAT(' **DUP CHKR THROWS ',2I5,2X,A8,',AALT=',F7.0,', TIME=', - $ F7.0,', DIR=',F5.0,', SPD=',F5.1,', LAT/LON=',2F7.2,' NUM=',I3) - 5383 FORMAT(' THE OTHER IS ',2I5,2X,A8,',AALT=',F7.0,', TIME=', - $ F7.0,', DIR=',F5.0,', SPD=',F5.1,', LAT/LON=',2F7.2,' KNUM=',I3) - END IF - ENDDO - IF(KNUM.EQ.1) THEN -C IF ALL DUPL. BUT ONE ARE REMOVED, THIS REPORT NOW TREATED AS ISOLATED - TAG(JNDX+1)(12:12) = 'I' - CALL RPACKR(1,1,JNDX+1) - GO TO 19 - END IF - END IF -C COUNT CALMS - KNUM = 0 - DO KNDX = JNDX,JNDX+NUM-1 - IF(ASPD(KNDX).EQ.0.0) KNUM = KNUM + 1 - ENDDO - IF(KNUM.LE.3.AND.NUM.LE.6) THEN -C IF NUMBER OF CALMS IN STACK (KNUM) < 3 THEN FLAG WINDS - DO K = 1,NUM - KNDX = K + JNDX - 1 - IF(ASPD(KNDX).EQ.0.0) THEN - IFLEPT(KNDX) = 0 - IF(TAG(KNDX)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 9007, KNDX,ACID(KNDX), - $ ALAT(KNDX),ALON(KOUNT),TIME(KNDX),TAG(KNDX) - 9007 FORMAT(/' #EVENT 306: # CALMS IN STACK < 3, WIND Q.M. SET TO "F"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KNDX)(4:4) = 'F' - TAG(KNDX)(14:14) = '3' - IWEVNT(KNDX) = 306 - END IF - END IF - ISTCPT(K) = IFLEPT(KNDX) - ENDDO - END IF - LOALT = 0 - DO I = 1,NUM - KNDX = JNDX + I - 1 - IF(AALT(KNDX).LT.8400.) THEN - IFLEPT(KNDX) = -1 - ISTCPT(I) = -1 - LOALT = LOALT + 1 - END IF - ENDDO -C CALLS TO APPROPRIATE ROUTINES - NTOTL = NUM - IF(NUM.EQ.2) THEN - CALL PRELIM(NUM,JNDX,LOALT,KNUM,STCLIM) - IF(DOSPOB) CALL NOEQ2(NUM,JNDX,NTOTL) - CALL RPACKR(NUM,NTOTL,JNDX) - ICNT2 = ICNT2 + 1 - NUM = 1 - ELSE - CALL PRELIM(NUM,JNDX,LOALT,KNUM,STCLIM) - IF(DOSPOB) CALL SUPROB(NUM,JNDX,NTOTL,LOALT,KNUM) -C CALL RPACKR - CALL RPACKR(NUM,NTOTL,JNDX) -C DO CENSUS ON #S AT POINTS-BOOKEEPING - IF(NUM.GT.10) THEN - ICNTX = ICNTX + 1 - ELSE IF(NUM.GT.5) THEN - ICNT69 = ICNT69 + 1 - ELSE IF(NUM .GT. 3) THEN - ICNT45 = ICNT45+ 1 - ELSE - ICNT3 = ICNT3 + 1 - END IF - NUM = 1 - END IF -C--------------------------------------------------------------------- - END IF - 19 CONTINUE - ENDDO - 6000 CONTINUE -C----------------------------------------------------------------------- -C PACK Q.C'ED AND SUPEROBED (DOSPOB=T) OBSERVATIONS -C INTO PREPBUFR FILE -C----------------------------------------------------------------------- - CALL OBUFR(KOUNT) -C----------------------------------------------------------------------- -C ALL REPORTS HAVE BEEN PROCESSED -- WE ARE DONE -C----------------------------------------------------------------------- - PRINT 8926, KNTOUT(1),KNTOUT(2),KNTOUT(4),KNTOUT(5) - 8926 FORMAT(/5X,'@@@@@ ALL REPORTS PROCESSED: NUMBER OF ORIGINAL ', - $ '"AIRCFT" MASS RPTS COPIED TO OUTPUT FILE =',I5/35X,'NUMBER OF ', - $ 'ORIGINAL "AIRCFT" WIND REPORTS COPIED TO OUTPUT FILE =',I5/35X, - $ 'NUMBER OF SUPEROB MASS RPTS WRITTEN TO OUTPUT FILE =',I5/35X, - $ 'NUMBER OF SUPEROB WIND RPTS WRITTEN TO OUTPUT FILE =',I5) - IF(FWRITE) THEN - PRINT 8923 - 8923 FORMAT(//26X,'>>>>> ORIGINAL LISTING OF AIRCRAFT REPORTS NOW ', - $'WITH NEW QUALITY MARKS <<<<<'//' K STNID TIME LAT ', - $ 'LON ALT TEMP DIR SPD Q.M. -----TAGS----- ITYP RCTME ', - $ 'KINI TEVN WEVN GALT GTEMP GDIR GSPD'/16X,'UTC',10X,'WEST', - $ 5X,'M C*10 DEG KTS',8X,14('-'),8X,'UTC',21X,'M C*10 DEG', - $ ' KTS'/) - KNT = 0 - DO K = 1,KOUNT - IF(TAG(K)(1:1).EQ.'D') GO TO 200 - KNT = KNT + 1 - PRINT 6111, KNT,ACID(K),NINT(TIME(K)),ALAT(K),ALON(K), - $ NINT(AALT(K)),NINT(ATMP(K)),NINT(ADIR(K)),NINT(ASPD(K)), - $ TAG(K)(2:2),TAG(K)(4:4),TAG(K),INTP(K),IRTM(K),KNTINI(K), - $ ITEVNT(K),IWEVNT(K),NINT(AALTF(K)),NINT(ATMPF(K)),NINT(ADIRF(K)), - $ NINT(ASPDF(K)) - 6111 FORMAT(' ',I5,1X,A8,I5,2F7.2,2I6,2I5,2X,A1,1X,A1,2X,'"',A14,'"', - $ I4,2I6,2I5,I7,3I6) - 200 CONTINUE - ENDDO - IF(KNTOUT(3).GT.0) THEN - PRINT 9925 - 9925 FORMAT(//35X,'>>>>> LISTING OF NEW SUPEROB REPORTS IN AIRCFT ', - $ 'FILE <<<<<'//5X,'K STNID',5X,'TIME',6X,'LAT',6X,'LON ALT', - $ 7X,'TEMP DIR SPEED QUAL GESS: ALT',6X,'TEMP DIR ', - $ ' SPEED INCR'/18X,'UTC',15X,'WEST METERS DEG.C DEG. ', - $ ' KNOTS MARKS --> METERS DEG.C DEG. KNOTS -T--W-'/) - KNT = 0 - DO K = 1,KNTOUT(3) - IF(SSMARK(K)(3:4).EQ.'FF') GO TO 202 - KNT = KNT + 1 - TEMP = XMSG - IF(SSTMP(K).LT.XMSG) TEMP = SSTMP(K)/10. - TMPF = XMSG - IF(SSTMPF(K).LT.XMSG) TMPF = SSTMPF(K)/10. - PRINT 6113, KNT,SSTIM(K),SSLAT(K),SSLON(K),SSHGT(K),TEMP, - $ SSDIR(K),SSSPD(K),SSMARK(K)(1:1),SSMARK(K)(2:2), - $ SSHGTF(K),TMPF,SSDIRF(K),SSSPDF(K),SSMARK(K)(3:3), - $ SSMARK(K)(4:4) - 6113 FORMAT(1X,I5,' SUPROB',F9.0,2F9.2,F9.0,F10.2,F7.0,F7.1,4X,A1,1X, - $ A1,6X,F9.0,F9.2,F7.0,F8.1,3X,A1,2X,A1) - 202 CONTINUE - ENDDO - END IF - END IF - PRINT 5001, NFILE,ICNT1,ICNT2,ICNT3,ICNT45,ICNT69,ICNTX,KDUP - 5001 FORMAT(//' ORIGINAL DATA (WITHIN EXPANDED INPUT TIME WINDOW)'/ - $ ' TOTAL KOUNTS =',I6,'; =1 -',I6,'; =2 -',I5,'; =3 -',I5, - $ '; =4,5 -',I5,'; =6-9 -',I5,'; .GT. 10 -',I5,'# DUPS -',I5) - PRINT 5012, KTYPS - 5012 FORMAT(/' #TYPE1A ',I2,' #TYPE1B ',I2,' #TYPE?? ',I2,' #TYPE1D ', - $ I2,' #TYPE2A ',I2,' #TYPE2B ',I2,' #TYPE3 ',I2,10X,I2,' TIME ', - $ 'TAGS',I2) - PRINT 5014, QCACMK - 5014 FORMAT(//' ORIGINAL DATA (WITHIN OUTPUT TIME WINDOW)'/14X, - $ 15(5X,A1)/) - PRINT 5331, NNQM - 5331 FORMAT(' TOTAL QM #S = ',15I6) - PRINT 5337, KISO - 5337 FORMAT(' ISOLA QM #S = ',15I6) - PRINT 5338, KNQM - 5338 FORMAT(' STACK QM #S = ',15I6) - PRINT 5011, KQM2F - 5011 FORMAT(' STACK WND QM=F',15I6/) - PRINT 5013, KSDM,KT - 5013 FORMAT(' STACK: NO. SDM (ONLY) PURGES',I5,'; NO. SDM KEEPS',I5, - $ '; NO. BAD TEMPS/NON-BAD WINDS',I5/10X,'(WIND AND/OR TEMP)'/) - END FILE 52 - REWIND 52 - END FILE 53 - REWIND 53 - PRINT 5015 - 5015 FORMAT(/49X,'************PROGRAM COMPLETED *********') - CALL W3TAGE('PREPOBS_PREPACQC') - STOP - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: TRKCHK COMPLETE TRACK CHECK FOR ALL FLIGHTS -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2007-10-17 -C -C ABSTRACT: PERFORMS COMPLETE TRACK CHECK FOR ALL AIRCRAFT FLIGHTS -C WITH TWO OR MORE REPORTS. USING REPORTS ALREADY SORTED BY STATION -C (FLIGHT) ID, CALULATES GROUND SPEED AND OTHER LOGICAL QUANTITIES -C TO ENTER DECISION MAKING ALGORITHM FOR CHOOSING BAD REPORTS. THESE -C OBSERVATIONS ARE FLAGGED. DUPLICATE REPORTS ARE ELIMINATED. -C -C PROGRAM HISTORY LOG: -C 1993-01-05 P. JULIAN (W/NMC00) -- ORIGINAL AUTHOR -C 1994-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND -C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT -C 1995-02-10 D. A. KEYSER -- ADDED COND. CODE 24 IF NO. RPTS. IN A -C TRACK EXCEEDS PARAMETER "ITMX", THIS IS BUMPED UP FROM -C 40 TO 500 -C 1995-03-27 D. A. KEYSER -- ALL ASDAR/AMDAR RPTS IN A TRACK W/ AVG. -C INCR. > 70 KTS AMONGST > 14 RPTS. GET FLAGGED WIND (& -C LATER TEMP) (& FOR INIDST=2, NEW RSN. CODE 27) -C 1995-04-26 D. A. KEYSER -- ALL ASDAR/AMDAR RPTS IN A TRACK W/ > 14 -C RPTS GET FLAGGED WIND (& LATER TEMP) IF > 9 RPTS HAVE -C WIND INCR. > 50 KNOTS (CHANGE FROM PREVIOUS TEST, SEE -C PREVIOUS HISTORY LOG) -C 1999-08-23 D.A. KEYSER -- ADDED HIGHER ORDERS IN CHARACTER SORTS -C TO HOPEFULLY ALWAYS GIVE SAME SORT ORDER REGARDLESS OF -C INPUT REPORT ORDER -C 2007-10-17 D. A. KEYSER -- CHECKS TO SEE IF PARAMETER "ITRKL" IS -C EXCEEDED IN A NUMBER OF TRACK CHECK TESTS, IF SO STOPS -C ABNORMALLY WITH CONDITION CODES 26-30 (DEPENDING ON WHAT -C CAUSES "ITRKL" TO BE EXCEEDED), BEFORE COULD RUN TO -C COMPLETION BUT CLOBBER MEMORY OR MAYBE SEG FAULT; -C INCREASED THE SIZE OF PARAMETER "ITRKL" FROM 20 TO 500 - -C TO PREVENT ARRAYS OVERFLOWS IN NEARLY EVERY PRODUCTION -C RUN; INCREASED SIZE OF ARRAY "IPTTRK" FROM 5 TO PARAMETER -C "ITRKL" (NOW 500) (THIS HOLDS POINTER TO REPORTS IN A -C TRACK WITH LARGE POSITION ERRORS), BEFORE THE VALUE OF 5 -C WAS OFTEN EXCEEDED AND MEMORY WAS UNKNOWINGLY BEING -C CLOBBERED; ANY REPORTS WITH ID "UNKNOWN" ARE NOT -C CONSIDERED FOR TRACK CHECKING (THIS WAS PLACED ON SOME -C REPORTS IN REANALYSIS WHEN NO ID WAS PRESENT - SINCE -C THESE ARE NOT NORMALLY PART OF THE SAME FLIGHT THEY -C CANNOT BE TRACK CHECKED); CHANGES TO TREAT TAMDAR AND -C CANADIAN AMDAR REPORTS THE SAME AS ASDAR/AMDAR REPORTS -C -C USAGE: CALL TRKCHK(NFILE,NASDAR,NEXCLD) -C INPUT ARGUMENT LIST: -C NFILE - NUMBER OF OBSERVATIONS TO BE TREATED -C NASDAR - NUMBER OF ASDAR/AMDAR/TAMDAR REPORTS -C NEXCLD - NUMBER OF EXCLUDED REPORTS AT END OF SORT -C -C OUTPUT ARGUMENT LIST: -C NFILE - NUMBER OF OBSERVATIONS AFTER DUPLICATES REMOVED -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C REMARKS: CALLED BY MAIN PROGRAM. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE TRKCHK(NFILE,NASDAR,NEXCLD) - PARAMETER (IRMX= 80000, ISMX= 8000) - PARAMETER (ISIZE= 16) -C PARAMETER NAME "ITMX" IN THIS SUBROUTINE (ONLY) SETS THE MAXIMUM -C NUMBER OF ACFT RPTS THAT CAN BE CHECKED IN A SINGLE TRACK - PARAMETER (ITMX= 8000) -C PARAMETER NAME "ITRKL" IN THIS SUBROUTINE (ONLY) SETS THE FOLLOWING: -C THE MAXIMUM NUMBER OF REPORTS IN THE POINTER SUMMARY FOR A TRACK -C THE MAXIMUM NUMBER OF REPORTS WITH ADJUSTABLE CONSTANTS FOR -C AIRCRAFT GROUND SPEED LIMITS IN A TRACK -C THE MAXIMUM NUMBER OF POINTERS FOR NON-ADJACENT REPORTS IN A -C TRACK -C THE MAXIMUM NUMBER OF DUPLICATE TYPES IN A TRACK -C THE MAXIMUM NUMBER OF REPORTS IN A TRACK WITH LARGE POSTION -C ERRORS - PARAMETER (ITRKL= 1000) - LOGICAL LOGLAT,LOGTME,LOGLT1,LOGWND,DUP,LOGTRK,LOGALT,NEW,LOGLON, - $ LOGLO,LOGTMP,LOGGT3,LOGHI,LPOS25,TRACE,LUTCEQ,LLATEQ,LLONEQ, - $ LVAREQ,EWRITE,IWRITE - CHARACTER*1 TOSLIM,CTG,CH1(9) - CHARACTER*8 ACID,SAAID(IRMX),AAID(IRMX),TYPE(ITRKL) - CHARACTER*14 TAG,CTAG(IRMX),STAG(IRMX) - CHARACTER*32 CARRAY(IRMX) - INTEGER IPTNAD(ITRKL),JPTNAD(ITRKL),IPTADJ(ITRKL),IPTTRK(ITRKL), - $ DTKNT,IARRAY(ISMX),INDR(IRMX),ICH1(9) - REAL AVESPD(ITMX),DELPOS(ITMX),DELLAT(ITMX),DELLON(ITMX) - COMMON/STWRIT/SWRITE,EWRITE,IWRITE - COMMON/XXXXX/AAID,JARRAY(IRMX,ISIZE),CTAG,KARRAY(IRMX,ISIZE),STAG - COMMON/ACCONT/KQM2F(15),KISO(15),KNQM(15),KSDM(2),KT,KTYPS(9) - COMMON/ALLDAT/IFLEPT(IRMX),ACID(IRMX),ALAT(IRMX),ALON(IRMX), - $ AALT(IRMX),TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE, - $ ATMP(IRMX),TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX), - $ ITEVNT(IRMX),IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX), - $ ADIRF(IRMX) - DATA CH1 /'Q','R','S','T','U','V','W','X','Y'/ - DATA ICH1 / 5, 15, 25, 35, 45, 55, 65, 75, 85 / - KOUNT = NFILE - TRACE = .TRUE. - TRACE = .FALSE. - DG2RAD = (4.0 * ATAN(1.0))/180. -C TRANSFER ORIGINAL DATA TO TEMPORARY ARRAYS TO HOLD FOR RE-ARRANGING -C (ORIGINAL DATA HAS BEEN SORTED BY FLIGHT ID, WITH ASDARS/AMDARS/ -C TAMDARS LAST) - AAID(1:NFILE) = ACID(1:NFILE) - SAAID(1:NFILE) = AAID(1:NFILE) - JARRAY(1:NFILE,1) = NINT(ALAT(1:NFILE)*100.) - JARRAY(1:NFILE,2) = NINT(ALON(1:NFILE)*100.) - JARRAY(1:NFILE,3) = NINT(AALT(1:NFILE)) - JARRAY(1:NFILE,4) = NINT(TIME(1:NFILE)) - JARRAY(1:NFILE,5) = NINT(ATMP(1:NFILE)) - JARRAY(1:NFILE,6) = NINT(ADIR(1:NFILE)) - JARRAY(1:NFILE,7) = NINT(ASPD(1:NFILE)) - JARRAY(1:NFILE,8) = INTP(1:NFILE) - JARRAY(1:NFILE,9) = IRTM(1:NFILE) - JARRAY(1:NFILE,10) = KNTINI(1:NFILE) - JARRAY(1:NFILE,11) = ITEVNT(1:NFILE) - JARRAY(1:NFILE,12) = IWEVNT(1:NFILE) - JARRAY(1:NFILE,13) = NINT(AALTF(1:NFILE)) - JARRAY(1:NFILE,14) = NINT(ADIRF(1:NFILE)) - JARRAY(1:NFILE,15) = NINT(ASPDF(1:NFILE)) - JARRAY(1:NFILE,16) = NINT(ATMPF(1:NFILE)) - KARRAY(1:NFILE,:) = JARRAY(1:NFILE,:) - CTAG(1:NFILE) = TAG(1:NFILE) - STAG(1:NFILE) = CTAG(1:NFILE) - NAIREP = NFILE - NASDAR - NEXCLD - PRINT 501, KOUNT,NASDAR,NAIREP,NEXCLD - 501 FORMAT(1X,128('*')/43X,'AIRCRAFT TRACK CHECK SORT - NCEP ', - $ 'WASHINGTON'/128('*')//' FILE KOUNT=',I6,' # AMDAR/ASDAR/', - $ 'TAMDAR=',I6,' # AIREP/PIREP=',I6,' # EXCLUDED=',I6) -CCCCC PRINT 502 -CC502 FORMAT(' LISTING OF IDSORTED DATA ENTERING TRKCHK----'/9X,'ACID', -cvvvvv a -Cxxxx$ 7X,' LAT WLON UTC ALT TEMP WDIR WSPD',6X, -CCCCC$ 8X,' LAT WLON UTC ALT TEMP WDIR WSPD',6X, -caaaaa a -CCCCC$ ' TAGS ',13X,'I.TYPE RCPT. TIME KNTINI'/) -CCCCC DO J = 1,KOUNT -CCCCC SARRY1 = 99999. -CCCCC IF(JARRAY(J,1).LT.99999) SARRY1 = JARRAY(J,1) * 0.01 -CCCCC SARRY2 = 99999. -CCCCC IF(JARRAY(J,2).LT.99999) SARRY2 = JARRAY(J,2) * 0.01 -CCCCC PRINT 331, J,AAID(J),SARRY1,SARRY2,JARRAY(J,4),JARRAY(J,3), -CCCCC$ JARRAY(J,5),JARRAY(J,6),JARRAY(J,7),CTAG(J),JARRAY(J,8), -CCCCC$ JARRAY(J,9),JARRAY(J,10) -CC ENDDO - PRINT 574 - 574 FORMAT(/' ----------------------------------') -C*********************************************************************** -C DETERMINE TRACK FOR EACH ASDAR/AMDAR/TAMDAR FLIGHT ID -C*********************************************************************** - PRINT 2521 - 2521 FORMAT(' ====> ASDAR/AMDAR/TAMDAR REPORTS CURRENTLY NOT TRACK ', - $ 'CHECKED'/) - PRINT 574 - NTRK = 0 - ITRK = NAIREP + 1 - 65 CONTINUE - IF(ITRK.LT.NFILE-NEXCLD) THEN - JTRK = ITRK + NTRK + 1 - IBEG = ITRK - IF(AAID(ITRK).EQ.AAID(JTRK)) THEN -C FLIGHT ID'S MATCH - RECORD STARTING POINT AS IBEG - NTRK = NTRK + 1 - GO TO 65 - ELSE -C END OF TRACK, STORE LAST INDEX - IEND = JTRK - 1 - ITRK = IEND + 1 - IF(NTRK.NE.0) NTRK = NTRK + 1 - LTRK = NTRK - END IF - IF(TRACE) PRINT 8810, ITRK,JTRK,NTRK,IBEG,IEND - 8810 FORMAT(' TRKEND- ITRK,JTRK,NTRK,IBEG,IEND ',5I5) -C TO GET REASONABLE GROUND SPEED CHECKS TAKE EVERY OTHER REPORT - DO LREP = 1,2 - LBEG = IBEG + (LREP - 1) - DO L = LBEG,IEND-2,2 - K = L - IBEG + 1 - IF(K.GT.ITMX) GO TO 9999 - IF(JARRAY(L,3).LT.8000) GO TO 221 - LOGTRK = (CTAG(L)(5:5).GE.'X'.AND.CTAG(L)(5:5).LE.'Z') - DELPOS(K) = 0.0 - DELLAT(K) = 0.0 - DELLON(K) = 0.0 - QCOS = COS((JARRAY(L,1)+JARRAY(L+2,1))*0.005*DG2RAD) - QDELT = IABS(JARRAY(L,4)-JARRAY(L+2,4)) * 0.01 - IF(QDELT.EQ.0.0) QDELT = 0.001 - DELLON(K) = IABS(JARRAY(L,2)-JARRAY(L+2,2)) * 0.01 - DELLON(K) = AMIN1(DELLON(K),360.-DELLON(K)) - DELLAT(K) = IABS(JARRAY(L,1)-JARRAY(L+2,1)) * 0.01 -C UNITS FOR POSTION DIFFERENCE- DEGREES - DELPOS(K) = SQRT(DELLAT(K)**2 + (DELLON(K)*QCOS)**2) - RDELT = 999. - IF(QDELT.GT.0.0) RDELT = 1./QDELT -C UNITS FOR APPARENT AVERAGE SPEED- KNOTS - AVESPD(K) = DELPOS(K) * RDELT * 65.3 -C LPOS25=T INDICATES UNREASONABLE GROUND SPEED FOR ASDAR/AMDAR/TAMDAR -C OBS. - LPOS25 = (AVESPD(K).LT.250..OR.AVESPD(K).GT.770.) - IF(LOGTRK.OR.LPOS25) THEN - PRINT 534, AAID(L),JARRAY(L,1),JARRAY(L,2),JARRAY(L,4), - $ JARRAY(L,3),JARRAY(L,5),JARRAY(L,6),JARRAY(L,7),CTAG(L), - $ DELPOS(K),AVESPD(K) - 534 FORMAT(' $$$$$ POSSIBLE ASDAR/AMDAR/TAMDAR ERROR: ',A8,6I7,I5, - $ ' "',A14,'"/ ',F7.1,F9.1) - IF(LOGTRK.AND.LPOS25.AND.CTAG(L)(14:14).GT.'3') THEN -CVVVVV%%%%% - PRINT *,'~~~~~ SEE BELOW: EVENT 307 ' -CAAAAA%%%%% - - IF(EWRITE) PRINT 9008, L,AAID(L),REAL(JARRAY(L,1))*.01, - $ REAL(JARRAY(L,2))*.01,REAL(JARRAY(L,4)),CTAG(L) - 9008 FORMAT(/' #EVENT 307: TRKCHK; ASDR QM X-Z & BAD G.SPD, WND QM F', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - CTAG(L)(4:4) = 'F' - STAG(L)(4:4) = 'F' - CTAG(L)(14:14) = '3' - STAG(L)(14:14) = '3' - JARRAY(L,12) = 307 - KARRAY(L,12) = 307 - END IF - END IF - 221 CONTINUE - ENDDO - ENDDO -C---------------------------------------------------------------------- - QSUM = 0.0 - IQNUM = 0 - QSUM1 = 0.0 - JQNUM = 0 - DO L = IBEG,IEND -C CALCULATE AVERAGE VECTOR INCREMENT FOR TRACK (QSUM) AMONGST THOSE OBS. -C WITH A SCALED INCREMENT CHARACTER Q-Z - IF(CTAG(L)(5:5).GE.'Q'.AND.CTAG(L)(5:5).LE.'Z') THEN - CTG = CTAG(L)(5:5) - SCALE = 95.0 - DO I=1,9 - IF(CTG.EQ.CH1(I)) THEN - SCALE = ICH1(I) - EXIT - END IF - ENDDO - IQNUM = IQNUM + 1 - QSUM = QSUM + SCALE - IF(CTAG(L)(5:5).GE.'V') THEN -C CALCULATE AVERAGE VECTOR INCREMENT FOR TRACK (QSUM1) AMONGST THOSE -C OBS. WITH SCALED INCREMENT > 50 KNOTS - JQNUM = JQNUM + 1 - QSUM1 = QSUM1 + SCALE - END IF - END IF - ENDDO - IF(IQNUM.GT.14) THEN - QSUM = QSUM/IQNUM -CVVVVV%%%%% - PRINT 5678, IBEG,IEND,IQNUM,QSUM+SIGN(.0005,QSUM) - 5678 FORMAT(' ~~~~~ FOR ASDAR/AMDAR/TAMDAR TRK BEG AT',I6,' AND ', - $ 'ENDING AT',I6,' THERE ARE',I4,' RPTS W/ INCR., MEAN IS',F7.1) -CAAAAA%%%%% - IF(JQNUM.GT.9) THEN - QSUM1 = QSUM1/JQNUM -CVVVVV%%%%% - PRINT 5679, JQNUM,QSUM1 - 5679 FORMAT(' ~~~~~ $$ A L S O FOR THIS ASDAR/AMDAR/TAMDAR TRK, ', - $ 'THERE ARE',I4,' RPTS W/ INCR. > 50 KNOTS, MEAN INCR. IS',F7.1) -CAAAAA%%%%% -C IF > 14 REPORTS IN TRACK AND AMONGST THESE > 9 HAVE VECTOR INCREMENT -C > 50 KNOTS, ASSUME ENTIRE FLIGHT IS BAD (FLAG ALL WINDS IN TRACK) - PRINT 574 -CVVVVV%%%%% - PRINT *,'~~~~~ SEE BELOW: LARGE TRACK INCR. IN ASDAR', - $ 'AMDAR/TAMDAR' -CAAAAA%%%%% - PRINT 520 - 520 FORMAT(' --> FOLLOWING TRACK HAS > 14 REPORTS WITH > 9 HAVING ', - $ 'WIND INCR. > 50 KTS, ALL WINDS FLAGGED!!'/) - DO L = IBEG,IEND - IF(CTAG(L)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 9027, L,AAID(L),REAL(JARRAY(L,1)) - $ *.01,REAL(JARRAY(L,2))*.01,REAL(JARRAY(L,4)),CTAG(L) - 9027 FORMAT(/' #EVENT 327: TRKCHK; ASDR TRK>14,>9 INCR>50KT,WND QM F', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - CTAG(L)(4:4) = 'F' - STAG(L)(4:4) = 'F' - CTAG(L)(14:14) = '3' - STAG(L)(14:14) = '3' - JARRAY(L,12) = 327 - KARRAY(L,12) = 327 - END IF - PRINT 9520, L,AAID(L),REAL(JARRAY(L,1))*.01, - $ REAL(JARRAY(L,2))*.01,REAL(JARRAY(L,4)),CTAG(L) - 9520 FORMAT(5X,I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - ENDDO - PRINT 574 - END IF - END IF -C---------------------------------------------------------------------- - NTRK = 0 - GO TO 65 - END IF - PRINT 574 -C*********************************************************************** -C DETERMINE TRACK FOR EACH NON-EXCLUDED AIREP/PIREP FLIGHT ID -C*********************************************************************** - PRINT 2520 - 2520 FORMAT(' ====> BEGIN TRACK CHECKING OF AIREP/PIREP REPORTS'/) - PRINT 574 - NTRK = 0 - ITRK = 1 - 66 CONTINUE - IF(ITRK.LT.NAIREP) THEN - JTRK = ITRK + NTRK + 1 - IBEG = ITRK - IF(AAID(ITRK).EQ.AAID(JTRK)) THEN -C FLIGHT ID'S MATCH - RECORD STARTING POINT AS IBEG - NTRK = NTRK + 1 - GO TO 66 - ELSE -C END OF TRACK, STORE LAST INDEX - IEND = JTRK - 1 - IF(IEND-IBEG.GT.ITMX) GO TO 9999 - ITRK = IEND + 1 - IF(NTRK.NE.0) NTRK = NTRK + 1 - LTRK = NTRK - END IF - IF(TRACE) PRINT 8810,ITRK,JTRK,NTRK,IBEG,IEND -C INITITIALIZE VARIABLES - LOGTRK = .FALSE. - LOGTME = .FALSE. - LOGLT1 = .FALSE. - LPOS25 = .FALSE. - DUP = .FALSE. - TOSLIM = 'S' - NAPTS = 0 - NPTRS = 0 - NTYPS = 0 - NTRKP = 0 - TYPE = ' ' -C----------------------------------------------------------------------- -C CHECK PAIRS -- LTRK = 2 -C----------------------------------------------------------------------- - IF(LTRK.EQ.2) THEN - II = IBEG - IF(AAID(II)(4:4).EQ.' '.OR.AAID(II)(1:4).EQ.'AIRC'.OR. - $ AAID(II)(1:5).EQ.'COA16'.OR.AAID(II)(1:7).EQ.'UNKNOWN')THEN -C CERTAIN RPTS (E.G, 3 CHAR ID,"AIRCFT", "UNKNOWN") ARE NOT CONSIDERED -C FOR THE TRACK CHECK - PRINT 8866, ITRK,LTRK,IBEG,IEND,AAID(II) - 8866 FORMAT(' SKIP IN TRKCHK ',4I5,2X,' ACID ',A8) - NTRK = 0 - GO TO 66 - END IF - LOGLAT = (JARRAY(II,1).EQ.JARRAY(II+1,1)) - LOGLON = (JARRAY(II,2).EQ.JARRAY(II+1,2)) - LOGALT = (JARRAY(II,3).EQ.JARRAY(II+1,3)) - LOGTMP = (JARRAY(II,5).EQ.JARRAY(II+1,5)) - LOGWND = ((JARRAY(II,6).EQ.JARRAY(II+1,6)).AND. - $ (JARRAY(II,7).EQ.JARRAY(II+1,7))) - QCOS = COS((JARRAY(II,1)+JARRAY(II+1,1))*0.005*DG2RAD) - QDELT = IABS(JARRAY(II,4)-JARRAY(II+1,4))*0.01 - LOGTME = (QDELT.LT.0.04) - DELPOS(1) = SQRT(((JARRAY(II,1)-JARRAY(II+1,1))*0.01)**2+ - $ ((JARRAY(II,2)-JARRAY(II+1,2))*QCOS*0.01)**2) - RDELT = 999. - AVESPD(1) = -9999.9 - IF(QDELT.GT.0.0) THEN - RDELT = 1./QDELT - AVESPD(1) = DELPOS(1) * RDELT * 65.3 - END IF - IF(QDELT.GT.4.0.AND.DELPOS(1).GT.40.) THEN - PRINT 301, IBEG,AAID(IBEG),JARRAY(IBEG,1),JARRAY(IBEG,2), - $ JARRAY(IBEG,4),JARRAY(IBEG,3),JARRAY(IBEG,5),JARRAY(IBEG,6), - $ JARRAY(IBEG,7),CTAG(IBEG),DELPOS(1),AVESPD(1) - PRINT 301, IEND,AAID(IEND),JARRAY(IEND,1),JARRAY(IEND,2), - $ JARRAY(IEND,4),JARRAY(IEND,3),JARRAY(IEND,5),JARRAY(IEND,6), - $ JARRAY(IEND,7),CTAG(IEND) - 301 FORMAT(' PROB 2 FLIGHTS',I5,2X,A8,6I8,2X,I3,3X,'"',A14,'"',3X, - $ 2F8.1) - END IF -C UNITS FOR APPARENT AVERAGE SPEED- KNOTS - LOGTRK = (DELPOS(1).GT.15.0.AND.AVESPD(1).GT.770.) -C CALIBRATION CONSTANTS <2.0 DEGREES FOR SEPARATION ADJACENT REPORTS -C CALIBRATION CONSTANTS >25.0 DEGREES FOR SEPARATION ADJACENT REPORTS - IF(DELPOS(1).LE.2.0) THEN - LOGLT1 = .TRUE. - ELSE IF(DELPOS(1).GE.25.) THEN - LPOS25 = .TRUE. - CALL WAYPT(IBEG,IEND,NCHNGD) - IF(NCHNGD.GT.0) THEN -CVVVVV%%%%% - PRINT *,'~~~~~ WAYPT(1) ERROR FOR PAIR IN TRACK CHECK' -CAAAAA%%%%% - PRINT *, 'WAYPOINT(1) HAS CHANGED REPORT LOCATION' - DELPOS(1) = SQRT(((JARRAY(II,1)-JARRAY(II+1,1))*0.01)**2+ - $ ((JARRAY(II,2)-JARRAY(II+1,2))*QCOS*0.01)**2) - IF(DELPOS(1).LE.2.0) THEN - LPOS25 = .FALSE. - LOGLT1 = .TRUE. - END IF - END IF - END IF -C TIMES MATCH -CCCCC PRINT 223, IBEG,IEND,DELPOS(1),AVESPD(1),LOGTRK -CC223 FORMAT(' NTRK=2 DBG',2(I5,1X),2(1X,F8.1),1X,L1) - IF(CTAG(II)(5:5).EQ.'N'.OR.CTAG(II+1)(5:5).EQ.'N') GO TO 812 - IF(LOGLT1.AND.LOGALT.AND.LOGWND) THEN -C TYPE IS DUPLICATE, PLACE 'D' IN POSITION 1 OF TAG - KTYPS(1) = KTYPS(1) + 1 - NTYPS = NTYPS + 1 - IF(NTYPS.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE DUPLICATE TYPES IN THIS TRACK THAN THE -C LIMIT "ITRKL" -- STOP 29 - PRINT 52, ITRKL - 52 FORMAT(/' THERE ARE MORE THAN',I5,' DUPLICATE TYPES IN THIS ', - $ 'TRACK -- MUST INCREASE SIZE OF PARAMETER NAME "ITRKL" - STOP ', - $ '29'/) - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(29) -C....................................................................... - END IF - TYPE(NTYPS) = 'TYPE 1A ' - DUP = .TRUE. - CALL CHOOSE(II,II+1,TOSLIM,DUP,IWHICH,MAYBE,NEW) - IF(IWHICH.GT.0.AND.CTAG(IWHICH)(14:14).GT.'0') THEN - IF(EWRITE) PRINT 9009, IWHICH,AAID(IWHICH), - $ REAL(JARRAY(IWHICH,1))*.01,REAL(JARRAY(IWHICH,2))*.01, - $ REAL(JARRAY(IWHICH,4)),CTAG(IWHICH) - 9009 FORMAT(/' #EVENT ###: TRKCHK; NTRK=2 TYPE 1A DUP, WND QM SET "D"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - CTAG(IWHICH)(1:1) = 'D' - CTAG(IWHICH)(13:13) = '0' - CTAG(IWHICH)(14:14) = '0' - END IF - PRINT 673, IBEG,IEND,CTAG(IBEG),CTAG(IEND) - 673 FORMAT(' NTRK=2 TYPE 1A DUP',2(I5,1X),1X,'"',A14,'"/"',A14,'"') -C TYPE IS NOT A STRICT DUPLICATE, PLACE 'F' IN POSITION 4 OF Q.M. WORD - ELSE IF(LOGLAT.AND.LOGLON) THEN - KTYPS(5) = KTYPS(5) + 1 - NTYPS = NTYPS + 1 - IF(NTYPS.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE DUPLICATE TYPES IN THIS TRACK THAN THE -C LIMIT "ITRKL" -- STOP 29 - PRINT 52, ITRKL - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(29) -C....................................................................... - END IF - TYPE(NTYPS) = 'TYPE 2A ' - DUP = .TRUE. - CALL CHOOSE(II,II+1,TOSLIM,DUP,IWHICH,MAYBE,NEW) - IF(IWHICH.GT.0.AND.CTAG(IWHICH)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 9010, IWHICH,AAID(IWHICH), - $ REAL(JARRAY(IWHICH,1))*.01,REAL(JARRAY(IWHICH,2))*.01, - $ REAL(JARRAY(IWHICH,4)),CTAG(IWHICH) - 9010 FORMAT(/' #EVENT 308: TRKCHK; NTRK=2 TYPE 2A DUP, WND QM SET "F"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - CTAG(IWHICH)(4:4) = 'F' - CTAG(IWHICH)(14:14) = '3' - JARRAY(IWHICH,12) = 308 - END IF - PRINT 373, IBEG,IEND,CTAG(IBEG),CTAG(IEND) - 373 FORMAT(' NTRK=2 TYPE 2 DUP',2(I5,1X),1X,'"',A14,'"/"',A14,'"') - ELSE IF(LOGTME.AND.(LOGTMP.OR.LOGALT).AND.LOGWND) THEN - KTYPS(2) = KTYPS(2) + 1 - NTYPS = NTYPS + 1 - IF(NTYPS.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE DUPLICATE TYPES IN THIS TRACK THAN THE -C LIMIT "ITRKL" -- STOP 29 - PRINT 52, ITRKL - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(29) -C....................................................................... - END IF - TYPE(NTYPS) = 'TYPE 1B ' - DUP = .TRUE. - CALL CHOOSE(II,II+1,TOSLIM,DUP,IWHICH,MAYBE,NEW) - IF(IWHICH.GT.0.AND.CTAG(IWHICH)(14:14).GT.'0') THEN - IF(EWRITE) PRINT 9011, IWHICH,AAID(IWHICH), - $ REAL(JARRAY(IWHICH,1))*.01,REAL(JARRAY(IWHICH,2))*.01, - $ REAL(JARRAY(IWHICH,4)),CTAG(IWHICH) - 9011 FORMAT(/' #EVENT ###: TRKCHK; NTRK=2 TYPE 1B DUP, WND QM SET "D"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - CTAG(IWHICH)(1:1) = 'D' - CTAG(IWHICH)(13:13) = '0' - CTAG(IWHICH)(14:14) = '0' - END IF - END IF -C CHECK FOR DELPOS AND LOGTRK - IF(LPOS25.AND.LOGWND.AND.LOGALT.AND.(LOGTMP.OR.LOGTME))THEN - CALL WAYPT(IBEG,IEND,NCHNGD) - IF(NCHNGD.GT.0) THEN -CVVVVV%%%%% - PRINT *,'~~~~~ WAYPT(2) ERROR FOR PAIR IN TRACK CHECK' -CAAAAA%%%%% - PRINT *, 'WAYPOINT(2) HAS CHANGED REPORT LOCATION' - KTYPS(6) = KTYPS(6) + 1 -CSKIP NTYPS = NTYPS + 1 - IF(NTYPS.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE DUPLICATE TYPES IN THIS TRACK THAN THE -C LIMIT "ITRKL" -- STOP 29 - PRINT 52, ITRKL - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(29) -C....................................................................... - END IF - TYPE(NTYPS) = 'TYPE 2B ' - END IF - DELPOS(1) = SQRT(((JARRAY(II,1)-JARRAY(II+1,1))*0.01)**2 - $ +((JARRAY(II,2)-JARRAY(II+1,2))*QCOS*0.01)**2) - IF(DELPOS(1).LE.2.0) THEN - LOGLT1 = .TRUE. - ELSE IF(DELPOS(1).GE.15.) THEN - LPOS25 = .TRUE. - END IF - IF(LPOS25) THEN - LOGTRK = .TRUE. - DUP = .FALSE. - CALL CHOOSE(II,II+1,TOSLIM,DUP,IWHICH,MAYBE,NEW) - IF(NEW) THEN - KTYPS(7) = KTYPS(7) + 1 - NTYPS = NTYPS + 1 - IF(NTYPS.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE DUPLICATE TYPES IN THIS TRACK THAN THE -C LIMIT "ITRKL" -- STOP 29 - PRINT 52, ITRKL - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(29) -C....................................................................... - END IF - TYPE(NTYPS) = 'TYPE 3 ' - IF(IWHICH.GT.0) THEN - IF(CTAG(IWHICH)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 9012, IWHICH,AAID(IWHICH), - $ REAL(JARRAY(IWHICH,1))*.01,REAL(JARRAY(IWHICH,2))*.01, - $ REAL(JARRAY(IWHICH,4)),CTAG(IWHICH) - 9012 FORMAT(/' #EVENT 309: TRKCHK; NTRK=2 TYPE 3 , WND QM SET "F"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - CTAG(IWHICH)(4:4) = 'F' - CTAG(IWHICH)(14:14) = '3' - JARRAY(IWHICH,12) = 309 - END IF - ELSEIF(MAYBE.GT.0.AND.CTAG(MAYBE)(14:14).GT.'3')THEN - IF(EWRITE) PRINT 9012, MAYBE,AAID(MAYBE), - $ REAL(JARRAY(MAYBE,1))*.01,REAL(JARRAY(MAYBE,2))*.01, - $ REAL(JARRAY(MAYBE,4)),CTAG(MAYBE) - CTAG(MAYBE)(4:4) = 'F' - CTAG(MAYBE)(14:14) = '3' - JARRAY(MAYBE,12) = 309 - END IF - END IF - END IF - PRINT 433, IBEG,IEND,DELPOS(1),CTAG(IBEG),CTAG(IEND) - 433 FORMAT(' NTRK=2 ERR',2(I5,1X),F5.1,1X,'"',A14,'"/"',A14,'"') - END IF - IF(LOGTRK) THEN - TOSLIM = 'U' - DUP = .FALSE. - CALL CHOOSE(II,II+1,TOSLIM,DUP,IWHICH,MAYBE,NEW) - IF(NEW) THEN - KTYPS(7) = KTYPS(7) + 1 - NTYPS = NTYPS + 1 - IF(NTYPS.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE DUPLICATE TYPES IN THIS TRACK THAN THE -C LIMIT "ITRKL" -- STOP 29 - PRINT 52, ITRKL - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(29) -C....................................................................... - END IF - TYPE(NTYPS) = 'TYPE 3 ' - IF(IWHICH.GT.0) THEN - IF(CTAG(IWHICH)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 9012, IWHICH,AAID(IWHICH), - $ REAL(JARRAY(IWHICH,1))*.01,REAL(JARRAY(IWHICH,2))*.01, - $ REAL(JARRAY(IWHICH,4)),CTAG(IWHICH) - CTAG(IWHICH)(4:4) = 'F' - CTAG(IWHICH)(14:14) = '3' - JARRAY(IWHICH,12) = 309 - END IF - ELSE IF(MAYBE.GT.0.AND.CTAG(MAYBE)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 9012, MAYBE,AAID(MAYBE), - $ REAL(JARRAY(MAYBE,1))*.01,REAL(JARRAY(MAYBE,2))*.01, - $ REAL(JARRAY(MAYBE,4)),CTAG(MAYBE) - CTAG(MAYBE)(4:4) = 'F' - CTAG(MAYBE)(14:14) = '3' - JARRAY(MAYBE,12) = 309 - END IF - END IF - END IF - IF(LPOS25.OR.LOGTME.OR.LOGWND.OR.LOGTRK.OR.DUP) THEN - PRINT 302, IBEG, AAID(IBEG),JARRAY(IBEG,1),JARRAY(IBEG,2), - $ JARRAY(IBEG,4),JARRAY(IBEG,3),JARRAY(IBEG,5),JARRAY(IBEG,6), - $ JARRAY(IBEG,7),CTAG(IBEG),DELPOS(1),AVESPD(1) - PRINT 302, IEND, AAID(IEND),JARRAY(IEND,1),JARRAY(IEND,2), - $ JARRAY(IEND,4),JARRAY(IEND,3),JARRAY(IEND,5),JARRAY(IEND,6), - $ JARRAY(IEND,7),CTAG(IEND) - 302 FORMAT(' ',I5,2X,A8,6I8,2X,I3,3X,'"',A14,'"',3X,2F8.1) - PRINT 300, TYPE(1) - 300 FORMAT(' TYPE ',A8) - PRINT 634 - END IF - 812 CONTINUE -C----------------------------------------------------------------------- -C ELSE LOOK AT SEQUENCE FOR LTRK GT 2 -C----------------------------------------------------------------------- - ELSE IF(LTRK.GT.2) THEN - LUTCEQ = .FALSE. - LLATEQ = .FALSE. - LLONEQ = .FALSE. - LVAREQ = .FALSE. - LOGTRK = .FALSE. - NCHNGD = 0 -C PRELIMINARY LOOP TO CHECK FOR POSSIBLE TWO FLIGHTS AND WAYPOINT -C ERRORS - CHECK ADJACENT REPORTS IN LONGITUDE SORT - CALCULATE -C DIFFERENCES IN VARIABLES AND COMPUTE AVERAGE SPEED -C NO POINTERS SET: COUNTER ON TIME INTERVALS SET - DTKNT = 0 - DO L = IBEG,IEND-1 - IF(AAID(L)(4:4).EQ.' '.OR.AAID(L)(1:4).EQ.'AIRC'.OR. - $ AAID(L)(1:5).EQ.'COA16'.OR.AAID(L)(1:7).EQ.'UNKNOWN')THEN -C CERTAIN RPTS (E.G, 3 CHAR ID,"AIRCFT", "UNKNOWN") ARE NOT CONSIDERED -C FOR THE TRACK CHECK - PRINT 8866, ITRK,LTRK,IBEG,IEND,AAID(L) - NTRK = 0 - GO TO 66 - END IF - K = L - IBEG + 1 - DELPOS(K) = 0.0 - DELLAT(K) = 0.0 - DELLON(K) = 0.0 - QCOS = COS((JARRAY(L,1)+JARRAY(L+1,1))*0.005 *DG2RAD) - QDELT = IABS(JARRAY(L,4)-JARRAY(L+1,4))*0.01 -C ADJUSTABLE CONSTANT FOR TIME DIFF BETWEEN SUCCESSIVE REPORTS = 2.5 HRS - IF(QDELT.GT.2.5) DTKNT = DTKNT + 1 - DELLON(K) = IABS(JARRAY(L,2)-JARRAY(L+1,2)) * 0.01 - DELLON(K) = AMIN1(DELLON(K),360.-DELLON(K)) - DELLAT(K) = IABS(JARRAY(L,1)-JARRAY(L+1,1)) * 0.01 -C UNITS FOR POSTION DIFFERENCE- DEGREES - DELPOS(K) = SQRT(DELLAT(K)**2 + (DELLON(K)*QCOS)**2) - RDELT = 999. - IF(QDELT.GT.0.0) RDELT = 1./QDELT -C UNITS FOR APPARENT AVERAGE SPEED- KNOTS - AVESPD(K) = DELPOS(K) * RDELT * 65.3 - IF(DELLON(K).GT.11.0.AND.AVESPD(K).GT.770..AND.K.EQ.1) - $ PRINT 510, K,DELLON(K),AVESPD(K) - 510 FORMAT(' $$$$$POSSIBLE CORRECTABLE ERROR IN LON ',I3,2F8.1) - IF(DELLON(K).GT.15..AND.AVESPD(K).GT.770.) LOGTRK=.TRUE. - ENDDO - DELPOS(LTRK) = -9999.9 - AVESPD(LTRK) = -9999.9 - IF(LOGTRK) THEN - CALL WAYPT(IBEG,IEND,NCHNGD) - PRINT 544, IBEG,IEND - 544 FORMAT(' WAYPOINT(3) CALL AT ',2I6) - END IF - IF(DTKNT.GT.0) PRINT 669, IBEG,IEND,DTKNT - 669 FORMAT(' POSSIBLE TWO FLIGHTS AT ',2I5,' DTKNT ',I3) -C POSSIBLE TWO OR MORE FLIGHTS IN AIR DURING SIX-HOUR TIME BLOCK - IF(DTKNT.GT.1.OR.NCHNGD.GT.0) THEN - IF(NCHNGD.GT.0) - $ PRINT *, 'WAYPOINT(3) HAS CHANGED REPORT LOCATION' -CVVVVV%%%%% - IF(NCHNGD.GT.0) - $ PRINT *,'~~~~~ WAYPT(3) ERROR FOR .GT. 2 IN TRACK CHECK' -CAAAAA%%%%% - PRINT 4442, ITRK,JTRK,IBEG,IEND,DTKNT,NCHNGD - 4442 FORMAT(' ITRK',I5,' JTRK ',I5,' IBEG,IEND ',2I6, - $ ' DTKNT ',I3,' NCHNGD ',I2) - DO I = 1,LTRK - K = IBEG + I - 1 - IARRAY(I) = KARRAY(K,4) -CCCCC PRINT 387, LTRK,I,K,SAAID(K),IARRAY(I) -CC387 FORMAT(' DBG ',3I6,2X,'; ID=',A8,'; TIME=',I8) - ENDDO - IF(LTRK.GT.0) CALL INDEXF(LTRK,IARRAY,INDR) - DO J = 1,LTRK - K = IBEG - 1 + J - L = IBEG - 1 + INDR(J) - AAID(K) = SAAID(L) - CTAG(K) = STAG(L) - JARRAY(K,:) = KARRAY(L,:) -CCCCC PRINT 388, J,K,L,AAID(K),JARRAY(K,4) -CC388 FORMAT(' DBG J K L ',3I6,2X,'; ID=',A8,'; TIME=',I8) - ENDDO - DTKNT = 0 - DO L = IBEG,IEND-1 - K = L - IBEG + 1 - DELPOS(K) = 0.0 - DELLAT(K) = 0.0 - DELLON(K) = 0.0 - QCOS = COS((JARRAY(L,1)+JARRAY(L+1,1))*0.005 *DG2RAD) - QDELT = IABS(JARRAY(L,4)-JARRAY(L+1,4))*0.01 -C ADJUSTABLE CONSTANT FOR TIME DIFF BETWEEN SUCCESSIVE REPORTS = 2.5 HRS - IF(QDELT.GT.2.5) DTKNT = DTKNT + 1 - DELLON(K) = IABS(JARRAY(L,2)-JARRAY(L+1,2)) * 0.01 - DELLON(K) = AMIN1(DELLON(K),360.-DELLON(K)) - DELLAT(K) = IABS(JARRAY(L,1)-JARRAY(L+1,1)) * 0.01 -C UNITS FOR POSTION DIFFERENCE- DEGREES - DELPOS(K) = SQRT(DELLAT(K)**2 + (DELLON(K)*QCOS)**2) - RDELT = 999. - IF(QDELT.GT.0.0) RDELT = 1./QDELT -C UNITS FOR APPARENT AVERAGE SPEED- KNOTS - AVESPD(K) = DELPOS(K) * RDELT * 65.3 - IF(DELLON(K).GT.15..AND.AVESPD(K).GT.770.)LOGTRK=.TRUE. - ENDDO - DELPOS(LTRK) = -9999.9 - AVESPD(LTRK) = -9999.9 - END IF - TYPE = ' ' - JPTNAD = 0 - IPTNAD = 0 - IPTTRK = 0 -C FIND POINTERS FOR NON-ADJACENT REPORTS - IF(TRACE) PRINT 8888,LTRK,IBEG,IEND - 8888 FORMAT(' TRACE AT 211 ',3(1X,I6)) - DO L = IBEG,IEND-2 ! Formerly DO LOOP 211 - DO M = L+2,IEND - IF(JARRAY(L,4).EQ.JARRAY(M,4)) LUTCEQ = .TRUE. - IF(JARRAY(L,1).EQ.JARRAY(M,1)) LLATEQ = .TRUE. - IF(JARRAY(L,2).EQ.JARRAY(M,2)) LLONEQ = .TRUE. - IF((JARRAY(L,5).EQ.JARRAY(M,5)).AND.(JARRAY(L,6).EQ.JARRAY(M,6)) - $ .AND.(JARRAY(L,7).EQ.JARRAY(M,7)).AND.(JARRAY(L,4).EQ. - $ JARRAY(M,4)).AND.(JARRAY(L,3).EQ.JARRAY(M,3))) THEN - LVAREQ = .TRUE. - NPTRS = NPTRS + 1 - IF(NPTRS.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE POINTERS FOR NON-ADJACENT REPORTS IN THIS -C TRACK THAN THE LIMIT "ITRKL" -- STOP 28 - PRINT 51, ITRKL - 51 FORMAT(/' THERE ARE MORE THAN',I5,' POINTERS FOR NON-ADJACENT ', - $ 'REPORTS IN THIS TRACK -- MUST INCREASE SIZE OF PARAMETER NAME ', - $ '"ITRKL" - STOP 28'/) - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(28) -C....................................................................... - END IF - IPTNAD(NPTRS) = L - JPTNAD(NPTRS) = M - IF(TRACE) PRINT 756, LLATEQ,LLONEQ,LVAREQ, - $ IPTNAD(NPTRS),JPTNAD(NPTRS) - 756 FORMAT('DBUG- NONADJ LOGICALS ',3(L1,1X),3X,'POINTERS ',2X,2I8) - END IF - ENDDO - ENDDO - IF(NPTRS.EQ.1) THEN - I1 = IPTNAD(1) - I2 = JPTNAD(1) - DUP = .TRUE. - CALL CHOOSE(I1,I2,TOSLIM,DUP,IWHICH,MAYBE,NEW) - IF(IWHICH.GT.0.AND.CTAG(IWHICH)(14:14).GT.'0') THEN - IF(EWRITE) PRINT 9013, IWHICH,AAID(IWHICH), - $ REAL(JARRAY(IWHICH,1))*.01,REAL(JARRAY(IWHICH,2))*.01, - $ REAL(JARRAY(IWHICH,4)),CTAG(IWHICH) - 9013 FORMAT(/' #EVENT ###: TRKCHK; NTRK>2 TYPE 1D DUP, WND QM SET "D"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - CTAG(IWHICH)(1:1) = 'D' - CTAG(IWHICH)(13:13) = '0' - CTAG(IWHICH)(14:14) = '0' - END IF - NTYPS = NTYPS + 1 - IF(NTYPS.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE DUPLICATE TYPES IN THIS TRACK THAN THE -C LIMIT "ITRKL" -- STOP 29 - PRINT 52, ITRKL - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(29) -C....................................................................... - END IF - TYPE(NTYPS) = 'TYPE 1D ' - KTYPS(4) = KTYPS(4) + 1 - END IF - IF(NPTRS.GT.1) PRINT 719, NPTRS - 719 FORMAT(' WARNING, NPTRS = ',I4) - IF(TRACE) PRINT 8889, LTRK,IBEG,IEND - 8889 FORMAT(' TRACE AT 213 ',3(1X,I6)) - IPTADJ = 0 - NPRNT = 0 -C BIG LOOP TO FIND BADDIES - IF(TRACE) PRINT 8890, LTRK,IBEG,IEND - 8890 FORMAT(' TRACE AT 216 ',3(1X,I6)) - DO L = IBEG,IEND-1 ! Formerly DO LOOP 216 - K = L - IBEG + 1 - LOGTRK = .FALSE. - TOSLIM = 'S' -C THIS IS A LIST OF NON-UNIQUE IDS - IF(AAID(L)(1:5).EQ.'AIRCF') GO TO 216 - DQLAT = ABS(JARRAY(L,1) - JARRAY(L+1,1)) - LOGLAT = (DQLAT.LT..03) - DQLON = ABS(JARRAY(L,2) - JARRAY(L+1,2)) - LOGLON = (DQLON.LT..03) - LOGALT = (JARRAY(L,3).EQ.JARRAY(L+1,3)) - LOGTMP = (JARRAY(L,5).GT.999.OR.JARRAY(L+1,5).GT.999 - $ .OR.JARRAY(L,5).EQ.JARRAY(L+1,5)) - LOGWND = ((JARRAY(L,6).EQ.JARRAY(L+1,6)).AND. - $ (JARRAY(L,7).EQ.JARRAY(L+1,7))) - QDELT = IABS(JARRAY(L,4)-JARRAY(L+1,4))*0.01 - LOGTME = (QDELT.LT.0.20.AND.AVESPD(K).GT.770.) - LOGGT3 = (QDELT.GT.3.01) - LOGLT1 = (DELPOS(K).LE.1.1) - LOGLO = (JARRAY(L,3).LT.8000) - LOGHI = (JARRAY(L,3).GT.13411) - LOGEQ = 0 - IF(LOGTMP) LOGEQ = LOGEQ + 1 - IF(LOGTME) LOGEQ = LOGEQ + 1 - IF(LOGALT) LOGEQ = LOGEQ + 1 - IF(.NOT.LOGLO.AND..NOT.LOGHI) THEN -C ADJUSTABLE CONSTANTS FOR AIRCRAFT GROUND SPEED LIMITS - IF(AVESPD(K).GT.770.0.OR.AVESPD(K).LT.200.0) THEN - NAPTS = NAPTS + 1 - IF(NAPTS.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE REPORTS WITH ADJUSTABLE CONSTANTS FOR -C AIRCRAFT GROUND SPEED LIMITS IN THIS TRACK THAN THE LIMIT "ITRKL" -- -C STOP 27 - PRINT 50, ITRKL - 50 FORMAT(/' THERE ARE MORE THAN',I5,' REPORTS WITH ADJUSTABLE ', - $ 'CONSTANTS FOR AIRCRAFT GROUND SPEED LIMITS IN THIS TRACK -- ', - $ 'MUST INCREASE SIZE OF PARAMETER NAME "ITRKL" - STOP 27'/) - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(27) -C....................................................................... - END IF - IPTADJ(NAPTS) = L - LOGTRK = .TRUE. - END IF - ELSE IF(LOGHI) THEN - IF(AVESPD(K).GT.1450.0.OR.AVESPD(K).LT.500.0) THEN - NAPTS = NAPTS + 1 - IF(NAPTS.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE REPORTS WITH ADJUSTABLE CONSTANTS FOR -C AIRCRAFT GROUND SPEED LIMITS IN THIS TRACK THAN THE LIMIT "ITRKL" -- -C STOP 27 - PRINT 50, ITRKL - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(27) -C....................................................................... - END IF - IPTADJ(NAPTS) = L - LOGTRK = .TRUE. - END IF - END IF -C START DECISION MAKING -C TUNING HERE- CHECK INCREMENT .GE. 'T' AS BAD - IF(LOGLT1.AND.LOGWND.AND.LOGEQ.GE.2) THEN -C CLASS 1 (SIMPLE) DUPLICATE, PLACE 'D' IN POSITION 1 OF TAG - DUP = .TRUE. - CALL CHOOSE(L,L+1,TOSLIM,DUP,IWHICH,MAYBE,NEW) - IF(IWHICH.GT.0.AND.CTAG(IWHICH)(14:14).GT.'0') THEN - IF(EWRITE) PRINT 9014, IWHICH,AAID(IWHICH), - $ REAL(JARRAY(IWHICH,1))*.01,REAL(JARRAY(IWHICH,2))*.01, - $ REAL(JARRAY(IWHICH,4)),CTAG(IWHICH) - 9014 FORMAT(/' #EVENT ###: TRKCHK; NTRK>2 TYPE 1A DUP, WND QM SET "D"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - CTAG(IWHICH)(1:1) = 'D' - CTAG(IWHICH)(13:13) = '0' - CTAG(IWHICH)(14:14) = '0' - END IF - IF(NEW) THEN - PRINT 721, IWHICH,MAYBE - 721 FORMAT(' 1A- IWHICH,MAYBE ',2I5) - KTYPS(1) = KTYPS(1) + 1 - NTYPS = NTYPS + 1 - IF(NTYPS.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE DUPLICATE TYPES IN THIS TRACK THAN THE -C LIMIT "ITRKL" -- STOP 29 - PRINT 52, ITRKL - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(29) -C....................................................................... - END IF - TYPE(NTYPS) = 'TYPE 1A ' - END IF - ELSE IF(LOGWND.AND.LOGALT.AND.LOGTMP.AND.LOGTME) THEN -C COME HERE IF NOT A STRICT DUPLICATE -- POSSIBLE POSITION ERROR - CTAG(L)(3:3) = 'E' - CTAG(L+1)(3:3) = 'E' - DUP = .TRUE. - CALL CHOOSE(L,L+1,TOSLIM,DUP,IWHICH,MAYBE,NEW) - IF(IWHICH.GT.0.AND.CTAG(IWHICH)(14:14).GT.'0') THEN - IF(EWRITE) PRINT 9015, IWHICH,AAID(IWHICH), - $ REAL(JARRAY(IWHICH,1))*.01,REAL(JARRAY(IWHICH,2))*.01, - $ REAL(JARRAY(IWHICH,4)),CTAG(IWHICH) - 9015 FORMAT(/' #EVENT ###: TRKCHK; NTRK>2 TYPE 1B DUP, WND QM SET "D"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - CTAG(IWHICH)(1:1) = 'D' - CTAG(IWHICH)(13:13) = '0' - CTAG(IWHICH)(14:14) = '0' - END IF - IF(NEW) THEN - PRINT 722, IWHICH,MAYBE - 722 FORMAT(' 1B- IWHICH,MAYBE ',2I5) - KTYPS(2) = KTYPS(2) + 1 - NTYPS = NTYPS + 1 - IF(NTYPS.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE DUPLICATE TYPES IN THIS TRACK THAN THE -C LIMIT "ITRKL" -- STOP 29 - PRINT 52, ITRKL - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(29) -C....................................................................... - END IF - TYPE(NTYPS) = 'TYPE 1B ' - END IF - ELSE IF(LOGTME.AND..NOT.LOGLT1.AND..NOT.LOGWND.AND. - $ .NOT.LOGTRK) THEN - DUP = .FALSE. - TOSLIM = 'V' - CALL CHOOSE(L,L+1,TOSLIM,DUP,IWHICH,MAYBE,NEW) - IF(NTYPS+1.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE DUPLICATE TYPES IN THIS TRACK THAN THE -C LIMIT "ITRKL" -- STOP 29 - PRINT 52, ITRKL - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(29) -C....................................................................... - END IF - IF(IWHICH.GT.0) THEN - IF(CTAG(IWHICH)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 9016, IWHICH,AAID(IWHICH), - $ REAL(JARRAY(IWHICH,1))*.01,REAL(JARRAY(IWHICH,2))*.01, - $ REAL(JARRAY(IWHICH,4)),CTAG(IWHICH) - 9016 FORMAT(/' #EVENT 310: TRKCHK; NTRK>2 TYPE 3 , WND QM SET "F"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - CTAG(IWHICH)(4:4) = 'F' - CTAG(IWHICH)(14:14) = '3' - JARRAY(IWHICH,12) = 310 - END IF - KTYPS(7) = KTYPS(7) + 1 - NTYPS = NTYPS + 1 - TYPE(NTYPS) = 'TYPE 3 ' - ELSE - KTYPS(9) = KTYPS(9) + 1 - NTYPS = NTYPS + 1 - TYPE(NTYPS) = 'TIME TAG' - END IF - ELSE IF(LOGTME.AND.LOGALT.AND.LOGWND.AND.(LOGLAT.OR.LOGLON))THEN - CTAG(L)(3:3) = 'E' - CTAG(L+1)(3:3) = 'E' - DUP = .TRUE. - CALL CHOOSE(L,L+1,TOSLIM,DUP,IWHICH,MAYBE,NEW) - IF(IWHICH.GT.0.AND.CTAG(IWHICH)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 9017, IWHICH,AAID(IWHICH), - $ REAL(JARRAY(IWHICH,1))*.01,REAL(JARRAY(IWHICH,2))*.01, - $ REAL(JARRAY(IWHICH,4)),CTAG(IWHICH) - 9017 FORMAT(/' #EVENT 311: TRKCHK; NTRK>2 TYPE 2B DUP, WND QM SET "F"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - CTAG(IWHICH)(4:4) = 'F' - CTAG(IWHICH)(14:14) = '3' - JARRAY(IWHICH,12) = 311 - END IF - IF(NEW) THEN - PRINT 723, IWHICH,MAYBE - 723 FORMAT(' 2B- IWHICH,MAYBE ',2I5) - KTYPS(6) = KTYPS(6) + 1 - NTYPS = NTYPS + 1 - IF(NTYPS.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE DUPLICATE TYPES IN THIS TRACK THAN THE -C LIMIT "ITRKL" -- STOP 29 - PRINT 52, ITRKL - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(29) -C....................................................................... - END IF - TYPE(NTYPS) = 'TYPE 2B ' - END IF - ELSE IF(LOGTME.AND.LOGALT.AND.LOGTMP.AND.LOGLT1) THEN - CTAG(L)(3:3) = 'E' - CTAG(L+1)(3:3) = 'E' - DUP = .TRUE. - CALL CHOOSE(L,L+1,TOSLIM,DUP,IWHICH,MAYBE,NEW) - IF(IWHICH.GT.0.AND.CTAG(IWHICH)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 9017, IWHICH,AAID(IWHICH), - $ REAL(JARRAY(IWHICH,1))*.01,REAL(JARRAY(IWHICH,2))*.01, - $ REAL(JARRAY(IWHICH,4)),CTAG(IWHICH) - CTAG(IWHICH)(4:4) = 'F' - CTAG(IWHICH)(14:14) = '3' - JARRAY(IWHICH,12) = 311 - END IF - IF(NEW) THEN - PRINT 723, IWHICH,MAYBE - KTYPS(6) = KTYPS(6) + 1 - NTYPS = NTYPS + 1 - IF(NTYPS.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE DUPLICATE TYPES IN THIS TRACK THAN THE -C LIMIT "ITRKL" -- STOP 29 - PRINT 52, ITRKL - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(29) -C....................................................................... - END IF - TYPE(NTYPS) = 'TYPE 2B ' - END IF - ELSE IF(LOGLAT.AND.LOGLON.AND..NOT.LOGGT3) THEN - DUP = .TRUE. - CALL CHOOSE(L,L+1,TOSLIM,DUP,IWHICH,MAYBE,NEW) - CTAG(IWHICH)(3:3) = 'E' - IF(IWHICH.GT.0.AND.CTAG(IWHICH)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 9018, IWHICH,AAID(IWHICH), - $ REAL(JARRAY(IWHICH,1))*.01,REAL(JARRAY(IWHICH,2))*.01, - $ REAL(JARRAY(IWHICH,4)),CTAG(IWHICH) - 9018 FORMAT(/' #EVENT 312: TRKCHK; NTRK>2 TYPE 2A DUP, WND QM SET "F"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - CTAG(IWHICH)(4:4) = 'F' - CTAG(IWHICH)(14:14) = '3' - JARRAY(IWHICH,12) = 312 - END IF - IF(NEW) THEN - PRINT 724, IWHICH,MAYBE - 724 FORMAT(' 2A- IWHICH,MAYBE ',2I5) - KTYPS(5) = KTYPS(5) + 1 - NTYPS = NTYPS + 1 - IF(NTYPS.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE DUPLICATE TYPES IN THIS TRACK THAN THE -C LIMIT "ITRKL" -- STOP 29 - PRINT 52, ITRKL - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(29) -C....................................................................... - END IF - TYPE(NTYPS) = 'TYPE 2A ' - END IF - ELSE IF(LOGTRK) THEN - I1 = IPTADJ(1) - IF(DELPOS(K).GT.50.0) TOSLIM = 'R' - I2 = I1 + 1 - DUP = .FALSE. - NEW = .FALSE. - IF(QDELT.NE.0..AND..NOT.LOGWND.AND.(.NOT.LOGLAT.OR. - $ .NOT.LOGLON)) THEN - CALL CHOOSE(I1,I2,TOSLIM,DUP,IWHICH,MAYBE,NEW) - IF(.NOT.NEW.AND.NAPTS.EQ.1) THEN - IF(IWHICH.GT.0.AND.IWHICH.EQ.IPTADJ(1).AND. - $ CTAG(IWHICH)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 9016, IWHICH,AAID(IWHICH), - $ REAL(JARRAY(IWHICH,1))*.01,REAL(JARRAY(IWHICH,2))*.01, - $ REAL(JARRAY(IWHICH,4)),CTAG(IWHICH) - CTAG(IWHICH)(4:4) = 'F' - CTAG(IWHICH)(14:14) = '3' - JARRAY(IWHICH,12) = 310 - END IF - ELSE IF(NEW.AND.TOSLIM.EQ.'R') THEN - PRINT 725, IWHICH,MAYBE - 725 FORMAT(' 3 - IWHICH,MAYBE ',2I5) - IF(MAYBE.GT.0) CTAG(MAYBE)(3:3) = 'E' - IF(IWHICH.GT.0.AND.CTAG(IWHICH)(14:14).GT.'3')THEN - IF(EWRITE) PRINT 9016, IWHICH,AAID(IWHICH), - $ REAL(JARRAY(IWHICH,1))*.01,REAL(JARRAY(IWHICH,2))*.01, - $ REAL(JARRAY(IWHICH,4)),CTAG(IWHICH) - CTAG(IWHICH)(4:4) = 'F' - CTAG(IWHICH)(14:14) = '3' - JARRAY(IWHICH,12) = 310 - END IF - ELSE IF(NEW) THEN -CVVVVVASK PAUL -C ASK PAUL: PAUL CLAIMS THIS SHOULD BE 'F' NOT 'D' (LIKE ABOVE) -C DOUBLE CHECK WITH HIM: NOTE PREV. IF-THEN SETS WIND TO 'F' IF -C NEW AND TOSLIM = R (HERE NEW AND TOSSLIM .NE. R) -CAAAAAASK PAUL - PRINT 725, IWHICH,MAYBE - IF(MAYBE.GT.0) CTAG(MAYBE)(3:3) = 'E' - IF(IWHICH.GT.0.AND.CTAG(IWHICH)(14:14).GT.'0')THEN - IF(EWRITE) PRINT 9019, IWHICH,AAID(IWHICH), - $ REAL(JARRAY(IWHICH,1))*.01,REAL(JARRAY(IWHICH,2))*.01, - $ REAL(JARRAY(IWHICH,4)),CTAG(IWHICH) - 9019 FORMAT(/' #EVENT ###: TRKCHK; NTRK>2 TYPE 3 , WND QM SET "D"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - CTAG(IWHICH)(1:1) = 'D' - CTAG(IWHICH)(13:13) = '0' - CTAG(IWHICH)(14:14) = '0' - END IF - END IF - IF(IWHICH.NE.L) THEN - CTAG(L)(3:3) = 'E' - ELSE - CTAG(L+1)(3:3) = 'E' - END IF - IF(NEW.AND.IWHICH.NE.0) THEN - KTYPS(7) = KTYPS(7) + 1 - NTYPS = NTYPS + 1 - IF(NTYPS.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE DUPLICATE TYPES IN THIS TRACK THAN THE -C LIMIT "ITRKL" -- STOP 29 - PRINT 52, ITRKL - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(29) -C....................................................................... - END IF - TYPE(NTYPS) = 'TYPE 3 ' - END IF - ELSE - KTYPS(9) = KTYPS(9) + 1 - NTYPS = NTYPS + 1 - IF(NTYPS.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE DUPLICATE TYPES IN THIS TRACK THAN THE -C LIMIT "ITRKL" -- STOP 29 - PRINT 52, ITRKL - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(29) -C....................................................................... - END IF - TYPE(NTYPS) = 'TIME TAG' - END IF - PRINT 667, L,L+1,AVESPD(K),DELPOS(K),LOGLAT,LOGLON, - $ LOGTME,LOGALT,LOGTMP,LOGWND,NEW,IWHICH,MAYBE - 667 FORMAT(' TYP3 ',2(1X,I4),' AVESPD(KTS)',F10.0,' DELPOS',F5.1, - $ ' LOGICALS ',6(L1,1X),'NEW ',L1,' IWHICH ',I5,' MAYBE ',I5) - END IF - 216 CONTINUE - ENDDO -C CHECK IF LAST REPORT IS BAD - IF(((DELPOS(LTRK-1).GT.35.0.AND.JARRAY(IEND,1).EQ.0).OR. - $ (DELPOS(LTRK-1).GT.35.0.AND.JARRAY(IEND,2).EQ.0)).AND. - $ CTAG(IEND)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 9020, IEND,AAID(IEND),REAL(JARRAY(IEND,1))*.01, - $ REAL(JARRAY(IEND,2))*.01,REAL(JARRAY(IEND,4)),CTAG(IEND) - 9020 FORMAT(/' #EVENT 313: TRKCHK; NTRK>2 LAST IS BAD, WND QM SET "F"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - CTAG(IEND)(4:4) = 'F' - CTAG(IEND)(14:14) = '3' - JARRAY(IEND,12) = 313 - END IF - QSUM = 0.0 - IQNUM = 0 -C LOOP SETS POINTERS IF POSITION DIFFERENCES ARE TOO LARGE - DO L = IBEG,IEND - K = L - IBEG + 1 - IF(DELPOS(K).GT.25.0) THEN - IF(NTRKP+1.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE REPORTS IN THIS TRACK WITH LARGE POSTION -C ERRORS THAN THE LIMIT "ITRKL" -- STOP 30 - PRINT 53, ITRKL - 53 FORMAT(/' THERE ARE MORE THAN',I5,' REPORTS IN THIS TRACK WITH ', - $ 'LARGE POSITION ERRORS -- MUST INCREASE SIZE OF PARAMETER NAME ', - $ '"ITRKL" - STOP 30'/) - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(30) -C....................................................................... - END IF - IF(L.LT.IEND) THEN - NTRKP = NTRKP + 1 - IPTTRK(NTRKP) = L - NTRKP = NTRKP + 1 - IF(NTRKP.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE REPORTS IN THIS TRACK WITH LARGE POSTION -C ERRORS THAN THE LIMIT "ITRKL" -- STOP 30 - PRINT 53, ITRKL - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(30) -C....................................................................... - END IF - IPTTRK(NTRKP) = L + 1 - ELSE - NTRKP = NTRKP + 1 - IPTTRK(NTRKP) = L - END IF - END IF -C CALCULATE AVERAGE VECTOR INCREMENT FOR TRACK (QSUM) AMONGST THOSE OBS. -C WITH A SCALED INCREMENT CHARACTER Q-Z - IF(CTAG(L)(5:5).GE.'Q'.AND.CTAG(L)(5:5).LE.'Z') THEN - CTG = CTAG(L)(5:5) - SCALE = 95.0 - DO I=1,9 - IF(CTG.EQ.CH1(I)) THEN - SCALE = ICH1(I) - EXIT - END IF - ENDDO - IQNUM = IQNUM + 1 - QSUM = QSUM + SCALE - END IF - ENDDO - IF(IQNUM.NE.0) THEN - QSUM = QSUM/IQNUM - ELSE - QSUM = 0.0 - END IF -C CHECK IF NTRKP INDICATES INTERIOR BAD - DO KK = 1,NTRKP-1 - DO JJ = KK+1,NTRKP - IF(IPTTRK(KK).EQ.IPTTRK(JJ)) THEN - I1 = IPTTRK(KK) - I2 = IPTTRK(JJ) - DUP = .TRUE. - CALL CHOOSE(I1,I2,TOSLIM,DUP,IWHICH,MAYBE,NEW) - IF(IWHICH.GT.0.AND.CTAG(IWHICH)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 9021, IWHICH,AAID(IWHICH), - $ REAL(JARRAY(IWHICH,1))*.01,REAL(JARRAY(IWHICH,2))*.01, - $ REAL(JARRAY(IWHICH,4)),CTAG(IWHICH) - 9021 FORMAT(/' #EVENT 314: TRKCHK; NTRK>2 TYPE 3 DUP , WND QM SET "F"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - CTAG(IWHICH)(4:4) = 'F' - CTAG(IWHICH)(14:14) = '3' - JARRAY(IWHICH,12) = 314 - END IF - PRINT 727, IWHICH,MAYBE - 727 FORMAT(' INT-IWHICH,MAYBE ',2I5) - KTYPS(7) = KTYPS(7) + 1 - NTYPS = NTYPS + 1 - IF(NTYPS.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE DUPLICATE TYPES IN THIS TRACK THAN THE -C LIMIT "ITRKL" -- STOP 29 - PRINT 52, ITRKL - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(29) -C....................................................................... - END IF - TYPE(NTYPS) = 'TYPE 3 ' - END IF - ENDDO - ENDDO - NPRNT = NPTRS + NTYPS + NAPTS + DTKNT - IF(NPRNT.GT.0.OR.LUTCEQ.OR.LVAREQ.OR.NCHNGD.GT.0) THEN - IF(TRACE) THEN - PRINT 480 - 480 FORMAT(' POINTER SUMMARY--K-- ADJ TRK NADI NADJ') - DO KK = 1,LTRK - IF(KK.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE REPORTS IN THE POINTER SUMMARY FOR THIS -C TRACK THAN THE LIMIT "ITRKL" -- STOP 26 - PRINT 49, ITRKL - 49 FORMAT(/' THERE ARE MORE THAN',I5,' REPORTS IN THE POINTER ', - $ 'SUMMARY FOR THIS TRACK -- MUST INCREASE SIZE OF PARAMETER NAME', - $ ' "ITRKL" - STOP 26'/) - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(26) -C....................................................................... - END IF - PRINT 482,KK,IPTADJ(KK), IPTTRK(KK), IPTNAD(KK),JPTNAD(KK) - 482 FORMAT(' ',15X,I3,3X,4(I4,2X)) - ENDDO - PRINT 8891, LTRK,IBEG,IEND - 8891 FORMAT(' TRACE AT 215 ',3(1X,I6)) - END IF - DO L = IBEG,IEND - K = L - IBEG + 1 - PRINT 334, K,L,AAID(L),JARRAY(L,1),JARRAY(L,2),JARRAY(L,4), - $ JARRAY(L,3),JARRAY(L,5),JARRAY(L,6),JARRAY(L,7),CTAG(L), - $ DELPOS(K),AVESPD(K) - 334 FORMAT(' K=',I3,' L=',I5,2X,A8,6I7,I5,' "',A14,'"/ ', - $ F7.1,F13.1) - ENDDO - PRINT 314, NAPTS,NTRKP,NPTRS,QSUM,(TYPE(M),M=1,NTYPS) - 314 FORMAT(' END /POINTERS #ADJS,#TRKS,#NADJ',3(1X,I4), - $ ' QSUM ',F5.1,/,' TYPES ',7(2X,A8)) -CCCCC PRINT 5012, KTYPS -C5012 FORMAT(//,' #TYPE1A ',I2,' #TYPE1B ',I2,' #TYPE?? ',I2, -CCCCC$ ' #TYPE1D ',I2,' #TYPE2A ',I2,' #TYPE2B ',I2,' #TYPE3 ',I2, -CCCCC$ ' ',I2,'TIME TAGS',I2) - IF(TRACE) PRINT 8892, LTRK,IBEG,IEND,I - 8892 FORMAT(' TRACE AT END, LTRK,IBEG,IEND,I!',4(1X,I6)) - PRINT 634 - 634 FORMAT(' ----------------------------------') - END IF - END IF -C----------------------------------------------------------------------- - NTRK = 0 -C GO BACK TO 66 TO START NEXT TRACK - GO TO 66 -C********************************************************************** - END IF - PRINT 574 -C RESORT FOR STACK DETERMINATION: -C 1ST ORDER - LATITUDE (SOUTH TO NORTH) -C 2ND ORDER - LONGITUDE (WEST, INCREASING) -C 3RD ORDER - TIME (INCREASING) -C 4TH ORDER - ALITITUDE (INCREASING) (THIS WAS ADDED 8/23/1999) -C SORT BY CONCATENATING THESE QUANITIIES INTO CHARACTER ARRAY -C (DO NOT INCLUDE ASDARS/AMDARS/TAMDARS AND EXCLUDED REPORTS IN THIS -C SORT) - DO J = 1,NAIREP - WRITE(CARRAY(J)(1:5),'(I5.5)') JARRAY(J,1) + 9000 - WRITE(CARRAY(J)(6:10),'(I5.5)') JARRAY(J,2) - WRITE(CARRAY(J)(11:14),'(I4.4)') JARRAY(J,4) - WRITE(CARRAY(J)(15:20),'(I6.6)') JARRAY(J,3) - CARRAY(J)(21:32) = '000000000000' -CCCCC PRINT 788, J,AAID(J),CARRAY(J) -CC788 FORMAT(' DBG J ',I6,2X,'; ID=',A8,'; CARRAY=',A32) - ENDDO -C CALL SORT ROUTINE- PUTS POINTERS INTO IPOINT ARRAY/DOES NOT REARRANGE - IF(NAIREP.GT.0) CALL INDEXC(NAIREP,CARRAY,INDR) -C WRITE SORTED REPORTS INTO SAAID, KARRAY, AND STAG ARRAYS (REMAINING -C ASDAR/AMDAR/TAMDAR AND EXCLUDED REPORTS ALREADY IN THESE ARRAYS IN -C PROPER POSITION FROM STORE MADE AT BEGINNING OF SUBROUTINE) - DO I = 1,NAIREP - J = INDR(I) - SAAID(I) = AAID(J) - STAG(I) = CTAG(J) - KARRAY(I,:) = JARRAY(J,:) - ENDDO -CCCCC PRINT 562 -CC562 FORMAT(' LAT/LON ACID ',6X,' LAT LON ',4X,'UTC ALT ', -CCCCC$' TEMP WDIR WSPD ') -CCCCC DO J = 1,KOUNT -CCCCC KARRY1 = MIN0(KARRAY(J,1),99999) -CCCCC KARRY2 = MIN0(KARRAY(J,2),99999) -CCCCC PRINT 711, J,SAAID(J),KARRY1,KARRY2,KARRAY(J,4),KARRAY(J,3), -CCCCC$ KARRAY(J,5),KARRAY(J,6),KARRAY(J,7),STAG(J) -CC711 FORMAT(' ',I5,2X,A8,7I8,1X,'"',A14,'"') -CCCCC ENDDO -C WRITE SORTED REPORTS BACK INTO ORIGINAL ARRAYS AND ELIMINATE DUPS - IF(IWRITE) PRINT 557 - 557 FORMAT(/' FINAL LISTING OF SORTED DATA LEAVING TRKCHK----'/9X, - $ 'ACID',8X,'LAT WLON UTC ALT TEMP WDIR WSPD -----', - $ 'TAGS----- ITYPE RPTIME KNTINI GALT GTEMP GDIR GSPD'/) - M = 0 - DO I = 1,KOUNT - IF(STAG(I)(1:1).EQ.'D') THEN - PRINT 9022, I,SAAID(I),REAL(KARRAY(I,1))*.01, - $ REAL(KARRAY(I,2))*.01,REAL(KARRAY(I,4)),STAG(I) - 9022 FORMAT(/' ##########: TRKCHK; DUPLICATE REMOVED AT END OF SUBR..', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - GO TO 219 - END IF - IF(STAG(I)(3:3).EQ.'Z') STAG(I)(3:3) = '-' - M = M + 1 - ACID(M) = SAAID(I) - ALAT(M) = KARRAY(I,1) * .01 - ALON(M) = KARRAY(I,2) * .01 - AALT(M) = KARRAY(I,3) - TIME(M) = KARRAY(I,4) - ATMP(M) = KARRAY(I,5) - ADIR(M) = KARRAY(I,6) - ASPD(M) = KARRAY(I,7) - INTP(M) = KARRAY(I,8) - IRTM(M) = KARRAY(I,9) - KNTINI(M) = KARRAY(I,10) - ITEVNT(M) = KARRAY(I,11) - IWEVNT(M) = KARRAY(I,12) - AALTF(M) = KARRAY(I,13) - ADIRF(M) = KARRAY(I,14) - ASPDF(M) = KARRAY(I,15) - ATMPF(M) = KARRAY(I,16) - TAG(M) = STAG(I) - IF(IWRITE) PRINT 331, M,ACID(M),ALAT(M),ALON(M),NINT(TIME(M)), - $ NINT(AALT(M)),NINT(ATMP(M)),NINT(ADIR(M)),NINT(ASPD(M)), - $ TAG(M),INTP(M),IRTM(M),KNTINI(M),NINT(AALTF(M)),NINT(ATMPF(M)) - $ , NINT(ADIRF(M)),NINT(ASPDF(M)) - 331 FORMAT(' ',I5,2X,A8,1X,2F8.2,I6,I7,3I6,3X,'"',A14,'"',I6,2I8, - $ I7,3I6) - 219 CONTINUE - ENDDO - NFILE = M - PRINT 681, NFILE - 681 FORMAT(1X,128('*')/47X,'OUT OF TRACK CHECK - NFILE =',I7/128('*')) - RETURN -C....................................................................... - 9999 CONTINUE -C FATAL ERROR: THERE ARE MORE RPTS IN TRACK THAN "ITMX" -- STOP 24 - PRINT 953, ITMX - 953 FORMAT(/' THERE ARE MORE THAN',I5,' REPORTS IN A SINGLE TRACK ', - $ '-- MUST INCREASE SIZE OF PARAMETER NAME "ITMX" - STOP 24'/) - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(24) -C....................................................................... - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: WAYPT CORRECTS WAYPOINT LOCATIONS FOR ACFT RPTS -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1995-11-08 -C -C ABSTRACT: LOOPS THRU FLIGHT FROM POINTER IBEG TO IEND CHECKING IF -C LAT/LON IS ON LIST OF KNOWN INCORRECT WAYPOINT LOCATIONS. IF -C SO, THE LAT/LON IS CHANGED TO THE CORRECT WAYPOINT LOCATION. -C THIS SUBROUTINE CAN BE CALLED ONLY FOR AIREP/PIREP REPORTS. -C -C PROGRAM HISTORY LOG: -C 1993-01-05 P. JULIAN (W/NMC00) -- ORIGINAL AUTHOR -C 1994-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND -C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT -C 1995-02-10 D. A. KEYSER -- MINOR CHANGE TO ALLOW WAYPOINT CORRECTED -C LAT/LON TO BE CARRIED BACK TO CALLING SUBROUTINE FOR -C WAYPOINT CALL REASON # 3 (WASN'T BEING DONE BEFORE) -C 1995-05-30 D. A. KEYSER -- ADDED PARAMETER NAME "LSIZE" FOR MAX. -C NO. OF LAT/LON CORRECTIONS IN WAYPOINT FILE, ADDED -C COND. CODE 25 IF PARAMETER NAME "LSIZE" IS EXCEEDED -C 1995-11-08 D. A. KEYSER -- INCREASED THE SIZE OF PARAMETER "LSIZE" -C FROM 26 TO 50 -C -C USAGE: CALL WAYPT(IBEG,IEND,NCHNGD) -C INPUT ARGUMENT LIST: -C IBEG - POINTER FOR START OF FLIGHT SEGMENT -C IEND - POINTER FOR END OF FLIGHT SEGMENT -C -C OUTPUT ARGUMENT LIST: -C NCHNGD - NUMBER OF REPORT LOCATIONS CHANGED IN A SINGLE CALL -C - TO THIS SUBROUTINE -C -C INPUT FILES: -C UNIT 23 - TEXT FILE CONTAINING WAYPOINT CORRECTIONS -C (READ IN WHEN NAMELIST SWITCH WAYPIN=.TRUE.) -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C REMARKS: CALLED BY MAIN PROGRAM AND BY SUBROUTINE 'TRKCHK'. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE WAYPT(IBEG,IEND,NCHNGD) - PARAMETER (IRMX= 80000) - PARAMETER (ISIZE= 16) -C PARAMETER NAME "LSIZE" IN THIS SUBROUTINE REFERS TO THE MAXIMUM -C NUMBER OF LATITUDES AND LONGITUDES IN THE WAYPOINT CORRECTION FILE - PARAMETER (LSIZE= 50) - PARAMETER (LSIZ23= LSIZE-23) - LOGICAL WAYPIN,EWRITE - CHARACTER*80 BUFF1 - CHARACTER*8 AAID(IRMX) - CHARACTER*14 CTAG(IRMX),STAG(IRMX) - INTEGER OLDLAT(LSIZE),NEWLAT(LSIZE),OLDLON(LSIZE),NEWLON(LSIZE) - COMMON/INPT/DOSPOB,DOACRS,TMAXO,TMINO,TIMINC,WAYPIN,INIDST,IFLGUS, - $ JAMASS(6),JAWIND(6),RCPTST - COMMON/XXXXX/AAID,JARRAY(IRMX,ISIZE),CTAG,KARRAY(IRMX,ISIZE),STAG - COMMON/STWRIT/SWRITE,EWRITE,IWRITE - SAVE - DATA ITKNT/0/,INUM/23/ - DATA OLDLAT/ 2017, 3717, 1067, 3000, 3383, 4850, 5683, 4283, 2617, - 1 3417, 3783, 4500, 3417, 3717, 4033, 3100, 6217,-0583, - 2 -0950,-0667, 0817, 4017, 2783,LSIZ23*99999/ - DATA NEWLAT/-2983, 6000, 3967,-2750,-2683,-2533, 3504, 3007, 3648, - 1 3019, 3845,-0511, 4092, 4056,-0813,-3123, 3950,-0583, - 2 2431, 1478, 4195, 0090, 3746,LSIZ23*99999/ - DATA OLDLON/35333,11367,28567, 8550,11650,11233,13550, 7150,31267, - 1 9717,11300, 7467,11783, 9700, 7845, 8467, 2050,19000, - 2 21300, 7633,26117,11017,13050,LSIZ23*99999/ - DATA NEWLON/ 6200, 4317, 3167, 5700, 6050, 4917,33384,32180, 0422, - 1 0923,34367, 3721,34562,34567, 3488, 5406, 3117,16900, - 2 10450, 9237, 7183, 7000, 2405,LSIZ23*99999/ - NCHNGD = 0 - IF(ITKNT.EQ.0) THEN - IF(WAYPIN) THEN -C FIRST TIME IN, READ WAYPOINTS FROM EXTERNAL FILE IF WAYPIN=TRUE - READ(23,230) BUFF1 - READ(23,230) BUFF1 - READ(23,231) INUM - IF(INUM.GT.LSIZE) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE LAT/LON CORRECTIONS IN WAYPOINT FILE THAN -C WHAT IS EXPECTED HERE IN "LSIZE" -- STOP 25 - PRINT 53, LSIZE,INUM - 53 FORMAT(/' THERE ARE MORE THAN THE',I5,' EXPECTED LAT/LON ', - $ 'CORRECTIONS IN THE WAYPOINT FILE'/5X,'-- MUST INCREASE SIZE OF', - $ ' PARAMETER NAME "LSIZE" TO AT LEAST',I5,' - STOP 25'/) - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(25) -C....................................................................... - END IF - READ(23,230) BUFF1 - READ(23,232) (OLDLAT(J),J=1,INUM) - READ(23,230) BUFF1 - READ(23,232) (NEWLAT(J),J=1,INUM) - READ(23,230) BUFF1 - READ(23,232) (OLDLON(J),J=1,INUM) - READ(23,230) BUFF1 - READ(23,232) (NEWLON(J),J=1,INUM) - 230 FORMAT(A80) - 231 FORMAT(I5) - 232 FORMAT(12I6) - ELSE - INUM = 23 - END IF - PRINT 2999, WAYPIN - PRINT 3000, (OLDLAT(K),K=1,INUM) - PRINT 3001, (NEWLAT(K),K=1,INUM) - PRINT 3002, (OLDLON(K),K=1,INUM) - PRINT 3003, (NEWLON(K),K=1,INUM) - 2999 FORMAT(/' FIRST CALL TO SUBROUTINE WAYPT, WAYPIN = ',L4) - 3000 FORMAT(' OLDLAT ',12I6) - 3001 FORMAT(' NEWLAT ',12I6) - 3002 FORMAT(' OLDLON ',12I6) - 3003 FORMAT(' NEWLON ',12I6) - ITKNT = 1 - END IF - DO L = IBEG,IEND - DO J = 1,INUM - IF(JARRAY(L,1).EQ.OLDLAT(J).AND.JARRAY(L,2).EQ.OLDLON(J))THEN - PRINT 2000, L,J - 2000 FORMAT(' WAYPT MATCH L,J ',I5,1X,I2) - NCHNGD = NCHNGD + 1 - JARRAY(L,1) = NEWLAT(J) - JARRAY(L,2) = NEWLON(J) - CTAG(L)(1:1) = '-' -C SET TAG POSITION 9 TO 'C' TO INDICATE WAYPOINT CORRECTION - CTAG(L)(9:9) = 'C' -C UPDATE KARRAY AS WELL - WAYPOINT(3) SORTS BY TIME (SEE SUBR. TRKCHK) - KARRAY(L,1) = NEWLAT(J) - KARRAY(L,2) = NEWLON(J) -C UPDATE STAG AS WELL - WAYPOINT(3) SORTS BY TIME (SEE SUBR. TRKCHK) - STAG(L)(1:1) = '-' -C SET TAG POSITION 9 TO 'C' TO INDICATE WAYPOINT CORRECTION - STAG(L)(9:9) = 'C' -CVVVVV%%%%% - PRINT *,'~~~~~ WAYPT CORRECTION MADE (PRINT IN WAYPT)' -CAAAAA%%%%% - IF(EWRITE) PRINT 9002, L,AAID(L),REAL(JARRAY(L,1))*.01, - $ REAL(JARRAY(L,2))*.01,REAL(JARRAY(L,4)),CTAG(L) - 9002 FORMAT(/' #EVENT ###: WAYPT; WAYPT ERROR, LAT/LON CHANGED.......', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - PRINT 1000, IBEG,IEND,JARRAY(L,1),JARRAY(L,2) - 1000 FORMAT(' WAYPT ERR ',2(I5,1X),' NEW POS ',2I6) - END IF - ENDDO - ENDDO - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: CHOOSE CHOOSES WORST/DUPL. BETWEEN PAIR OF RPTS -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1994-08-25 -C -C ABSTRACT: USES SCALED VECTOR INCREMENTS TO EITHER CHOOSE UNEQUIVICALLY -C ONE OF A PAIR OF REPORTS (E.G. A DUPLICATE) OR TO CHOOSE THE -C 'WORST' AMONGST TWO REPORTS BASED UPON THE SCALED INCREMENTS -C OF THE PAIR OF REPORTS. -C -C PROGRAM HISTORY LOG: -C 1993-01-05 P. JULIAN (W/NMC00) -- ORIGINAL AUTHOR -C 1994-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND -C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT -C -C USAGE: CALL CHOOSE(I,J,TOSLIM,DUP,IWHICH,MAYBE,NEW) -C INPUT ARGUMENT LIST: -C I - POINTER FOR FIRST OF THE PAIR -C J - POINTER FOR SECOND OF THE PAIR -C TOSLIM - LIMITING SCALED QUALITY MARKER -C DUP - LOGICAL: =.TRUE. CHOOSE WHICH OF PAIR IS DUPLICATE; -C - =.FALSE. CHOOSE WHICH OF PAIR IS WORST -C -C OUTPUT ARGUMENT LIST: -C IWHICH - POINTER (I OR J) FOR THE ONE OF THE PAIR CHOSEN -C - (DUP=T) OR FOR THE ONE OF THE PAIR CHOSEN BECAUSE -C - IT EXCEEDED THE 'TOSLIM' (DUP=F) -C MAYBE - POINTER (I OR J) FOR THE ONE OF THE PAIR CHOSEN -C - BUT NOT BECAUSE IT EXCEEDED 'TOSLIM' (DUP=F ONLY) -C NEW - SET TO TRUE UNLESS REPORT ALREADY HAD A DUPLICATE -C - OR FAILED FLAG IN QUALITY MARKER -C -C REMARKS: CALLED BY SUBROUTINE 'TRKCHK'. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE CHOOSE(I,J,TOSLIM,DUP,IWHICH,MAYBE,NEW) - PARAMETER (IRMX= 80000) - PARAMETER (ISIZE= 16) - CHARACTER*1 TOSLIM - CHARACTER*8 AAID(IRMX) - CHARACTER*14 CTAG(IRMX),STAG(IRMX) - LOGICAL LIGS,LIGX,LJGS,LJGX,LIGJ,LJGI,DUP,NEW - COMMON/XXXXX/AAID,JARRAY(IRMX,ISIZE),CTAG,KARRAY(IRMX,ISIZE),STAG - NEW = .FALSE. - IWHICH = 0 - MAYBE = 0 -C IF DUPL. AND 2ND INCREMENT NOT CHECKED, SET 2ND INCREMENT TO THAT OF 1 - IF(CTAG(J)(5:5).EQ.'N'.AND.DUP) CTAG(J)(5:5) = CTAG(I)(5:5) - IF(CTAG(I)(1:1).EQ.'D'.OR.CTAG(I)(4:4).EQ.'F') THEN -C----------------------------------------------------------------------- -C IF FIRST OF PAIR HAS DUPLICATE OR BAD Q. MARK IT IS SELECTED - IWHICH = I - PRINT 1116, IWHICH,I,J,CTAG(I),CTAG(J),DUP,NEW - 1116 FORMAT(' CHOICE= ',I5,' I&J= ',2I5,' TAGS= "',A14,'"/"',A14, - $ '" DUP? ',L1,' NEW? ',L1) - ELSE IF(CTAG(J)(1:1).EQ.'D'.OR.CTAG(J)(4:4).EQ.'F') THEN -C----------------------------------------------------------------------- -C ELSE, IF SECOND OF PAIR HAS DUPLICATE OR BAD Q. MARK IT IS SELECTED - IWHICH = J - PRINT 1116, IWHICH,I,J,CTAG(I),CTAG(J),DUP,NEW - ELSE IF(.NOT.DUP) THEN -C----------------------------------------------------------------------- -C ELSE, IF NOT CHECKING FOR DUPLICATES, FIND THE WORST OF THE PAIR - NEW = .TRUE. - IF((CTAG(I)(5:5).EQ.'Q'.AND.CTAG(J)(5:5).EQ.'Q').OR. - $ (CTAG(I)(5:5).EQ.'R'.AND.CTAG(J)(5:5).EQ.'R')) THEN -C IF BOTH HAVE Q.M. OF 'Q' OR 'R' THEN RETAIN THEM BOTH - RETURN - END IF -C LIGJ = T IF 1ST WORSE THAN OR SAME AS 2ND; =F IF 1ST BETTER THAN 2ND - LIGJ = (CTAG(I)(5:5).GE.CTAG(J)(5:5)) -C LIGS = T IF 1ST BETWEEN S AND Z - LIGS = (CTAG(I)(5:5).GE.'S'.AND.CTAG(I)(5:5).LE.'Z') -C LIGX = T IF 1ST WORSE THAN OR SAME AS 'TOSLIM' - LIGX = (CTAG(I)(5:5).GE.TOSLIM.AND.CTAG(I)(5:5).LE.'Z') -C LJGS = T IF 2ND BETWEEN S AND Z - LJGS = (CTAG(J)(5:5).GE.'S'.AND.CTAG(J)(5:5).LE.'Z') -C LJGX = T IF 2ND WORSE THAN OR SAME AS 'TOSLIM' - LJGX = (CTAG(J)(5:5).GE.TOSLIM.AND.CTAG(J)(5:5).LE.'Z') - IF(LIGX.AND..NOT.LJGX) THEN -C 1ST WORSE THAN/SAME AS 'TOSLIM' & 2ND BETTER THAN 'TOSLIM': CHOOSE 1ST - IWHICH = I - ELSE IF(LJGX.AND..NOT.LIGX) THEN -C 2ND WORSE THAN/SAME AS 'TOSLIM' & 1ST BETTER THAN 'TOSLIM': CHOOSE 2ND - IWHICH = J - ELSE IF(LIGX.AND.LJGX) THEN -C BOTH WORSE THAN/SAME AS 'TOSLIM' .. CHECK CARSWELL-TINKER INDICATOR - IF(CTAG(I)(7:7).EQ.'C'.AND.CTAG(J)(7:7).NE.'C') THEN -C ...1ST IS CARSWELL-TINKER, CHOOSE 1ST - IWHICH = I - ELSE IF(CTAG(J)(7:7).EQ.'C'.AND.CTAG(I)(7:7).NE.'C') THEN -C ...2ND IS CARSWELL-TINKER, CHOOSE 2ND - IWHICH = J - ELSE IF(LIGJ) THEN -C ...BOTH EITHER ARE OR AREN'T CARSWELL-TINKER, CHOOSE 1ST IF WORSE -C THAN 2ND - IWHICH = I - ELSE -C ...BOTH EITHER ARE OR AREN'T CARSWELL-TINKER, CHOOSE 2ND IF WORSE -C THAN 1ST - IWHICH = J - END IF - ELSE IF(LIGS.AND..NOT.LJGS.AND.CTAG(J)(5:5).NE.'N') THEN -C 1ST BETWEEN S AND Z & 2ND IS Q OR R, CHOOSE 1ST MAYBE - MAYBE = I - ELSE IF(LJGS.AND..NOT.LIGS.AND.CTAG(I)(5:5).NE.'N') THEN -C 2ND BETWEEN S AND Z & 1ST IS Q OR R, CHOOSE 2ND MAYBE - MAYBE = J - ELSE IF(LIGS.AND.LJGS) THEN -C BOTH BETWEEN S AND Z .. CHECK CARSWELL-TINKER INDICATOR - IF(CTAG(I)(7:7).EQ.'C'.AND.CTAG(J)(7:7).NE.'C') THEN -C ...1ST IS CARSWELL-TINKER, CHOOSE 1ST MAYBE - MAYBE = I - ELSE IF(CTAG(J)(7:7).EQ.'C'.AND.CTAG(I)(7:7).NE.'C') THEN -C ...2ND IS CARSWELL-TINKER, CHOOSE 2ND MAYBE - MAYBE = J - ELSE IF(LIGJ) THEN -C ...BOTH EITHER ARE/AREN'T CARSWELL-TINKER, CHOOSE 1ST MAYBE IF WORSE -C THAN 2ND - MAYBE = I - ELSE -C ...BOTH EITHER ARE/AREN'T CARSWELL-TINKER, CHOOSE 2ND MAYBE IF WORSE -C THAN 1ST - MAYBE = J - END IF - END IF - PRINT 1117, IWHICH,LIGS,LJGS,LIGX,LJGX,LIGJ,I,J,CTAG(I), - $ CTAG(J),DUP,NEW - 1117 FORMAT(' CHOICE= ',I5,' W/ LOGICALS: LIGS=',L1,' LJGS=',L1, - $ ' LIGX=',L1,' LJGX=',L1,' LIGJ=',L1,' I&J=',2I5,' TAGS="', - $ A14,'"/"',A14,'" DUP? ',L1,' NEW? ',L1) - ELSE -C----------------------------------------------------------------------- -C ELSE IF CHECKING FOR DUPLICATES, FIND THE DUPLICATE - NEW =.TRUE. -C LIGJ = T IF 1ST WORSE THAN 2ND; =F IF 1ST BETTER THAN OR SAME AS 2ND - LIGJ = (CTAG(I)(5:5).GT.CTAG(J)(5:5)) -C LJGI = T IF 2ND WORSE THAN 1ST; =F IF 2ND BETTER THAN OR SAME AS 1ST - LJGI = (CTAG(J)(5:5).GT.CTAG(I)(5:5)) - IF(CTAG(I)(5:5).EQ.CTAG(J)(5:5)) THEN -C BOTH HAVE SAME QUALITY .. CHECK CARSWELL-TINKER INDICATOR - IF(CTAG(J)(7:7).EQ.'C'.AND.CTAG(I)(7:7).NE.'C') THEN -C ...2ND IS CARSWELL-TINKER, CHOOSE 2ND - IWHICH = J - ELSE IF(CTAG(I)(7:7).EQ.'C'.AND.CTAG(J)(7:7).NE.'C') THEN -C ...1ST IS CARSWELL-TINKER, CHOOSE 1ST - IWHICH = I - ELSE -C ...BOTH EITHER ARE OR AREN'T CARSWELL-TINKER, CHOOSE 1ST - IWHICH = I - END IF - ELSE IF(LIGJ) THEN -C 1ST IS WORSE THAN 2ND, CHOOSE 1ST - IWHICH = I - ELSE IF(LJGI) THEN -C 2ND IS WORSE THAN 1ST, CHOOSE 2ND - IWHICH = J - END IF - PRINT 1118, IWHICH,LIGJ,LJGI,I,J,CTAG(I),CTAG(J),DUP,NEW - 1118 FORMAT(' CHOICE= ',I5,' FROM LOGICALS: LIGJ=',L1,' LJGI=',L1, - $ ' I&J= ',2I5,' TAGS= "',A14,'"/"',A14,'" DUP? ',L1,' NEW? ',L1) -C----------------------------------------------------------------------- - END IF - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: SHEAR CHECKS WIND DIFFERENCE AGAINST STATISTICS -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1994-08-25 -C -C ABSTRACT: DOES WIND DIFFERENCING BOTH AT SAME AND AT DIFFERENT -C LEVELS AND ASSIGNS DIGITAL FLAGS DEPENDING UPON THE MAGNITUDES -C COMPARED WITH A STATISTICAL DISTRIBUTION OF SUCH DIFFERENCES -C AND USING THE OBSERVED VECTOR INCREMENTS. FLAGS BAD OBSERVATIONS. -C THERE MUST BE AT LEAST TWO HIGH-ALTITUDE OBSERVATIONS IN STACK -C FOR THIS CHECK TO BE PERFORMED. -C -C PROGRAM HISTORY LOG: -C 1989-04-01 P. JULIAN -- ORIGINAL AUTHOR -C 1993-01-05 P. JULIAN -- CHANGES TO UTILIZE SCALED OBS INCREMENTS -C 1994-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND -C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT -C -C USAGE: CALL SHEAR(NUM,INDX) -C INPUT ARGUMENT LIST: -C NUM - NUMBER OF OBSERVATIONS TO BE TREATED -C INDX - POINTER TO POSITION IN ORIGINAL AIRCRAFT ARRAY -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C REMARKS: CALLED BY SUBROUTINE 'PRELIM'. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE SHEAR(NUM,INDX) - PARAMETER (IRMX= 80000, ISMX= 8000) -C PRINT LOGICALS- PRNTA:PRINT ALL; PRNTT:PRINT TITLE; PRNTL: PRINT LINE - LOGICAL PRNTA,PRNTT,PRNTL - CHARACTER*1 CTG,CH1(9) - CHARACTER*8 ACID,SAID - CHARACTER*14 TAG - INTEGER COUNT(ISMX),LOUNT(ISMX),CHKSUM(ISMX),KPOINT(ISMX), - $ GOUNT(ISMX),IARRAY(ISMX),INDR(ISMX),ICH1(9) - REAL TABLE(7,7),VPOINT(ISMX) - COMMON/CMPNTS/U(ISMX),V(ISMX),UF(ISMX),VF(ISMX) - COMMON/SUMDAT/ISTCPT(ISMX),SAID(ISMX),SLAT(ISMX),SLON(ISMX), - $ SHGT(ISMX),STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX), - $ KBAD(ISMX),NUMORG,SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX) - COMMON/ALLDAT/IFLEPT(IRMX),ACID(IRMX),ALAT(IRMX),ALON(IRMX), - $ AALT(IRMX),TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE, - $ ATMP(IRMX),TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX), - $ ITEVNT(IRMX),IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX), - $ ADIRF(IRMX) -C VECTOR ERROR (TABLE(IALT,ITIM),ITIM=1,6)/ KNOTS / - DATA (TABLE(1,ITIM),ITIM=1,7)/ 38.,39.,40.,41.,42.,43.,44./ - DATA (TABLE(2,ITIM),ITIM=1,7)/ 49.,50.,51.,52.,53.,54.,55./ - DATA (TABLE(3,ITIM),ITIM=1,7)/ 60.,61.,62.,63.,64.,65.,66./ - DATA (TABLE(4,ITIM),ITIM=1,7)/ 71.,72.,73.,74.,75.,76.,77./ - DATA (TABLE(5,ITIM),ITIM=1,7)/ 82.,83.,84.,85.,86.,87.,88./ - DATA (TABLE(6,ITIM),ITIM=1,7)/ 93.,94.,95.,96.,97.,98.,99./ - DATA (TABLE(7,ITIM),ITIM=1,7)/ 97.,98.,99.,99.,99.,99.,99./ - DATA KNO/5/ - DATA CH1 /'Q','R','S','T','U','V','W','X','Y'/ - DATA ICH1 /10, 20, 30, 40, 50, 60, 70, 80, 90 / -C CALL STATS TO OBTAIN AVG. SPEED & VECTOR DIFFERENCE - CALL STATS(KNO,INDX,NUM,SBAR,VPOINT) - LOOP = 0 -C CALIBX IS ADJUSTABLE CONSTANT FOR ON-LEVEL DIFFERENCE CHECK -CCCCC CALIBX = 0.30 SLIGHTLY MORE PERMISSIVE IS - CALIBX = 0.45 -C GOUNT IS INTEGER WEIGHTING FROM SCALED OBSERVED VECTOR INCREMENT - DO K = 1,NUM - GOUNT(K) = 0 - KNDX = INDX + K - 1 - IF(IFLEPT(KNDX).LE.0.OR.KBAD(K).LE.0) GO TO 45 - SCALE = 25.0 -C SCALE IS BASED ON VALUE OF SCALED INCREMENT CHARACTER Q-Z - IF(TAG(KNDX)(5:5).GE.'Q'.AND.TAG(KNDX)(5:5).LE.'Z') THEN - CTG = TAG(KNDX)(5:5) - SCALE = 100.0 - DO I=1,9 - IF(CTG.EQ.CH1(I)) THEN - SCALE = ICH1(I) - EXIT - END IF - ENDDO - END IF -C NOTE: GOUNT WILL BE -1 FOR OBS. W/O SCALED VECTOR INCREMENT VALUE - GOUNT(K) = NINT((SCALE - 30) * 0.2) -C IF SUSPECTED TRACK CHECK ERROR ADD 2 TO GOUNT - IF(TAG(KNDX)(3:3).EQ.'E') GOUNT(K) = GOUNT(K) + 2 - 45 CONTINUE - ENDDO -C START OF ITERATION CHECKING AND TOSSING - 1010 CONTINUE - LOOP = LOOP + 1 -C COUNT IS INTEGER SUM OF QUALITY UNITS FOR OFF-LEVEL(SHEAR) CHECKS -C LOUNT IS SAME BUT FOR ON-LEVEL CHECKS - IARRAY(1:NUM) = NINT(VPOINT(1:NUM)*100.) - COUNT(1:NUM) = 0 - LOUNT(1:NUM) = 0 - CHKSUM(1:NUM) = -99 - DO K = 1,NUM - IF(KBAD(K).LE.0) GOUNT(K) = 0 - ENDDO -C EACH ITERATION MUST RESORT VECTOR DIFFERENCE AMONGST "GOOD" -C OBS. IN STACK - IF(NUM.GT.0) CALL INDEXF(NUM,IARRAY,KPOINT) - DIFF = 0.0 - IMAXK = 0 - IMAXJ = 0 - PRNTT =.TRUE. - PRNTA =.FALSE. - DO K = 1,NUM - IF(IARRAY(KPOINT(K)).LT.0) KPOINT(K) = -9 - KNDX = INDX + K - 1 - IF(IFLEPT(KNDX).GT.0.AND.KBAD(K).GT.0) THEN - DO J = K+1,NUM - PRNTL =.FALSE. - JNDX = INDX + J - 1 - IF(IFLEPT(JNDX).LE.0.OR.KBAD(J).LE.0) GO TO 2 - TIMDIF = ABS(TIME(JNDX)-TIME(KNDX)) * .01 - ALTDIF = ABS(AALT(JNDX)-AALT(KNDX)) - IALT = (ALTDIF + 50.) * 0.001637 - ITIM = MAX0(1,NINT(TIMDIF)) - IF(IALT.GT.9.OR.ITIM.GT.7) GO TO 999 - QUAN = SQRT((U(K) - U(J))**2 + (V(K) - V(J))**2) - IF(IALT.LE.0) THEN -C ON-LEVEL CHECK -C CALIBX=0.45 IS ADJUSTABLE CONSTANT FOR ON-LEVEL DIFFERENCE CHECK - CHEK = 9.0 + (TIMDIF * SBAR * CALIBX) - IF((QUAN-CHEK).GT.DIFF) THEN - DIFF = QUAN - CHEK -C IMAXJ AND IMAXK ARE THE TWO LEVELS EXCEEDING THE LIMITS - IMAXJ = J - IMAXK = K - PRNTL = .TRUE. - PRNTA = .TRUE. - END IF - IF(QUAN.LT.0.25*CHEK) THEN - LOUNT(K) = LOUNT(K) - 2 - LOUNT(J) = LOUNT(J) - 2 - ELSE IF(QUAN.LT.0.5*CHEK) THEN - LOUNT(K) = LOUNT(K) - 1 - LOUNT(J) = LOUNT(J) - 1 - ELSE IF(QUAN.GT.2.*CHEK) THEN - LOUNT(K) = LOUNT(K) + 2 - LOUNT(J) = LOUNT(J) + 2 - ELSE IF(QUAN.GT.CHEK) THEN - LOUNT(K) = LOUNT(K) + 1 - LOUNT(J) = LOUNT(J) + 1 - END IF - ELSE -C OFF-LEVEL CHECK - IF(IALT.GT.5) GO TO 2 - CHEK = TABLE(IALT,ITIM) + (SBAR * 0.14) - IF((QUAN-CHEK).GT.DIFF) THEN - DIFF = QUAN - CHEK -C IMAXJ AND IMAXK ARE THE TWO LEVELS EXCEEDING THE LIMITS - IMAXJ = J - IMAXK = K - PRNTL = .TRUE. - PRNTA = .TRUE. - END IF - IF(QUAN.GT.2.8*CHEK) THEN - COUNT(K) = COUNT(K) + 4 - COUNT(J) = COUNT(J) + 4 - ELSE IF(QUAN.GT.1.4*CHEK) THEN - COUNT(K) = COUNT(K) + 2 - COUNT(J) = COUNT(J) + 2 - ELSE IF(QUAN.GT.CHEK) THEN - COUNT(K) = COUNT(K) + 1 - COUNT(J) = COUNT(J) + 1 - END IF - END IF - CHKSUM(J) = LOUNT(J) + COUNT(J) + GOUNT(J) - CHKSUM(K) = LOUNT(K) + COUNT(K) + GOUNT(K) - IF(PRNTT.AND.PRNTL) THEN - PRINT 441 - 441 FORMAT(' SHEAR/ I J ALTDIF TIMDIF SHEARVEC LIMIT') - PRNTT = .FALSE. - END IF - IF(PRNTL) PRINT 401, K,J,ALTDIF,TIMDIF,QUAN, - $ CHEK+SIGN(.0005,CHEK) - 401 FORMAT(' ',2I4,3X,F8.0,F8.2,2X,F7.1,2X,F7.1) - 2 CONTINUE - ENDDO - END IF - ENDDO - IF(KPOINT(NUM).LT.1.OR.KPOINT(NUM-1).LT.1) RETURN - IPOINT = KPOINT(NUM) - JPOINT = KPOINT(NUM-1) - IF(DIFF.GT.0.0) THEN - IF(NUM.GT.0) CALL INDEXF(NUM,CHKSUM,INDR) -C HOW MANY OBS. DO WE ACTUALLY HAVE TO EVALUATE (NUMT) ? -C (THERE MUST BE AT LEAST TWO) - NUMT = 0 - DO I = 1,NUM - IF(CHKSUM(I).GT.-99) NUMT = NUMT + 1 - ENDDO - ICHK1 = INDR(NUM) - ICHK2 = INDR(NUM-1) -C*********************************************************************** -C LOGIC TREE FOR DECIDING WHATS WRONG -C ITERATE IF MAJOR BADS-ONLY 4 BADS ALLOWED -C THIS IS SET FOR MAXIMUM TOSSES -C*********************************************************************** - IF(NUMT.GT.3) THEN -C----------------------------------------------------------------------- -C FOUR OR MORE OBSERVATIONS IN THE STACK CAN BE EVALUATED - ICHK3 = INDR(NUM-2) - ICHK4 = INDR(NUM-3) - ICDIF1 = CHKSUM(ICHK1) - CHKSUM(ICHK2) - ICDIF2 = CHKSUM(ICHK2) - CHKSUM(ICHK3) - ICDIF3 = CHKSUM(ICHK3) - CHKSUM(ICHK4) - IF(ICDIF1.EQ.0.AND.ICDIF2.EQ.0.AND.ICDIF3.EQ.0) RETURN - IF(PRNTA) THEN - IF(NUM.LE.24) THEN - PRINT 136, (COUNT(I),I=1,NUM) - PRINT 138, (LOUNT(I),I=1,NUM) - PRINT 139, (GOUNT(I),I=1,NUM) - PRINT 148, ICHK1,ICHK2,ICHK3,(CHKSUM(I),I=1,NUM) - ELSE - PRINT 9136, (COUNT(I),I=1,NUM) - PRINT 9138, (LOUNT(I),I=1,NUM) - PRINT 9139, (GOUNT(I),I=1,NUM) - PRINT 9148, ICHK1,ICHK2,ICHK3,(CHKSUM(I),I=1,NUM) - END IF - END IF -C CALCULATE TOLERANCE LEVEL FOR CHECKING BADS- FUNCTION OF AVG. SPEED - DLIM = 2.5 - IF(SBAR.GT.70.) DLIM = DLIM + ((SBAR - 70.) * 0.02857) -C START LOGIC TREE CHECK - IF(DIFF.GT.DLIM) THEN -C -C NOTE: IN GENERAL, ALL THE CALC. FOR NEW IPOINT AND JPOINT IN THE IF -C BLOCKS BELOW ARE NEEDED ONLY IF ONE OF THE LOOPS ENDS UP GOING INTO -C THE TOSSKEY=2 OR 3 IF BLOCKS IN THE NEXT ELSE BLOCK .... -C ---> ELSE IF(DIFF.GT.2.5.AND.ICDIF1.EQ.0) THEN -C THIS NEXT ELSE BLOCK CAN ONLY BE ATTAINED IF SBAR > 70 AND DIFF IS -C BETWEEN 2.5 AND SOME NUMBER NOT MUCH LARGER THAN 2.5 -- SELDOM -C OCCURS AND WHEN IT DOES, NEXT IF TEST IS ALMOST NEVER SATISFIED -C -- OTHERWISE DLIM IS 2.5 AND THE FIRST ELSE BLOCK ALWAYS ENTERED -C - PRINT 177, DIFF,DLIM,SBAR,ICHK1,IMAXJ,ICHK2,IMAXK,IPOINT,JPOINT - 177 FORMAT(' FOR SHEAR & NUMT> 3: DIFF=',F6.1,', DLIM=',F5.1, - $ ', SBAR=',F5.1,', ICHK1=',I3,', IMAXJ=',I3,', ICHK2=',I3, - $ ', IMAXK=',I3,', IPOINT=',I3,', JPOINT=',I3) - IF(ICHK1.EQ.IMAXJ.OR.ICHK1.EQ.IMAXK) THEN - KBAD(ICHK1) = 0 - ITOSSK = 0 - PRINT 152, ITOSSK,LOOP,ICHK1 - IF(LOOP.EQ.4) RETURN - VPOINT(ICHK1) = -999.0 - GO TO 1010 - ELSE IF(ICHK2.EQ.IMAXJ.OR.ICHK2.EQ.IMAXK) THEN - KBAD(ICHK2) = 0 - ITOSSK = 1 - PRINT 152, ITOSSK,LOOP,ICHK2 - IF(LOOP.EQ.4) RETURN - VPOINT(ICHK2) = -999.0 - GO TO 1010 - END IF - ELSE IF(DIFF.GT.2.5.AND.ICDIF1.EQ.0) THEN -CVVVVV%%%%% - PRINT *,'~~~~~ DIFF .GT. 2.5 AMD ICDIF1.EQ.0' -CAAAAA%%%%% - PRINT 3177, DIFF,DLIM,SBAR,ICHK3,IMAXJ,IMAXK,IPOINT,JPOINT,ICDIF1 - 3177 FORMAT(' FOR SHEAR & NUMT> 3: DIFF=',F6.1,', DLIM=',F5.1, - $ ', SBAR=',F5.1,', ICHK3=',I3,', IMAXJ=',I3,', IMAXK=',I3, - $ ', IPOINT=',I3,', JPOINT=',I3,', ICDIF1=',I3) - IF((ICHK3.EQ.IMAXJ.AND.ICHK3.EQ.IPOINT).OR. - $ (ICHK3.EQ.IMAXK.AND.ICHK3.EQ.IPOINT)) THEN -CVVVVV%%%%% - PRINT *,'~~~~~ TOSSKEY=2 FOUND!!' -CAAAAA%%%%% - KBAD(ICHK3) = 0 - ITOSSK = 2 - PRINT 152, ITOSSK,LOOP,ICHK3 - IF(LOOP.EQ.4) RETURN - VPOINT(ICHK3) = -999.0 - GO TO 1010 - ELSE IF((ICHK3.EQ.IMAXJ.AND.ICHK3.EQ.JPOINT).OR. - $ (ICHK3.EQ.IMAXK.AND.ICHK3.EQ.JPOINT)) THEN -CVVVVV%%%%% - PRINT *,'~~~~~ TOSSKEY=3 FOUND!!' -CAAAAA%%%%% - KBAD(ICHK3) = 0 - ITOSSK = 3 - PRINT 152, ITOSSK,LOOP,ICHK3 - RETURN - END IF - END IF - ELSE IF(NUMT.GT.1) THEN -C----------------------------------------------------------------------- -C ONLY TWO OR THREE OBSERVATIONS IN THE STACK CAN BE EVALUATED - PRNTA = .FALSE. - ITOSSK = -99 - IF((CHKSUM(ICHK1)-CHKSUM(ICHK2)).GT.3) THEN - KBAD(ICHK1) = 0 - ITOSSK = 4 - PRNTA = .TRUE. - ELSE IF(DIFF.GT.9.) THEN - KBAD(ICHK1) = 0 - ITOSSK = 5 - PRNTA = .TRUE. - END IF - IF(PRNTA) THEN - PRINT 136, (COUNT(I),I=1,NUM) - PRINT 138, (LOUNT(I),I=1,NUM) - PRINT 139, (GOUNT(I),I=1,NUM) - PRINT 158, ICHK1,ICHK2,(CHKSUM(I),I=1,NUM) - PRINT 9177, DIFF,ICHK1,ICHK2 - 9177 FORMAT(' FOR SHEAR & NUMT< 4: DIFF=',F6.1,', ICHK1=',I6, - $ '; ICHK2=',I6) - PRINT 149, ITOSSK,ICHK1 - END IF -C----------------------------------------------------------------------- - END IF - END IF - 136 FORMAT(' SHEAR CHKSUM',29X,24I3) - 138 FORMAT(' ONLVL CHKSUM',29X,24I3) - 139 FORMAT(' OBSINCCHKSUM',29X,24I3) - 148 FORMAT(' SUM RANK(1ST 3)',3I4,' SUM CHKSUMS ',24I3) - 158 FORMAT(' SUM RANK(1ST 2)',2I4,4X,' SUM CHKSUMS ',24I3) - 9136 FORMAT(' SHEAR CHKSUM',/,40I3) - 9138 FORMAT(' ONLVL CHKSUM',/,40I3) - 9139 FORMAT(' OBSINCCHKSUM',/,40I3) - 9148 FORMAT(' SUM RANK(1ST 3)',3I4,' SUM CHKSUMS ',/,40I3) - 149 FORMAT(' FOR NUMT< 4 TOSSKEY IS ',I4,' TOSSES #',I4) - 152 FORMAT(' TOSSKEY IS ',I4,' LOOP ',I3,' TOSSES #',I4) - RETURN - 999 CONTINUE - PRINT 200, K,J,TIMDIF,ALTDIF - 200 FORMAT(' DISASTER AT ',2I4,2F8.0) - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: LAPSE CHECKS TEMPERATURES WITH LAPSE-RATE CHECK -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1994-08-25 -C -C ABSTRACT: DOES TEMPERATURE CHECK BOTH AT SAME AND AT DIFFERENT -C LEVELS AND ASSIGNS DIGITAL FLAGS DEPENDING UPON THE MAGNITUDES -C COMPARED WITH POSSIBLE LAPSE RATES. THERE MUST BE AT LEAST THREE -C HIGH-ALTITUDE OBS. IN STACK FOR THIS CHECK TO BE PERFORMED. -C -C PROGRAM HISTORY LOG: -C 1993-01-05 P. JULIAN -- ORIGINAL AUTHOR -C 1994-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND -C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT -C -C USAGE: CALL LAPSE(NUM,INDX) -C INPUT ARGUMENT LIST: -C NUM - NUMBER OF OBSERVATIONS TO BE TREATED -C INDX - POINTER TO POSITION IN ORIGINAL AIRCRAFT ARRAY -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C REMARKS: CALLED BY SUBROUTINE 'PRELIM'. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE LAPSE(NUM,INDX) - PARAMETER (IRMX= 80000, ISMX= 8000) - LOGICAL PRNTT - CHARACTER*8 ACID,SAID - CHARACTER*14 TAG - INTEGER COUNT(ISMX),LOUNT(ISMX),CHKSUM(ISMX),INDR(ISMX) - REAL TABLE(7,7) - COMMON/SUMDAT/ISTCPT(ISMX),SAID(ISMX),SLAT(ISMX),SLON(ISMX), - $ SHGT(ISMX),STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX), - $ KBAD(ISMX),NUMORG,SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX) - COMMON/ALLDAT/IFLEPT(IRMX),ACID(IRMX),ALAT(IRMX),ALON(IRMX), - $ AALT(IRMX),TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE, - $ ATMP(IRMX),TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX), - $ ITEVNT(IRMX),IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX), - $ ADIRF(IRMX) -C LAPSE RATE CHECK (TABLE(IALT,ITIM),ITIM=1,6)/ DEG.C/KM / - DATA(TABLE(1,ITIM),ITIM=1,7)/-12.,-12.,-13.,-13.,-13.,-14.,-14./ - DATA(TABLE(2,ITIM),ITIM=1,7)/-12.,-12.,-13.,-13.,-13.,-14.,-14./ - DATA(TABLE(3,ITIM),ITIM=1,7)/-12.,-12.,-13.,-14.,-14.,-15.,-15./ - DATA(TABLE(4,ITIM),ITIM=1,7)/-12.,-12.,-13.,-14.,-14.,-15.,-15./ - DATA(TABLE(5,ITIM),ITIM=1,7)/-13.,-13.,-14.,-14.,-14.,-15.,-16./ - DATA(TABLE(6,ITIM),ITIM=1,7)/-13.,-13.,-14.,-15.,-15.,-16.,-16./ - DATA(TABLE(7,ITIM),ITIM=1,7)/-14.,-14.,-15.,-15.,-15.,-16.,-16./ -C CALIBX IS ADJUSTABLE CONSTANT FOR ON-LEVEL DIFFERENCE CHECK - CALIBX = 0.70 -C START OF CHECKING AND TOSSING (NO ITERATION - ONLY ONCE THROUGH) -C COUNT IS INTEGER SUM OF QUALITY UNITS FOR OFF-LEVEL(LAPSE) CHECKS -C LOUNT IS SAME BUT FOR ON-LEVEL CHECKS - COUNT(1:NUM) = 0 - LOUNT(1:NUM) = 0 - CHKSUM(1:NUM) = -99 - DIFF = 0.0 - PRNTT = .TRUE. - DO K = 1,NUM - IF(STMP(K).GT.100.) GO TO 1 - IMAXK = 0 - ISUPK = 0 - KNDX = INDX + K - 1 - IF(IFLEPT(KNDX).GT.0.AND.KBAD(K).GT.0) THEN - DO J = K+1,NUM - IF(STMP(J).GT.100.) GO TO 2 - QUAN = 0.0 - QTDF = 0.0 - CHEK = 0.0 - CHEC = 0.0 - IMAXJ = 0 - ISUPJ = 0 - JNDX = INDX + J - 1 - IF(IFLEPT(JNDX).LE.0.OR.KBAD(J).LE.0) GO TO 2 - TIMDIF = ABS(TIME(JNDX)-TIME(KNDX)) * .01 - ALTDIF = ABS(AALT(JNDX)-AALT(KNDX)) - IALT = (ALTDIF + 50.) * 0.001637 - ITIM = MAX0(1,NINT(TIMDIF)) - IF(IALT.GT.9.OR.ITIM.GT.7) GO TO 999 - IF(IALT.LE.0) THEN -C ON-LEVEL CHECK - QUAN = ABS(STMP(K)-STMP(J)) * 0.1 -C CALIBX=0.70 IS ADJUSTABLE CONSTANT FOR ON-LEVEL DIFFERENCE CHECK - CHEK = 2.5 + (TIMDIF * CALIBX) - IF((QUAN-CHEK).GT.DIFF) DIFF = QUAN - CHEK - IF(QUAN.LT.0.25*CHEK) THEN - LOUNT(K) = LOUNT(K) - 2 - LOUNT(J) = LOUNT(J) - 2 - ELSE IF(QUAN.LT.0.5*CHEK) THEN - LOUNT(K) = LOUNT(K) - 1 - LOUNT(J) = LOUNT(J) - 1 - ELSE IF(QUAN.GT.CHEK) THEN - IMAXJ = J - IMAXK = K - IFPC = QUAN/CHEK + 1.0 - LOUNT(K) = IFPC + LOUNT(K) - LOUNT(J) = IFPC + LOUNT(J) - END IF - ELSE -C OFF-LEVEL CHECK - QQQ = AALT(KNDX) - AALT(JNDX) - QTDF = ((STMP(K) - STMP(J)) * 0.1)/(QQQ * .001) - IF(IALT.GT.5) GO TO 2 - CHEC = TABLE(IALT,ITIM) - IF((ABS(QTDF)-ABS(CHEC)).GT.DIFF)DIFF=ABS(QTDF)-ABS(CHEC) - IF((QTDF-CHEC).LT.0.0) THEN -C LAPSE CHECK - ISUPJ = J - ISUPK = K - IF(QTDF.LT.1.3*CHEC) THEN - COUNT(K) = COUNT(K) + 4 - COUNT(J) = COUNT(J) + 4 - ELSE IF(QTDF.LT.1.15*CHEC) THEN - COUNT(K) = COUNT(K) + 2 - COUNT(J) = COUNT(J) + 2 - ELSE IF(QTDF.LT.CHEC) THEN - COUNT(K) = COUNT(K) + 1 - COUNT(J) = COUNT(J) + 1 - END IF - END IF -C INVERSION CHECK - IF(QTDF.GT.16.0) THEN - COUNT(K) = COUNT(K) + 4 - COUNT(J) = COUNT(J) + 4 - ELSE IF(QTDF.GT.10.0) THEN - COUNT(K) = COUNT(K) + 2 - COUNT(J) = COUNT(J) + 2 - END IF - END IF - CHKSUM(J) = LOUNT(J) + COUNT(J) - CHKSUM(K) = LOUNT(K) + COUNT(K) - IF(IMAXJ.NE.0.OR.ISUPJ.NE.0) THEN - IF(DIFF.GT.4.0) THEN - IF(PRNTT) THEN - PRINT 161 - 161 FORMAT(' LAPSE/ ONLVL INDX STABE INDX ALTDIF TIMDIF TDIF ', - $ ' CHEK LAPSERATE CHEC') - PRNTT = .FALSE. - END IF - PRINT 401, IMAXJ,IMAXK,ISUPJ,ISUPK,ALTDIF,TIMDIF, - $ QUAN,CHEK,QTDF,CHEC - 401 FORMAT(' ',4I6,F8.0,F8.2,4F9.1) - END IF - END IF - 2 CONTINUE - ENDDO - END IF - 1 CONTINUE - ENDDO - IF(DIFF.GT.4.0) THEN - IF(NUM.GT.0) CALL INDEXF(NUM,CHKSUM,INDR) -C HOW MANY OBS. DO WE ACTUALLY HAVE TO EVALUATE (NUMT) ? -C (THERE MUST BE AT LEAST THREE) - NUMT = 0 - DO I = 1,NUM - IF(CHKSUM(I).GT.-99) NUMT = NUMT + 1 - ENDDO - ICHK1 = INDR(NUM) - ICHK2 = INDR(NUM-1) - ICHK3 = INDR(NUM-2) - ICDIF2 = CHKSUM(ICHK2) - CHKSUM(ICHK3) - ICHK4 = 0 -C********************************************************************** -C LOGIC TREE FOR DECIDING WHATS WRONG - NO ITERATION HERE (ONCE ONLY) -C********************************************************************** - IF(NUMT.GT.3) THEN -C---------------------------------------------------------------------- -C FOUR OR MORE OBSERVATIONS IN THE STACK CAN BE EVALUATED - ICHK4 = INDR(NUM-3) - ICDIF3 = CHKSUM(ICHK3) - CHKSUM(ICHK4) - IF(NUM.LE.24) THEN - PRINT 136, (COUNT(I),I=1,NUM) - PRINT 138, (LOUNT(I),I=1,NUM) - PRINT 148, ICHK1,ICHK2,ICHK3,(CHKSUM(I),I=1,NUM) - ELSE - PRINT 9136, (COUNT(I),I=1,NUM) - PRINT 9138, (LOUNT(I),I=1,NUM) - PRINT 9148, ICHK1,ICHK2,ICHK3,(CHKSUM(I),I=1,NUM) - END IF - PRINT 177, DIFF,CHKSUM(ICHK1),CHKSUM(ICHK2),ICDIF2,ICDIF3 - 177 FORMAT(' FOR LAPSE & NUMT> 3: DIFF=',F6.1,', CHKSUM(ICHK1)=',I6, - $ ', CHKSUM(ICHK2)=',I6,', ICDIF2=',I6,', ICDIF3=',I6) - IF(CHKSUM(ICHK1).GE.7.AND.CHKSUM(ICHK2).GE.7) THEN - KBAD(ICHK1) = 0 - KBAD(ICHK2) = 0 - I1TOSS = ICHK1 - I2TOSS = ICHK2 - ITOSSK = 0 - PRINT 149, ITOSSK,I1TOSS,I2TOSS - ELSE IF(CHKSUM(ICHK1).GE.6.AND.ICDIF2.LT.5.AND.ICDIF3.LT.5) THEN - KBAD(ICHK1) = 0 - I1TOSS = ICHK1 - ITOSSK = 1 - PRINT 1149, ITOSSK,I1TOSS - 1149 FORMAT(' FOR NUMT> 3 TOSSKEY IS ',I4,' TOSSES #',I4) - ELSE IF(CHKSUM(ICHK1).GE.6.AND.ICDIF2.GE.5) THEN - KBAD(ICHK1) = 0 - KBAD(ICHK2) = 0 - I1TOSS = ICHK1 - I2TOSS = ICHK2 - ITOSSK = 2 - PRINT 149, ITOSSK,I1TOSS,I2TOSS - END IF - ELSE IF(NUMT.EQ.3) THEN -C---------------------------------------------------------------------- -C ONLY THREE OBSERVATIONS IN THE STACK CAN BE EVALUATED - ICDIF1 = CHKSUM(ICHK1) - CHKSUM(ICHK2) - PRINT 136, (COUNT(I),I=1,NUM) - PRINT 138, (LOUNT(I),I=1,NUM) - PRINT 148, ICHK1,ICHK2,ICHK3,(CHKSUM(I),I=1,NUM) - PRINT 9177, DIFF,ICDIF1,ICDIF2 - 9177 FORMAT(' FOR LAPSE & NUMT= 3: DIFF=',F6.1,', ICDIF1=',I6, - $ ', ICDIF2=',I6) - IF(ICDIF1.GT.4.AND.ICDIF2.LT.2) THEN - KBAD(ICHK1) = 0 - I1TOSS = ICHK1 - ITOSSK = 3 - PRINT 147, ITOSSK,I1TOSS - ELSE IF(DIFF.GT.2.9) THEN - KBAD(ICHK1) = 0 - I1TOSS = ICHK1 - ITOSSK = 4 - PRINT 147, ITOSSK,I1TOSS - END IF -C---------------------------------------------------------------------- - END IF - END IF - 136 FORMAT(' STABIL (LAPSE) CHKSUM',20X,24I3) - 138 FORMAT(' ONLVL CHKSUM ',20X,24I3) - 148 FORMAT(' SUM RANK(1ST 3)',3I4,' SUM CHKSUMS ',24I3) - 9136 FORMAT(' STABIL (LAPSE) CHKSUM',/,40I3) - 9138 FORMAT(' ONLVL CHKSUM ',/,40I3) - 9148 FORMAT(' SUM RANK(1ST 3)',3I4,' SUM CHKSUMS ',/,40I3) - 147 FORMAT(' FOR NUMT= 3 TOSSKEY IS ',I4,' TOSSES #',I4) - 149 FORMAT(' FOR NUMT> 3 TOSSKEY IS ',I4,' TOSSES #',I4,' &',I4) - RETURN - 999 CONTINUE - PRINT 200, K,J,TIMDIF,ALTDIF - 200 FORMAT(' DISASTER AT ',2I4,2F8.0) - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: AVEROB COMPUTES SIMPLE AVG. OF WINDS (SUPEROB) -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1995-03-27 -C -C ABSTRACT: COMPUTES SIMPLE AVERAGE VECTOR WIND FOR ALL OBSERVATIONS -C MEETING SPECIFIED TOLERANCES IN ALTITUDE, TIME, AND VECTOR -C DIFFERENCE. THESE OBSERVATIONS ARE SUPEROBS. -C -C PROGRAM HISTORY LOG: -C 1989-04-01 P. JULIAN (W/NMC00) -- ORIGINAL AUTHOR -C 1990-06-14 D. A. KEYSER -- CORRECTED TO HONOR ALL SDM/QCAIRCFT PURGES -C FOR STACKED OBS.; FIXED ERROR IN Q. MARK DESIGNATOR -C 1990-07-03 D. A. KEYSER -- SOME OMIT Q.M. INCORRECTLY CHANGED BACK -C TO 'N' OR 'C', FIXED -C 1993-01-05 P. JULIAN -- MINOR CHNAGES TO REFLECT USE OF SCALED INCRS -C 1994-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND -C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT -C 1995-03-27 D. A. KEYSER -- FOR INIDST=2, SUPEROBS NOW CONTAIN -C SUPEROBED FORECAST(GUESS) P-ALT, WIND DIR, WIND SPEED & -C TEMP (IF AVAILABLE FROM INDIV. RPTS MAKING UP SUPEROBS) -C -C USAGE: CALL AVEROB(NUM,INDX,LK) -C INPUT ARGUMENT LIST: -C NUM - NUMBER OF OBSERVATIONS TO BE TREATED -C INDX - POINTER TO POSITION IN ORIGINAL AIRCRAFT ARRAY -C -C OUTPUT ARGUMENT LIST: -C LK - POINTER INDICATING ' NUM + NO. OF AVERAGES FORMED ' -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C REMARKS: CALLED BY SUBROUTINE 'SUPROB'. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE AVEROB(NUM,INDX,LK) - PARAMETER (IRMX= 80000, ISMX= 8000) - LOGICAL EWRITE - CHARACTER*8 ACID,SAID - CHARACTER*14 TAG - INTEGER SUPMRK(ISMX) - COMMON/SUMDAT/ISTCPT(ISMX),SAID(ISMX),SLAT(ISMX),SLON(ISMX), - $ SHGT(ISMX),STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX), - $ KBAD(ISMX),NUMORG,SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX) - COMMON/ALLDAT/IFLEPT(IRMX),ACID(IRMX),ALAT(IRMX),ALON(IRMX), - $ AALT(IRMX),TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE, - $ ATMP(IRMX),TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX), - $ ITEVNT(IRMX),IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX), - $ ADIRF(IRMX) - COMMON/CMPNTS/U(ISMX),V(ISMX),UF(ISMX),VF(ISMX) - COMMON/STWRIT/SWRITE,EWRITE,IWRITE - DATA XMSG/99999./ - NUMGT = MAX0(NUMORG,NUM) - LK = NUMGT - NOOK = 0 - DO K = 1,NUM - JNDX = INDX + K - 1 - IF(KBAD(K).EQ.0) ISTCPT(K) = 0 -C ASK PAUL: IS BELOW LOGIC CORRECT?? - IF(IFLEPT(JNDX).NE.0.OR.ISTCPT(K).NE.0.OR.TAG(JNDX)(4:4).NE. - $ 'F') THEN - NOOK = NOOK + 1 - ELSE - KBAD(K) = 0 - END IF -CCCCC PRINT 1315, K,JNDX,IFLEPT(JNDX),ISTCPT(K),(TAG(JNDX)(II:II), -CCCCC$ II=2,4,2) -C1315 FORMAT(' AVEROB K,JNDX,IFLEPT,ISTCPT,QFS',4I5,2X,A1,2X,A1) - ENDDO - IF(NOOK.EQ.2) THEN - CALL NOEQ2(NUM,INDX,LK) - RETURN - END IF - SUPMRK = 65 - DO K = 1,NUM - JNDX = INDX + K - 1 -C ASK PAUL: IS BELOW LOGIC CORRECT?? - IF(IFLEPT(JNDX).GT.0.OR.ISTCPT(K).GT.0.AND.TAG(JNDX)(4:4).NE. - $ 'F') THEN - IF(SUPMRK(K).GT.K) THEN - SUPMRK(K) = K - DO KK = K+1,NUM - KNDX = INDX + KK - 1 -C ASK PAUL: IS BELOW LOGIC CORRECT?? - IF(IFLEPT(KNDX).GT.0.OR.ISTCPT(KK).GT.0.AND. - $ TAG(JNDX)(4:4).NE.'F') THEN - ALTDIF = ABS(AALT(JNDX)-AALT(KNDX)) - TIMDIF = ABS(TIME(JNDX)-TIME(KNDX)) - VECDIF = SQRT((U(K)-U(KK))**2 + (V(K)-V(KK))**2) - IF(ALTDIF.LT.150..AND.TIMDIF.LT.550..AND.VECDIF.LT. - $ 16.0) SUPMRK(KK) = K - END IF - ENDDO - END IF - END IF - ENDDO - DO K = 1,NUM - KNDX = INDX + K - 1 - IF(ISTCPT(K).NE.0) THEN - SUMU = 0.0 - SUMV = 0.0 - SUMS = 0.0 - SUMT = 0.0 - SUMTMP = 0.0 - KOUNTM = 0 - SUMUF = 0.0 - SUMVF = 0.0 - SUMSF = 0.0 - SUMTMF = 0.0 - KOUNTF = 0 - KOUNWF = 0 - KOUNT = 0 - DO KK = K,NUM - JNDX = INDX + KK - 1 - IF(SUPMRK(KK).EQ.K.AND.ISTCPT(KK).NE.0) THEN - SUMU = SUMU + U(KK) - SUMV = SUMV + V(KK) - SUMS = SUMS + SSPD(KK) - SUMT = TIME(JNDX) + SUMT - IF(AMAX1(UF(KK),VF(KK),SSPDF(KK)).LT.XMSG) THEN - SUMUF = SUMUF + UF(KK) - SUMVF = SUMVF + VF(KK) - SUMSF = SUMSF + SSPDF(KK) - KOUNWF = KOUNWF + 1 - END IF - IF(TAG(JNDX)(2:2).NE.'F'.AND.ATMP(JNDX).LT.XMSG) THEN - SUMTMP = ATMP(JNDX) + SUMTMP - KOUNTM = KOUNTM + 1 - IF(ATMPF(JNDX).LT.XMSG) THEN - SUMTMF = ATMPF(JNDX) + SUMTMF - KOUNTF = KOUNTF + 1 - END IF - END IF - KOUNT = KOUNT + 1 - END IF -CCCCC PRINT 2215,K,JNDX,IFLEPT(JNDX),KK,KNDX,IFLEPT(KNDX),KOUNT -C2215 FORMAT(' TEST K,JNDX,IFLEPT,KK,KNDX,IFLEPT ',7I6) - ENDDO - IF(KOUNT.GT.1) THEN -C THERE IS AT LEAST ONE OTHER REPORT AT THE SAME LEVEL - SUMU = SUMU/KOUNT - SUMV = SUMV/KOUNT - SUMS = SUMS/KOUNT - TBAR = SUMT/KOUNT - LK = LK + 1 - SSPD(LK) = SUMS - SDIR(LK) = AVEDIR(SUMU,SUMV,SUMS) - SHGT(LK) = AALT(KNDX) - SSPDF(LK) = XMSG - SDIRF(LK) = XMSG - IF(KOUNWF.GT.1) THEN - SSPDF(LK) = SUMSF/KOUNWF - SDIRF(LK) = AVEDIR(SUMUF/KOUNWF,SUMVF/KOUNWF,SUMSF/KOUNWF) - END IF - STMP(LK) = XMSG - STMPF(LK) = XMSG - IF(KOUNTM.GT.1) THEN - STMP(LK) = SUMTMP/KOUNTM - IF(KOUNTF.GT.1) STMPF(LK) = SUMTMF/KOUNTF - END IF - SHGTF(LK) = AALTF(KNDX) - SLAT(LK) = ALAT(KNDX) - SLON(LK) = ALON(KNDX) - STIM(LK) = TBAR - ISTCPT(LK) = KOUNT - CTEMP = STMP(LK) - IF(STMP(LK).LT.XMSG) CTEMP = STMP(LK)/10. - CTMPF = STMPF(LK) - IF(STMPF(LK).LT.XMSG) CTMPF = STMPF(LK)/10. - PRINT 6427, LK,KOUNT,NINT(SDIR(LK)),SSPD(LK), - $ CTEMP+SIGN(.0005,CTEMP),NINT(SHGT(LK)),NINT(STIM(LK)), - $ NINT(SDIRF(LK)),SSPDF(LK),CTMPF+SIGN(.0005,CTMPF),NINT(SHGTF(LK)) - 6427 FORMAT(' SUPROB(AVEROB)',I3,',KOUNT=',I3,',DIR/SPD=',I3,'/',F5.1, - $ ',TMP=',F7.1,',ALT=',I5,',TIME=',I4,',GES: DIR/SPD=',I5,'/',F7.1, - $ ',TMP=',F7.1,',ALT=',I5) - END IF - IF(SUPMRK(K).EQ.65) IFLEPT(KNDX) = MIN0(IFLEPT(KNDX),0) - END IF - ENDDO - IF(LK.GT.NUMGT) THEN - DO K = 1,NUM-1 - KNDX = INDX + K - 1 - DO KK = K+1,NUM - JNDX = INDX + KK - 1 - IF(SUPMRK(KK).EQ.SUPMRK(K)) THEN - IF(TAG(KNDX)(14:14).GT.'4') THEN - IF(EWRITE) PRINT 9024, KNDX,ACID(KNDX),ALAT(KNDX), - $ ALON(KNDX),TIME(KNDX),TAG(KNDX) - 9024 FORMAT(/' #EVENT 315: AVEROB; OMIT WIND(S-OB), WND QM SET TO "O"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KNDX)(4:4) = 'O' - TAG(KNDX)(14:14) = '4' - IWEVNT(KNDX) = 315 - END IF - IF(TAG(JNDX)(14:14).GT.'4') THEN - IF(EWRITE) PRINT 9024, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - TAG(JNDX)(4:4) = 'O' - TAG(JNDX)(14:14) = '4' - IWEVNT(JNDX) = 315 - END IF - IF(TAG(KNDX)(13:13).GT.'4') THEN - IF(EWRITE) PRINT 9025, KNDX,ACID(KNDX),ALAT(KNDX), - $ ALON(KNDX),TIME(KNDX),TAG(KNDX) - 9025 FORMAT(/' #EVENT 315: AVEROB; OMIT TEMP(S-OB), TMP QM SET TO "O"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KNDX)(2:2) = 'O' - TAG(KNDX)(13:13) = '4' - ITEVNT(KNDX) = 315 - END IF - IF(TAG(JNDX)(13:13).GT.'4') THEN - IF(EWRITE) PRINT 9025, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - TAG(JNDX)(2:2) = 'O' - TAG(JNDX)(13:13) = '4' - ITEVNT(JNDX) = 315 - END IF - END IF - ENDDO - ENDDO - END IF - PRINT 7070, (SUPMRK(M),M=1,NUM) - PRINT 7071, (KBAD(M),M=1,NUM) - 7070 FORMAT(' FROM AVEROB, SUPMRK = ',21I5) - 7071 FORMAT(' FROM AVEROB, KBAD = ',21I5) - IF(NUM.LT.NUMORG) THEN - DO K = 1,NUMORG - KNDX = INDX + K - 1 - ISTCPT(K) = IFLEPT(KNDX) - ENDDO - END IF - NUM = NUMGT - NUMORG = 0 - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FORSDM WRITES FLAGGED OR LARGE INCR. ISOL. RPTS -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2002-11-20 -C -C ABSTRACT: WRITES ALL ISOLATED REPORTS CONTAINING A WIND WHICH HAS -C BEEN FLAGGED FOR NON-USE TO A TEXT FILE WHICH THE SDM CAN EXAMINE. -C ALSO WRITES ALL ISOLATED REPORTS WITH LARGE INCREMENTS, REGARDLESS -C OF QUALITY MARKER. THIS ALLOWS THE SDM TO USE SDMEDIT TO 'KEEP' -C ANY OF THESE REPORTS IN THE NEXT NETWORK RUN. AIREP/PIREP REPORTS -C WITHIN THE CONTINENTAL U.S. ARE EXCLUDED FROM THE WRITE IF IFLGUS=1 -C OR 2 AND KTACAR > 1. -C -C PROGRAM HISTORY LOG: -C 1993-01-05 P. JULIAN -- NEW SUBPROGRAM -C 1994-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND -C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT -C 1998-02-17 D. A. KEYSER -- IMPROVED PRINT IN SDMACQC FILE IN UNIT 52 -C 2002-11-20 D. A. KEYSER -- SINCE HAVE REMOVED ASSUMPTION THAT AN SDM -C PURGE ON TEMP ONLY ALSO RESULTS IN AN SDM PURGE ON WIND -C AS WELL AS THE RELATIONSHIP BETWEEN AN SDM KEEP ON WIND -C VS. A KEEP ON TEMP (THEY ARE INDENDENDENT OF EACH OTHER), -C NOW TESTS BOTH BYTE 2 AND 4 OF TAG FOR "P" OR "H" RATHER -C THAN JUST BYTE 1 OF TAG {WHICH NOW CAN NEVER HAVE AN "H" -C AND WILL ONLY HAVE A "P" IF WIND (AND THUS ALSO TEMP VIA -C ACTIONS OF PREVIOUS PREPOBS_PREPACQC PROGRAM} IS PURGED} -C -C USAGE: CALL FORSDM(INDX) -C INPUT ARGUMENT LIST: -C INDX - POINTER TO POSITION IN ORIGINAL AIRCRAFT ARRAY -C -C OUTPUT FILES: -C UNIT 52 - TEXT FILE FOR SDM PERUSAL (LIST OF ISOLATED REPORTS -C - THAT ARE FLAGGED FOR NON-USE BY THIS PROGRAM AS WELL -C - AS THOSE WITH LARGE INCREMENTS) -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE FORSDM(INDX) - PARAMETER (IRMX= 80000) - CHARACTER*1 CTG,CLON,C1,CH1(9) - CHARACTER*8 ACID - CHARACTER*14 TAG - INTEGER ICH1(9) - COMMON/TSTACAR/KTACAR - COMMON/INPT/DOSPOB,DOACRS,TMAXO,TMINO,TIMINC,WAYPIN,INIDST,IFLGUS, - $ JAMASS(6),JAWIND(6),RCPTST - COMMON/MASK/GDNH(362,91),GDSH(145,37),GDUS(362,91) - COMMON/ALLDAT/IFLEPT(IRMX),ACID(IRMX),ALAT(IRMX),ALON(IRMX), - $ AALT(IRMX),TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE, - $ ATMP(IRMX),TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX), - $ ITEVNT(IRMX),IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX), - $ ADIRF(IRMX) - DATA CH1 /'Q','R','S','T','U','V','W','X','Y'/ - DATA ICH1 /10, 20, 30, 40, 50, 60, 70, 80, 90 / -C -C NOTE: ALL CONV'L AIREP/PIREP (NOT ASDAR/AMDAR/TAMDAR) RPTS OVER CONUS -C (DEFINED AS CONTINENTAL U.S, SO. ONTARIO AND THE GULF OF MEXICO NORTH -C OF 25 DEG. N LAT) WILL BE EXCLUDED FROM ALL NCEP ANALYSES IF: -C IFLGUS= 1 OR 2 & KTACAR>1. BASED ON THESE SWITCHES, THIS SUBR. MAY -C CHECK FOR OBS. OVER THIS REGION AND NOT WRITE ANY FLAGGED REPORTS TO -C THE SDM TEXT FILE HERE -C - IF((TAG(INDX)(1:1).GE.'U'.AND.TAG(INDX)(1:1).LE.'Z').OR. - $ TAG(INDX)(4:4).EQ.'F') THEN - IF(NINT(ALAT(INDX)).GT.0.AND.TAG(INDX)(7:7).NE.'Z'.AND. - $ IFLGUS.GT.0) THEN - IF(KTACAR.GT.1) THEN - KXI = (360.0 - ALON(INDX)) + 0.005 + 1.0 - KYJ = ALAT(INDX) + 1.0 - IF(KYJ.LT.91.AND.(GDUS(KXI,KYJ).GT.0.5.OR.GDUS(KXI+1,KYJ).GT.0.5 - $ .OR.GDUS(KXI,KYJ+1).GT.0.5.OR.GDUS(KXI+1,KYJ+1).GT.0.5)) RETURN - END IF - END IF -C SKIP WRITING OF ANY FLAGGED REPORTS OUTSIDE REQUESTED TIME WINDOW - IF(TIME(INDX).LT.TMINO.OR.TIME(INDX).GT.TMAXO) RETURN -C WRITE SDM WINDS W/ VECTOR INCR. U-Z OR FLAGGED BY THIS PROGRAM; SCALE -C BASED ON VALUE OF SCALED INCREMENT CHARACTER Q-Z, IF INCREMENT NOT -C AVAIL. SCALE SET TO MSG - SCALE = 99999. - IF(TAG(INDX)(1:1).GE.'Q'.AND.TAG(INDX)(1:1).LE.'Z') THEN - CTG = TAG(INDX)(1:1) - SCALE = 100.0 - DO I=1,9 - IF(CTG.EQ.CH1(I)) THEN - SCALE = ICH1(I) - EXIT - END IF - ENDDO - END IF - IF(AALT(INDX).LE.11000.) THEN - PRALT = 1013.25 * - $ (((288.15 - (.0065*AALT(INDX)))/288.15)**5.256) - ELSE - PRALT = 226.3 * EXP(1.576106E-4*(11000.-AALT(INDX))) - END IF - QTIME = MOD(TIME(INDX),2400.) - QTEMP = 99999. - IF(ATMP(INDX).LT.99999.) QTEMP = ATMP(INDX) * 0.1 - QLON = ALON(INDX) - CLON = 'W' - IF(NINT(QLON).GT.180) THEN - QLON = (360. - QLON) - CLON = 'E' - END IF - C1 = '-' -ccccc IF(TAG(INDX)(1:1).EQ.'H'.OR.TAG(INDX)(1:1).EQ.'P') -ccccc$ C1 = TAG(INDX)(1:1) - IF(TAG(INDX)(4:4).EQ.'H'.OR.TAG(INDX)(2:2).EQ.'H' .OR. - $ TAG(INDX)(4:4).EQ.'P'.OR.TAG(INDX)(2:2).EQ.'P') - $ C1 = 'Y' - WRITE(52,25) ACID(INDX),ALAT(INDX),QLON,CLON,QTIME,PRALT, - $ QTEMP,ADIR(INDX),ASPD(INDX),SCALE,C1,TAG(INDX)(4:4), - $ TAG(INDX)(2:2) - 25 FORMAT(' ',A8,2F8.2,A1,3F7.0,F6.0,F7.1,F7.0,3(4X,A1)) - END IF - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: RPACKR PREPARES OBS. FOR PACKING -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2007-10-17 -C -C ABSTRACT: PREPARES OBSERVATIONS FOR FINAL PACKING TO OUTPUT FILE. -C FINAL CHECK TO REMOVE DUPLICATES, FINAL ASSIGNMENT OF TEMPERATURE -C AND WIND QUALITY MARKERS (IF APPLICABLE) AND ACCUMULATION OF NEW -C SUPEROBS IN HOLDING ARRAYS (IF APPLICABLE). -C -C PROGRAM HISTORY LOG: -C 1989-04-01 P. JULIAN (W/NMC00) -- ORIGINAL AUTHOR -C 1990-04-16 P. JULIAN -- MODIFIED TO PACK SUPEROBS ONE AT A -C TIME ON SINGLE LEVELS ONLY -C 1990-06-14 D. A. KEYSER -- INCLUDED PROCESSING OF TEMP; CORRECTED -C ERROR LEADING TO LOSS OF SOME OBS. IN REPACKING; -C CORRECTED TO HONOR ALL SDM/QCAIRCFT PURGES FOR STACKED -C OBS. & ALL SDM KEEPS FOR ISOL. OBS.; CORRECTED SLIGHT -C ERROR IN LAT/LON IN OUTPUT FILE FOR SOME OBS. -C 1990-07-03 D. A. KEYSER -- ADDED 1 TO OUTPUT TIME FOR MULTIPLE -C SUPEROBS IN SAME STACK W/ SAME ORIG. TIME (SO OI WON'T -C TOSS AS DUPLICATES); ROUNDED OUTPUT TIME OFF TO NEAREST -C INTEGER (FOR AVG'D SUPEROBS), WAS TRUNCATED -C 1991-02-26 G. J. DIMEGO -- MADE INCREMENT TO-BE-ADDED 11 (SEE ABOVE) -C 1994-01-01 P. JULIAN -- CHANGES TO RE-DO ON29(REV) QUAL MARKS -C 1994-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND -C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT; ADDED -C REPACKING OF ORIGINAL RESERVE CHARACTER INFO PLUS OTHER -C META-DATA IN CATEGORY 8 FOR NON-SUPEROBED REPORTS FOR -C ON29 OUTPUT; ADDED STORAGE OF ALL SUPEROBS IN HOLDING -C ARRAYS -C 1995-03-27 D. A. KEYSER -- ASDAR/AMDAR TMP/WND RPTS NOT FLAGGED BY -C OTHER CHKS NOW GET "GOOD" Q.M. (& FOR INIDST=2, NEW RSN. -C CODE 28) REGARDLESS OF SCALED VECTOR INCR. (BEFORE Q.M. -C BASED ON SCALED VECTOR INCR.) -C 1995-07-06 D. A. KEYSER -- REPORTS IN A STACK OF TWO NOW GET -C TEMPERATURE AND WIND FLAGGED AS BAD (AND ARE ASSIGNED -C THE NEW REASON CODE "329" FOR OUTPUT TO PREPBUFR -C FILE) IF THE SCALED VECTOR WIND INCREMENT IS LARGE -C (IN THE RANGE 'V' TO 'Z'), A SUPEROB IS NEVER STORED; -C ASDAR/AMDAR REPORTS NOW GET TEMPERATURE AND WIND Q. -C MARKS SET TO "SUSPECT" (AND ARE ASSIGNED THE NEW REASON -C CODE "330" FOR OUTPUT TO PREPBUFR FILE) IF THE -C PHASE OF FLIGHT INDICATOR IS MISSING (INDICATES A -C PROBABLE "BANKING" AIRCRAFT WITH SUSPECT DATA QUALITY) -C 2002-11-20 D. A. KEYSER -- SINCE THERE IS NO LONGER ANY RELATIONSHIP -C BETWEEN AN SDM KEEP ON WIND VS. A KEEP ON TEMP - THEY ARE -C INDENDENDENT OF EACH OTHER, FULL Q.C. IS NOW PERFORMED ON -C REPORTS WITH A KEEP FLAG ON EITHER, ALTHOUGH THE ORIGINAL -C KEEP FLAGS ARE STILL HONORED -C 2007-10-17 D. A. KEYSER -- CHANGES TO TREAT TAMDAR AND CANADIAN -C AMDAR REPORTS THE SAME AS ASDAR/AMDAR REPORTS -C -C USAGE: CALL RPACKR(NUM,NOBS,INDX) -C INPUT ARGUMENT LIST: -C NUM - NUMBER OF OBSERVATIONS IN ORIGINAL STACK -C NOBS - NUMBER OF OBSERVATIONS TO BE PACKED -C INDX - POINTER TO POSITION IN ORIGINAL AIRCRAFT ARRAY -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C REMARKS: CALLED BY MAIN PROGRAM. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE RPACKR(NUM,NOBS,INDX) - PARAMETER (IRMX= 80000, ISMX= 8000) - PARAMETER (ISUP= 4000) - LOGICAL EWRITE - CHARACTER*4 SSMARK - CHARACTER*8 ACID,SAID - CHARACTER*14 TAG - INTEGER IDATA(1608) - REAL ORIGTM(10),RDATA(1608) - COMMON/INPT/DOSPOB,DOACRS,TMAXO,TMINO,TIMINC,WAYPIN,INIDST,IFLGUS, - $ JAMASS(6),JAWIND(6),RCPTST - COMMON/OUTPUT/KNTOUT(5) - COMMON/STWRIT/SWRITE,EWRITE,IWRITE - COMMON/SUMDAT/ISTCPT(ISMX),SAID(ISMX),SLAT(ISMX),SLON(ISMX), - $ SHGT(ISMX),STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX), - $ KBAD(ISMX),NUMORG,SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX) - COMMON/ALLDAT/IFLEPT(IRMX),ACID(IRMX),ALAT(IRMX),ALON(IRMX), - $ AALT(IRMX),TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE, - $ ATMP(IRMX),TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX), - $ ITEVNT(IRMX),IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX), - $ ADIRF(IRMX) - COMMON/SUPOBS/SSLAT(ISUP),SSLON(ISUP),SSTIM(ISUP),SSHGT(ISUP), - $ SSTMP(ISUP),SSDIR(ISUP),SSSPD(ISUP),SSHGTF(ISUP),SSTMPF(ISUP), - $ SSDIRF(ISUP),SSSPDF(ISUP),SSMARK(ISUP) - EQUIVALENCE (IDATA,RDATA) - N2DO = NOBS -C NSPOB IS NO. OF SUPEROBS FORMED FOR THE STACK (NSPOB IS LIMITED TO 5) - NSPOB = N2DO - NUM -C INVENTORY INCREMENTS - CALL ACOUNT(NUM,INDX) - IF(NOBS.GE.2) THEN - PRINT 8000, NOBS,NUM,NSPOB,INDX - 8000 FORMAT(' ENTERING RPACKR WITH NOBS =',I4,', NUM =',I4,', AND', - $ ' NO. OF SPROBS =',I3,' AND INDX= ',I5) - ELSE - ISTCPT(1) = -2 - END IF - DO I = 1,NUM - JNDX = INDX + I - 1 - IF(TAG(JNDX)(1:1).EQ.'D') THEN -C SKIP REPACKING OF ORIGINAL REPORT IF IT IS INDEED A DUPLICATE REPORT - PRINT 9026, JNDX,ACID(JNDX),ALAT(JNDX),ALON(JNDX), - $ TIME(JNDX),TAG(JNDX) - 9026 FORMAT(/' ##########: RPACKR; DUPLICATE REMOVED AT BEG OF SUBR..', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"'/) - KNTINI(JNDX) = 99999 - GO TO 1 - END IF -C SKIP REPACKING OF ORIGINAL REPORT IF IT IS OUTSIDE REQ. TIME WINDOW - IF(TIME(JNDX).LT.TMINO.OR.TIME(JNDX).GT.TMAXO) THEN -C SET POS.1 OF TAG TO 'D' TO REMOVE FROM FINAL LISTING OF ORIG. REPORTS - TAG(JNDX)(1:1) = 'D' -CCCCC PRINT 9002, JNDX,ACID(JNDX),ALAT(JNDX),ALON(JNDX), -CCCCC$ TIME(JNDX),TAG(JNDX) -C9002 FORMAT(/' ##########: RPACKR; RPTS OUTSIDE TIME WINDOW SKIPPED..', -CCCCC$ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"'/) - KNTINI(JNDX) = 99999 - GO TO 1 - END IF -C NOW, MAKE FINAL ASSIGNMENT OF TEMPERATURE AND WIND Q. MARKS (IF APPL.) - IF(TAG(JNDX)(1:1).EQ.'P') THEN -C SDM WIND PURGE OBSERVATIONS HAVE ALREADY BEEN MARKED -C (NOTE: IF PURGE ON WIND, WILL ALSO BE PURGE ON TEMP FROM ACTION -C TAKEN BY PREVIOUS PREPOBS_PREPDATA PROGRAM) - ELSE IF(N2DO.EQ.1) THEN -C********************************************************************** -C ISOLATED OBSERVATIONS COME HERE -C********************************************************************** - IF(TAG(JNDX)(7:7).EQ.'Z') THEN -C---------------------------------------------------------------------- -C ASDARS/AMDARS/TAMDARS -C---------------------------------------------------------------------- - IF(TAG(JNDX)(13:13).GT.'5') THEN - IF(TAG(JNDX)(10:10).EQ.'7') THEN - IF(EWRITE) PRINT 9095, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - 9095 FORMAT(/' #EVENT 330: RPACKR; ISOLAT. ASDAR/AMDAR/TAMDAR ', - $ 'BANKING?, TMP QM. Q',I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(JNDX)(2:2) = 'Q' - TAG(JNDX)(13:13) = '5' - ITEVNT(JNDX) = 330 - ELSE IF(TAG(JNDX)(13:13).GT.'6') THEN -C IF "GOOD" ASDAR/AMDAR/TAMDAR REPORT, TEMP Q.M. IS 'A' - IF(EWRITE) PRINT 9090, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - 9090 FORMAT(/' #EVENT 328: RPACKR; ISOLAT. "GOOD" ASDAR/AMDAR/TAMDAR,', - $ ' TEMP Q.M. A',I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(JNDX)(2:2) = 'A' - TAG(JNDX)(13:13) = '6' - ITEVNT(JNDX) = 328 - END IF - END IF - IF(TAG(JNDX)(14:14).GT.'5') THEN - IF(TAG(JNDX)(10:10).EQ.'7') THEN - IF(EWRITE) PRINT 8095, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - 8095 FORMAT(/' #EVENT 330: RPACKR; ISOLAT. ASDAR/AMDAR/TAMDAR ', - $ 'BANKING?, WND QM. Q',I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(JNDX)(4:4) = 'Q' - TAG(JNDX)(14:14) = '5' - IWEVNT(JNDX) = 330 - ELSE IF(TAG(JNDX)(14:14).GT.'6') THEN -C IF "GOOD" ASDAR/AMDAR/TAMDAR REPORT, WIND Q.M. IS 'A' - IF(EWRITE) PRINT 9091, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - 9091 FORMAT(/' #EVENT 328: RPACKR; ISOLAT. "GOOD" ASDAR/AMDAR/TAMDAR,', - $ ' WIND Q.M. A',I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(JNDX)(4:4) = 'A' - TAG(JNDX)(14:14) = '6' - IWEVNT(JNDX) = 328 - END IF - END IF - ELSE -C---------------------------------------------------------------------- -C AIREPS/PIREPS -C---------------------------------------------------------------------- - IF(TAG(JNDX)(1:1).EQ.'Q'.OR.TAG(JNDX)(1:1).EQ.'R') THEN - IF(TAG(JNDX)(13:13).GT.'6') THEN -C IF "GOOD" REPORT W/ SMALL VECTOR WIND INCREMENT (Q-R) TEMP Q.M. IS 'A' - IF(EWRITE) PRINT 9030, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - 9030 FORMAT(/' #EVENT 317: RPACKR; ISOLAT. AIREP SMALL INCR. TMP QM A', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(JNDX)(2:2) = 'A' - TAG(JNDX)(13:13) = '6' - ITEVNT(JNDX) = 317 - END IF - IF(TAG(JNDX)(14:14).GT.'6') THEN -C IF "GOOD" REPORT W/ SMALL VECTOR WIND INCREMENT (Q-R) WIND Q.M. IS 'A' - IF(EWRITE) PRINT 8030, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - 8030 FORMAT(/' #EVENT 317: RPACKR; ISOLAT. AIREP SMALL INCR. WND QM A', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(JNDX)(4:4) = 'A' - TAG(JNDX)(14:14) = '6' - IWEVNT(JNDX) = 317 - END IF - ELSE IF(TAG(JNDX)(1:1).GE.'V'.AND.TAG(JNDX)(1:1).LE.'Z')THEN - IF(TAG(JNDX)(13:13).GT.'3') THEN -C IF LARGE VECTOR WIND INCREMENT (V - Z), TEMP Q.M. IS 'F' - IF(EWRITE) PRINT 9029, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - 9029 FORMAT(/' #EVENT 316: RPACKR; ISOLAT. AIREP LARGE INCR. TMP QM F', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(JNDX)(2:2) = 'F' - TAG(JNDX)(13:13) = '3' - ITEVNT(JNDX) = 316 - END IF - IF(TAG(JNDX)(14:14).GT.'3') THEN -C IF LARGE VECTOR WIND INCREMENT (V - Z), WIND Q.M. IS 'F' - IF(EWRITE) PRINT 8029, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - 8029 FORMAT(/' #EVENT 316: RPACKR; ISOLAT. AIREP LARGE INCR. WND QM F', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(JNDX)(4:4) = 'F' - TAG(JNDX)(14:14) = '3' - IWEVNT(JNDX) = 316 - END IF - ELSE IF((TAG(JNDX)(1:1).GE.'S'.AND.TAG(JNDX)(1:1) - $ .LE.'U').OR.TAG(JNDX)(1:1).EQ.'-') THEN - IF(TAG(JNDX)(13:13).GT.'5') THEN -C IF "GOOD" REPORT WITH INTERMEDIATE VECTOR WIND INCREMENT (S - U) OR -C WAYPOINT LOCATION CHANGED ('-'), TEMP Q.M. IS 'Q' - IF(EWRITE) PRINT 9031, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - 9031 FORMAT(/' #EVENT 318: RPACKR; ISOLAT. AIREP SUSP. INCR. TMP QM Q', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(JNDX)(2:2) = 'Q' - TAG(JNDX)(13:13) = '5' - ITEVNT(JNDX) = 318 - END IF - IF(TAG(JNDX)(14:14).GT.'5') THEN -C IF "GOOD" REPORT WITH INTERMEDIATE VECTOR WIND INCREMENT (S - U) OR -C WAYPOINT LOCATION CHANGED ('-'), WIND Q.M. IS 'Q' - IF(EWRITE) PRINT 8031, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - 8031 FORMAT(/' #EVENT 318: RPACKR; ISOLAT. AIREP SUSP. INCR. WND QM Q', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(JNDX)(4:4) = 'Q' - TAG(JNDX)(14:14) = '5' - IWEVNT(JNDX) = 318 - END IF - ELSE IF(TAG(JNDX)(1:1).EQ.'C') THEN -C IF REPORT WITH VECTOR WIND INCREMENT NOT CALCULATED ('C'), TEMP & -C WIND Q.M. IS '-' (INCLUDES ALL RPTS OUTSIDE +/- 3.33-HR WINDOW) - IF(TAG(JNDX)(13:13).GT.'7') THEN - IF(EWRITE) PRINT 9032, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - 9032 FORMAT(/' #EVENT ###: RPACKR; ISOLAT. AIREP INCR. N/A TMP QM " "', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(JNDX)(13:13) = '7' - END IF - IF(TAG(JNDX)(14:14).GT.'7') THEN - IF(EWRITE) PRINT 8032, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - 8032 FORMAT(/' #EVENT ###: RPACKR; ISOLAT. AIREP INCR. N/A WND QM " "', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(JNDX)(14:14) = '7' - END IF - ELSE - END IF -C---------------------------------------------------------------------- - END IF - ELSE -C********************************************************************** -C STACKED OBSERVATIONS COME HERE -C********************************************************************** - IF(TAG(JNDX)(1:1).GE.'V'.AND.TAG(JNDX)(1:1).LE.'Z'.AND. - $ NUM.LT.3) THEN -C IF NO. IN STACK IS TWO, THEN AIREP/PIREP WITH LARGE VECTOR WIND INCR. -C (V - Z) HAVE TEMP & WIND Q.M. SET TO 'F' (AS WITH ISOLATED REPORTS) - IF(TAG(JNDX)(13:13).GT.'3') THEN -CVVVVV%%%%% - PRINT *,'~~~~~ NUM=2 & THIS OBS. HAS A LARGE INCR., FLAG TEMP' -CAAAAA%%%%% - IF(EWRITE) PRINT 9929, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - 9929 FORMAT(/' #EVENT 329: RPACKR; <3 STACKD AIREP LRG INCR. TMP QM F', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(JNDX)(2:2) = 'F' - TAG(JNDX)(13:13) = '3' - ITEVNT(JNDX) = 329 - END IF - IF(TAG(JNDX)(14:14).GT.'3') THEN -CVVVVV%%%%% - PRINT *,'~~~~~ NUM=2 & THIS OBS. HAS A LARGE INCR., FLAG WIND' -CAAAAA%%%%% - IF(EWRITE) PRINT 8929, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - 8929 FORMAT(/' #EVENT 329: RPACKR; <3 STACKD AIREP LRG INCR. WND QM F', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(JNDX)(4:4) = 'F' - TAG(JNDX)(14:14) = '3' - IWEVNT(JNDX) = 329 - END IF -C WILL NOT STORE ANY SUPEROB REPORTS IN THIS CASE - IF(NSPOB.GT.0) PRINT 9903 -CVVVVV%%%%% - IF(NSPOB.GT.0) - $ PRINT *,'~~~~~ THE SUPEROB HERE IS NOT STORED' -CAAAAA%%%%% - 9903 FORMAT(/' ##########: RPACKR; SUPEROB IS SKIPPED - ONE OR BOTH ', - $ 'ORIG. OBS. IN A STACK OF TWO ORIG. OBS. HAVE LARGE INCREMENT'/) - NSPOB = 0 - END IF - IF(TAG(JNDX)(14:14).GT.'6') THEN -C IF WIND IS NEITHER BAD NOR SUSPECT AT THIS POINT, SET Q.M. TO GOOD - IF(EWRITE) PRINT 9034, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - 9034 FORMAT(/' #EVENT 320: RPACKR; STACKED W/ GOOD WND, WIND Q.M. "A"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(JNDX)(4:4) = 'A' - TAG(JNDX)(14:14) = '6' - IWEVNT(JNDX) = 320 - END IF - IF(TAG(JNDX)(13:13).GT.'6') THEN -C IF TEMP IS NEITHER BAD NOR SUSPECT AT THIS POINT, SET Q.M. TO GOOD - IF(EWRITE) PRINT 9035, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - 9035 FORMAT(/' #EVENT 320: RPACKR; STACKED W/ GOOD TMP, TEMP Q.M. "A"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(JNDX)(2:2) = 'A' - TAG(JNDX)(13:13) = '6' - ITEVNT(JNDX) = 320 - END IF -C********************************************************************** - END IF - IF(TAG(JNDX)(4:4).EQ.'F'.AND.TAG(JNDX)(13:13).GT.'3') THEN -C IF WIND IS FLAGGED, THEN TEMPERATURE IS ALWAYS ALSO FLAGGED - IF(EWRITE) PRINT 9033, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - 9033 FORMAT(/' #EVENT 319: RPACKR; BAD WIND, TEMP Q.M. SET TO "F"....', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(JNDX)(2:2) = 'F' - TAG(JNDX)(13:13) = '3' - ITEVNT(JNDX) = 319 - END IF - 1 CONTINUE - ENDDO - NPT = NUM - IF(NSPOB.GT.0) THEN -C####################################################################### -C####################################################################### -C S U P E R O B S -C####################################################################### -C####################################################################### - DO I = 1,NSPOB - NPT = NPT + 1 -C RE-STORE TIME IN WORD 4 - RDATA(4) = NINT(MOD(STIM(NPT),2400.)) - IF(RDATA(4).LT.0.0) THEN - RDATA(4) = RDATA(4) + 2400. - STIM(NPT) = STIM(NPT) + 2400. - END IF -C MULT. SUPEROBS IN STACK W/ SAME ORIG. TIME HAVE OUTPUT TIME INCR. BY -C 'TIMINC' FOR EACH OCCURRENCE OF A DUPL. TIME (PREVENTS OI DUPL. TOSS) - ORIGTM(I) = RDATA(4) - DO J = 1,I-1 - IF(ORIGTM(I).EQ.ORIGTM(J)) THEN - RDATA(4) = MOD(RDATA(4)+TIMINC,2400.) - STIM(NPT) = STIM(NPT) + TIMINC - END IF - ENDDO -C SKIP PACKING OF SUPEROB REPORT IF IT IS OUTSIDE REQ. TIME WINDOW - IF(STIM(NPT).LT.TMINO.OR.STIM(NPT).GT.TMAXO) THEN - PRINT 9003, I,SLAT(NPT),SLON(NPT),STIM(NPT) - 9003 FORMAT(/' ##########: RPACKR; SUPOBS OUTSIDE TIME WINDOW SKIPPED', - $ I5,2X,'SUPROB ',2F8.2,F6.0/) - GO TO 2 - END IF - KNTOUT(3) = KNTOUT(3) + 1 - IF(KNTOUT(3).GT.ISUP) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE SUPEROBED RPTS THAN "ISUP" -- STOP 23 - PRINT 53, ISUP - 53 FORMAT(/' THERE ARE MORE THAN',I5,' SUPEROBED REPORTS GENERATED', - $ ' -- MUST INCREASE SIZE OF PARAMETER NAME "ISUP" - STOP 23'/) - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(23) -C....................................................................... - END IF - SSLAT(KNTOUT(3)) = SLAT(NPT) - SSLON(KNTOUT(3)) = SLON(NPT) - SSTIM(KNTOUT(3)) = STIM(NPT) - SSHGT(KNTOUT(3)) = SHGT(NPT) - SSTMP(KNTOUT(3)) = STMP(NPT) - SSDIR(KNTOUT(3)) = SDIR(NPT) - SSSPD(KNTOUT(3)) = SSPD(NPT) - SSHGTF(KNTOUT(3)) = SHGTF(NPT) - SSTMPF(KNTOUT(3)) = STMPF(NPT) - SSDIRF(KNTOUT(3)) = SDIRF(NPT) - SSSPDF(KNTOUT(3)) = SSPDF(NPT) - SSMARK(KNTOUT(3)) = 'SS ' - 2 CONTINUE - ENDDO -C####################################################################### - END IF - IF(NOBS.GE.2.OR.NOBS.NE.NUM) PRINT 8378 - 8378 FORMAT(1X,'***********************************************') - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: ACOUNT DOES SIMPLE ACCOUNTING OF REPORTS -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2002-11-20 -C -C ABSTRACT: DOES SIMPLE ACCOUNTING BY LOGGING NUMBER OF REPORTS BY -C SCALED VECTOR INCREMENT. FURTHER ACCOUNTING ACCORDING TO ISOLATED -C OR STACKED REPORTS ALSO PERFORMED. IN ADDITION, LOGS THE NUMBER OF -C SDM KEEPS AND SDM PURGES ON WIND AND/OR TEMP. THE NUMBER OF BAD -C TEMPERATURES IS ALSO ACCOUNTED FOR HERE. -C -C PROGRAM HISTORY LOG: -C 1994-01-01 P. JULIAN (W/NMC00) -- ORIGINAL AUTHOR -C 1994-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND -C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT -C 2002-11-20 D. A. KEYSER -- SINCE HAVE REMOVED ASSUMPTION THAT AN SDM -C PURGE ON TEMP ONLY ALSO RESULTS IN AN SDM PURGE ON WIND -C AS WELL AS THE RELATIONSHIP BETWEEN AN SDM KEEP ON WIND -C VS. A KEEP ON TEMP (THEY ARE INDENDENDENT OF EACH OTHER), -C NOW TESTS BOTH BYTE 2 AND 4 OF TAG FOR "P" OR "H" RATHER -C THAN JUST BYTE 1 OF TAG {WHICH NOW CAN NEVER HAVE AN "H" -C AND WILL ONLY HAVE A "P" IF WIND (AND THUS ALSO TEMP VIA -C ACTIONS OF PREVIOUS PREPOBS_PREPACQC PROGRAM} IS PURGED} -C -C USAGE: CALL ACOUNT(NUM,INDX) -C INPUT ARGUMENT LIST: -C NUM - NUMBER OF OBSERVATIONS TO BE TREATED -C INDX - POINTER TO POSITION IN ORIGINAL AIRCRAFT ARRAY -C -C REMARKS: CALLED BY SUBROUTINE 'RPACKR'. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE ACOUNT(NUM,INDX) - PARAMETER (IRMX= 80000) - CHARACTER*1 QCACMK(15) - CHARACTER*8 ACID - CHARACTER*14 TAG - COMMON/ACCONT/KQM2F(15),KISO(15),KNQM(15),KSDM(2),KT,KTYPS(9) - COMMON/ALLDAT/IFLEPT(IRMX),ACID(IRMX),ALAT(IRMX),ALON(IRMX), - $ AALT(IRMX),TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE, - $ ATMP(IRMX),TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX), - $ ITEVNT(IRMX),IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX), - $ ADIRF(IRMX) - COMMON/INPT/DOSPOB,DOACRS,TMAXO,TMINO,TIMINC,WAYPIN,INIDST,IFLGUS, - $ JAMASS(6),JAWIND(6),RCPTST - DATA QCACMK/'Q','R','S','T','U','V','W','X','Y','Z','C','P','H', - $ '-','D'/ - IF(NUM.EQ.1) THEN - IF(TIME(INDX).GE.TMINO.AND.TIME(INDX).LE.TMAXO) THEN - DO M = 1,15 - IF(TAG(INDX)(1:1).EQ.QCACMK(M)) THEN - KISO(M) = KISO(M) + 1 - GO TO 618 - END IF - ENDDO - 618 CONTINUE - END IF - ELSE - DO K = INDX,INDX+NUM-1 - IF(TIME(K).GE.TMINO.AND.TIME(K).LE.TMAXO) THEN - DO M = 1,15 - IF(TAG(K)(1:1).EQ.QCACMK(M)) THEN - KNQM(M) = KNQM(M) + 1 - IF(TAG(K)(4:4).EQ.'F') KQM2F(M) = KQM2F(M) + 1 - GO TO 718 - END IF - ENDDO - 718 CONTINUE -ccccc IF(TAG(K)(1:1).EQ.'P') KSDM(1) = KSDM(1) + 1 - IF(TAG(K)(2:2).EQ.'P'.OR.TAG(K)(4:4).EQ.'P') - $ KSDM(1) = KSDM(1) + 1 -ccccc IF(TAG(K)(1:1).EQ.'H') KSDM(2) = KSDM(2) + 1 - IF(TAG(K)(2:2).EQ.'H'.OR.TAG(K)(4:4).EQ.'H') - $ KSDM(2) = KSDM(2) + 1 - IF(TAG(K)(2:2).EQ.'F'.AND.TAG(K)(4:4).NE.'F') KT = KT +1 - END IF - ENDDO - END IF - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: IDSORT SORTS INPUT AIRCFT REPORTS BY STATION ID -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1999-08-23 -C -C ABSTRACT: USES LOCAL SORT ROUTINE TO SORT ENTIRE AIRCRAFT FILE -C BY THE 8-CHARACTER STATION (FLIGHT) IDENTIFICATION. -C -C PROGRAM HISTORY LOG: -C 1993-01-05 P. JULIAN -- THIS IS A NEW SUBPROGRAM-ALL CODE WAS -C WRITTEN TO ENABLE LOCAL SORT PROGRAM TO BE USED. -C 1994-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND -C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT -C 1995-07-06 D. A. KEYSER -- NO LONGER SETS CHAR. ' ' TO '0' IN -C WORKING STNID ARRAY PRIOR TO IDSORT (WAS BREAKING-UP -C SOME TRACKS AND WAS NEVER NEEDED FOR ANY OTHER REASON) -C 1999-08-23 D.A. KEYSER -- ADDED HIGHER ORDERS IN CHARACTER SORTS -C TO HOPEFULLY ALWAYS GIVE SAME SORT ORDER REGARDLESS OF -C INPUT REPORT ORDER -C -C USAGE: CALL IDSORT(NFILE,NASDAR,NEXCLD) -C INPUT ARGUMENT LIST: -C NFILE - NUMBER OF OBSERVATIONS TO SORT -C -C OUTPUT ARGUMENT LIST: -C NASDAR - NUMBER OF ASDAR/AMDAR/TAMDAR REPORTS IN SORT -C NEXCLD - NUMBER OF EXCLUDED REPORTS AT END OF SORT -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C REMARKS: CALLED BY MAIN PROGRAM. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE IDSORT(NFILE,NASDAR,NEXCLD) - PARAMETER (IRMX= 80000) - PARAMETER (ISIZE= 16) - CHARACTER*8 ACID,AAID(IRMX) - CHARACTER*14 TAG,STAG(IRMX) - CHARACTER*32 CARRAY(IRMX) - REAL SARRAY(IRMX,ISIZE) - INTEGER INDR(IRMX) - COMMON/ALLDAT/IFLEPT(IRMX),ACID(IRMX),ALAT(IRMX),ALON(IRMX), - $ AALT(IRMX),TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE, - $ ATMP(IRMX),TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX), - $ ITEVNT(IRMX),IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX), - $ ADIRF(IRMX) - COMMON/WORD/ICHTP - NASDAR = 0 - NEXCLD = 0 -C FILL IN CARRAY FOR SORT ROUTINE - DO J = 1,NFILE - IF(TAG(J)(12:12).EQ.'@') THEN -C EXCLUDED RPTS ARE COUNTED AND WILL BE AT VERY END OF SORT -C (DO THIS BY CHANGING CHARACTER STRING TO: -C '99999' IF CHARACTERS ARE EBCDIC, -C '~~~~~' IF CHARACTERS ARE ASCII) -C 1ST ORDER - "99999" or "~~~~~"//STATION ID -C 2ND ORDER - TIME (INCREASING) (THIS WAS ADDED 8/23/1999) -C 3RD ORDER - LONGITUDE (WEST, INCREASING) (THIS WAS ADDED 8/23/1999) -C 4TH ORDER - LATITUDE (SOUTH TO NORTH) (THIS WAS ADDED 8/23/1999) -C 5TH ORDER - ALTITUDE (INCREASING) (THIS WAS ADDED 8/23/1999) - NEXCLD = NEXCLD + 1 - CARRAY(J)(1:5) = '99999' - IF(ICHTP.EQ.0) CARRAY(J)(1:5) = '~~~~~' - CARRAY(J)( 6:12) = ACID(J)(1:7) - WRITE(CARRAY(J)(13:16),'(I4.4)') NINT(TIME(J)) - WRITE(CARRAY(J)(17:21),'(I5.5)') NINT(ALON(J)*100.) - WRITE(CARRAY(J)(22:26),'(I5.5)') NINT(ALAT(J)*100.) + 9000 - WRITE(CARRAY(J)(27:32),'(I6.6)') NINT(AALT(J)) -C RESET POS. 8 OF ID BACK TO '-' (LATER USED TO TAG ISOLATED REPORTS) - TAG(J)(12:12) = '-' - ELSE IF(TAG(J)(7:7).EQ.'Z') THEN -C ASDAR/AMDAR/TAMDAR RPTS ARE COUNTED AND WILL BE AFTER AIREPS IN SORT -C (DO THIS BY CHANGING CHARACTER STRING TO: -C '999' IF CHARACTERS ARE EBCDIC, -C '~~~' IF CHARACTERS ARE ASCII) -C 1ST ORDER - "999" or "~~~"//STATION ID -C 2ND ORDER - TIME (INCREASING) -C 3RD ORDER - LONGITUDE (WEST, INCREASING) (THIS WAS ADDED 8/23/1999) -C 4TH ORDER - LATITUDE (SOUTH TO NORTH) (THIS WAS ADDED 8/23/1999) -C 5TH ORDER - ALTITUDE (INCREASING) (THIS WAS ADDED 8/23/1999) - NASDAR = NASDAR + 1 - CARRAY(J)(1:3) = '999' - IF(ICHTP.EQ.0) CARRAY(J)(1:3) = '~~~' - CARRAY(J)(4:11) = ACID(J) - WRITE(CARRAY(J)(12:16),'(I5.5)') NINT(TIME(J)) - WRITE(CARRAY(J)(17:21),'(I5.5)') NINT(ALON(J)*100.) - WRITE(CARRAY(J)(22:26),'(I5.5)') NINT(ALAT(J)*100.) + 9000 - WRITE(CARRAY(J)(27:32),'(I6.6)') NINT(AALT(J)) - ELSE -C AIREPS WILL BE AT BEGINNING OF SORT -C 1ST ORDER - STATION ID -C 2ND ORDER - LONGITUDE (WEST, INCREASING) -C 3RD ORDER - TIME (INCREASING) -C 4TH ORDER - LATITUDE (SOUTH TO NORTH) (THIS WAS ADDED 8/23/1999) -C 5TH ORDER - ALTITUDE (INCREASING) (THIS WAS ADDED 8/23/1999) - CARRAY(J)(1:7) = ACID(J)(1:7) - WRITE(CARRAY(J)(8:12),'(I5.5)') NINT(ALON(J)*100.) - WRITE(CARRAY(J)(13:16),'(I4.4)') NINT(TIME(J)) - WRITE(CARRAY(J)(17:21),'(I5.5)') NINT(ALAT(J)*100.) + 9000 - WRITE(CARRAY(J)(22:27),'(I6.6)') NINT(AALT(J)) - CARRAY(J)(28:32) = '00000' - END IF -C REMOVED THIS FOR 6 JUL 1995 VERSION (WAS SPLITTING UP SOME TRACKS) -CCCCCCCCCDO K = 1,12 -CCCCCCCCC IF(CARRAY(J)(K:K).EQ.' ') CARRAY(J)(K:K) = '0' -CCCCCCCCCENDDO -C TRANSFER ORIGINAL DATA TO TEMPORARY ARRAYS TO HOLD FOR RE-ARRANGING - AAID(J) = ACID(J) - SARRAY(J,1) = ALAT(J) - SARRAY(J,2) = ALON(J) - SARRAY(J,3) = AALT(J) - SARRAY(J,4) = TIME(J) - SARRAY(J,5) = ATMP(J) - SARRAY(J,6) = ADIR(J) - SARRAY(J,7) = ASPD(J) - SARRAY(J,8) = REAL(INTP(J)) - SARRAY(J,9) = REAL(IRTM(J)) - SARRAY(J,10) = REAL(KNTINI(J)) - SARRAY(J,11) = REAL(ITEVNT(J)) - SARRAY(J,12) = REAL(IWEVNT(J)) - SARRAY(J,13) = AALTF(J) - SARRAY(J,14) = ADIRF(J) - SARRAY(J,15) = ASPDF(J) - SARRAY(J,16) = ATMPF(J) - STAG(J) = TAG(J) -CCCCC LON = 99999 -CCCCC IF(ALON(J).LT.99999.) LON = NINT(ALON(J)*100.) -CCCCC PRINT 1927, AAID(J),NINT(TIME(J)),LON,CARRAY(J) -C1927 FORMAT(' ',A8,2X,2I8,3X,A32) -CCCCC PRINT 100, J,AAID(J),SARRAY(J,1),SARRAY(J,2),SARRAY(J,4), -CCCCC$ SARRAY(J,3),SARRAY(J,5),SARRAY(J,6),SARRAY(J,7),STAG(J)(1:4) -CD100 FORMAT(' ', I7,2X,A8,2X,2F9.2,5F9.0,1X,A4) - ENDDO -C CALL SORT ROUTINE- PUTS POINTERS INTO IPOINT ARRAY/DOES NOT REARRANGE - IF(NFILE.GT.0) CALL INDEXC(NFILE,CARRAY,INDR) - DO I = 1,NFILE - J = INDR(I) -C WRITE SORTED REPORTS BACK INTO ORIGINAL ARRAYS - ACID(I) = AAID(J) - ALAT(I) = SARRAY(J,1) - ALON(I) = SARRAY(J,2) - AALT(I) = SARRAY(J,3) - TIME(I) = SARRAY(J,4) - ATMP(I) = SARRAY(J,5) - ADIR(I) = SARRAY(J,6) - ASPD(I) = SARRAY(J,7) - INTP(I) = NINT(SARRAY(J,8)) - IRTM(I) = NINT(SARRAY(J,9)) - KNTINI(I) = NINT(SARRAY(J,10)) - ITEVNT(I) = NINT(SARRAY(J,11)) - IWEVNT(I) = NINT(SARRAY(J,12)) - AALTF(I) = SARRAY(J,13) - ADIRF(I) = SARRAY(J,14) - ASPDF(I) = SARRAY(J,15) - ATMPF(I) = SARRAY(J,16) - TAG(I) = STAG(J) - ENDDO - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: PRELIM SUPERVISES QUALITY CONTROL -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2002-11-20 -C -C ABSTRACT: DOES BASIC SCREENING OF OBS. CALCULATES STATISTICAL -C QUANTITIES AND BRANCHES DEPENDING UPON HOW MANY OBS ARE CO- -C LOCATED (STACKED). USES STATISTICS TO CHECK ON MUTUAL AGREEMENT -C OR DISAGREEMENT WITHIN OBSERVATION STACKS. -C -C PROGRAM HISTORY LOG: -C 1993-01-05 P. JULIAN -- THIS IS A NEW SUBPROGRAM-ALL CODE WAS -C PREVIOUSLY A PART OF SUBPROGRAM SUPROB (WHICH NOW -C STANDS ALONE); THIS SUBPROGRAM IS CALLED REGARDLESS -C OF LOGICAL DOSPOB -C 1994-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND -C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT -C 2002-11-20 D. A. KEYSER -- SINCE HAVE REMOVED THE RELATIONSHIP -C BETWEEN AN SDM KEEP ON WIND VS. A KEEP ON TEMP (THEY ARE -C INDENDENDENT OF EACH OTHER), NOW TESTS BOTH BYTE 2 AND 4 -C OF TAG FOR "H" RATHER THAN JUST BYTE 1 OF TAG (WHICH NOW -C CAN NEVER HAVE AN "H") -C -C USAGE: CALL PRELIM(NUM,INDX,LOALT,KNUM,STCLIM) -C INPUT ARGUMENT LIST: -C NUM - NUMBER OF OBSERVATIONS -C INDX - POINTER TO POSITION IN ORIGINAL AIRCRAFT ARRAY -C LOALT - NUMBER OF OBSERVATIONS AT LOW ALTITUDE -C STCLIM - VECTOR WIND INCREMENT THRESHOLD FOR SDM PRINT (UNIT 53) -C -C OUTPUT ARGUMENT LIST: -C KNUM - NUMBER OF GOOD WIND OBSERVATIONS -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C UNIT 53 - TEXT FILE FOR SDM PERUSAL (LIST OF STACKED REPORTS -C - WITH AVERAGE VECTOR WIND INCREMENT .GT. NAMELIST -C - VARIABLE 'STCLIM', ALSO LIST OF STACKED REPORTS WITH -C - AT LEAST ONE REPORT CONTAINING SDM KEEP FLAG ON WIND -C - AND/OR TEMP) -C -C REMARKS: CALLED BY MAIN PROGRAM. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE PRELIM(NUM,INDX,LOALT,KNUM,STCLIM) - PARAMETER (IRMX= 80000, ISMX= 8000) - LOGICAL EWRITE - CHARACTER*1 CTG,CLON,C1,CH1(9) - CHARACTER*8 ACID,SAID - CHARACTER*14 TAG - INTEGER ICH1(9) - REAL SCALE(ISMX) - COMMON/STWRIT/SWRITE,EWRITE,IWRITE - COMMON/SUMDAT/ISTCPT(ISMX),SAID(ISMX),SLAT(ISMX),SLON(ISMX), - $ SHGT(ISMX),STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX), - $ KBAD(ISMX),NUMORG,SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX) - COMMON/ALLDAT/IFLEPT(IRMX),ACID(IRMX),ALAT(IRMX),ALON(IRMX), - $ AALT(IRMX),TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE, - $ ATMP(IRMX),TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX), - $ ITEVNT(IRMX),IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX), - $ ADIRF(IRMX) - DATA XMSG/99999./ - DATA CH1 /'Q','R','S','T','U','V','W','X','Y'/ - DATA ICH1 / 5, 15, 25, 35, 45, 55, 65, 75, 85 / - KNUM = 0 - NUMORG = NUM -C NUMH IS THE NUMBER OF OBSERVATIONS AT MID- AND HIGH ALTITUDES - NUMH = NUM - LOALT - PRINT 6001, NUM,INDX,ALAT(INDX)+SIGN(.0005,ALAT(INDX)), - $ ALON(INDX)+SIGN(.0005,ALON(INDX)),NUMH,LOALT - 6001 FORMAT(' ******* IN PRELIM FOR A STACK ======> NUM =',I6, - $ ', INDX =',I6,' AT LAT',F7.1,', LON',F7.1,', NUMH=',I3, - $ ', LOALT=',I3,' <==========') - IF(NUMH.LT.2) GO TO 1369 -C IF 2 OR MORE HI-ALT. OBS, CALL SHEAR TO CALC. ON- & OFF-LVL DIFFS - CALL SHEAR(NUM,INDX) -C UPDATE STAC ARRAY INDICATORS AND QUALITY INDICATORS - DO I = 1,NUM - JNDX = INDX + I - 1 - IF(TAG(JNDX)(4:4).EQ.'F') ISTCPT(I) = 0 - IF(ISTCPT(I).GT.0) KNUM = KNUM + 1 - IF(ISTCPT(I).EQ.0.OR.KBAD(I).EQ.0) THEN - ISTCPT(I) = 0 - IFLEPT(JNDX) = 0 - IF(TAG(JNDX)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 9036, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - 9036 FORMAT(/' #EVENT 321: PRELIM; WND FAILED SHEAR CHK, WND Q.M. "F"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(JNDX)(4:4) = 'F' - TAG(JNDX)(14:14) = '3' - IWEVNT(JNDX) = 321 - END IF - KBAD(I) = I - END IF - ENDDO -C IF 3 OR MORE HI-ALT. OBS, CALL LAPSE TO FIND BAD TEMPS, MAKE DECISIONS - IF(NUMH.GT.2) CALL LAPSE(NUM,INDX) - 1369 CONTINUE -C UPDATE STAC ARRAY INDICATORS AND QUALITY INDICATORS -C FROM HERE ON SUPEROB QUANTITIES ARE DETERMINED BY GOOD WINDS ONLY - -C ANY GOOD TEMPS WITH BAD WIND REPORTS ARE IGNORED (C'EST LA VI) - QSUM = 0.0 - IQNUM = 0 - SCALE = XMSG - IFLAG = 0 - DO I = 1,NUM - JNDX = INDX + I - 1 - IF(ISTCPT(I).EQ.0.OR.KBAD(I).EQ.0) THEN - IF(TAG(JNDX)(13:13).GT.'3') THEN - IF(KBAD(I).EQ.0) THEN - IF(EWRITE) PRINT 9037, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - 9037 FORMAT(/' #EVENT 322: PRELIM; TMP FAILED LAPSE CHK, TMP Q.M. "F"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - ITEVNT(JNDX) = 322 - ELSE - IF(EWRITE) PRINT 9028, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - 9028 FORMAT(/' #EVENT 319: PRELIM; WIND IS BAD, TEMP Q.M. SET TO "F".', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - ITEVNT(JNDX) = 319 - END IF - TAG(JNDX)(2:2) = 'F' - TAG(JNDX)(13:13) = '3' - END IF - KBAD(I) = I - END IF -C AMONGST THOSE OBS. WITH A SCALED VECTOR INCREMENT, SCALE IS BASED ON -C VALUE OF SCALED INCREMENT CHARACTER Q-Z - IF(TAG(JNDX)(5:5).GE.'Q'.AND.TAG(JNDX)(5:5).LE.'Z'.AND. - $ ISTCPT(I).GT.0) THEN -C WE WANT ONLY GOOD HIGH-ALTITUDE OBSERVED VECTOR INCREMENTS HERE - CTG = TAG(JNDX)(5:5) - SCALE(I) = 95.0 - DO II=1,9 - IF(CTG.EQ.CH1(II)) THEN - SCALE(I) = ICH1(II) - EXIT - END IF - ENDDO - IQNUM = IQNUM + 1 - QSUM = QSUM + SCALE(I) - END IF -C IF ANY OBS. IN STACK HAS A KEEP FLAG (SDM) ON WIND AND/OR TEMP -C WILL ALWAYS FORCE THIS STACK TO GO TO SDMSTAC D-SET FOR SDM PERUSAL -C AND POSSIBLE DELETING OF THE STACK, REGARDLESS OF QSUM VALUE -ccccc IF(TAG(JNDX)(1:1).EQ.'H') IFLAG = 1 - IF(TAG(JNDX)(4:4).EQ.'H'.OR.TAG(JNDX)(2:2).EQ.'H') IFLAG = 1 -CCCCC CTEMP = ATMP(JNDX) -CCCCC IF(ATMP(JNDX).LT.XMSG) CTEMP = ATMP(JNDX)/10. -CCCCC PRINT 6003, I,ACID(JNDX),ADIR(JNDX),ASPD(JNDX),AALT(JNDX), -CCCCC$ CTEMP+SIGN(.0005,CTEMP),TIME(JNDX),KBAD(I),ISTCPT(I),TAG(JNDX), -CCCCC$ SCALE(I),IQNUM -C6003 FORMAT(' ',I3,1X,A8,F6.0,F6.1,1X,F7.0,F6.1,2X,F5.0,2I4,2X,'"', -CCCCC$ A14,'"',F4.1,1X,I3) - ENDDO - IF(IQNUM.NE.0) THEN - QSUM = QSUM/IQNUM - ELSE - QSUM = 0.0 - END IF - PRINT 111, INDX,KNUM,IQNUM,QSUM - 111 FORMAT(' FROM PRELIM, INDX,KNUM,IQNUM,QSUM ',3I5,F7.1) - IF(QSUM.GT.STCLIM.OR.IFLAG.EQ.1) THEN -C IF VECTOR WIND INCREMENT THRESHOLD EXEEDED, OR IF AT LEAST ONE REPORT -C IN STACK CONTAINS SDM KEEP FLAG ON WIND AND/OR TEMP, SEND PRINT TO -C SDM IN UNIT 53 - DO I = 1,NUM - JNDX = INDX + I - 1 - QTEMP = 99999. - IF(ATMP(JNDX).LT.99999.) QTEMP = ATMP(JNDX) * 0.1 - QLON = ALON(JNDX) - QTIME = MOD(TIME(JNDX),2400.) - CLON = 'W' - IF(NINT(QLON).GT.180) THEN - QLON = 360. - QLON - CLON = 'E' - END IF - IF(AALT(JNDX).LE.11000.) THEN - PRALT = - $ 1013.25*(((288.15 - (.0065*AALT(JNDX)))/288.15)**5.256) - ELSE - PRALT = 226.3 * EXP(1.576106E-4 * (11000. - AALT(JNDX))) - END IF - C1 = '-' -ccccccccccccIF(TAG(JNDX)(1:1).EQ.'H'.OR.TAG(JNDX)(1:1).EQ.'P') -ccccc$ C1 = TAG(JNDX)(1:1) - IF(TAG(JNDX)(4:4).EQ.'H'.OR.TAG(JNDX)(2:2).EQ.'H' .OR. - $ TAG(JNDX)(4:4).EQ.'P'.OR.TAG(JNDX)(2:2).EQ.'P') - $ C1 = 'Y' - WRITE(53,26) ACID(JNDX),ALAT(JNDX),QLON,CLON,QTIME,PRALT, - $ QTEMP,ADIR(JNDX),ASPD(JNDX),SCALE(I),C1,TAG(JNDX)(4:4), - $ TAG(JNDX)(2:2) - 26 FORMAT(' ',A8,2F8.2,A1,3F7.0,F6.0,F7.1,F7.0,3(4X,A1)) - ENDDO - WRITE(53,27) - 27 FORMAT(' ','-------------------') - END IF - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: SUPROB DOES SUPEROBING -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1996-01-26 -C -C ABSTRACT: DOES BASIC SCREENING OF OBS. CALCULATES STATISTICAL -C QUANTITIES AND BRANCHES DEPENDING UPON HOW MANY OBS ARE CO- -C LOCATED (STACKED). USES STATISTICS TO CHECK ON MUTUAL AGREEMENT -C OR DISAGREEMENT WITHIN OBSERVATION STACKS. -C -C PROGRAM HISTORY LOG: -C 1989-04-01 P. JULIAN (W/NMC00) -- ORIGINAL AUTHOR -C 1990-03-29 P. JULIAN -- MODIFIED TO HONOR SDM/QCAIRCFT PURGE FOR -C STACKED OBSERVATIONS (OBS. INCRMENT CHECK) -C 1990-06-14 D. A. KEYSER -- CORRECTED TO HONOR ALL SDM/QCAIRCFT PURGES -C FOR STACKED OBS.; FIXED ERROR IN Q. MARK DESIGNATOR -C 1990-07-03 D. A. KEYSER -- ALT. CORRESP. TO PRESS. OF 300 & 200 MB -C FOR REGRESS. CALC. OF SUPEROBS OFF SLIGHTLY, FIXED -C 1990-09-18 D. A. KEYSER -- MINOR ERROR IN LOGIC CORRECTED, SOME ORIG. -C REPORTS WERE BEING GIVEN 'O' Q. MARK BY MISTAKE -C 1993-01-05 P. JULIAN -- SUBPROGRAM PRELIM CREATED FROM THE FIRST -C PORTION OF THE OLD VERSION -C 1994-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND -C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT -C 1995-03-27 D. A. KEYSER -- FOR INIDST=2, SUPEROBS NOW CONTAIN -C SUPEROBED FORECAST(GUESS) P-ALT, WIND DIR, WIND SPEED & -C TEMP (IF AVAILABLE FROM INDIV. RPTS MAKING UP SUPEROBS) -C 1995-04-26 D. A. KEYSER -- CORRECTED PROBLEM IN SUPEROBING GUESS -C (OCCASIONALLY OCCURRED) -C 1996-01-26 D. A. KEYSER -- CORRECTED DIVIDE-BY-ZERO POSSIBILITY IN -C THE CALCULATION OF MULTIPLE CORRELATIONS -C -C USAGE: CALL SUPROB(NUM,INDX,LK,LOALT,KNUM) -C INPUT ARGUMENT LIST: -C NUM - NUMBER OF OBSERVATIONS TO BE TREATED -C INDX - POINTER TO POSITION IN ORIGINAL AIRCRAFT ARRAY -C LOALT - NUMBER OF OBSERVATIONS AT LOW ALTITUDE -C KNUM - NUMBER OF GOOD WIND OBS -C -C OUTPUT ARGUMENT LIST: -C LK - POINTER INDICATING ' NUM + NO. OF SUPEROBS FORMED ' -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C REMARKS: CALLED BY MAIN PROGRAM. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE SUPROB(NUM,INDX,LK,LOALT,KNUM) - PARAMETER (IRMX= 80000, ISMX= 8000) - DIMENSION UOB(5),VOB(5),SALT(3),ALTNRM(5),QSPD(5),QDIR(5),TOB(5), - $ UOBF(5),VOBF(5),ALTNRF(5),QSPDF(5),QDIRF(5),TOBF(5),KFLAG(ISMX) - LOGICAL EWRITE - CHARACTER*8 ACID,SAID - CHARACTER*14 TAG - INTEGER IARRAY(ISMX),INDR(ISMX) - COMMON/SUMDAT/ISTCPT(ISMX),SAID(ISMX),SLAT(ISMX),SLON(ISMX), - $ SHGT(ISMX),STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX), - $ KBAD(ISMX),NUMORG,SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX) - COMMON/ALLDAT/IFLEPT(IRMX),ACID(IRMX),ALAT(IRMX),ALON(IRMX), - $ AALT(IRMX),TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE, - $ ATMP(IRMX),TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX), - $ ITEVNT(IRMX),IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX), - $ ADIRF(IRMX) - COMMON/CMPNTS/U(ISMX),V(ISMX),UF(ISMX),VF(ISMX) - COMMON/STWRIT/SWRITE,EWRITE,IWRITE - COMMON/STUFF/SDALT,TBAR -C FOLLOWING IS NUMBER OF OBS SEPARATING TREATMENT OF STACK - DATA KNO/5/ -C FOLLOWING ARE STANDARD ALT PRESS LEVELS FOR ANALYSIS(M) - DATA SALT/9160.,10360.,11780./,XMSG/99999./ - NUMORG = NUM -C NUMH IS THE NUMBER OF OBSERVATIONS AT MID- AND HIGH ALTITUDES - NUMH = NUM - LOALT - IF((NUMH.EQ.0.AND.NUM.GT.0).OR.NUMH.EQ.2) THEN -C FOR NUMH = 2 -- AVERAGE WHAT IS THERE - CALL AVEROB(NUM,INDX,LK) - RETURN - ELSE IF(NUMH.LT.2) THEN - LK = NUM - RETURN - END IF - IF(KNUM.GT.KNO) THEN -C*********************************************************************** -C FIND SUPEROBS FOR NUMBER LEFT .GT. 5 ( = KNO ) -C*********************************************************************** -C START SUPEROBING - CRSDA = 400. - IF(NUMH.GE.10) CRSDA = 300. - IF(SDALT.LT.CRSDA) THEN -C SUPEROB SINGLE LEVEL REPORTS, STND DEV OF ALTS NOT ENOUGH FOR INTERP - SUMU = 0.0 - SUMV = 0.0 - SUMS = 0.0 - SUMH = 0.0 - SUMTMP = 0.0 - NTEMP = 0 - SUMUF = 0.0 - SUMVF = 0.0 - SUMSF = 0.0 - SUMHF = 0.0 - SUMTMF = 0.0 - NTEMPF = 0 - NWINDF = 0 - NHGHTF = 0 - NT = 0 - DO K = 1,NUM - KNDX = INDX + K - 1 - IF(ISTCPT(K).GT.0) THEN - NT = NT + 1 - IF(TAG(KNDX)(2:2).NE.'F'.AND.ATMP(KNDX).LT.XMSG) THEN - NTEMP = NTEMP + 1 - SUMTMP = SUMTMP + ATMP(KNDX) - IF(ATMPF(KNDX).LT.XMSG) THEN - NTEMPF = NTEMPF + 1 - SUMTMF = SUMTMF + ATMPF(KNDX) - END IF - END IF - SUMU = SUMU + U(K) - SUMV = SUMV + V(K) - SUMS = SUMS + SSPD(K) - SUMH = SUMH + SHGT(K) - IF(AMAX1(UF(K),VF(K),SSPDF(K)).LT.XMSG) THEN - NWINDF = NWINDF + 1 - SUMUF = SUMUF + UF(K) - SUMVF = SUMVF + VF(K) - SUMSF = SUMSF + SSPDF(K) - END IF - IF(SHGTF(K).LT.XMSG) THEN - NHGHTF = NHGHTF + 1 - SUMHF = SUMHF + SHGTF(K) - END IF - IF(TAG(KNDX)(13:13).GT.'4') THEN - IF(EWRITE) PRINT 9038, KNDX,ACID(KNDX),ALAT(KNDX), - $ ALON(KNDX),TIME(KNDX),TAG(KNDX) - 9038 FORMAT(/' #EVENT 315: SUPROB; S-LVL TMP SUPEROBED, TEMP Q.M. "O"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KNDX)(2:2) = 'O' - TAG(KNDX)(13:13) = '4' - ITEVNT(KNDX) = 315 - END IF - IF(TAG(KNDX)(14:14).GT.'4') THEN - IF(EWRITE) PRINT 9039, KNDX,ACID(KNDX),ALAT(KNDX), - $ ALON(KNDX),TIME(KNDX),TAG(KNDX) - 9039 FORMAT(/' #EVENT 315: SUPROB; S-LVL WND SUPEROBED, WIND Q.M. "O"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KNDX)(4:4) = 'O' - TAG(KNDX)(14:14) = '4' - IWEVNT(KNDX) = 315 - END IF - END IF - ENDDO - IF(NT.GE.2) THEN - LK = NUM + 1 - SUMH = SUMH/NT - SUMU = SUMU/NT - SUMV = SUMV/NT - SUMS = SUMS/NT - SSPD(LK) = SUMS - SHGT(LK) = SUMH - STMP(LK) = XMSG - IF(NTEMP.GT.0) STMP(LK) = SUMTMP/NTEMP - SDIRF(K) = AVEDIR(SUMUF,SUMVF,SUMSF) - STIM(LK) = TBAR - SLAT(LK) = ALAT(INDX) - SLON(LK) = ALON(INDX) - SDIR(LK) = AVEDIR(SUMU,SUMV,SUMS) - SSPDF(K) = XMSG - SDIRF(K) = XMSG - IF(NWINDF.GT.0) THEN - SSPDF(K) = SUMSF/NWINDF - SDIRF(K)=AVEDIR(SUMUF/NWINDF,SUMVF/NWINDF,SUMSF/NWINDF) - END IF - SHGTF(LK) = XMSG - IF(NHGHTF.GT.0) SHGTF(LK) = SUMHF/NHGHTF - STMPF(LK) = XMSG - IF(NTEMPF.GT.0) STMPF(LK) = SUMTMF/NTEMPF - ISTCPT(LK) = NT - CTEMP = STMP(LK) - IF(STMP(LK).LT.XMSG) CTEMP = STMP(LK)/10. - CTMPF = STMPF(LK) - IF(STMPF(LK).LT.XMSG) CTMPF = STMPF(LK)/10. - PRINT 6412, NINT(SDIR(LK)),SSPD(LK),CTEMP+SIGN(.0005,CTEMP), - $ NINT(SHGT(LK)),ISTCPT(LK),NT,NINT(SDIRF(LK)),SSPDF(LK), - $ CTMPF+SIGN(.0005,CTMPF),NINT(SHGTF(LK)) - 6412 FORMAT(' SNG LVL: DIR/SPD=',I3,'/',F5.1,', TMP=',F6.1,', ALT=',I5, - $ ', ISTCPT=',I4,', # USED=',I3,', GES: DIR/SPD=',I5,'/',F7.1, - $ ', TMP=',F6.1,', ALT=',I5) - ELSE - RETURN - END IF - ELSE -C NOT SINGLE LEVEL, USE 2-D INTERP (TIME AND ALTITUDE) - SUMU = 0.0 - SUMV = 0.0 - SUMT = 0.0 - SUMA = 0.0 - SUMS = 0.0 - SSQU = 0.0 - SSQV = 0.0 - SSQT = 0.0 - SSQA = 0.0 - SSQS = 0.0 - CSPAU = 0.0 - CSPAV = 0.0 - CSPTU = 0.0 - CSPTV = 0.0 - CSPAS = 0.0 - CSPAT = 0.0 - CSPTS = 0.0 - CSPATM = 0.0 - CSPTTM = 0.0 - SUMUF = 0.0 - SUMVF = 0.0 - SUMTF = 0.0 - SUMAF = 0.0 - SSQUF = 0.0 - SSQVF = 0.0 - SSQTF = 0.0 - SSQAF = 0.0 - CSPAUF = 0.0 - CSPAVF = 0.0 - CSPTUF = 0.0 - CSPTVF = 0.0 - CFPATM = 0.0 - CFPTTM = 0.0 -C LOOP THRU ALL REPORTS CACLULATING REGRESSION INFO-WIND - NWIND = 0 - NWINDF = 0 - DO I = 1,NUM - JNDX = INDX + I - 1 - IF(IFLEPT(JNDX).GT.0) THEN - NWIND = NWIND + 1 - SUMU = SUMU + U(I) - SUMV = SUMV + V(I) - SUMS = SUMS + ASPD(JNDX) - SUMT = SUMT + TIME(JNDX) - SUMA = SUMA + AALT(JNDX) - SSQU = SSQU + (U(I) * U(I)) - SSQV = SSQV + (V(I) * V(I)) - SSQS = SSQS + (ASPD(JNDX) * ASPD(JNDX)) - SSQT = SSQT + (TIME(JNDX) * TIME(JNDX)) - SSQA = SSQA + (AALT(JNDX) * AALT(JNDX)) - CSPAU = CSPAU + (U(I) * AALT(JNDX)) - CSPAV = CSPAV + (V(I) * AALT(JNDX)) - CSPTU = CSPTU + (U(I) * TIME(JNDX)) - CSPTV = CSPTV + (V(I) * TIME(JNDX)) - CSPAS = CSPAS + (ASPD(JNDX) * AALT(JNDX)) - CSPTS = CSPTS + (ASPD(JNDX) * TIME(JNDX)) - CSPAT = CSPAT + (TIME(JNDX) * AALT(JNDX)) - IF(AMAX1(UF(I),VF(I),ASPDF(JNDX)).LT.XMSG) THEN - NWINDF = NWINDF + 1 - SUMUF = SUMUF + UF(I) - SUMVF = SUMVF + VF(I) - SUMTF = SUMTF + TIME(JNDX) - SUMAF = SUMAF + AALT(JNDX) - SSQUF = SSQUF + (UF(I) * UF(I)) - SSQVF = SSQVF + (VF(I) * VF(I)) - SSQTF = SSQTF + (TIME(JNDX) * TIME(JNDX)) - SSQAF = SSQAF + (AALT(JNDX) * AALT(JNDX)) - CSPAUF = CSPAUF + (UF(I) * AALT(JNDX)) - CSPAVF = CSPAVF + (VF(I) * AALT(JNDX)) - CSPTUF = CSPTUF + (UF(I) * TIME(JNDX)) - CSPTVF = CSPTVF + (VF(I) * TIME(JNDX)) - END IF - END IF - ENDDO - RNDF = 1./NWIND - RFNO = 1./NWIND - IF(NWIND.GT.3) RNDF = 1./(NWIND - 1) - UBAR = SUMU * RFNO - VBAR = SUMV * RFNO - TBAR = SUMT * RFNO - ABAR = SUMA * RFNO - SBAR = SUMS * RFNO - QQQ = (SSQU - (UBAR * UBAR * NWIND)) * RNDF - IF(QQQ.LE.0.0) QQQ = .0001 - SDU = SQRT(QQQ) - QQQ = (SSQV - (VBAR * VBAR * NWIND)) * RNDF - IF(QQQ.LE.0.0) QQQ = .0001 - SDV = SQRT(QQQ) - QQQ = (SSQT - (TBAR * TBAR * NWIND)) * RNDF - IF(QQQ.LE.0.0) QQQ = .0001 - SDT = SQRT(QQQ) - QQQ = (SSQA - (ABAR * ABAR * NWIND)) * RNDF - IF(QQQ.LE.0.0) QQQ = .0001 - SDALT = SQRT(QQQ) - QQQ = (SSQS - (SBAR * SBAR * NWIND)) * RNDF - IF(QQQ.LE.0.0) QQQ = .0001 - SDS = SQRT(QQQ) - RUA = ((CSPAU - (UBAR * ABAR * NWIND)) * RNDF)/(SDU *SDALT) - RVA = ((CSPAV - (VBAR * ABAR * NWIND)) * RNDF)/(SDV *SDALT) - RUT = ((CSPTU - (UBAR * TBAR * NWIND)) * RNDF)/(SDU * SDT) - RVT = ((CSPTV - (VBAR * TBAR * NWIND)) * RNDF)/(SDV * SDT) - RSA = ((CSPAS - (SBAR * ABAR * NWIND)) * RNDF)/(SDS *SDALT) - RST = ((CSPTS - (SBAR * TBAR * NWIND)) * RNDF)/(SDS * SDT) - RAT = ((CSPAT - (TBAR * ABAR * NWIND)) * RNDF)/(SDT *SDALT) - RNDFF = XMSG - ABARF = XMSG - UBARF = XMSG - VBARF = XMSG - TBARF = XMSG - IF(NWINDF.GT.0) THEN - RNDFF = 1./NWINDF - RFNOF = 1./NWINDF - IF(NWINDF.GT.3) RNDFF = 1./(NWINDF - 1) - UBARF = SUMUF * RFNOF - VBARF = SUMVF * RFNOF - TBARF = SUMTF * RFNOF - ABARF = SUMAF * RFNOF - END IF - SDUF = XMSG - SDALTF = XMSG - RUAF = XMSG - RUTF = XMSG - RVAF = XMSG - RVTF = XMSG - IF(NWINDF.GT.1) THEN - QQQF = (SSQUF - (UBARF * UBARF * NWINDF)) * RNDFF - IF(QQQF.LE.0.0) QQQF = .0001 - SDUF = SQRT(QQQF) - QQQF = (SSQVF - (VBARF * VBARF * NWINDF)) * RNDFF - IF(QQQF.LE.0.0) QQQF = .0001 - SDVF = SQRT(QQQF) - QQQF = (SSQTF - (TBARF * TBARF * NWINDF)) * RNDFF - IF(QQQF.LE.0.0) QQQF = .0001 - SDTF = SQRT(QQQF) - QQQF = (SSQAF - (ABARF * ABARF * NWINDF)) * RNDFF - IF(QQQF.LE.0.0) QQQF = .0001 - SDALTF = SQRT(QQQF) - RUAF =((CSPAUF-(UBARF*ABARF*NWINDF))*RNDFF)/(SDUF*SDALTF) - RVAF =((CSPAVF-(VBARF*ABARF*NWINDF))*RNDFF)/(SDVF*SDALTF) - RUTF =((CSPTUF-(UBARF*TBARF*NWINDF))*RNDFF)/(SDUF*SDTF) - RVTF =((CSPTVF-(VBARF*TBARF*NWINDF))*RNDFF)/(SDVF*SDTF) - END IF -C LOOP THRU ALL REPORTS CACLULATING REGRESSION INFO FOR TEMPERATURES - SUMTT = 0.0 - SUMAT = 0.0 - SUMTMP = 0.0 - SSQTT = 0.0 - SSQAT = 0.0 - SSQTMP = 0.0 - CSPATM = 0.0 - CSPTTM = 0.0 - NTEMP = 0 - SUMTTF = 0.0 - SUMATF = 0.0 - SUMTMF = 0.0 - SSQTTF = 0.0 - SSQATF = 0.0 - SSQTMF = 0.0 - CFPATM = 0.0 - CFPTTM = 0.0 - NTEMPF = 0 - DO JNDX = INDX,INDX+NUM-1 - IF(TAG(JNDX)(2:2).NE.'F'.AND.ATMP(JNDX).LT.XMSG) THEN - NTEMP = NTEMP + 1 - SUMTT = SUMTT + TIME(JNDX) - SUMAT = SUMAT + AALT(JNDX) - SUMTMP = SUMTMP + ATMP(JNDX) - SSQTT = SSQTT + (TIME(JNDX) * TIME(JNDX)) - SSQAT = SSQAT + (AALT(JNDX) * AALT(JNDX)) - SSQTMP = SSQTMP + (ATMP(JNDX) * ATMP(JNDX)) - CSPATM = CSPATM + (ATMP(JNDX) * AALT(JNDX)) - CSPTTM = CSPTTM + (ATMP(JNDX) * TIME(JNDX)) - IF(ATMPF(JNDX).LT.XMSG) THEN - NTEMPF = NTEMPF + 1 - SUMTTF = SUMTTF + TIME(JNDX) - SUMATF = SUMATF + AALT(JNDX) - SUMTMF = SUMTMF + ATMPF(JNDX) - SSQTTF = SSQTTF + (TIME(JNDX) * TIME(JNDX)) - SSQATF = SSQATF + (AALT(JNDX) * AALT(JNDX)) - SSQTMF = SSQTMF + (ATMPF(JNDX) * ATMPF(JNDX)) - CFPATM = CFPATM + (ATMPF(JNDX) * AALT(JNDX)) - CFPTTM = CFPTTM + (ATMPF(JNDX) * TIME(JNDX)) - END IF - END IF - ENDDO - TTBAR = XMSG - ATBAR = XMSG - TMPBAR = XMSG - IF(NTEMP.GT.0) THEN -CVVVVV FIX BY DAK 3/14/95 (ADDED NEXT LINE) - RNDF = 1./NTEMP -CAAAAA FIX BY DAK 3/14/95 - RFNO = 1./NTEMP - IF(NTEMP.GT.3) RNDF = 1./(NTEMP - 1) - TMPBAR = SUMTMP * RFNO - TTBAR = SUMTT * RFNO - ATBAR = SUMAT * RFNO - END IF - QQQ = 0.0 - RTTT = XMSG - RTMA = XMSG - SDTMP = XMSG - IF(NTEMP.GT.1) THEN - QQQ = (SSQTMP - (TMPBAR * TMPBAR * NTEMP)) * RNDF - IF(QQQ.LE.0.0) QQQ = .0001 - SDTMP = SQRT(QQQ) - QQQ = (SSQTT - (TTBAR * TTBAR * NTEMP)) * RNDF - IF(QQQ.LE.0.0) QQQ = .0001 - SDTT = SQRT(QQQ) - QQQ = (SSQAT - (ATBAR * ATBAR * NTEMP)) * RNDF - IF(QQQ.LE.0.0) QQQ = .0001 - SDAT = SQRT(QQQ) -CCCCC PRINT 6346, TMPBAR,TTBAR,SDTMP,SDTT,ATBAR,SDAT -C6346 FORMAT(' STATS ',6F12.3) - RTTT = ((CSPTTM-(TMPBAR*TTBAR*NTEMP))*RNDF)/(SDTMP*SDTT) - RTMA = ((CSPATM-(TMPBAR*ATBAR*NTEMP))*RNDF)/(SDTMP*SDAT) - PRINT 6017, RTTT,RTMA,NTEMP - 6017 FORMAT(' CORR COEFFS TEMP-TIME,TEMP-ALT ', - $ 2F7.2,' WITH NTEMP=',I3) - END IF - TTBARF = XMSG - ATBARF = XMSG - TMFBAR = XMSG - IF(NTEMPF.GT.0) THEN - RNDFF = 1./NTEMPF - RFNOF = 1./NTEMPF - IF(NTEMPF.GT.3) RNDFF = 1./(NTEMPF - 1) - TMFBAR = SUMTMF * RFNOF - TTBARF = SUMTTF * RFNOF - ATBARF = SUMATF * RFNOF - END IF - QQQF = 0.0 - RTTTF = XMSG - RTMAF = XMSG - SDTMPF = XMSG - IF(NTEMPF.GT.1) THEN - QQQF = (SSQTMF - (TMFBAR * TMFBAR * NTEMPF)) * RNDFF - IF(QQQF.LE.0.0) QQQF = .0001 - SDTMPF = SQRT(QQQF) - QQQF = (SSQTTF - (TTBARF * TTBARF * NTEMPF)) * RNDFF - IF(QQQF.LE.0.0) QQQF = .0001 - SDTTF = SQRT(QQQF) - QQQF = (SSQATF - (ATBARF * ATBARF * NTEMPF)) * RNDFF - IF(QQQF.LE.0.0) QQQF = .0001 - SDATF = SQRT(QQQF) -CCCCC PRINT 7346, TMFBAR,TTBARF,SDTMPF,SDTTF,ATBARF,SDATF -C7346 FORMAT(' GESS STATS ',6F12.3) - RTTTF=((CFPTTM-(TMFBAR*TTBARF*NTEMPF))*RNDFF)/(SDTMPF*SDTTF) - RTMAF=((CFPATM-(TMFBAR*ATBARF*NTEMPF))*RNDFF)/(SDTMPF*SDATF) - PRINT 7017, RTTTF,RTMAF,NTEMPF - 7017 FORMAT(' GESS CORR COEFFS TEMP-TIME,TEMP-ALT ', - $ 2F7.2,' WITH NTEMPF=',I3) - END IF -C CALCULATE MULTIPLE CORRELATIONS - DEN = 1. - (RAT * RAT) - IF(DEN.EQ.0.) DEN = 0.0001 - RUMULT = ((RUA*RUA+RUT*RUT-2.*RUA*RUT*RAT)/DEN) - IF(RUMULT.LE.0.0) RUMULT = .0001 - RUMULT = SQRT(RUMULT) - RVMULT = ((RVA*RVA+RVT*RVT-2.*RVA*RVT*RAT)/DEN) - IF(RVMULT.LE.0.0) RVMULT = .0001 - RVMULT = SQRT(RVMULT) - PRINT 6016, RUA,RUT,RVA,RVT,RSA,RST,NWIND - 6016 FORMAT(' CORR COEFFS RUA,RUT,RVA,RVT,RSPDA,RSPDT ', - $ 3(2F7.2,4X),'WITH NWIND=',I3) - PRINT 6416, RUMULT,RVMULT,RAT - 6416 FORMAT(' MULT CORR COEFFS, U-COMP, V-COMP ',2F9.2,';ALT,TIME ', - $ 'CORR= ',F9.2) - KOUNT = 0 -C CHECK ON NUMBER LEFT - IF(NWIND.GT.KNO) THEN -C CHECK ON TIME DEVIATION - TIMCHK = ABS(TBASE-TBAR)/SDT - IF(TIMCHK.LE.2.8) THEN -C FIND MAX & MIN WIND SPEED - IARRAY(1:NUM) = NINT(SSPD(1:NUM)*100.) - IF(NUM.GT.0) CALL INDEXF(NUM,IARRAY,INDR) - TIMCHK = (TBASE-TBAR)/SDT - SPDMAX = SSPD(INDR(NUM)) - SPDMIN = SSPD(INDR(1)) -C FIND MAX & MIN TEMPERATURE - IARRAY(1:NUM) = NINT(STMP(1:NUM)*100.) - IF(NUM.GT.0) CALL INDEXF(NUM,IARRAY,INDR) - TMPMAX = STMP(INDR(NUM)) - IF(TMPMAX.GE.XMSG) TMPMAX = STMP(INDR(NUM-1)) - TMPMIN = STMP(INDR(1)) -C TRY TO INTERPOLATE TO THREE STANDARD LEVELS - DO JA = 1,3 - UOB(JA) = XMSG - VOB(JA) = XMSG - QSPD(JA) = XMSG - QDIR(JA) = XMSG - TOB(JA) = XMSG - ALTNRM(JA) = (SALT(JA) - ABAR)/SDALT - UOBF(JA) = XMSG - VOBF(JA) = XMSG - QSPDF(JA) = XMSG - QDIRF(JA) = XMSG - TOBF(JA) = XMSG - ALTNRF(JA) = XMSG - IF(NWINDF.GT.1) ALTNRF(JA) =(SALT(JA)-ABARF)/SDALTF -C THE FOLLOWING VALUES OF VARIABLE QQQ ARE SELECTABLE CONSTANTS -C SPECIFYING THE ALLOWABLE SPREAD IN ALT; THEY ARE FUNCTIONS OF -C THE MULT CORRELATIONS (WIND COMPS WITH TIME AND ALTITIUDE) - IF(RUMULT.GT.0.85.OR.RVMULT.GT.0.85) THEN - QQQ = 1.8 - ELSE IF(RUMULT.GT.0.70.OR.RVMULT.GT.0.70) THEN - QQQ = 1.6 - ELSE - QQQ = 1.2 - END IF -C IF ALT DEVIATION TOO GREAT, SKIP LEVEL - IF(ABS(ALTNRM(JA)).LE.QQQ) THEN -C TRY IT - UOB(JA) = (RUT * SDU * TIMCHK) + (RUA * SDU * ALTNRM(JA)) + UBAR -C KEYSER: ASK PAUL: ANY CHANCE BELOW SHOULD BE 'SDV' INSTEAD OF 'SDU' - VOB(JA) = (RVT * SDU * TIMCHK) + (RVA * SDU * ALTNRM(JA)) + VBAR - QSPD(JA) = SQRT(UOB(JA)**2 + VOB(JA)**2) - QDIR(JA) = AVEDIR(UOB(JA),VOB(JA),QSPD(JA)) - IF(NTEMP.GT.1) TOB(JA) = (RTTT * SDTMP * - $ TIMCHK) + (RTMA * SDTMP * ALTNRM(JA)) + TMPBAR - IF(NWINDF.GT.1) THEN - UOBF(JA)=(RUTF * SDUF * TIMCHK)+(RUAF * SDUF * ALTNRF(JA))+UBARF -C KEYSER: ASK PAUL: ANY CHANCE BELOW SHOULD BE 'SDVF' INSTEAD OF 'SDUF' - VOBF(JA)=(RVTF * SDUF * TIMCHK)+(RVAF * SDUF * ALTNRF(JA))+VBARF - QSPDF(JA) = SQRT(UOBF(JA)**2 + VOBF(JA)**2) - QDIRF(JA)=AVEDIR(UOBF(JA),VOBF(JA),QSPDF(JA)) - END IF - IF(NTEMPF.GT.1) TOBF(JA) = (RTTTF * SDTMPF * - $ TIMCHK) + (RTMAF * SDTMPF * ALTNRF(JA)) + TMFBAR -C ADJUSTABLE LIMITS TUNING OPTION - QMAX = SPDMAX * 1.09 - QMIN = SPDMIN * 0.91 -C IF ESTIMATED WIND OUTSIDE LIMITS, SKIP IT (W.R.T. REGRESSION) - IF(QSPD(JA).LE.QMAX.AND.QSPD(JA).GE.QMIN) THEN -C OTHERWISE, GO ON - KOUNT = KOUNT + 1 - LK = KOUNT + NUM - SDIR(LK) = QDIR(JA) - SSPD(LK) = QSPD(JA) - SLAT(LK) = ALAT(INDX) - SLON(LK) = ALON(INDX) - SHGT(LK) = SALT(JA) - STIM(LK) = TBASE - SDIRF(LK) = QDIRF(JA) - SSPDF(LK) = QSPDF(JA) - SHGTF(LK) = XMSG - IF(NWINDF.GT.1) SHGTF(LK) = SALT(JA) - QMAX = TMPMAX * 0.91 - QMIN = TMPMIN * 1.05 - STMP(LK) = XMSG - STMPF(LK) = XMSG - IF(TOB(JA).LE.QMAX.AND.TOB(JA).GE.QMIN) THEN - STMP(LK) = TOB(JA) - STMPF(LK) = TOBF(JA) - END IF - ISTCPT(LK) = LK - END IF - END IF - CTEMP = TOB(JA) - IF(TOB(JA).LT.XMSG) CTEMP = TOB(JA)/10. - CTMPF = TOBF(JA) - IF(TOBF(JA).LT.XMSG) CTMPF = TOBF(JA)/10. - PRINT 6712, NINT(SALT(JA)),NINT(QDIR(JA)),QSPD(JA),ALTNRM(JA), - $ TIMCHK,KOUNT,CTEMP+SIGN(.0005,CTEMP),NINT(QDIRF(JA)),QSPDF(JA), - $ CTMPF+SIGN(.0005,CTMPF) - 6712 FORMAT(' FOR ALT=',I5,',DIR/SPD=',I5,'/',F7.1,',NORM ALT=',F4.1, - $ ',NORM TIME=',F4.1,',KOUNT=',I3,',TMP=',F7.1,',GES: DIR/SPD=',I5, - $ '/',F7.1,',TMP=',F7.1) - ENDDO - END IF - END IF -C ALL INTERPS HAVE BEEN TRIED, RESULT IS KOUNT - IF(KOUNT.GT.0) THEN - DO I = 1,NUM - KNDX = INDX + I - 1 - IF(ISTCPT(I).GT.0) THEN -C Q.MARKS WILL BE SET TO 'O' --> OMIT - IF(TAG(KNDX)(13:13).GT.'4') THEN - IF(EWRITE) PRINT 9040, KNDX,ACID(KNDX), - $ ALAT(KNDX),ALON(KNDX),TIME(KNDX),TAG(KNDX) - 9040 FORMAT(/' #EVENT 315: SUPROB; M-LVL TMP SUPEROBED, TEMP Q.M. "O"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KNDX)(2:2) = 'O' - TAG(KNDX)(13:13) = '4' - ITEVNT(KNDX) = 315 - END IF - IF(TAG(KNDX)(14:14).GT.'4') THEN - IF(EWRITE) PRINT 9041, KNDX,ACID(KNDX), - $ ALAT(KNDX),ALON(KNDX),TIME(KNDX),TAG(KNDX) - 9041 FORMAT(/' #EVENT 315: SUPROB; M-LVL WND SUPEROBED, WIND Q.M. "O"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KNDX)(4:4) = 'O' - TAG(KNDX)(14:14) = '4' - IWEVNT(KNDX) = 315 - END IF - ELSE IF(ISTCPT(I).EQ.0) THEN - IF(TAG(KNDX)(13:13).GT.'3') THEN - IF(EWRITE) PRINT 9042, KNDX,ACID(KNDX), - $ ALAT(KNDX),ALON(KNDX),TIME(KNDX),TAG(KNDX) - 9042 FORMAT(/' #EVENT 323: SUPROB; MUL-LVL TEMP BAD, TEMP Q.M. IS "F"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KNDX)(2:2) = 'F' - TAG(KNDX)(13:13) = '3' - ITEVNT(KNDX) = 323 - END IF - IF(TAG(KNDX)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 8042, KNDX,ACID(KNDX), - $ ALAT(KNDX),ALON(KNDX),TIME(KNDX),TAG(KNDX) - 8042 FORMAT(/' #EVENT 323: SUPROB; MUL-LVL WIND BAD, WIND Q.M. IS "F"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KNDX)(4:4) = 'F' - TAG(KNDX)(14:14) = '3' - IWEVNT(KNDX) = 323 - END IF - ELSE IF(ISTCPT(I).LT.0) THEN - IF(TAG(KNDX)(13:13).GT.'7') THEN - IF(EWRITE) PRINT 9043, KNDX,ACID(KNDX), - $ ALAT(KNDX),ALON(KNDX),TIME(KNDX),TAG(KNDX) - 9043 FORMAT(/' #EVENT ###: SUPROB; MUL-LO-LVL TEMP, TEMP Q.M. IS " "', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KNDX)(13:13) = '7' - END IF - IF(TAG(KNDX)(14:14).GT.'7') THEN - IF(EWRITE) PRINT 8043, KNDX,ACID(KNDX), - $ ALAT(KNDX),ALON(KNDX),TIME(KNDX),TAG(KNDX) - 8043 FORMAT(/' #EVENT ###: SUPROB; MUL-LO-LVL WIND, WIND Q.M. IS " "', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KNDX)(14:14) = '7' - END IF - END IF - ENDDO - ELSE -C INTERPOLATION FAILED SO TRANSFER TO AVEROB - CALL AVEROB(NUM,INDX,LK) - END IF -C SUPEROB ANY LOW ALTITUDE REPORTS - IF(LOALT.GE.2) THEN - KFLAG = 0 - DO K = 1,NUM - IF(K.EQ.NUM) GO TO 705 - JNDX = INDX + K - 1 - IF(ISTCPT(K).LT.0.AND.KFLAG(K).EQ.0) THEN - KOUNT = 1 - KOUNTM = 0 - KOUNWF = 0 - KOUNTF = 0 - KOUNHF = 0 - SUMD = SDIR(K) - SUMS = SSPD(K) - SUMT = STIM(K) - SUMH = SHGT(K) - SUMDF = XMSG - SUMSF = XMSG - IF(AMAX1(SDIRF(K),SSPDF(K)).LT.XMSG) THEN - SUMDF = SDIRF(K) - SUMSF = SSPDF(K) - KOUNWF = KOUNWF + 1 - END IF - SUMTMP = XMSG - SUMTMF = XMSG - IF(STMP(K).LT.XMSG) THEN - SUMTMP = STMP(K) - KOUNTM = 1 - IF(STMPF(K).LT.XMSG) THEN - SUMTMF = STMPF(K) - KOUNTF = 1 - END IF - END IF - SUMHF = XMSG - IF(SHGTF(K).LT.XMSG) THEN - SUMHF = SHGTF(K) - KOUNHF = 1 - END IF - DO KK = K+1,NUM - KNDX = INDX + KK - 1 - IF(ISTCPT(KK).LT.0.AND.ABS(SHGT(K)-SHGT(KK)).LT.150..AND. - $ ABS(STIM(K)-STIM(KK)).LT.350..AND.KFLAG(KK).EQ.0) THEN - SUMD = SDIR(KK) + SUMD - SUMS = SSPD(KK) + SUMS - SUMT = STIM(KK) + SUMT - SUMH = SHGT(KK) + SUMH - KOUNT = KOUNT + 1 - KFLAG(KK) = -1 - IF(AMAX1(SDIRF(KK),SSPDF(KK)).LT.XMSG.AND.KOUNWF.GT.0) THEN - SUMDF = SDIRF(KK) + SUMDF - SUMSF = SSPDF(KK) + SUMSF - KOUNWF = KOUNWF + 1 - END IF - IF(STMP(KK).LT.XMSG.AND.KOUNTM.GT.0) THEN - SUMTMP = STMP(KK) + SUMTMP - KOUNTM = KOUNTM + 1 - IF(STMPF(KK).LT.XMSG.AND.KOUNTF.GT.0) THEN - SUMTMF = STMPF(KK) + SUMTMF - KOUNTF = KOUNTF + 1 - END IF - END IF - IF(SHGTF(KK).LT.XMSG.AND.KOUNHF.GT.0) THEN - SUMHF = SHGTF(KK) + SUMHF - KOUNHF = KOUNHF + 1 - END IF - IF(TAG(JNDX)(13:13).GT.'4') THEN - IF(EWRITE) PRINT 9044, JNDX,ACID(JNDX), - $ ALAT(KNDX),ALON(JNDX),TIME(JNDX),TAG(JNDX) - 9044 FORMAT(/' #EVENT 315: SUPROB; MUL-LO-LVL TMP SUPOBED, TMP QM "O"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(JNDX)(2:2) = 'O' - TAG(JNDX)(13:13) = '4' - ITEVNT(JNDX) = 315 - END IF - IF(TAG(JNDX)(14:14).GT.'4') THEN - IF(EWRITE) PRINT 8044, JNDX,ACID(JNDX), - $ ALAT(JNDX),ALON(JNDX),TIME(JNDX),TAG(JNDX) - 8044 FORMAT(/' #EVENT 315: SUPROB; MUL-LO-LVL WND SUPOBED, WND QM "O"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(JNDX)(4:4) = 'O' - TAG(JNDX)(14:14) = '4' - IWEVNT(JNDX) = 315 - END IF - IF(TAG(KNDX)(13:13).GT.'4') THEN - IF(EWRITE) PRINT 9044, KNDX,ACID(KNDX), - $ ALAT(KNDX),ALON(KNDX),TIME(KNDX),TAG(KNDX) - TAG(KNDX)(2:2) = 'O' - TAG(KNDX)(13:13) = '4' - ITEVNT(KNDX) = 315 - END IF - IF(TAG(KNDX)(14:14).GT.'4') THEN - IF(EWRITE) PRINT 8044, KNDX,ACID(KNDX), - $ ALAT(KNDX),ALON(KNDX),TIME(KNDX),TAG(KNDX) - TAG(KNDX)(4:4) = 'O' - TAG(KNDX)(14:14) = '4' - IWEVNT(KNDX) = 315 - END IF - END IF - ENDDO - IF(KOUNT.GT.1) THEN - SUMD = SUMD/KOUNT - SUMS = SUMS/KOUNT - TBAR = SUMT/KOUNT - SUMH = SUMH/KOUNT - LK = LK + 1 - SSPD(LK) = SUMS - SDIR(LK) = SUMD - SHGT(LK) = SUMH - SSPDF(LK) = XMSG - SDIRF(LK) = XMSG - IF(KOUNWF.GT.0) THEN - SSPDF(LK) = SUMSF/KOUNWF - SDIRF(LK) = SUMDF/KOUNWF - END IF - STMP(LK) = XMSG - STMPF(LK) = XMSG - IF(KOUNTM.GT.0) THEN - STMP(LK) = SUMTMP/KOUNTM - IF(KOUNTF.GT.0) STMPF(LK) = SUMTMF/KOUNTF - END IF - SHGTF(LK) = XMSG - IF(KOUNHF.GT.0) SHGTF(LK) = SUMHF/KOUNHF - SLAT(LK) = ALAT(INDX) - SLON(LK) = ALON(INDX) - STIM(LK) = TBAR - ISTCPT(LK) = KOUNT - CTEMP = STMP(LK) - IF(STMP(LK).LT.XMSG) CTEMP = STMP(LK)/10. - CTMPF = STMPF(LK) - IF(STMPF(LK).LT.XMSG) CTMPF = STMPF(LK)/10. -CVVVVVV%%%%% - PRINT *, ' ~~~~~ HERE IS LOW ALT FIX-UP FOR SUPEROBING' -CAAAAAA%%%%% - PRINT 6427, LK,KOUNT,NINT(SDIR(LK)),SSPD(LK), - $ CTEMP+SIGN(.0005,CTEMP),NINT(SHGT(LK)),NINT(SDIRF(LK)),SSPDF(LK), - $ CTMPF+SIGN(.0005,CTMPF),NINT(SHGTF(LK)) - 6427 FORMAT(' LOALT(SUPROB)',I3,',KOUNT=',I5,',DIR/SPD=',I3,'/',F5.1, - $ ',TMP=',F7.1,',ALT=',I5,',GES: DIR/SPD=',I5,'/',F7.1,',TMP=', - $ F7.1,',ALT=',I5) - END IF - END IF - 705 CONTINUE - ENDDO - END IF - END IF - RETURN - ELSE -C*********************************************************************** -C FIND SUPEROBS FOR NUMBER LEFT .LE. 5 -C*********************************************************************** - IF(NUM.LE.2) RETURN -C SUPEROB SINGLE LEVEL REPORTS - NUMGT = MAX0(NUMORG,NUM) - LK = NUMGT - IF(SDALT.LT.400.) THEN - SUMU = 0.0 - SUMV = 0.0 - SUMS = 0.0 - SUMA = 0.0 - SUMTMP = 0.0 - NTEMP = 0 - SUMUF = 0.0 - SUMVF = 0.0 - SUMSF = 0.0 - SUMAF = 0.0 - SUMTMF = 0.0 - NTEMPF = 0 - NWINDF = 0 - NHGHTF = 0 - NT = 0 - DO K = 1,NUMGT - JNDX = INDX + K - 1 - IF(IFLEPT(JNDX).EQ.0.OR.TAG(JNDX)(4:4).EQ.'F') THEN - ISTCPT(K) = IFLEPT(JNDX) - ELSE IF(ISTCPT(K).GT.0) THEN - NT = NT + 1 - IF(ATMP(JNDX).LT.XMSG.AND.TAG(JNDX)(2:2).NE.'F') THEN - NTEMP = NTEMP + 1 - SUMTMP = SUMTMP + ATMP(JNDX) - IF(ATMPF(JNDX).LT.XMSG) THEN - NTEMPF = NTEMPF + 1 - SUMTMF = SUMTMF + ATMPF(JNDX) - END IF - END IF - SUMU = SUMU + U(K) - SUMV = SUMV + V(K) - SUMS = SUMS + SSPD(K) - SUMA = SUMA + SHGT(K) - IF(AMAX1(UF(K),VF(K),SSPDF(K)).LT.XMSG) THEN - NWINDF = NWINDF + 1 - SUMUF = SUMUF + UF(K) - SUMVF = SUMVF + VF(K) - SUMSF = SUMSF + SSPDF(K) - END IF - IF(SHGTF(K).LT.XMSG) THEN - NHGHTF = NHGHTF + 1 - SUMAF = SUMAF + SHGTF(K) - END IF - IF(TAG(JNDX)(13:13).GT.'4') THEN - IF(EWRITE) PRINT 9038, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - TAG(JNDX)(2:2) = 'O' - TAG(JNDX)(13:13) = '4' - ITEVNT(JNDX) = 315 - END IF - IF(TAG(JNDX)(14:14).GT.'4') THEN - IF(EWRITE) PRINT 9039, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - TAG(JNDX)(4:4) = 'O' - TAG(JNDX)(14:14) = '4' - IWEVNT(JNDX) = 315 - END IF - END IF - ENDDO - IF(NT.EQ.0.OR.NT.EQ.1) RETURN - IF(NT.EQ.2) THEN - CALL NOEQ2(NUM,INDX,LK) - ELSE - LK = LK + 1 - SUMU = SUMU/NT - SUMV = SUMV/NT - SUMS = SUMS/NT - SHGT(LK) = SUMA/NT - STIM(LK) = TBAR - SLAT(LK) = ALAT(INDX) - SLON(LK) = ALON(INDX) - ISTCPT(LK) = IFLEPT(INDX) - SSPD(LK) = SUMS - SDIR(LK) = AVEDIR(SUMU,SUMV,SUMS) - SSPDF(LK) = XMSG - SDIRF(LK) = XMSG - IF(NWINDF.GT.0) THEN - SSPDF(LK) = SUMSF/NWINDF - SDIRF(LK) = AVEDIR(SUMUF/NWINDF,SUMVF/NWINDF,SUMSF/NWINDF) - END IF - SHGTF(LK) = XMSG - IF(NHGHTF.GT.0) SHGTF(LK) = SUMAF/NHGHTF - STMP(LK) = XMSG - STMPF(LK) = XMSG - IF(NTEMP.GT.0) THEN - STMP(LK) = SUMTMP/NTEMP - IF(NTEMPF.GT.0) STMPF(LK) = SUMTMF/NTEMPF - END IF - END IF - DO I = 1,NUM - KNDX = INDX + I - 1 - IF(ISTCPT(I).GT.0) THEN - IF(TAG(KNDX)(13:13).GT.'4') THEN - IF(EWRITE) PRINT 9038, KNDX,ACID(KNDX),ALAT(KNDX), - $ ALON(KNDX),TIME(KNDX),TAG(KNDX) - TAG(KNDX)(2:2) = 'O' - TAG(KNDX)(13:13) = '4' - ITEVNT(KNDX) = 315 - END IF - IF(TAG(KNDX)(14:14).GT.'4') THEN - IF(EWRITE) PRINT 9039, KNDX,ACID(KNDX),ALAT(KNDX), - $ ALON(KNDX),TIME(KNDX),TAG(KNDX) - TAG(KNDX)(4:4) = 'O' - TAG(KNDX)(14:14) = '4' - IWEVNT(KNDX) = 315 - END IF - END IF - ENDDO - CTEMP = STMP(K) - IF(STMP(K).LT.XMSG) CTEMP = STMP(K)/10. - CTMPF = STMPF(K) - IF(STMPF(K).LT.XMSG) CTMPF = STMPF(K)/10. - PRINT 8412, LK,NINT(SDIR(LK)),SSPD(LK),NINT(STIM(LK)), - $ NINT(SHGT(LK)),CTEMP+SIGN(.0005,CTEMP),NT,NINT(SDIRF(LK)), - $ SSPDF(LK),NINT(SHGTF(LK)),CTMPF+SIGN(.0005,CTMPF) - 8412 FORMAT(' LK=',I3,' SDALT <400, DIR/SPD=',I3,'/',F5.1,',TIME=',I4, - $ ',ALT=',I5,',TMP=',F7.1,I4,' OBS, GES: DIR/SPD=',I5,'/',F7.1, - $ ',ALT=',I5,',TMP=',F7.1) -C ELSE NOT SINGLE LEVEL - ELSE - CALL AVEROB(NUM,INDX,LK) - END IF - END IF - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: NOEQ2 DOES SUPEROBING FOR TWO OBSERVATIONS ONLY -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1995-03-27 -C -C ABSTRACT: CALCULATES SUPEROB FOR CASE OF TWO OBSERVATIONS ONLY. -C -C PROGRAM HISTORY LOG: -C 1989-04-01 P. JULIAN (W/NMC00) -- ORIGINAL AUTHOR -C 1990-03-29 P. JULIAN -- MODIFIED TO HONOR SDM/QCAIRCFT PURGE FOR -C STACKED OBSERVATIONS (OBS. INCRMENT CHECK) -C 1990-06-14 D. A. KEYSER -- CORRECTED TO HONOR ALL SDM/QCAIRCFT PURGES -C FOR STACKED OBS.; FIXED ERROR IN Q. MARK DESIGNATOR -C 1990-07-03 D. A. KEYSER -- ALT. CORRESP. TO PRESS. OF 300 & 200 MB -C FOR REGRESS. CALC. OF SUPEROBS OFF SLIGHTLY, FIXED -C 1990-09-18 D. A. KEYSER -- MINOR ERROR IN LOGIC CORRECTED, SOME ORIG. -C REPORTS WERE BEING GIVEN 'O' Q. MARK BY MISTAKE -C 1994-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND -C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT -C 1995-03-27 D. A. KEYSER -- FOR INIDST=2, SUPEROBS NOW CONTAIN -C SUPEROBED FORECAST(GUESS) P-ALT, WIND DIR, WIND SPEED & -C TEMP (IF AVAILABLE FROM INDIV. RPTS MAKING UP SUPEROBS) -C -C USAGE: CALL NOEQ2(NUM,INDX,LK) -C INPUT ARGUMENT LIST: -C NUM - NUMBER OF OBSERVATIONS TO BE TREATED -C INDX - POINTER TO POSITION IN ORIGINAL AIRCRAFT ARRAY -C -C OUTPUT ARGUMENT LIST: -C LK - POINTER INDICATING ' NUM + NO. OF SUPEROBS FORMED ' -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C REMARKS: CALLED BY MAIN PROGRAM AND BY SUBROUTINES 'AVEROB' AND -C 'SUPROB'. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE NOEQ2(NUM,INDX,LK) - PARAMETER (IRMX= 80000, ISMX= 8000) - LOGICAL L1L,L2L,EWRITE - CHARACTER*8 ACID,SAID - CHARACTER*14 TAG - COMMON/SUMDAT/ISTCPT(ISMX),SAID(ISMX),SLAT(ISMX),SLON(ISMX), - $ SHGT(ISMX),STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX), - $ KBAD(ISMX),NUMORG,SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX) - COMMON/ALLDAT/IFLEPT(IRMX),ACID(IRMX),ALAT(IRMX),ALON(IRMX), - $ AALT(IRMX),TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE, - $ ATMP(IRMX),TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX), - $ ITEVNT(IRMX),IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX), - $ ADIRF(IRMX) - COMMON/STWRIT/SWRITE,EWRITE,IWRITE - COMMON/CMPNTS/U(ISMX),V(ISMX),UF(ISMX),VF(ISMX) - DATA XMSG/99999./ - LK = NUMORG -C LK IS INITIALIZED TO NUMBER IN STACK -C K1 AND K2 ARE RELATIVE TO STACK; I1 AND I2 ARE RELATIVE TO ALL OBS. - K1 = 0 - K2 = 0 - DO K = 1,NUM - KNDX = INDX + K - 1 - IF(ISTCPT(K).NE.0.AND.TAG(KNDX)(4:4).NE.'F') THEN - IF(K1.EQ.0) THEN - K1 = K - KBAD(K) = K - ELSE - K2 = K - KBAD(K) = K - END IF - END IF - ENDDO -C BOTH OBS. MUST BE GOOD, MID- OR HIGH-ALTITUDE - IF(K1.EQ.0.OR.K2.EQ.0) RETURN - I1 = INDX + K1 - 1 - I2 = INDX + K2 - 1 -C L1L & L2L ARE TRUE FOR LARGE VECTOR INCREMENT (V-Z) - L1L = (TAG(I1)(1:1).GE.'V'.AND.TAG(I1)(1:1).LE.'Z') - L2L = (TAG(I2)(1:1).GE.'V'.AND.TAG(I2)(1:1).LE.'Z') - IF(L1L.AND.TAG(I1)(3:3).EQ.'E') THEN - IF(TAG(I1)(13:13).GT.'3') THEN - IF(EWRITE) PRINT 9047, I1,ACID(I1),ALAT(I1),ALON(I1), - $ TIME(I1),TAG(I1) - 9047 FORMAT(/' #EVENT 324: NOEQ2; VRY LRG INCR/?TRKCHK ERR,TMP QM "F"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(I1)(2:2) = 'F' - TAG(I1)(13:13) = '3' - ITEVNT(I1) = 324 - END IF - IF(TAG(I1)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 8047, I1,ACID(I1),ALAT(I1),ALON(I1), - $ TIME(I1),TAG(I1) - 8047 FORMAT(/' #EVENT 324: NOEQ2; VRY LRG INCR/?TRKCHK ERR,WND QM "F"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(I1)(4:4) = 'F' - TAG(I1)(14:14) = '3' - IWEVNT(I1) = 324 - END IF - RETURN - END IF - IF(L2L.AND.TAG(I2)(3:3).EQ.'E') THEN - IF(TAG(I2)(13:13).GT.'3') THEN - IF(EWRITE) PRINT 9047, I2,ACID(I2),ALAT(I2),ALON(I2), - $ TIME(I2),TAG(I2) - TAG(I2)(2:2) = 'F' - TAG(I2)(13:13) = '3' - ITEVNT(I2) = 324 - END IF - IF(TAG(I2)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 8047, I2,ACID(I2),ALAT(I2),ALON(I2), - $ TIME(I2),TAG(I2) - TAG(I2)(4:4) = 'F' - TAG(I2)(14:14) = '3' - IWEVNT(I2) = 324 - END IF - RETURN - END IF - IF(ABS(SHGT(K1)-SHGT(K2)).LE.700..AND.ABS(STIM(K1)-STIM(K2)).LE. - $ 300.) THEN - LK = NUM + 1 - SUMU = (U(K1) + U(K2)) * 0.5 - SUMV = (V(K1) + V(K2)) * 0.5 - SUMS = (SSPD(K1) + SSPD(K2)) * 0.5 - DDD = AVEDIR(SUMU,SUMV,SUMS) - SUMA = (SHGT(K1) + SHGT(K2)) * 0.5 - SUMSF = XMSG - DDDF = XMSG - IF(AMAX1(UF(K1),UF(K2),VF(K1),VF(K2),SSPDF(K1),SSPDF(K2)) - $ .LT.XMSG) THEN - SUMUF = (UF(K1) + UF(K2)) * 0.5 - SUMVF = (VF(K1) + VF(K2)) * 0.5 - SUMSF = (SSPDF(K1) + SSPDF(K2)) * 0.5 - DDDF = AVEDIR(SUMUF,SUMVF,SUMSF) - END IF - SUMAF = XMSG - IF(AMAX1(SHGTF(K1),SHGTF(K2)).LT.XMSG) SUMAF = (SHGTF(K1) + - $ SHGTF(K2)) * 0.5 - SUMTMP = XMSG - SUMTMF = XMSG - IF(STMP(K1).LT.XMSG.AND.STMP(K2).LT.XMSG.AND. - $ TAG(I1)(2:2).NE.'F'.AND.TAG(I2)(2:2).NE.'F') THEN - SUMTMP = (STMP(K1) + STMP(K2)) * 0.5 - IF(STMPF(K1).LT.XMSG.AND.STMPF(K2).LT.XMSG) THEN - SUMTMF = (STMPF(K1) + STMPF(K2)) * 0.5 - ELSE IF(STMPF(K1).LT.XMSG) THEN - SUMTMF = STMPF(K1) - ELSE IF(STMPF(K2).LT.XMSG) THEN - SUMTMF = STMPF(K2) - END IF - ELSE IF(STMP(K1).LT.XMSG.AND.TAG(I1)(2:2).NE.'F') THEN - SUMTMP = STMP(K1) - IF(STMPF(K1).LT.XMSG) SUMTMF = STMPF(K1) - ELSE IF(STMP(K2).LT.XMSG.AND.TAG(I2)(2:2).NE.'F') THEN - SUMTMP = STMP(K2) - IF(STMPF(K2).LT.XMSG) SUMTMF = STMPF(K2) - END IF - SUMT = (STIM(K1) + STIM(K2)) * 0.5 - IF(TAG(I1)(13:13).GT.'4') THEN - IF(EWRITE) PRINT 9048, I1,ACID(I1),ALAT(I1),ALON(I1), - $ TIME(I1),TAG(I1) - 9048 FORMAT(/' #EVENT 315: NOEQ2; USED TO MAKE SUPROB, TEMP Q.M. "O".', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(I1)(2:2) = 'O' - TAG(I1)(13:13) = '4' - ITEVNT(I1) = 315 - END IF - IF(TAG(I1)(14:14).GT.'4') THEN - IF(EWRITE) PRINT 8048, I1,ACID(I1),ALAT(I1),ALON(I1), - $ TIME(I1),TAG(I1) - 8048 FORMAT(/' #EVENT 315: NOEQ2; USED TO MAKE SUPROB, WIND Q.M. "O".', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(I1)(4:4) = 'O' - TAG(I1)(14:14) = '4' - IWEVNT(I1) = 315 - END IF - IF(TAG(I2)(13:13).GT.'4') THEN - IF(EWRITE) PRINT 9048, I2,ACID(I2),ALAT(I2),ALON(I2), - $ TIME(I2),TAG(I2) - TAG(I2)(2:2) = 'O' - TAG(I2)(13:13) = '4' - ITEVNT(I2) = 315 - END IF - IF(TAG(I2)(14:14).GT.'4') THEN - IF(EWRITE) PRINT 8048, I2,ACID(I2),ALAT(I2),ALON(I2), - $ TIME(I2),TAG(I2) - TAG(I2)(4:4) = 'O' - TAG(I2)(14:14) = '4' - IWEVNT(I2) = 315 - END IF - SDIR(LK) = DDD - STIM(LK) = SUMT - SHGT(LK) = SUMA - STMP(LK) = SUMTMP - SLAT(LK) = ALAT(INDX) - SLON(LK) = ALON(INDX) - KBAD(LK) = LK - SSPD(LK) = SUMS - SDIRF(LK) = DDDF - SHGTF(LK) = SUMAF - STMPF(LK) = SUMTMF - SSPDF(LK) = SUMSF - CTEMP = STMP(LK) - IF(STMP(LK).LT.XMSG) CTEMP = STMP(LK)/10. - CTMPF = STMPF(LK) - IF(STMPF(LK).LT.XMSG) CTMPF = STMPF(LK)/10. - PRINT 8666, INDX,NUM,NINT(SDIR(LK)),SSPD(LK),NINT(SHGT(LK)), - $ CTEMP+SIGN(.0005,CTEMP),K1,K2,I1,I2,NINT(SDIRF(LK)),SSPDF(LK), - $ CTMPF+SIGN(.0005,CTMPF),NINT(SHGTF(LK)) - 8666 FORMAT(' NOEQ2',I5,',NM=',I2,',DIR/SPD=',I3,'/',F5.1,',AL=',I5, - $ ',T=',F7.1,',K1-2;I1-2=',2I3,2I5,',GES: DIR/SPD=',I5,'/',F7.1, - $ ',T=',F7.1,',AL=',I5) - END IF - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: STATS CALCS. STATS W/ AND W/O EACH OBS. IN TURN -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1994-08-25 -C -C ABSTRACT: CALCULATES MEANS AND VARIANCES WITH AND WITHOUT EACH -C OBSERVATION IN TURN. IF THERE ARE MORE THAN 'KNO' OBSERVATIONS -C NORMALIZED STANDARD DEVIATIONS ARE CALCULATED. OTHERWISE UN- -C NORMALIZED STANDARD DEVIATIONS ARE CALCULATED. -C -C PROGRAM HISTORY LOG: -C 1989-04-01 P. JULIAN -- ORIGINAL AUTHOR -C 1994-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND -C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT -C -C USAGE: CALL STATS(KNO,INDX,NUM,SBAR,VPOINT) -C INPUT ARGUMENT LIST: -C KNO - NO. OF OBS. SEPARATING TREATMENT & STATS CALCULATED -C INDX - POINTER TO POSITION IN ORIGINAL AIRCRAFT ARRAY -C NUM - NUMBER OF OBSERVATIONS IN STACK -C -C OUTPUT ARGUMENT LIST: -C VPOINT - ARRAY CONTAINING VECTOR DIFFERENCE TO AVERAGE VECTOR -C - FOR ALL OBS. IN STACK (IN ORDER OF OBS. IN STACK) -C SBAR - AVERAGE SPEED IN STACK -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C REMARKS: CALLED BY SUBROUTINE 'SHEAR'. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE STATS(KNO,INDX,NUM,SBAR,VPOINT) - PARAMETER (IRMX= 80000, ISMX= 8000) - DIMENSION SQQ(ISMX),DU(ISMX),DV(ISMX),VECT(ISMX),ALTNRM(ISMX), - $ UN(ISMX),VN(ISMX),UECT(ISMX),TIMNRM(ISMX),SSDN(ISMX),VPOINT(ISMX) - LOGICAL SWRITE - CHARACTER*8 ACID,SAID - CHARACTER*14 TAG - COMMON/SUMDAT/ISTCPT(ISMX),SAID(ISMX),SLAT(ISMX),SLON(ISMX), - $ SHGT(ISMX),STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX), - $ KBAD(ISMX),NUMORG,SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX) - COMMON/ALLDAT/IFLEPT(IRMX),ACID(IRMX),ALAT(IRMX),ALON(IRMX), - $ AALT(IRMX),TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE, - $ ATMP(IRMX),TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX), - $ ITEVNT(IRMX),IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX), - $ ADIRF(IRMX) - COMMON/CMPNTS/U(ISMX),V(ISMX),UF(ISMX),VF(ISMX) - COMMON/STUFF/SDALT,TBAR - COMMON/STWRIT/SWRITE,EWRITE,IWRITE - DATA XMSG/99999./ -C THE FOLLOWING IS CALIBRATION CONSTANT - EMPIRICALLY TUNED FOR -C SELECTING SIGNIFICANT VECTOR RMS DIFFERENCE - DATA CALIBX/1.40/ - CRITCN = 5.35 - IBAD = 0 - SUMT = 0.0 - SUMA = 0.0 - SUMTMP = 0.0 - SSSTMP = 0.0 - SUMS = 0.0 - SSST = 0.0 - SSSA = 0.0 - SSSS = 0.0 - SDU = 0.0 - SQV = 0.0 - SQU = 0.0 - SUMU = 0.0 - SUMV = 0.0 - SSSU = 0.0 - SSSV = 0.0 - KNUM = 0 - JNUM = 0 - KNUMT = 0 - UN = XMSG - DU = XMSG - VN = XMSG - DV = XMSG - SSDN = XMSG - UECT = -999. - VECT = -999. - ALTNRM = XMSG - TIMNRM = XMSG - DO K = 1,NUM - KNDX = INDX + K - 1 -C INITIALIZE VPOINT AS THE ORIGINAL STACK ORDER - VPOINT(K) = REAL(K) - IF(IFLEPT(KNDX).LE.0.OR.ISTCPT(K).LE.0) GO TO 101 - KNUM = KNUM + 1 - IF(ATMP(KNDX).LT.XMSG) THEN - KNUMT = KNUMT + 1 - SUMTMP = SUMTMP + ATMP(KNDX) - SSSTMP = SSSTMP + (ATMP(KNDX) * ATMP(KNDX)) - END IF - SUMU = SUMU + U(K) - SUMV = SUMV + V(K) - SUMS = SUMS + ASPD(KNDX) - SUMT = SUMT + TIME(KNDX) - QQ = AALT(KNDX) - 8000. - SUMA = SUMA + QQ - SSSU = SSSU + (U(K) * U(K)) - SSSV = SSSV + (V(K) * V(K)) - SSSS = SSSS + (ASPD(KNDX) * ASPD(KNDX)) - SSST = SSST + (TIME(KNDX) * TIME(KNDX)) - SSSA = SSSA + (QQ * QQ) - SMQU = 0.0 - SMQV = 0.0 - SSQU = 0.0 - SSQV = 0.0 -C NOTE: JNUM COMES OUT OF 1 LOOP WITH SAME VALUE EVERY TIME ( = FINAL -C VALUE OF KNUM COMING OUT OF 101 LOOP MINUS 1; THUS IT COMES OUT -C OF 101 LOOP WITH THE VALUE KNUM - 1) - JNUM = 0 - DO J = 1,NUM - JNDX = INDX + J - 1 - IF(J.EQ.K.OR.(ISTCPT(J).LE.0.AND.IFLEPT(JNDX).LE.0)) GO TO 1 - JNUM = JNUM + 1 - SMQU = SMQU + U(J) - SMQV = SMQV + V(J) - SSQU = SSQU + (U(J) * U(J)) - SSQV = SSQV + (V(J) * V(J)) - 1 CONTINUE - ENDDO -C IF JNUM .GT. KNO CALCULATE NORMALIZED QUANTITIES - IF(JNUM.GT.KNO) THEN - RFNO = 1./JNUM - UQAR = SMQU * RFNO - VQAR = SMQV * RFNO - RNDF = 1.0 - IF(JNUM.GE.2) RNDF = 1./(JNUM - 1) - QQQ = (SSQU - (UQAR * UQAR * JNUM)) * RNDF - IF(QQQ.LE.0.0) QQQ = .0001 - SQU = SQRT(QQQ) - QQQ = (SSQV - (VQAR * VQAR * JNUM)) * RNDF - IF(QQQ.LE.0.0) QQQ = .0001 - SQV = SQRT(QQQ) - UN(K) = (U(K) - UQAR)/SQU - VN(K) = (V(K) - VQAR)/SQV - UECT(K) = SQRT((UN(K) * UN(K)) + (VN(K) * VN(K))) - ELSE IF(JNUM.NE.0) THEN - RFNO = 1./JNUM - UQAR = SMQU * RFNO - VQAR = SMQV * RFNO - DU(K) = U(K) - UQAR - DV(K) = V(K) - VQAR - VECT(K) = SQRT((DU(K) * DU(K)) + (DV(K) * DV(K))) - END IF - 101 CONTINUE - ENDDO - RNUM = 1. - IF(KNUM.GT.0) RNUM = 1./KNUM - SBAR = SUMS * RNUM -C IF 2 OR FEWER GOOD HIGH-ALT. OBS. IN STACK, NO MORE NEED BE DONE - IF(KNUM.LE.2) RETURN - TMPBAR = XMSG - RNUMTM = 1. - IF(KNUMT.GT.0) THEN - RNUMTM = 1./KNUMT - TMPBAR = SUMTMP * RNUMTM - END IF - IF(KNUMT.GT.1) RNUMTM = 1./(KNUMT - 1) - UBAR = SUMU * RNUM - VBAR = SUMV * RNUM - TBAR = SUMT * RNUM - ABAR = SUMA * RNUM - IF(KNUM.GT.1) RNUM = 1./(KNUM - 1) - QQQ = (SSSU - (UBAR * UBAR * KNUM)) * RNUM - IF(QQQ.LE.0.0) QQQ = .0001 - SDU = SQRT(QQQ) - QQQ = (SSSV - (VBAR * VBAR * KNUM)) * RNUM - IF(QQQ.LE.0.0) QQQ = .0001 - SDV = SQRT(QQQ) - SDT = SQRT((SSST - (TBAR * TBAR * KNUM)) * RNUM) - QQQ = (SSSA - (ABAR * ABAR * KNUM)) * RNUM - IF(QQQ.LE.0.0) QQQ = .0001 - SDALT = SQRT(QQQ) - ABAR = ABAR + 8000. - QQQ = (SSSS - (SBAR * SBAR * KNUM)) * RNUM - IF(QQQ.LE.0.0) QQQ = .0001 - SDS = SQRT(QQQ) - SDTMP = XMSG - QQQ = 0.0 - IF(KNUMT.GT.1) QQQ = (SSSTMP - (TMPBAR * TMPBAR * KNUMT)) * RNUMTM - IF(QQQ.LE.0.0) QQQ = .0001 - SDTMP = SQRT(QQQ) - KNUM = 0 - DO K = 1,NUM - KNDX = INDX + K - 1 - IF(IFLEPT(KNDX).LE.0) GO TO 102 - SQ = 0.0 - SSQ = 0.0 -C NOTE: KNUM COMES OUT OF 1030 LOOP WITH SAME VALUE EVERY TIME -C ( = NUMBER OF TIMES 1030 LOOP IS EXECUTED MINUS 1) - KNUM = 0 - DO J = 1,NUM - IF(J.EQ.K.OR.ISTCPT(J).LE.0) GO TO 1030 - KNUM = KNUM + 1 - IF(JNUM.GT.KNO) THEN - SQ = SQ + UECT(J) - SSQ = SSQ + (UECT(J) * UECT(J)) - ELSE - SQ = SQ + VECT(J) - SSQ = SSQ + (VECT(J) * VECT(J)) - END IF - 1030 CONTINUE - ENDDO - IF(KNUM.NE.0) THEN - SQ = SQ/KNUM - QNDF = 0.0 - IF(KNUM.GT.1) QNDF = 1./(KNUM - 1) - QARG = (SSQ - (SQ * SQ * KNUM)) * QNDF - IF(QARG.LE.0.0) QARG = .00001 - SSDN(K) = SQRT(QARG) - IF(JNUM.GT.KNO) SSDN(K) = SSDN(K) * CRITCN - END IF - 102 CONTINUE - ENDDO - IF(KNUM.GT.KNO) THEN -C*********************************************************************** -C MORE THAN KNO OBSERVATIONS -C*********************************************************************** - SQQ = XMSG - VPOINT(1:NUM) = UECT(1:NUM) - DO I = 1,NUM - JNDX = INDX + I - 1 - IF(ISTCPT(I).LE.0) GO TO 117 - ALTNRM(I) = 0. -CVVVVV%%%%% - IF(SDALT.EQ.0.) PRINT *, '~~~~~ SDALT=0 IN STATS' -CAAAAA%%%%% - IF(SDALT.NE.0.) ALTNRM(I) = ABS((AALT(JNDX)-ABAR)/SDALT) - TIMNRM(I) = 0. -CVVVVV%%%%% - IF(SDT.EQ.0.) PRINT *, '~~~~~ SDT=0 IN STATS' -CAAAAA%%%%% - IF(SDT.NE.0.) TIMNRM(I) = ABS((TIME(JNDX)-TBAR)/SDT) - QNORM = SQRT(ALTNRM(I) * ALTNRM(I) + TIMNRM(I) * TIMNRM(I)) - SQQ(I) = 2.50 + (QNORM * CALIBX) - IF(UECT(I).GT.SQQ(I).AND.ISTCPT(I).GT.0) IBAD = IBAD + 1 - 117 CONTINUE - ENDDO - PRINT 6006, UBAR,SDU,VBAR,SDV,KNUM,JNUM - CTEMP = TMPBAR - CTSD = SDTMP - IF(TMPBAR.LT.XMSG) CTEMP = TMPBAR/10. - IF(SDTMP.LT.XMSG) CTSD = SDTMP/10. - PRINT 6106, TBAR+SIGN(.0005,TBAR),SDT,ABAR,SDALT,SBAR, - $ SDS+SIGN(.0005,SDS),CTEMP+SIGN(.0005,CTEMP), - $ CTSD+SIGN(.0005,CTSD) -CCCCC IF(IBAD.GT.0) PRINT 1627, (L,UECT(L),SQQ(L),KBAD(L), -CCCCC$ ISTCPT(L),ALTNRM(L),TIMNRM(L),L=1,NUM) -C1627 FORMAT(' L=',I4,', UECT=',F9.3,', SQQ=',F9.3,', KBAD=',I6, -CCCCC$', ISTCPT=',I6,', ALTNRM=',F9.2,', TIMNRM=',F9.2) - ELSE -C*********************************************************************** -C LESS THAN KNO OBSERVATIONS -C*********************************************************************** - VPOINT(1:NUM) = VECT(1:NUM) - PRINT 6006, UBAR,SDU,VBAR,SDV,KNUM,JNUM - 6006 FORMAT(' UBAR,SDU,VBAR,SDV ',2(F8.1,F8.1),'; KNUM,JNUM ',2I4) - CTEMP = TMPBAR - CTSD = SDTMP - IF(TMPBAR.LT.XMSG) CTEMP = TMPBAR/10. - IF(SDTMP.LT.XMSG) CTSD = SDTMP/10. - PRINT 6106, TBAR+SIGN(.0005,TBAR),SDT,ABAR,SDALT,SBAR, - $ SDS+SIGN(.0005,SDS),CTEMP+SIGN(.0005,CTEMP), - $ CTSD+SIGN(.0005,CTSD) - 6106 FORMAT(' TBAR,SDT ',2F7.0,'; ABAR,SDALT ',2F8.0,'; SBAR,SDS ', - $ 2F7.0,'; TMPBAR,SDTMP ',2F7.1) - END IF -C*********************************************************************** -C PRINT SECTION -C*********************************************************************** - IF(SWRITE) THEN - IF(JNUM.GT.KNO) THEN - PRINT 6332 - 6332 FORMAT(6X,'DIR SPD U V DELU DELV D VECT ', - $ 'SQQ NALT NTIM ALT TEMP TIME KBAD ISTCPT TAGS') - DO I = 1,NUM - JNDX = INDX + I - 1 - CTEMP = ATMP(JNDX) - IF(ATMP(JNDX).LT.XMSG) CTEMP = ATMP(JNDX)/10. - PRINT 6003, I,ADIR(JNDX),ASPD(JNDX),U(I),V(I),UN(I),VN(I),UECT(I), - $ SQQ(I),ALTNRM(I),TIMNRM(I),AALT(JNDX),CTEMP+SIGN(.0005,CTEMP), - $ TIME(JNDX),KBAD(I),ISTCPT(I),TAG(JNDX) - 6003 FORMAT(' ',I3,F6.0,F6.1,1X,2F7.1,2F8.2,4F8.2,F8.0,F7.1,F7.0,I4,I5, - $ 6X,'"',A14,'"') - ENDDO - ELSE - PRINT 6472 - 6472 FORMAT(7X,'DIR SPD U V DELU DELV D VECT ', - $ 'SSDN ALT TEMP TIME KBAD ISTCPT TAGS') - DO I = 1,NUM - JNDX = INDX + I - 1 - CTEMP = ATMP(JNDX) - IF(ATMP(JNDX).LT.XMSG) CTEMP = ATMP(JNDX)/10.0 -C FOR COMPARISON DAK VS. PRJ SWITCH COMMENTS - PRINT 6002, I,ADIR(JNDX),ASPD(JNDX),U(I),V(I),DU(I),DV(I),VECT(I), - $ SSDN(I),AALT(JNDX),CTEMP+SIGN(.0005,CTEMP),TIME(JNDX),KBAD(I), - $ ISTCPT(I),TAG(JNDX) - 6002 FORMAT(' ',I3,F6.0,F6.1,1X,2F7.1,4F8.2,F9.0,F9.1,F7.0,2I5,6X,'"', - $ A14,'"') - ENDDO - END IF - END IF - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: AVEDIR CALC. AVG. WIND DIR. FROM AVG. U-/V-COMPS -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1994-08-25 -C -C ABSTRACT: FUNCTION -- CALCULATES THE AVERAGE METEROLOGICAL WIND -C DIRECTION FROM THE AVERAGE OF A NUMBER OF ZONAL AND MERIDIONAL -C WIND COMPONENTS. -C -C PROGRAM HISTORY LOG: -C 1994-01-01 P. JULIAN (W/NMC00) -- ORIGINAL AUTHOR -C 1994-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND -C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT -C -C USAGE: XX = AVEDIR(SUMU,SUMV,SUMS) -C INPUT ARGUMENT LIST: -C SUMU - THE AVERAGE OF THE ZONAL WIND COMPONENTS -C SUMV - THE AVERAGE OF THE MERIDIONAL WIND COMPONENTS -C SUMS - THE AVERAGE OF THE WIND SPEEDS -C -C REMARKS: REAL VARIABLE 'AVEDIR' RETURNED IS THE AVERAGE WIND -C DIRECTION. CALLED BY SUBROUTINES 'AVEROB', 'SUPROB' AND 'NOEQ2'. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - REAL FUNCTION AVEDIR(SUMU,SUMV,SUMS) - IF(SUMV.EQ.0.0) SUMV = .001 - AVEDIR = (ATAN2( -SUMV, SUMU) * (180./3.14159)) + 270. - IF(AVEDIR.GT.360.) AVEDIR = AVEDIR - 360. - IF(SUMS.LT.0.5.OR.AVEDIR.LT.0.4) AVEDIR = 360. - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: INDEXC GENERAL SORT ROUTINE FOR CHARACTER ARRAY -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1999-08-23 -C -C ABSTRACT: USES EFFICIENT SORT ALGORITHM TO PRODUCE INDEX SORT LIST -C FOR A 32-CHARACTER ARRAY. DOES NOT REARRANGE THE FILE. -C -C PROGRAM HISTORY LOG: -C 1993-06-05 R KISTLER --- FORTRAN VERSION OF C-PROGRAM -C 1993-07-15 P. JULIAN ---- MODIFIED TO SORT 12-CHARACTER ARRAY -C 1994-08-25 D. A. KEYSER - MODIFIED TO SORT 16-CHARACTER ARRAY -C 1995-05-30 D. A. KEYSER - TESTS FOR < 2 ELEMENTS IN SORT LIST, -C IF SO RETURNS WITHOUT SORTING (BUT FILLS INDX ARRAY) -C 1999-08-23 D. A. KEYSER - EXPANDED CHARACTER ARRAY FROM 16 TO 32 -C BYTES (ALLOWS HIGHER ORDERS TO BE INCLUDED IN SORT) -C -C USAGE: CALL INDEXC(N,CARRIN,INDX) -C INPUT ARGUMENT LIST: -C N - SIZE OF ARRAY TO BE SORTED -C CARRIN - 32-CHARACTER ARRAY TO BE SORTED -C -C OUTPUT ARGUMENT LIST: -C INDX - ARRAY OF POINTERS GIVING SORT ORDER OF CARRIN IN -C - ASCENDING ORDER {E.G., CARRIN(INDX(I)) IS SORTED IN -C - ASCENDING ORDER FOR ORIGINAL I = 1, ... ,N} -C -C REMARKS: CALLED BY SUBROUTINES 'TRKCHK' AND 'IDSORT'. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE INDEXC(N,CARRIN,INDX) - CHARACTER*32 CARRIN(N),CC - INTEGER INDX(N) - DO J = 1,N - INDX(J) = J - ENDDO -C MUST BE > 1 ELEMENT IN SORT LIST, ELSE RETURN - IF(N.LE.1) RETURN - L = N/2 + 1 - IR = N - 33 CONTINUE - IF(L.GT.1) THEN - L = L - 1 - INDXT = INDX(L) - CC = CARRIN(INDXT) - ELSE - INDXT = INDX(IR) - CC = CARRIN(INDXT) - INDX(IR) = INDX(1) - IR = IR - 1 - IF(IR.EQ.1) THEN - INDX(1) = INDXT - RETURN - END IF - END IF - I = L - J = L * 2 - 30 CONTINUE - IF(J.LE.IR) THEN - IF(J.LT.IR) THEN - IF(CARRIN(INDX(J)).LT.CARRIN(INDX(J+1))) J = J + 1 - END IF - IF(CC.LT.CARRIN(INDX(J))) THEN - INDX(I) = INDX(J) - I = J - J = J + I - ELSE - J = IR + 1 - ENDIF - END IF - IF(J.LE.IR) GO TO 30 - INDX(I) = INDXT - GO TO 33 - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: INDEXF GENERAL SORT ROUTINE FOR INTEGER ARRAY -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1995-05-30 -C -C ABSTRACT: USES EFFICIENT SORT ALGORITHM TO PRODUCE INDEX SORT LIST -C FOR AN INTEGER ARRAY. DOES NOT REARRANGE THE FILE. -C -C PROGRAM HISTORY LOG: -C 1993-06-05 R KISTLER -- FORTRAN VERSION OF C-PROGRAM -C 1995-05-30 D. A. KEYSER - TESTS FOR < 2 ELEMENTS IN SORT LIST, -C IF SO RETURNS WITHOUT SORTING (BUT FILLS INDX ARRAY) -C -C USAGE: CALL INDEXF(N,IARRIN,INDX) -C INPUT ARGUMENT LIST: -C N - SIZE OF ARRAY TO BE SORTED -C IARRIN - INTEGER ARRAY TO BE SORTED -C -C OUTPUT ARGUMENT LIST: -C INDX - ARRAY OF POINTERS GIVING SORT ORDER OF IARRIN IN -C - ASCENDING ORDER {E.G., IARRIN(INDX(I)) IS SORTED IN -C - ASCENDING ORDER FOR ORIGINAL I = 1, ... ,N} -C -C REMARKS: CALLED BY SUBROUTINES 'TRKCHK', 'SHEAR', 'LAPSE', 'SUPROB', -C 'STATS' AND 'OBUFR'. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE INDEXF(N,IARRIN,INDX) - INTEGER INDX(N),IARRIN(N) - DO J = 1,N - INDX(J) = J - ENDDO -C MUST BE > 1 ELEMENT IN SORT LIST, ELSE RETURN - IF(N.LE.1) RETURN - L = N/2 + 1 - IR = N - 33 CONTINUE - IF(L.GT.1) THEN - L = L - 1 - INDXT = INDX(L) - II = IARRIN(INDXT) - ELSE - INDXT = INDX(IR) - II = IARRIN(INDXT) - INDX(IR) = INDX(1) - IR = IR - 1 - IF(IR.EQ.1) THEN - INDX(1) = INDXT - RETURN - END IF - END IF - I = L - J = L * 2 - 30 CONTINUE - IF(J.LE.IR) THEN - IF(J.LT.IR) THEN - IF(IARRIN(INDX(J)).LT.IARRIN(INDX(J+1))) J = J + 1 - END IF - IF(II.LT.IARRIN(INDX(J))) THEN - INDX(I) = INDX(J) - I = J - J = J + I - ELSE - J = IR + 1 - END IF - END IF - IF(J.LE.IR) GO TO 30 - INDX(I) = INDXT - GO TO 33 - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: DBUFR GETS THE DATE FROM A PREPBUFR FILE -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1994-08-25 -C -C ABSTRACT: READS THRU SUCCESSIVE BUFR MESSAGES UNTIL THE BUFR TABLE -C A ENTRY "AIRCFT" (CONVENTIONAL AIREP/PIREP AND ASDAR/AMDAR/TAMDAR -C AIRCRAFT REPORTS) IS FOUND IN A PREPBUFR FILE. RETURNS THE DATE -C OF THIS MESSAGE TO THE CALLING PROGRAM. -C -C PROGRAM HISTORY LOG: -C 1994-08-25 D. A. KEYSER -- ORIGINAL AUTHOR -C -C USAGE: CALL DBUFR(IDATEP) -C OUTPUT ARGUMENT LIST: -C IDATEP - DATE FROM FIRST TABLE A "AIRCFT" MESSAGE (YYMMDDHH) -C -C INPUT FILES: -C UNIT 14 - PREPBUFR FILE CONTAINING ALL DATA -C -C OUTPUT FILES: -C UNIT06 - PRINTOUT -C -C REMARKS: CALLED BY MAIN PROGRAM. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE DBUFR(IDATEP) - CHARACTER*8 SUBSET - COMMON/TSTACAR/KTACAR - CALL DATELEN(10) - CALL OPENBF(14,'IN',14) - 10 CONTINUE - CALL READMG(14,SUBSET,IDATEP,IRET) - IF(IRET.NE.0) GO TO 999 - IF(SUBSET.EQ.'AIRCAR ') KTACAR = KTACAR + 1 - IF(SUBSET.NE.'AIRCFT ') GO TO 10 -cppppp - print * ,' ' - print *, 'First AIRCFT message found ... ' - print *,'PREPBUFR File Sec. 1 message date (IDATEP) = ',IDATEP -cppppp - IF(IDATEP.LT.1000000000) THEN - -C If 2-digit year returned in IDATEP, must use "windowing" technique -C to create a 4-digit year - -C IMPORTANT: IF DATELEN(10) IS CALLED, THE DATE HERE SHOULD ALWAYS -C CONTAIN A 4-DIGIT YEAR, EVEN IF INPUT FILE IS NOT -C Y2K COMPLIANT (BUFRLIB DOES THE WINDOWING HERE) - - PRINT *, '##PREPACQC - THE FOLLOWING SHOULD NEVER HAPPEN!!!!!' - PRINT *, '##PREPACQC - 2-DIGIT YEAR IN IDATEP RETURNED FROM ', - $ 'READMG (IDATEP IS: ',IDATEP,') - USE WINDOWING TECHNIQUE ', - $ 'TO OBTAIN 4-DIGIT YEAR' - IF(IDATEP/1000000.GT.20) THEN - IDATEP = 1900000000 + IDATEP - ELSE - IDATEP = 2000000000 + IDATEP - ENDIF - PRINT *, '##PREPACQC - CORRECTED IDATEP WITH 4-DIGIT YEAR, ', - $ 'IDATEP NOW IS: ',IDATEP - ENDIF - RETURN - 999 CONTINUE -C PREPBUFR DATA SET CONTAINS NO "AIRCFT" TABLE A MSGS -- STOP 4 !!! - PRINT 14 - 14 FORMAT(/' PREPBUFR DATA SET CONTAINS NO "AIRCFT" TABLE A ', - $ 'MESSAGES - STOP 4'/) - CALL CLOSBF(14) - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(4) - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: IBUFR DECODES ACFT OBS. FROM PREPBUFR FILE -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2008-07-30 -C -C ABSTRACT: DECODES A CONVENTIONAL AIREP/PIREP OR ASDAR/AMDAR/TAMDAR -C AIRCRAFT OBSERVATION FROM A TABLE A ENTRY "AIRCFT" MESSAGE IN A -C PREPBUFR FILE FOR EACH CALL. IF ALL SUBSETS HAVE BEEN DECODED IN -C A MESSAGE THE NEXT TABLE A ENTRY "AIRCFT" MESSAGE IN READ IN AND -C DECODED. A RETURN 1 OCCURS WHEN ALL TABLE A ENTRY "AIRCFT" MESSAGES -C HAVE BEEN PROCESSED. SPECIAL LOGIC COMBINES THE SEPARATE WIND AND -C MASS REPORT "PIECES" INTO A SINGLE OBSERVATION PRIOR TO RETURN TO -C CALLING PROGRAM. -C -C PROGRAM HISTORY LOG: -C 1994-08-25 D. A. KEYSER -- ORIGINAL AUTHOR -C 1995-03-27 D. A. KEYSER -- STORES FORECAST (GUESS) P-ALTITUDE, WIND -C DIRECTION, WIND SPEED AND TEMPERATURE FOR EACH DECODED -C REPORT (DIRECTION/SPEED OBTAINED FROM FORECAST U/V) -C (I/O ARGUMENTS ADDED TO TRANSFER VALUES TO CALLING PGM) -C 1995-07-06 D. A. KEYSER -- FOR ASDAR/AMDAR: CHECKS "TSB" MNENOMIC -C FOR VALUE OF "2", IF SO MEANS REPORT HAS A MISSING -C PHASE OF FLIGHT INDICATOR AND STORES A "7" IN THE -C CHARACTER*1 VARIABLE LATER CHECKED BY MAIN PROGRAM -C 1996-10-18 D. A. KEYSER -- NOW CLOSES INPUT BUFR DATA SET AFTER ALL -C REPORTS HAVE BEEN READ IN BY SUBR. IBUFR, UPDATED BUFRLIB -C CAUSES PGM TO ABORT WITH CALL TO OPENBF IN SUBR. OBUFR -C W/O THIS FIX -C 2002-11-20 D. A. KEYSER -- EXPANDED CHARACTER QMARKI FROM 4 TO 5 -C BYTES, WHERE BYTE 5 HOLDS "P" OR "H" FOR TEMP SDM PURGE -C OR KEEP FLAG - BYTE 1 HOLDS "P" OR "H" EXCLUSIVELY FOR -C WIND SDM PURGE OR KEEP FLAGS, USED TO BE COMBINED FOR -C WIND AND TEMP, BUT REMOVED ASSUMPTION THAT AN SDM PURGE -C ON TEMP ONLY ALSO RESULTS IN AN SDM PURGE ON WIND, THERE -C IS ALSO NO LONGER ANY RELATIONSHIP BETWEEN AN SDM KEEP ON -C WIND VS. A KEEP ON TEMP - THEY ARE INDENDENDENT OF EACH -C OTHER -C 2008-07-30 D. A. KEYSER -- RECEIPT TIME TEST IS NO LONGER DONE FOR -C TAMDAR REPORTS (REGARDLESS OF SWITCH "RCPTST" BECAUSE -C TAMDAR REPORTS CAN BE RESENT MANY TIMES OVER AND THE -C RECEIPT TIME FOR VERY LATE (E.G., T-12 NDAS) RUNS MAY -C INCORRECTLY DISPLAY WHAT LOOKS LIKE A "STRANGE" RECEIPT -C TIME); IN RESPONSE TO CHANGE FROM SINGLE LEVEL TO -C DELAYED REPLICATION FOR "AIRCFT" REPORT LEVEL DATA NOW IN -C PREPBUFR FILE (IN PREPARATION FOR NRL AIRCRAFT QC PROGRAM -C WHICH WILL REPLACE THIS PROGRAM AND CAN GENERATE AIRCRAFT -C "PROFILES"), RECEIPT TIME (RCT) (WHICH IS NOW PART OF -C LEVEL DATA) IS NO LONGER RETRIEVED IN SAME CALL TO UFBINT -C AS REMAINING SINGLE-LEVEL HEADER DATA (TO AVOID BUFRLIB -C ERROR) (ALL LEVEL DATA HERE STILL HAS JUST ONE -C REPLICATION AT THIS POINT) -C -C USAGE: CALL IBUFR(ALTF,DIRF,SPDF,TMPF,*) -C INPUT ARGUMENT LIST: -C ALTF - INITIAL FORECAST VALUE FOR PRESSURE ALTITUDE, MISSING -C DIRF - INITIAL FORECAST VALUE FOR WIND DIRECTION, MISSING -C SPDF - INITIAL FORECAST VALUE FOR WIND SPEED, MISSING -C TMPF - INITIAL FORECAST VALUE FOR TEMPERATURE, MISSING -C -C OUTPUT ARGUMENT LIST: -C ALTF - FORECAST VALUE FOR PRESSURE ALTITUDE (METERS) -C DIRF - FORECAST VALUE FOR WIND DIRECTION (DEGREES) -C SPDF - FORECAST VALUE FOR WIND SPEED (KNOTS) -C TMPF - FORECAST VALUE FOR TEMPERATURE (DEG. C X 10) -C -C INPUT FILES: -C UNIT 14 - PREPBUFR FILE CONTAINING ALL DATA -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C REMARKS: CALLED BY MAIN PROGRAM. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE IBUFR(ALTF,DIRF,SPDF,TMPF,*) - SAVE - CHARACTER*1 CIQMMK(10),CF,PF - CHARACTER*5 QMARKI - CHARACTER*8 SUBSET,IDENT - CHARACTER*40 HEADR,OBLVL,FCLVL - REAL(8) HDR6,OBS(8),HDR(9),FST_8(4),RCT - REAL ACAT(9),FST(4) - COMMON/CBUFR/IDENT,IRCTME,RDATA(1608),KIX,QMARKI,CF,PF - COMMON/STDATE/IDATE(5) - EQUIVALENCE (IDENT,HDR6),(IRPTYP,RDATA(8)) - DATA CIQMMK/'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z'/ - DATA ACAT/10.5,20.5,30.5,40.5,50.5,60.5,70.5,80.5,90.5/ - DATA HEADR/'YOB XOB NUL DHR TSB SID ITP TYP SQN '/ - DATA OBLVL/'ZOB TOB DDO FFO TQM WQM UOB VOB '/ - DATA FCLVL/'UFC VFC TFC ZFC '/ - DATA XMSG/99999./,IMSG/99999/,IFLAG/0/,ILOOP/1/,KI/0/,SQNL/0/ -C ON INPUT: IFLAG =0 - 1ST "PIECE" OF NEXT OBS. HAS NOT YET BEEN DECODED -C IFLAG =1 - 1ST "PIECE" OF NEXT OBS. DECODED IN PREVIOUS CALL - IF(IFLAG.EQ.1) GO TO 45 - RDATA = XMSG - 30 CONTINUE - CALL READSB(14,IRET) - IF(IRET.NE.0) THEN - 20 CONTINUE - CALL READMG(14,SUBSET,IDATEP,IRET) - IF(IRET.NE.0) THEN -C NON-ZERO IRET IN READMG MEANS ALL BUFR MESSAGES IN FILE HAVE BEEN READ -C FILE WILL BE CLOSED - PRINT 101 - 101 FORMAT(/5X,'===> PREPBUFR DATA SET IN UNIT 14 SUCCESSFULLY', - $ ' CLOSED FROM INITIAL READ OF AIRCFT OBS.') - CALL CLOSBF(14) - RETURN 1 - END IF - IF(SUBSET.NE.'AIRCFT ') GO TO 20 - GO TO 30 - END IF - CALL UFBINT(14,HDR,9,1,N1LEV,HEADR) - CALL UFBINT(14,OBS,8,1,NLEV ,OBLVL) - CALL UFBINT(14,FST_8,4,1,NLEV2,FCLVL); FST=FST_8 - CALL UFBINT(14,RCT,1,1,N3LEV,'RCT') - IF(N1LEV.NE.NLEV.OR.NLEV2.NE.NLEV.OR.NLEV.NE.1.OR.N3LEV.NE.NLEV) - $ GO TO 999 - KI = NINT(HDR(8))/100 - IF(ILOOP.EQ.2) THEN -C COMPARE RPT SEQ. NUMBERS IN HEADERS OF TWO "PIECES" DECODED IN THIS -C CALL - IF THEY AGREE THEN BOTH ARE PART OF SAME OBS., OTHERWISE THIS -C OBS. CONSISTS OF ONLY ONE "PIECE" AND IT IS RETURNED TO CALLING PGM -C (IFLAG=1 ON RETURN INDICATES NEXT OBS. 1ST "PIECE" HAS BEEN DECODED) - IF(HDR(9).EQ.SQNL) GO TO 40 - ILOOP = 1 - IFLAG = 1 - RETURN - END IF - 45 CONTINUE -C CONSTRUCT OBSERVATION HEADER(ONLY DONE FOR 1ST DECODED REPORT "PIECE") - CF = '-' - PF = '-' - QMARKI = '---C-' -C RDATA(1) = MIN0(IMSG,NINT(HDR(1)*100.)) -C RDATA(2) = MIN0(IMSG,NINT(36000.-(HDR(2)*100.))) -C IRCTME = MIN0(IMSG,NINT(RCT*100.)) -C NDT = MIN0(IMSG,NINT(HDR(4)*100.)) - RDATA(1) = NINT(MIN(99999._8,HDR(1)*100.)) - RDATA(2) = NINT(MIN(99999._8,(36000.-(HDR(2)*100.)))) - IRCTME = NINT(MIN(99999._8,RCT*100.)) - NDT = NINT(MIN(99999._8,HDR(4)*100.)) - RDATA(4) = NDT + (IDATE(4) * 100) - RDATA(4) = MOD(NINT(RDATA(4)),2400) - IF(NINT(RDATA(4)).LT.0) RDATA(4) = NINT(2400. + RDATA(4)) - IF(NINT(HDR(5)).EQ.1) CF = 'C' - IF(NINT(HDR(5)).EQ.2) PF = '7' -C IRPTYP = MIN0(99,NINT(HDR(7))) - IRPTYP = NINT(MIN(99._8,HDR(7))) - HDR6 = HDR(6) - KIX = HDR(8) - 40 CONTINUE - IF(KI.EQ.2) THEN -C CONSTRUCT WIND PART OF OBSERVATION FROM DECODED WIND REPORT "PIECE" -C -C QMARKI(4:4) HOLDS SCALED VECTOR WIND INCREMENT MARKER (IF APPLICABLE) -C OBTAINED FROM THE CALCULATED VECTOR INCREMENT (NOTE: IF REPORT TIME -C IS > 3.33-HOURS FROM CYCLE TIME THE DEFAULT SCALE = 'C' IS STORED) - IF(MAX(FST_8(1),FST_8(2)).LT.XMSG) THEN - IF(MAX(OBS(7),OBS(8)).LT.XMSG.AND.(ABS(RDATA(4)- - $ REAL(IDATE(4)*100.)).LE.333..OR.(RDATA(4)- - $ REAL(IDATE(4)*100.)).GE.2067.)) THEN - VDIF = SQRT((FST_8(1)-OBS(7))**2+(FST_8(2)-OBS(8))**2)*1.9425 - QMARKI(4:4) = 'Z' - DO J = 1,9 - IF(VDIF.LT.ACAT(J)) THEN - QMARKI(4:4) = CIQMMK(J) - GO TO 175 - END IF - ENDDO - 175 CONTINUE - END IF -C CONSTRUCT FCST WIND DIR. (DEG) & SPD (KTS) FROM FCST WIND COMPONENTS - ISUNIT = 1 - CALL CMDDFF(ISUNIT,FST(1),FST(2),DIRF,SPDF) - DIRF = NINT(DIRF) - SPDF = NINT(SPDF) - END IF -C RDATA(43) HOLDS PRESSURE ALTITUDE (METERS) -C RDATA(43) = MIN0(IMSG,NINT(OBS(1))) - RDATA(43) = NINT(MIN(99999._8,OBS(1))) -C ALTF HOLDS FORECAST PRESSURE ALTITUDE (METERS) - IF(FST_8(4).LT.XMSG) ALTF = NINT(FST_8(4)) -C RDATA(46) HOLDS WIND DIRECTION (DEGREES) -C RDATA(46) = MIN0(IMSG,NINT(OBS(3))) - RDATA(46) = NINT(MIN(99999._8,OBS(3))) -C RDATA(46) HOLDS WIND SPEED (KNOTS) -C RDATA(47) = MIN0(IMSG,NINT(OBS(4))) - RDATA(47) = NINT(MIN(99999._8,OBS(4))) -C QMARKI(1:1) HOLDS SDM WIND PURGE FLAG (IF APPLICABLE) -- OR -- -C HOLDS SDM WIND KEEP FLAG (IF APPLICABLE) - IF(NINT(OBS(6)).EQ.14) THEN - QMARKI(1:1) = 'P' - ELSE IF(NINT(OBS(6)).EQ.0) THEN - QMARKI(1:1) = 'H' - END IF - ELSE -C CONSTRUCT MASS PART OF OBSERVATION FROM DECODED MASS REPORT "PIECE" -C -C RDATA(44) HOLDS TEMPERATURE (DEGREES CELSIUS X 10) -C RDATA(44) = MIN0(IMSG,NINT(OBS(2)*10.)) - RDATA(44) = NINT(MIN(99999._8,OBS(2)*10.)) -C TMPF HOLDS FORECAST TEMPERATURE (DEGREES CELSIUS X 10) - IF(FST_8(3).LT.XMSG) TMPF = NINT(FST_8(3) * 10.) -C QMARKI(5:5) HOLDS SDM TEMP PURGE FLAG (IF APPLICABLE) -- OR -- -C HOLDS SDM TEMP KEEP FLAG (IF APPLICABLE) -C (NOTE: IF ONLY SDM PURGE FLAG ON WIND, PREVIOUS PREPOBS_PREPDATA -C PROGRAM WILL ALSO SET TEMP Q.M. AS SDM PURGE) - IF(NINT(OBS(5)).EQ.14) THEN - QMARKI(5:5) = 'P' - ELSE IF(NINT(OBS(5)).EQ.0) THEN - QMARKI(5:5) = 'H' - END IF - END IF - IF(ILOOP.EQ.1) THEN -C IF ONLY ONE "PIECE" HAS BEEN DECODED IN THIS CALL, DECODE NEXT "PIECE" -C TO DETERMINE IF IT IS THE SECOND "PIECE" OF THE AIRCRAFT OBSERVATION -C (SAVE RPT SEQ. # OF 1ST "PIECE" FOR LATER COMPARISON AGAINST SECOND) - SQNL = HDR(9) - ILOOP = 2 - GO TO 30 - END IF -C IF TWO "PIECES" HAVE BEEN DECODED IN THIS CALL, READY TO RETURN -C COMPLETE AIRCRAFT OBSERVATION TO CALLING PROGRAM - ILOOP = 1 - IFLAG = 0 - RETURN -C----------------------------------------------------------------------- - 999 CONTINUE -C THE NUMBER OF DECODED LEVELS IS NOT 1!! -- STOP 70 - PRINT 217 - 217 FORMAT(/' THE NUMBER OF DECODED LEVELS FOR A REPORT IS NOT 1 -- ', - $ 'STOP 70'/) - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(70) -C----------------------------------------------------------------------- - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: OBUFR WRITES AIRCRAFT RPTS TO PREPBUFR FILE -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2008-07-30 -C -C ABSTRACT: RESORTS ALL OBS. IN HOLDING ARRAYS BACK TO ORIGINAL ORDER, -C THEN FOR ALL TABLE A ENTRY MESSAGES EXCEPT "AIRCFT" DOES A -C STRAIGHT COPY OF EACH SUBSET (REPORT) FROM THE INPUT PREPBUFR -C FILE TO THE OUTPUT PREPBUFR FILE. FOR TABLE A ENTRY "AIRCFT" -C MESSAGES, ALSO COPIES ALL SUBSETS (RPTS) THAT ARE NOT DUPLICATES -C OR NOT OUTSIDE USER-SPECIFIED TIME WINDOW. HOWEVER, FROM RESORTED -C OBS. HOLDING ARRAYS, DETERMINES IF AN "EVENT" HAS OCCURRED (I.E., -C A CHANGED TEMPERATURE OR WIND QUALITY MARKER ON AN OBS THAT WAS NOT -C ORIGNALLY "BAD"). IF SO, PUSHES DOWN TEMPERATURE OR WIND STACKED -C EVENTS AND RECORDS THIS EVENT (REASON CODE) ALONG WITH THE NEW -C QUALITY MARKER PRIOR TO WRITING THE SUBSET TO THE OUTPUT PREPBUFR -C FILE. WILL ALSO UPDATE LAT/LON IF IT WAS CHANGED DUE TO A WAYPOINT -C ERROR (THIS IS NOT A STACKED EVENT, HOWEVER). -C -C PROGRAM HISTORY LOG: -C 1994-08-25 D. A. KEYSER -- ORIGINAL AUTHOR -C 1995-03-27 D. A. KEYSER -- N-LIST SWITCHES "JAMASS" & "JAWIND" NOW -C 6-WORD ARRAYS, RPTS CAN NOW BE EXCLUDED FROM OUTPUT -C ACCORDING TO LAT. BAND; N-LIST SWITCH "FLAGUS"(LOGICAL) -C REPLACED BY "IFLGUS"(INTEGER), WHERE IFLGUS=0(1) EQUATES -C TO FLAGUS=F(T) AND NEW CHOICE IFLGUS=2 MEANS EXCLUDE RPTS -C OVER U.S. FROM OUTPUT RATHER THAN JUST FLAGGING -C 1995-04-26 D. A. KEYSER -- PROGRAM CODE STILL ENCODED INTO BUFR -C BUT ITS VALUE HARDWIRED TO 7 (IN PREP. FOR NEW BUFR -C USER TABLE WHICH WILL NO LONGER HAVE PGM CODE) -C 2004-11-16 D. A. KEYSER -- NOW CALLS BUFRLIB ROUTINE "UFBQCD" TO GET -C PROGRAM CODE FOR THIS Q.C. STEP ("PREPACQC") RATHER THAN -C HARDWIRING IT TO 7 AS BEFORE -C 2008-07-30 D. A. KEYSER -- PRIOR TO WRITING OUT EVENT, TESTS ORIG. T -C & W QM'S - IF > 3, WILL NOT WRITE OUT EVENT (HONORS -C ORIGINAL T & W QM'S IF BAD), THIS NEEDED BECAUSE TAMDAR -C AND CANADIAN AMDAR CURRENTLY HAVE T & W QM=9 COMING IN -C (MISSING OBS ERROR) WHICH CODE WAS IGNORING (AND WRITING -C OUT EVENT WITH GOOD QM MOST OF THE TIME - THIS CAUSED -C OIQC TO USE THESE OBS IN ITS DECISION MAKING PROCESS - -C THESE OBS ARE CURRENTLY ONLY MONITORED BY GSI AND SHOULD -C NOT BE CONSIDERED BY OIQC) -C -C USAGE: CALL OBUFR(KOUNT) -C INPUT ARGUMENT LIST: -C KOUNT - THE NUMBER OF AIRCRAFT OBSERVATIONS IN HOLDING ARRAYS -C -C INPUT FILES: -C UNIT 14 - PREPBUFR FILE CONTAINING ALL DATA -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C UNIT 61 - PREPBUFR FILE CONTAINING ALL DATA (NOW WITH ACFT QC) -C -C REMARKS: CALLED BY MAIN PROGRAM. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE OBUFR(KOUNT) - PARAMETER (IRMX= 80000) - PARAMETER (ISIZE= 16) - LOGICAL LTEST,DOSPOB - CHARACTER*1 CHRQM(6) - CHARACTER*8 LAST,ACID,AAID(IRMX),SUBSET,POSITN,HEADR - CHARACTER*14 TAG,STAG(IRMX) - CHARACTER*20 QM1LVL,QM2LVL - REAL(8) HDR(2),POS(2),QMS1(4),QMS2(5) - REAL RQM(6),SARRAY(IRMX,ISIZE),PHIACF(7) - INTEGER INDR(IRMX),IARRAY(IRMX),MFLAG(2) - COMMON/ALLDAT/IFLEPT(IRMX),ACID(IRMX),ALAT(IRMX),ALON(IRMX), - $ AALT(IRMX),TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE, - $ ATMP(IRMX),TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX), - $ ITEVNT(IRMX),IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX), - $ ADIRF(IRMX) - COMMON/OUTPUT/KNTOUT(5) - COMMON/INPT/DOSPOB,DOACRS,TMAXO,TMINO,TIMINC,WAYPIN,INIDST,IFLGUS, - $ JAMASS(6),JAWIND(6),RCPTST - COMMON/TSTACAR/KTACAR - COMMON/MASK/GDNH(362,91),GDSH(145,37),GDUS(362,91) - DATA QM1LVL/'TOB TQM TPC TRC '/ - DATA QM2LVL/'UOB WQM WPC WRC VOB '/ - DATA HEADR/'TYP SQN '/ - DATA POSITN/'YOB XOB '/ - DATA KNTBFR/0/,KKK/0/,IFLAG/0/,SQNL/0/ - DATA RQM / 0., 1., 3.,13.,10.,14./ - DATA CHRQM/'H','A','Q','F','O','P'/ - DATA LAST/'XXXXXXXX'/,ISUBO/0/,ISUBOT/0/,IRECOL/0/,IRECO/0/ - DATA PHIACF/-90.,-70.,-20.,0.,20.,70.,90./ - DATA MFLAG/2*0/ - PRINT 199 - 199 FORMAT(/5X,'===> ALL REPORTS Q.C.ED AND READY FOR REPACKING'/) - LTEST = (IFLGUS.GT.0.AND.KTACAR.GT.1) -C TRANSFER ORIGINAL DATA TO TEMPORARY ARRAYS TO HOLD FOR RE-ARRANGING - DO J = 1,KOUNT - IF(LTEST.AND.NINT(ALAT(J)).GT.0.AND.TAG(J)(7:7).NE.'Z') THEN -C TEST FOR AIREP/PIREP OBS. OVER CONTINENTAL U.S. WHEN IFLGUS = 1 OR 2 -C AND THERE ARE AT LEAST TWO "AIRCAR" TABLE A ENTRY BUFR MESSAGES - KXI = (360.0 - ALON(J)) + 0.005 + 1.0 - KYJ = ALAT(J) + 1.0 - IF(KYJ.LT.91.AND.(GDUS(KXI,KYJ).GT..5.OR.GDUS(KXI+1,KYJ).GT. - $ .5.OR.GDUS(KXI,KYJ+1).GT..5.OR.GDUS(KXI+1,KYJ+1).GT..5))THEN - IF(IFLGUS.EQ.1) THEN -C ..IN SUCH A CASE, FOR IFLGUS=1 ADD 400 TO TEMPERATURE AND WIND EVENT -C VALUE (THIS WILL LATER BECOME EVENT 325 & FLAG TEMP/WIND W/ 15'S) - ITEVNT(J) = ITEVNT(J) + 400 - IWEVNT(J) = IWEVNT(J) + 400 - ELSE -C ..IN SUCH A CASE, FOR IFLGUS=2, SET KNTINI TO 99999 (THIS WILL LATER -C EXCLUDE SUCH REPORTS FROM BEING OUTPUT) AND SET TAG POS. 1 TO "D" - KNTINI(J) = 99999 - TAG(J)(1:1) = 'D' - END IF - END IF - END IF - AAID(J) = ACID(J) - SARRAY(J,1) = ALAT(J) - SARRAY(J,2) = ALON(J) - SARRAY(J,3) = AALT(J) - SARRAY(J,4) = TIME(J) - SARRAY(J,5) = ATMP(J) - SARRAY(J,6) = ADIR(J) - SARRAY(J,7) = ASPD(J) - SARRAY(J,8) = REAL(INTP(J)) - SARRAY(J,9) = REAL(IRTM(J)) - SARRAY(J,10) = REAL(KNTINI(J)) - SARRAY(J,11) = REAL(ITEVNT(J)) - SARRAY(J,12) = REAL(IWEVNT(J)) - SARRAY(J,13) = AALTF(J) - SARRAY(J,14) = ADIRF(J) - SARRAY(J,15) = ASPDF(J) - SARRAY(J,16) = ATMPF(J) - STAG(J) = TAG(J) - IARRAY(J) = KNTINI(J) - ENDDO -C NEED TO RESORT OBS. ACCORDING TO ORIGINAL ORDER THAT WAS READ IN -C CALL SORT ROUTINE- PUTS POINTERS INTO IPOINT ARRAY/DOES NOT REARRANGE - IF(KOUNT.GT.0) CALL INDEXF(KOUNT,IARRAY,INDR) -C WRITE SORTED REPORTS BACK INTO ORIGINAL ARRAYS - DO I = 1,KOUNT - J = INDR(I) - ACID(I) = AAID(J) - ALAT(I) = SARRAY(J,1) - ALON(I) = SARRAY(J,2) - AALT(I) = SARRAY(J,3) - TIME(I) = SARRAY(J,4) - ATMP(I) = SARRAY(J,5) - ADIR(I) = SARRAY(J,6) - ASPD(I) = SARRAY(J,7) - INTP(I) = NINT(SARRAY(J,8)) - IRTM(I) = NINT(SARRAY(J,9)) - KNTINI(I) = NINT(SARRAY(J,10)) - ITEVNT(I) = NINT(SARRAY(J,11)) - IWEVNT(I) = NINT(SARRAY(J,12)) - AALTF(I) = SARRAY(J,13) - ADIRF(I) = SARRAY(J,14) - ASPDF(I) = SARRAY(J,15) - ATMPF(I) = SARRAY(J,16) - TAG(I) = STAG(J) - ENDDO - CALL DATELEN(10) - CALL OPENBF(14,'IN',14) - PRINT 200 - 200 FORMAT(/5X,'+++> PREPBUFR DATA SET IN UNIT 14 SUCCESSFULLY', - $ ' OPENED FOR INPUT; FIRST MESSAGE CONTAINS BUFR TABLES A,B,D'/) - CALL OPENBF(61,'OUT',14) - PRINT 100 - 100 FORMAT(/5X,'+++> PREPBUFR DATA SET IN UNIT 61 SUCCESSFULLY', - $ ' OPENED FOR OUTPUT; CUSTOMIZED BUFR TABLES A,B,D IN UNIT 14'/ - $ 12X,'READ IN AND ENCODED INTO MESSAGE NO. 1 OF OUTPUT DATA SET'/) - IF(LTEST) THEN - IF(IFLGUS.EQ.1) PRINT 300, KTACAR - IF(IFLGUS.EQ.2) PRINT 323, KTACAR - END IF - 300 FORMAT(/8X,'==> CONVL AIREP/PIREP RPTS OVER U.S. MAINLAND/G. MEX' - $,'ICO/SO.ONTARIO WILL BE FLAGGED, NO. ACARS MSGS PREV=',I5,' <==') - 323 FORMAT(/8X,'==> CONVL AIREP/PIREP RPTS OVER U.S. MAINLAND/G. MEXI' - $,'CO/SO.ONTARIO WILL BE EXCLUDED, NO. ACARS MSGS PREV=',I5,' <==') - -C GET THE "PROGRAM CODE" CORRESPONDING TO "PREPACQC" - CALL UFBQCD(14,'PREPACQC',PCODE) - - 10 CONTINUE - -C READ IN NEXT BUFR MESSAGE FROM INPUT FILE - CALL READMG(14,SUBSET,IDATEP,IRET) - IF(IRET.NE.0) THEN -C NON-ZERO IRET IN READMG MEANS ALL BUFR MESSAGES IN FILE HAVE BEEN READ -C CLOSE INPUT DATA SET - IF(LAST.EQ.'AIRCFT ') THEN -C CALL SUBR. SBUFR IF SUPEROBS ARE TO BE INCLUDED - IF(DOSPOB.AND.KNTOUT(3).GT.0) - $ CALL SBUFR(LTEST,SQNL,IRECOL,ISUBO,ISUBOT,PCODE) - CALL UFBCNT(61,IRECO,ISUBO) - ISUBOT = ISUBOT + ISUBO - PRINT 1254, IRECO,LAST,ISUBO,ISUBOT - 1254 FORMAT(/' --- WROTE BUFR DATA MSG NO. ',I10,' -- TABLE A ENTRY "', - $A8,'" - CONTAINS',I6,' REPORTS (TOTAL NO. RPTS WRITTEN =',I7,')'/) - END IF - PRINT 9101, IRECO,ISUBOT - 9101 FORMAT(/' --- ALL TOTAL OF',I11,' BUFR MESSAGES WRITTEN OUT -- TO' - $,'TAL NUMBER OF REPORTS WRITTEN =',I7//5X,'===> PREPBUFR DATA ' - $,'SET IN UNIT 14 SUCCESSFULLY CLOSED FROM FINAL READ OF ALL OBS') - CALL CLOSBF(61) - PRINT 9102 - 9102 FORMAT(/5X,'===> PREPBUFR DATA SET IN UNIT 61 SUCCESSFULLY ', - $ 'CLOSED AFTER WRITING OF ALL OBS'/25X,' *** ALL DONE ***'/) - RETURN - END IF - CALL UFBCNT(14,IRECI,ISUBI) -CCCCC PRINT 1364, IRECI,SUBSET - IF(SUBSET.EQ.'AIRCFT ') PRINT 1364, IRECI,SUBSET - 1364 FORMAT(' --- READ IN BUFR DATA MESSAGE NUMBER',I6,' WITH TABLE ', - $ 'A ENTRY "',A8,'"') - IF(LAST.NE.SUBSET) THEN - IF(LAST.EQ.'AIRCFT ') THEN -C CALL SUBR. SBUFR IF SUPEROBS ARE TO BE INCLUDED - IF(DOSPOB.AND.KNTOUT(3).GT.0) - $ CALL SBUFR(LTEST,SQNL,IRECOL,ISUBO,ISUBOT,PCODE) - CALL UFBCNT(61,IRECO,ISUBO) - ISUBOT = ISUBOT + ISUBO - PRINT 1254, IRECO,LAST,ISUBO,ISUBOT -C MUST CLOSE THE LAST "AIRCFT" TABLE A ENTRY MESSAGE - CALL CLOSMG(61) - END IF - PRINT 105, SUBSET,IDATEP - 105 FORMAT(/' ===> NEXT MESSAGE IN OUTPUT PREPBUFR DATA SET IN ', - $ 'UNIT 61 HAS NEW TABLE A ENTRY OF "',A6,'" -- DATE IS',I11) - CALL UFBCNT(61,IRECOL,ISUBO) - IRECOL = IRECOL + 1 - END IF - LAST = SUBSET - IF(SUBSET.NE.'AIRCFT ') THEN -C ALL TABLE A ENTRY BUFR MESSAGES THAT ARE NOT "AIRCFT" ARE SIMPLY -C COPIED FROM INPUT FILE TO OUTPUT FILE AS IS (NO DECODING OF SUBSETS) - CALL COPYMG(14,61) - CALL UFBCNT(61,IRECO,ISUBO) - ISUBOT = ISUBOT + ISUBO -CCCCC PRINT 1254, IRECO,SUBSET,ISUBO,ISUBOT - GO TO 10 - END IF -C TABLE A ENTRY "AIRCFT" MESSAGES COME HERE TO DECODE/ENCODE EACH SUBSET - CALL OPENMB(61,SUBSET,IDATEP) - 2 CONTINUE -C READ IN NEXT SUBSET (REPORT) FROM THIS BUFR MESSAGE - CALL READSB(14,IRET) -C NON-ZERO IRET IN READSB MEANS ALL SUBSETS IN BUFR MSG HAVE BEEN READ -C GO ON TO READ NEXT BUFR MESSAGE - IF(IRET.NE.0) GO TO 10 -C OTHERWISE, MUST LOOK AT RPT SEQ. NUMBER TO SEE IF THIS IS PIECE 1 OF A -C 1- OR 2-PIECE(MASS/WIND) OBS. (KNEW=1) OR IF THIS IS PIECE 2 (KNEW=0) - CALL UFBINT(14,HDR,2,1,N1LEV,HEADR) - IF(N1LEV.NE.1) GO TO 999 - KNEW = 0 - IF(HDR(2).NE.SQNL) THEN - KNEW = 1 - IF(IFLAG.EQ.0) THEN -C TEST BELOW SATISFIED WHEN BOTH JAMASS & JAWIND ARE 9999 FOR LAT BAND -C (SET POS. 1 OF TAG TO 'D' TO REMOVE FROM FINAL PRINTOUT LISTING) - IF(MIN0(MFLAG(1),MFLAG(2)).EQ.1) TAG(KKK)(1:1) = 'D' - KKK = KKK + 1 - MFLAG(1) = 1 - MFLAG(2) = 1 - END IF - IFLAG = 0 - KNTBFR = KNTBFR + 1 - END IF - SQNL = HDR(2) -C DETERMINE IF THIS "AIRCFT" OBS SHOULD INDEED BE WRITTEN TO OUTPUT FILE - IF(KNTBFR.NE.KNTINI(KKK)) THEN -C -- COME HERE IF NOT AND SET IFLAG=1 IN CASE NEXT PIECE READ IN IS -C PART OF THIS SAME OBS. - IFLAG = 1 - GO TO 2 - END IF -C DETERMINE LATITUDE BAND INDEX (IBNDA) - DO IBNDA = 1,5 - IF(ALAT(KKK).LT.(PHIACF(IBNDA+1)-0.005)) GO TO 6701 - ENDDO - IBNDA = 6 - 6701 CONTINUE - KI = NINT(HDR(1))/100 - IF((JAMASS(IBNDA).NE.0.AND.KI.EQ.1).OR.(JAWIND(IBNDA).NE.0.AND. - $ KI.EQ.2)) GO TO 3 - MFLAG(KI) = 0 -C ALL SUBSETS THAT ARE TO BE RETAINED ARE FIRST COPIED FROM INPUT BUFFER -C TO OUTPUT BUFFER AS IS - CALL UFBCPY(14,61) - IF(KI.EQ.1.AND.ITEVNT(KKK).GT.0) THEN -C --> COME HERE IF THERE IS A TEMPERATURE EVENT (NEW Q. MARKER) -C STACK NEW Q.MARK, PGM CODE, REASON CODE (EVENT) AND TEMP. OB -C (UNLESS ORIGINAL TEMP. QM IS "BAD", THEN DON'T WRITE OUT EVENT) - CALL UFBINT(14,QMS1,4,1,N1LEV,QM1LVL) - IF(QMS1(2).GT.3) THEN - IF(QMS1(2).LT.10) THEN - WRITE(TAG(KKK)(2:2),'(I1)') NINT(QMS1(2)) - ELSE IF(QMS1(2).EQ.10) THEN - TAG(KKK)(2:2) = 'a' - ELSE IF(QMS1(2).EQ.11) THEN - TAG(KKK)(2:2) = 'b' - ELSE IF(QMS1(2).EQ.12) THEN - TAG(KKK)(2:2) = 'c' - ELSE IF(QMS1(2).EQ.13) THEN - TAG(KKK)(2:2) = 'd' - ELSE IF(QMS1(2).EQ.14) THEN - TAG(KKK)(2:2) = 'e' - ELSE - TAG(KKK)(2:2) = 'f' - END IF - TAG(KKK)(13:13) = '8' - ITEVNT(KKK) = 0 - GO TO 2203 - END IF - IF(N1LEV.NE.1) GO TO 999 - IF(MOD(ITEVNT(KKK),400).GT.0) THEN -C ----> COME HERE FOR ALL EVENTS EXCEPT 325 - QMS1(2) = 2. - QMS1(3) = PCODE - QMS1(4) = REAL(MOD(ITEVNT(KKK),400)) -CVVVVVTEMPORARY -C UNTIL NEW USER TABLE SET-UP, MUST SUBTRACT 300 FROM REASON CODE - QMS1(4) = QMS1(4) - 300. -CAAAAATEMPORARY - DO I = 1,6 - IF(TAG(KKK)(2:2).EQ.CHRQM(I)) THEN - QMS1(2) = RQM(I) - GO TO 203 - END IF - ENDDO - 203 CONTINUE - CALL UFBINT(61,QMS1,4,1,IRET,QM1LVL) - END IF - IF(ITEVNT(KKK).GE.400) THEN -C ----> COME HERE FOR EVENT 325 - QMS1(2) = 15. - QMS1(3) = PCODE - QMS1(4) = 325. -CVVVVVTEMPORARY -C UNTIL NEW USER TABLE SET-UP, MUST SUBTRACT 300 FROM REASON CODE - QMS1(4) = QMS1(4) - 300. -CAAAAATEMPORARY - CALL UFBINT(61,QMS1,4,1,IRET,QM1LVL) - END IF - ELSE IF(KI.EQ.2.AND.IWEVNT(KKK).GT.0) THEN -C --> COME HERE IF THERE IS A WIND EVENT (NEW Q. MARKER) -C STACK NEW Q.MARK, PGM CODE, REASON CODE (EVENT) AND WIND OB -C (UNLESS ORIGINAL WIND QM IS "BAD", THEN DON'T WRITE OUT EVENT) - CALL UFBINT(14,QMS2,5,1,N1LEV,QM2LVL) - IF(QMS2(2).GT.3) THEN - IF(QMS2(2).LT.10) THEN - WRITE(TAG(KKK)(4:4),'(I1)') NINT(QMS2(2)) - ELSE IF(QMS2(2).EQ.10) THEN - TAG(KKK)(4:4) = 'a' - ELSE IF(QMS2(2).EQ.11) THEN - TAG(KKK)(4:4) = 'b' - ELSE IF(QMS2(2).EQ.12) THEN - TAG(KKK)(4:4) = 'c' - ELSE IF(QMS2(2).EQ.13) THEN - TAG(KKK)(4:4) = 'd' - ELSE IF(QMS2(2).EQ.14) THEN - TAG(KKK)(4:4) = 'e' - ELSE - TAG(KKK)(4:4) = 'f' - END IF - TAG(KKK)(14:14) = '8' - IWEVNT(KKK) = 0 - GO TO 2203 - END IF - IF(N1LEV.NE.1) GO TO 999 - IF(MOD(IWEVNT(KKK),400).GT.0) THEN -C ----> COME HERE FOR ALL EVENTS EXCEPT 325 - QMS2(2) = 2. - QMS2(3) = PCODE - QMS2(4) = REAL(MOD(IWEVNT(KKK),400)) -CVVVVVTEMPORARY -C UNTIL NEW USER TABLE SET-UP, MUST SUBTRACT 300 FROM REASON CODE - QMS2(4) = QMS2(4) - 300. -CAAAAATEMPORARY - DO I = 1,6 - IF(TAG(KKK)(4:4).EQ.CHRQM(I)) THEN - QMS2(2) = RQM(I) - GO TO 303 - END IF - ENDDO - 303 CONTINUE - CALL UFBINT(61,QMS2,5,1,IRET,QM2LVL) - END IF - IF(IWEVNT(KKK).GE.400) THEN -C ----> COME HERE FOR EVENT 325 - QMS2(2) = 15. - QMS2(3) = PCODE - QMS2(4) = 325. -CVVVVVTEMPORARY -C UNTIL NEW USER TABLE SET-UP, MUST SUBTRACT 300 FROM REASON CODE - QMS2(4) = QMS2(4) - 300. -CAAAAATEMPORARY - CALL UFBINT(61,QMS2,5,1,IRET,QM2LVL) - END IF - END IF - IF(TAG(KKK)(9:9).EQ.'C') THEN -C --> COME HERE IF LAT/LON WAS CHANGED DUE TO WAYPOINT ERROR -C WRITE NEW LAT/LON OUT (NOT A STACKED EVENT, OLD LAT/LON GONE!!) - POS(1) = ALAT(KKK) - POS(2) = 360. - ALON(KKK) - CALL UFBINT(61,POS,2,1,IRET,POSITN) - END IF - IF(KI.EQ.1) THEN - KNTOUT(1) = KNTOUT(1) + 1 - ELSE - KNTOUT(2) = KNTOUT(2) + 1 - END IF - - 2203 CONTINUE - -C FINALLY, WRITE SUBSET (REPORT) WITH ANY ADDED EVENTS (IF APPL.) TO -C OUTPUT FILE - CALL WRITSB(61) - CALL UFBCNT(61,IRECO,ISUBON) - IF(IRECO.GT.IRECOL) THEN - IRECOL = IRECO - ISUBOT = ISUBOT + ISUBO - PRINT 1264, IRECO-1,ISUBO,ISUBOT - 1264 FORMAT(/' --- THIS REPORT OPENS NEW MSG (SAME TABLE A): LAST ', - $ 'DATA MSG WAS NO.',I10,' WITH',I5,' REPORTS (TOTAL NO. REPORTS ', - $ 'WRITTEN =',I7,')'/) - END IF - ISUBO = ISUBON - 3 CONTINUE -CCCCC IF(KNEW.EQ.1) THEN -CCCCC TEMP = 99999. -CCCCC IF(ATMP(KKK).LT.99999.) TEMP = ATMP(KKK)/10. -CCCCC PRINT 6111, KKK,ACID(KKK),TIME(KKK),ALAT(KKK),ALON(KKK), -CCCCC$ AALT(KKK),TEMP,ADIR(KKK),ASPD(KKK),TAG(KKK)(2:2),TAG(KKK)(4:4), -CCCCC$ TAG(KKK),INTP(KKK),IRTM(KKK),KNTINI(KKK),ITEVNT(KKK),IWEVNT(KKK) -C6111 FORMAT(' ',I5,2X,A8,F8.0,2F9.2,F7.0,F9.2,F7.0,F8.1,4X,A1,1X,A1, -CCCCC$ 3X,'"',A14,'"',2I6,I8,2I6) -CCCCC END IF - GO TO 2 -C----------------------------------------------------------------------- - 999 CONTINUE -C THE NUMBER OF DECODED HEADER AND/OR OBS. LEVELS IS NOT 1!! -- STOP 70 - PRINT 217 - 217 FORMAT(/' THE NUMBER OF DECODED HEADER AND/OR OBS. LEVELS FOR', - $ ' A REPORT IS NOT 1 -- STOP 70'/) - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(70) -C----------------------------------------------------------------------- - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: SBUFR WRITES SUPEROB RPTS TO PREPBUFR FILE -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2004-11-16 -C -C ABSTRACT: ENCODES SUPEROB AIRCRAFT MASS AND WIND REPORTS INTO THE -C OUTPUT PREPBUFR FILE. THESE ARE CONSIDERED EVENT 326 FOR -C TEMPERATURE AND WIND. MAY ALSO PUSH DOWN TEMPERATURE AND WIND -C STACK AND RECORD AN EVENT IF REPORT IS OVER CONTINENTAL U.S. AND -C ACARS DATA ARE PRESENT (EVENT IS SETTING QUALITY MARKER TO 15, -C VALID ONLY FOR NAMELIST SWITCH IFLGUS = 1). -C -C PROGRAM HISTORY LOG: -C 1994-08-25 D. A. KEYSER -- ORIGINAL AUTHOR -C 1995-03-27 D. A. KEYSER -- SUPEROBS NOW CONTAIN S-OBED FCST P-ALT, -C WIND DIR, WIND SPEED & TEMP (IF AVAIL. FROM INDIV. RPTS -C MAKING UP SUPEROBS), FCST INFO. ENCODED IN BUFR ALONG W/ -C REST OF SUPEROBED DATA (FCST DIR/SPEED CONVERTED TO U/V); -C N-LIST SWITCHES "JAMASS" & "JAWIND" NOW 6-WORD ARRAYS, -C REPORTS CAN NOW BE EXCLUDED FROM OUTPUT ACCORDING TO -C LAT. BAND; N-LIST SWITCH "FLAGUS"(LOGICAL) REPLACED BY -C "IFLGUS"(INTEGER), WHERE IFLGUS=0(1) EQUATES TO -C FLAGUS=F(T) AND NEW CHOICE IFLGUS=2 MEANS EXCLUDE RPTS -C OVER U.S. FROM OUTPUT RATHER THAN JUST FLAGGING -C 2004-11-16 D. A. KEYSER -- ADDED INPUT ARGUMENT "PCODE" WHICH HOLDS -C PROGRAM CODE FOR THIS Q.C. STEP ("PREPACQC"), BEFORE IT -C WAS HARDWIRED TO 7 -C -C USAGE: CALL SBUFR(LTEST,COUNT,IRECOL,ISUBO,ISUBOT,PCODE) -C INPUT ARGUMENT LIST: -C LTEST - LOGICAL TO INDICATE IF REPORTS OVER CONTINENTAL U.S. -C - SHOULD BE FLAGGED (BASED ON NUMBER OF ACARS REPORTS -C - AND NAMELIST SWITCH IFLGUS) -C COUNT - REPORT SEQUENCE NUMBER OF LAST ORIGINAL AIRCRAFT -C - REPORT PROCESSED IN SUBROUTINE OBUFR -C IRECOL - CURRENT RECORD (MESSAGE) NUMBER BEING WRITTEN INTO -C - IN PREPBUFR DATA SET -C ISUBO - CURRENT NUMBER OF SUBSETS THAT HAVE BEEN WRITTEN INTO -C - CURRENT RECORD (MESSAGE) IN PREPBUFR DATA SET -C ISUBOT - TOTAL NUMBER OF SUBSETS THAT HAVE BEEN WRITTEN INTO -C - PREPBUFR DATA SET PRIOR TO THE CURRENT RECORD -C PCODE - PROGRAM CODE CORRESPONDING TO THIS Q.C. STEP -C - ("PREPACQC") -C -C OUTPUT ARGUMENT LIST: -C ISUBOT - TOTAL NUMBER OF SUBSETS THAT HAVE BEEN WRITTEN INTO -C - PREPBUFR DATA SET PRIOR TO THE CURRENT RECORD -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C UNIT 61 - PREPBUFR FILE CONTAINING ALL DATA (NOW WITH ACFT QC -C - AND SUPEROBS) -C -C REMARKS: CALLED BY SUBROUTINE OBUFR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE SBUFR(LTEST,COUNT,IRECOL,ISUBO,ISUBOT,PCODE) - PARAMETER (ISUP= 4000) - LOGICAL LTEST - CHARACTER*1 CIQMMK(10) - CHARACTER*4 SSMARK - CHARACTER*8 IDENT - CHARACTER*16 QMSLV(2),FSTLV(2) - CHARACTER*32 OBSLV(2),EVNLV(2) - CHARACTER*40 HEADR - REAL(8) HDR1,HDR(10),OBS(8),QMS(4),EVN(8),QFLG(5),FST_8(4) - REAL ACAT(9),PHIACF(7) - INTEGER LCAT(9),MFLAG(2) - - COMMON/TSTACAR/KTACAR - COMMON/MASK/GDNH(362,91),GDSH(145,37),GDUS(362,91) - COMMON/SUPOBS/SSLAT(ISUP),SSLON(ISUP),SSTIM(ISUP),SSHGT(ISUP), - $ SSTMP(ISUP),SSDIR(ISUP),SSSPD(ISUP),SSHGTF(ISUP),SSTMPF(ISUP), - $ SSDIRF(ISUP),SSSPDF(ISUP),SSMARK(ISUP) - COMMON/OUTPUT/KNTOUT(5) - COMMON/STDATE/IDATE(5) - COMMON/INPT/DOSPOB,DOACRS,TMAXO,TMINO,TIMINC,WAYPIN,INIDST,IFLGUS, - $ JAMASS(6),JAWIND(6),RCPTST - EQUIVALENCE (IDENT,HDR1) - DATA HEADR/'SID XOB YOB DHR TYP T29 TSB ITP ELV SQN '/ - DATA OBSLV/'POB TOB ZOB CAT NUL NUL NUL NUL ', - $ 'POB NUL ZOB CAT UOB VOB DDO FFO '/ - DATA QMSLV/'PQM NUL TQM ZQM ', - $ 'PQM WQM NUL ZQM '/ - DATA FSTLV/'NUL NUL TFC ZFC ', - $ 'UFC VFC NUL ZFC '/ - DATA EVNLV/'PPC PRC ZPC ZRC TPC TRC NUL NUL ', - $ 'PPC PRC ZPC ZRC NUL NUL WPC WRC '/ - DATA IDENT/'SUPROB '/,XMSG/99998./ - DATA CIQMMK/'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z'/ - DATA ACAT/10.5,20.5,30.5,40.5,50.5,60.5,70.5,80.5,90.5/ - DATA LCAT/ 20, 40, 60, 80, 100, 120, 140, 160, 180/ - DATA PHIACF/-90.,-70.,-20.,0.,20.,70.,90./ -C FCNS PRS, PR CALC. PRESS. FROM ALT. FOR Z > 11000M, Z < 11000M; RESP -C (U.S. STANDARD ATMOSPHERE) - PRS(Z) = 226.3 * EXP(1.576106E-4 * (11000. - Z)) - PR(Z) = 1013.25 * (((288.15 - (.0065 * Z))/288.15)**5.256) - PRINT 299 - 299 FORMAT(/25X,'**** READY TO ENCODE SUPEROB MASS AND WIND REPORTS', - $ ' IN THE PREPBUFR FILE ****'/) - IF(LTEST) THEN - IF(IFLGUS.EQ.1) PRINT 300, KTACAR - IF(IFLGUS.EQ.2) PRINT 323, KTACAR - END IF - 300 FORMAT(8X,'==> SUPEROBED REPORTS OVER U.S. MAINLAND/G. MEXICO/SO', - $ '.ONTARIO WILL ALSO BE FLAGGED, NO. ACARS MSGS PREV=',I5,' <=='/) - 323 FORMAT(8X,'==> SUPEROBED REPORTS OVER U.S. MAINLAND/G. MEXICO/SO', - $'.ONTARIO WILL ALSO BE EXCLUDED, NO. ACARS MSGS PREV=',I5,' <=='/) -C INITIALIZE THE CONSTANTS - HDR(1) = HDR1 - HDR(6) = 41. - HDR(7) = 0. - HDR(8) = 99. - OBS(4) = 6. - QMS(1) = 2. - QMS(4) = 2. - EVN(1) = PCODE - EVN(2) = 326. -CVVVVVTEMPORARY -C UNTIL NEW USER TABLE SET-UP, MUST SUBTRACT 300 FROM REASON CODE - EVN(2) = EVN(2) - 300. -CAAAAATEMPORARY - EVN(3) = PCODE - EVN(4) = 326. -CVVVVVTEMPORARY -C UNTIL NEW USER TABLE SET-UP, MUST SUBTRACT 300 FROM REASON CODE - EVN(4) = EVN(4) - 300. -CAAAAATEMPORARY - QFLG(2) = 15. - QFLG(3) = PCODE - QFLG(4) = 325. -CVVVVVTEMPORARY -C UNTIL NEW USER TABLE SET-UP, MUST SUBTRACT 300 FROM REASON CODE - QFLG(4) = QFLG(4) - 300. -CAAAAATEMPORARY -C LOOP THROUGH ALL THE SUPEROBS - DO I = 1,KNTOUT(3) - SSMARK(I) = 'SS ' - IFLAG = 0 -C CONVERT PRESSURE ALTITUDE TO PRESSURE (VIA U.S. STD. ATMOS. EST.) - IF(SSHGT(I).GE.XMSG) THEN - SSMARK(I)(3:4) = 'FF' - GO TO 1 - END IF - IF(LTEST.AND.NINT(SSLAT(I)).GT.0) THEN -C TEST FOR SUPEROBS OVER CONTINENTAL U.S. WHEN IFLGUS=1 OR 2 AND THERE -C ARE AT LEAST TWO "AIRCAR" TABLE A ENTRY BUFR MESSAGES - KXI = (360.0 - SSLON(I)) + 0.005 + 1.0 - KYJ = SSLAT(I) + 1.0 - IF(KYJ.LT.91.AND.(GDUS(KXI,KYJ).GT..5.OR.GDUS(KXI+1,KYJ).GT. - $ .5.OR.GDUS(KXI,KYJ+1).GT..5.OR.GDUS(KXI+1,KYJ+1).GT..5))THEN - IF(IFLGUS.EQ.1) THEN -C ..IN SUCH A CASE, IF IFLGUS=1 SET IFLAG = 1 (WILL LATER FLAG TEMP/ -C (WIND WITH 15'S) - IFLAG = 1 - SSMARK(I)(1:2) = 'PP' - ELSE -C ..IN SUCH A CASE, IF IFLGUS=2 EXCLUDE REPORT FROM PROCESSING -C (WIND WITH 15'S) - SSMARK(I)(3:4) = 'FF' - GO TO 1 - END IF - END IF - END IF -CCCCC TEMP = 99999. -CCCCC IF(SSTMP(I).LT.99999.) TEMP = SSTMP(I)/10. -CCCCC PRINT 6111, I,SSTIM(I),SSLAT(I),SSLON(I),SSHGT(I),TEMP, -CCCCC$ SSDIR(I),SSSPD(I),IFLAG -C6111 FORMAT(' ',I5,' SUPROB',F9.0,2F9.2,F7.0,F9.2,F7.0,F8.1,4X, -CCCCC$ 'S S',I5) -C FILL THE HEADER INFORMATION FOR THIS SUPEROB REPORT - OBS(1) = PR(SSHGT(I)) - IF(SSHGT(I).GT.11000.) OBS(1) = PRS(SSHGT(I)) - HDR(2) = 360. - SSLON(I) - HDR(3) = SSLAT(I) - DT = SSTIM(I) - REAL(IDATE(4)*100) - IF(DT.GT. 1200.) DT = DT - 2400. - IF(DT.LT.-1200.) DT = DT + 2400. - HDR(4) = DT * .01 - HDR(9) = SSHGT(I) - HDR(10) = COUNT + REAL(I) - OBS(3) = SSHGT(I) - IF(SSHGTF(I).LT.XMSG) FST_8(4) = SSHGTF(I) -C DETERMINE LATITUDE BAND INDEX (IBNDA) - DO IBNDA = 1,5 - IF(HDR(3).LT.(PHIACF(IBNDA+1)-0.005)) GO TO 6701 - ENDDO - IBNDA = 6 - 6701 CONTINUE - MFLAG(1) = 1 - MFLAG(2) = 1 - IF(SSTMP(I).LT.XMSG.AND.JAMASS(IBNDA).EQ.0) THEN - MFLAG(1) = 0 -C FILL THE MASS PIECE INFORMATION FOR THIS SUPEROB REPORT - HDR(5) = 131. - OBS(2) = SSTMP(I)/10. - IF(SSTMPF(I).LT.XMSG) THEN - FST_8(3) = SSTMPF(I)/10. - IF(ABS(HDR(4)).LE.3.33) THEN - TDIF = ABS(FST_8(3)-OBS(2)) - SSMARK(I)(3:3) = 'Z' - DO J = 1,9 - IF(NINT(TDIF*10.).LT.LCAT(J)) THEN - SSMARK(I)(3:3) = CIQMMK(J) - GO TO 1175 - END IF - ENDDO - 1175 CONTINUE - END IF - END IF - QMS(3) = 1. - EVN(5) = PCODE - EVN(6) = 326. -CVVVVVTEMPORARY -C UNTIL NEW USER TABLE SET-UP, MUST SUBTRACT 300 FROM REASON CODE - EVN(6) = EVN(6) - 300. -CAAAAATEMPORARY - CALL UFBINT(61,HDR,10,1,IRET,HEADR) - CALL UFBINT(61,OBS,08,1,IRET,OBSLV(1)) - CALL UFBINT(61,QMS,04,1,IRET,QMSLV(1)) - CALL UFBINT(61,FST_8,04,1,IRET,FSTLV(1)) - CALL UFBINT(61,EVN,08,1,IRET,EVNLV(1)) - IF(IFLAG.EQ.1) THEN -C ----> COME HERE FOR EVENT 325 - QFLG(1) = OBS(2) - CALL UFBINT(61,QFLG,4,1,IRET,'TOB TQM TPC TRC') - END IF - KNTOUT(4) = KNTOUT(4) + 1 -C WRITE SUBSET (SUPEROB MASS REPORT) TO OUTPUT FILE - CALL WRITSB(61) - CALL UFBCNT(61,IRECO,ISUBON) - IF(IRECO.GT.IRECOL) THEN - IRECOL = IRECO - ISUBOT = ISUBOT + ISUBO - PRINT 1264, IRECO-1,ISUBO,ISUBOT - 1264 FORMAT(/' --- THIS REPORT OPENS NEW MSG (SAME TABLE A): LAST ', - $ 'DATA MSG WAS NO.',I10,' WITH',I5,' REPORTS (TOTAL NO. REPORTS ', - $ 'WRITTEN =',I7,')'/) - END IF - ISUBO = ISUBON - END IF - IF(SSDIR(I).LT.XMSG.AND.SSSPD(I).LT.XMSG.AND. - $ JAWIND(IBNDA).EQ.0) THEN - MFLAG(2) = 0 -C FILL THE WIND PIECE INFORMATION FOR THIS SUPEROB REPORT - HDR(5) = 231. - OBS(7) = SSDIR(I) - OBS(8) = SSSPD(I) - IF(SSSPD(I).GT.0.) THEN - OBS(5) = (-SSSPD(I) * 0.5148) * SIN(SSDIR(I)*0.017453293) - OBS(6) = (-SSSPD(I) * 0.5148) * COS(SSDIR(I)*0.017453293) - ELSE - OBS(5) = 0. - OBS(6) = 0. - END IF - IF(SSDIRF(I).LT.XMSG.AND.SSSPDF(I).LT.XMSG) THEN - FST_8(1)=(-SSSPDF(I)* 0.5148) *SIN(SSDIRF(I)*0.017453293) - FST_8(2)=(-SSSPDF(I)* 0.5148) *COS(SSDIRF(I)*0.017453293) - IF(ABS(HDR(4)).LE.3.33) THEN - VDIF=SQRT((FST_8(1)-OBS(5))**2+(FST_8(2)-OBS(6))**2)*1.9425 - SSMARK(I)(4:4) = 'Z' - DO J = 1,9 - IF(VDIF.LT.ACAT(J)) THEN - SSMARK(I)(4:4) = CIQMMK(J) - GO TO 175 - END IF - ENDDO - 175 CONTINUE - END IF - END IF - QMS(2) = 1. - EVN(7) = PCODE - EVN(8) = 326. -CVVVVVTEMPORARY -C UNTIL NEW USER TABLE SET-UP, MUST SUBTRACT 300 FROM REASON CODE - EVN(8) = EVN(8) - 300. -CAAAAATEMPORARY - CALL UFBINT(61,HDR,10,1,IRET,HEADR) - CALL UFBINT(61,OBS,08,1,IRET,OBSLV(2)) - CALL UFBINT(61,QMS,04,1,IRET,QMSLV(2)) - CALL UFBINT(61,FST_8,04,1,IRET,FSTLV(2)) - CALL UFBINT(61,EVN,08,1,IRET,EVNLV(2)) - IF(IFLAG.EQ.1) THEN -C ----> COME HERE FOR EVENT 325 - QFLG(1) = OBS(5) - QFLG(5) = OBS(6) - CALL UFBINT(61,QFLG,5,1,IRET,'UOB WQM WPC WRC VOB') - END IF - KNTOUT(5) = KNTOUT(5) + 1 -C WRITE SUBSET (SUPEROB WIND REPORT) TO OUTPUT FILE - CALL WRITSB(61) - CALL UFBCNT(61,IRECO,ISUBON) - IF(IRECO.GT.IRECOL) THEN - IRECOL = IRECO - ISUBOT = ISUBOT + ISUBO - PRINT 1264, IRECO-1,ISUBO,ISUBOT - END IF - ISUBO = ISUBON - END IF -C TEST BELOW SATISFIED WHEN BOTH JAMASS & JAWIND ARE 9999 FOR LAT BAND -C (SET POS. 1 & 2 OF SSMARK TO 'FF' REMOVE FROM FINAL PRINTOUT LISTING) - IF(MIN0(MFLAG(1),MFLAG(2)).EQ.1) SSMARK(I)(3:4) = 'FF' - 1 CONTINUE - ENDDO - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: CMDDFF CONVERTS WIND U/V COMPONENTS TO DIR/SPD -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1995-03-27 -C -C ABSTRACT: CONVERTS GRID U AND V COMPONENTS OF VELOCITY (M/S) TO WIND -C DIRECTION AND SPEED. SEE ARGUMENT 'ISUNIT' FOR OUTPUT SPEED UNITS. -C -C PROGRAM HISTORY LOG: -C UNKNOWN -C 1995-03-27 D. A. KEYSER -- ORIGINAL AUTHOR -C -C USAGE: CALL CMDDFF(ISUNIT,U,V,DD,FF) -C INPUT ARGUMENT LIST: -C ISUNIT - OUTPUT SPEED UNIT INDICATOR (=1 - KNOTS, =2 - M/S) -C U - U-COMPONENT OF WIND VELOCITY (M/S) -C V - V-COMPONENT OF WIND VELOCITY (M/S) -C -C OUTPUT ARGUMENT LIST: -C DD - DIRECTION OF WIND (DEGREES) -C FF - SPEED OF WIND (SEE 'ISUNIT' FOR UNITS) -C -C REMARKS: CALLED BY SUBROUTINE IBUFR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE CMDDFF(ISUNIT,U,V,DD,FF) - REAL FACTOR(2) - DATA FACTOR/0.5148,1.0/,CONV2R/0.017453293/ - IF(U.EQ.0.0) THEN - DD = 0. - IF(V.GT.0.0) DD = 180. - ELSE - IF(V.EQ.0.0) THEN - DD = 90. - IF(U.GT.0.0) DD = 270. - ELSE - DD = (ATAN2(U,V)/CONV2R) + 180. - DD = AMOD(DD,360.) - END IF - END IF - FF = SQRT(U**2 + V**2)/FACTOR(ISUNIT) - RETURN - END +c SYSTEM: - SYSTEM +c W3NCO: - ERREXIT W3TAGB W3TAGE W3MOVDAT MOVA2I W3FI04 +c W3EMC: - W3FC05 ORDERS +c BUFRLIB: - IREADMG IREADSB UFBINT UFBSEQ UFBEVN READNS IBFMS +c - COPYMG OPENMB UFBCPY WRITSB WRITLC CLOSMG DATELEN +c - OPENBF CLOSBF UFBQCD SETBMISS GETBMISS +c +c Exit states: +c Cond = 0 - successful run +c 4 - no aircraft reports of any type read in +c 23 - unexpected return code from readns; problems reading BUFR file +c 31 - indexing problem encountered when trying to match QC'd data in arrays to +c mass and wind pieces in original PREPBUFR file (subroutine +c output_acqc_noprof) +c 59 - nlvinprof is zero coming into subroutine sub2mem_mer (should never +c happen!) +c 61 - index "j is .le. 1 meaning "iord" array underflow (should never happen!) +c (subroutine sub2mem_mer) +c 69 - row number for input data matrix is outside range of 1-34 (subroutine +c tranQCflags) +c 79 - characters on this machine are not ASCII, conversion of quality flag to +c row number in subroutine tranQCflags cannot be made +c 98 - too many flights in input PREPBUFR file, must increase size of parameter +c "maxflt" (in some places code continues but in this case can't be sure +c continuing on w/o processing any more data would turn out ok) +calloc 99 - unable to allocate one or more array +c +c Remarks: +c Input Namelist switches (namelist &nrlacqcinput)): +c trad - time window radius in hours for outputting reports (if l_otw=T) +c (default=3.0) +c l_otw - logical: +c TRUE - eliminate reports outside the time window radius +c +/- trad when writing out reports +c +c FALSE - DO NOT eliminate reports outside the time window +c radius +/- trad when writing out reports +c (default=FALSE) +c l_nhonly - logical: +c TRUE - eliminate reports outside tropics & N. Hemisphere +c when writing out reports +c FALSE - DO NOT eliminate reports outside tropics & N. +c Hemisphere when writing out reports +c (default=FALSE) +c l_doprofiles - logical: +c TRUE - create merged raob lookalike QC'd profiles from +c aircraft ascents and descents (always) and output +c these as well as QC'd merged single(flight)-level +c aircraft reports not part of any profile (when +c l_prof1lvl=T) to a PREPBUFR-like file +c **CAUTION: Will make code take quite a bit longer +c to run! +c FALSE - SKIP creation of merged raob lookalike QC'd +c profiles from aircraft ascents and descents into +c PREPBUFR-like file +c (default=FALSE) +c l_allev_pf - logical: +c TRUE - process latest (likely NRLACQC) events plus all +c prior events into profiles PREPBUFR-like file +c **CAUTION: More complete option, but will make code +c take longer to run! +c FALSE - process ONLY latest (likely NRLACQC) events into +c profiles PREPBUFR-like file +c (Note 1: Hardwired to FALSE if l_doprofiles=FALSE) +c {Note 2: All pre-existing events plus latest (likely +c NRLACQC) events are always encoded into full +c PREPBUFR file} +c (default=FALSE) +c l_prof1lvl - logical: +c TRUE - encode merged single(flight)-level aircraft reports +c with NRLACQC events that are not part of any +c profile into PREPBUFR-like file, along with merged +c profiles from aircraft ascents and descents +c **CAUTION: Will make code take a bit longer to run! +c FALSE - DO NOT encode merged single(flight)-level aircraft +c reports with NRLACQC events that are not part of +c any profile into PREPBUFR-like file +c - only merged profiles from aircraft ascents and +c descents will be encoded into this file +c (Note: Applicable only when l_doprofiles=TRUE) +c (default=FALSE) +c l_mandlvl - logical: +c TRUE - interpolate obs data to mandatory levels in profile +c generation +c FALSE - DO NOT interpolate obs data to mandatory levels in +c profile generation +c (Note: Applicable only when l_doprofiles=TRUE) +c (default=TRUE) +c tsplines - logical: +c TRUE - use Jim Purser's tension-spline interpolation +c utility to generate aircraft vertical velocity rate +c in profile generation +c FALSE - use finite-difference method based on nearest +c neighboring pair of obs which are at least one +c minute apart to generate aircraft vertical velocity +c rate in profile generation +c (Note: Applicable only when l_doprofiles=TRUE) +c (default=TRUE) +c +c Attributes: +c Language: FORTRAN 90 +c Machine: NCEP WCOSS +c +c$$$ + program prepobs_prepacqc + + implicit none + +c ------------------------------ +c Parameter statements/constants +c ------------------------------ + integer inlun ! input unit number (for pre-prepacqc PREPBUFR file + ! containing all obs) + parameter (inlun = 11) + + integer extbl ! unit number for external table file (if used) + parameter (extbl = 12) + + integer outlun ! output unit number for post-PREPACQC PREPBUFR file + ! with added NRLACQC events + parameter (outlun=61) + + integer proflun ! output unit number for post-PREPACQC PREPBUFR-like + ! file containing merged profile reports (always) and + parameter (proflun=62) + + integer max_reps ! maximum number of input merged (mass + wind piece) + ! aircraft-type reports allowed + parameter (max_reps = 300000) + +cvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv +c replace above with this in event of future switch to dynamic memory allocation + +calloc integer max_reps ! original number of input merged (mass + wind piece) +calloc ! aircraft-type reports (obtained from first pass +calloc ! through input PREPBUFR file to get total for array +calloc ! allocation should = nrpts4QC_pre) +c^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + + integer maxflt ! maximum number of flights allowed (inside NRL QC) + parameter (maxflt = 12500) + character*6 cmaxflt ! character form of maxflt + + integer imiss ! NRL integer missing value flag + parameter (imiss = 99999) + + real amiss ! NRL real missing value flag + parameter (amiss = -9999.) + + real*8 bmiss ! BUFR missing value + real*8 getbmiss ! Function to return current bmiss value from BUFRLIB + + real m2ft ! NRL conversion factor to convert m to ft + + parameter (m2ft = 3.28084) + +c ---------------------- +c Declaration statements +c ---------------------- + +c Indices/counters +c ---------------- + integer i,j ! loop indeces + + integer nrpts4QC_pre ! original number of input merged (mass + wind piece) + ! aircraft-type reports (read in from PREPBUFR file) + ! (after all is said and done, should equal nrpts4QC + + ! krej) + + integer nrpts4QC ! number of merged (mass + wind piece) reports going + ! through NRL QC code (initially equals nrpts4QC_pre, + ! then reduced as processing continues - ultimately + ! includes only "good" reports) + + integer krej ! number of merged (mass + wind piece) reports + ! ulimately rejected by NRL QC code + +c Observation variables required by the NRL aircraft QC routine +c ------------------------------------------------------------- + character*10 cdtg_an ! date-time group for analysis (YYYYMMDDCC) + + + character*11 c_qc(max_reps) ! character QC flags output from NRL QC code + ! 1st char - info about reject (if ob was rejected) + ! 2nd char - reason why time was rejected + ! 3rd char - reason why latitude was rejected + ! 4th char - reason why longitude was rejected + ! 5th char - reason why pressure/atitude was rejected + ! 6th char - readon why temperature was rejected + ! 7th char - reason why wind direction was rejected + ! 8th char - reason why wind speed was rejected + ! 9th char - reason why mixing ratio was rejected + ! 10th char - reason for blacklisting the aircraft + ! 11th char - info about flight phase + + character*25 csort(max_reps) ! variable (sort key) used for sorting data in NRL QC + ! code + + integer itype(max_reps) ! instrument (aircraft) type + real*8 alat(max_reps) ! latitude + +, alon(max_reps) ! longitude + real pres(max_reps) ! pressure + +, ht_ft(max_reps) ! altitude in feet + integer idt(max_reps) ! time in seconds to anal. time (- before, + after) + integer idp(max_reps) ! surface pressure change at ob location (not created + ! anywhere, set to missing) + integer ncep_qm_p(max_reps) ! NCEP PREPBUFR quality mark pressure (PQM) + +, ncep_rc_p(max_reps) ! NCEP PREPBUFR NRLACQC pressure event reason code(PRC) + +, ncep_qm_z(max_reps) ! NCEP PREPBUFR quality mark on altitude (ZQM) + +, ncep_rc_z(max_reps) ! NCEP PREPBUFR NRLACQC alt/hght event reason code(ZRC) + +, ncep_qm_t(max_reps) ! NCEP PREPBUFR quality mark on temperature (TQM) + +, ncep_rc_t(max_reps) ! NCEP PREPBUFR NRLACQC temperature evnt rea. code(TRC) + +, ncep_qm_q(max_reps) ! NCEP PREPBUFR quality mark on moisture (QQM) + +, ncep_rc_q(max_reps) ! NCEP PREPBUFR NRLACQC moisture reason code (QRC) + +, ncep_qm_w(max_reps) ! NCEP PREPBUFR quality mark on wind (WQM) + +, ncep_rc_w(max_reps) ! NCEP PREPBUFR NRLACQC wind event reason code (WRC) + +, ncep_rej(max_reps) ! NCEP PREPBUFR rejection indicator + + character*14 c_dtg(max_reps) ! full date-time group (yyyymmddhhmmss) + character*8 c_acftreg(max_reps) ! aircraft registration (tail) number (used in NRL QC + ! QC processing) + character*9 c_acftid(max_reps) ! aircraft flight number (used in NRL QC processing) + + real t_prcn(max_reps) ! temperature precision + +, ob_t(max_reps) ! temperature + +, ob_q(max_reps) ! moisture (specific humidity) + +, ob_dir(max_reps) ! wind direction + +, ob_spd(max_reps) ! wind speed + +, xiv_t(max_reps) ! temperature innovation/increment (ob-bg) + +, xiv_q(max_reps) ! specific humidity innovation/increment (ob-bg) + +, xiv_d(max_reps) ! wind direction innovation/increment (ob-bg) + +, xiv_s(max_reps) ! wind speed innovation/increment (ob-bg) + + integer ichk_t(max_reps) ! NRL QC flag for temperature ob + +, ichk_q(max_reps) ! NRL QC flag for specific humidity ob + +, ichk_d(max_reps) ! NRL QC flag for wind direction ob + +, ichk_s(max_reps) ! NRL QC flag for wind speed ob + +, nchk_t(max_reps) ! NCEP QC flag for temperature ob + +, nchk_q(max_reps) ! NCEP QC flag for specific humidity ob + +, nchk_d(max_reps) ! NCEP QC flag for wind direction ob + +, nchk_s(max_reps) ! NCEP QC flag for wind speed ob + +, phase(max_reps) ! phase of flight for aircraft + + logical l_minus9c(max_reps) ! true for MDCRS -9C temperatures + +c Pointers +c -------- + integer indx(max_reps) ! pointer index in NRL QC for good reports + +, in_bad(max_reps) ! pointer index in NRL QC for bad reports + +, isave(max_reps) ! second pointer index in NRL QC + +c ************************************************** +c All below are output from NRL acftobs_qc routine +c ************************************************** + +c Flight statistics +c ----------------- + character*8 creg_flt(maxflt) ! tail number for each flight + character*9 cid_flt(maxflt) ! flight id for each flight + +, cid_flt_old(maxflt) ! previous value of cid_flt + integer nobs_flt(maxflt) ! number of reports per flight + +, ntot_flt(maxflt) ! total number of reports per flight + +, ntot_flt_old(maxflt)! previous value of total num of reports per flt + +, nrej_flt(maxflt) ! number of reports rejected per flight + +, nrej_flt_old(maxflt)! previous value of num of reports rejected per flt + +, iobs_flt(maxflt) ! index for first report in each flight + +, kflight ! number of flights in dataset + logical l_newflt(maxflt) ! true if flight is new flight + +c Tail number statistics +c ---------------------- + character*8 creg_reg(maxflt) ! tail numbers + integer nobs_reg(maxflt,5) ! number of reports per tail number per type + +, ntot_reg(maxflt,5) ! total number of reports rejected per tail number + +, nrej_reg(maxflt,5) ! number of reports rejected per tail number + +, ntemp_reg(maxflt,5) ! number of reports with rejected temperature + +, nwind_reg(maxflt,5) ! number of reports with rejected wind + +, nwhol_reg(maxflt,5) ! number of reports with temperature in whole degrees + + character*10 creg_reg_tot(maxflt) ! master list of tail numbers + integer nobs_reg_tot(maxflt,5) ! number of reports per tail number + +, nwhol_reg_tot(maxflt,5) ! number of temperatures in whole degs/tail number + +, nrej_reg_tot(maxflt,5) ! number of reports rejected per tail number + +, ntemp_reg_tot(maxflt,5) ! number of temperatures rejected per tail number + +, nwind_reg_tot(maxflt,5) ! number of winds rejected per tail number + +, nrej_inv_tot(maxflt,5) ! number of reports rejected in subr. invalid + +, nrej_stk_tot(maxflt,5) ! number of reports rejected in subr. stkchek + +, nrej_grc_tot(maxflt,5) ! number of reports rejected in subr. grchek + +, nrej_pos_tot(maxflt,5) ! number of reports rejected in subr. poschek + +, nrej_ord_tot(maxflt,5) ! number of reports rejected in subr. ordchek + +, nrej_sus_tot(maxflt,5) ! number of reports rejected in suspect data check + + integer lead_t_tot(maxflt,11,2) ! distribution of temperature innovations + +, lead_d_tot(maxflt,11,2) ! distribution of wind direction innovations + +, lead_s_tot(maxflt,11,2) ! distribution of wind speed innovations + +, n_xiv_t(maxflt,2) ! number of temperature innovations + +, n_xiv_d(maxflt,2) ! number of wind direction innovations + +, n_xiv_s(maxflt,2) ! number of wind speed innovations + + real sum_xiv_t(maxflt,2) ! sum of temperature innovations + +, sum_xiv_d(maxflt,2) ! sum of wind direction innovations + +, sum_xiv_s(maxflt,2) ! sum of wind speed innovations + +, sumabs_xiv_t(maxflt,2) ! sum of absolute value of temperature innovations + +, sumabs_xiv_d(maxflt,2) ! sum of absolute value of wind dir. innovations + +, sumabs_xiv_s(maxflt,2) ! sum of absolute value of wind speed innovations + +c ************************************************** + +c Variables for sorting data by type, tail, flight, etc., including bad reports - will be +c used AFTER NRL QC code in the generation of profiles PREPBUFR-like profiles file +c --------------------------------------------------------------------------------------- + integer iob ! loop index + +, kidt ! idt + 100000 (converted to charcter c_idt and + ! added to csort_wbad sort key string) + +, iht_ft ! integer of ht_ft (converted to charcter c_ht_ft + ! and added to csort_wbad sort key string) + +, ilon ! integer of alon (converted to charcter c_lon + ! and added to csort_wbad sort key string) + +, ilat ! integer of alat (converted to charcter c_lat + ! and added to csort_wbad sort key string) + character*6 c_lon ! character form of ilon (added to csort_wbad + ! sort key string) + character*7 c_idt ! character form of kidt (added to csort_wbad + ! sort key string) + character*5 c_ht_ft ! character form of iht_ft (added to csort_wbad + ! sort key string) + +, c_lat ! character form of ilat (added to csort_wbad + ! sort key string) + character*4 c_type ! first 4 characters defining aircraft type + ! (added to csort_wbad sort key string) + character*1 c_qc11 ! value of 11th char in NRL c_qc string, + ! specifies whether report is part of an ascent, + ! descent, level leg, etc. (added to csort_wbad + ! sort key string) + character*16 c_insty_ob ! function - convers aircraft type to character + ! string ((added to csort_wbad sort key string) + character*40 csort_wbad(max_reps) ! variable (sort key) used to sort data after NRL + ! QC code - used in generation of profiles + ! PREPBUFR-like profiles file + integer indx_wbad(max_reps) ! sorted array index (specifies the order in + ! which reports should be written to the + ! PREPBUFR-like profiles file +c Namelist variables +c ------------------ + namelist /nrlacqcinput/ trad,l_otw,l_nhonly,l_doprofiles, + + l_allev_pf,l_prof1lvl,l_mandlvl,tsplines, + + l_ext_table,l_qmwrite + + real trad ! Time window radius for outputting reports (if l_otw=T) + logical l_otw ! T=eliminate reports outside the time window radius +/- trad + +, l_nhonly ! T=eliminate reports outside tropics & N. Hemisphere + +, l_doprofiles ! T=create merged raob lookalike QC'd profiles from aircraft + ! ascents and descents (always) and output these as well as + ! QC'd merged single(flight)-level aircraft reports not part + ! of any profile (when l_prof1lvl=T) to a PREPBUFR-like file + ! **CAUTION: Will make code take quite a bit longer to run! + ! F=skip creation of merged raob lookalike QC'd profiles from + ! aircraft ascents and descents into PREPBUFR-like file + +, l_allev_pf ! T=process latest (likely NRLACQC) events plus all prior + ! events into profiles PREPBUFR-like file + ! **CAUTION: More complete option, but will make code take + ! longer to run! + ! F=process ONLY latest (likely NRLACQC) events into profiles + ! PREPBUFR-like file + ! + ! Note 1: Hardwired to F if l_doprofiles=F + ! Note 2: All pre-existing events plus latest (likely NRLACQC) + ! events are always encoded into full PREPBUFR file) + +, l_prof1lvl ! T=encode merged single(flight)-level aircraft reports with + ! NRLACQC events that are not part of any profile into + ! PREPBUFR-like file, along with merged profiles from + ! aircraft ascents and descents + ! **CAUTION: Will make code take a bit longer to run! + ! F=do not encode merged single(flight)-level aircraft reports + ! with NRLACQC events that are not part of any profile into + ! PREPBUFR-like file - only merged profiles from aircraft + ! ascents and descents will be encoded into this file + ! Note : Applicable only when l_doprofiles=T + +, l_mandlvl ! T=interpolate to mandatory levels in profile generation + ! F=do not interpolate to mandatory levels in profile + ! generation + +, tsplines ! T=use tension-splines for aircraft vertical velocity + ! calculation + ! F=use finite-differencing for aircraft vertical velocity + ! calculation + ! Note : Applicable only when l_doprofiles=T + +, l_ext_table ! T=use external text table to define profile prepbufr format + ! F=take prepbufr format definition from input prepbufr file + +, l_qmwrite ! T=write NRL QMs in main prepbufr output file + ! F=omit NRL QMs from main prepbufr output file - use with old formats + +c Variables used to hold original aircraft data read from the input PREPBUFR file - necessary +c for carrying data through program so that it can be written to output profiles PREPBUFR- +c like file from memory instead of going back to input PREPBUFR file and re-reading that +c file before adding any QC events resulting from a decision made by the NRL QC routine (not +c applicable for case of single-level QC'd reports written back to full PREPBUFR file) +c -------------------------------------------------------------------------------------------- + integer mxnmev ! maximum number of events allowed in stack + parameter (mxnmev = 15) + + integer mxlv ! maximum number of report levels allowed in aircraft + ! profiles + parameter(mxlv = 255) + + + integer nevents(max_reps,6) ! array tracking number of events for variables for + ! each report: + ! 1 - number of pressure events + ! 2 - number of specific humidity events + ! 3 - number of temperature events + ! 4 - number of altitude events + ! 5 - number of wind (u/v) events + ! 6 - number of wind (direction/speed) events + integer nnestreps(4,max_reps) ! number of "nested replications" for TURB3SEQ, + ! PREWXSEQ, CLOUDSEQ, AFIC_SEQ + + real*8 pob_ev(max_reps,mxnmev) ! POB values for each report, including all events + +, pqm_ev(max_reps,mxnmev) ! PQM values for each report, including all events + +, ppc_ev(max_reps,mxnmev) ! PPC values for each report, including all events + +, prc_ev(max_reps,mxnmev) ! PRC values for each report, including all events + +, zob_ev(max_reps,mxnmev) ! ZOB values for each report, including all events + +, zqm_ev(max_reps,mxnmev) ! ZQM values for each report, including all events + +, zpc_ev(max_reps,mxnmev) ! ZPC values for each report, including all events + +, zrc_ev(max_reps,mxnmev) ! ZRC values for each report, including all events + +, tob_ev(max_reps,mxnmev) ! TOB values for each report, including all events + +, tqm_ev(max_reps,mxnmev) ! TQM values for each report, including all events + +, tpc_ev(max_reps,mxnmev) ! TPC values for each report, including all events + +, trc_ev(max_reps,mxnmev) ! TRC values for each report, including all events + +, qob_ev(max_reps,mxnmev) ! QOB values for each report, including all events + +, qqm_ev(max_reps,mxnmev) ! QQM values for each report, including all events + +, qpc_ev(max_reps,mxnmev) ! QPC values for each report, including all events + +, qrc_ev(max_reps,mxnmev) ! QRC values for each report, including all events + +, uob_ev(max_reps,mxnmev) ! UOB values for each report, including all events + +, vob_ev(max_reps,mxnmev) ! VOB values for each report, including all events + +, wqm_ev(max_reps,mxnmev) ! WQM values for each report, including all events + +, wpc_ev(max_reps,mxnmev) ! WPC values for each report, including all events + +, wrc_ev(max_reps,mxnmev) ! WRC values for each report, including all events + +, ddo_ev(max_reps,mxnmev) ! DDO values for each report, including all events + +, ffo_ev(max_reps,mxnmev) ! FFO values for each report, including all events + +, dfq_ev(max_reps,mxnmev) ! DFQ values for each report, including all events + +, dfp_ev(max_reps,mxnmev) ! DFP values for each report, including all events + +, dfr_ev(max_reps,mxnmev) ! DFR values for each report, including all events + + +, hdr(max_reps,15) ! SID XOB YOB DHR ELV TYP T29 TSB ITP SQN PROCN RPT + ! TCOR RSRD EXRSRD + +, acid(max_reps) ! ACID + +, rct(max_reps) ! RCT + + +, pbg(max_reps,3) ! POE PFC PFCMOD + +, zbg(max_reps,3) ! ZOE ZFC ZFCMOD + +, tbg(max_reps,3) ! TOE TFC TFCMOD + +, qbg(max_reps,3) ! QOE QFC QFCMOD + +, wbg(max_reps,5) ! WOE UFC VFC UFCMOD VFCMOD + + +, ppp(max_reps,3) ! PAN PCL PCS + +, zpp(max_reps,3) ! ZAN ZCL ZCS + +, tpp(max_reps,3) ! TAN TCL TCS + +, qpp(max_reps,3) ! QAN QCL QCS + +, wpp(max_reps,6) ! UAN VAN UCL VCL UCS VCS + + +, drinfo(max_reps,3) ! XOB YOB DHR + +, acft_seq(max_reps,2) ! PCAT POAF + + +, turb1seq(max_reps) ! TRBX + +, turb2seq(max_reps,4) ! TRBX10 TRBX21 TRBX32 TRBX43 + +, turb3seq(3,max_reps,5) ! DGOT HBOT HTOT + +, prewxseq(1,max_reps,5) ! PRWE + +, cloudseq(5,max_reps,5) ! VSSO CLAM CLTP HOCB HOCT + +, afic_seq(3,max_reps,5) ! AFIC HBOI HTOI + +, mstq(max_reps) ! MSTQ + +, cat(max_reps) ! CAT + +, rolf(max_reps) ! ROLF + + +, sqn(max_reps,2) ! SQN (1=SQN for mass, 2=SQN for wind) + +, procn(max_reps,2) ! PROCN (1=PROCN for mass, 2=PROCN for wind) + +cvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv +c add these in place of above declar. in event of future switch to dynamic memory allocation + +calloc character*11,allocatable :: c_qc(:) +calloc character*25,allocatable :: csort(:) +calloc integer,allocatable :: itype(:) +calloc real*8, allocatable :: alat(:) +calloc real*8, allocatable :: alon(:) +calloc real, allocatable :: pres(:) +calloc real, allocatable :: ht_ft(:) +calloc integer,allocatable :: idt(:) +calloc integer,allocatable :: idp(:) +calloc character*14,allocatable :: c_dtg(:) +calloc character*8, allocatable :: c_acftreg(:) +calloc character*9, allocatable :: c_acftid(:) +calloc real, allocatable :: t_prcn(:) +calloc real, allocatable :: ob_t(:) +calloc real, allocatable :: ob_q(:) +calloc real, allocatable :: ob_dir(:) +calloc real, allocatable :: ob_spd(:) +calloc real, allocatable :: xiv_t(:) +calloc real, allocatable :: xiv_q(:) +calloc real, allocatable :: xiv_d(:) +calloc real, allocatable :: xiv_s(:) +calloc integer,allocatable :: ichk_t(:) +calloc integer,allocatable :: ichk_q(:) +calloc integer,allocatable :: ichk_d(:) +calloc integer,allocatable :: ichk_s(:) +calloc integer,allocatable :: nchk_t(:) +calloc integer,allocatable :: nchk_q(:) +calloc integer,allocatable :: nchk_d(:) +calloc integer,allocatable :: nchk_s(:) +calloc integer,allocatable :: phase(:) +calloc logical,allocatable :: l_minus9c(:) +calloc integer,allocatable :: indx(:) +calloc integer,allocatable :: in_bad(:) +calloc integer,allocatable :: isave(:) +calloc character*40,allocatable :: csort_wbad(:) +calloc integer,allocatable :: indx_wbad(:) +calloc integer,allocatable :: nevents(:,:) +calloc integer,allocatable :: nnestreps(:,:) +calloc real*8,allocatable :: pob_ev(:,:) +calloc real*8,allocatable :: pqm_ev(:,:) +calloc real*8,allocatable :: ppc_ev(:,:) +calloc real*8,allocatable :: prc_ev(:,:) +calloc real*8,allocatable :: zob_ev(:,:) +calloc real*8,allocatable :: zqm_ev(:,:) +calloc real*8,allocatable :: zpc_ev(:,:) +calloc real*8,allocatable :: zrc_ev(:,:) +calloc real*8,allocatable :: tob_ev(:,:) +calloc real*8,allocatable :: tqm_ev(:,:) +calloc real*8,allocatable :: tpc_ev(:,:) +calloc real*8,allocatable :: trc_ev(:,:) +calloc real*8,allocatable :: qob_ev(:,:) +calloc real*8,allocatable :: qqm_ev(:,:) +calloc real*8,allocatable :: qpc_ev(:,:) +CAlloc real*8,allocatable :: qrc_ev(:,:) +calloc real*8,allocatable :: uob_ev(:,:) +calloc real*8,allocatable :: vob_ev(:,:) +calloc real*8,allocatable :: wqm_ev(:,:) +calloc real*8,allocatable :: wpc_ev(:,:) +calloc real*8,allocatable :: wrc_ev(:,:) +calloc real*8,allocatable :: ddo_ev(:,:) +calloc real*8,allocatable :: ffo_ev(:,:) +calloc real*8,allocatable :: dfq_ev(:,:) +calloc real*8,allocatable :: dfp_ev(:,:) +calloc real*8,allocatable :: dfr_ev(:,:) +calloc real*8,allocatable :: hdr(:,:) +calloc real*8,allocatable :: acid(:) +calloc real*8,allocatable :: rct(:) +calloc real*8,allocatable :: pbg(:,:) +calloc real*8,allocatable :: zbg(:,:) +calloc real*8,allocatable :: tbg(:,:) +calloc real*8,allocatable :: qbg(:,:) +calloc real*8,allocatable :: wbg(:,:) +calloc real*8,allocatable :: ppp(:,:) +calloc real*8,allocatable :: zpp(:,:) +calloc real*8,allocatable :: tpp(:,:) +calloc real*8,allocatable :: qpp(:,:) +calloc real*8,allocatable :: wpp(:,:) +calloc real*8,allocatable :: drinfo(:,:) +calloc real*8,allocatable :: acft_seq(:,:) +calloc real*8,allocatable :: turb1seq(:) +calloc real*8,allocatable :: turb2seq(:,:) +calloc real*8,allocatable :: turb3seq(:,:,:) +calloc real*8,allocatable :: prewxseq(:,:,:) +calloc real*8,allocatable :: cloudseq(:,:,:) +calloc real*8,allocatable :: afic_seq(:,:,:) +calloc real*8,allocatable :: mstq(:) +calloc real*8,allocatable :: cat(:) +calloc real*8,allocatable :: rolf(:) +calloc real*8,allocatable :: sqn(:,:) +calloc real*8,allocatable :: procn(:,:) + +c Variables for reading numeric data out of BUFR files via BUFRLIB +c ---------------------------------------------------------------- +calloc real*8 sqn_8 ! array holding BUFR subset sequence number from +calloc ! BUFRLIB call to input PREPBUFR file +calloc integer nlev ! number of report levels returned from BUFRLIB call +calloc Integer iret ! return code for call to BUFRLIB routine readns + +c Functions +c --------- +calloc integer ireadmg ! for reading messages +callo+, ireadsb ! for reading subsets + + +c Variables for BUFRLIB interface +c ------------------------------- +calloc character*8 mesgtype ! mesgtype of message +calloc integer mesgdate ! date time from BUFR message + +c Variables for determining whether consecutive reports are mass and wind pieces that belong +c together +c ------------------------------------------------------------------------------------------ +calloc logical l_match +calloc real sqn_current, sqn_next + +c^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +c Miscellaneous +c ------------- + real nrlacqc_pc ! PREPBUFR program code for the NRL PREPACQC step + + logical l_first_date ! true for first date (used inside NRL QC code) + data l_first_date /.true./ ! always initialize as T + + logical l_operational ! run program in operational mode if true + data l_operational /.true./ ! will get reset to F within acftobs_qc since + ! l_ncep=T; must be set to true here so that the + ! first l_operational=F section of the if block in + ! acftobs_qc.f will get skipped over + ! DAK: would code run faster if l_operational=F?, does it give + ! same answers I wonder ?? + logical l_pc ! true if running checkout at NRL (used inside NRL + ! QC code) + data l_pc /.false./ ! always set to F + logical l_last ! true if last time subroutine acftobs_qc is called + data l_last /.true./ ! DAK: I think this should be set to T + logical l_ncep ! run NRL QC code using NCEP preferences if true + data l_ncep /.true./ ! always set to T + +c Machine characteristics (obtained from W3FI04) +c ---------------------------------------------- + integer lwr ! machine word length in bytes (either 4 or 8) + +, ichtp ! machine charatcer type (either 0 for ASCII or 1 + ! for EBCDIC) + +, iendn ! machine Endian configuration (either 0 for Big- + ! Endian or 1 for Little-Endian) + +c ********************************************************************************** + +c Start program +c ------------- + call w3tagb('PREPOBS_PREPACQC',2016,344,1927,'NP22') + + write(*,*) + write(*,*) '************************************************' + write(*,*) 'Welcome to PREPOBS_PREPACQC, version 2016-12-09 ' + call system('date') + write(*,*) '************************************************' + write(*,*) + +C On WCOSS should always set BUFRLIB missing (BMISS) to 10E8 to avoid overflow when either an +C INTEGER*4 variable is set to BMISS or a REAL*8 (or REAL*4) variable that is missing is +C NINT'd +C ------------------------------------------------------------------------------------------- +ccccc call setbmiss(10E10_8) + call setbmiss(10E8_8) + bmiss = getbmiss() + print * + print *, 'BUFRLIB value for missing is: ',bmiss + print * + +c Initialize observation arrays +c ----------------------------- + c_qc = '-----------' + idp = imiss ! this is not created anywhere (even inside acftobs_qc) + +c Call W3FI04 to determine machine characteristics {word length (bytes), character type +c (ASCII or EBCDIC), and Endian-type (Big or Little)} +c ------------------------------------------------------------------------------------- + call w3fi04(iendn,ichtp,lwr) + print 2213, lwr, ichtp, iendn + 2213 format(/' ---> CALL TO W3FI04 RETURNS: LWR = ',I3,', ICHTP = ',i3, + + ', IENDN = ',I3/) + +c...................................................... + if(ichtp.ne.0) then + +C Characters on this machine are not ASCII!! -- stop 79 +c ----------------------------------------------------- + print 217 + 217 format(/5x,'++ CHARACTERS ON THIS MACHINE ARE NOT ASCII - STOP ', + + '79'/) + call w3tage('PREPOBS_PREPACQC') + call errexit(79) + endif +c...................................................... + +c Read in namelist nrlacqcinput, but set namelist defaults first +c -------------------------------------------------------------- + trad = 3.0 + l_otw = .false. + l_nhonly = .false. + l_doprofiles = .false. + l_allev_pf = .false. + l_prof1lvl = .false. + l_mandlvl = .true. + tsplines = .true. + l_ext_table = .false. + l_qmwrite = .true. + + read(5,nrlacqcinput,end=10) + 10 continue + write(6,nrlacqcinput) + + if(.not.l_doprofiles) l_allev_pf = .false. ! l_allev_pf always set to FALSE if profiles + ! are not being generated + + call datelen(10) + +c Open input PREPBUFR file (contains mass and wind reports for all data types, no NRLACQC +c events on reports in AIRCAR and AIRCFT message types) +c --------------------------------------------------------------------------------------- + call openbf(inlun,'IN',inlun) + print * + print'(" Opened input PREPBUFR file with all data, including ", + + "pre-NRLACQC aircraft data; unit number ",I0)', inlun + print * + +c Open output PREPBUFR file (will eventually be identical to input PREPBUFR file but with +c NRLACQC events on reports in AIRCAR and AIRCFT message types) +c --------------------------------------------------------------------------------------- + call openbf(outlun,'OUT',inlun) + print * + print'(" Opened output PREPBUFR file - will hold all data, ", + + "including post-NRLACQC aircraft data; unit number ",I0)', + + outlun + print * + + if(l_doprofiles) then + +c Open output PREPBUFR-like file (will eventually contain merged aircraft mass/wind data in +c AIRCAR and AIRCFT message types, including constructed profiles, with NRLACQC events on +c reports) +c ----------------------------------------------------------------------------------------- + if (l_ext_table) then + open(unit=extbl,form='formatted') + call openbf(proflun,'OUT',extbl) + close(extbl) + else + call openbf(proflun,'OUT',inlun) + end if + print * + print'(" Opened output PREPBUFR-like file - will hold only ", + + "post-NRLACQC merged aircraft profile data; unit ", + + "number ",I0)', proflun + print * + endif + +c Get the program code for NRLACQC +c -------------------------------- + if (.not. l_qmwrite ) then + nrlacqc_pc = 15 + else + call ufbqcd(outlun,'NRLACQC',nrlacqc_pc) + end if + + print * + print *, 'NRLACQC PROGRAM CODE IS: ', nrlacqc_pc + print * + +cvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv +c add this in event of future switch to dynamic memory allocation + +calloc CALL SYSTEM('date') +calloc max_reps = 0 +calloc l_match = .false. +calloc write(*,*) 'First time through just get count of number of ', +callo+ 'merged reports for dynamic array allocation' +calloc loop1: do while(ireadmg(inlun,mesgtype,mesgdate).eq.0) +calloc if((mesgtype.eq.'AIRCFT').or. +callo+ (mesgtype.eq.'AIRCAR')) then +calloc do while(ireadsb(inlun).eq.0) +c4051 continue +calloc l_match = .false. +calloc if(mesgtype.ne.'AIRCAR' .and. mesgtype.ne. 'AIRCFT') +callo+ cycle loop1 +c5051 continue +calloc max_reps = max_reps + 1 +calloc call ufbint(inlun,sqn_8,1,1,nlev,'SQN') +calloc sqn_current = sqn_8 +c6051 continue +calloc if(l_match) then +calloc call readns(inlun,mesgtype,mesgdate,iret) +calloc if(iret.eq.-1) then +calloc exit +calloc elseif(iret.eq.0) then +calloc go to 4051 +calloc else +calloc print *, 'Unexpected return code(iret=',iret, +callo+ ') from readns!' +calloc call w3tage('PREPOBS_PREPACQC') +calloc call errexit(23) ! Problems reading BUFR file +calloc endif +calloc endif +calloc call readns(inlun,mesgtype,mesgdate,iret) +calloc if(iret.eq.-1) then +calloc exit +calloc elseif(iret.eq.0) then +calloc if(mesgtype.ne.'AIRCAR' .and. mesgtype.ne. 'AIRCFT') +callo+ cycle loop1 +calloc call ufbint(inlun,sqn_8,1,1,nlev,'SQN') +calloc sqn_next = sqn_8 +calloc if(sqn_next.eq.sqn_current) then +calloc l_match = .true. +calloc go to 6051 +calloc else +calloc l_match = .false. +calloc go to 5051 +calloc endif +calloc else +calloc print *, 'Unexpected return code(iret=',iret, +callo+ ') from readns!' +calloc call w3tage('PREPOBS_PREPACQC') +calloc call errexit(23) ! Problems reading BUFR file +calloc endif +calloc enddo +calloc endif +calloc enddo loop1 +calloc write(*,*) +calloc write(*,*) 'TOTAL NUM OF RPTS IN FIRST READ THROUGH: ', +callo+ max_reps +calloc call closbf(inlun) +calloc call openbf(inlun,'IN',inlun) +calloc CALL SYSTEM('date') +calloc allocate(c_qc(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(csort(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(itype(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(alat(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(alon(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(pres(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(ht_ft(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(idt(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(idp(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(c_dtg(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(c_acftreg(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(c_acftid(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(t_prcn(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(ob_t(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(ob_q(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(ob_dir(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(ob_spd(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(xiv_t(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(xiv_q(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(xiv_d(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(xiv_s(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(ichk_t(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(ichk_q(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(ichk_d(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(ichk_s(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(nchk_t(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(nchk_q(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(nchk_d(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(nchk_s(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(phase(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(l_minus9c(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(indx(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(in_bad(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(isave(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(csort_wbad(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(indx_wbad(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(nevents(max_reps,6),stat=i);if(i.ne.0) go to 901 +calloc allocate(nnestreps(4,max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(pob_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(pqm_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(ppc_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(prc_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(zob_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(zqm_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(zpc_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(zrc_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(tob_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(tqm_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(tpc_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(trc_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(qob_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(qqm_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(qpc_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(qrc_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(uob_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(vob_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(wqm_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(wpc_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(wrc_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(ddo_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(ffo_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(dfq_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(dfp_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(dfr_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(hdr(max_reps,15),stat=i);if(i.ne.0) go to 901 +calloc allocate(acid(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(rct(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(pbg(max_reps,3),stat=i);if(i.ne.0) go to 901 +calloc allocate(zbg(max_reps,3),stat=i);if(i.ne.0) go to 901 +calloc allocate(tbg(max_reps,3),stat=i);if(i.ne.0) go to 901 +calloc allocate(qbg(max_reps,3),stat=i);if(i.ne.0) go to 901 +calloc allocate(wbg(max_reps,5),stat=i);if(i.ne.0) go to 901 +calloc allocate(ppp(max_reps,3),stat=i);if(i.ne.0) go to 901 +calloc allocate(zpp(max_reps,3),stat=i);if(i.ne.0) go to 901 +calloc allocate(tpp(max_reps,3),stat=i);if(i.ne.0) go to 901 +calloc allocate(qpp(max_reps,3),stat=i);if(i.ne.0) go to 901 +calloc allocate(wpp(max_reps,6),stat=i);if(i.ne.0) go to 901 +calloc allocate(drinfo(max_reps,3),stat=i);if(i.ne.0) go to 901 +calloc allocate(acft_seq(max_reps,2),stat=i);if(i.ne.0) go to 901 +calloc allocate(turb1seq(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(turb2seq(max_reps,4),stat=i);if(i.ne.0) go to 901 +calloc allocate(turb3seq(3,max_reps,5),stat=i);if(i.ne.0) go to 901 +calloc allocate(prewxseq(1,max_reps,5),stat=i);if(i.ne.0) go to 901 +calloc allocate(cloudseq(5,max_reps,5),stat=i);if(i.ne.0) go to 901 +calloc allocate(afic_seq(3,max_reps,5),stat=i);if(i.ne.0) go to 901 +calloc allocate(mstq(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(cat(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(rolf(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(sqn(max_reps,2),stat=i);if(i.ne.0) go to 901 +calloc allocate(procn(max_reps,2),stat=i);if(i.ne.0) go to 901 +c^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +c Call input routine input_acqc to read the input PREPBUFR file, merge the mass and wind +c pieces, translate some values to NRL standards and store in memory (arrays) +c -------------------------------------------------------------------------------------- + write(*,*) + write(*,*) 'Calling input_acqc....' + write(*,*) + + call input_acqc(inlun,max_reps,mxnmev,bmiss,imiss,amiss,m2ft,mxlv, + + nrpts4QC_pre,cdtg_an,alat,alon,ht_ft,idt,c_dtg, + + itype,phase,t_prcn,c_acftreg,c_acftid, + + pres,ob_t,ob_q,ob_dir,ob_spd, + + ichk_t,ichk_q,ichk_d,ichk_s, + + nchk_t,nchk_q,nchk_d,nchk_s, + + xiv_t,xiv_q,xiv_d,xiv_s,l_minus9C,nevents, + + hdr,acid,rct,drinfo,acft_seq,turb1seq,turb2seq, + + turb3seq,prewxseq,cloudseq,afic_seq,mstq,cat,rolf, + + nnestreps,sqn,procn, + + pob_ev,pqm_ev,ppc_ev,prc_ev,pbg,ppp, + + zob_ev,zqm_ev,zpc_ev,zrc_ev,zbg,zpp, + + tob_ev,tqm_ev,tpc_ev,trc_ev,tbg,tpp, + + qob_ev,qqm_ev,qpc_ev,qrc_ev,qbg,qpp, + + uob_ev,vob_ev,wqm_ev,wpc_ev,wrc_ev,wbg,wpp, + + ddo_ev,ffo_ev,dfq_ev,dfp_ev,dfr_ev,l_allev_pf) + +c Close input PREPBUFR file +c ------------------------- + call closbf(inlun) + print * + print'(" Closed input PREPBUFR file with all data, including ", + + "pre-NRLACQC aircraft data; unit number ",I0)', inlun + print * + + write(*,*) + write(*,*) 'Back from input_acqc....' + write(*,'(" There are ",I0," merged reports for acftobs_qc (NRL ", + + "aircraft data QC routine).")') nrpts4QC_pre + write(*,*) + + if(nrpts4QC_pre.gt.0) then + +c Now that we are done reading in data from the input PREPBUFR file, need to call acftobs_qc +c (actual NRL aircraft QC code) +c ------------------------------------------------------------------------------------------ + write(*,*) 'Passing ',nrpts4QC_pre,'obs to acftobs_qc.f...' + write(*,*) + write(*,*) 'Calling acftobs_qc...' + +c NRPTS4QC_PRE is returned from input_acqc and represents the original number of "merged" +c reports (mass and wind pieces put together) read in from the PREPBUFR file - we need to +c save this value now as it will be used later (e.g., to correctly match the QC decisions +c made by acftobs_qc to the reports originally in the input PREPBUFR file) - we will set +c NRPTS4qc to NRPTS4QC_PRE at this point and then pass NRPTS4QC into acftobs_qc - the value +c for NRPTS4Qc gets reduced in the various subroutines in acftobs_qc as it only represents +c the number of "good" reports coming out of each subroutine +c------------------------------------------------------------------------------------------- + nrpts4QC = nrpts4QC_pre + + call acftobs_qc(max_reps,cdtg_an,nrpts4QC,krej,c_acftreg,c_acftid, + + itype,idt,idp,alon,alat,pres,ht_ft,ob_t,ob_q, + + ob_dir,ob_spd,t_prcn,xiv_t,xiv_q,xiv_d,xiv_s, + + ichk_t,ichk_q,ichk_d,ichk_s,nchk_t,nchk_q,nchk_d, + + nchk_s,indx,isave,in_bad,c_qc,csort,maxflt, + + kflight,creg_flt,cid_flt,cid_flt_old,l_newflt, + + nobs_flt,iobs_flt,ntot_flt,nrej_flt,ntot_flt_old, + + nrej_flt_old,creg_reg,nobs_reg,ntot_reg,nrej_reg, + + ntemp_reg,nwind_reg,nwhol_reg,creg_reg_tot, + + nobs_reg_tot,nwhol_reg_tot,nrej_reg_tot, + + ntemp_reg_tot,nwind_reg_tot,nrej_inv_tot, + + nrej_stk_tot,nrej_grc_tot,nrej_pos_tot, + + nrej_ord_tot,nrej_sus_tot,lead_t_tot,lead_d_tot, + + lead_s_tot,n_xiv_t,n_xiv_d,n_xiv_s,sum_xiv_t, + + sum_xiv_d,sum_xiv_s,sumabs_xiv_t,sumabs_xiv_d, + + sumabs_xiv_s,l_minus9c,l_last,l_first_date, + + l_operational,l_pc,l_ncep,*99) + + go to 34 + +c----------------------------------- + 99 continue ! return 1 out of subr. acftobs_qc comes here - keep going but post message + print 153, maxflt,maxflt + 153 format(/' #####> WARNING: THERE ARE MORE THAN ',I6,' AIRCRAFT ', + + '"FLIGHTS" IN INPUT FILE -- MUST INCREASE SIZE OF PARAMETER ', + +'NAME "MAXFLT" - WILL CONTINUE ON PROCESSING ONLY ',I6,' FLTS-0'/) + write(cmaxflt,'(i6)') maxflt + call system('[ -n "$jlogfile" ] && $DATA/postmsg'// + + ' "$jlogfile" "***WARNING:'//cmaxflt//' AIRCRAFT "FLIGHT" '// + + 'LIMIT EXCEEDED IN PREPOBS_PREPACQC, ONLY '// + + cmaxflt//' FLIGHTS PROCESSED-0"') +c----------------------------------- + + 34 continue + + write(*,'(" After running acftobs_qc, there are ",I0," good ", + + "reports, ",I0," bad reports (total rpts = ",I0,")")') + + nrpts4QC,krej,nrpts4QC_pre + write(*,*) + write(*,*) + +c Sort reports (including bad ones) into profiles (sort logic and sort key construction +c borrowed from acftobs_qc) (note this is done even if l_doprofiles = FALSE because it +c is used in the final listing of single-level aircraft reports) +c ------------------------------------------------------------------------------------- + +c Initialize sort key and sort index +c ---------------------------------- + do i=1,max_reps + csort_wbad(i) = 'zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz' + indx_wbad(i) = i + enddo + +c Form variable to sort / sort key +c -------------------------------- + write(*,'(" Sorting reports and creating sort index, including ", + + "reports marked as bad....")') + + do iob=1,nrpts4QC_pre + + kidt = idt(iob) + 100000 + if(kidt.ge.1000000) then + write(*,*) + write(*,*) '** WARNING: kidt too large (=',kidt,')' + write(*,*) + write (*,8073) iob,c_insty_ob(itype(iob)),c_acftreg(iob), + + c_acftid(iob),idt(iob),alat(iob),alon(iob), + + pres(iob),ht_ft(iob),t_prcn(iob),ob_t(iob), + + xiv_t(iob),ichk_t(iob),ob_q(iob),xiv_q(iob), + + ichk_q(iob),ob_dir(iob),xiv_d(iob),ichk_d(iob), + + ob_spd(iob),xiv_s(iob),ichk_s(iob),idp(iob) + 8073 format(i5,1x,a8,1x,a8,1x,a9,1x,i7,1x,2f11.5,1x,f8.1,1x,f7.0,1x, + + f5.2,4(2(1x,f8.2),1x,i5),1x,i4) + write(*,*) + kidt = 999999 + endif + write(c_idt,'(i6)') kidt + + if(ht_ft(iob).eq.amiss) then + c_ht_ft = '99999' + else + iht_ft = nint(ht_ft(iob)) + if(iht_ft.ge.100000) then + write(*,*) + write(*,*) '** WARNING: iht_ft too large (=',iht_ft,')' + write (*,8073) iob,c_insty_ob(itype(iob)),c_acftreg(iob), + + c_acftid(iob),idt(iob),alat(iob),alon(iob), + + pres(iob),ht_ft(iob),t_prcn(iob),ob_t(iob), + + xiv_t(iob),ichk_t(iob),ob_q(iob),xiv_q(iob), + + ichk_q(iob),ob_dir(iob),xiv_d(iob), + + ichk_d(iob),ob_spd(iob),xiv_s(iob), + + ichk_s(iob),idp(iob) + write(*,*) + iht_ft = 99999 + endif + +c Make descents look like ascents for sorting purposes (complication comes in when a descent +c has two obs with the same time, but different altitudes) +c +c *** -> Need to make sure to reverse order upon writing to output in output_acqc_prof for +c descents - profile levels need to be ordered by decreasing pressure (for example, +c 1st lvl = 1010 mb, 2nd lvl = 987 mb, 3rd lvl = 764 mb, etc.) +c ----------------------------------------------------------------------------------------- + if(c_qc(iob)(11:11).eq.'d' .or. c_qc(iob)(11:11).eq.'D') + + iht_ft = 50000 + (-1)*iht_ft + + if(iht_ft.ge.0) then + write(c_ht_ft,'(i5.5)') iht_ft + else + write(c_ht_ft,'(i5.4)') iht_ft + endif + endif + +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alat(iob).eq.amiss) then + c_lat = '99999' + else + ilat = nint(alat(iob)*100.) + if(abs(ilat).ge.100000) then + write(*,*) + write(*,*) '** WARNING: ilat too large (=',ilat,')' + write (*,8073) iob,c_insty_ob(itype(iob)),c_acftreg(iob), + + c_acftid(iob),idt(iob),alat(iob),alon(iob), + + pres(iob),ht_ft(iob),t_prcn(iob),ob_t(iob), + + xiv_t(iob),ichk_t(iob),ob_q(iob),xiv_q(iob), + + ichk_q(iob),ob_dir(iob),xiv_d(iob), + + ichk_d(iob),ob_spd(iob),xiv_s(iob), + + ichk_s(iob),idp(iob) + write(*,*) + ilat = 99999 + endif + write(c_lat,'(i5)') ilat + endif + + if(alon(iob).eq.amiss) then + c_lon = '999999' + else + ilon = nint(alon(iob)*100.) + if(abs(ilon).ge.1000000) then + write(*,*) + write(*,*) '** WARNING: ilon too large (=',ilon,')' + write (*,8073) iob,c_insty_ob(itype(iob)),c_acftreg(iob), + + c_acftid(iob),idt(iob),alat(iob),alon(iob), + + pres(iob),ht_ft(iob),t_prcn(iob),ob_t(iob), + + xiv_t(iob),ichk_t(iob),ob_q(iob),xiv_q(iob), + + ichk_q(iob),ob_dir(iob),xiv_d(iob), + + ichk_d(iob),ob_spd(iob),xiv_s(iob), + + ichk_s(iob),idp(iob) + write(*,*) + ilon = 999999 + endif + write(c_lon,'(i6)') ilon + endif +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + + c_type = c_insty_ob(itype(iob)) + +c NRL sort key: +c ------------- +cc Option 1: not used +cc csort_wbad(iob) = c_idt(1:6) ! time +cc + //c_ht_ft(1:5) ! altitude +cc + //c_lat(1:5) ! latitude +cc + //c_lon(1:6) ! longitude +cc + //c_type(1:2) ! aircraft type + +cc Option 2: not used (tail number first) +cc csort_wbad(iob) = c_acftreg(iob)(1:7) ! tail number +cc + //c_acftid(iob)(1:7) ! flight number +cc + //c_idt(1:6) ! time +cc + //c_ht_ft(1:5) ! altitude +cc + //c_lat(1:5) ! latitude +cc + //c_type(1:2) ! aircraft type + +cc Option 3: not used (use type first to group AIRCFT and AIRCAR message types together) +cc csort_wbad(iob) = c_type(1:2) ! aircraft type +cc + //c_acftreg(iob)(1:7) ! tail number +cc + //c_acftid(iob)(1:7) ! flight number +cc + //c_idt(1:6) ! time +cc + //c_ht_ft(1:5) ! altitude +cc + //c_lat(1:5) ! latitude +cc + //c_lon(1:6) ! longitude + +c Option 4: not used +c Sort by altitude before time... want descents in order with an increasing vertical +c coordinate - but if you have two obs in a descent with the same time but different +c altitude, the altitudes will show up reversed -- use offset to get around this +c ----------------------------------------------------------------------------------- +c +c Option 5: USE THIS (sort by time then altitude that is adjusted for descents) +c ----------------------------------------------------------------------------- + if(c_qc(iob)(11:11).eq.'A') then ! change 'A' to 'a' + c_qc11 = 'a' + elseif(c_qc(iob)(11:11).eq.'D') then + c_qc11 = 'd' ! change 'D' to 'd' + else + c_qc11 = c_qc(iob)(11:11) + endif + +c Option 6: not used {sort by altitude first, then time... trust vertical coordinate more +c than position (many less bad marks in c_qc(5:5)'s vs c_qc(2:4))} +c --------------------------------------------------------------------------------------- + csort_wbad(iob) = c_type(1:2)//c_qc11 ! aircraft type + ascent/descent + + //c_acftreg(iob)(1:8) ! tail number + + //c_acftid(iob)(1:7) ! flight number +ccccc+ //c_ht_ft(1:5) +ccccc+ //c_idt(1:6) + + //c_idt(1:6) ! time + + //c_ht_ft(1:5) ! altitude +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + + //c_lat(1:5) ! latitude + + //c_lon(1:6) ! longitude +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + + enddo + +c Sort reports in file according to array csort_wbad +c -------------------------------------------------- + call indexc40(nrpts4QC_pre,csort_wbad,indx_wbad) + + if(l_doprofiles) then ! takes longer to run, because it outputs profiles in separate + ! PREPBUFR-like file + +c ---------------------------------------------------------------------------------- +c Translate NRL QC flags to NCEP events and add events to PREPBUFRlike profiles file +c ---------------------------------------------------------------------------------- + write(*,*) 'Calling output_acqc_prof....' + write(*,*) + + call output_acqc_prof(proflun,nrpts4QC_pre,max_reps,mxnmev,mxlv, + + bmiss,cdtg_an,alat,alon,ht_ft,idt,c_qc, + + trad,l_otw,l_nhonly,indx_wbad,c_acftreg, + + c_acftid,ob_t,nevents,hdr,acid,rct,drinfo, + + acft_seq,mstq,cat, + + pob_ev,pqm_ev,ppc_ev,prc_ev,pbg,ppp, + + zob_ev,zqm_ev,zpc_ev,zrc_ev,zbg,zpp, + + tob_ev,tqm_ev,tpc_ev,trc_ev,tbg,tpp, + + qob_ev,qqm_ev,qpc_ev,qrc_ev,qbg,qpp, + + uob_ev,vob_ev,wqm_ev,wpc_ev,wrc_ev, + + wbg,wpp, + + ddo_ev,ffo_ev,dfq_ev,dfp_ev,dfr_ev, + + nrlacqc_pc,l_allev_pf,l_prof1lvl, + + l_mandlvl,tsplines, + + l_operational,lwr) + + write(*,*) + write(*,*) + write(*,*) 'Back from output_acqc_prof ....' + write(*,'(" PREPBUFR-like (profiles) file has been updated ", + + "with events representing the QC marks applied by ", + + "the NRLACQC routine acftobs_qc.")') + write(*,*) + write(*,*) + +c Close output PREPBUFR-like (profiles) file +c ------------------------------------------ + call closbf(proflun) ! closbf will take care of flushing last message + print * + print'(" Closed output PREPBUFR-like file - now holds post-", + + "NRLACQC merged aircraft profile data; unit number ", + + I0)', proflun + print * + endif + +c ---------------------------------------------------------------------- +c Always output single-level QC'd aircraft data in regular PREPBUFR file +C ---------------------------------------------------------------------- + +c Re-open input PREPBUFR file (contains mass and wind reports for all data types, no NRLACQC +c events on reports in AIRCAR and AIRCFT message types) +c ------------------------------------------------------------------------------------------ + call openbf(inlun,'IN',inlun) + print * + print'(" Again opened input PREPBUFR file with all data, ", + + "including pre-NRLACQC aircraft data; unit number ",I0)', + + inlun + print * + + +C Initialize some variables that will be set in output_acqc_noprof and used in printout +c ------------------------------------------------------------------------------------- + ncep_qm_p = 9999 + ncep_rc_p = 9999 + ncep_qm_z = 9999 + ncep_rc_z = 9999 + ncep_qm_t = 9999 + ncep_rc_t = 9999 + ncep_qm_q = 9999 + ncep_rc_q = 9999 + ncep_qm_w = 9999 + ncep_rc_w = 9999 + ncep_rej = 0 + +c Translate NRL QC flags to NCEP events and add events to aircraft reports in "AIRCAR" and +c "AIRCFT" message types in full PREPBUFR file (split mass and wind pieces) +c ---------------------------------------------------------------------------------------- + call output_acqc_noprof(inlun,outlun,nrpts4QC_pre,max_reps,bmiss, + + alat,alon,ht_ft,idt,c_qc,trad,l_otw, + + l_nhonly,l_qmwrite, + + ncep_qm_p,ncep_rc_p, + + ncep_qm_z,ncep_rc_z, + + ncep_qm_t,ncep_rc_t, + + ncep_qm_q,ncep_rc_q, + + ncep_qm_w,ncep_rc_w, + + ncep_rej,nrlacqc_pc) + + write(*,*) + write(*,*) + write(*,*) 'Back from output_acqc_noprof ....' + write(*,'(" PREPBUFR file has been updated with events ", + + "representing the QC marks applied by the NRL aircraft", + + " QC routine acftobs_qc")') + write(*,*) + write(*,*) + +c Close input PREPBUFR file +c ------------------------- + call closbf(inlun) + print * + print'(" Closed input PREPBUFR file with all data, including ", + + "pre-NRLACQC aircraft data; unit number ",I0)', inlun + print * + +c Close output PREPBUFR file +c -------------------------- + call closbf(outlun) ! closbf will take care of flushing last message + print * + print'(" Closed output PREPBUFR file - now holds all data, ", + + "including post-NRLACQC aircraft data; unit number ",I0)', + + outlun + print * + + if(.not.l_operational) then + +c Write merged reports and resulting NRL QC decisions (array c_qc) to an output file for +c later perusal +c -------------------------------------------------------------------------------------- + + open(51,file='merged.reports.post_acftobs_qc.sorted',form= + + 'formatted') + write(51,*) + write(51,'(" Final listing of all aircraft reports in PREPBUFR", + + " file after NRL QC (sorted according to array ", + + "csort_wbad)")') + if(nrpts4QC_pre.eq.max_reps) write(51,'(" (since max report ", + + "limit hit, only reports going through QC listed here)")') + write(51,'(" -------------------------------------------------", + + "--------------------------------------------------", + + "-------")') + write(51,*) + write(51,'(" TAMDAR reports here replace characters 1-3 of ", + + "manufactured flight # (''000'') with (''TAM'') in ", + + "order to create truncated tail # ''TAM'' for ", + + "NRLACQC sorting - the PREPBUFR file continues to ", + + "encode ''000'' in")') + write(51,'(" characters 1-3 of manufactured flight # for ", + + "TAMDAR (stored as both ''SID'' and ''ACID'')")') + + write(51,*) + write(51,'(" AIREP and PIREP reports report only a flight # ", + + "(manufactured for PIREPs) - a tail # for NRLACQC ", + + "sorting is created by truncating the flight # - ", + + "the PREPBUFR file will not encode these truncated ", + + "tail #''s")') + + write(51,*) + write(51,'(" All AMDAR reports except LATAM report only a tail", + + " # - this is stored as both flight # and tail # for", + + " NRLACQC sorting - the PREPBUFR file continues to ", + + "encode only tail # (stored in ''SID'')")') + write(51,*) + write(51,'(" AMDAR reports from LATAM report both a tail # and", + + " a flight # - these are used as reported for ", + + "NRLACQC sorting - the PREPBUFR file continues to ", + + "encode both tail # and flight # (as ''SID'' and ", + + "''ACID'',")') + write(51,*) 'resp.)' + write(51,*) + write(51,'(" MDCRS reports from ARINC report both a tail # and", + + " a flight # - these are used as reported for ", + + "NRLACQC sorting - the PREPBUFR file continues to ", + + "encode both tail # and flight # (as ''SID'' and ", + + "''ACID'',")') + write(51,*) 'resp.)' + + write(51,*) + write(51,3001) + 3001 format(173x,'! _PREPBUFR_QMs_!NRLACQC_REASON_CODE'/' index ', + + 'flight tail num itp ph lat lon ', + + 'time hght pres temp/chk spec_h/chk wspd/chk ', + + 'wdir/chk t-prec !__qc_flag__!_______________', + + 'csort_wbad_______________! Pq Zq Tq Qq Wq!Prc Zrc Trc ', + + 'Qrc Wrc'/'------ --------- -------- --- -- ', + + '-------- --------- ------ ----- ------ --------- ', + + '---------- --------- -------- ------ !-----------!', + + '----------------------------------------! -- -- -- ', + + '-- --!--- --- --- --- ---') + + do i=1,nrpts4QC_pre + j=indx_wbad(i) + + if(ncep_rej(j).eq.0) then + write(51,fmt=8001) j,c_acftid(j),c_acftreg(j),itype(j), + + phase(j),alat(j),alon(j),idt(j),nint(ht_ft(j)),pres(j), + + ob_t(j),ichk_t(j),ob_q(j),ichk_q(j),ob_spd(j),ichk_s(j), + + nint(ob_dir(j)),ichk_d(j),t_prcn(j),c_qc(j),csort_wbad(j), + + ncep_qm_p(j),ncep_qm_z(j),ncep_qm_t(j),ncep_qm_q(j), + + ncep_qm_w(j),ncep_rc_p(j),ncep_rc_z(j),ncep_rc_t(j), + + ncep_rc_q(j),ncep_rc_w(j) +c if(ncep_rc_p(j).ge.1000) write(51,fmt=9001) ncep_rc_p(j) +c9001 format(' PRC too large = ',i10) +c if(ncep_rc_z(j).ge.1000) write(51,fmt=9002) ncep_rc_z(j) +c9002 format(' ZRC too large = ',i10) +c if(ncep_rc_t(j).ge.1000) write(51,fmt=9003) ncep_rc_t(j) +c9003 format(' TRC too large = ',i10) +c if(ncep_rc_q(j).ge.1000) write(51,fmt=9004) ncep_rc_q(j) +c9004 format(' QRC too large = ',i10) +c if(ncep_rc_w(j).ge.1000) write(51,fmt=9005) ncep_rc_w(j) +c9005 format(' WRC too large = ',i10) + endif + enddo + + 8001 format(i6,1x,a9,1x,a8,i4,1x,i2,2f10.5,1x,i6,1x,i5,1x,f6.1,1x, + + f6.2,i3,1x,f7.2,i3,1x,f6.1,i3,2x,i4,i3,1x,f6.2,1x, + + '!',a11,'!',a40,'!',5(1x,i2.2),'!',i3.3,4(1x,i3.3)) + +c Close data listing file +c ----------------------- + close(51) + + endif + +c End program +c ----------- + + write(*,*) + write(*,*) '**************************' + write(*,*) 'PREPOBS_PREPACQC has ended' + call system('date') + write(*,*) '**************************' + write(*,*) + call w3tage('PREPOBS_PREPACQC') + + else ! nrpts4QC_pre.le.0 + +c Input PREPBUFR file contains NO aircraft data of any kind -- STOP 4 +c ------------------------------------------------------------------- + + WRITE(6,108) + 108 FORMAT(/' INPUT PREPBUFR FILE CONTAINS NO "AIRCAR" OR "AIRCFT" ', + $ 'MESSAGES WITH REPORTS - STOP 4'/) + CALL ERREXIT(4) + + endif ! nrpts4QC_pre.gt.0 + + stop + +cvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv +c add this event of future switch to dynamic memory allocation + +ca901 continue + +calloc print *, '#####PREPOBS_PREPACQC - UNABLE TO ALLOCATE ARRAYS' +calloc call w3tage('PREPOBS_PREPACQC') +calloc call errexit(99) +c^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + + end diff --git a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/prepobs_landc b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/prepobs_landc deleted file mode 100644 index 4b847c55d75e67413fc009ef6a32a0dc8d7bb8f7..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 285020 zcmeI43zFp~5=A?DWApal4b8H=5HDziYi@KF1qcv-9Yv@!f&3ow$>W#~|N8y=?_U|u zfByUH*D7yDx!anA7>Ak(+4*}RKlUIngMdGqBiA$fotbka+q+ydIrPe%>e9cyBnRgW1(mXSn zw90+gb1F~FH|4__1ZEJ3&1#SR8U4-9*@I)Nn6ueD&7Z^JE=MfJoge2A7)c;Dr#<#Z z_BAtC4|cs`&gAqow`JmD*|qeX9I~}C#}69_j3QuXv!_0)pQm|33|vgRuN>Ob+PBmB z>eALfQWuw2ITcT`G_L%d3_Uszov{ajo&+>|Ev2hh@p{(YGPde{qio5sB$im0_{3}# zOEPAc+Q0MFxsyB)7)ij+-cx;K-7RxH?fV4(mON9j#LC%NJ>_$ErZ`Uad`9Kz*#oin zAfQ=u)k<$A_aN}S%2vIf5a&CY_Ny49rGfov-uD+`*CMBlYvb8{>Gr%tf9hY73)}Y*h|QPVw~y>ZzSUeo94KE3ZQ z#IHq88&~n{p0CTML@Gv!54I4`o*9SWYgb3JKO6eirH}0hvop|Q%xTLSvGm)FSByVoam|boz>!0g`9RwT!&5qTz zCn-{H&GVChIGrxld2OHaeD%V!aCX+W#1Gqd60q}Pf8WkO&t12Qlbdgbo!{eWYcXxvmtvO6 zCpGxFTEwz3{P?UPkW0YMQB04;^6g`GcHjEg{gZXu^NG5Yz&P1!+e!f<56~~Xy z8UnclG($0Y7svXww7rY9%em!qs_yQhM{l`z+#`3-n7Msn2LTbdn@8EzN8?p9Sl@|NWhsgVPwg zUTsgQ-Z?v$fM!4)YJDeVkE|zf$9UIsN91Ykp%|9*)A+mkTL$RwAfQ=Qw_4{&`5>PW z$YK2^8%y&|ec$zJxuCy`fSV0HcXQ&O%db}2+_f=I@$=d4ymoi;r2eP=PjavBd&<1i zM;-w?kF~#xyi8#$k^w= zS2qkUoz>o-tyKG=J)MQ5v$y-!-|Dgn?dc5pon=oR_8z4B`Lu7PZ=*_pqBB zPiozacXwwicebUEjUV!jo!k8$x~-*0{2gOjCemYl=sYH^U(AO6{sinj?5OuAv`2>A zyK~(*+tj02F&qC}Yf1TO-AgKulf8267}s)<9_mA9chdUa*>c{8fW3nq^*&Vgi<*0P zt~1%jy41Oo{u4U0d(xes^qx}n^~`Z9b_2zF9Txlvn&xQvIZCIO|71{7;hoXssRj$sL9|yNl<1?riM2&0+VY+jHqU zi%Hoz8M9$O&BiiBUz5O!Gwev&x-2=npVF<*Tl5r<(lf^_=94;$`MCX(ClyC$il;R) zerKg@#MYO79RHkk9|Au271plPoH|l=eQ2#6HHX=3n;e2UHQG2i_Soe8rYtARSh_uT zI?osaKKB*Yu5(+5NN6tXSxT3mjc4~x)O{Z6(cho7Ry|JI8nkcsQo8K@I4K{_zBA9^ zVL4mY{yyuz1aj_bw2eAeUag(fUa1WE+PH7fOPTeu7i$|ov}eylx_qn**|AsuyK(Gz z)*!I@9E(z~Iu-wP*^3`>pM3{+;HTe)YSkJ!hJd)wl&MZz*OkiU&O-U_d{#dX^~7HI zuHh2rVt*g2&-`iitu&WD+m^NYvF-XUkG0)Nzw3+h_%{hQKiRn1w_JAmE$m#YWxk5; z&qC|EV)qrw6SLiAKhzU@-@i5RsOPcE?_k$D-#D8&cO@=4wmaCUA1C$P?b&nm`fu19 z*lDJ6q|9cpg{60c+QR4pwTgOOGh}Uj=qk2)EU1ZHY#(JxXg%988l6i{R zj^1~3yTYS7PWT;(XYXE=XE&M4#r37RXwhSCUhMYzmbaJ<&06g4Tjh8f$JX~WR*k>S zzq_vfd-kCmJIY)xrM<=C`f*}*?C$}>Y)^!(u)$`iETl7<#dlx^;D5qv?U!p5^i4V4CeydyG zt7fa0boIKYwC<44zk&Y$M{V5FI!4&rzDo7n`V`l<*M6;R9j~^ImVSOuxog#sYmZ&| zcj4{KG-EyF+u7#y|AhNp{3o$vzNwrspI!D-y`|37U&@9vzRf*nKr>h>d)9Pf>{7nY zKE}bu@@?!{iSEaVtxICAXdCN`{rJ4WWAqiRo$`;Jh2n(v zV*Weshx%hLf1Y7AhE?m|7Wek--u(Nh<>|*stw-bt<0jT^Gdi665G#S87l{9Epa^7h@)f1&W(N> z%t4j;ytnT^X{;I z(r=D$DTADt*!257uEMr-Ze%~BewTYj-j+F2J&3JjZeH2v%G|iU>~iazZCBg>$hvE5 z#BZN(NvnD4ap$Vd#ZEn;+|FKpv2(=?o$t7(esbgr{pHlTl1+-)N_E;=QZ;kd?>lYp zU}Zfv1G8(6)pf#t3EP$WEvfrWw*DQ}^zO%a<2uCc35QTT_Sz75axW|TKB2N&KTmo& z**Eu|av0>sI?XPJ4L0i#IAQ);(Oi*5tKLqHle)83J*RT4bk?e0;;cs?XU@*Ja)1H8xpW5g) z#uNQ6|C87&``-24^1OsY%e<$@y5o9!|Mb_FfSs>YCTllRS4|^xj?SeXN63=iM%1%w zjuMW}mIneO2$arcD|_|UD&C55)Z++Q(*KBhcF0k}Otw4pMUC$xp!q~T|NABHo1V2h z4$bu16;mAq$_a$#oV~p7c{y!7AOHafloQ~aocB!*aVn>c2LvDhf%XJK-=|)Ce)YZb zoed8JAOHafKmY;|fB*y_009U<00Izz00bZa0SG_<0uX=z z1Rwwb2tWV=5P$##eh~Qm`|n@B{`x2P@1S5;|99G92Rmkf8DIvO0cL<1U?OpV!Me%#YCgvIhbjMEeK%j;IGgLzj9|%AI0uY!@fPa3?zJa~- zYkv0b;=X$R9pRo)jfLh%vL*&T?&RTGp6%I)nryz9ZtIYZ-Rr3kcML-3J?ahRN$sfy*=Rjd zDz}x&uRX0#lmg)(e$Ii5GWypW`J=@m34E@Q?tSu|R*WkQ4+J0p0SGiC@VR2yxAt4D7*{wR2tWV= z5O_%7^M8LQLvPKuT5+zBJP?2Y1R(H$z~}Ok00bZafiD7|ORV&MRmGnWfB*y_;0SyceO+xl5P$##-b~SIaxU@4GQNh5!WKMBsBZd&2vsJEKhIlupD9%T)fNu~AOL|Q2z;(Cc6jZ#+UYqpU#;;#00I!$ zp1|koV29WLPTO@({a2ej5P$##wj}Vms@~zX-{lo2)then + e=exp(x)-u1 +else + p=x; e=p + do i=2,19; p=p*x/i; e=e+p; if(abs(p)<=abs(e*eps))return; enddo +endif +end function expm + +!============================================================================= +function expmm(x) result(e)! [expmm] +!============================================================================= +! exp(x)-1-x (approximately x^2/2 for small x) +! = I^(2)exp(x), where I^(p) is the integral iterated p times +real(dp),intent(in ):: x +real(dp) :: e +!----------------------------------------------------------------------------- +real(dp):: p +integer :: i +!============================================================================= +if(abs(x)>o2)then + e=exp(x)-u1-x +else + p=x*x*o2; e=p + do i=3,25; p=p*x/i; e=e+p; if(abs(p)<=abs(e*eps))return; enddo +endif +end function expmm + +!============================================================================= +function coshm(x) result(c)! [coshm] +!============================================================================= +! cosh(x)-1 (approximately x**2/2 for small x) +! =I^(2)cosh(x), where I^(p) is the integral iterated p times +real(dp),intent(in ):: x +real(dp) :: c +!----------------------------------------------------------------------------- +c=2*sinh(x*o2)**2 +end function coshm + +!============================================================================= +function sinhm(x) result(s)! [sinhm] +!============================================================================= +! sinh(x)-x (approximately x**3/6 for small x) +! =I^(3)cosh(x), where I^(p) is the integral iterated p times +real(dp),intent(in ):: x +real(dp) :: s +!----------------------------------------------------------------------------- +real(dp):: p,xx +integer :: i +!============================================================================= +if(abs(x)>o2)then + s=sinh(x)-x +else + p=x**3/6; s=p; xx=x*x + do i=5,19,2; p=p*xx/(i*(i-1)); s=s+p; if(abs(p)<=abs(s*eps))return; enddo +endif +end function sinhm + +!============================================================================= +function coshmm(x) result(c)! [coshmm] +!============================================================================= +! cosh(x)-1-x^2/2 (approximately x**4/24 for small x) +! =I^(4)cosh(x), where I^(p) is the integral iterated p times +real(dp),intent(in ):: x +real(dp) :: c +!----------------------------------------------------------------------------- +real(dp) :: xh +!============================================================================= +xh=x*o2 +c=sinhm(xh)*(2*sinh(xh)+x) +end function coshmm + +!============================================================================= +function xcms(x) result(e)! [xcms] +!============================================================================= +real(dp),intent(in ):: x +real(dp) :: e +!----------------------------------------------------------------------------- +real(dp):: p,xx +integer :: i,i2 +!============================================================================= +! x*coshm(x)-sinhm(x) (approximately x**3/3 for small x) +if(abs(x)>o2)then + e=x*coshm(x)-sinhm(x) +else + p=x**3/3; e=p; xx=x*x + do i=2,15 + i2=i*2; p=p*xx/(i2*(i2+1)); e=e+i*p; if(abs(p)<=abs(e*eps))return + enddo +endif +end function xcms + +!============================================================================== +function enbase_t(tspan,hspan)result(r)! [enbase_t] +!============================================================================== +! For a nondimensional time span, tspan, but a dimensional height +! span, hspan, return the baseline minimum possible tensioned spline +! energy integrated over the central span plus the two wings. +! If the hspan vanishes, return a nominal unit energy. +! The energy is quadratic in hspan, which can therefore be of either sign, +! but tspan must be strictly positive for a meaningful positive energy. +!============================================================================== +real(dp),intent(in ):: tspan,hspan +real(dp) :: r +!============================================================================= +if(tspangate)then + write(41,*) 'WARNING! In tbnewton; i,it,dt/gate = ',i,it,dt/gate + exit + endif + if(abs(dh)nit) + if(FF)then + write(41,'("In tbnewton; Newton iterations seem not to be")') + write(41,'("converging at i=",i3)'),i + write(41,'("tee,he,hac,heps,dhadt:",5(1x,e11.4))'),tee,he,hac,heps,dhadt + endif + te(i) = tee +enddo +end subroutine tbnewton + +!============================================================================= +subroutine ubnewton(nh,m,halfgate,hgts,hs,hgtp,p,q, te,dhdt,FF)! [bnewton] +!============================================================================= +! Like tbnewton, but for the case of untensioned (i.e., cubic) splines +!============================================================================= +integer, intent(in ):: nh,m +real(dp), intent(in ):: halfgate +integer, dimension(nh),intent(in ):: hgts +real(dp),dimension(nh),intent(in ):: hs +integer, dimension(m), intent(in ):: hgtp +real(dp),dimension(m) ,intent(in ):: p,q +real(dp),dimension(nh),intent(out):: dhdt, te +logical, intent(out):: FF +!----------------------------------------------------------------------------- +integer,parameter :: nit=12 +real(dp),dimension(m):: tr +real(dp) :: gate,tee,he,hac,dhadt,dh,dt +integer :: i,it +!============================================================================= +gate=2*halfgate +tr=hgtp*halfgate +do i=1,nh + tee=hgts(i)*halfgate + he=hs(i) +! Use Newton iterations to estimate the rescaled time, tee, at which the +! height is he + it = 1 + do while (it <= nit) + call eval_uspline(m,tr,p,q, tee,hac,dhadt) + if(it==1)dhdt(i)=dhadt + if(dhadt==u0)exit + dh=hac-he + dt=-dh/dhadt + if(abs(dt)>gate)then + write(41,*) 'WARNING! In ubnewton; i,it,dt/gate = ',i,it,dt/gate + exit + endif + if(abs(dh)nit) + if(FF)then + write(41,'("In ubnewton; Newton iterations seem not to be")') + write(41,'("converging at i=",i3)'),i + write(41,'("tee,he,hac,heps,dhadt:",5(1x,e11.4))'),tee,he,hac,heps,dhadt + endif + te(i) = tee +enddo +end subroutine ubnewton + +!============================================================================ +subroutine fit_gtspline(n,xs,ys,on,q,j,yac,en,FF)! [fit_tspline] +!============================================================================ +! Fit the gappy tensioned spline, where only those nodes flagged "on" +! are effective in the fitting procedure. Owing to the fact that, where +! constraints are not "on" the spline will generally depart from ys, the +! actual y (yac) is returned for all nodes, regardless of the partial +! duplication with the given ys. In other respects, this is just +! like fit_tspline. +!============================================================================ +integer, intent(in ):: n +real(dp),dimension(n),intent(in ):: xs,ys +logical, dimension(n),intent(in ):: on +real(dp),dimension(n),intent(out):: q,j,yac +real(dp), intent(out):: en +logical, intent(out):: FF +!---------------------------------------------------------------------------- +real(dp),dimension(n):: xa,ya,qa,ja +integer :: i,k,m +!============================================================================ +m=0 +do i=1,n + if(on(i))then; m=m+1; xa(m)=xs(i); ya(m)=ys(i); endif +enddo +call fit_tspline(m,xa(1:m),ya(1:m),qa(1:m),ja(1:m),en,FF) +if(FF)then + write(41,*) 'In fit_gtspline; failure flag raised at call to fit_tspline' + return +endif +k=0 +do i=1,n + if(on(i))then + k=k+1 + q(i)=qa(k) + j(i)=ja(k) + yac(i)=ys(i) + else + call eval_tsplined(m,xa(1:m),ya(1:m),qa(1:m),xs(i), yac(i),q(i)) + j(i)=0 + endif +enddo +end subroutine fit_gtspline + +!============================================================================ +subroutine fit_tspline(n,xs,p,q,j,en,FF)! [fit_tspline] +!============================================================================ +! Solve for the coefficients, the 3rd-derivative jumps, and the energy, +! of the standardized tensioned spline passing through the n nodes at (xs,p). +! +! The value and successive derivatives on the immediate positive side of +! each node, xs(i), are to be found as p(i), q(i), r(i), s(i), with j(i) +! being the discontinuity of 3rd-derivative s between the negative and positive +! side of the node (value itself, and other derivatives, remaining continuous). +! In addition, p(0), q(0), r(0) and s(0) are the value and derivatives on the +! immediate negative side of xs(1). The spline solution minimizes elastic +! and tensional energy, en, defined as the integral dx of half the sum of the +! squared first and second derivatives over the whole line. Euler-Lagrange +! implies the solution is expressible in each segment between or beyond nodes: +! y(x') = p + q*x' + r*coshm(x') + s*sinhm(x') +! where x' = x-xs(i) is the local coordinate relative to the relevant node +! (the node at the left of the segent except that, implicitly, we take +! xs(0)===xs(1), and the two functions, coshm and sinhm, are defined: +! coshm(x) = cosh(x)-1 +! sinhm(x) = sinh(x)-x. +! The solution in segment 0, i.e., x< xs(1), must exponentially decay towards +! a constant as x--> -infinity, while that for segment n must likewise decay +! as x--> +infinity, in order that energy remains finite. Thus, q(0)=r(0)=s(0) +! and q(n)=-r(n)=s(n) always. Solutions in these infinite end segments are +! therefore expressible in terms only of p(0),q(0) for segment 0 and in terms +! only of p(n), q(n) for segment n and is linear in these coefficients. +! Between consecutive nodes (segments 0=xs(i)) then + FF=T + write(41,*) 'In fit_tspline; xs data must increase strictly monotonically' + return + end if +enddo +! Initialize tri-diagonal kernels for the energy definition: +qq=0 ! <- initialize symmetric tridiagonal, kernel for q^T*QQ*q + ! where "q" are the dp/dx at each node. +! The coefficients in the quadratic form defining the spline energy also +! include terms involving factors (p(ip)-p(i))*(q(i)+q(ip)) and +! (p(ip)-p(i))*(p(ip)-p(i)), but these can be dealt with using, respectively, +! the matrices cqp and cpp which are simply diagonal. It is the symmetries +! in the defiition of energy that allow this simplification. + +! Loop over the intervals bounded by consecutive nodes: +do i=1,n-1 + ip=i+1 + difp(i)=p(ip)-p(i) + x=(xs(ip)-xs(i))*o2 ! Halfwidth of interval + ch=cosh(x); sh=sinh(x) + xcmsx2=xcms(x)*2 +! egg relates to the odd-g-basis function's energy integral coefficient +! ehh relates to the even-g-basis function's energy integral coefficient + egg=x*sh/xcmsx2; ehh=ch/(2*sh) +! ccc is the coefficient of energy integral coupling g(i)*g(i) and g(ip)*g(ip) + ccc=egg+ehh + cpp(i)=ch/xcmsx2 ! Energy coefficient for difp(i)*difp(i)... + cqp(i)=-difp(i)*sh/xcmsx2 ! ..and for difp(i)*sumq(i) + qq(i,0)=qq(i,0)+ccc; qq(ip,-1)=qq(ip,-1)+egg-ehh; qq(ip,0)=qq(ip,0)+ccc +enddo +! Add the exterior energy contributions to qq at both ends: +qq(1,0)=qq(1,0)+1 +qq(n,0)=qq(n,0)+1 + +! Temporarily, q is made the vector of forcings in the tridiagonal linear +! system from which the final spline coefficients, q, are solved in place. +q(1:n-1)=-cqp; q(n)=0 +q(2:n)=q(2:n)-cqp + +! The following 2 lines solve the tridiagonal system for q: +call ldltb(n,1,qq) ! <- Decompose qq into factors, L*(1/D)*L^T, L=lower +call ltdlbv(n,1,qq,q) ! <- Back-substitute, thus solving for q +sumq=q(1:n-1)+q(2:n) ! <-pairwise sums of derivatives, q: + +! The minimizing energy can now be evaluated as a sum of only 2 terms: +en=o2*(dot_product(difp**2,cpp)+dot_product(sumq,cqp)) + +! Finally, evaluate the 3rd-derivative "jumps", j, at each node: +! Here, sb is the 3rd-derivative at the right end, sa that at the left end, +! of whichever interval is under consideration, but for interior intervals, +! sa = sap+q(i) and sb=sap+q(i+1). +sb=q(1) +do i=1,n-1 + ip=i+1 + x=o2*(xs(ip)-xs(i)) + xcmsx2=xcms(x)*2 + ch=cosh(x); sh=sinh(x) + sap=(sh*sumq(i)-ch*difp(i))/xcmsx2 + sa=sap+q(i) + j(i)=sa-sb + sb =sap+q(ip) +enddo +j(n)=q(n)-sb ! Final "sa" is just q(n) for the right exterior +end subroutine fit_tspline + +!============================================================================= +subroutine int_tspline(n,xs,p,q, m)! [int_tspline] +!============================================================================= +! Take the sets of n parameters p and q of the tensioned spline +! and return the values of its integral at the n-1 interval midpoints, and +! the value at the last node, assuming that the integral at the first node +! is set to zero. +!============================================================================= +integer, intent(in ):: n +real(dp),dimension(n),intent(in ):: xs,p,q +real(dp),dimension(n),intent(out):: m +!----------------------------------------------------------------------------- +real(dp):: a,b,c,d,e,t2,x,pa,pd,qa,qd,shx,chmx,shmx,chmmx,xcmsx +integer :: i,ip +!============================================================================= +! e is the running integral as we loop over successive nodes, so it starts out +! zero at the first node: +e=u0 +! Loop over intervals: +do i=1,n-1 + ip=i+1 + x=(xs(ip)-xs(i))*o2 !<- interval half-width + t2=x*x*o2 + shx =sinh (x) + chmx =coshm (x) + shmx =sinhm (x) + chmmx=coshmm(x) + xcmsx=xcms (x) + pa=(p(ip)+p(i))*o2 + pd=(p(ip)-p(i))*o2/x + qa=(q(ip)+q(i))*o2 + qd=(q(ip)-q(i))*o2/shx +! a,b,c,d are analogous to the Taylor coefficients of a cubic about the +! interval midpoint, but more precisely, c and d relate to basis functions +! coshm and sinhm (instead of x**2/2 and x**3/6 for the perfect cubic). + c=qd + a=pa-c*chmx + d=(qa-pd)*x/xcmsx + b=qa-d*chmx + m(i)=e+a*x -b*t2 +c*shmx -d*chmmx + e=e+2*(a*x+c*shmx) +enddo +m(n)=e +end subroutine int_tspline + +!============================================================================ +subroutine fit_guspline(n,xs,ys,on,q,j,yac,en,FF)! [fit_uspline] +!============================================================================ +! Fit the gappy untensioned spline, where only those nodes flagged "on" +! are effective in the fitting procedure. Owing to the fact that, where +! constraints are not "on" the spline will generally depart from ys, the +! actual y (yac) is returned for all nodes, regardless of the partial +! duplication with the given ys. In other respects, this is just +! like fit_tspline. +!============================================================================ +integer, intent(in ):: n +real(dp),dimension(n),intent(in ):: xs,ys +logical, dimension(n),intent(in ):: on +real(dp),dimension(n),intent(out):: q,j,yac +real(dp), intent(out):: en +logical, intent(out):: FF +!---------------------------------------------------------------------------- +real(dp),dimension(n):: xa,ya,qa,ja +integer :: i,k,m +!============================================================================ +m=0 +do i=1,n + if(on(i))then; m=m+1; xa(m)=xs(i); ya(m)=ys(i); endif +enddo +call fit_uspline(m,xa(1:m),ya(1:m),qa(1:m),ja(1:m),en,FF) +if(FF)then + write(41,*) 'In fit_guspline; failure flag raised at call to fit_uspline' + return +endif +k=0 +do i=1,n + if(on(i))then + k=k+1 + q(i)=qa(k) + j(i)=ja(k) + yac(i)=ys(i) + else + call eval_usplined(m,xa(1:m),ya(1:m),qa(1:m),xs(i), yac(i),q(i)) + j(i)=0 + endif +enddo +end subroutine fit_guspline + +!============================================================================= +subroutine fit_uspline(n,xs,p,q,j,en,FF)! [fit_uspline] +!============================================================================= +! Solve for the coefficients, the 3rd-derivative jumps, and the energy, +! of the untensioned (cubic) spline passing through the n nodes at (xs,p). +! +! The algorithm follows the pattern given in fit_tspline, except that the +! hyperbolic functions are all replaced by their asymptotic (x--> 0) limiting +! forms. These limiting forms are as follows: +! cosh(x) --> 1 +! sinh(x) --> x +! coshm(x) --> x**2/2 +! sinhm(x) --> x**3/6 +! xcms(x) --> x**3/3 +!============================================================================= +use pietc, only: o3 +use pmat2, only: ldltb, ltdlbv +integer, intent(in ):: n +real(dp),dimension( n),intent(in ):: xs,p +real(dp),dimension( n),intent(out):: q,j +real(dp), intent(out):: en +logical, intent(out):: FF +!---------------------------------------------------------------------------- +integer :: i,ip +real(dp) :: x,x2,sa,sb,ccc,xcmsx2 +real(dp),dimension(n-1) :: difp,sumq,cpp,cqp +real(dp),dimension(n,-1:0):: qq ! <- Tridiagonal, stored as rows of nonupper +!============================================================================= +FF=F +if(n<1)stop 'In fit_uspline; size of data array must be positive' +if(n==1)then; q=0; j=0; en=0; return; endif +! apply a strict monotonicity check on the xs: +do i=2,n + if(xs(i-1)>=xs(i)) then + FF=T + write(41,*) 'In fit_uspline; xs data must increase strictly monotonically' + return + end if +enddo +! Initialize tri-diagonal kernels for the energy definition: +qq=0 ! <- initialize symmetric tridiagonal, kernel for q^T*QQ*q + ! where "q" are the dp/dx at each node. +! The coefficients in the quadratic form defining the spline energy also +! include terms involving factors (p(ip)-p(i))*(q(i)+q(ip)) and +! (p(ip)-p(i))*(p(ip)-p(i)), but these can be dealt with using, respectively, +! the matrices cqp and cpp which are simply diagonal. It is the symmetries +! in the defiition of energy that allow this simplification. + +! Loop over the intervals bounded by consecutive nodes: +do i=1,n-1 + ip=i+1 + difp(i)=p(ip)-p(i) + x2=xs(ip)-xs(i); x=o2*x2! Width, and halfwidth of interval + xcmsx2=o3*x**3*2 + +! ccc is the coefficient of energy integral coupling g(i)*g(i) and g(ip)*g(ip) + ccc=2/x + cpp(i)=u1/xcmsx2 ! Energy coefficient for difp(i)*difp(i)... + cqp(i)=-difp(i)*x/xcmsx2 ! ..and for difp(i)*sumq(i) + qq(i,0)=qq(i,0)+ccc; qq(ip,-1)=qq(ip,-1)+1/x; qq(ip,0)=qq(ip,0)+ccc +enddo +! There is NO exterior energy contributions to qq at both ends: + +! Temporarily, q is made the vector of forcings in the tridiagonal linear +! system from which the final spline coefficients, q, are solved in place. +q(1:n-1)=-cqp; q(n)=0 +q(2:n)=q(2:n)-cqp + +! The following 2 lines solve the tridiagonal system for q: +call ldltb(n,1,qq) ! <- Decompose qq into factors, L*(1/D)*L^T, L=lower +call ltdlbv(n,1,qq,q) ! <- Back-substitute, thus solving for q +sumq=q(1:n-1)+q(2:n) ! <-pairwise sums of derivatives, q: + +! The minimizing energy can now be evaluated as a sum of only 2 terms: +en=o2*(dot_product(difp**2,cpp)+dot_product(sumq,cqp)) + +! Finally, evaluate the 3rd-derivative "jumps", j, at each node: +! Here, sb and sa are the 3rd-derivatives in consecutive intervals +sb=0 +do i=1,n-1 + ip=i+1 + x=o2*(xs(ip)-xs(i)) + xcmsx2=o3*x**3*2 + sa=(x*sumq(i)-difp(i))/xcmsx2 + j(i)=sa-sb + sb =sa +enddo +j(n)=-sb ! Final "sa" is just 0 for the right exterior +end subroutine fit_uspline + +!============================================================================= +subroutine int_uspline(n,xs,p,q, m)! [int_uspline] +!============================================================================= +! Take the sets of n parameters p and q of the untensioned cubic spline +! and return the values of its integral at the n-1 interval midpoints, and +! the value at the last node, assuming that the integral at the first node +! is set to zero. +!============================================================================= +integer, intent(in ):: n +real(dp),dimension(n),intent(in ):: xs,p,q +real(dp),dimension(n),intent(out):: m +!----------------------------------------------------------------------------- +real(dp),parameter:: u3o2=3*o2 +real(dp):: a,b,c,d,e,t2,t3,t4,x,pa,pd,qa,qd +integer :: i,ip +!============================================================================= +! e is the running integral as we loop over successive nodes, so it starts out +! zero at the first node: +e=u0 +! Loop over intervals: +do i=1,n-1 + ip=i+1 + x=(xs(ip)-xs(i))*o2 !<- interval half-width + t2=x*x/2 + t3=t2*x/3 + t4=t3*x/4 + pa=(p(ip)+p(i))*o2 + pd=(p(ip)-p(i))*o2/x + qa=(q(ip)+q(i))*o2 + qd=(q(ip)-q(i))*o2/x +! a,b,c,d are the Taylor coefficients of the cubic about the interval midpoint: + c=qd + a=pa-c*t2 + d=(qa-pd)*u3o2/t2 + b=qa-d*t2 + m(i)=e+a*x-b*t2+c*t3-d*t4 + e=e+2*(a*x+c*t3) +enddo +m(n)=e +end subroutine int_uspline + +!============================================================================= +subroutine eval_tspline(n,xs,p,q, x,y)! [eval_tspline] +!============================================================================= +! Assuming the 1st derivatives, q, are correctly given at the n nodes, xs, +! of the standardized tensioned spline, where p are the nodal values, +! evaluate the spline function y at the location x. +! First find the nonvanishing interval in which x resides, then expand +! y using basis functions implied by the interval-end values of p and q +! using the interval midpoint as local origin when x is interior, or the +! single interval endpoint when it is exterior. +!============================================================================= +integer, intent(in ):: n +real(dp),dimension(n),intent(in ):: xs,p,q +real(dp), intent(in ):: x +real(dp), intent(out):: y +!---------------------------------------------------------------------------- +integer :: ia,ib +real(dp):: xr,xh,pm,qm,qah,qbh,qxh,qdh,shh,chh,sh,ch,xcmsh,shm,chm,shhm,chhm +!============================================================================ +if(x<=xs(1))then; xr=x-xs(1); y=p(1)+q(1)*expm( xr); return; endif +if(x>=xs(n))then; xr=x-xs(n); y=p(n)-q(n)*expm(-xr); return; endif +do ib=2,n + if(xs(ib)<=xs(ib-1))cycle ! <- only consider intervals of positive width + if(xs(ib)>=x)exit ! <- exit once finite interval straddling x is found +enddo +ia=ib-1 +xh=(xs(ib)-xs(ia))*o2 ! <- halfwidth of interval +xr=x-xs(ia)-xh ! <- x relative to interval midpoint +pm=(p(ia)+p(ib))*o2 ! average of end values +qm=(p(ib)-p(ia))/(xh*2) ! average gradient +qah=q(ia)*o2; qbh=q(ib)*o2 +qxh=qah+qbh-qm ! Half the total excess q at interval ends +qdh=qbh-qah ! Half the difference of q at interval ends +shh=sinh(xh); chh=cosh(xh) +sh =sinh(xr); ch=cosh(xr) +shm=sinhm(xr); chm=coshm(xr) +shhm=sinhm(xh); chhm=coshm(xh) +xcmsh=xcms(xh) +qdh=qdh/shh; qxh=qxh/xcmsh ! <- rescale qdh, qxh +y=pm+xr*qm +qdh*(chm-chhm) + qxh*(xh*shm-xr*shhm) +end subroutine eval_tspline + +!============================================================================= +subroutine eval_tsplined(n,xs,p,q, x,y,dydx)! [eval_tspline] +!============================================================================= +! Like eval_tspline, but also return the derivative dy/dx +!============================================================================= +integer, intent(in ):: n +real(dp),dimension(n),intent(in ):: xs,p,q +real(dp), intent(in ):: x +real(dp), intent(out):: y,dydx +!---------------------------------------------------------------------------- +integer :: ia,ib +real(dp):: xr,xh,pm,qm,qah,qbh,qxh,qdh,shh,chh,sh,ch,xcmsh,shm,chm,shhm,chhm,& + qemxr +!============================================================================ +if(x<=xs(1))then + xr=x-xs(1); qemxr=q(1)*expm( xr); y=p(1)+qemxr; dydx=qemxr+q(1); return +endif +if(x>=xs(n))then + xr=x-xs(n); qemxr=q(n)*expm(-xr); y=p(n)-qemxr; dydx=qemxr+q(n); return +endif +do ib=2,n + if(xs(ib)<=xs(ib-1))cycle ! <- only consider intervals of positive width + if(xs(ib)>=x)exit ! <- exit once finite interval straddling x is found +enddo +ia=ib-1 +xh=(xs(ib)-xs(ia))*o2 ! <- halfwidth of interval +xr=x-xs(ia)-xh ! <- x relative to interval midpoint +pm=(p(ia)+p(ib))*o2 ! average of end values +qm=(p(ib)-p(ia))/(xh*2) ! average gradient +qah=q(ia)*o2; qbh=q(ib)*o2 +qxh=qah+qbh-qm ! Half the total excess q at interval ends +qdh=qbh-qah ! Half the difference of q at interval ends +shh=sinh(xh); chh=cosh(xh) +sh =sinh(xr); ch=cosh(xr) +shm=sinhm(xr); chm=coshm(xr) +shhm=sinhm(xh); chhm=coshm(xh) +xcmsh=xcms(xh) +qdh=qdh/shh; qxh=qxh/xcmsh ! <- rescale qdh, qxh +y=pm+xr*qm +qdh*(chm-chhm) + qxh*(xh*shm-xr*shhm) +dydx=qm+qdh*sh +qxh*(xh*chm-shhm) +end subroutine eval_tsplined + +!============================================================================= +subroutine eval_tsplinedd(n,xs,p,q, x,y,dydx,ddydxx)! [eval_tspline] +!============================================================================= +! Like eval_tspline, but also return the derivative dy/dx +!============================================================================= +integer, intent(in ):: n +real(dp),dimension(n),intent(in ):: xs,p,q +real(dp), intent(in ):: x +real(dp), intent(out):: y,dydx,ddydxx +!---------------------------------------------------------------------------- +integer :: ia,ib +real(dp):: xr,xh,pm,qm,qah,qbh,qxh,qdh,shh,chh,sh,ch,xcmsh,shm,chm,shhm,chhm,& + qemxr +!============================================================================ +if(x<=xs(1))then + xr=x-xs(1); qemxr=q(1)*expm( xr); y=p(1)+qemxr; dydx=qemxr+q(1) + ddydxx=dydx; return +endif +if(x>=xs(n))then + xr=x-xs(n); qemxr=q(n)*expm(-xr); y=p(n)-qemxr; dydx=qemxr+q(n) + ddydxx=-dydx; return +endif +do ib=2,n + if(xs(ib)<=xs(ib-1))cycle ! <- only consider intervals of positive width + if(xs(ib)>=x)exit ! <- exit once finite interval straddling x is found +enddo +ia=ib-1 +xh=(xs(ib)-xs(ia))*o2 ! <- halfwidth of interval +xr=x-xs(ia)-xh ! <- x relative to interval midpoint +pm=(p(ia)+p(ib))*o2 ! average of end values +qm=(p(ib)-p(ia))/(xh*2) ! average gradient +qah=q(ia)*o2; qbh=q(ib)*o2 +qxh=qah+qbh-qm ! Half the total excess q at interval ends +qdh=qbh-qah ! Half the difference of q at interval ends +shh=sinh(xh); chh=cosh(xh) +sh =sinh(xr); ch=cosh(xr) +shm=sinhm(xr); chm=coshm(xr) +shhm=sinhm(xh); chhm=coshm(xh) +xcmsh=xcms(xh) +qdh=qdh/shh; qxh=qxh/xcmsh ! <- rescale qdh, qxh +y=pm+xr*qm +qdh*(chm-chhm) + qxh*(xh*shm-xr*shhm) +dydx=qm+qdh*sh +qxh*(xh*chm-shhm) +ddydxx=qdh*ch +qxh*xh*sh +end subroutine eval_tsplinedd + +!============================================================================= +subroutine eval_tsplineddd(n,xs,p,q, x,y,dydx,ddydxx,dddydxxx)! [eval_tspline] +!============================================================================= +! Like eval_tspline, but also return the derivative dy/dx +!============================================================================= +integer, intent(in ):: n +real(dp),dimension(n),intent(in ):: xs,p,q +real(dp), intent(in ):: x +real(dp), intent(out):: y,dydx,ddydxx,dddydxxx +!---------------------------------------------------------------------------- +integer :: ia,ib +real(dp):: xr,xh,pm,qm,qah,qbh,qxh,qdh,shh,chh,sh,ch,xcmsh,shm,chm,shhm,chhm,& + qemxr +!============================================================================ +if(x<=xs(1))then + xr=x-xs(1); qemxr=q(1)*expm( xr); y=p(1)+qemxr; dydx=qemxr+q(1) + ddydxx=dydx; dddydxxx=dydx; return +endif +if(x>=xs(n))then + xr=x-xs(n); qemxr=q(n)*expm(-xr); y=p(n)-qemxr; dydx=qemxr+q(n) + ddydxx=-dydx; dddydxxx=dydx; return +endif +do ib=2,n + if(xs(ib)<=xs(ib-1))cycle ! <- only consider intervals of positive width + if(xs(ib)>=x)exit ! <- exit once finite interval straddling x is found +enddo +ia=ib-1 +xh=(xs(ib)-xs(ia))*o2 ! <- halfwidth of interval +xr=x-xs(ia)-xh ! <- x relative to interval midpoint +pm=(p(ia)+p(ib))*o2 ! average of end values +qm=(p(ib)-p(ia))/(xh*2) ! average gradient +qah=q(ia)*o2; qbh=q(ib)*o2 +qxh=qah+qbh-qm ! Half the total excess q at interval ends +qdh=qbh-qah ! Half the difference of q at interval ends +shh=sinh(xh); chh=cosh(xh) +sh =sinh(xr); ch=cosh(xr) +shm=sinhm(xr); chm=coshm(xr) +shhm=sinhm(xh); chhm=coshm(xh) +xcmsh=xcms(xh) +qdh=qdh/shh; qxh=qxh/xcmsh ! <- rescale qdh, qxh +y =pm+xr*qm +qdh*(chm-chhm) + qxh*(xh*shm-xr*shhm) +dydx = qm +qdh*sh + qxh*(xh*chm- shhm) +ddydxx = qdh*ch + qxh* xh*sh +dddydxxx= qdh*sh + qxh* xh*ch +end subroutine eval_tsplineddd + +!============================================================================= +subroutine eval_itspline(n,xs, p,q,m, x,y)! [eval_itspline] +!============================================================================= +! Evaluate the integrated tension spline at x, returning the value, y. +!============================================================================= +integer, intent(in ):: n +real(dp),dimension(n),intent(in ):: xs,p,q,m +real(dp), intent(in ):: x +real(dp), intent(out):: y +!----------------------------------------------------------------------------- +real(dp):: a,b,c,d,t2,xh,shx,chmx,shmx,chmmx,xcmsx,xr,pa,pd,qa,qd +integer :: ia,ib +!============================================================================= +if(x<=xs(1))then; xr=x-xs(1); y= p(1)*xr+q(1)*expmm( xr); return; endif +if(x>=xs(n))then; xr=x-xs(n); y=m(n)+p(n)*xr+q(n)*expmm(-xr); return; endif +do ib=2,n + if(xs(ib)<=xs(ib-1))cycle ! <- only consider intervals of positive width + if(xs(ib)>=x)exit ! <- exit once finite interval straddling x is found +enddo +ia=ib-1 +xh=(xs(ib)-xs(ia))*o2 ! <- halfwidth of interval +shx =sinh (xh) +chmx=coshm(xh) +xcmsx=xcms(xh) +xr=x-xs(ia)-xh ! <- x relative to interval midpoint +pa=(p(ib)+p(ia))*o2 +pd=(p(ib)-p(ia))*o2/xh +qa=(q(ib)+q(ia))*o2 +qd=(q(ib)-q(ia))*o2/shx +! a,b,c,d are analogous to the Taylor coefficients about the interval midpoint +c=qd +a=pa-c*chmx +d=(qa-pd)*xh/xcmsx +b=qa-d*chmx + +t2=xr**2/2 +shmx =sinhm (xr) +chmmx=coshmm(xr) +y=m(ia)+a*xr+b*t2+c*shmx+d*chmmx +end subroutine eval_itspline + +!============================================================================= +subroutine eval_uspline(n,xs,p,q, x,y)! [eval_uspline] +!============================================================================= +! Assuming the 1st derivatives, q, are correctly given at the n nodes, xs, +! of the standardized untensioned spline, where p are the nodal values, +! evaluate the (UNtensioned) spline function y at the location x. +! First find the nonvanishing interval in which x resides, then expand +! y using basis functions implied by the interval-end values of p and q +! using the interval midpoint as local origin when x is interior, or the +! single interval endpoint when it is exterior. +!============================================================================= +integer, intent(in ):: n +real(dp),dimension(n),intent(in ):: xs,p,q +real(dp), intent(in ):: x +real(dp), intent(out):: y +!---------------------------------------------------------------------------- +integer :: ia,ib +real(dp):: xr,xh,pm,qm,qah,qbh,qxh,qdh,shh,chh,sh,ch,xcmsh,shm,chm,shhm,chhm +!============================================================================ +if(x<=xs(1))then; xr=x-xs(1); y=p(1)+q(1)*xr; return; endif +if(x>=xs(n))then; xr=x-xs(n); y=p(n)+q(n)*xr; return; endif +do ib=2,n + if(xs(ib)<=xs(ib-1))cycle ! <- only consider intervals of positive width + if(xs(ib)>=x)exit ! <- exit once finite interval straddling x is found +enddo +ia=ib-1 +xh=(xs(ib)-xs(ia))*o2 ! <- halfwidth of interval +xr=x-xs(ia)-xh ! <- x relative to interval midpoint +pm=(p(ia)+p(ib))*o2 ! average of end values +qm=(p(ib)-p(ia))/(xh*2) ! average gradient +qah=q(ia)*o2; qbh=q(ib)*o2 +qxh=qah+qbh-qm ! Half the total excess q at interval ends +qdh=qbh-qah ! Half the difference of q at interval ends +shh=xh; chh=u1 +sh =xr; ch =u1 +shm =xr**3/6; chm =xr**2*o2 +shhm=xh**3/6; chhm=xh**2*o2 +xcmsh=xh**3/3 +qdh=qdh/shh; qxh=qxh/xcmsh ! <- rescale qdh, qxh +y=pm+xr*qm +qdh*(chm-chhm) + qxh*(xh*shm-xr*shhm) + +end subroutine eval_uspline + +!============================================================================= +subroutine eval_usplined(n,xs,p,q, x,y,dydx)! [eval_uspline] +!============================================================================= +! Like eval_uspline, but also return the derivative dy/dx +!============================================================================= +integer, intent(in ):: n +real(dp),dimension(n),intent(in ):: xs,p,q +real(dp), intent(in ):: x +real(dp), intent(out):: y,dydx +!---------------------------------------------------------------------------- +integer :: ia,ib +real(dp):: xr,xh,pm,qm,qah,qbh,qxh,qdh,shh,chh,sh,ch,xcmsh,shm,chm,shhm,chhm +!============================================================================ +if(x<=xs(1))then; xr=x-xs(1); y=p(1)+q(1)*xr; dydx=q(1); return; endif +if(x>=xs(n))then; xr=x-xs(n); y=p(n)+q(n)*xr; dydx=q(n); return; endif +do ib=2,n + if(xs(ib)<=xs(ib-1))cycle ! <- only consider intervals of positive width + if(xs(ib)>=x)exit ! <- exit once finite interval straddling x is found +enddo +ia=ib-1 +xh=(xs(ib)-xs(ia))*o2 ! <- halfwidth of interval +xr=x-xs(ia)-xh ! <- x relative to interval midpoint +pm=(p(ia)+p(ib))*o2 ! average of end values +qm=(p(ib)-p(ia))/(xh*2) ! average gradient +qah=q(ia)*o2; qbh=q(ib)*o2 +qxh=qah+qbh-qm ! Half the total excess q at interval ends +qdh=qbh-qah ! Half the difference of q at interval ends +shh=xh; chh=u1 +sh =xr; ch =u1 +shm =xr**3/6; chm =xr**2*o2 +shhm=xh**3/6; chhm=xh**2*o2 +xcmsh=xh**3/3 +qdh=qdh/shh; qxh=qxh/xcmsh ! <- rescale qdh, qxh +y=pm+xr*qm +qdh*(chm-chhm) + qxh*(xh*shm-xr*shhm) +dydx=qm+qdh*sh +qxh*(xh*chm-shhm) +end subroutine eval_usplined + +!============================================================================= +subroutine eval_usplinedd(n,xs,p,q, x,y,dydx,ddydxx)! [eval_uspline] +!============================================================================= +! Like eval_uspline, but also return the derivative dy/dx +!============================================================================= +integer, intent(in ):: n +real(dp),dimension(n),intent(in ):: xs,p,q +real(dp), intent(in ):: x +real(dp), intent(out):: y,dydx,ddydxx +!---------------------------------------------------------------------------- +integer :: ia,ib +real(dp):: xr,xh,pm,qm,qah,qbh,qxh,qdh,shh,chh,sh,ch,xcmsh,shm,chm,shhm,chhm +!============================================================================ +if(x<=xs(1))then; xr=x-xs(1); y=p(1)+q(1)*xr; dydx=q(1); return; endif +if(x>=xs(n))then; xr=x-xs(n); y=p(n)+q(n)*xr; dydx=q(n); return; endif +do ib=2,n + if(xs(ib)<=xs(ib-1))cycle ! <- only consider intervals of positive width + if(xs(ib)>=x)exit ! <- exit once finite interval straddling x is found +enddo +ia=ib-1 +xh=(xs(ib)-xs(ia))*o2 ! <- halfwidth of interval +xr=x-xs(ia)-xh ! <- x relative to interval midpoint +pm=(p(ia)+p(ib))*o2 ! average of end values +qm=(p(ib)-p(ia))/(xh*2) ! average gradient +qah=q(ia)*o2; qbh=q(ib)*o2 +qxh=qah+qbh-qm ! Half the total excess q at interval ends +qdh=qbh-qah ! Half the difference of q at interval ends +shh=xh; chh=u1 +sh =xr; ch =u1 +shm =xr**3/6; chm =xr**2*o2 +shhm=xh**3/6; chhm=xh**2*o2 +xcmsh=xh**3/3 +qdh=qdh/shh; qxh=qxh/xcmsh ! <- rescale qdh, qxh +y=pm+xr*qm +qdh*(chm-chhm) + qxh*(xh*shm-xr*shhm) +dydx=qm+qdh*sh +qxh*(xh*chm-shhm) +ddydxx=qdh +qxh*xh*sh +end subroutine eval_usplinedd + +!============================================================================= +subroutine eval_usplineddd(n,xs,p,q, x,y,dydx,ddydxx,dddydxxx)! [eval_uspline] +!============================================================================= +! Like eval_uspline, but also return the derivative dy/dx +!============================================================================= +integer, intent(in ):: n +real(dp),dimension(n),intent(in ):: xs,p,q +real(dp), intent(in ):: x +real(dp), intent(out):: y,dydx,ddydxx,dddydxxx +!---------------------------------------------------------------------------- +integer :: ia,ib +real(dp):: xr,xh,pm,qm,qah,qbh,qxh,qdh,shh,chh,sh,ch,xcmsh,shm,chm,shhm,chhm +!============================================================================ +if(x<=xs(1))then; xr=x-xs(1); y=p(1)+q(1)*xr; dydx=q(1); return; endif +if(x>=xs(n))then; xr=x-xs(n); y=p(n)+q(n)*xr; dydx=q(n); return; endif +do ib=2,n + if(xs(ib)<=xs(ib-1))cycle ! <- only consider intervals of positive width + if(xs(ib)>=x)exit ! <- exit once finite interval straddling x is found +enddo +ia=ib-1 +xh=(xs(ib)-xs(ia))*o2 ! <- halfwidth of interval +xr=x-xs(ia)-xh ! <- x relative to interval midpoint +pm=(p(ia)+p(ib))*o2 ! average of end values +qm=(p(ib)-p(ia))/(xh*2) ! average gradient +qah=q(ia)*o2; qbh=q(ib)*o2 +qxh=qah+qbh-qm ! Half the total excess q at interval ends +qdh=qbh-qah ! Half the difference of q at interval ends +shh=xh; chh=u1 +sh =xr; ch =u1 +shm =xr**3/6; chm =xr**2*o2 +shhm=xh**3/6; chhm=xh**2*o2 +xcmsh=xh**3/3 +qdh=qdh/shh; qxh=qxh/xcmsh ! <- rescale qdh, qxh +y=pm+xr*qm +qdh*(chm-chhm) + qxh*(xh*shm-xr*shhm) +dydx=qm+qdh*sh +qxh*(xh*chm-shhm) +ddydxx=qdh +qxh*xh*sh +dddydxxx=qxh*xh +end subroutine eval_usplineddd + +!============================================================================= +subroutine eval_iuspline(n,xs, p,q,m, x,y)! [eval_iuspline] +!============================================================================= +! Evaluate the integrated untensioned spline at x, returning the value, y. +!============================================================================= +integer, intent(in ):: n +real(dp),dimension(n),intent(in ):: xs,p,q,m +real(dp), intent(in ):: x +real(dp), intent(out):: y +!----------------------------------------------------------------------------- +real(dp),parameter:: u3o2=3*o2 +real(dp):: a,b,c,d,t2,t3,t4,xh,xr,pa,pd,qa,qd +integer :: ia,ib +!============================================================================= +if(x<=xs(1))then; xr=x-xs(1); y=p(1)*xr+q(1)*xr**2/2; return; endif +if(x>=xs(n))then; xr=x-xs(n); y=m(n)+p(n)*xr+q(n)*xr**2/2; return; endif +do ib=2,n + if(xs(ib)<=xs(ib-1))cycle ! <- only consider intervals of positive width + if(xs(ib)>=x)exit ! <- exit once finite interval straddling x is found +enddo +ia=ib-1 +xh=(xs(ib)-xs(ia))*o2 ! <- halfwidth of interval +xr=x-xs(ia)-xh ! <- x relative to interval midpoint +t2=xh**2/2 +t3=t2*xh/3 +pa=(p(ib)+p(ia))*o2 +pd=(p(ib)-p(ia))*o2/xh +qa=(q(ib)+q(ia))*o2 +qd=(q(ib)-q(ia))*o2/xh +! a,b,c,d are the Taylor coefficients of the cubic about the interval midpoint: +c=qd +a=pa-c*t2 +d=(qa-pd)*u3o2/t2 +b=qa-d*t2 +t2=xr**2/2 +t3=t2*xr/3 +t4=t3*xr/4 +y=m(ia)+a*xr+b*t2+c*t3+d*t4 +end subroutine eval_iuspline + +!============================================================================== +subroutine best_tslalom(nh,mh,doru,hgts,hs,halfgate,bigT, & ! [best_slalom] + hgtp,hp,qbest,yabest,enbest,modebest,maxita,maxitb,maxit,maxrts,FF) +!============================================================================== +! Run through the different allowed routes between the slalom gates and +! select as the final solution the one whose spline has the smallest "energy". +!============================================================================== +integer, intent(in ):: nh,mh,doru +integer, dimension(nh), intent(in ):: hgts +real(dp),dimension(nh), intent(in ):: hs +real(dp), intent(in ):: halfgate,bigT +integer, dimension(mh*2),intent( out):: hgtp +real(dp),dimension(mh*2),intent( out):: hp +real(dp),dimension(mh*2),intent( out):: qbest +real(dp),dimension(mh*2),intent( out):: yabest +real(dp), intent( out):: enbest +integer,dimension(mh), intent( out):: modebest +integer, intent(inout):: maxita,maxitb,maxit,maxrts +logical, intent( out):: FF +!----------------------------------------------------------------------------- +integer, dimension(2,mh) :: hgtn +real(dp),dimension(mh*2) :: q,ya +real(dp),dimension(2,2,mh):: hn +real(dp) :: en,tspan,hspan,enbase,hgbigT +integer, dimension(mh) :: code,mode +integer, dimension(mh*2) :: bend +integer :: i,k,m,route_count,ita,ittot +logical, dimension(mh*2) :: off +logical :: flag,descending +!============================================================================== +m=mh*2 +call set_gates(nh,mh,doru,hgts,hs, hgtn,hn,code,FF) +! Examine gate posts of first and last slalom gate to determine whether +! profile is predominantly descending or ascending: +if (hn(1,2,1)>hn(1,1,mh))then; descending=T ! definitely descending +elseif(hn(2,2,1)4)call list_routes(mh,code) ! Only bother to list them when >4 +enbest=hu +flag=T +do k=1,ihu + call next_route(mh,code,mode,flag) + if(flag)then; flag=F; exit; endif + call set_posts(mh,mode,hgtn,hn,bend,hgtp,hp,off) + call slalom_tspline(m,bend,hgtp,hp,off,hgbigT, & + q,ya,en,ita,maxitb,ittot,FF); en=en/enbase + maxita=max(maxita,ita) + maxit =max(maxit,ittot) + if(FF)then + write(41,*) & + 'In best_tslalom; failure flag was raised in call to slalom_tspline' + return + endif + if(en4)call list_routes(mh,code)! Only bother to list them when >4 +enbest=hu +flag=T +do k=1,ihu + call next_route(mh,code,mode,flag) + if(flag)then; flag=F; exit; endif + call set_posts(mh,mode,hgtn,hn,bend,hgtp,hp,off) + call slalom_uspline(m,bend,hgtp,hp,off,halfgate, q,ya,en,ita,maxitb,ittot,FF) + maxita=max(maxita,ita) + maxit =max(maxit,ittot) + if(FF)then + write(41,*) & + 'In best_uslalom; failure flag was raised in call to slalom_uspline' + return + endif + if(en Option code(i) ; ==> Option Code(i) +!............................................................................ +! 0 0 0 +! 2 2 0 +! 3 0 1 +! 4 1 1 +! 5 2 1 +! 8 2 2 +!............................................................................. +! +! The first route code in a chain of gates, ie., code(1), is alway set +! to 0, so at the very least, two combinations of routes are always coded +! according as whether we choose to initialize the spline solution with +! descent through gate 1 or an ascent. If all the gates are temporally +! separated, then then final gate's route_code also has this 0 value +! signifying an indeterminate mode of passage. +! +! In the special case where mh=1 and the given hs data are not enough to +! decide whether this trajectory is descending or ascending, the tie-breaker +! code, doru ("down or up") forces the sense of the trajectory as follows: +! doru=1 ==> descending +! doru=2 ==> ascending +!============================================================================= +integer, intent(in ):: nh,mh,doru +integer, dimension(nh), intent(in ):: hgts +real(dp),dimension(nh), intent(in ):: hs +integer, dimension(2, mh),intent(out):: hgtn +real(dp),dimension(2,2,mh),intent(out):: hn +integer, dimension( mh),intent(out):: code +logical, intent(out):: FF +!----------------------------------------------------------------------------- +real(dp):: hp +integer :: i,im,i2,i2m,imh,n,atti,attim,codeim,hgtp +!============================================================================= +FF=F +n=nh*2 +hgtp=hgts(1)-1 ! <- default "time at present" in units of halfgate +imh=0 +do i=1,nh + i2=i*2 + i2m=i2-1 + hp=hs(i) + if(hgts(i)>hgtp)then +! A new nominal time of observation: + imh=imh+1 + hgtp=hgts(i) + hgtn(1,imh)=hgtp-1 + hgtn(2,imh)=hgtp+1 + hn(:,:,imh)=hp + elseif(hgts(i)=hn(1,1,i))then + atti=1 ! <-descending attitude at common time + code(i)=3 + if(attim==1.and.(codeim==0.or.codeim==3))code(im)=4 + else +! Overlapping, attitude at common time neither ascending nor descending, +! but sense of passage through gates must alternate (code=5). + code(i)=5 + if(hn(2,1,im)<=hn(1,2,i))then; hn(1,2,i) =hn(2,1,im) + else; hn(2,1,im)=hn(1,2,i) + endif + if(hn(2,2,im)<=hn(1,1,i))then; hn(2,2,im)=hn(1,1,i) + else; hn(1,1,i) =hn(2,2,im) + endif + endif + else +! Gates im and i separated by an intermission: + if(hn(2,2,im)<=hn(1,2,i))then + atti=2 ! <-ascending attitude at intermission + if(attim==2.and.(codeim==0.or.codeim==2))code(im)=8 + elseif(hn(2,1,im)>=hn(1,1,i))then + atti=1 ! <-descending attitude at intermission + if(attim==1.and.(codeim==0.or.codeim==3))code(im)=4 + endif + endif + attim=atti + codeim=code(i) +enddo +end subroutine set_gates + +!============================================================================= +subroutine set_posts(mh,mode,hgtn,hn, bend,hgtp,hp,off)! [set_posts] +!============================================================================= +! Given a set of mh double-gates (both descending and ascending types) and +! the array of actual passage modes (i.e., the actual route threading +! the sequence of gates), set the array of actual gateposts coordinates, +! hgtp and hp, and the corresponding set of signs, bend, by which these +! gatepost constraints, when activatived, must alter the principal +! changed derivative of the optimal spline taking the prescribed route. +! Also, flag (using logical array, "off") those gateposts that, for this +! particular route, are redundant owing to existence of duplication of +! consecutive pairs of (hgtp,hp) sometimes occurring when no intermission +! separates consecutive gates. All times are in integer units of halfgate. +!============================================================================= +integer, intent(in ):: mh +integer, dimension( mh),intent(in ):: mode +integer, dimension(2, mh),intent(in ):: hgtn +real(dp),dimension(2,2,mh),intent(in ):: hn +integer, dimension(mh*2), intent(out):: bend,hgtp +real(dp),dimension(mh*2), intent(out):: hp +logical, dimension(mh*2), intent(out):: off +!----------------------------------------------------------------------------- +real(dp):: hprev +integer :: i,i2,i2m,i2mm,im,modei,hgtprev +!============================================================================= +off=F +do i=1,mh + im=i-1 + modei=mode(i) + i2=i*2; i2m=i2-1; i2mm=i2-2 + hgtp(i2m)=hgtn(1,i) + hgtp(i2 )=hgtn(2,i) + hp(i2m)=hn(1,modei,i) + hp(i2 )=hn(2,modei,i) +! Check whether gatepost duplications exist, or one dominates another at same t: + if(i>1)then + if(hgtprev==hgtp(i2m))then + if(hprev==hp(i2m))off(i2m)=T + if(mode(im)==2.and.modei==1)then + if(hprev<=hp(i2m))then + off(i2mm)=T + else + off(i2m)=T + endif + elseif(mode(im)==1.and.modei==2)then + if(hprev<=hp(i2m))then + off(i2m)=T + else + off(i2mm)=T + endif + endif + endif + endif + bend(i2m)=modei*2-3 ! mode=1 ==> bend=-1; mode=2 ==> bend=+1 + bend(i2 )=-bend(i2m)! mode=1 ==> bend=+1; mode=2 ==> bend=-1 + hgtprev=hgtp(i2) + hprev =hp(i2) +enddo +end subroutine set_posts + +!============================================================================= +subroutine count_routes(n,code,count,FF)! [count_routes] +!============================================================================= +! Given the route code array, "code", list all the allowed combinations +! of passage modes (descending === 1; ascending === 2) through the sequence +! of slalom gates. +!============================================================================= +integer, intent(in ):: n +integer,dimension(n),intent(in ):: code +integer, intent(out):: count +logical, intent(out):: FF +!----------------------------------------------------------------------------- +integer,dimension(n):: mode +logical :: flag +!============================================================================ +FF=F +flag=T +do count=0,ihu; call next_route(n,code,mode,flag); if(flag)return; enddo +FF=(count>ihu) +if(FF) write(41,*) 'In count_routes; number of routes exceeds allowance = ',ihu +end subroutine count_routes + +!============================================================================= +subroutine list_routes(n,code)! [list_routes] +!============================================================================= +! Given the route code array, "code", list all the allowed combinations +! of passage modes (descending === 1; ascending === 2) through the sequence +! of slalom gates. +!============================================================================= +integer, intent(in ):: n +integer,dimension(n),intent(in ):: code +!----------------------------------------------------------------------------- +integer,dimension(n):: mode +integer :: i +logical :: flag +!============================================================================ +write(41,'("List all route combinations of ",i4," allowed passage modes")'),n +flag=T +do i=1,ihu + call next_route(n,code,mode,flag) + if(flag)then + write(41,'(" In list_routes; List of routes complete")'); flag=F; exit + endif + write(41,60)i,mode +enddo +if(i>ihu) write(41,'("This list is not necessarily complete")') +60 format(i5,3x,6(2x,5i2)) +end subroutine list_routes + +!============================================================================= +subroutine next_route(n,code,mode,flag)! [next_route] +!============================================================================= +! Given the combinatoric specification of sequentially-conditional +! allowable modes of passage through the n gates encoded in array +! codes, and generically given the present sequence, modes, (a series of +! 1's and 2's denoting respectively descents and ascents through the gates) +! return the next allowed combination defining the updated modes. If instead, +! the intent is to initialize the sequence of modes, input the flag to "true" +! and the first route (array of modes) will be returned (and the flag lowered +! to "false"). +! If there is no "next" route, the sequence having been already exhausted, +! the flag is raised to "true" on output and the route encoded in array, +! modes, is not meaningful. +! When, at gate i, the preceding gate's mode is "modeim" ( = modes(i-1)) +! and the present gate's given route code is code=codes(i), the options +! for choosing mode(i) are encoded in the options code, +! option = options(code, +!============================================================================= +integer, intent(in ):: n +integer,dimension(n),intent(in ):: code +integer,dimension(n),intent(inout):: mode +logical, intent(inout):: flag +!----------------------------------------------------------------------------- +integer,dimension(0:8,2):: options ! <- evaluates the trinary digit of code +integer,dimension(0:2) :: firstmode +integer :: i,im,j,modeim,modejm,option +data options/0,1,2,0,1,2,0,1,2, 0,0,0,1,1,1,2,2,2/ +data firstmode/1,1,2/ +!============================================================================= +modeim=1 ! <-arbitrarily set mode of previous gate passage to "descent" +if(flag)then +! Initialize the route sequence and reset the flag: + do i=1,n + option=options(code(i),modeim) + mode(i)=firstmode(option) + modeim=mode(i) + enddo + flag=F + return +endif + +! Use the present route (array of "mode" elements), and the route code, +! to find the next allowed route, or return with the flag raised when +! no more allowed routes are to be found: +do i=n,1,-1 + im=i-1 + if(i>1)then + modeim=mode(im) + else + modeim=1 + endif + option=options(code(i),modeim) + if(option>0.or.mode(i)==2)cycle + mode(i)=2 + modejm=mode(i) + do j=i+1,n + option=options(code(j),modejm) + mode(j)=firstmode(option) + modejm=mode(j) + enddo + return +enddo +flag=T +end subroutine next_route + +!============================================================================= +subroutine slalom_tspline(n,bend,hgxn,yn,off,bigX, &! [slalom_tspline] + q,ya,en,ita,maxitb,ittot,FF) +!============================================================================= +! Fit a tensioned spline, characteristic abscissa scale, bigX, between the +! "slalom gates" defined by successive pairs of abscissae, integer hgxn, and +! corresponding ordinate values, real yn. Even number n is the total number +! of inequality constraints, or twice the number of gates. There is no +! assumed conditional monotonicity for the gates, but the sense in which +! they are threaded is encoded in the array of signs (-1 or +1), "bend" +! which determines, when activated, the sense in which the gatepost constraint +! changes the principal non-continuous derivative (generally 3rd derivative) +! of the spline. Some gatepost inequality constraints are disabled, as flagged +! by logical array, "off", when two consecutive gateposts constraints are +! identical. +! Subject to the linear inequality constraints, we seek the tensioned +! spline with characteristic scale, bigX, whose energy is minimized. +! The energy of the tensioned spline in the infinitesimal segment [x,x+dx] +! is proportional to half*{ (dy/dx)**2 + (bigT**2)*(ddy/dxx)**2 }*dx. +! The problem is therefore of the type: minimize a quadratic functional +! subject to finitely many (n) linear inequality constraints. +! +! The problem is first standardized by rescaling hgxn (to real xs=xn/bigX) so +! that the characteristic scale becomes unity. We start with a feasible spline +! fitted (equality constraints) to as many of the constraints with distinct +! xs as we can. We "A" iterate from one such feasible, conditionally minimum- +! energy solution to another with a different set of equality constraints +! via an "B" iteration" as follows. The "A" solution generally may have +! constraints at the gateposts that are "pushing" when they should be +! "pulling" (specifically, the sign of the discontinuity in the spline's +! third derivative is the opposite of what it should be at that point). Take +! ALL such violations and, first, simply switch them "off". In general, this +! will cause the energy of the spline to fall significantly, but the resulting +! spline may no longer thread all the slalom gates, so we will have to ADD +! some constraints via what we call the "B-iteration" (whereupon the energy +! increases again, but not to point where it was when we released the +! constraints at this last A-iteration). In the spline's state space, the +! first of the new cycle of B-iterations back-tracks along the line-segment +! joining this new spline-state to the more constrained one we just departed, +! to the point on the spline-state-space segment where the solution becomes +! once again feasible. This involves adding just one more constraint where the +! spine just touches the inside of a slalom gatepost where it did not touch +! before. This new contact is made a new constraint, the spline state is +! recorded as the state reached at the 1st B-iteration, and a new spline +! solution is solved for. If, once again, the spline fails to thread the +! gateposts, then in the next B-iteration, we back-track once again along a +! line segment in spline-space, but this time towards the state at the previous +! B-iteration. Again, we add a new constraint (which adds energy, but still +! not so much that the energy exceeds that of the last A-iteration). We +! continue this process until we have added just enough new constraints to +! achieve a feasible (slalom-threading) spline. This cycle of B-iterations +! is thus complete and, in the generic case, the energy is still smaller +! than it was at the last A-iteration. But since the new configuration may +! be in violation of a new set of "jump-sign" violations, we must check +! whether another A-iteration is required -- and so on. The B-iterations +! are nested within the loop of A-iterations. To summarize: the A-iterations +! release the gatepost constraints where jump-sign violations occur and the +! energy between A-iterations decreases; the B-iterations activate new +! gatepost constraints to keep the spline between the gateposts, and the +! energy between B iterations increases. The process terminates when the +! jump-sign conditions are all satisfied in the generic case. However, we +! find that, in extremely rare and special cases of numerical coincidence, +! jump-sign condition is close enough to machine-zero to be ambiguous -- +! and this seems to occur at the very last stage of the A-iterations. To +! allow for this very rare occurrence, we now check that the energy between +! A-iterations really IS decreasing and, if it is ever found not to be, we +! terminate the iteration anyway. +! +! In general, when the constraint of the final solution is not active, the +! value y of the spline differs from the yn there; it is therefore convenient +! to output what the actual y value of the spline is, which we do in the +! array, ya ("y actual"). +!============================================================================= +integer, intent(in ):: n +integer, dimension(n), intent(in ):: bend,hgxn +real(dp),dimension(n), intent(in ):: yn +logical, dimension(n), intent(in ):: off +real(dp), intent(in ):: bigX +real(dp),dimension(n), intent( out):: q +real(dp),dimension(n), intent( out):: ya +real(dp), intent( out):: en +integer, intent( out):: ita,ittot +integer, intent(inout):: maxitb +logical, intent( out):: FF +!----------------------------------------------------------------------------- +integer,parameter :: nita=50,nitb=80 +real(dp),dimension(n) :: xs,jump,qt,yat +real(dp) :: sj,sjmin,ena +integer :: i,j,k,itb,hgxp +logical,dimension(n) :: on +!============================================================================= +FF=F +! For algebraic convenience, work in terms of rescaled times, xs, of +! the constraints whose given times, hgxn, are in integer units of halfgate +xs=hgxn/bigX + +! Initialize the "A" iteration by fitting a feasible spline to as many +! "gateposts" as is possible with distinct xs. A constraint i is signified +! to be activated when logical array element, on(i), is true: +hgxp=hgxn(1)-1 +do i=1,n + if(off(i))then; on(i)=F; cycle; endif + on(i)=(hgxn(i)>hgxp); if(on(i))hgxp=hgxn(i) +enddo +ittot=1 +call fit_gtspline(n,xs,yn,on,qt,jump,yat,en,FF)! <- Make the initial fit +ena=en +if(FF)then + write(41,*) 'In slalom_tspline; failure flag raised in call to fit_gtspline' + write(41,*) 'at initialization of A loop' + return +endif + +! loop over steps of iteration "A" to check for jump-sign violations +do ita=1,nita + q=qt ! Copy solution vector q of nodal 1st-derivatives + ya=yat ! Copy nodal intercepts + +! Determine whether there exists sign-violations in any active "jumps" +! of the 3rd derviative and, if so, inactivate (on==F) the constraints +! at those points. Also, count the number, j, of such violations. + j=0 + k=0 + sjmin=0 + do i=1,n + if(.not.on(i))cycle + sj=-bend(i)*jump(i) + if(sj<0)then + j=i + on(i)=F + else + k=k+1 ! <- new tally of constraints switched "on" + endif + enddo + if(j==0)exit !<-Proper conditions for a solution are met + if(k==0)on(j)=T ! <- must leave at least one constraint "on" + +! Begin a new "B" iteration that adds as many new constraints as needed +! to keep the new conditional minimum energy spline in the feasible region: + do itb=1,nitb + call fit_gtspline(n,xs,yn,on,qt,jump,yat,en,FF) + if(FF)then + write(41,*)& + 'In slalom_tspline; failure flag raised in call to fit_gtspline' + write(41,*) 'at B loop, iterations ita,itb = ',ita,itb + return + endif + ittot=ittot+1 ! Increment the running total of calls to fit_tspline + +! Determine whether this "solution" wanders outside any slalom gates at +! the unconstrained locations and identify and calibrate the worst violation. +! In this case, sjmin, ends up being the under-relaxation coefficient +! by which we need to multiply this new increment in order to just stay +! within the feasible region of spline space, and constraint j must be +! switched "on": + j=0 + sjmin=u1 + do i=1,n + if(on(i).or.off(i))cycle + sj=bend(i)*(yn(i)-yat(i)) + if(sj<0)then + sj=(yn(i)-ya(i))/(yat(i)-ya(i)) + if(sjnitb) then + FF=T + write(41,*) 'In slalom_tspline; exceeding the allocation of B iterations' + return + end if + q=qt + ya=yat + if(en>=ena)then + write(41,*) 'In slalom_tspline; energy failed to decrease' + exit + endif + ena=en +enddo ! ita loop +if(ita>nita)then + FF=T + write(41,*) 'In slalom_tspline; exceeding the allocation of A iterations' + return +endif +end subroutine slalom_tspline + +!============================================================================= +subroutine slalom_uspline(n,bend,hgxn,yn,off,halfgate,&! [slalom_uspline] + q, ya,en,ita,maxitb,ittot,FF) +!============================================================================= +! Like slalom_tspline, except this treats the special case where the spline +! is untensioned, and therefore the characteristic scale in x become infinite, +! and the spline becomes piecewise cubic instead of involving hyperbolic +! (or exponential) function. In other respects, the logic follows that of +! subroutine slalom_tsline. +!============================================================================= +integer, intent(in ):: n +integer, dimension(n), intent(in ):: bend,hgxn +real(dp),dimension(n), intent(in ):: yn +logical, dimension(n), intent(in ):: off +real(dp), intent(in ):: halfgate +real(dp),dimension(n), intent( out):: q +real(dp),dimension(n), intent( out):: ya +real(dp), intent( out):: en +integer, intent( out):: ita,ittot +integer, intent(inout):: maxitb +logical, intent( out):: FF +!----------------------------------------------------------------------------- +integer,parameter :: nita=50,nitb=80 +real(dp),dimension(n) :: xs,jump,qt,yat +real(dp) :: sj,sjmin,ena +integer :: i,j,k,itb,hgxp +logical,dimension(n) :: on +!============================================================================= +! Initialize the "A" iteration by fitting a feasible spline to as many +! "gateposts" as is possible with distinct xn. A constraint i is signified +! to be activated when logical array element, on(i), is true: +FF=F +xs=hgxn*halfgate +hgxp=hgxn(1)-1 +do i=1,n + if(off(i))then + on(i)=F + cycle + endif + on(i)=(hgxn(i)>hgxp) + if(on(i))hgxp=hgxn(i) +enddo +ittot=1 +call fit_guspline(n,xs,yn,on,qt,jump,yat,en,FF)! <- Make the initial fit +ena=en +if(FF)then + write(41,*) 'In slalom_uspline; failure flag raised in call to fit_guspline' + write(41,*) 'at initialization of A loop' + return +endif + +! loop over steps of iteration "A" to check for jump-sign violations +do ita=1,nita + q=qt ! Copy solution vector q of nodal 1st-derivatives + ya=yat ! Copy nodal intercepts + +! Determine whether there exists sign-violations in any active "jumps" +! of the 3rd derviative and, if so, inactivate (on==F) the constraints +! at those points. Also, count the number, j, of such violations. + j=0 + k=0 + sjmin=0 + do i=1,n + if(.not.on(i))cycle + sj=-bend(i)*jump(i) + if(sj<0)then + j=i + on(i)=F + else + k=k+1 ! <- new tally of constraints switched "on" + endif + enddo + if(j==0)exit !<-Proper conditions for a solution are met + if(k==0)on(j)=T ! <- must leave at least one constraint "on" + +! Begin a new "B" iteration that adds as many new constraints as needed +! to keep the new conditional minimum energy spline in the feasible region: + do itb=1,nitb + call fit_guspline(n,xs,yn,on,qt,jump,yat,en,FF) + if(FF)then + write(41,*)& + 'In slalom_uspline; failure flag raised in call to fit_guspline' + write(41,*) 'at B loop, iterations ita,itb = ',ita,itb + return + endif + ittot=ittot+1 ! Increment the running total of calls to fit_uspline + +! Determine whether this "solution" wanders outside any slalom gates at +! the unconstrained locations and identify and calibrate the worst violation. +! In this case, sjmin, ends up being the under-relaxation coefficient +! by which we need to multiply this new increment in order to just stay +! within the feasible region of spline space, and constraint j must be +! switched "on": + j=0 + sjmin=u1 + do i=1,n + if(on(i).or.off(i))cycle + sj=bend(i)*(yn(i)-yat(i)) + if(sj<0)then + sj=(yn(i)-ya(i))/(yat(i)-ya(i)) + if(sjnitb) then + FF=T + write(41,*) 'In slalom_uspline; exceeding the allocation of B iterations' + return + end if + q=qt + ya=yat + if(en>=ena)then + write(41,*) 'In slalom_uspline; energy failed to decrease' + exit + endif + ena=en +enddo +if(ita>nita)then + FF=T + write(41,*) 'In slalom_uspline; exceeding the allocation of A iterations' + return +endif +end subroutine slalom_uspline + +!============================================================================= +subroutine convertd(n,halfgate,tdata,hdata,phof,&! [convertd] + doru,idx,hgts,hs,descending,FF) +!============================================================================= +! tdata (in single precision real hours) is discretized into bins of size +! gate=2*halfgate (in units of seconds) and expressed as even integer units +! hgts of halfgate that correspond to the mid-time of each bin. (The two +! limits of each time-bin are odd integers in halfgate units.) +!============================================================================= +integer, intent(in ):: n +real(dp), intent(in ):: halfgate +real, dimension(n),intent(in ):: tdata,hdata +integer, dimension(n),intent(in ):: phof +integer, intent(out):: doru +integer, dimension(n),intent(out):: idx,hgts +real(dp),dimension(n),intent(out):: hs +logical, intent(out):: descending +logical, intent(out):: FF +!------------------------------------------------------------------------------ +integer,parameter:: hour=3600 ! 1 hour converted to S.I. units +integer :: i,j,ii,upsign,hgs +real(dp) :: s,gate +!============================================================================= +FF=F +if(size(hdata)/=n)stop 'In convertd; inconsistent dimensions of hdata' +if(size(tdata)/=n)stop 'In convertd; inconsistent dimensions of tdata' +if(size(hs)/=n)stop 'In convertd; inconsistent dimensions of hs' +if(size(hgts)/=n)stop 'In convertd; inconsistent dimensions of hgts' +hs=hdata +! convert to whole number of seconds rounded to the nearest gate=2*halfgate: +upsign=0 +gate=halfgate*2 +do i=1,n + hgts(i)=2*nint(tdata(i)*hour/gate)! + if(phof(i)==5)upsign=1 ! Ascending flight + if(phof(i)==6)upsign=-1 ! Descending flight +enddo +doru=0 +if (upsign>0) then + doru=2 +else + doru=1 +endif +if(n==1)return +if(hgts(1)>hgts(n))then ! Reverse the order: + do i=1,n/2 + j=n+1-i + hgs=hgts(i); hgts(i)=hgts(j); hgts(j)=hgs ! Swap integer hgts + s =hs(i) ; hs(i) =hs(j) ; hs(j) =s ! and swap real hs + enddo +endif +if(upsign==1)then + descending=F +elseif(upsign==-1)then + descending=T +else + descending=(hs(n) 80 characters +c 2014-12-09 Y. Zhu -- Modified the calculation of vertical velocity rate (stored in +c rate_accum) still using a finite-difference method, but now +c calculated for both ascents and descents using the nearest +c neighboring pair which are at least one minute apart (before, +c only only be calculated for descents) +c 2014-12-09 Y. Zhu -- Add new namelist switch "l_mandlvl" which, when F, will skip +c interpolation to mandatory levels +c 2014-12-09 J. Purser/Y. Zhu -- Add new namelist switch "tsplines" which, when T, will +c calculate vertical velocity rate (stored in rate_accum) using +c Jim Purser's tension-spline interpolation utility to get +c continuous gradient results in a profile and mitigate missing +c time information +c 2014-12-12 D. Keyser -- Printout from vertical velocity rate calculation information for +c QC'd merged aircraft reports written to profiles PREPBUFR-like +c file is written to unit 41 rather than stdout. +c 2015-04-17 Y. Zhu -- +c 1) This subroutine is more robust. If there is an error in the +c generation of vertical velocity rate in the tension-spline +c interpolation utility pspl (called in this subroutine), this +c subroutine (and thus the program itself) will no longer abort +c (with either c. code 62, 63 or 64 depending upon which routine +c inside pspl generated the error) but will instead revert to the +c finite difference method for calculating vertical velocity rate. +c 2) Previously, halfgate was set to be 30 for the data profiles that +c don't have second information in time, but a tighter value of 10 +c for the data profiles that do have second information in time. Now +c halfgate is relaxed to be 30 for the data profiles that do have +c complete time information. +c 2016-12-09 D. Keyser -- +c - Nomenclature change: replaced "MDCRS/ACARS" with just "MDCRS". +c - The format for a print statement containing latitude and longitude changed +c to print to 5 decimal places since some aircraft reports contain this +c precision. +c +c Usage: call sub2mem_mer(proflun,bmiss,mxlv,mxnmev,maxmandlvls, +c mandlvls,mesgtype,hdr2wrt, +c acid1,c_acftid1,c_acftreg1, +c rct_accum,drinfo_accum,acft_seq_accum, +c mstq_accum,cat_accum,elv_accum,rpt_accum, +c tcor_accum, +c pevn_accum,pbg_accum,ppp_accum, +c qevn_accum,qbg_accum,qpp_accum, +c tevn_accum,tbg_accum,tpp_accum, +c zevn_accum,zbg_accum,zpp_accum, +c wuvevn_accum,wuvbg_accum,wuvpp_accum, +c wdsevn_accum,mxe4prof,c_qc_accum, +c num_events_prof,lvlsinprof,nlvinprof, +c nrlacqc_pc,l_mandlvl,tsplines,l_operational,lwr) +c +c Input argument list: +c proflun - Unit number for the output post-PREPACQC PREPBUFR-like file containing +c merged profile reports (always) and single(flight)-level reports not +c part of any profile (when l_prof1lvl=T) with added NRLACQC events +c (aircraft data only) +c bmiss - BUFRLIB missing value (set in main program) +c mxlv - Maximum number of levels allowed in a report profile +c mxnmev - Maximum number of events allowed, per variable type +c maxmandlvls - Maxmum number of mandatory pressure levels to consider for aircraft +c profiles +c mandlvls - List of mandatory pressure levels to consider for aircraft profiles +c mesgtype - PREPBUFR message type (AIRCAR or AIRCFT) of the profile in question +c hdr2wrt - Array containing header information for the profile report +c acid1 - Aircraft flight number for the profile MDCRS report {this will be encoded +c into 'ACID' for MDCRS or AMDAR (LATAM only) reports in output PREPBUFR- +c like profiles file} +c c_acftreg - Aircraft tail number for the profile report as used in NRL QC processing +c (passed into this subroutine only for printing purposes) +c c_acftid - Aircraft flight number for the profile report as used in NRL QC +c processing (passed into this subroutine only for printing purposes) +c rct_accum - Array containing receipt time on all profile levels +c drinfo_accum - Array containing drift coordinates (lat, lon, time) on all profile +c levels +c acft_seq_accum - Array containing the temperature precision and flight phase on all +c profile levels +c mstq_accum - Array containing the moisture quality flag on all profile levels +c cat_accum - Array containing the PREPBUFR level categories on all profile levels +c elv_accum - Array containing elevation on all profile levels +c rpt_accum - Array containing reported observation time on all profile levels +c tcor_accum - Array containing time correction indicator on all profile levels +c pevn_accum - Array containing all pressure events (ob, qm, pc, rc) on all profile +c levels +c pbg_accum - Array containing pressure background information on all profile levels +c ppp_accum - Array containing pressure post-processing information on all profile +c levels +c qevn_accum - Array containing all moisture events (ob, qm, pc, rc) on all profile +c levels +c qbg_accum - Array containing moisture background information on all profile levels +c qpp_accum - Array containing moisture post-processing information on all profile +c levels +c tevn_accum - Array containing all temperature events (ob, qm, pc, rc) on all profile +c levels +c tbg_accum - Array containing temperature background information on all profile +c levels +c tpp_accum - Array containing temperature post-processing information on all profile +c levels +c zevn_accum - Array containing all altitude events (ob, qm, pc, rc) on all profile +c levels +c zbg_accum - Array containing altitude background information on all profile levels +c zpp_accum - Array containing altitude post-processing information on all profile +c levels +c wuvevn_accum - Array containing all wind (u/v) events (ob, qm, pc, rc) on all profile +c levels +c wuvbg_accum - Array containing wind (u/v) background information on all profile levels +c wuvpp_accum - Array containing wind (u/v) post-processing information on all profile +c levels +c wdsevn_accum - Array containing all wind (direction/speed) events (ob, qm, pc, rc) on +c all profile levels +c mxe4prof - Maximum number of events in a single-level merged report (i.e., the +c maximum amongst the number of pressure, moisture, temperature, altitude, +c u/v wind and dir/speed wind events) +c c_qc_accum - Array containing NQLACQC quality information 11-character strings on all +c profile levels +c lvlsinprof - Array containing a list of pressure levels that are present in the +c current profile +c nlvinprof - Number of levels in profile +c nrlacqc_pc - PREPBUFR program code for the NRLACQC step +c l_mandlvl - Logical whether to interpolate to mandatory levels in profile generation +c tsplines - Logical whether to use tension-splines for aircraft vertical velocity +c calculation +c l_operational- Run program in operational mode if true +c lwr - Machine word length in bytes (either 4 or 8) +c +c Output argument list: +c hdr2wrt - Array containing header information for the profile report (TYP undated, +c (also changed to highest/lowest pressure level for ascents/descents) +c num_events_prof - Total number of events on an ob, across all levels, across all +c reports (to this point), written into the PREPBUFR-like file (this value +c is the same for each ob type) +c lvlsinprof - Array containing a list of pressure levels that are present in the +c current profile (now possibly also contains mandatory levels) +c +c Output files: +c Unit proflun - PREPBUFR-like file containing merged (mass and wind) profile reports +c (always) and single(flight)-level reports not part of any profile (when +c l_prof1lvl=T) with NRLACQC events +c Unit 06 - Standard output print +c Unit 52 - Text file containing listing of all QC'd merged aircraft reports written +c to profiles PREPBUFR-like file +c +c Subprograms called: +c Unique: none +c Library: +c SYSTEM: SYSTEM +c BUFRLIB: UFBINT IBFMS +c W3NCO: W3TAGE ERREXIT +c W3EMC: ORDERS +c +c Exit States: +c Cond = 0 - successful run +c 59 - nlvinprof is zero coming into this subroutine (should never happen!) +c 61 - index "j is .le. 1 meaning "iord" array underflow (should never happen!) +c +c Remarks: Called by subroutine output_acqc_prof. +c +c Attributes: +c Language: FORTRAN 90 +c Machine: NCEP WCOSS +c +c$$$ + subroutine sub2mem_mer(proflun,bmiss,mxlv,mxnmev,maxmandlvls, + + mandlvls,mesgtype,hdr2wrt, + + acid1,c_acftid1,c_acftreg1, + + rct_accum,drinfo_accum,acft_seq_accum, + + mstq_accum,cat_accum,elv_accum,rpt_accum, + + tcor_accum, + + pevn_accum,pbg_accum,ppp_accum, + + qevn_accum,qbg_accum,qpp_accum, + + tevn_accum,tbg_accum,tpp_accum, + + zevn_accum,zbg_accum,zpp_accum, + + wuvevn_accum,wuvbg_accum,wuvpp_accum, + + wdsevn_accum,mxe4prof,c_qc_accum, + + num_events_prof,lvlsinprof,nlvinprof, + + nrlacqc_pc,l_mandlvl,tsplines, + + l_operational,lwr) + + use pkind, only: dp + use pspl, only: bnewton,best_slalom,count_gates,convertd, + + convertd_back + implicit none + +c ------------------------------ +c Parameter statements/constants +c ------------------------------ + integer proflun ! output unit number for post-PREPACQC PREPBUFR-like + ! file containing merged profile reports (always) and + ! single(flight)-level reports not part of any + ! profile (when l_prof1lvl=T) with added NRLACQC + ! events + + real*8 bmiss ! BUFRLIB missing value (set in main program) + +c Variables used to write data to output PREPBUFR-like file in sorted order +c ------------------------------------------------------------------------- + integer mxlv ! maximum number of report levels allowed in aircraft + ! profiles + character*6 cmxlv ! character form of mxlv + + integer mxnmev ! maximum number of events allowed in stack + +, lvlsinprof(mxlv) ! array containing a list of pressure levels that are + ! present in the current profile (later changed to + ! add mandatory levels) + +, mxe4prof ! maximum number of events in a single-level merged + ! report (i.e., the maximum amongst the number of + ! pressure, moisture, temperature, altitude, u/v wind + ! and dir/speed wind events) + +, nlvinprof ! number of levels in a profile upon input + + real*8 hdr2wrt(15) ! header info for current profile (passed in) + +, drinfo_accum(3,mxlv) ! array used to accumulate drift info across profile + ! levels + +, acft_seq_accum(2,mxlv) ! array used to accumulate ACFT_SEQ (PCAT -temperature + ! precision, POAF - phase of flight) info across + ! profile levels + +, mstq_accum(1,mxlv) ! array used to accumulate moisture QC marks across + ! profile levels + +, cat_accum(1,mxlv) ! array used to accumulate level category markers + ! across profile levels + +, elv_accum(1,mxlv) ! array used to accumulate elevation across profile + ! levels + +, rpt_accum(1,mxlv) ! array used to accumulate reported obs time across + ! profile levels + +, tcor_accum(1,mxlv) ! array used to accumulate time correction factor + ! across profile levels + +, rct_accum(1,mxlv) ! array used to accumulate receipt time across profile + ! levels + + real*8 pevn_accum(4,mxlv,mxnmev)! array used to accumulate pressure data/events for a + ! single profile, across profile levels + +, pbg_accum(3,mxlv) ! array used to accumulate pressure background info + ! (POE, PFC, PFCMOD) for a single profile, across + ! profile levels + +, ppp_accum(3,mxlv) ! array used to accumulate pressure post-processing + ! info (PAN, PCL, PCS) for a single profile, across + ! profile levels + + real*8 qevn_accum(4,mxlv,mxnmev)! array used to accumulate moisture data/events for a + ! single profile, across profile levels + +, qbg_accum(3,mxlv) ! array used to accumulate moisture background info + ! (QOE, QFC, QFCMOD) for a single profile, across + ! profile levels + +, qpp_accum(3,mxlv) ! array used to accumulate moisture post-processing + ! info (QAN, QCL, QCS) for a single profile, across + ! profile levels + + real*8 tevn_accum(4,mxlv,mxnmev)! array used to accumulate temperature data/events + ! for a single profile, across profile levels + +, tbg_accum(3,mxlv) ! array used to accumulate temperature background + ! info (TOE, TFC, TFCMOD) for a single profile, + ! across profile levels + +, tpp_accum(3,mxlv) ! array used to accumulate temperature post- + ! processing info (TAN, TCL, TCS) for a single + ! profile, across profile levels + + real*8 zevn_accum(4,mxlv,mxnmev)! array used to accumulate altitude data/events for a + ! single profile, across profile levels + +, zbg_accum(3,mxlv) ! array used to accumulate altitude background info + ! (ZOE, ZFC, ZFCMOD) for a single profile, across + ! profile levels + +, zpp_accum(3,mxlv) ! array used to accumulate altitude post-processing + ! info (ZAN, ZCL, ZCS) for a single profile, across + ! profile levels + + real*8 wuvevn_accum(5,mxlv,mxnmev)! array used to accumulate wind data/events (u/v + ! components) for a single profile, across profile + ! levels + +, wuvbg_accum(5,mxlv) ! array used to accumulate wind background info (WOE, + ! UFC, VFC, UFCMOD, VFCMOD) for a single profile, + ! across profile levels + +, wuvpp_accum(6,mxlv) ! array used to accumulate wind post-processing info + ! (UAN, VAN, UCL, VCL, UCS, VCS) for a single + ! profile, across profile levels + + real*8 wdsevn_accum(5,mxlv,mxnmev)! array used to accumulate wind data/events + ! (direction/speed) for a single profile, across + ! profile levels + + character*11 c_qc_accum(mxlv) ! array used to accumulate NRLACQC quality information + ! on individual obs in a profile, across profile + ! levels + +c Logicals controlling processing (not read in from namelist in main program) +c --------------------------------------------------------------------------- + logical l_mandlvl ! T=interpolate to mandatory levels in profile + ! generation + ! F=do not interpolate to mandatory levels in profile + ! generation + logical tsplines ! T=use tension-splines for aircraft vertical velocity + ! calculation + ! F=use finite-differencing for aircraft vertical + ! velocity calculation + logical l_operational ! Run program in operational mode if true + +c Summary counters +c ---------------- + integer num_events_prof ! total number of events on an ob, across all levels, + ! across all reports, written in the PREPBUFR-like + ! (profiles) file (this value is the same for each + ! ob type) +c Mandatory levels settings +c ------------------------- + integer maxmandlvls ! maxmum number of mandatory pressure levels to + ! consider for aircraft profiles + +, mandlvls(maxmandlvls) ! list of mandatory pressure levels to consider for + ! aircraft profiles + +, nmandlvls ! number of mandatory levels interpolated for this + ! profile + +, nmNbtw ! number of mandatory levels between "bread of the + ! sandwich" reports + + character*8 mesgtype ! BUFR message type (e.g., 'AIRCFT ') + + real*8 acid1 ! aircraft flight number for the profile MDCRS or AMDAR + ! (LATAM only) report + +, acid_arr1 ! used with ufbint routine to encode aircraft flight + ! number (ACID) into MDCRS or AMDAR (LATAM only) + ! reports in output PREPBUFR-like file) + + character*9 c_acftid1 ! aircraft flight number (as processed by NRLACQC) + ! for the profile report (used for printing purposes + ! only) + + character*8 c_acftreg1 ! aircraft tail number (as processed by NRLACQC) + ! for the profile report (used for printing purposes + ! only) + + integer nlv2wrt_tot ! total number of levels to write in this profile, + ! including any interpolated mandatory levels + character*6 cnlv2wrt_tot ! character form of nlv2wrt_tot + + integer nlv2wrt ! number of levels in profile to write to output + character*6 cnlv2wrt ! character form of nlv2wrt + + integer nlvwrt ! number of levels written to output PREPBUFR-like + ! file + + real*8 pevns4(4,mxlv) ! array used with ufbint routine to encode pressure + ! events into output PREPBUFR-like file + +, qevns4(4,mxlv) ! array used with ufbint routine to encode moisture + ! events into output PREPBUFR-like file + +, tevns4(4,mxlv) ! array used with ufbint routine to encode temperature + ! events into output PREPBUFR-like file + +, zevns4(4,mxlv) ! array used with ufbint routine to encode altitude + ! events into output PREPBUFR-like file + +, wuvevns5(5,mxlv) ! array used with ufbint routine to encode wind (u/v + ! component) events into output PREPBUFR-like file + +, wdsevns5(5,mxlv) ! array used with ufbint routine to encode wind + ! (direction/speed) events into output PREPBUFR-like + ! file + +c For background/post-processing info +c ----------------------------------- + real*8 pbgarr3(3,mxlv) ! array used with ufbint routine to encode pressure + ! background info into output PREPBUFR-like file + +, qbgarr3(3,mxlv) ! array used with ufbint routine to encode moisture + ! background info into output PREPBUFR-like file + +, tbgarr3(3,mxlv) ! array used with ufbint routine to encode temperature + ! background info into output PREPBUFR-like file + +, zbgarr3(3,mxlv) ! array used with ufbint routine to encode altitude + ! background info into output PREPBUFR-like file + +, wuvbgarr5(5,mxlv) ! array used with ufbint routine to encode wind (u/v + ! component) background info into output PREPBUFR- + ! like file + +, ppparr3(3,mxlv) ! array used with ufbint routine to encode pressure + ! post-processing info into output PREPBUFR-like file + +, qpparr3(3,mxlv) ! array used with ufbint routine to encode moisture + ! post-processing info into output PREPBUFR-like file + +, tpparr3(3,mxlv) ! array used with ufbint routine to encode temperature + ! post-processing info into output PREPBUFR-like file + +, zpparr3(3,mxlv) ! array used with ufbint routine to encode altitude + ! post-processing info into output PREPBUFR-like file + +, wuvpparr6(6,mxlv) ! array used with ufbint routine to encode wind (u/v + ! component) info into output PREPBUFR-like file + +, drarr3(3,mxlv) ! array used with ufbint routine to encode drift info + ! into output PREPBUFR-like file + +, acft_seq_arr2(2,mxlv)! array used with ufbint routine to encode PCAT, POAF + ! into output PREPBUFR-like file + +, mstq_arr1(1,mxlv) ! array used with ufbint routine to encode moisture QC + ! flag into output PREPBUFR-like file + +, cat_arr1(1,mxlv) ! array used with ufbint routine to encode level + ! category info into output PREPBUFR-like file + +, rct_arr1(1,mxlv) ! array used with ufbint routine to encode level + ! receipt time info into output PREPBUFR-like file + +, ialr_arr1(1,mxlv) ! array used with ufbint routine to encode ascent/ + ! descent rate into output PREPBUFR-like file + +, turb_arr4(4,mxlv) ! array used with ufbint routine to encode turbulence + ! data into output PREPBUFR-like file + +C Arrays associated with sorting of data +c -------------------------------------- + integer iwork(mxlv) ! work array + +, iord(mxlv) ! array containing sorted index + +C Loop indices +c ------------ + integer i,j,k,l ! original (unsorted) indices + +, iii ! index + +, jj ! sorted (pressure low->high) index pointing to lvl j + +, jjp1 ! sorted index pointing to next level below jj + +, jjm1 ! sorted index pointing to previous level above jj + +, jjp2 ! sorted index pointing to next level below jjp1 + +, jjm2 ! sorted index pointing to previous level above jjm1 + +, jjmaxp ! sorted index pointing to level jj with max pressure + +, jjminp ! sorted index pointing to level jj with min pressure + +, jjpnmnbtw ! sorted index pointing to next level below jj that is + ! not a mandatory pressure level + +, jk ! index, + +, c1_jk ! index, + +, c2_jk ! index, + +, jkp ! index, + +, jkm ! index, + +, jjp ! index, + +, jjm ! index, + +, kk ! sorted (pressure low->high) index pointing to lvl k + +, jjpk ! sorted index pointing to level jj plus k + + real pul ! pressure ob at level "below" mandatory level (higher + ! pressure, lower altitude) + +, pll ! pressure ob at level "above" mandatory level (lower + ! pressure, higher altitude) + +, pqul ! pressure qm at level "below" mandatory level (higher + ! pressure, lower altitude) + +, pqll ! pressure qm at level "above" mandatory level (lower + ! pressure, higher altitude) + +, pml ! pressure ob at mandatory level + +, tul ! temperature ob at level "below" mandatory level + ! (higher pressure, lower altitude) + +, tll ! temperature ob at level "above" mandatory level + ! (lower pressure, higher altitude) + +, tqul ! temperature qm at level "below" mandatory level + ! (higher pressure, lower altitude) + +, tqll ! temperature qm at level "above" mandatory level + ! (lower pressure, higher altitude) + +, tml ! temperature ob at mandatory level + +, dt_dlnp ! change in temperature w.r.t. change in log-pressure + +, qul ! moisture ob at level "below" mandatory level (higher + ! pressure, lower altitude) + +, qll ! moisture ob at level "above" mandatory level (lower + ! pressure, higher altitude) + +, qqul ! moisture qm at level "below" mandatory level (higher + ! pressure, lower altitude) + +, qqll ! moisture qm at level "above" mandatory level (lower + ! pressure, higher altitude) + +, qml ! moisture ob at mandatory level + +, dq_dlnp ! change in moisture w.r.t. change in log-pressure + +, zul ! altitude ob at level "below" mandatory level (higher + ! pressure, lower altitude) + +, zll ! altitude ob at level "above" mandatory level (lower + ! pressure, higher altitude) + +, zqul ! altitude qm at level "below" mandatory level (higher + ! pressure, lower altitude) + +, zqll ! altitude qm at level "above" mandatory level (lower + ! pressure, higher altitude) + +, zml ! altitude ob at mandatory level + +, dz_dlnp ! change in altitude w.r.t. change in log-pressure + +, uul ! u-comp of wind ob at level "below" mandatory level + ! (higher pressure, lower altitude) + +, ull ! u-comp of wind ob at level "above" mandatory level + ! (lower pressure, higher altitude) + +, uml ! u-comp of wind ob at mandatory level + +, du_dlnp ! change in u-comp of wind w.r.t. change in + ! log-pressure + +, vul ! v-comp of wind ob at level "below" mandatory level + ! (higher pressure, lower altitude) + +, vll ! v-comp of wind ob at level "above" mandatory level + ! (lower pressure, higher altitude) + +, vml ! v-comp of wind ob at mandatory level + +, dv_dlnp ! change in v-comp of wind w.r.t. change in + ! log-pressure + +, uvqul ! u/v-comp of wind qm at level "below" mandatory level + ! (higher pressure, lower altitude) + +, uvqll ! u/v-comp of wind qm at level "above" mandatory level + ! (lower pressure, higher altitude) + + integer ibfms ! BUFRLIB function for testing for missing + + real*8 dtime_dlnp ! change in time w.r.t. change in log-pressure + + real dist_pul_pll ! horizontal distance traveled when going from point + ! at pll to pul + +, spd_pul_pll ! average speed while traveling from point at pll to + ! pul + +, dist2pml ! horizontal distance traveled when going from point + ! at pll to pml +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + +, lat_pul ! latitude at data level "below" mandatory level + ! (higher pressure, lower altitude) + +, lon_pul ! longitude at data level "below" mandatory level + ! (higher pressure, lower altitude) + +, lat_pll ! latitude at data level "above" mandatory level + ! (lower pressure, higher altitude) + +, lon_pll ! longitude at data level "above" mandatory level + ! (lower pressure, higher altitude) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + +, radius_e ! radius of the earth in meters + +, deg2rad ! conversion factor for converting degrees -> radians + + parameter(radius_e = 6371229.) + parameter(deg2rad = 3.14159274/180.) + + real*8 delx ! change in longitude/nmNbtw + +, dely ! change in latitude/nmNbtw + +, dt ! delta time (sec) between two levels, used to + ! calculate instantaneous altitude (ascent/descent) + ! rate + +, dt_new ! delta time + +, rate_accum(mxlv) ! array of instantaneous altitude (ascent/descent) + ! rates on all levels of profile + +c Variables used in printing values for a particular report and level +c ------------------------------------------------------------------- + integer ihdr2wrt9 ! PREPBUFR instrument type ("ITP" from header) + +, iacft_seq_accum2 ! temperature precision, and phase of flight + +, idrinfo_accum3 ! drift information + +, izevn_accum1 ! altitude ob + +, iwdsevn_accum1 ! wind direction ob + +, ipevn_accum2 ! pressure quality mark + +, izevn_accum2 ! altitude quality mark + +, itevn_accum2 ! temperature quality mark + +, iqevn_accum2 ! moisture quality mark + +, iwuvevn_accum3 ! wind quality mark + +, ipevn_accum4 ! pressure reason code + +, izevn_accum4 ! altitude reason code + +, itevn_accum4 ! temperature reason code + +, iqevn_accum4 ! moisture code + +, iwuvevn_accum5 ! wind reason code + +, nevents_t ! number of events on temperature + +, nevents_q ! number of events on moisture + +, nevents_w ! number of events on wind + +, imstq_accum1 ! moisture qc flag + +, icat_accum1 ! PREPBUFR level category ("CAT") + +, ihdr2wrt6 ! PREPBUFR report type ("TYP" from header) + + real*8 wspd ! wind speed ob + +, q_sphum ! moisture (specific humidity) ob + +, hdr2wrt1 ! real form of PREPBUFR report id ("SID" from header) + +c Misc. +c ----- + real nrlacqc_pc ! PREPBUFR program code for the NRLACQC step + + integer lwr ! machine word length in bytes (either 4 or 8) + +c Variables related to tspline + integer, parameter:: nit=30 +! real(dp),parameter:: bigT=120.0,halfgate=30.0,heps=.01 + real(dp),parameter:: bigT=120.0,heps=.01 + integer nh,nh2,m,mh,maxita,maxitb,maxit,maxrts,doru + integer err_tspline + real(dp) enbest,timemin + real(dp) halfgate + integer, allocatable :: idx(:) + integer, allocatable :: modebest(:) + integer, allocatable :: pof(:) + integer, allocatable :: hgts(:) + integer, allocatable :: hgtp(:) + real, allocatable :: tdata(:),hdata(:),wdata(:) + real(dp), allocatable :: te(:),hs(:),dhdt(:) + real(dp), allocatable :: hp(:) + real(dp), allocatable :: qbest(:),habest(:) + logical descending,FF,nearsec + +c ---------------------------------------------------- + +c Start program +c ------------- +ccc print *, 'in sub2mem_mer for the next merged report' + + rate_accum = bmiss + + if(nlvinprof.eq.0) then + print * + print *, '### PROBLEM - into subr, sub2mem_mer with nlvinprof ', + + '= ',0 + print *, ' this should never happen!!' + print * + call w3tage('PREPOBS_PREPACQC') + call errexit(59) + endif + +c First sort pressures from lowest to highest, this will also determine the maximum and +c minimum pressure values in this profile +c ------------------------------------------------------------------------------------- + call orders(1,iwork,lvlsinprof,iord,nlvinprof,1,lwr,2) + +ccc print *, '.. there are originally ',nlvinprof,' p-levels in this', +ccc + ' report' + +c Interpolate z,t,q,u,v values to mandatory levels - include the levels of 1000, 850, 700, +c 500, 400, 300, 200, 150 and 100 mb in the acceptable mandatory levels for aircraft +c profiles (not many aircraft flying above 100 mb!) +c --------------------------------------------------------------------------------------- + nmandlvls = 0 + nlv2wrt_tot = nlvinprof + + if(l_mandlvl .and. nlvinprof.gt.1) then ! do interpolation only for profiles with + ! more than one report! + loop1: do i = 1,maxmandlvls ! maxmandlvls=9 - number of mandatory levels to check + do j = 1,nlvinprof ! levels will appear in increasing order via index + ! jj... first level might be 247 mb, second might be + ! 427 mb, etc. + jj = iord(j) + jjp1 = iord(j+1) + + if(j.lt.nlvinprof) then ! exclude last level in profile (one closest to the + ! ground) (use .lt. instead of .le. to do this); only + ! interpolate for mandatory levels sandwiched by + ! actual data + +c Below, jj points to level at a lower pressure/higher altitude and jjp1 points to the +c adjacent level at a higher pressure, lower altitude) +c ------------------------------------------------------------------------------------ + if(lvlsinprof(jj) .lt.mandlvls(i) .and. + + lvlsinprof(jjp1).gt.mandlvls(i)) then + + if(nlvinprof+nmandlvls+1.gt.mxlv) then +C....................................................................... +C There are more levels in profile than "mxlv" -- do not process any more levels +C ------------------------------------------------------------------------------ + print 53, mxlv,mxlv + 53 format(/' #####> WARNING: THERE ARE MORE THAN ',I6,' LEVELS IN ', + + 'THIS PROFILE -- WILL CONTINUE ON PROCESSING ONLY ',I6,' LEVELS', + + ' FOR THIS PROFILE'/) + write(cmxlv,'(i6)') mxlv + call system('[ -n "$jlogfile" ] && $DATA/postmsg'// + + ' "$jlogfile" "***WARNING:'//cmxlv//' AIRCRAFT '// + + 'PROFILE LEVEL LIMIT EXCEEDED IN '// + + 'PREPOBS_PREPACQC, ONLY '//cmxlv//' LEVELS '// + + 'PROCESSED"') + exit loop1 +C....................................................................... + endif + + nmandlvls = nmandlvls + 1 + +c Now calculate values on mandlvls(i) using values at lvlsinprof(j) (ll/lower level and (j+1) +c (ul/upper level) - USE REASON CODE 98 FOR INTERPOLATED MANDATORY LEVELS (use highest +c quality mark amongst lower and upper levels) +c ------------------------------------------------------------------------------------------- + pll = lvlsinprof(jj) ! pressure ob at level "above" mandatory level + pul = lvlsinprof(jjp1) ! pressure ob at level "below" mandatory level + pqll = pevn_accum(2,jj,1) ! pressure qm at level "above" mandatory level + pqul = pevn_accum(2,jjp1,1) ! pressure qm at level "below" mandatory level + pml = mandlvls(i) ! pressure at mandatory level + + lvlsinprof(nlvinprof+nmandlvls) = mandlvls(i) + pevn_accum(1,nlvinprof+nmandlvls,1) = pml/10. ! POB + pevn_accum(2,nlvinprof+nmandlvls,1) = max(pqll,pqul) ! PQM + pevn_accum(3,nlvinprof+nmandlvls,1) = nrlacqc_pc ! PPC + pevn_accum(4,nlvinprof+nmandlvls,1) = 98 ! PRC + + cat_accum(1,nlvinprof+nmandlvls) = 7 ! interpolated mand. levels get CAT = 7 + +c Temperature +c ----------- + if(ibfms(tevn_accum(1,jj,1)).eq.0 .and. + + ibfms(tevn_accum(1,jjp1,1)).eq.0 ) then ! temperature isn't missing + do iii = mxe4prof,1,-1 + if(ibfms(tevn_accum(1,jj,iii)).ne.0) then + nevents_t = iii + else + nevents_t = iii + exit + endif + enddo + tll = tevn_accum(1,jj,nevents_t) ! temp ob at lvl "above" mandatory level + tqll = tevn_accum(2,jj,nevents_t) ! temp qm at lvl "above" mandatory level + do iii = mxe4prof,1,-1 + if(ibfms(tevn_accum(1,jjp1,iii)).ne.0) then + nevents_t = iii + else + nevents_t = iii + exit + endif + enddo + tul = tevn_accum(1,jjp1,nevents_t) ! temp ob at lvl "below" mandatory level + tqul = tevn_accum(2,jjp1,nevents_t) ! temp qm at lvl "below" mandatory level +ccccc print *, 'pmd, pll, pul, tqll,tqul: ',pml, pll, pul, +ccccc+ tqll,tqul + + dt_dlnp = (tul - tll)/alog(pul/pll) + + tml = tll + (dt_dlnp * (alog(pml/pll))) + + tevn_accum(1,nlvinprof+nmandlvls,1) = tml ! TOB + tevn_accum(2,nlvinprof+nmandlvls,1) = max(tqll,tqul) ! TQM + tevn_accum(3,nlvinprof+nmandlvls,1) = nrlacqc_pc ! TPC + tevn_accum(4,nlvinprof+nmandlvls,1) = 98 ! TRC + + endif ! temps missing? + +c Moisture +c -------- + if(ibfms(qevn_accum(1,jj,1)).eq.0 .and. + + ibfms(qevn_accum(1,jjp1,1)).eq.0 ) then ! moisture isn't missing + do iii = mxe4prof,1,-1 + if(ibfms(qevn_accum(1,jj,iii)).ne.0) then + nevents_q = iii + else + nevents_q = iii + exit + endif + enddo + qll = qevn_accum(1,jj,nevents_q) ! q ob at level "above" mandatory level + qqll = qevn_accum(2,jj,nevents_q) ! q qm at level "above" mandatory level + do iii = mxe4prof,1,-1 + if(ibfms(qevn_accum(1,jjp1,iii)).ne.0) then + nevents_q = iii + else + nevents_q = iii + exit + endif + enddo + qul = qevn_accum(1,jjp1,nevents_q) ! q ob at level "below" mandatory level + qqul = qevn_accum(2,jjp1,nevents_q) ! q qm at level "below" mandatory level + + dq_dlnp = (qul - qll)/alog(pul/pll) + + qml = qll + (dq_dlnp * (alog(pml/pll))) + + qevn_accum(1,nlvinprof+nmandlvls,1) = qml ! QOB + qevn_accum(2,nlvinprof+nmandlvls,1) = max(qqll,qqul) ! QQM + qevn_accum(3,nlvinprof+nmandlvls,1) = nrlacqc_pc ! QPC + qevn_accum(4,nlvinprof+nmandlvls,1) = 98 ! QRC + + else ! if moisture missing, check to see if QFC is present for "bread" + ! levels; if so, interpolate QFC + if(ibfms(qbg_accum(2,jj)).eq.0 .and. + + ibfms(qbg_accum(2,jjp1)).eq.0 ) then ! QFC isn't missing for "bread" + ! levels + qll = qbg_accum(2,jj) ! QFC at ob level "above" mandatory level + qul = qbg_accum(2,jjp1) ! QFC at ob level "below" mandatory level + + dq_dlnp = (qul - qll)/alog(pul/pll) + + qml = qll + (dq_dlnp * (alog(pml/pll))) + + qbg_accum(2,nlvinprof+nmandlvls) = qml ! QFC + + endif ! is QFC present for "bread" levels when moisture missing? + endif ! moisture missing? + +c Altitude +c -------- + if(ibfms(zevn_accum(1,jj,1)).eq.0 .and. + + ibfms(zevn_accum(1,jjp1,1)).eq.0 ) then ! altitude isn't missing + zll = zevn_accum(1,jj,1) ! z ob at level "above" mandatory level + zul = zevn_accum(1,jjp1,1) ! z ob at level "below" mandatory level + zqll = zevn_accum(2,jj,1) ! z qm at level "above" mandatory level + zqul = zevn_accum(2,jjp1,1) ! z qm at level "below" mandatory level + + dz_dlnp = (zul - zll)/alog(pul/pll) + + zml = zll + (dz_dlnp * (alog(pml/pll))) + + zevn_accum(1,nlvinprof+nmandlvls,1) = zml ! ZOB + zevn_accum(2,nlvinprof+nmandlvls,1) = max(zqll,zqul) ! ZQM + zevn_accum(3,nlvinprof+nmandlvls,1) = nrlacqc_pc ! ZPC + zevn_accum(4,nlvinprof+nmandlvls,1) = 98 ! ZRC + + endif ! altitude missing? + +c u- and v- components of wind +c ---------------------------- + if(ibfms(wuvevn_accum(1,jj,1)).eq.0 .and. + + ibfms(wuvevn_accum(1,jjp1,1)).eq.0 .and. + + ibfms(wuvevn_accum(2,jj,1)).eq.0 .and. + + ibfms(wuvevn_accum(2,jjp1,1)).eq.0) then ! u and v aren't missing + do iii = mxe4prof,1,-1 + if(ibfms(wuvevn_accum(1,jj,iii)).ne.0 .or. + + ibfms(wuvevn_accum(2,jj,iii)).ne.0) then + nevents_w = iii + else + nevents_w = iii + exit + endif + enddo + ull = wuvevn_accum(1,jj,nevents_w) ! UOB ob at lvl "above" mandatory lvl + vll = wuvevn_accum(2,jj,nevents_w) ! VOB ob at lvl "above" mandatory lvl + uvqll = wuvevn_accum(3,jj,nevents_w) ! UOB/VOB qm at lvl "above" mandatory + ! lvl + do iii = mxe4prof,1,-1 + if(ibfms(wuvevn_accum(1,jjp1,iii)).ne.0 .or. + + ibfms(wuvevn_accum(2,jjp1,iii)).ne.0) then + nevents_w = iii + else + nevents_w = iii + exit + endif + enddo + uul = wuvevn_accum(1,jjp1,nevents_w) ! UOB ob at lvl "below" mandatory lvl + vul = wuvevn_accum(2,jjp1,nevents_w) ! VOB ob at lvl "below" mandatory lvl + uvqul = wuvevn_accum(3,jjp1,nevents_w) ! UOB/VOB qm at lvl "below" mandatory + ! lvl + + du_dlnp = (uul - ull)/alog(pul/pll) + dv_dlnp = (vul - vll)/alog(pul/pll) + + uml = ull + (du_dlnp * (alog(pml/pll))) + vml = vll + (dv_dlnp * (alog(pml/pll))) + + wuvevn_accum(1,nlvinprof+nmandlvls,1) = uml ! UOB + wuvevn_accum(2,nlvinprof+nmandlvls,1) = vml ! VOB + wuvevn_accum(3,nlvinprof+nmandlvls,1) = + + max(uvqll,uvqul) ! WQM + wuvevn_accum(4,nlvinprof+nmandlvls,1) = nrlacqc_pc ! WPC + wuvevn_accum(5,nlvinprof+nmandlvls,1) = 98 ! WRC + + endif ! wind missing? + + endif ! calc values for this mandatory level? + endif ! j.lt.nlvinprof + enddo ! j = 1,nlvinprof + enddo loop1 ! i = 1,maxmandlvls + + nlv2wrt_tot = nlvinprof + nmandlvls +ccc print'(" .. there are eventually ",I0," p-levels in this ", +ccc + "report (incl. mand. levels to which obs interp. to)")', +ccc + nlv2wrt_tot + +c Re-sort pressures (now with mandatory levels inclded) from lowest to highest +c ---------------------------------------------------------------------------- + call orders(1,iwork,lvlsinprof,iord,nlv2wrt_tot,1,lwr,2) + + end if ! l_mandlvl .and. nlvinprof.gt.1 + +c ----------------------------------------- +c Calculate vertical velocity rate_accum +c add ascent/descent rate here +c ----------------------------------------- + write(41,*) 'nlv2wrt_tot=', nlv2wrt_tot,'c_acftreg=',c_acftreg1 + err_tspline = 0 + + if ((nlv2wrt_tot.gt.1) .and. tsplines) then + nh = 0 + do j = 1,nlv2wrt_tot + jj = iord(j) + if (ibfms(drinfo_accum(3,jj)).eq.0) then + nh = nh + 1 +c write(41,*) 'j,ord,z,t=', j, jj,zevn_accum(1,jj,1), +c + drinfo_accum(3,jj) + end if + end do + nh2 = nh * 2 + + halfgate=30.0 +! nearsec=.false. +! do j = 1,nlv2wrt_tot +! jj = iord(j) +! if (ibfms(drinfo_accum(3,jj)).eq.0) then +! timemin=drinfo_accum(3,jj)*60.0 +! timemin=abs(timemin-nint(timemin)) +! if (timemin>=0.01 .and. timemin<=0.99) nearsec=.true. +! end if +! end do +! if (nearsec) halfgate=10.0 + write(41,*) 'halfgate=', halfgate + + allocate(idx(nh),pof(nh)) + allocate(tdata(nh),hdata(nh),wdata(nh)) + allocate(te(nh),hgts(nh),hs(nh),dhdt(nh)) + maxita = 0 + maxitb = 0 + maxrts = 0 + maxit = 0 + + nh = 0 + do j = 1,nlv2wrt_tot + jj = iord(j) + if (ibfms(drinfo_accum(3,jj)).eq.0) then + nh = nh + 1 + tdata(nh) = drinfo_accum(3,jj) ! hours + hdata(nh) = zevn_accum(1,jj,1) ! meters + pof(nh) = nint(acft_seq_accum(2,jj)) + write(41,*) 'tdata,hdata,pof=',nh,tdata(nh),hdata(nh), + + pof(nh) + end if + end do + +c arrange data with time increase + call convertd(nh,halfgate,tdata,hdata,pof, + + doru,idx,hgts,hs,descending,FF) +!!!!!!!! if (FF) call w3tage('PREPOBS_PREPACQC') +!!!!!!!! if (FF) call errexit(62) + if (FF) then +c Error generating vertical velocity rate in tension-spline interpolation utility pspl +c (coming out of subroutine convertd) - use finite difference method +c ------------------------------------------------------------------------------------ + print*,"WARNING: tspline err in utility pspl, coming out ", + + "of subr. convertd - use finite difference method" + write(41,*)"WARNING: tspline err in utility pspl, coming ", + + "out of subr. convertd - use finite difference ", + + "method" + err_tspline = 1 + go to 666 + end if + if (descending)then + write(41,'('' set descending'')') + else + write(41,'('' set ascending'')') + endif + + call count_gates(nh,hgts(1:nh),mh) + m = mh*2 + allocate(hgtp(m),hp(m),qbest(m),habest(m),modebest(mh)) + call best_slalom(nh,mh,doru,hgts,hs,halfgate,bigT,hgtp,hp, + + qbest,habest,enbest,modebest,maxita,maxitb,maxit,maxrts,FF) + write(41,*) 'maxita,maxitb,maxit,maxrts=',maxita,maxitb,maxit, + + maxrts +!!!!!!!! if (FF) call w3tage('PREPOBS_PREPACQC') +!!!!!!!! if (FF) call errexit(63) + if (FF) then +c Error generating vertical velocity rate in tension-spline interpolation utility pspl +c (coming out of subroutine best_slalom) - use finite difference method +c ------------------------------------------------------------------------------------ + print*,"WARNING: tspline err in utility pspl, coming out ", + + "of subr. best_slalom - use finite difference method" + write(41,*)"WARNING: tspline err in utility pspl, coming ", + + "out of subr. best_slalom - use finite ", + + "difference method" + err_tspline = 1 + go to 666 + end if + +c Use bounded Newton iterations to estimate the vertical velocity + call bnewton(nh,m,bigT,halfgate,hgts,hs,hgtp,habest, + + qbest,te(1:nh),dhdt(1:nh),FF) +!!!!!!!! if (FF) call w3tage('PREPOBS_PREPACQC') +!!!!!!!! if (FF) call errexit(64) + if (FF) then +c Error generating vertical velocity rate in tension-spline interpolation utility pspl +c (coming out of subroutine bnewton) - use finite difference method +c ------------------------------------------------------------------------------------ + print*,"WARNING: tspline err in utility pspl, coming out ", + + "of subr. bnewton - use finite difference method" + write(41,*)"WARNING: tspline err in utility pspl, coming ", + + "out of subr. bnewton - use finite difference ", + + "method" + err_tspline = 1 + go to 666 + end if + +c convert back data with time decrease for ascending + call convertd_back(nh,halfgate,wdata,tdata,dhdt,hgts,idx, + + descending) + do j = 1, nh + write(41,*) 'hgts,hs,dhdt,wdata=', j,hgts(j),hs(j),dhdt(j), + + wdata(j) + end do + +c Encode dhdt into PREPBUFR-like file as IALR + nh = 0 + do j = 1,nlv2wrt_tot + jj = iord(j) + if (ibfms(drinfo_accum(3,jj)).eq.0) then + nh = nh + 1 + rate_accum(jj) = wdata(nh) + write(41,*) 'j,z,rate=',j,zevn_accum(1,jj,1), + + rate_accum(jj) + end if + end do + + 666 continue + + if(allocated(idx)) deallocate(idx) + if(allocated(pof)) deallocate(pof) + if(allocated(tdata)) deallocate(tdata) + if(allocated(hdata)) deallocate(hdata) + if(allocated(wdata)) deallocate(wdata) + if(allocated(te)) deallocate(te) + if(allocated(hgts)) deallocate(hgts) + if(allocated(hs)) deallocate(hs) + if(allocated(dhdt)) deallocate(dhdt) + if(allocated(hgtp)) deallocate(hgtp) + if(allocated(hp)) deallocate(hp) + if(allocated(qbest)) deallocate(qbest) + if(allocated(habest)) deallocate(habest) + if(allocated(modebest)) deallocate(modebest) + end if ! nlv2wrt_tot.gt.1 .and. tsplines + + if (((nlv2wrt_tot.gt.1) .and. (.not.tsplines)) + + .or. err_tspline>0) then + do j = 1,nlv2wrt_tot + jj = iord(j) + write(41,*) 'j,ord,z,t,pof=', j, jj,zevn_accum(1,jj,1), + + drinfo_accum(3,jj),acft_seq_accum(1,jj),acft_seq_accum(2,jj) + end do + + do j = 1,nlv2wrt_tot + jj = iord(j) + + jkp = 0 + jkm = 0 + jjp1 = 0 + jjm1 = 0 + if (j .eq. nlv2wrt_tot) then + if (ibfms(drinfo_accum(3,jj)).eq.0) then + jjp1 = jj + jkp = j + end if + else + do jk = j+1,nlv2wrt_tot + jjp = iord(jk) + if (jjp > nlvinprof) cycle + if (ibfms(drinfo_accum(3,jjp)).eq.0) then + jjp1 = jjp + jkp = jk + exit + end if + end do + end if + + if (j .eq. 1 ) then + if (ibfms(drinfo_accum(3,jj)).eq.0) then + jjm1 = jj + jkm = j + end if + else + do jk = j-1,1,-1 + jjm = iord(jk) + if (jjm > nlvinprof) cycle ! use real obs only + if (ibfms(drinfo_accum(3,jjm)).eq.0) then + jjm1 = jjm + jkm = jk + exit + end if + end do + end if + + if ((jjp1 .ne. 0) .and. (jjm1 .ne. 0)) then + dt = (drinfo_accum(3,jjp1) - drinfo_accum(3,jjm1))*3600. ! seconds + + c1_jk = 0 + c2_jk = 0 + do while ((abs(dt)<60.) .and. ((jkp+c1_jk<=nlv2wrt_tot) + + .or. (jkm-c2_jk>=1))) + jjp2 = 0 + jjm2 = 0 + c1_jk = c1_jk+1 + c2_jk = c2_jk+1 + dt_new = dt + + do while (jkp+c1_jk<=nlv2wrt_tot + + .and. iord(jkp+c1_jk)>nlvinprof) + c1_jk = c1_jk+1 ! skip mandatory level + end do + if (jkp+c1_jk<=nlv2wrt_tot + + .and. iord(jkp+c1_jk)<=nlvinprof) then + jjp = iord(jkp+c1_jk) + if (ibfms(drinfo_accum(3,jjp)).eq.0) then + jjp2 = jjp + dt_new = (drinfo_accum(3,jjp2) + + - drinfo_accum(3,jjm1))*3600. + end if + end if + if (abs(dt_new) >= 60.) then + if (jjp2 .ne. 0) jjp1 = jjp2 + exit + end if + + do while (jkm-c2_jk>=1 .and. iord(jkm-c2_jk)>nlvinprof) + c2_jk = c2_jk+1 ! skip mandatory level + end do + if (jkm-c2_jk>=1 .and. iord(jkm-c2_jk)<=nlvinprof) then + jjm = iord(jkm-c2_jk) + if (ibfms(drinfo_accum(3,jjm)).eq.0) then + jjm2 = jjm + dt_new = (drinfo_accum(3,jjp1) + + - drinfo_accum(3,jjm2))*3600. + end if + end if + if (abs(dt_new) >= 60.) then + if (jjm2 .ne. 0) jjm1 = jjm2 + exit + end if + + if ((jjp2 .ne. 0) .and. (jjm2 .ne. 0)) then + dt_new = (drinfo_accum(3,jjp2) + + - drinfo_accum(3,jjm2))*3600. + if (abs(dt_new) >= 60.) then + if (jjp2 .ne. 0) jjp1 = jjp2 + if (jjm2 .ne. 0) jjm1 = jjm2 + exit + end if + end if + end do + dt = (drinfo_accum(3,jjp1) - drinfo_accum(3,jjm1))*3600. + +c write(41,*)' fj,ord1,z1,t1 = ',j,jjp1,zevn_accum(1,jjp1,1), +c + drinfo_accum(3,jjp1) +c write(41,*)' fj,ord2,z2,t2 = ',j,jjm1,zevn_accum(1,jjm1,1), +c + drinfo_accum(3,jjm1) + zul = zevn_accum(1,jjp1,1) ! meters + zll = zevn_accum(1,jjm1,1) ! meters + +c Need gross checks on ascent/descent rate here? + if(abs(dt) .gt. 0.) ! added to avoid divide by zero + + rate_accum(jj) = (zul - zll)/dt ! m/s + ! will be encoded into + ! PREPBUFR-like file as IALR + + write(41,*) ' fj,dt,rate_accum=',j,dt,rate_accum(jj) + write(41,*) '' + end if + end do + end if ! ((nlv2wrt_tot.gt.1) .and. (.not.tsplines)) .or. err_tspline>0 + +c Interpolate position and time to mandatory level (will be stored in XDR YDR HRDR) (need to +c have mandatory levels inserted into the profile before this step) +c ------------------------------------------------------------------------------------------ + if (l_mandlvl .and. nlvinprof.gt.1) then + +ccccccc print *, ' nlv2wrt_tot = ',nlv2wrt_tot + do j = 1,nlv2wrt_tot + jj = iord(j) +ccccccc print *, ' j,jj = ',j,jj + + nmNbtw = 0 ! reset 'number of mandatory levels in-between' counter +c------------------------------------------------------------------------------------------ +c------------------------------------------------------------------------------------------ +! (DAK: verified that logic below gives the correct answer - good news!) + if(ibfms(drinfo_accum(1,jj)).ne.0 .and. + + ibfms(drinfo_accum(2,jj)).ne.0 .and. + + ibfms(drinfo_accum(3,jj)).ne.0) then ! all obs in drift sequence missing likely + ! means this is a mandatory level for + ! which these obs must be filled via + ! interpolation + nmNbtw = 1 ! set 'number of mandatory levels in-between' counter to 1 +ccccc print *, 'here is a first mand. level - p = ',lvlsinprof(jj) + +c see if there is more than one mandatory level in a row for which we need to calculate XDR, +c YDR and HRDR values +c ------------------------------------------------------------------------------------------ + do k = j+1, nlv2wrt_tot +ccccccc print *, ' k = ',k + kk = iord(k) + if(ibfms(drinfo_accum(1,kk)).ne.0 .and. + + ibfms(drinfo_accum(2,kk)).ne.0 .and. + + ibfms(drinfo_accum(3,kk)).ne.0) then ! another mandatory levelw/ missing + ! XDR, YDR and HRDR + nmNbtw = nmNbtw + 1 ! increment 'number of mandatory levels in-between' + ! counter by 1 + +ccccc print *, 'here is ANOTHER adjacent MANDATORY LEVEL - ', +ccccc+ 'p =',lvlsinprof(kk) +ccccc print *, 'nmNbtw = ',nmNbtw + else + exit ! exit k loop + endif + enddo + +c At this point, nmNbtw is the number of mandatory levels in a row w/ missing XDR, YDR and +c HRDR - ow we need to determine the "bread" levels; in other words, levels with real, non- +c interpolated data, that sandwich the mandatory levels - below, jj points to the mandatory +c level, jjm1 points to the "bread" level with actual data at the lower pressure/higher +c altitude and jjpnmNbtw points to the "bread" level with actual data at a higher pressure/ +c lower altitude +c ------------------------------------------------------------------------------------------ + if(j.le.1) then +c DAK: Make sure j is > 1 here !! (not sure it can ever happen) + print * + print *, '### PROBLEM - j .le. 1 (= ',j,') in subr. ', + + 'sub2mem_mer, iord array underflow' + print *, ' this should never happen!!' + print * + call w3tage('PREPOBS_PREPACQC') + call errexit(61) + endif + jjm1 = iord(j-1) + jjpnmNbtw = iord(j+nmNbtw) + pll = lvlsinprof(jjm1) + pul = lvlsinprof(jjpnmNbtw) + +c Interpolate lat/lon/time to mandatory levels +c -------------------------------------------- + +c Determine dtime/dlnp, total horizontal distance covered between the two points, and average +c groundspeed of aircraft between the points +c ------------------------------------------------------------------------------------------- + dtime_dlnp = (drinfo_accum(3,jjpnmNbtw) - + + drinfo_accum(3,jjm1)) / alog(pul/pll) + +c Use Haversine formula to determine distance, given two lat/lons (the same formula is used +c in the acftobs_qc/gcirc_qc routine and more information is available at +c http://www.movable-type.co.uk/scripts/GIS-FAQ-5.1.html) +c ----------------------------------------------------------------------------------------- + lat_pul = drinfo_accum(2,jjpnmNbtw) + lon_pul = drinfo_accum(1,jjpnmNbtw) + lat_pll = drinfo_accum(2,jjm1) + lon_pll = drinfo_accum(1,jjm1) + + if(int(lon_pul*100.).eq.int(lon_pll*100.)) then + dist_pul_pll = radius_e * abs(lat_pul-lat_pll) * deg2rad + elseif(int(lat_pul*100.).eq.int(lat_pll*100.)) then + dist_pul_pll = 2.0*radius_e* + + asin(min(1.0,abs(cos(lat_pul*deg2rad)* + + sin((lon_pul-lon_pll)*0.5*deg2rad)))) + else + dist_pul_pll = 2.0*radius_e* + + asin(min(1.0,sqrt( + + (sin((lat_pul-lat_pll)*0.5*deg2rad))**2 + + + cos(lat_pul*deg2rad)* + + cos(lat_pll*deg2rad)* + + (sin((lon_pul-lon_pll)*0.5*deg2rad))**2 + + ) + + ) + + ) + endif + +c Check if times are equal, then interpolate lat/lon - assume aircraft is traveling at a +c constant speed between the locations where pul and pll are observed +c -------------------------------------------------------------------------------------- + if(int(drinfo_accum(3,jjpnmNbtw)*100000.).ne. + + int(drinfo_accum(3,jjm1)*100000.) .and. + + dist_pul_pll.ne.0.) then + + spd_pul_pll = dist_pul_pll / + + abs((drinfo_accum(3,jjpnmNbtw) - + + drinfo_accum(3,jjm1))*3600.) + + do k = 0,nmNbtw-1 +ccccccc print *, ' k 2 = ',k + jjpk = iord(j+k) + pml = lvlsinprof(jjpk) + +c time + drinfo_accum(3,jjpk) = drinfo_accum(3,jjm1) + + + dtime_dlnp*alog(pml/pll) + + dist2pml = spd_pul_pll * + + abs(drinfo_accum(3,jjpk)-drinfo_accum(3,jjm1))* + + 3600. ! sec/hour... drinfo_accum(3,x) values are in hours + +c latitude + drinfo_accum(2,jjpk) = drinfo_accum(2,jjm1) + + + dist2pml/dist_pul_pll* + + (drinfo_accum(2,jjpnmNbtw)-drinfo_accum(2,jjm1)) + +c longitude + drinfo_accum(1,jjpk) = drinfo_accum(1,jjm1) + + + dist2pml/dist_pul_pll* + + (drinfo_accum(1,jjpnmNbtw)-drinfo_accum(1,jjm1)) + + enddo + else ! times are equal; assume groundspeed varies linearly -- or, dist_pul_pll=0 + ! and lat/lons of pul and pll are either equal or very very close + +c Determine delx, y +c ----------------- + delx = (drinfo_accum(1,jjpnmNbtw) - + + drinfo_accum(1,jjm1))/(nmNbtw+1) + dely = (drinfo_accum(2,jjpnmNbtw) - + + drinfo_accum(2,jjm1))/(nmNbtw+1) + +c Store interpolated lat/lon/time values for the levels that need it +c ------------------------------------------------------------------ + do k = 0,nmNbtw-1 +ccccccc print *, ' k 3 = ',k + jjpk = iord(j+k) + pml = lvlsinprof(jjpk) + drinfo_accum(1,jjpk) = + + drinfo_accum(1,jjm1) + (k+1)*delx + drinfo_accum(2,jjpk) = + + drinfo_accum(2,jjm1) + (k+1)*dely + drinfo_accum(3,jjpk) = drinfo_accum(3,jjm1) + + + dtime_dlnp*alog(pml/pll) ! if times are equal, + ! dtime_dlnp =0, and then + ! time at pml = time at pll + +cc drinfo_accum(3,jj) = +cc + drinfo_accum(3,jjpnmNbtw) ! give pml the same time as pul and pll + + enddo + endif ! times of "bread" levels equal? + endif ! need to interpolate for mandatory level ? +! (DAK: verified that above below gives the correct answer - good news!) +c------------------------------------------------------------------------------------------ +c------------------------------------------------------------------------------------------ + enddo ! j = 1,nlv2wrt_tot + endif ! l_mandlvl .and. nlvinprof.gt.1 + +c Set TYP to reflect whether or not report is part of a profile, ascending or descending +c -------------------------------------------------------------------------------------- + jjmaxp = iord(nlv2wrt_tot) + jjminp = iord(1) + if(nlv2wrt_tot.eq.1) then + hdr2wrt(6) = 300 + mod(int(hdr2wrt(6)),100) ! TYP = 3xx for single level merged + ! (mass + wind) reports + elseif(nlv2wrt_tot.gt.1 .and. + + (c_qc_accum(jjmaxp)(11:11).eq.'a' .or. + + c_qc_accum(jjmaxp)(11:11).eq.'A')) then ! ascending profile (merged) + hdr2wrt(6) = 400 + mod(int(hdr2wrt(6)),100) ! TYP = 4xx for ascending profile + ! merged (mass + wind) reports + +c Make sure the header information for the ascent is the coordinates, etc, present at the +c "launch" level (highest pressure/lowest altitude) +c --------------------------------------------------------------------------------------- + hdr2wrt(2) = drinfo_accum(1,jjmaxp) + hdr2wrt(3) = drinfo_accum(2,jjmaxp) + hdr2wrt(4) = drinfo_accum(3,jjmaxp) + hdr2wrt(5) = elv_accum(1,jjmaxp) + hdr2wrt(12) = rpt_accum(1,jjmaxp) + hdr2wrt(13) = tcor_accum(1,jjmaxp) + + elseif(nlv2wrt_tot.gt.1 .and. + + (c_qc_accum(jjmaxp)(11:11).eq.'d' .or. + + c_qc_accum(jjmaxp)(11:11).eq.'D')) then ! descending profile (merged) + hdr2wrt(6) = 500 + mod(int(hdr2wrt(6)),100) ! TYP = 5xx for descending profile + ! merged (mass + wind) reports + +c Make sure the header information for the descent is the coordinates, etc., present at the +c "launch" level (lowest pressure/highest altitude) +c ----------------------------------------------------------------------------------------- + hdr2wrt(2) = drinfo_accum(1,jjminp) + hdr2wrt(3) = drinfo_accum(2,jjminp) + hdr2wrt(4) = drinfo_accum(3,jjminp) + hdr2wrt(5) = elv_accum(1,jjminp) + hdr2wrt(12) = rpt_accum(1,jjminp) + hdr2wrt(13) = tcor_accum(1,jjminp) + + endif +ccc print *, '.. the report type here is ',hdr2wrt(6) + +c Set SQN/PROCN to missing for profiles +c ------------------------------------- + hdr2wrt(10) = bmiss + hdr2wrt(11) = bmiss + +c Write header info/metadata +c -------------------------- + call ufbint(proflun,hdr2wrt,15,1,nlvwrt, + + 'SID XOB YOB DHR ELV TYP T29 TSB ITP SQN PROCN RPT TCOR '// + + 'RSRD EXPRSRD') + + acid_arr1 = acid1 + if(ibfms(acid1).eq.0) + + call ufbint(proflun,acid_arr1,1,1,nlvwrt,'ACID') ! store 'ACID' if present + ! {currently only in MDCRS or AMDAR + ! (LATAM only) reports} + + if(mesgtype.ne.'AIRCAR'.and. mesgtype.ne.'AIRCFT') then + print *, 'Non-compatible message type! (',mesgtype,')' + print *, 'Skipping this report; it will not be written to ', + + 'output.' + go to 9999 + endif + +ccc print *, 'FOR THIS REPORT: mxe4prof = ',mxe4prof + +c ------------------------------------- +c Process each event set, one at a time +c ------------------------------------- + do i = 1,mxe4prof ! maximum number of events in a single-level merged report (i.e., the + ! maximum amongst the number of pressure, moisture,temperature, + ! altitude, u/v wind and direction/speed wind events) +ccc print *, '.. bring in next event for writing out' +ccc print *, 'Next event is number ',i + +c Clear out arrays used with ufbint to store data in memory +c --------------------------------------------------------- + nlv2wrt = 0 + + pevns4 = bmiss + qevns4 = bmiss + tevns4 = bmiss + zevns4 = bmiss + wuvevns5 = bmiss + wdsevns5 = bmiss + + pbgarr3 = bmiss + qbgarr3 = bmiss + tbgarr3 = bmiss + zbgarr3 = bmiss + wuvbgarr5 = bmiss + + ppparr3 = bmiss + qpparr3 = bmiss + tpparr3 = bmiss + zpparr3 = bmiss + wuvpparr6 = bmiss + + drarr3 = bmiss + + acft_seq_arr2 = bmiss + + mstq_arr1 = bmiss + rct_arr1 = bmiss + cat_arr1 = bmiss + ialr_arr1 = bmiss + turb_arr4 = bmiss + +c Collapse stacks of events; keep levels where there is pressure data - do this in +c anticipation of "striping"/layering events onto data upon output - organize data across +c all levels for each "event set"/"layer" +c ---------------------------------------------------------------------------------------- + + do j = nlv2wrt_tot,1,-1 + + jj = iord(j) +ccc print *, 'j: ',j + + nlv2wrt = nlv2wrt + 1 ! nlv2wrt = number of pressure levels to be written out +ccc print *, 'nlv2wrt = ',nlv2wrt + + if(ibfms(pevn_accum(1,jj,i)).eq.0) then ! if POB is missing, don't process this + ! event + pevns4(1:4,nlv2wrt) = pevn_accum(1:4,jj,i) +ccc print *, 'POB PQM PPC PRC for this level and event:' +ccc print *, ' pevns4(1,',nlv2wrt,') = ',pevns4(1,nlv2wrt) +ccc print *, ' pevns4(2,',nlv2wrt,') = ',pevns4(2,nlv2wrt) +ccc print *, ' pevns4(3,',nlv2wrt,') = ',pevns4(3,nlv2wrt) +ccc print *, ' pevns4(4,',nlv2wrt,') = ',pevns4(4,nlv2wrt) +ccc else +ccc print *, 'POB missing, pevns4 is missing for this level ', +ccc + 'and event' + endif + + if(ibfms(qevn_accum(1,jj,i)).eq.0) then ! if QOB is missing, don't process this + ! event + qevns4(1:4,nlv2wrt) = qevn_accum(1:4,jj,i) +ccc print *, 'QOB QQM QPC QRC for this level and event:' +ccc print *, ' qevns4(1,',nlv2wrt,') = ',qevns4(1,nlv2wrt) +ccc print *, ' qevns4(2,',nlv2wrt,') = ',qevns4(2,nlv2wrt) +ccc print *, ' qevns4(3,',nlv2wrt,') = ',qevns4(3,nlv2wrt) +ccc print *, ' qevns4(4,',nlv2wrt,') = ',qevns4(4,nlv2wrt) +ccc else +ccc print *, 'QOB missing, qevns4 is missing for this ', +ccc + 'level and event' + endif + + if(ibfms(tevn_accum(1,jj,i)).eq.0) then ! if TOB is missing, don't process this + ! event + tevns4(1:4,nlv2wrt) = tevn_accum(1:4,jj,i) +ccc print *, 'TOB TQM TPC TRC for this level and event:' +ccc print *, ' tevns4(1,',nlv2wrt,') = ',tevns4(1,nlv2wrt) +ccc print *, ' tevns4(2,',nlv2wrt,') = ',tevns4(2,nlv2wrt) +ccc print *, ' tevns4(3,',nlv2wrt,') = ',tevns4(3,nlv2wrt) +ccc print *, ' tevns4(4,',nlv2wrt,') = ',tevns4(4,nlv2wrt) +ccc else +ccc print *, 'TOB missing, tevns4 is missing for this ', +ccc + 'level and event' + endif + + if(ibfms(zevn_accum(1,jj,i)).eq.0) then ! if ZOB is missing, don't process this + ! event + zevns4(1:4,nlv2wrt) = zevn_accum(1:4,jj,i) +ccc print *, 'ZOB ZQM ZPC ZRC for this level and event:' +ccc print *, ' zevns4(1,',nlv2wrt,') = ',zevns4(1,nlv2wrt) +ccc print *, ' zevns4(2,',nlv2wrt,') = ',zevns4(2,nlv2wrt) +ccc print *, ' zevns4(3,',nlv2wrt,') = ',zevns4(3,nlv2wrt) +ccc print *, ' zevns4(4,',nlv2wrt,') = ',zevns4(4,nlv2wrt) +ccc else +ccc print *, 'ZOB missing, zevns4 is missing for this level ', +ccc + 'and event' + endif + + if(ibfms(wuvevn_accum(1,jj,i)).eq.0 .and. ! if UOB or VOB are missing, don't + + ibfms(wuvevn_accum(2,jj,i)).eq.0) then ! process this event + wuvevns5(1:5,nlv2wrt) = wuvevn_accum(1:5,jj,i) +ccc print *, 'UOB VOB WQM WPC WRC for this level and event:' +ccc print *, ' wuvevns5(1,',nlv2wrt,') = ',wuvevns5(1,nlv2wrt) +ccc print *, ' wuvevns5(2,',nlv2wrt,') = ',wuvevns5(2,nlv2wrt) +ccc print *, ' wuvevns5(3,',nlv2wrt,') = ',wuvevns5(3,nlv2wrt) +ccc print *, ' wuvevns5(4,',nlv2wrt,') = ',wuvevns5(4,nlv2wrt) +ccc print *, ' wuvevns5(5,',nlv2wrt,') = ',wuvevns5(5,nlv2wrt) +ccc else +ccc print *, 'either UOB or VOB missing, wuvevns5 is missing ', +ccc + 'for this level and event' + endif + + wdsevns5(1:5,nlv2wrt) = wdsevn_accum(1:5,jj,i) +ccc print *, 'DDO FFO DFQ DFP DFR for this level and event:' +ccc print *, ' wdsevns5(1,',nlv2wrt,') = ',wdsevns5(1,nlv2wrt) +ccc print *, ' wdsevns5(2,',nlv2wrt,') = ',wdsevns5(2,nlv2wrt) +ccc print *, ' wdsevns5(3,',nlv2wrt,') = ',wdsevns5(3,nlv2wrt) +ccc print *, ' wdsevns5(4,',nlv2wrt,') = ',wdsevns5(4,nlv2wrt) +ccc print *, ' wdsevns5(5,',nlv2wrt,') = ',wdsevns5(5,nlv2wrt) + +c Collapse arrays of background, post-processing, drift, acft_seq info - need to accumulate +c background, etc., across all levels - only write out these values upon writing first +c "event"/"layer". These values occur only once per layer, there is no nested replication +c ----------------------------------------------------------------------------------------- + + if(i.eq.1) then + + pbgarr3(1:3,nlv2wrt) = pbg_accum(1:3,jj) +ccc print *, 'POE PFC PFCMOD for this level - NO event:' +ccc print *, ' pbgarr3(1,',nlv2wrt,') = ',pbgarr3(1,nlv2wrt) +ccc print *, ' pbgarr3(2,',nlv2wrt,') = ',pbgarr3(2,nlv2wrt) +ccc print *, ' pbgarr3(3,',nlv2wrt,') = ',pbgarr3(3,nlv2wrt) + qbgarr3(1:3,nlv2wrt) = qbg_accum(1:3,jj) +ccc print *, 'QOE QFC QFCMOD for this level - NO event:' +ccc print *, ' qbgarr3(1,',nlv2wrt,') = ',qbgarr3(1,nlv2wrt) +ccc print *, ' qbgarr3(2,',nlv2wrt,') = ',qbgarr3(2,nlv2wrt) +ccc print *, ' qbgarr3(3,',nlv2wrt,') = ',qbgarr3(3,nlv2wrt) + tbgarr3(1:3,nlv2wrt) = tbg_accum(1:3,jj) +ccc print *, 'TOE TFC TFCMOD for this level - NO event:' +ccc print *, ' tbgarr3(1,',nlv2wrt,') = ',tbgarr3(1,nlv2wrt) +ccc print *, ' tbgarr3(2,',nlv2wrt,') = ',tbgarr3(2,nlv2wrt) +ccc print *, ' tbgarr3(3,',nlv2wrt,') = ',tbgarr3(3,nlv2wrt) + zbgarr3(1:3,nlv2wrt) = zbg_accum(1:3,jj) +ccc print *, 'ZOE ZFC ZFCMOD for this level - NO event:' +ccc print *, ' zbgarr3(1,',nlv2wrt,') = ',zbgarr3(1,nlv2wrt) +ccc print *, ' zbgarr3(2,',nlv2wrt,') = ',zbgarr3(2,nlv2wrt) +ccc print *, ' zbgarr3(3,',nlv2wrt,') = ',zbgarr3(3,nlv2wrt) + wuvbgarr5(1:5,nlv2wrt) = wuvbg_accum(1:5,jj) +ccc print *, 'WOE UFC VFC UFCMOD VFCMOD for this level - NO event:' +ccc print *, ' wuvbgarr5(1,',nlv2wrt,') = ',wuvbgarr5(1,nlv2wrt) +ccc print *, ' wuvbgarr5(2,',nlv2wrt,') = ',wuvbgarr5(2,nlv2wrt) +ccc print *, ' wuvbgarr5(3,',nlv2wrt,') = ',wuvbgarr5(3,nlv2wrt) +ccc print *, ' wuvbgarr5(4,',nlv2wrt,') = ',wuvbgarr5(4,nlv2wrt) +ccc print *, ' wuvbgarr5(5,',nlv2wrt,') = ',wuvbgarr5(5,nlv2wrt) + + ppparr3(1:3,nlv2wrt) = ppp_accum(1:3,jj) +ccc print *, 'PAN PCL PCS for this level - NO event:' +ccc print *, ' ppparr3(1,',nlv2wrt,') = ',ppparr3(1,nlv2wrt) +ccc print *, ' ppparr3(2,',nlv2wrt,') = ',ppparr3(2,nlv2wrt) +ccc print *, ' ppparr3(3,',nlv2wrt,') = ',ppparr3(3,nlv2wrt) + qpparr3(1:3,nlv2wrt) = qpp_accum(1:3,jj) +ccc print *, 'QAN QCL QCS for this level - NO event:' +ccc print *, ' qpparr3(1,',nlv2wrt,') = ',qpparr3(1,nlv2wrt) +ccc print *, ' qpparr3(2,',nlv2wrt,') = ',qpparr3(2,nlv2wrt) +ccc print *, ' qpparr3(3,',nlv2wrt,') = ',qpparr3(3,nlv2wrt) + tpparr3(1:3,nlv2wrt) = tpp_accum(1:3,jj) +ccc print *, 'TAN TCL TCS for this level - NO event:' +ccc print *, ' tpparr3(1,',nlv2wrt,') = ',tpparr3(1,nlv2wrt) +ccc print *, ' tpparr3(2,',nlv2wrt,') = ',tpparr3(2,nlv2wrt) +ccc print *, ' tpparr3(3,',nlv2wrt,') = ',tpparr3(3,nlv2wrt) + zpparr3(1:3,nlv2wrt) = zpp_accum(1:3,jj) +ccc print *, 'ZAN ZCL ZCS for this level - NO event:' +ccc print *, ' zpparr3(1,',nlv2wrt,') = ',zpparr3(1,nlv2wrt) +ccc print *, ' zpparr3(2,',nlv2wrt,') = ',zpparr3(2,nlv2wrt) +ccc print *, ' zpparr3(3,',nlv2wrt,') = ',zpparr3(3,nlv2wrt) + wuvpparr6(1:6,nlv2wrt) = wuvpp_accum(1:6,jj) +ccc print *, 'UAN VAN UCL UCS VCL VCS for this level - NO event:' +ccc print *, ' wuvpparr6(1,',nlv2wrt,') = ',wuvpparr6(1,nlv2wrt) +ccc print *, ' wuvpparr6(2,',nlv2wrt,') = ',wuvpparr6(2,nlv2wrt) +ccc print *, ' wuvpparr6(3,',nlv2wrt,') = ',wuvpparr6(3,nlv2wrt) +ccc print *, ' wuvpparr6(4,',nlv2wrt,') = ',wuvpparr6(4,nlv2wrt) +ccc print *, ' wuvpparr6(5,',nlv2wrt,') = ',wuvpparr6(5,nlv2wrt) +ccc print *, ' wuvpparr6(6,',nlv2wrt,') = ',wuvpparr6(6,nlv2wrt) + + drarr3(1:3,nlv2wrt) = drinfo_accum(1:3,jj) +ccc print *, 'XDR YDR HRDR for this level - NO event:' +ccc print *, ' drarr3(1,',nlv2wrt,') = ',drarr3(1,nlv2wrt) +ccc print *, ' drarr3(2,',nlv2wrt,') = ',drarr3(2,nlv2wrt) +ccc print *, ' drarr3(3,',nlv2wrt,') = ',drarr3(3,nlv2wrt) + + acft_seq_arr2(1:2,nlv2wrt) = acft_seq_accum(1:2,jj) +ccc print *, 'PCAT POAF for this level - NO event:' +ccc print *, ' acft_seq_arr2(1,',nlv2wrt,') = ', +ccc + acft_seq_arr2(1,nlv2wrt) +ccc print *, ' acft_seq_arr2(2,',nlv2wrt,') = ', +ccc + acft_seq_arr2(2,nlv2wrt) + + mstq_arr1(1,nlv2wrt) = mstq_accum(1,jj) +ccc print *, 'MSTQ for this level - NO event:' +ccc print *, ' mstq_arr1(1,',nlv2wrt,') = ',mstq_arr1(1,nlv2wrt) + + rct_arr1(1,nlv2wrt) = rct_accum(1,jj) +ccc print *, 'RCT for this level - NO event:' +ccc print *, ' rct_arr1(1,',nlv2wrt,') = ',rct_arr1(1,nlv2wrt + + cat_arr1(1,nlv2wrt) = cat_accum(1,jj) +ccc print *, 'CAT for this level - NO event:' +ccc print *, ' cat_arr1(1,',nlv2wrt,') = ',cat_arr1(1,nlv2wrt) + + ialr_arr1(1,nlv2wrt) = rate_accum(jj) +ccc print *, 'IALR for this level - NO event:' +ccc print *, ' ialr_arr1(1,',nlv2wrt,') = ',ialr_arr1(1,nlv2wrt) + endif + + if(.not.l_operational) then ! this is currently invoked because l_operational + ! is hardwired to F for l_ncep=T + if(i.eq.mxe4prof) then + hdr2wrt1 = hdr2wrt(1) + if(ibfms(drinfo_accum(3,jj)).ne.0) then + idrinfo_accum3 = 9999999 + else + idrinfo_accum3 = nint(drinfo_accum(3,jj) * 3600.) + endif + if(ibfms(hdr2wrt(9)).ne.0) then + ihdr2wrt9 = 99999 + else + ihdr2wrt9 = nint(hdr2wrt(9)) + endif + if(ibfms(hdr2wrt(6)).ne.0) then + ihdr2wrt6 = 9999 + else + ihdr2wrt6 = nint(hdr2wrt(6)) + endif + if(ibfms(acft_seq_accum(2,jj)).ne.0) then + iacft_seq_accum2 = 99 + else + iacft_seq_accum2 = nint(acft_seq_accum(2,jj)) + endif + if(ibfms(mstq_accum(1,jj)).ne.0) then + imstq_accum1 = 9999 + else + imstq_accum1 = nint(mstq_accum(1,jj)) + endif + if(ibfms(cat_accum(1,jj)).ne.0) then + icat_accum1 = 9999 + else + icat_accum1 = nint(cat_accum(1,jj)) + endif + do iii = mxe4prof,1,-1 + if(ibfms(tevn_accum(1,jj,iii)).ne.0) then + nevents_t = iii + else + nevents_t = iii + exit + endif + enddo + if(ibfms(zevn_accum(1,jj,1)).ne.0) then + izevn_accum1 = 999999 + else + izevn_accum1 = nint(zevn_accum(1,jj,1)) + endif + if(ibfms(wdsevn_accum(1,jj,1)).ne.0) then + iwdsevn_accum1 = 99999 + else + iwdsevn_accum1 = nint(wdsevn_accum(1,jj,1)) + endif + do iii = mxe4prof,1,-1 + if(ibfms(wuvevn_accum(1,jj,iii)).ne.0 .or. + + ibfms(wuvevn_accum(2,jj,iii)).ne.0) then + if(iii.eq.1) wspd = bmiss + nevents_w = iii + else + wspd = sqrt(wuvevn_accum(1,jj,iii)**2 + + + wuvevn_accum(2,jj,iii)**2) + nevents_w = iii + exit + endif + enddo + do iii = mxe4prof,1,-1 + if(ibfms(qevn_accum(1,jj,iii)).ne.0) then + if(iii.eq.1) q_sphum = bmiss + nevents_q = iii + else + q_sphum = qevn_accum(1,jj,iii) * 0.001 + nevents_q = iii + exit + endif + enddo + if(ibfms(pevn_accum(2,jj,1)).ne.0) then + ipevn_accum2 = 999 + else + ipevn_accum2 = nint(pevn_accum(2,jj,1)) + endif + if(ibfms(zevn_accum(2,jj,1)).ne.0) then + izevn_accum2 = 999 + else + izevn_accum2 = nint(zevn_accum(2,jj,1)) + endif + if(ibfms(tevn_accum(2,jj,nevents_t)).ne.0) then + itevn_accum2 = 999 + else + itevn_accum2 = nint(tevn_accum(2,jj,nevents_t)) + endif + if(ibfms(qevn_accum(2,jj,nevents_q)).ne.0) then + iqevn_accum2 = 999 + else + iqevn_accum2 = nint(qevn_accum(2,jj,nevents_q)) + endif + if(ibfms(wuvevn_accum(3,jj,nevents_w)).ne.0) then + iwuvevn_accum3 = 999 + else + iwuvevn_accum3 = nint(wuvevn_accum(3,jj,nevents_w)) + endif + if(ibfms(pevn_accum(4,jj,1)).ne.0 .or. + + nint(pevn_accum(3,jj,1)).ne.nrlacqc_pc) then + ipevn_accum4 = 9999 + else + ipevn_accum4 = nint(pevn_accum(4,jj,1)) + endif + if(ibfms(zevn_accum(4,jj,1)).ne.0 .or. + + nint(zevn_accum(3,jj,1)).ne.nrlacqc_pc) then + izevn_accum4 = 9999 + else + izevn_accum4 = nint(zevn_accum(4,jj,1)) + endif + if(ibfms(tevn_accum(4,jj,nevents_t)).ne.0 .or. + + nint(tevn_accum(3,jj,nevents_t)).ne.nrlacqc_pc) then + itevn_accum4 = 9999 + else + itevn_accum4 = nint(tevn_accum(4,jj,nevents_t)) + endif + if(ibfms(qevn_accum(4,jj,nevents_q)).ne.0 .or. + + nint(qevn_accum(3,jj,nevents_q)).ne.nrlacqc_pc) then + iqevn_accum4 = 9999 + else + iqevn_accum4 = nint(qevn_accum(4,jj,nevents_q)) + endif + if(ibfms(wuvevn_accum(5,jj,nevents_w)).ne.0 .or. + + nint(wuvevn_accum(4,jj,nevents_w)).ne.nrlacqc_pc) then + iwuvevn_accum5 = 9999 + else + iwuvevn_accum5 = nint(wuvevn_accum(5,jj,nevents_w)) + endif + +ccccc write(52,fmt=7999) i +c7999 format('EVENT # ',i5) + write(52,fmt=8001) j,c_acftid1,c_acftreg1,ihdr2wrt9, + + iacft_seq_accum2,drinfo_accum(2,jj), + + drinfo_accum(1,jj),idrinfo_accum3,izevn_accum1, + + pevn_accum(1,jj,1),tevn_accum(1,jj,nevents_t)+273.16, + + nevents_t,q_sphum,nevents_q,wuvevn_accum(1,jj,nevents_w), + + wuvevn_accum(2,jj,nevents_w),nevents_w, + + acft_seq_accum(1,jj),c_qc_accum(jj),rct_accum(1,jj), + + imstq_accum1,icat_accum1,wspd,iwdsevn_accum1,ihdr2wrt6, + + ipevn_accum2,izevn_accum2,itevn_accum2,iqevn_accum2, + + iwuvevn_accum3,ipevn_accum4,izevn_accum4,itevn_accum4, + + iqevn_accum4,iwuvevn_accum5 + + 8001 format(i5,1x,a9,1x,a8,1x,i3,2x,i1,1x,2f10.5, 1x,i6,1x,i5,1x,f6.1, + + 1x,f6.2,i3,1x,f7.2,1x,i3,1x,f6.1,1x,f6.1,1x,i3,1x,f6.2,1x, + + '!',a11,'!',f5.2,1x,i3,2x,i2,1x,f6.1,1x,i4,2x,i3,9x,'!', + + 5(1x,i2.2),'!',i3.3,4(1x,i3.3)) + + endif ! i.eq.mxe4prof + endif ! .not.l_operational + enddo ! do j = nlv2wrt_tot,1,-1 +ccc print *, '.. will write out ',nlv2wrt,' p-levels for this ', +ccc + 'report' + +c Store pressure events across levels, z events, t, q, w, df events +c ----------------------------------------------------------------- + if(nlv2wrt.gt.0 .and. nlv2wrt.eq.nlv2wrt_tot) then ! should be equal; vertical coord. + ! is pressure + call ufbint(proflun,pevns4,4,nlv2wrt,nlvwrt,'POB PQM PPC PRC') +ccc print *, 'ufbint has stored POB PQM PPC PRC on all levels ', +ccc + 'for this event:' + + call ufbint(proflun,qevns4,4,nlv2wrt,nlvwrt,'QOB QQM QPC QRC') +ccc print *, 'ufbint has stored QOB QQM QPC QRC on all levels ', +ccc + 'for this event:' + + call ufbint(proflun,tevns4,4,nlv2wrt,nlvwrt,'TOB TQM TPC TRC') +ccc print *, 'ufbint has stored TOB TQM TPC TRC on all levels ', +ccc + 'for this event:' + + call ufbint(proflun,zevns4,4,nlv2wrt,nlvwrt,'ZOB ZQM ZPC ZRC') +ccc print *, 'ufbint has stored ZOB ZQM ZPC ZRC on all levels ', +ccc + 'for this event:' + + call ufbint(proflun,wuvevns5,5,nlv2wrt,nlvwrt, + + 'UOB VOB WQM WPC WRC') +ccc print *, 'ufbint has stored UOB VOB WQM WPC WRC on all ', +ccc + 'levels for this event:' + + call ufbint(proflun,wdsevns5,5,nlv2wrt,nlvwrt, + + 'DDO FFO DFQ DFP DFR') +ccc print *, 'ufbint has stored DDO FFO DFQ DFP DFR on all ', +ccc + 'levels for this event:' + +ccc print *, 'Finished writing p,q,t,u/v,s/d on all ',nlv2wrt, +ccc + ' levels for THIS event' + num_events_prof = num_events_prof + nlv2wrt +ccc print *, 'Finished writing p,q,t,u/v,s/d on all ',nlv2wrt, +ccc + ' levels for THIS event' +ccc print *, 'num_events_prof = ',num_events_prof + + if(i.eq.1) then ! store/write these only on first event application the following + ! values only occur once in the subset; there are no multiple + ! events to write out + +c ------------------------------------------------------------------------------------------- +c Store background and post processing info - each pressure level in the profile gets one set +c of each (not nested replication like with the events) +c ------------------------------------------------------------------------------------------- + +ccc print'(" write background and post-processing info - only ", +ccc + "for first ""event"" since there are no events for ", +ccc + "these")' + +c write background info + call ufbint(proflun,pbgarr3,3,nlv2wrt,nlvwrt, + + 'POE PFC PFCMOD') +ccc print *, 'ufbint has stored POE PFC PFCMOD on all levels -', +ccc + ' "event" ',i,' ONLY' + + call ufbint(proflun,qbgarr3,3,nlv2wrt,nlvwrt, + + 'QOE QFC QFCMOD') +ccc print *, 'ufbint has stored QOE QFC QFCMOD on all levels -', +ccc + ' "event" ',i,' ONLY' + + call ufbint(proflun,tbgarr3,3,nlv2wrt,nlvwrt, + + 'TOE TFC TFCMOD') +ccc print *, 'ufbint has stored TOE TFC TFCMOD on all levels -', +ccc + ' "event" ',i,' ONLY' + + call ufbint(proflun,zbgarr3,3,nlv2wrt,nlvwrt, + + 'ZOE ZFC ZFCMOD') +ccc print *, 'ufbint has stored ZOE ZFC ZFCMOD on all levels -', +ccc + ' "event" ',i,' ONLY' + + call ufbint(proflun,wuvbgarr5,5,nlv2wrt,nlvwrt, + + 'WOE UFC VFC UFCMOD VFCMOD') +ccc print *, 'ufbint has stored WOE UFC VFC UFCMOD VFCMOD on', +ccc + ' all levels - "event" ',i,' ONLY' + +c write post-processing info + call ufbint(proflun,ppparr3,3,nlv2wrt,nlvwrt,'PAN PCL PCS') +ccc print *, 'ufbint has stored PAN PCL PCS on all levels - ', +ccc + '"event" ',i,' ONLY' + + call ufbint(proflun,qpparr3,3,nlv2wrt,nlvwrt,'QAN QCL QCS') +ccc print *, 'ufbint has stored QAN QCL QCS on all levels - ', +ccc + '"event" ',i,' ONLY' + + call ufbint(proflun,tpparr3,3,nlv2wrt,nlvwrt,'TAN TCL TCS') +ccc print *, 'ufbint has stored TAN TCL TCS on all levels - ', +ccc + '"event" ',i,' ONLY' + + call ufbint(proflun,zpparr3,3,nlv2wrt,nlvwrt,'ZAN ZCL ZCS') +ccc print *, 'ufbint has stored ZAN ZCL ZCS on all levels - ', +ccc + '"event" ',i,' ONLY' + + call ufbint(proflun,wuvpparr6,6,nlv2wrt,nlvwrt, + + 'UAN VAN UCL UCS VCL VCS') +ccc print *, 'ufbint has stored UAN VAN UCL UCS VCL VCS on all', +ccc + ' levels - "event" ',i,' ONLY' + +c write out drift info + call ufbint(proflun,drarr3,3,nlv2wrt,nlvwrt,'XDR YDR HRDR') +ccc print *, 'ufbint has stored XDR YDR HRDR on all levels - ', +ccc + '"event" ',i,' ONLY' + +c write out acft_seq info + call ufbint(proflun,acft_seq_arr2,2,nlv2wrt,nlvwrt, + + 'PCAT POAF') +ccc print *, 'ufbint has stored PCAT POAF on all levels - ', +ccc + '"event" ',i,' ONLY' + +c There is no turbulence info carried forth into this subroutine right now, comment out +ccccc call ufbint(proflun,turb_arr4,4,nlv2wrt,nlvwrt, +ccccc+ 'TRBX10 TRBX21 TRBX32 TRBX43') +ccc print *, 'ufbint has stored TRBX10 TRBX21 TRBX32 TRBX43 on', +ccc + ' all levels - "event" ',i,' ONLY' + +c write out moisture QC flag + call ufbint(proflun,mstq_arr1,1,nlv2wrt,nlvwrt,'MSTQ') +ccc print *, 'ufbint has stored MSTQ on all levels - "event"', +ccc + ' ',i,' ONLY' + +c write out level receipt time + call ufbint(proflun,rct_arr1,1,nlv2wrt,nlvwrt,'RCT') +ccc print *, 'ufbint has stored RCT on all levels - "event" ',i, +ccc + ' ONLY' + +c write out level category + call ufbint(proflun,cat_arr1,1,nlv2wrt,nlvwrt,'CAT') +ccc print *, 'ufbint has stored CAT on all levels - "event" ',i, +ccc + ' ONLY' + +c write out the ascent/descent rate + call ufbint(proflun,ialr_arr1,1,nlv2wrt,nlvwrt,'IALR') +ccc print *, 'ufbint has stored IALR on all levels - "event" ', +ccc + i,' ONLY' + + endif ! i.eq.1/1st event? - only write background/pp info once + + else +C....................................................................... +C For some reason the total number of levels written out (nlv2wrt_tot) does not equal the +c number of pressure levels written out (nlv2wrt) for this profile report - problems!!! +c (go on to next profile) +c---------------------------------------------------------------------------------------- + print 54, nlv2wrt_tot,nlv2wrt + 54 format(/' #####> WARNING: THE TOTAL # OF LEVELS WRITTEN OUT ',I6, + + ' .NE. THE # OF PRESSURE LEVELS WRITTEN OUT ',I6,' FOR THIS ', + + 'PROFILE -- GO ON TO NEXT PROFILE'/) + write(cnlv2wrt_tot,'(i3)') nlv2wrt_tot + write(cnlv2wrt,'(i3)') nlv2wrt + call system('[ -n "$jlogfile" ] && $DATA/postmsg '// + + '"$jlogfile" "***WARNING: LEVEL MISMATCH FOR PREPACQC '// + + 'PROFILE: TOTAL WRITTEN '//cnlv2wrt_tot//' .ne. # PRESS '// + + 'LVLS WRITTEN '//cnlv2wrt//' - PROFILE SKIPPED"') + go to 9999 +C....................................................................... + endif + + enddo ! i = 1,mxnmev + + if(.not.l_operational) then + write(52,fmt=8002) + 8002 format(208('X')) + endif + + 9999 continue + +ccc print *, 'out of sub2mem_mer for this merged report' + + return + + end + diff --git a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/sub2mem_um.f b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/sub2mem_um.f new file mode 100644 index 00000000..3fa73075 --- /dev/null +++ b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/sub2mem_um.f @@ -0,0 +1,649 @@ +c$$$ Subprogram Documentation Block +c BEST VIEWED WITH 94-CHARACTER WIDTH WINDOW +c +c Subprogram: sub2mem_um +c Programmer: D. Keyser Org: NP22 Date: 2012-05-08 +c +c Abstract: Adds new NRLACQC events for pressure, altitude, temperature, moisture and wind to +c the top of event stack in memory for a single merged aircraft report. This is +c accomplished via calls to subroutine tranQCflags to translate the QC information (for +c each variable) from NRL standards (c_qc_stg array) to their NCEP counterparts and to +c establish event reason codes for each variable. +c +c Program history log: +c 2010-11-15 S. Bender -- Original Author +c 2012-05-08 D. Keyser -- Prepared for operational implementation +c +c Usage: call sub2mem_um(c_qc_stg,max_reps,mxnmev,j,nevents, +c pob_ev,pqm_ev,ppc_ev,prc_ev, +c zob_ev,zqm_ev,zpc_ev,zrc_ev, +c tob_ev,tqm_ev,tpc_ev,trc_ev, +c qob_ev,qqm_ev,qpc_ev,qrc_ev, +c uob_ev,vob_ev,wqm_ev,wpc_ev,wrc_ev, +c nrlacqc_pc,l_allev_pf) +c +c Input argument list: +c c_qc_stg - NRLACQC quality information (11 character string) +c max_reps - Maximum number of reports accepted by acftobs_qc +c mxnmev - Maximum number of events allowed, per variable type +c j - Report number index +c nevents - Array tracking number of events for variables for each report +c pob_ev - Pressure event obs +c pqm_ev - Pressure event quality marks +c ppc_ev - Pressure event program codes +c prc_ev - Pressure event reason codes +c zob_ev - Altitude event obs +c zqm_ev - Altitude event quality marks +c zpc_ev - Altitude event program codes +c zrc_ev - Altitude event reason codes +c tob_ev - Temperature event obs +c tqm_ev - Temperature event quality marks +c tpc_ev - Temperature event program codes +c trc_ev - Temperature event reason codes +c qob_ev - Moisture event obs +c qqm_ev - Moisture event quality marks +c qpc_ev - Moisture event program codes +c qrc_ev - Moisture event reason codes +c uob_ev - Wind/u-comp event obs +c vob_ev - Wind/v-comp event obs +c wqm_ev - Wind event quality marks +c wpc_ev - Wind event program codes +c wrc_ev - Wind event reason codes +c nrlacqc_pc - PREPBUFR program code for the NRLACQC step +c l_allev_pf - Logical whether to process latest (likely NRLACQC) event plus all prior +c events (TRUE) or only latest event (FALSE) into profiles PREPBUFR-like +c file +c +c Output argument list: +c nevents - Array tracking number of events for variables for each report +c pob_ev - Pressure event obs +c ppc_ev - Pressure event program codes +c prc_ev - Pressure event reason codes +c zob_ev - Altitude event obs +c zqm_ev - Altitude event quality marks +c zpc_ev - Altitude event program codes +c zrc_ev - Altitude event reason codes +c tob_ev - Temperature event obs +c tqm_ev - Temperature event quality marks +c tpc_ev - Temperature event program codes +c trc_ev - Temperature event reason codes +c qob_ev - Moisture event obs +c qqm_ev - Moisture event quality marks +c qpc_ev - Moisture event program codes +c qrc_ev - Moisture event reason codes +c uob_ev - Wind/u-comp event obs +c vob_ev - Wind/v-comp event obs +c wqm_ev - Wind event quality marks +c wpc_ev - Wind event program codes +c wrc_ev - Wind event reason codes +c +c Output files: +c Unit 06 - Standard output print +c +c Subprograms called: +c Unique: TRANQCFLAGS +c Library: +c BUFRLIB: IBFMS +c +c Exit States: +c Cond = 0 - successful run +c +c Remarks: Called by subroutine output_acqc_prof. +c +c Attributes: +c Language: FORTRAN 90 +c Machine: NCEP WCOSS +c +c$$$ + subroutine sub2mem_um(c_qc_stg,max_reps,mxnmev,j,nevents, + + pob_ev,pqm_ev,ppc_ev,prc_ev, + + zob_ev,zqm_ev,zpc_ev,zrc_ev, + + tob_ev,tqm_ev,tpc_ev,trc_ev, + + qob_ev,qqm_ev,qpc_ev,qrc_ev, + + uob_ev,vob_ev,wqm_ev,wpc_ev,wrc_ev, + + nrlacqc_pc,l_allev_pf) + + implicit none + +c ---------------------- +c Declaration statements +c ---------------------- + +c Indices/counters +c ---------------- + integer j ! report number index + + character*11 c_qc_stg ! character QC flags output from NRL QC code + ! 1st char - info about reject (if ob was rejected) + ! 2nd char - reason why time was rejected + ! 3rd char - reason why latitude was rejected + ! 4th char - reason why longitude was rejected + ! 5th char - reason why pressure/atitude was rejected + ! 6th char - readon why temperature was rejected + ! 7th char - reason why wind direction was rejected + ! 8th char - reason why wind speed was rejected + ! 9th char - reason why mixing ratio was rejected + ! 10th char - reason for blacklisting the aircraft + ! 11th char - info about flight phase + +c Variables for updating input reports with QC results/events from NRLACQC +c ------------------------------------------------------------------------ + logical l_badrpt_p ! T = pressure/altitude is bad per NRLACQC info (c_qc_stg) + +, l_badrpt_z ! T = pressure/altitude is bad per NRLACQC info (c_qc_stg) + +, l_badrpt_t ! T = temperature is bad per NRLACQC info (c_qc_stg) + +, l_badrpt_q ! T = moisture is bad per NRLACQC info (c_qc_stg) + +, l_badrpt_w ! T = wind is bad per NRLACQC info (c_qc_stg) + + logical l_duprpt ! T = report is marked as a duplicate per NRLACQC info + ! (c_qc_stg(1:1)=D/d) + + real*8 pob_topstk ! event POB at top of stack before adding any events + ! containing info from NRLACQC + +, zob_topstk ! event ZOB at top of stack before adding any events + ! containing info from NRLACQC + +, tob_topstk ! event TOB at top of stack before adding any events + ! containing info from NRLACQC + +, qob_topstk ! event QOB at top of stack before adding any events + ! containing info from NRLACQC + +, uob_topstk ! event UOB at top of stack before adding any events + ! containing info from NRLACQC + +, vob_topstk ! event VOB at top of stack before adding any events + ! containing info from NRLACQC + + integer ipqm_topstk ! event PQM at top of stack before adding any events + ! containing info from NRLACQC + +, izqm_topstk ! event ZQM at top of stack before adding any events + ! containing info from NRLACQC + +, itqm_topstk ! event TQM at top of stack before adding any events + ! containing info from NRLACQC + +, iqqm_topstk ! event QQM at top of stack before adding any events + ! containing info from NRLACQC + +, iwqm_topstk ! event WQM at top of stack before adding any events + ! containing info from NRLACQC + + integer ipqm_nrlacqc ! value for pressure q.m. (PQM) returned from tranQCflags + +, iprc_nrlacqc ! value for pressure r.c. (PRC) returned from tranQCflags + +, izqm_nrlacqc ! value for altitude q.m. (ZQM) returned from tranQCflags + +, izrc_nrlacqc ! value for altitude r.c. (ZRC) returned from tranQCflags + +, itqm_nrlacqc ! value for temperature q.m. (TQM) returned from tranQCflags + +, itrc_nrlacqc ! value for temperature r.c. (TRC) returned from tranQCflags + +, iqqm_nrlacqc ! value for moisture q.m. (QQM) returned from tranQCflags + +, iqrc_nrlacqc ! value for moisture r.c. (QRC) returned from tranQCflags + +, iwqm_nrlacqc ! value for wind q.m. (WQM) returned from tranQCflags + +, iwrc_nrlacqc ! value for wind r.c. (WRC) returned from tranQCflags + +c Variables used to hold original aircraft data read from input PREPBUFR file - necessary for +c carrying data through program so that it can be later written to output PREPBUFR-like +c profiles file from memory instead of going back to input PREPBUFR file and re-reading that +c file before adding any NRLACQC events +c ------------------------------------------------------------------------------------------- + integer nevents(max_reps,6) ! array tracking number of events for variables for each + ! report: + ! 1 - number of pressure events + ! 2 - number of moisture events + ! 3 - number of temperature events + ! 4 - number of altitude events + ! 5 - number of wind (u/v) events + ! 6 - number of wind (direction/speed) events + + real*8 pob_ev(max_reps,mxnmev) ! POB values for each report, including all events + +, pqm_ev(max_reps,mxnmev) ! PQM values for each report, including all events + +, ppc_ev(max_reps,mxnmev) ! PPC values for each report, including all events + +, prc_ev(max_reps,mxnmev) ! PRC values for each report, including all events + +, zob_ev(max_reps,mxnmev) ! ZOB values for each report, including all events + +, zqm_ev(max_reps,mxnmev) ! ZQM values for each report, including all events + +, zpc_ev(max_reps,mxnmev) ! ZPC values for each report, including all events + +, zrc_ev(max_reps,mxnmev) ! ZRC values for each report, including all events + +, tob_ev(max_reps,mxnmev) ! TOB values for each report, including all events + +, tqm_ev(max_reps,mxnmev) ! TQM values for each report, including all events + +, tpc_ev(max_reps,mxnmev) ! TPC values for each report, including all events + +, trc_ev(max_reps,mxnmev) ! TRC values for each report, including all events + +, qob_ev(max_reps,mxnmev) ! QOB values for each report, including all events + +, qqm_ev(max_reps,mxnmev) ! QQM values for each report, including all events + +, qpc_ev(max_reps,mxnmev) ! QPC values for each report, including all events + +, qrc_ev(max_reps,mxnmev) ! QRC values for each report, including all events + +, uob_ev(max_reps,mxnmev) ! UOB values for each report, including all events + +, vob_ev(max_reps,mxnmev) ! VOB values for each report, including all events + +, wqm_ev(max_reps,mxnmev) ! WQM values for each report, including all events + +, wpc_ev(max_reps,mxnmev) ! WPC values for each report, including all events + +, wrc_ev(max_reps,mxnmev) ! WRC values for each report, including all events + + integer mxnmev,max_reps + +c Misc. +c ----- + real nrlacqc_pc ! PREPBUFR program code for the NRLACQC step + + integer ibfms ! BUFRLIB function for testing for missing + + logical l_skip ! skip (TRUE) or execute (FALSE) block of code + +c Logicals controlling processing (read in from namelist in main program) +c ----------------------------------------------------------------------- + logical l_allev_pf ! T=process latest (likely NRLACQC) events plus all prior + ! events into profiles PREPBUFR-like file + ! **CAUTION: More complete option, but will make code take + ! longer to run!!! + ! F=process ONLY latest (likely NRLACQC) events into profiles + ! PREPBUFR-like file (here means input latest events will + ! likely be written over by NRLACQC events) + ! Note : All pre-existing events plus latest (likely NRLACQC) + ! events are always encoded into full PREPBUFR file) + + +c ******************************************************************* + +c Initialize variables +c -------------------- + + ipqm_topstk = 9999 + izqm_topstk = 9999 + itqm_topstk = 9999 + iqqm_topstk = 9999 + iwqm_topstk = 9999 + +c Start subroutine +c ---------------- + +c --------------------------------------------------------------- +c Translate NRLACQC flags to NCEP events and add events to memory +c --------------------------------------------------------------- + +c Also, first initialize the "bad report", "suspect report", and "duplicate report" flags as +c false - these flags will be set to true if the NRLACQC quality information (array +c c_qc_stg) indicates that the report or any part of it is bad, suspect or a duplicate +c ------------------------------------------------------------------------------------------ + l_badrpt_p = .false. + l_badrpt_z = .false. + l_badrpt_t = .false. + l_badrpt_q = .false. + l_badrpt_w = .false. + + l_duprpt = .false. + +c Pressure +c -------- + +c Get pressure OB and QM at top of stack coming in (from memory) and store in pob_topstk and +c ipqm_topstk, translate NRLACQC quality flags in c_qc_stg to NCEP standards for pressure +c and store in ipqc_nrlacqc, also store reason code in iprc_nrlacqc +c ------------------------------------------------------------------------------------------ + pob_topstk = pob_ev(j,nevents(j,1)) + if(ibfms(pqm_ev(j,nevents(j,1))).eq.0) then + if(nint(pqm_ev(j,nevents(j,1))).ge.0.and. + + nint(pqm_ev(j,nevents(j,1))).le.15) then +c PQM for event at top of stack (prior to adding any NRLACQC events) + ipqm_topstk = nint(pqm_ev(j,nevents(j,1))) + endif + endif + + call tranQCflags(c_qc_stg,'p',ipqm_nrlacqc,iprc_nrlacqc, + + l_badrpt_p,l_duprpt) + +c if PQM = 2 and PRC = 099, returned from tranQCflags, then can't translate! + if(ipqm_nrlacqc.eq.2 .and. iprc_nrlacqc.eq.099) then + print * + print *, 'Unknown c_qc_stg flag on pressure/altitude:', + + c_qc_stg(5:5) + print * + endif + +c Altitude +c -------- + +c Get altitude OB and QM at top of stack coming in (from memory) and store in zob_topstk and +c izqm_topstk, translate NRLACQC quality flags in c_qc_stg to NCEP standards for altitude +c and store in izqc_nrlacqc, also store reason code in izrc_nrlacqc +c +c Use same quality marks for altitude as were used for pressure - NRLACQC has one flag for +c both (c_qc_stg(5:5)) +c ------------------------------------------------------------------------------------------ + zob_topstk = zob_ev(j,nevents(j,4)) + if(ibfms(zqm_ev(j,nevents(j,4))).eq.0) then + if(nint(zqm_ev(j,nevents(j,4))).ge.0.and. + + nint(zqm_ev(j,nevents(j,4))).le.15) then +c ZQM for event at top of stack (prior to adding any NRLACQC events) + izqm_topstk = nint(zqm_ev(j,nevents(j,4))) + endif + endif + + call tranQCflags(c_qc_stg,'z',izqm_nrlacqc,izrc_nrlacqc, + + l_badrpt_z,l_duprpt) + +c if ZQM = 2 and ZRC = 099 returned from tranQCflags, then can't translate! + if(izqm_nrlacqc.eq.2 .and. izrc_nrlacqc.eq.099) then + print * + print *, 'Unknown c_qc_stg flag on pressure/altitude:', + + c_qc_stg(5:5) + print * + endif + +c Temperature +c ----------- + +c Get temperature OB and QM at top of stack coming in (from memory) and store in tob_topstk +c and itqm_topstk, translate NRLACQC quality flags in c_qc_stg to NCEP standards for +c temperature and store in itqc_nrlacqc, also store reason code in itrc_nrlacqc +c ----------------------------------------------------------------------------------------- + tob_topstk = tob_ev(j,nevents(j,3)) + if(ibfms(tqm_ev(j,nevents(j,3))).eq.0) then + if(nint(tqm_ev(j,nevents(j,3))).ge.0.and. + + nint(tqm_ev(j,nevents(j,3))).le.15) then +c TQM for event at top of stack (prior to adding any NRLACQC events) + itqm_topstk = nint(tqm_ev(j,nevents(j,3))) + endif + endif + + call tranQCflags(c_qc_stg,'t',itqm_nrlacqc,itrc_nrlacqc, + + l_badrpt_t,l_duprpt) + +c if TQM = 2 and TRC = 099 returned from tranQCflags, then can't translate! + if(itqm_nrlacqc.eq.2 .and. itrc_nrlacqc.eq.099) then + print * + print *, 'Unknown c_qc_stg flag on temperature:', + + c_qc_stg(6:6) + print * + endif + +c Moisture +c -------- + +c Get moisture OB and QM at top of stack coming in (from memory) and store in qob_topstk and +c iqqm_topstk, translate NRLACQC quality flags in c_qc_stg to NCEP standards for moisture +c and store in iqqc_nrlacqc, also store reason code in iqrc_nrlacqc +c ------------------------------------------------------------------------------------------ + qob_topstk = qob_ev(j,nevents(j,2)) + if(ibfms(qqm_ev(j,nevents(j,2))).eq.0) then + if(nint(qqm_ev(j,nevents(j,2))).ge.0.and. + + nint(qqm_ev(j,nevents(j,2))).le.15) then +c QQM for event at top of stack (prior to adding any NRLACQC events) + iqqm_topstk = nint(qqm_ev(j,nevents(j,2))) + endif + endif + + call tranQCflags(c_qc_stg,'q',iqqm_nrlacqc,iqrc_nrlacqc, + + l_badrpt_q,l_duprpt) + +c if QQM = 2 and QRC = 099 returned from tranQCflags, then can't translate! + if(iqqm_nrlacqc.eq.2 .and. iqrc_nrlacqc.eq.099) then + print * + print *, 'Unknown c_qc_stg flag on moisture:', + + c_qc_stg(9:9) + print * + endif + +c Wind +c ---- + +c Get wind OB (u- and v-) and QM at top of stack coming in (from memory) and store in +c uob_topstk, vob_topstk, and iwqm_topstk, translate NRLACQC quality flags in c_qc_stg to +c NCEP standards for wind and store in iwqc_nrlacqc, also store reason code in iwrc_nrlacqc +c ------------------------------------------------------------------------------------------ + uob_topstk = uob_ev(j,nevents(j,5)) + vob_topstk = vob_ev(j,nevents(j,5)) + if(ibfms(wqm_ev(j,nevents(j,5))).eq.0) then + if(nint(wqm_ev(j,nevents(j,5))).ge.0.and. + + nint(wqm_ev(j,nevents(j,5))).le.15) then +c WQM for event at top of stack (prior to adding any NRLACQC events) + iwqm_topstk = nint(wqm_ev(j,nevents(j,5))) + endif + endif + + call tranQCflags(c_qc_stg,'w',iwqm_nrlacqc,iwrc_nrlacqc, + + l_badrpt_w,l_duprpt) + +c if WQM = 2 and WRC = 099 returned from tranQCflags, then can't translate! + if(iwqm_nrlacqc.eq.2 .and. iwrc_nrlacqc.eq.099) then + print * + print *, 'Unknown c_qc_stg flag on wind:', + + c_qc_stg(7:7),'/',c_qc_stg(8:8) + print * + endif + +c If entire report is to be rejected, put reject flags (QM=13) on pressure, altitude, +c temperature, moisture, and wind +c ----------------------------------------------------------------------------------- + if(l_badrpt_p .or. l_badrpt_z .or. + + l_badrpt_t .or. l_badrpt_q .or. l_badrpt_w) then + ipqm_nrlacqc = 13 ! PQM + ! PRC already encoded into iprc_nrlacqc in subr. tranQCflags + + izqm_nrlacqc = 13 ! ZQM + ! ZRC already encoded into izrc_nrlacqc in subr. tranQCflags + + itqm_nrlacqc = 13 ! TQM + ! TRC already encoded into itrc_nrlacqc in subr. tranQCflags + + iqqm_nrlacqc = 13 ! QQM + ! QRC already encoded into iqrc_nrlacqc in subr. tranQCflags + + iwqm_nrlacqc = 13 ! WQM + ! WRC already encoded into iwrc_nrlacqc in subr. tranQCflags + + endif ! l_badrpt_[p,z,t,q,w] + +c If report is marked as a duplicate (c_qc_stg(1:1) = d or D), then mark the entire report +c with a bad NCEP quality mark (=13) +c ---------------------------------------------------------------------------------------- + if(l_duprpt) then + ipqm_nrlacqc = 13 ! PQM + ! PRC already encoded into iprc_nrlacqc in subr. tranQCflags + + izqm_nrlacqc = 13 ! ZQM + ! ZRC already encoded into izrc_nrlacqc in subr. tranQCflags + + itqm_nrlacqc = 13 ! TQM + ! TRC already encoded into itrc_nrlacqc in subr. tranQCflags + + iqqm_nrlacqc = 13 ! QQM + ! QRC already encoded into iqrc_nrlacqc in subr. tranQCflags + + iwqm_nrlacqc = 13 ! WQM + ! WRC already encoded into iwrc_nrlacqc in subr. tranQCflags + + endif ! l_duprpt + +c Update pressure, altitude, temperature, moisture and wind stacks with new event in memory +c when there has been a qualty mark change by NRLACQC (don't need to write out an event if +c quality mark has not been changed by this program) +c +c EXCEPTION: Retain (honor) the incoming quality mark at the top of the stack (i.e., do not +c write event) when: +c +c (1) The incoming quality mark at the top of the stack is 0 (keep flag) +c (2) The incoming quality mark at the top of the stack is between 4 and 15 (bad) - +c except when NRLACQC itself generates a BAD quality mark (translated to NCEP +c value of 13), allows reason code to denote why action taken by NRLACQC to mark +c obs as bad +c (3) The incoming quality mark at the top of the stack is not between 0 and 15 +c (i.e.,missing) +c (4) The incoming quality mark at the top of the stack is 3 (suspect) and the NRLACQC +c generates a GOOD or NEUTRAL or SUSPECT quality mark (translated to NCEP values of +c 1, 2 and 3 resp.) {in other words, unless an ob previously marked as suspect was +c marked bad by NRLACQC, don't change a suspect quality mark assigned by a PREPBUFR +c processing step prior to the NRLACQC step} +c (5) The quality mark translated to its NCEP value is 2 (neutral) and the reason code +c is returned from tranQCflags is 099 - this indicates that the NRLACQC quality +c flags in c_qc_stg pertaining to this ob are unknown to transQCflags (the routine +c tranQCflags may need to be updated to account for the c_qc_stg flags that is +c coming out of the NRLACQC QC routine for this ob - this would probably only +c happen if NRL provides an updated/upgraded acftobs_qc module to NCEP) +c (6) The NCEP equivalent of the NRLACQC is the same as the incoming quality mark of +c the stack - if there is no change in the quality mark, then do not add a new +c event and leave the event at the top of the event stack as is with TWO +c exceptions: +c a) NRLACQC itself generates a GOOD quality mark (translated to NCEP value of +c 1) +c b) NRLACQC itself generates a BAD quality mark (translated to NCEP value of +c 13) (see 2 above for more on this) +c ------------------------------------------------------------------------------------------- + +c Pressure +c -------- + + l_skip = .true. ! SKIP LOGIC TO WRITE PRESSURE EVENTS - there is no need to do so since + ! pressure is a vertical coordinate and it is not analyzed, in + ! addition, adding pressure events complicates reason code logic + + if(.not.l_skip) then + +c .... if here, include logic to write pressure events + if(ipqm_topstk.eq.0 .or. + + (ipqm_topstk.ge.4 .and. ipqm_topstk.le.15) .or. ! ob has already been marked bad + ! by NCEP codes + + ipqm_topstk.eq.9999 .or. + + (ipqm_topstk.eq.3.and.ipqm_nrlacqc.le.3) .or. + + (ipqm_nrlacqc.eq.2.and.iprc_nrlacqc.eq.099) .or. + + (ipqm_topstk.eq.ipqm_nrlacqc.and.ipqm_nrlacqc.ne.1) + + ) then ! no event needed; leave PQM as is + + ipqm_nrlacqc = ipqm_topstk + + else ! NRL QC produced an event; add this event to top of stack in memory + if(l_allev_pf) nevents(j,1) = nevents(j,1) + 1 ! add new event (do not write over + ! event currently at top of stack + ! since l_allev_pf=TRUE) + pob_ev(j,nevents(j,1)) = pob_topstk + pqm_ev(j,nevents(j,1)) = ipqm_nrlacqc + ppc_ev(j,nevents(j,1)) = nrlacqc_pc + prc_ev(j,nevents(j,1)) = iprc_nrlacqc + + endif + + else + +c .... if here, SKIP logic to write pressure events + ipqm_nrlacqc = ipqm_topstk + + endif + +c Altitude +c -------- + + l_skip = .true. ! SKIP LOGIC TO WRITE ALTITUDE EVENTS - there is no need to do so since + ! altitude is a vertical coordinate and it is not analyzed, in + ! addition, adding altitude events complicates reason code logic + + if(.not.l_skip) then + +c .... if here, include logic to write altitude events + if(izqm_topstk.eq.0 .or. + + (izqm_topstk.ge.4 .and. izqm_topstk.le.15) .or. ! ob has already been marked bad + ! by NCEP codes + + izqm_topstk.eq.9999 .or. + + (izqm_topstk.eq.3.and.izqm_nrlacqc.le.3) .or. + + (izqm_nrlacqc.eq.2.and.izrc_nrlacqc.eq.099) .or. + + (izqm_topstk.eq.izqm_nrlacqc.and.izqm_nrlacqc.ne.1) + + ) then ! no event needed; leave ZQM as is + izqm_nrlacqc = izqm_topstk + + else ! NRL QC produced an event; add this event to top of stack in memory + if(l_allev_pf) nevents(j,4) = nevents(j,4) + 1 ! add new event (do not write over + ! event currently at top of stack + ! since l_allev_pf=TRUE) + zob_ev(j,nevents(j,4)) = zob_topstk + zqm_ev(j,nevents(j,4)) = izqm_nrlacqc + zpc_ev(j,nevents(j,4)) = nrlacqc_pc + zrc_ev(j,nevents(j,4)) = izrc_nrlacqc + + endif + + else + +c .... if here, SKIP logic to write altitude events + izqm_nrlacqc = izqm_topstk + + endif + +c Temperature +c ----------- + +c Obs/Events + if((itqm_topstk.eq.0 .or. + + (itqm_topstk.ge.4 .and. itqm_topstk.le.15) .or. ! ob has already been marked bad by + ! NCEP codes + + itqm_topstk.eq.9999 .or. + + (itqm_topstk.eq.3.and.itqm_nrlacqc.le.3) .or. + + (itqm_nrlacqc.eq.2.and.itrc_nrlacqc.eq.099) .or. + + (itqm_topstk.eq.itqm_nrlacqc.and.itqm_nrlacqc.ne.1) + + ) .and. (itqm_nrlacqc.ne.13.or. + + itqm_topstk.eq.9999)) then ! no event needed; leave TQM as is + itqm_nrlacqc = itqm_topstk + + else ! NRL QC produced an event; add this event to top of stack in memory + if(l_allev_pf) nevents(j,3) = nevents(j,3) + 1 ! add new event (do not write over + ! event currently at top of stack + ! since l_allev_pf=TRUE) + if(int(itrc_nrlacqc/100).eq.9 .and. + + itqm_nrlacqc.eq.13) itqm_nrlacqc = 14 ! if temperature marked bad here due to it + ! being on reject list, reset TQM to 14 + tob_ev(j,nevents(j,3)) = tob_topstk + tqm_ev(j,nevents(j,3)) = itqm_nrlacqc + tpc_ev(j,nevents(j,3)) = nrlacqc_pc + trc_ev(j,nevents(j,3)) = itrc_nrlacqc + + endif + +c Moisture +c -------- + +c Obs/Events + if((iqqm_topstk.eq.0 .or. + + (iqqm_topstk.ge.4 .and. iqqm_topstk.le.15) .or. ! ob has already been marked bad by + ! NCEP codes + + iqqm_topstk.eq.9999 .or. + + (iqqm_topstk.eq.3 .and. iqqm_nrlacqc.le.3) .or. + + (iqqm_nrlacqc.eq.2.and.iqrc_nrlacqc.eq.099) .or. + + (iqqm_topstk.eq.iqqm_nrlacqc.and.iqqm_nrlacqc.ne.1) + + ) .and. (iqqm_nrlacqc.ne.13.or. + + iqqm_topstk.eq.9999)) then ! no event needed; leave QQM as is + iqqm_nrlacqc = iqqm_topstk + + else ! NRL QC produced a new event; add this event to top of stack in memory + if(l_allev_pf) nevents(j,2) = nevents(j,2) + 1 ! add new event (do not write over + ! event currently at top of stack + ! since l_allev_pf=TRUE) + if(int(iqrc_nrlacqc/100).eq.9 .and. + + iqqm_nrlacqc.eq.13) iqqm_nrlacqc = 14 ! if moisture marked bad here due to + ! temperature being on reject list, reset + ! QQM to 14 + qob_ev(j,nevents(j,2)) = qob_topstk + qqm_ev(j,nevents(j,2)) = iqqm_nrlacqc + qpc_ev(j,nevents(j,2)) = nrlacqc_pc + qrc_ev(j,nevents(j,2)) = iqrc_nrlacqc + + endif + +c Wind +c ---- + +c Obs/Events + if((iwqm_topstk.eq.0 .or. + + (iwqm_topstk.ge.4 .and. iwqm_topstk.le.15) .or. ! ob has already been marked bad by + ! NCEP codes + + iwqm_topstk.eq.9999 .or. + + (iwqm_topstk.eq.3 .and. iwqm_nrlacqc.le.3) .or. + + (iwqm_nrlacqc.eq.2.and.iwrc_nrlacqc.eq.099) .or. + + (iwqm_topstk.eq.iwqm_nrlacqc.and.iwqm_nrlacqc.ne.1) + + ) .and. (iwqm_nrlacqc.ne.13.or. + + iwqm_topstk.eq.9999)) then ! no event needed; leave WQM as is + iwqm_nrlacqc = iwqm_topstk + + else ! NRL QC produced a new event; add this event to top of stack in memory + if(l_allev_pf) nevents(j,5) = nevents(j,5) + 1 ! add new event (do not write over + ! event currently at top of stack + ! since l_allev_pf=TRUE) + if(int(iwrc_nrlacqc/100).eq.9 .and. + + iwqm_nrlacqc.eq.13) iwqm_nrlacqc = 14 ! if wind marked bad here due to it being + ! on reject list, reset WQM to 14 + uob_ev(j,nevents(j,5)) = uob_topstk + vob_ev(j,nevents(j,5)) = vob_topstk + wqm_ev(j,nevents(j,5)) = iwqm_nrlacqc + wpc_ev(j,nevents(j,5)) = nrlacqc_pc + wrc_ev(j,nevents(j,5)) = iwrc_nrlacqc + + endif + + return + + end diff --git a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/tranQCflags.f b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/tranQCflags.f new file mode 100644 index 00000000..7b3e2dd6 --- /dev/null +++ b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/tranQCflags.f @@ -0,0 +1,813 @@ +c$$$ Subprogram Documentation Block +c BEST VIEWED WITH 94-CHARACTER WIDTH WINDOW +c +c Subprogram: tranQCflags +c Programmer: D. Keyser Org: NP22 Date: 2012-05-08 +c +c Abstract: Translates quality information from NRL standards to equivalent NCEP PREPBUFR +c quality marks. Also generates the NCEP PREPBUFR reason codes based on the NRL quality +c information. This is read in for one observation at a time for each report (e.g., +c pressure reads it, then altitude, then temperature, then moisture, then wind). +c +c Program History Log: +c 2010-11-15 S. Bender -- Original Author +c 2012-05-08 D. Keyser -- Prepared for operational implementation +c +c Usage: call tranQCflags(NRLQCstg,type,NCEPqm,NCEPrc,l_badrpt,l_duprpt) +c +c Input argument list: +c NRLQCstg - NRLACQC quality information (11 char. string) for this complete report +c type - Type of variable being considered in this call (e.g., 'p', 'z', 't', +c 'q', 'w') +c +c Output argument list: +c NCEPqm - Equivalent NCEP PREPBUFR quality mark for this variable +c NCEPrc - Generated NCEP PREPBUFR reason code for this variable +c l_badrpt - Logical indicating if the entire report should be marked as "bad" +c l_duprpt - Logical indicating if the entire report should be marked as a duplicate +c +c Output files: +c Unit 06 - Standard output print +c +c Subprograms called: +c Library: +c W3NCO: ERREXIT W3TAGE MOVA2I +c +c Exit States: +c Cond = 0 - successful run +c 69 - row number for input data matrix is outside range of 1-34 +c +c Remarks: Called by subroutines output_acqc_noprof and sub2mem_um. +c +c Attributes: +c Language: FORTRAN 90 +c Machine: NCEP WCOSS +c +c$$$ + subroutine tranQCflags(NRLQCstg,type,NCEPqm,NCEPrc,l_badrpt, + + l_duprpt) + + implicit none + + character*11 NRLQCstg + character*1 type + + logical l_badrpt,l_duprpt + + integer iii(45:118) ! the "row number" (RN) corresponding to the single + ! character NRLACQC quality flag pulled out of + ! NRLQCstg, this is the second dimension of table + ! w2d + +, mova2i + + integer cp ! character position in c_qc string (1-11), this + ! value minus 1 is the first dimension of table w2d + +, RN ! row number in w2d/action data table/numerical + ! equivalent of character value (example: a=1, + ! F=10), this is obtained via integer conversion of + ! the single ASCII character NRLACQC quality flag + ! pulled out of NRLQCstg, obtained from iii + + character*2 w2d(0:10,34) +c 0 = overall report +c |--- 1 = time +c |--- |--- 2 = latitude +c |--- |--- |--- 3 = longitude +c |--- |--- |--- |--- 4 = pressure/altitude +c |--- |--- |--- |--- |--- 5 = temperature +c |--- |--- |--- |--- |--- |--- 6 = wind direction +c |--- |--- |--- |--- |--- |--- |--- 7 = wind speed +c |--- |--- |--- |--- |--- |--- |--- |--- 8 = moisture +c |--- |--- |--- |--- |--- |--- |--- |--- |--- 9 = reject (black) list +c |--- |--- |--- |--- |--- |--- |--- |--- |--- |--- 10 = flight phase +c |--- |--- |--- |--- |--- |--- |--- |--- |--- |--- |--- +c i: 0:10 (cp-1) --------------> + data w2d/'ND','ND','ND','ND','ND','ND','ND','ND','ND','ND','IO', ! a j:1-34 (RN) 1 | + + 'RR','ND','ND','ND','ND','ND','ND','RW','ND','ND','IO', ! A 2 | + + 'RR','RR','RR','RR','RR','RR','RW','RW','RM','ND','ND', ! B 3 | + + 'ND','ND','ND','ND','ND','RT','ND','ND','ND','ND','ND', ! b 4 V + + 'ND','ND','ND','ND','ND','ND','ND','ND','ND','IO','ND', ! C 5 + + 'DR','ND','ND','ND','ND','ND','ND','ND','ND','ND','IO', ! D 6 + + 'DR','ND','ND','ND','ND','ND','ND','ND','ND','ND','IO', ! d 7 + + 'RR','ND','ND','ND','ND','RT','RW','RW','ND','ND','ND', ! E 8 + + 'RR','ND','ND','ND','ND','ND','ND','ND','ND','ND','ND', ! e 9 + + 'ND','ND','ND','ND','ND','ND','ND','ND','ND','ND','ND', ! F 10 + + 'ND','RR','RR','RR','RR','RT','RW','RW','ND','ND','ND', ! I 11 + + 'ND','ND','ND','ND','RR','ND','ND','ND','ND','ND','IO', ! i 12 + + 'ND','RR','RR','RR','RR','CW','CT','CT','RM','ND','ND', ! K 13 + + 'ND','ND','ND','ND','ND','ND','ND','ND','ND','ND','IO', ! L 14 + + 'ND','RR','RR','RR','RR','CW','CT','CT','RM','IO','IO', ! M 15 + + 'NU','NU','NU','NU','ND','NU','ND','ND','NU','ND','IO', ! N 16 + + 'RR','ND','ND','ND','ND','ND','ND','ND','ND','RR','ND', ! O 17 + + 'RR','ND','ND','ND','ND','ND','ND','ND','ND','ND','ND', ! P 18 + + 'RR','ND','ND','ND','ND','ND','ND','ND','ND','ND','ND', ! p 19 + + 'ND','IO','IO','IO','IO','IO','ND','ND','ND','ND','ND', ! R 20 + + 'RR','ND','ND','ND','IO','ND','ND','ND','ND','ND','ND', ! r 21 + + 'RR','RR','RR','RR','RR','ND','ND','SW','SM','ND','ND', ! S 22 + + 'RR','ND','ND','ND','ND','ND','SW','SW','ND','ND','ND', ! s 23 + + 'ND','ND','ND','ND','ND','ND','ND','ND','ND','RT','ND', ! T 24 + + 'RR','ND','ND','ND','ND','ND','ND','ND','ND','ND','ND', ! t 25 + + 'ND','ND','ND','ND','ND','ND','ND','ND','ND','ND','IO', ! U 26 + + 'RR','ND','ND','ND','ND','ND','ND','ND','ND','ND','ND', ! V 27 + + 'RR','ND','ND','ND','ND','ND','ND','ND','ND','ND','ND', ! v 28 + + 'RR','ND','ND','ND','ND','ND','ND','ND','ND','RW','ND', ! W 29 + + 'RR','ND','ND','ND','ND','ND','ND','ND','ND','ND','ND', ! X 30 + + 'GR','IO','IO','IO','GV','GT','GW','GW','GM','IO','ND', ! . 31 + + 'NU','ND','ND','ND','NU','NU','NU','NU','NU','ND','ND', ! - 32 + + 'IO','ND','ND','ND','ND','ND','ND','ND','SM','ND','ND', ! 2 33 + + 'ND','ND','ND','ND','ND','ND','ND','ND','SM','ND','ND' ! 3 34 + + / + +c 'CT' -- check temperature -> reject wind, or will reject report if temperature also bad +c 'CW' -- check wind -> reject temperature, or will reject report if wind also bad +c 'DR' -- duplicate report +c 'GM' -- good moisture +c 'GR' -- good report +c 'GT' -- good temperature` +c 'GV' -- good pressure/altitude +c 'GW' -- good wind +c 'IO' -- inconclusive (?) +c 'ND' -- not defined +c 'NU' -- neutral report (not checked) +c 'RM' -- reject moisture +c 'RR' -- reject entire report +c 'RT' -- reject temperature +c 'RW' -- reject wind +c 'SM' -- suspect moisture +c 'SW' -- suspect wind +c 'XX' -- initialized value (not yet set) + + character*2 action ! action value to be passed back to the calling + ! routine (RR,DR,GR,RT,RM,RW,SW,NU,ND,IO) + +, bl_action ! reject (black) list action (c_qc(10:10)) + +, pres_action ! pressure/altitude action (c_qc(5:5)) + +, temp_action ! temperature action (c_qc(6:6)) + +, moist_action ! moisture action (c_qc(9:9)) + +, wdir_action ! wind direction action (c_qc(7:7)) + +, wspd_action ! wind speed action (c_qc(8:8)) + +, lat_action ! latitude action (c_qc(3:3)) + +, lon_action ! longitude action (c_qc(4:4)) + +, time_action ! time action (c_qc(2:2)) + +, overall_action ! action per c_qc(1:1) + + integer NCEPqm ! value of NCEP quality mark to be passed back to + ! calling routine + +, NCEPrc ! value of NCEP reason code to be passed back to + ! calling routine + +, NCEPrc_t ! intermediate value for temperature quality mark + +, NCEPrc_q ! intermediate value for moisture quality mark + +, NCEPrc_w ! intermediate value for wind quality mark + + +c Misc. +c ----- + +c decimal --> 45 46 50 51 +c character --> '-' '.' '2' '3' + data iii / 32, 31, 0, 0, 0, 33, 34, 0, 0, 0, 0, 0, 0, + +c decimal --> 65 66 67 68 69 70 +c character --> 'A' 'B' 'C' 'D' 'E' 'F' + + 0, 0, 0, 0, 0, 0, 0, 2, 3, 5, 6, 8, 10, + +c decimal --> 73 75 76 77 78 79 80 82 83 +c character --> 'I' 'K' 'L' 'M' 'N' 'O' 'P' 'R' 'S' + + 0, 0, 11, 0, 13, 14, 15, 16, 17, 18, 0, 20, 22, + +c decimal --> 84 85 86 87 88 +c character --> 'T' 'U' 'V' 'W' 'X' + + 24, 26, 27, 29, 30, 0, 0, 0, 0, 0, 0, 0, 0, + +c decimal --> 97 98 100 101 105 +c character --> 'a' 'b' 'd' 'e' 'i' + + 1, 4, 0, 7, 9, 0, 0, 0, 12, 0, 0, 0, 0, + +c decimal --> 112 114 115 116 118 +c character --> 'p' 'r' 's' 't' 'v' + + 0, 0, 19, 0, 21, 23, 25, 0, 28 / + +c ----------------------------------------------------------- + +c Initialize variables +c -------------------- + l_badrpt = .false. + l_duprpt = .false. + + bl_action = 'XX' + pres_action = 'XX' + temp_action = 'XX' + moist_action = 'XX' + wdir_action = 'XX' + wspd_action = 'XX' + lat_action = 'XX' + lon_action = 'XX' + time_action = 'XX' + overall_action = 'XX' + action = 'XX' + + NCEPqm = 99999 + NCEPrc = 99999 + NCEPrc_t = 99999 + NCEPrc_q = 99999 + NCEPrc_w = 99999 +c ----------------------------------------------------------- + +C ************************************************************************* +c FIRST CHECK FOR UNILATERAL REJECT REPORT - APPLIES TO ALL VARIABLES +C ************************************************************************* + +c --------------------------------------------------------------------- +c First sub-check is on OVERALL REPORT (first character of c_qc string) +c --------------------------------------------------------------------- + cp = 1 + +c iii represents the "row number" corresponding to the single ASCII character NRLACQC +c quality flag NRLQCstg(cp:cp) and is the second dimension of table w2d (Note: this comment +c is not repeated for each instance where iii is obtained below) +c ------------------------------------------------------------------------------------------- + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + action = w2d(cp-1,RN) ! either 'ND', 'RR', 'IO', 'NU', 'GR', 'DR' + overall_action = action + if(action.eq.'RR' .or. action.eq.'DR') then + NCEPrc = (cp-1)*100 + RN ! RC range 001-034 + go to 2000 ! reject entire report here means we don't need to do anymore testing + endif + +c ------------------------------------------------------------------------ +C If we make it to here ... +c Second sub-check is on PRESSURE/ALTITUDE (fifth character of c_qc string) +c ------------------------------------------------------------------------- + cp = 5 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + action = w2d(cp-1,RN) ! either 'ND', 'RR', 'IO', 'NU', 'GV' + pres_action = action + if(action.eq.'RR') then + NCEPrc = (cp-1)*100 + RN ! RC range 401-434 + go to 2000 ! reject entire report here means we don't need to do anymore testing + endif + +c ------------------------------------------------------------------ +C If we make it to here ... +c Third sub-check is on TEMPERATURE (sixth character of c_qc string) +c ------------------------------------------------------------------ + cp = 6 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + action = w2d(cp-1,RN) ! either 'ND', 'RR', 'IO', 'NU', 'RT', 'GT', 'CW' + temp_action = action + if(temp_action.eq.'RT') then +c If temperature action is reject temperature ('RT'), change reject (black) list value in +c tenth character of c_qc string from 'O' (reject entire report) to 'W' (reject wind only) - +c this prevents eighth sub-check below from masking QM (13) & RC associated with this code's +c reject of temperature {instead it would receive reject (black) list QM (14) and RC} + if(NRLQCstg(10:10).eq.'O') NRLQCstg(10:10) = 'W' + endif + if(action.eq.'RR') then + NCEPrc = (cp-1)*100 + RN ! RC range 501-534 + go to 2000 ! reject entire report here means we don't need to do anymore testing + endif + +c ------------------------------------------------------------- +C If we make it to here ... +c Fourth sub-check is on TIME (second character of c_qc string) +c ------------------------------------------------------------- + cp = 2 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + action = w2d(cp-1,RN) ! either 'ND', 'RR', 'IO', 'NU' + time_action = action + if(action.eq.'RR') then + NCEPrc = (cp-1)*100 + RN ! RC range 101-134 + go to 2000 ! reject entire report here means we don't need to do anymore testing + endif + +c --------------------------------------------------------------- +C If we make it to here ... +c Fifth sub-check is on LATITUDE (third character of c_qc string) +c --------------------------------------------------------------- + cp = 3 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + action = w2d(cp-1,RN) ! either 'ND', 'RR', 'IO', 'NU' + lat_action = action + if(action.eq.'RR') then + NCEPrc = (cp-1)*100 + RN ! RC range 201-234 + go to 2000 ! reject entire report here means we don't need to do anymore testing + endif + +c ----------------------------------------------------------------- +C If we make it to here ... +c Sixth sub-check is on LONGITUDE (fourth character of c_qc string) +c ----------------------------------------------------------------- + cp = 4 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + action = w2d(cp-1,RN) ! either 'ND', 'RR', 'IO', 'NU' + lon_action = action + if(action.eq.'RR') then + NCEPrc = (cp-1)*100 + RN ! RC range 301-334 + go to 2000 ! reject entire report here means we don't need to do anymore testing + endif + +c ------------------------------------------------------------------------------------------- +C If we make it to here ... +c Seventh sub-check is on TEMPERATURE/WIND COMBINATION (sixth thru tenth char of c_qc string) +c ------------------------------------------------------------------------------------------- +c We already know temperature action (from sixth character of c_qc string) from above +c {temp_action, either 'ND', 'IO', 'NU', 'RT', 'GT', 'CW' ('RR' already considered)} + +c Obtain wind direction action from seventh character of c_qc string (wdir_action) + cp = 7 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + wdir_action = w2d(cp-1,RN) ! either 'ND', 'NU', 'RW', 'SW', 'GW', 'CT' + ! (Note: 'RR' not a choice here) + if(wdir_action.eq.'RW') then +c If wind direction action is reject wind ('RW'), change reject (black) list value in tenth +c character of c_qc string from 'O' (reject entire report) to 'T' (reject temperature only) +c - this prevents eighth sub-check below from masking QM (13) & RC associated with this +c code's reject of wind {instead it would receive reject (black) list QM (14) & RC} + if(NRLQCstg(10:10).eq.'O') NRLQCstg(10:10) = 'T' + endif + +c Obtain wind speed action from eighth character of c_qc string (wspd_action) + cp = 8 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + wspd_action = w2d(cp-1,RN) ! either 'ND', 'NU', 'RW', 'SW', 'GW', 'CT' + ! (Note: 'RR' not a choice here) + if(wspd_action.eq.'RW') then +c If wind speed action is reject wind ('RW'), change reject (black) list value in tenth +c character of c_qc string from 'O' (reject entire report) to 'T' (reject temperature only) +c - this prevents eighth sub-check below from masking QM (13) & RC associated with this +c code's reject of wind {instead it would receive reject (black) list QM (14) and RC} + if(NRLQCstg(10:10).eq.'O') NRLQCstg(10:10) = 'T' + endif + +c Obtain moisture action from ninth character of c_qc string (wspd_action) + cp = 9 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + moist_action = w2d(cp-1,RN) ! either 'ND', 'NU', 'RM', 'SM', 'GM' + ! (Note: 'RR' not a choice here) + +c Obtain reject (black) list action from tenth character of c_qc string (bl_action) + cp = 10 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + bl_action = w2d(cp-1,RN) ! either 'ND', 'RR', 'IO', 'RT', 'RW' + +c If temperature action is to check wind ('CW'), then a "bad" wind will result in the entire +c report being rejected + if(temp_action.eq.'CW') then + action = 'RR' + cp = 6 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + NCEPrc_t = (cp-1)*100 + RN ! temperature RC range 501-534 +c .... first check wind direction to see if it is "bad" + if(wdir_action.eq.'CT'.or.wdir_action.eq.'RW') then + cp = 7 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + NCEPrc_w = (cp-1)*100 + RN ! wind RC range 601-634 +c ........ a bad wind direction rejects entire report +c ........ set RC for moisture to moisture action if moisture rejected, otherwise set it to +c RC for temperature + if(moist_action.eq.'RM') then + cp = 9 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + NCEPrc_q = (cp-1)*100 + RN ! moisture RC range 801-834 + else + NCEPrc_q = NCEPrc_t ! moisture RC range 501-534 + endif + go to 2000 ! reject entire report here means we don't need to do anymore testing + elseif(wspd_action.eq.'CT'.or.wspd_action.eq.'RW') then +c .... next check wind speed to see if it is "bad" + cp = 8 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + NCEPrc_w = (cp-1)*100 + RN ! wind RC range 701-734 +c ........ a bad wind speed rejects entire report +c ........ set RC for moisture to moisture action if moisture rejected, otherwise set it to +c RC for temperature + if(moist_action.eq.'RM') then + cp = 9 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + NCEPrc_q = (cp-1)*100 + RN ! moisture RC range 801-834 + else + NCEPrc_q = NCEPrc_t ! moisture RC range 501-534 + endif + go to 2000 ! reject entire report here means we don't need to do anymore testing + elseif(bl_action.eq.'RW' ) then +c .... finally check reject (black) list to see if wind (direction/speed) is rejected ("bad") +c (Note: bl_action = 'RR' will be considered separately in eighth sub-check below) + cp = 10 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + NCEPrc_w = (cp-1)*100 + RN ! wind RC range 901-934 +c ........ wind on reject (black) list rejects entire report +c ........ set RC for moisture to moisture action if moisture rejected, otherwise set it to +c RC for temperature + if(moist_action.eq.'RM') then + cp = 9 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + NCEPrc_q = (cp-1)*100 + RN ! moisture RC range 801-834 + else + NCEPrc_q = NCEPrc_t ! moisture RC range 501-534 + endif + go to 2000 ! reject entire report here means we don't need to do anymore testing + else +c .... even though temperature action is to check wind ('CW'), wind is not "bad", so +c temperature (and wind and moisture if they are present) will be tested later as a +c single variable unless eighth sub-check below yields a reject entire report + action = 'XX' ! reset action back to initialized value + NCEPrc_t = 99999 ! reset temperature reason code back to initialized value + endif + else +c Temperature action is something other than check wind ('CW') {or, for that matter, reject +c report ('RR')}, so temperature (and wind and moisture if present) will be tested later as +c a single variable unless eighth sub-check below yields a reject entire report + temp_action = temp_action ! dummy statement to allow else branch here + endif + +c If wind direction action is to check temperature ('CT'), then a "bad" temperature will +c result in the entire report being rejected + if(wdir_action.eq.'CT') then + action = 'RR' + cp = 7 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + NCEPrc_w = (cp-1)*100 + RN ! wind RC range 601-634 +c .... first check temperature to see if it is "bad" + if(temp_action.eq.'CW'.or.temp_action.eq.'RT') then + cp = 6 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + NCEPrc_t = (cp-1)*100 + RN ! temperature RC range 501-534 +c ........ a bad temperature rejects entire report +c ........ set RC for moisture to moisture action if moisture rejected, otherwise set it to +c RC for temperature + if(moist_action.eq.'RM') then + cp = 9 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + NCEPrc_q = (cp-1)*100 + RN ! moisture RC range 801-834 + else + NCEPrc_q = NCEPrc_t ! moisture RC range 501-534 + endif + go to 2000 ! reject entire report here means we don't need to do anymore testing + elseif(bl_action.eq.'RT' ) then +c .... finally check reject (black) list to see if temperature is rejected ("bad") +c (Note: bl_action = 'RR' will be considered separately in eighth sub-check below) + cp = 10 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + NCEPrc_t = (cp-1)*100 + RN ! temperature RC range 901-934 +c ........ temperature on reject (black) list rejects entire report +c ........ set RC for moisture to moisture action if moisture rejected, otherwise set it to +c RC for temperature + if(moist_action.eq.'RM') then + cp = 9 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + NCEPrc_q = (cp-1)*100 + RN ! moisture RC range 801-834 + else + NCEPrc_q = NCEPrc_t ! moisture RC range 501-534 + endif + go to 2000 ! reject entire report here means we don't need to do anymore testing + else +c .... even though wind direction action is to check temperature ('CT'), temperature is not +c "bad", so wind (and temperature and moisture if present) will be tested later as a +c single variable unless either wind speed check (action 'CT' checking against "bad" +c temperature) just below yields a reject entire report, or eighth sub-check below +c yields a reject entire report + action = 'XX' ! reset action back to initialized value + NCEPrc_w = 99999 ! reset wind reason code back to initialized value + endif + else +c Wind direction action is something other than check temperature ('CT') {or, for that +c matter, reject report ('RR')}, so wind (and temperature and moisture if present) will be +c tested later as a single variable unless either wind speed check (action 'CT' checking +c against "bad" temperature) just below yields a reject entire report, or eighth sub-check +c below yields a reject entire report + wdir_action = wdir_action ! dummy statement to allow else branch here + endif + +c If wind speed action is to check temperature ('CT'), then a "bad" temperature will result +c in the entire report being rejected + if(wspd_action.eq.'CT') then + action = 'RR' + cp = 8 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + NCEPrc_w = (cp-1)*100 + RN ! wind RC range 701-734 +c .... first check temperature to see if it is "bad" + if(temp_action.eq.'CW'.or.temp_action.eq.'RT') then + cp = 6 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + NCEPrc_t = (cp-1)*100 + RN ! temperature RC range 501-534 +c ........ a bad temperature rejects entire report +c ........ set RC for moisture to moisture action if moisture rejected, otherwise set it to +c RC for temperature + if(moist_action.eq.'RM') then + cp = 9 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + NCEPrc_q = (cp-1)*100 + RN ! moisture RC range 801-834 + else + NCEPrc_q = NCEPrc_t ! moisture RC range 501-534 + endif + go to 2000 ! reject entire report here means we don't need to do anymore testing + elseif(bl_action.eq.'RT' ) then +c .... finally check reject (black) list to see if temperature is rejected ("bad") +c (Note: bl_action = 'RR' will be considered separately in eighth sub-check below) + cp = 10 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + NCEPrc_t = (cp-1)*100 + RN ! temperature RC range 901-934 +c ........ temperature on reject (black) list rejects entire report +c ........ set RC for moisture to moisture action if moisture rejected, otherwise set it to +c RC for temperature + if(moist_action.eq.'RM') then + cp = 9 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + NCEPrc_q = (cp-1)*100 + RN ! moisture RC range 801-834 + else + NCEPrc_q = NCEPrc_t ! moisture RC range 501-534 + endif + go to 2000 ! reject entire report here means we don't need to do anymore testing + else +c .... even though wind speed action is to check temperature ('CT'), temperature is not"bad", +c so wind (and temperature and moisture if present) will be tested later as a single +c variable unless eighth sub-check below yields a reject entire report + action = 'XX' ! reset action back to initialized value + NCEPrc_w = 99999 ! reset wind reason code back to initialized value + endif + else +c Wind speed action is something other than check temperature ('CT') {or, for that matter, +c reject report ('RR')}, so wind (and temperature and moisture if present) will be tested +c later as a single variable unless eighth sub-check below yields a reject entire report + wspd_action = wspd_action ! dummy statement to allow else branch here + endif + +c --------------------------------------------------------------------------- +C If we make it to here ... +c Eighth sub-check is on REJECT (BLACK) LIST (tenth character of c_qc string) +c --------------------------------------------------------------------------- +c We already know reject (black) list action (from tenth character of c_qc string) from above +c {bl_action, either 'ND', 'RR', 'IO', 'RT', 'RW'} + action = bl_action + if(action.eq.'RR') then + cp = 10 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + NCEPrc = (cp-1)*100 + RN ! RC range 901-934 + go to 2000 ! reject entire report here means we don't need to do anymore testing + endif + +C ************************************************************************* +C If we make it to here ... +c NEXT CHECK SINGLE VARIABLES +C ************************************************************************* + + if(type.eq.'p' .or. type.eq.'z') then ! check 5 +c ***************** +c PRESSURE/ALTITUDE +c ***************** + cp = 5 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + action = w2d(cp-1,RN) ! either 'ND', 'IO', 'NU', 'GV' ('RR' already considered) + NCEPrc = (cp-1)*100 + RN ! pressure/altitude RC range 401-434 + pres_action = action + + elseif(type.eq.'t') then ! check 6, 10 +c *********** +c TEMPERATURE +c *********** + cp = 6 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + action = w2d(cp-1,RN) ! either 'ND', 'IO', 'NU', 'RT', 'GT', 'CW' + ! ('RR' already considered) + NCEPrc_t = (cp-1)*100 + RN ! temperature RC range 501-534 + +c A temperature action of check wind ('CW') is treated as a reject temperature ('RT') - test +c for unilateral reject of entire report above has already tested cases where temperature +c action of 'CW' is combined with a "bad" wind (resulting in a reject of the entire report), +c so we know here that wind is not bad and only temperature should be rejected +c ------------------------------------------------------------------------------------------- + if(action.eq.'CW') action = 'RT' + +c Check reject (black) list flag to see if temperature should be rejected {but ONLY if +c temperature action is not already set to reject temperature ('RT')} +c ------------------------------------------------------------------------------------ + if(action.ne.'RT') then + cp = 10 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + bl_action = w2d(cp-1,RN) ! either 'ND', 'IO', 'RT', 'RW' ('RR' already considered) + if(bl_action.eq.'RT') then + action = 'RT' ! reject temperature + NCEPrc_t = (cp-1)*100 + RN ! temperature RC range 901-934 + endif + endif + + elseif(type.eq.'q') then ! check 9 +c ******** +c MOISTURE +c ******** + cp = 9 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + action = w2d(cp-1,RN) ! either 'ND', 'NU', 'RM', 'SM', 'GM' + ! (Note: 'RR' not a choice here) + NCEPrc_q = (cp-1)*100 + RN ! moisture RC range 801-834 + moist_action = action + + if(action.ne.'RM') then + +c A reject of temperature forces a reject of moisture (if moisture not already rejected) +c -------------------------------------------------------------------------------------- + cp = 6 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + temp_action = w2d(cp-1,RN) ! either 'ND', 'IO', 'NU', 'RT', 'GT', 'CW' + ! ('RR' already considered) + if(temp_action.eq.'RT') then + action = 'RM' + NCEPrc_q = (cp-1)*100 + RN ! moisture RC range 501-534 + endif + endif + + elseif(type.eq.'w') then ! check 7, 8, 10 +c **** +c WIND +c **** + +c First, check Wind direction action +c ---------------------------------- + cp = 7 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + wdir_action = w2d(cp-1,RN) ! either 'ND', 'NU', 'RW', 'SW', 'GW', 'CT' + ! (Note: 'RR' not a choice here) + NCEPrc_w = (cp-1)*100 + RN ! initially set overall wind RC to reflect wind direction + ! status, wind RC range 601-634 {this may be overwritten later + ! by wind speed status if it is inferior to wind direction + ! status (quality-wise)}) + + action = wdir_action ! initially set overall wind action to wind direction + ! action {this may be overwritten later by wind speed action + ! if it is inferior to wind direction action (quality-wise)} + +c A wind direction action of check temperature ('CT') is treated as a reject wind ('RW') - +c test for unilateral reject of entire report above has already tested cases where wind +c direction action of 'CT' is combined with a "bad" temperature (resulting in a reject of +c the entire report), so we know here that temperature is not bad and only wind should be +c rejected +c ---------------------------------------------------------------------------------------- + if(wdir_action.eq.'CT') wdir_action = 'RW' + + if(wdir_action.eq.'RW') then + +c If wind direction action is reject wind ('RW') then set overall wind action to 'RW' - no +c need to examine wind speed action in this case +c ---------------------------------------------------------------------------------------- + action = 'RW' + else + +c Otherwise, check wind speed action to see if it is inferior to wind direction action +C (quality-wise) +c ------------------------------------------------------------------------------------ + + cp = 8 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + wspd_action = w2d(cp-1,RN) ! either 'ND', 'NU', 'RW', 'SW', 'GW', 'CT' + ! (Note: 'RR' not a choice here) + +c A wind speed action of check temperature ('CT') is treated as a reject wind ('RW') - test +c for unilateral reject of entire report above has already tested cases where wind speed +c action of 'CT' is combined with a "bad" temperature (resulting in a reject of the entire +c report), so we know here that temperature is not bad and only wind should be rejected +c ----------------------------------------------------------------------------------------- + if(wspd_action.eq.'CT') wspd_action = 'RW' + + if(wspd_action.eq.'RW') then + +c For cases when wind direction action is not 'RW' but wind speed action is 'RW', use wind +c speed's RC as overall wind RC value since it is inferior to wind direction action +C (quality-wise) +c ---------------------------------------------------------------------------------------- + NCEPrc_w = (cp-1)*100 + RN ! wind RC range 701-734 + action = 'RW' + elseif (wdir_action.eq.'SW') then + +c For cases when wind direction action is suspect wind ('SW') and wind speed action is not +c 'RW', set overall wind action to 'SW' and use wind direction's RC as overall wind RC value +c since it is inferior to wind speed action (quality-wise) +c ------------------------------------------------------------------------------------------- + action = 'SW' + elseif (wspd_action.eq.'SW') then + +c For cases when wind direction action is neither 'RW' nor 'SW' but wind speed action is +c 'SW', set overall wind action to 'SW' and use wind speed's RC as overall wind RC value +c since it is inferior to wind direction action (quality-wise) +c --------------------------------------------------------------------------------------- + NCEPrc_w = (cp-1)*100 + RN ! wind RC range 701-734 + action = 'SW' + endif + endif + +c Check reject (black) list flag to see if wind should be rejected {but ONLY if overall wind +c action is not already set to reject wind ('RW')} +c ------------------------------------------------------------------------------------------ + if(action.ne.'RW') then + cp = 10 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + bl_action = w2d(cp-1,RN) ! either 'ND', 'IO', 'RT', 'RW' ('RR' already considered) + if(bl_action.eq.'RW') then + action = 'RW' ! reject wind + NCEPrc_w = (cp-1)*100 + RN ! wind RC range 901-934 + endif + endif + + endif + +C ************************************************************************* + + 2000 continue + +c ------------------------------------------- +c Translate actions into NCEP QUALITY MARKERS +c ------------------------------------------- + if(action.eq.'RR') then + l_badrpt = .true. + + elseif(action.eq.'DR') then + l_duprpt = .true. + + elseif(action.eq.'GV'.or.action.eq.'GT' .or. + + action.eq.'GM'.or.action.eq.'GW') then + NCEPqm = 1 ! good (RC already set) + + elseif(action.eq.'NU') then + NCEPqm = 2 ! neutral/not checked (RC already set) + + elseif(action.eq.'ND') then ! not defined + NCEPqm = 2 ! QM -> neutral + NCEPrc = 099 ! RC -> 099 - override any RCs already set + + print *, 'type: ',type + print *, 'overall_action: ',overall_action + print *, 'time_action: ',time_action + print *, 'lat/lon_action: ',lat_action,'/',lon_action + print *, 'pres_action: ',pres_action + print *, 'temp_action: ',temp_action + print *, 'moist_action: ',moist_action + print *, 'wdir_action: ',wdir_action + print *, 'wspd_action: ',wspd_action + print *, 'bl_action: ',bl_action + print *, 'c_qc: "',NRLQCstg,'"' + + elseif(action.eq.'RT'.or.action.eq.'RM'.or.action.eq.'RW') then + NCEPqm = 13 ! QM -> bad (RC already set) + + elseif(action.eq.'SM'.or.action.eq.'SW') then + NCEPqm = 3 ! QM -> suspect (RC already set) + + else + cp = 99 ! this is just a dummy statement + ! leave QM as is (IO,GR) + endif + +c ------------------------------------------------------------- +c Set QM, RC info into arrays to be returned to calling routine +c ------------------------------------------------------------- + if(type.eq.'t' .and. NCEPrc_t.ne.99999) then + NCEPrc = NCEPrc_t + elseif(type.eq.'q' .and. NCEPrc_q.ne.99999) then + NCEPrc = NCEPrc_q + elseif(type.eq.'w' .and. NCEPrc_w.ne.99999) then + NCEPrc = NCEPrc_w + endif + + return + + 999 continue + + write(*,*) '*** Warning! RN is out of range 1-34, here = ',RN + call w3tage('PREPOBS_PREPACQC') + call errexit(69) + + end From 7d915a1850a549f826b0a9fb91bcdd5eaf8e7f99 Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz Date: Mon, 19 Aug 2019 17:50:05 -0400 Subject: [PATCH 003/205] remove file added accidentally --- .../GMAO_Etc/GMAO_bias/air_update.f | 867 ------------------ 1 file changed, 867 deletions(-) delete mode 100644 src/Applications/GMAO_Etc/GMAO_bias/air_update.f diff --git a/src/Applications/GMAO_Etc/GMAO_bias/air_update.f b/src/Applications/GMAO_Etc/GMAO_bias/air_update.f deleted file mode 100644 index a1b883b7..00000000 --- a/src/Applications/GMAO_Etc/GMAO_bias/air_update.f +++ /dev/null @@ -1,867 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Global Modeling and Assimilation Office, Code 610.1 ! -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: acdatad data type for aircraft data read from diag or prepbufr -! -! !INTERFACE: -! - module acdatad -! -! !USES: - - implicit none -! -! !DESCRIPTION: -! This module defines observation types for handling aircraft data -! and aircraft bias data -! -! !REVISION HISTORY: -! -! Apr2013 Sienkiewicz Created module -! 4Jun2013 Sienkiewicz added prologue -! 7Mar2014 Sienkiewicz added YYYYMM (kym) to bias structure -! -!EOP -!------------------------------------------------------------------------- - - type :: cft_data_type - real :: xob ! longitude - real :: yob ! latitude - real :: elv ! level - real :: dmn ! delta time (hr) in assim window - real :: pob ! pressure - real :: tob ! temperature - real :: omf ! (obs - ges) - real :: alrt ! asceent/descent rate - character (len=8) :: sid ! aircraft ID - integer :: ityp ! obs type - integer :: itqm ! temperature quality mark - integer :: ks ! 'sounding' index - integer :: is ! index within 'sounding' - end type cft_data_type - - integer, parameter :: maxobs=300000 - integer, parameter :: maxcft=7000 -! -! data type for bias file - type :: bias_data_type - character (len=8) :: sid - real :: bias - real :: err - integer :: nval - integer :: kount - integer :: kskip - integer :: kym - end type bias_data_type - - end module acdatad - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Global Modeling and Assimilation Office, Code 610.1 ! -!----------------------------------------------------------------------- -!BOP -! -! !ROUTINE: cft_update --- update aircraft bias correction files -! -! !INTERFACE: -! - program cft_update - -! !USES: - - use acdatad - use m_MergeSorts - - implicit none - -! -! !DESCRIPTION: Reads in conventional diag file output from GSI and uses -! the observed-minus-forecast values for aircraft temperature -! data (KX=131,133) to update bias correction values for each -! aircraft tail number. -! -! This version calculates ascent/descent rate from consecutive -! observations and optionally uses that information to screen -! out observations in ascending/descending legs from use in -! the bias calculation. -! -! -! !USAGE: cft_update.x diag_file bias_file [outputfile] < gmao_acft_bias.parm -! -! -! !REVISION HISTORY -! -! 15Apr2013 Sienkiewicz Initial code -! 24Apr2013 Sienkiewicz revise to use uncorrected OmF in bias calculation -! 15May2013 Sienkiewicz New more modular version - determine range of -! obs with same tail number and pass to subroutine -! to calculate bias correction. Add constraint -! for level-flight obs for use in bias calculation -! 29May2013 Sienkiewicz Namelist input to control parameters for screening -! allow to run like original version (all good obs) -! or to screen for level flight obs -! 30May2012 Sienkiewicz Write elevation in optional output file in terms of kilo-ft -! (i.e. ~aircraft flight levels) -! 4Jun2013 Sienkiewicz added prologue -! 25Jun2013 Sienkiewicz put additional fields in bias file (for testing) -! to track current stats, number of updates to bias -! and number of times since bias last updated -! 26Jun2013 Sienkiewicz try 'dfact' factor to scale down the bias corr with -! time if it is not updated -! 26Nov2013 Sienkiewicz add restriction of minimum date = 1991040100 for bias corr. -! 11Dec2013 Sienkiewicz Revised defaults to match namelist values -! 7Mar2014 Sienkiewicz Modified output to match format from Yanqiu's code, add index -! column, extra predictor columns, and column with YYYYMM of -! last update for bias. Results same as before, just format change. -! 28Jul2016 Sienkiewicz Switch variance and count columns so they are in the same order -! as in the NCEP bias files. (Probably will otherwise get confused.) -! 17Nov2016 Sienkiewicz add namelist array to choose KX values for bias correction accumulation -! -!EOP -!------------------------------------------------------------------------- - - integer,parameter :: nhdr=8 - integer,parameter :: ntime=8 - integer,parameter :: maxkx=15 - - real, parameter :: m2kft = 39.37/12000. - - CHARACTER(len=200) diagfile,outputfile,biasfile - character(len=3) dtype - CHARACTER(len=8) SUBSET,cstid - - character(8),allocatable, dimension(:):: cdiagbuf - real,allocatable,dimension(:,:)::rdiagbuf - - character(len=11) c_nrlqm - character(len=8) sid - integer idate, lui,luo,lub - type (cft_data_type) :: adata(maxobs) - integer isrt(maxobs),idex(maxobs),n,m,i1,i2 - - type (bias_data_type) :: bdata(maxcft) - type (bias_data_type) :: cdata(maxcft) - type (bias_data_type) :: ddata(maxcft) - integer jdex(maxcft), kdex(maxcft) - - integer argc,iargc - integer nchar, nreal, nobs, mype - integer ndat - integer i,ios - integer ipre, ip, ks, is, im1 - integer itstart,itend - integer idum, kount, kskip - integer nkx - - integer,dimension(maxkx):: kx_list, kx2chk - - integer nflt, nbflt, mflt - integer idx, iym, izero - - real bias, errr - real zero - integer nval - real bnew, enew - real dum - - real plevlim ! limiting pressure level to use in bias calc - real adsclm ! limiting asc/dsc rate to use in bias calc - real dfact ! reduction factor for bias corr - integer nobsmin ! min nobs value used to toss old bias entry - real bvarmin ! minimum value for bias error - integer nminb ! min nobs value for using bias correction - logical docount ! keep tally of # of times tail number - ! appears and count since last updated - integer mindate ! minimum date for aircraft bias to be active - logical apply_bias ! if .false. set bias (as read by GSI) to zero - ! i.e. if prior to mindate - - namelist/acftbias/ plevlim, adsclm, dfact, nobsmin, bvarmin, nminb, - & docount, mindate, kx_list - - integer ichk, jchk, kchk - - logical lprint, verbose - - data lui /10/,lub/11/ - - ndat = 0 - luo = 6 - kdex = -1 - lprint = .false. - verbose = .false. - dfact = 0.99 ! set '1' to be compatible with original - ! recommend value = 0.99 - nobsmin = 0 ! use -1 to match original, recommend > 0 - bvarmin = 0.001 ! default 0.001 to match original - nminb = 10 ! use 1 to be compatible with original - docount = .false. ! default .false. , leave off count - ! (avoid eventual integer overflow) - mindate = 1991040100 ! default minimum date to apply Apr 01, 1991 00z - apply_bias= .true. ! default is to apply the bias - - zero = 0.0 - izero = 0 - - argc = iargc() - if (argc .lt. 2) then - print *,'usage: cft_update.x diag_file bias_file ' - & // '[outputfile] < namelist ' - stop - end if - -! default values for screening - plevlim = 600. - adsclm = 10. - kx_list = 0 - - read(5,acftbias,end=1234) - - go to 1235 - - 1234 continue - print *,'using default values for aircraft bias namelist' - - 1235 continue - - nkx = 0 ! walk through kx_list, stop at 0 value - do i = 1,maxkx - if (kx_list(i) .le. 0) exit - nkx = nkx + 1 - kx2chk(nkx) = kx_list(i) - end do - - if (nkx .eq. 0) then ! if no kx values, use defaults - kx_list(1) = 131 - kx_list(2) = 133 - kx2chk = kx_list - nkx = 2 - end if - - write(*,acftbias) - - print *,'kx2chk = ',kx2chk(1:nkx) - - call getarg(2,biasfile) - if (argc .gt. 2) then - luo = 20 - lprint = .true. - call getarg(3,outputfile) - open(unit=luo,file=outputfile,form='formatted') - end if - - cdata%sid = 'ZZZZZZZZ' - bdata%sid = 'YZZZZZZZ' - ddata%bias = 0.0 - ddata%err = 0.0 - ddata%nval = 0 - - - open(unit=lub,file=biasfile,form='formatted',status='old') - ios = 0 - nbflt = 0 - -! read in bias correction from file, apply reduction factor to -! downweight prior bias - - do while (ios .eq. 0) - read(lub,2010,iostat=ios) sid, idx, dum, dum, dum, - & nval, idum, idum, - & errr, dum, dum, - & iym, bias, dum, dum, idum, kount, kskip - if (ios .eq. 0) then - nbflt = nbflt + 1 - cdata(nbflt)%sid = trim(sid) - cdata(nbflt)%bias = bias ! don't rescale bias - cdata(nbflt)%err = errr*errr/dfact - cdata(nbflt)%nval = nval*dfact - cdata(nbflt)%kount = kount - cdata(nbflt)%kskip = kskip + 1 - cdata(nbflt)%kym = iym - end if - end do - print *,'Read in from biasfile ',trim(biasfile),' total of ', - & nbflt,' entries' - close(lub) - nflt = nbflt - call IndexSet(nflt,jdex) - call IndexSort(nflt,jdex,cdata(1:nflt)%sid,descend=.false.) - -! Read data in from diag files, select observations with kx=131 (AMDAR) or 133 (MDCRS) -! - call getarg(1,diagfile) - open(unit=lui,file=diagfile,form='unformatted',status='old') - - read(lui) idate - - if (idate .lt. mindate) then - print *,'Current date ',idate,' is less than minimum date' - print *,'Calculate bias but pass zero value to GSI' - apply_bias = .false. - end if - - idate = idate / 10000 - - do while (ndat .lt. maxobs) - read(lui,iostat=ios) dtype,nchar,nreal,nobs,mype - if (ios .ne. 0) exit - if (dtype .ne. ' t') then - read(lui) - cycle - end if - allocate(cdiagbuf(nobs),rdiagbuf(nreal,nobs)) - read(lui) cdiagbuf,rdiagbuf - do i = 1,nobs -c$$$ select case (nint(rdiagbuf(1,i))) -c$$$ case (130, 131, 133) - if (any(nint(rdiagbuf(1,i))==kx2chk(1:nkx))) then - ndat = ndat + 1 - if (ndat .gt. maxobs) then - print *,'exceeded maxobs value, ndat = ',ndat - exit - end if - adata(ndat)%xob = rdiagbuf(4,i) - adata(ndat)%yob = rdiagbuf(3,i) - adata(ndat)%elv = rdiagbuf(5,i)*m2kft - adata(ndat)%dmn = rdiagbuf(8,i)*60. - adata(ndat)%pob = rdiagbuf(6,i) - adata(ndat)%tob = rdiagbuf(17,i) - adata(ndat)%omf = rdiagbuf(19,i) - adata(ndat)%sid = trim(cdiagbuf(i)) - adata(ndat)%ityp = nint(rdiagbuf(1,i)) - adata(ndat)%itqm = nint(rdiagbuf(12,i)) - end if -c$$$ case default -c$$$ end select - end do - deallocate(cdiagbuf,rdiagbuf) - - end do - print *,'processed ', ndat, ' obs' - - call IndexSet(ndat,idex) - call IndexSort(ndat,idex,adata(1:ndat)%ityp,descend=.false.) - call IndexSort(ndat,idex,adata(1:ndat)%dmn,descend=.false.) - call IndexSort(ndat,idex,adata(1:ndat)%sid,descend=.false.) - -! -! at this point the obs are sorted by kx, time, and tail number -! we can move along the index array and label flights and calculate -! ascent descent rates and mean values - - mflt = 0 - ipre = idex(1) - ks = 1 - is = 1 - adata(ipre)%ks = ks - adata(ipre)%is = is - adata(ipre)%alrt = 0.0 - itstart = 1 - i1 = 2 - do while (i1 <= ndat) - ip = idex(i1) - if (adata(ip)%sid .ne. adata(ipre)%sid) then - itend = i1-1 - call process_tailno(itstart,itend,idex,adata,plevlim) - call process_bias(itstart,itend,adata,idex,bias,errr,nval, - & plevlim,adsclm) - if (nval .gt. 1) then - mflt = mflt + 1 - bdata(mflt)%sid = adata(ipre)%sid - bdata(mflt)%bias = bias - bdata(mflt)%err = errr - bdata(mflt)%nval = nval - end if - - itstart = i1 - ks = ks + 1 - is = 0 - end if - is = is + 1 - adata(ip)%ks = ks - adata(ip)%is = is - ipre = ip - i1 = i1 + 1 - end do - call process_tailno(itstart,ndat,idex,adata,plevlim) - call process_bias(itstart,ndat,adata,idex,bias,errr,nval, - & plevlim,adsclm) - if (nval .gt. 1) then - mflt = mflt + 1 - bdata(mflt)%sid = adata(ipre)%sid - bdata(mflt)%bias = bias - bdata(mflt)%err = errr - bdata(mflt)%nval = nval - end if - - print *,'total flights extracted from diag file = ',mflt - - ichk = 1 - kchk = 0 - - do jchk = 1,mflt - - do while(ichk .le. nbflt) - if (cdata(jdex(ichk))%sid .ge. bdata(jchk)%sid) exit - if (verbose) print *,cdata(jdex(ichk))%sid, ' lt ', - & bdata(jchk)%sid, ' so no match in new file' - kchk = kchk + 1 - kdex(kchk) = jdex(ichk) - ichk = ichk + 1 - end do - - if (ichk .le. nbflt) then - - if (cdata(jdex(ichk))%sid .eq. bdata(jchk)%sid) then - -! combine the entries - print *,'combining entries for ',bdata(jchk)%sid - i1 = jdex(ichk) -! enew = bdata(jchk)%err*cdata(i1)%err/ -! & (bdata(jchk)%err+cdata(i1)%err) - enew = 1./(1./bdata(jchk)%err + - & 1./cdata(i1)%err) - bnew = (cdata(i1)%bias/cdata(i1)%err + - & bdata(jchk)%bias/bdata(jchk)%err)* - & bdata(jchk)%err*cdata(i1)%err/ - & (bdata(jchk)%err+cdata(i1)%err) - cdata(i1)%bias = bnew - cdata(i1)%err = max(enew,bvarmin) - cdata(i1)%nval = min(5000,bdata(jchk)%nval+ - & cdata(i1)%nval) - cdata(i1)%kskip = 0 - cdata(i1)%kount = cdata(i1)%kount + 1 - cdata(i1)%kym = idate - - ddata(i1)%bias = bdata(jchk)%bias - ddata(i1)%err = bdata(jchk)%err - ddata(i1)%nval = bdata(jchk)%nval - - kchk = kchk + 1 - kdex(kchk) = i1 - ichk = ichk + 1 - - else - -! add an entry at the end of the array and put the location -! in the (after merge) pointer array - - im1 = ichk - 1 - if (im1 .gt. 0) then - print *,'insert ',bdata(jchk)%sid,' between ', - & cdata(jdex(im1))%sid,' and ',cdata(jdex(ichk))%sid - else - print *,'insert ',bdata(jchk)%sid,' at start before ', - & cdata(jdex(ichk))%sid - end if - kchk = kchk + 1 - nflt = nflt + 1 - kdex(kchk) = nflt - cdata(nflt)%sid = bdata(jchk)%sid - cdata(nflt)%bias = bdata(jchk)%bias - cdata(nflt)%err = bdata(jchk)%err - cdata(nflt)%nval = bdata(jchk)%nval - cdata(nflt)%kskip = 0 - cdata(nflt)%kount = 1 - cdata(nflt)%kym = idate - - ddata(nflt)%bias = bdata(jchk)%bias - ddata(nflt)%err = bdata(jchk)%err - ddata(nflt)%nval = bdata(jchk)%nval - - end if - else -! add an entry at the end of the array and put the location -! in the (after merge) pointer array - - print *,'insert ',bdata(jchk)%sid,' at end of array' - kchk = kchk + 1 - nflt = nflt + 1 - kdex(kchk) = nflt - cdata(nflt)%sid = bdata(jchk)%sid - cdata(nflt)%bias = bdata(jchk)%bias - cdata(nflt)%err = bdata(jchk)%err - cdata(nflt)%nval = bdata(jchk)%nval - cdata(nflt)%kskip = 0 - cdata(nflt)%kount = 1 - cdata(nflt)%kym = idate - - ddata(nflt)%bias = bdata(jchk)%bias - ddata(nflt)%err = bdata(jchk)%err - ddata(nflt)%nval = bdata(jchk)%nval - - end if - - end do - - if (ichk .le. nbflt) then - do i1 = ichk,nbflt - if (verbose) print *,cdata(jdex(i1))%sid, - & ' no match in new file' - kchk = kchk + 1 - kdex(kchk) = jdex(i1) - end do - end if - - print *,'total flights in merged file: ',nflt - - - if (lprint) then - write(luo,1999) - 1999 format(' SID DMIN ELEV POB', - & ' XOB YOB TOB TQM KX') - do i1 = 1,ndat - i2 = idex(i1) - write(luo,2000) adata(i2)%sid,adata(i2)%dmn, - & adata(i2)%elv,adata(i2)%pob,adata(i2)%xob, - & adata(i2)%yob,adata(i2)%tob, - & adata(i2)%itqm,adata(i2)%ityp, - & adata(i2)%ks,adata(i2)%is,adata(i2)%alrt - end do - - end if - - open(unit=lub,file=biasfile,form='formatted') - idx = 0 - do i1 = 1,nflt - i2 = kdex(i1) - if (cdata(i2)%nval .gt. nobsmin) then -! fill in bias value read by GSI - if ( apply_bias .and. cdata(i2)%nval >= nminb ) then - bias = cdata(i2)%bias - else - bias = zero - end if - idx = idx + 1 -! -! columns being written 1-12 are read by GSI, 13-18 only in external program -! 1 - tail number -! 2 - index for tail ID -! 3 - bias value to be used by GSI (zerored if too -! little data used or estimate is too old) -! 4 - zero (unused second predictor coefficient) -! 5 - zero (unused third predictor coefficient) -! 6 - running count of obs -! 7 - zero (unused count for second predictor) -! 8 - zero (unused count for third predictor) -! 9 - error value for calculated bias -! 10 - zero (unused slot for second predictor) -! 11 - zero (unused slot for third predictor) -! 12 - YYYYMM time indicator -! 13 - actual bias value calculated -! 14 - mean OmF for tail number for current synoptic time -! 15 - std.dev OmF for tail number for current synoptic time -! 16 - count for tail number for current synoptic time -! (optional) -! 17 - number of days tail number has appeared -! 18 - count of days missing for tail number - if (docount) then - write(lub,2010) cdata(i2)%sid,idx,bias,zero,zero, - & cdata(i2)%nval, izero, izero, - & sqrt(cdata(i2)%err), zero, zero, cdata(i2)%kym, - & cdata(i2)%bias, ddata(i2)%bias, sqrt(ddata(i2)%err), - & ddata(i2)%nval, cdata(i2)%kount, cdata(i2)%kskip - else - write(lub,2010) cdata(i2)%sid,idx,bias,zero,zero, - & cdata(i2)%nval, izero, izero, - & sqrt(cdata(i2)%err), zero, zero, cdata(i2)%kym, - & cdata(i2)%bias, ddata(i2)%bias, sqrt(ddata(i2)%err), - & ddata(i2)%nval - endif - - else - print *,'Removing old bias correction for ',cdata(i2)%sid - end if - end do - - stop - 2000 format(2x,a8,2x,f10.2,5(2x,f10.2),i4,3i6,f10.2) - 2010 format(1x,a8,i5,3f10.2,3i8,3f10.4,i8,2f10.2,f10.3,3i8) - - end program cft_update - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Global Modeling and Assimilation Office, Code 610.1 ! -!----------------------------------------------------------------------- -!BOP -! -! !ROUTINE: process_tailno -! -! !INTERFACE: -! - subroutine process_tailno(itstart,itend,idex,adata,plevlim) - -! !USES: - use acdatad - implicit none - -! !INPUT PARAMETERS: -! - integer itstart ! start value in index of flight - integer itend ! end value in index of flight - integer idex(maxobs) ! sorted index of observations - real plevlim ! limiting pressure level to use for fill value -! -! !INPUT/OUTPUT PARAMETERS: - type (cft_data_type) :: adata(maxobs) ! data structure with observations - -! !DESCRIPTION: process data with same tail number to calculate -! ascent/descent rates -! -! !REVISION HISTORY: -! 24Oct2013 Sienkiewicz new wrapper to separate out 'flights' from -! all obs with same tail number - copied from -! cft_prp_vv.f90 -! -!EOP -!------------------------------------------------------------------------- -! -! run through tail number array to see if delta-dhr is too large, -! split into new flight (no acid available in diag file) -! - integer i - integer ip1, is1, iptr, iprev - real, parameter :: dtlim = 25. - real dt - - is1 = itstart - ip1 = idex(is1) - iprev = ip1 - - do i = itstart+1,itend - iptr = idex(i) - dt = adata(iptr)%dmn-adata(iprev)%dmn - if ( dt .gt. dtlim ) then -! -! end of current flight, process and start new flight - call process_flight(is1,i-1,idex,adata,plevlim) - is1 = i - ip1 = iptr - end if - iprev = iptr - end do - if (is1 <= itend) then - call process_flight(is1,itend,idex,adata,plevlim) - end if - return - end subroutine process_tailno - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Global Modeling and Assimilation Office, Code 610.1 ! -!----------------------------------------------------------------------- -!BOP -! -! !ROUTINE: process_flight -! -! !INTERFACE: -! - subroutine process_flight(itstart,itend,idex,adata,plevlim) - -! !USES: - use acdatad - implicit none - -! !INPUT PARAMETERS: -! - integer itstart ! start value in index of flight - integer itend ! end value in index of flight - integer idex(maxobs) ! sorted index of observations - real plevlim ! limiting pressure level to use for fill value -! -! !INPUT/OUTPUT PARAMETERS: - type (cft_data_type) :: adata(maxobs) ! data structure with observations - -! !DESCRIPTION: process data with same tail number to calculate -! ascent/descent rates -! -! !REVISION HISTORY: -! 15May2013 Sienkiewicz Initial code -! 4Jun2013 Sienkiewicz added prologue -! 23Oct2013 Sienkiewicz trying centered difference calculation -! 29Oct2013 Sienkiewicz add code to exclude 'bad' obs, rename to -! 'process_flight' (changes from cft_prp_vv.f90; -! note we are using dP/dt hPa/min not dZ/dt m/s) -! 30Oct2013 Sienkiewicz pass in plevlim to limit "fill" values for isolated obs -!EOP -!------------------------------------------------------------------------- - - - real, allocatable :: utime(:), ulev(:), alr(:) - integer, allocatable :: nattime(:) - - integer i1,ialrt, intm - integer ier - integer iptr - integer nflt - - nflt = itend - itstart + 1 - - if (nflt .lt. 1) then - print *,'bad flight?',itstart,itend - return - end if - - allocate(utime(nflt),ulev(nflt),alr(nflt),nattime(nflt),stat=ier) - if (ier .ne. 0) then - print *,'error allocating arrays for ascent/descent processing',ier - stop - end if - - utime = 0.0 - ulev = 0.0 - alr = 0.0 - nattime = 0 - - iptr = idex(itstart) - intm = 1 - utime(intm) = adata(iptr)%dmn - ulev(intm) = adata(iptr)%pob - nattime(intm) = 1 - do i1 = itstart+1,itend - iptr=idex(i1) - if (adata(iptr)%dmn .ne. utime(intm)) then -! -! if time is different, add new unique time to array -! - intm = intm + 1 - utime(intm) = adata(iptr)%dmn - ulev(intm) = adata(iptr)%pob - nattime(intm) = 1 - else -! -! if time is the same, combine with other reports with the same time stamp -! - ulev(intm) = ((ulev(intm)*nattime(intm))+adata(iptr)%pob)/ - & (nattime(intm)+1) - nattime(intm) = nattime(intm) + 1 - end if - end do - -! -! add fill value for isolated reports - if below 'plevlim' use -9999.9, if above they -! may be isolated reports at cruise level so leave the 0.0 value - if (intm .lt. 2) then - if(ulev(1) .gt. plevlim) then - alr(1) = -9999.9 - endif - else -! -! we now have 'intm' unique time/level pairs so we can calculate ascent/descent -! rates for each of these times (with an "average" value for the obs with -! identical times) - - alr(1) = (ulev(2)-ulev(1))/(utime(2)-utime(1)) - - do i1 = 2,intm-1 - alr(i1) = (ulev(i1+1)-ulev(i1-1))/(utime(i1+1)-utime(i1-1)) - end do - - alr(intm) = (ulev(intm)-ulev(intm-1))/(utime(intm)-utime(intm-1)) - - end if -! now fill in the calculated ascent/descent rate for each obs in the flight - - ialrt = 1 - do i1 = itstart,itend - iptr = idex(i1) - if (adata(iptr)%itqm .ne. 1) then - adata(iptr)%alrt = -9999.9 - cycle - end if - do while(ialrt < intm .and. utime(ialrt) .ne. adata(iptr)%dmn) - ialrt = ialrt + 1 - end do - if (utime(ialrt) .ne. adata(iptr)%dmn) then - print *,'Error, time not found in array' - adata(iptr)%alrt = -9999.9 - else - adata(iptr)%alrt = alr(ialrt) - end if - end do - - deallocate(utime, ulev, nattime, alr, stat=ier) - if (ier .ne. 0) then - print *,'deallocate failed, ier=',ier - end if - - return - - end subroutine process_flight - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Global Modeling and Assimilation Office, Code 610.1 ! -!----------------------------------------------------------------------- -!BOP -! -! !ROUTINE: process_bias -! -! !INTERFACE: -! - subroutine process_bias(itstart,itend,adata,idex,bias,errr,nval, - & plevlim,adsclm) - -! !USES: - use acdatad - implicit none - -! !INPUT PARAMETERS: -! - integer itstart - integer itend - type (cft_data_type) :: adata(maxobs) - integer idex(maxobs) - real plevlim - real adsclm - -! !OUTPUT PARAMETERS: - integer nval - real bias - real errr - -! !DESCRIPTION: calculate bias for data from given tail number -! with restriction based on ascent/descent rate -! and pressure level -! -! -! !REVISION HISTORY: -! 15May2013 Sienkiewicz Initial code -! 4Jun2013 Sienkiewicz added prologue -!EOP -!------------------------------------------------------------------------- - - -! local variables - real(8) sum,sum2 - integer i, ii - real omf - - sum = 0.0 - sum2 = 0.0 - nval = 0 - do i = itstart,itend - ii = idex(i) - if (adata(ii)%itqm .ne. 1) cycle ! only data that passed qc - if (adata(ii)%pob .ge. plevlim) cycle ! only data higher than plevlim - if (abs(adata(ii)%alrt) .gt. adsclm) cycle !only level(ish) flight - - omf = adata(ii)%omf - sum = sum + omf - sum2 = sum2 + omf*omf - nval = nval + 1 - - end do - - if (nval .gt. 1) then - bias = sum/float(nval) - errr = max((sum2-sum*sum/float(nval))/ - & float(nval*nval),0.01) - end if - - return - - end subroutine process_bias From ba0d5b9b69bfe707789b6b850c40d7e4f86e1d90 Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz Date: Tue, 20 Aug 2019 17:55:06 -0400 Subject: [PATCH 004/205] Additional changes for NRL ACQC * modify script to run the new executable and copy the aircraft profile file to a place where it can be read in by GSI * modify 'prevents.x' to correct bad heights in MERRA2 heritage ACARS data --- .../NCEP_Paqc/{README => ChangeLog} | 0 .../NCEP_Paqc/GMAOprev/gblevents_gmao.f | 81 +++++++++++++++++-- src/Applications/NCEP_Paqc/oiqc/gmao_prepqc | 53 ++++++++++-- 3 files changed, 119 insertions(+), 15 deletions(-) rename src/Applications/NCEP_Paqc/{README => ChangeLog} (100%) diff --git a/src/Applications/NCEP_Paqc/README b/src/Applications/NCEP_Paqc/ChangeLog similarity index 100% rename from src/Applications/NCEP_Paqc/README rename to src/Applications/NCEP_Paqc/ChangeLog diff --git a/src/Applications/NCEP_Paqc/GMAOprev/gblevents_gmao.f b/src/Applications/NCEP_Paqc/GMAOprev/gblevents_gmao.f index 9cff9d91..71ff32a6 100644 --- a/src/Applications/NCEP_Paqc/GMAOprev/gblevents_gmao.f +++ b/src/Applications/NCEP_Paqc/GMAOprev/gblevents_gmao.f @@ -256,7 +256,9 @@ C 2014-05-08 JWhiting -- altered print statement (2 format) in GBLEVN10 C subroutine; increased field width for spectral resolution to C accommodate models w/ up to 5-digit resolution (I3 to I5). -C +C 2016-10-25 M. Sienkiewicz - REPLACE INCORRECT HEIGHTS FOR ACARS OBS +C ABOVE 226.3HPA. (INCORRECT CALCULATION IN MERRA PREPDATA PROCESSING +C PRIOR TO WCOSS TRANSITION.) CONTROL BY NAMELIST SWITCH 'ACARSH'. C C USAGE: CALL GBLEVENTS(IDATEP,IUNITF,IUNITE,IUNITP,IUNITS,SUBSET, C $ NEWTYP) @@ -486,6 +488,11 @@ C PG4243 =.TRUE. ---> GIVE ALL MASS VARIABLES A C PREPBUFR TBL. VAL. 15 C (DEFAULT=.TRUE.) +C ACARSH - RECALCULATE HEIGHTS FOR ACARS DATA WHEN P<226.3 MB +C ACARSH =.FALSE. ---> DO NOT CHANGE REPORTS +C ACARSH =.TRUE. ---> RECALCULATE STD. ATM. HEIGHT ABOVE 226.3 MB +C (DEFAULT=.TRUE.) +C C CC C @@ -521,7 +528,8 @@ SUBROUTINE GBLEVENTS(IDATEP,IUNITF,IUNITE,IUNITP,IUNITS,SUBSET, REAL(8) OBS_8,QMS_8,BAK_8,SID_8,HDR_8(10) REAL(8) BMISS,GETBMISS LOGICAL DOVTMP,DOFCST,SOME_FCST,DOBERR,FCST,VIRT,DOANLS, - $ SATMQC,ADPUPA_VIRT,RECALC_Q,DOPREV,dopmsl,PG4243 + $ SATMQC,ADPUPA_VIRT,RECALC_Q,DOPREV,dopmsl,PG4243, + $ ACARSH DIMENSION IUNITF(2) @@ -529,7 +537,7 @@ SUBROUTINE GBLEVENTS(IDATEP,IUNITF,IUNITE,IUNITP,IUNITS,SUBSET, $ XOB,YOB,DHR,TYP,NLEV COMMON /GBEVBB/ PVCD,VTCD COMMON /GBEVCC/ DOVTMP,DOFCST,SOME_FCST,DOBERR,FCST,VIRT, - $ QTOP_REJ,SATMQC,ADPUPA_VIRT,RECALC_Q,DOPREV,dopmsl,PG4243 + $ QTOP_REJ,SATMQC,ADPUPA_VIRT,RECALC_Q,DOPREV,dopmsl,PG4243,ACARSH COMMON /GBEVDD/ ERRS(300,33,6) COMMON /GBEVFF/ BMISS @@ -551,7 +559,8 @@ SUBROUTINE GBLEVENTS(IDATEP,IUNITF,IUNITE,IUNITP,IUNITS,SUBSET, $ 'POE QOE TOE ZOE WOE PWE PW1E PW2E PW3E PW4E NUL NUL '/ NAMELIST /PREVDATA/DOVTMP,DOFCST,SOME_FCST,DOBERR,DOANLS, - $ QTOP_REJ,SATMQC,ADPUPA_VIRT,RECALC_Q,DOPREV,dopmsl,PG4243 + $ QTOP_REJ,SATMQC,ADPUPA_VIRT,RECALC_Q,DOPREV,dopmsl,PG4243, + $ ACARSH C---------------------------------------------------------------------- C---------------------------------------------------------------------- @@ -588,6 +597,7 @@ SUBROUTINE GBLEVENTS(IDATEP,IUNITF,IUNITE,IUNITP,IUNITS,SUBSET, ADPUPA_VIRT = .FALSE. dopmsl = .false. PG4243 = .TRUE. + ACARSH = .TRUE. READ(5,PREVDATA,ERR=101,END=102) GO TO 103 C----------------------------------------------------------------------- @@ -623,6 +633,8 @@ SUBROUTINE GBLEVENTS(IDATEP,IUNITF,IUNITE,IUNITP,IUNITS,SUBSET, DOBERR = .FALSE. ADPUPA_VIRT = .FALSE. dopmsl = .false. + PG4243 = .FALSE. + ACARSH = .FALSE. ENDIF IF(DOVTMP) RECALC_Q=.TRUE. ! RECALC_Q must be T if DOVTMP is T WRITE (6,PREVDATA) @@ -834,6 +846,10 @@ SUBROUTINE GBLEVENTS(IDATEP,IUNITF,IUNITE,IUNITP,IUNITS,SUBSET, CALL GBLEVN08(IUNITP,SUBSET) ENDIF + if(SUBSET .EQ. 'AIRCAR ' .AND. ACARSH ) then + CALL ACARSFIX(IUNITP) + end if + C RETURN TO CALLING PROGRAM TO WRITE GBL-EVENTED REPORT (SUBSET) INTO C PREPBUFR FILE C ------------------------------------------------------------------- @@ -887,14 +903,14 @@ SUBROUTINE GBLEVN02(IUNITP,IUNITS,NEWTYP,subset) LOGICAL FCST,REJP_PS,REJPS,REJT,REJQ,REJW,REJPW,REJPW1, $ REJPW2,REJPW3,REJPW4,SATMQC,SATEMP,SOLN60,SOLS60, $ MOERR_P,MOERR_T,ADPUPA_VIRT,DOBERR,DOFCST,SOME_FCST, - $ DOVTMP,VIRT,RECALC_Q,DOPREV,dopmsl,PG4243 + $ DOVTMP,VIRT,RECALC_Q,DOPREV,dopmsl,PG4243,ACARSH REAL(8) BMISS COMMON /GBEVAA/ SID_8,OBS_8(13,255),QMS_8(12,255),BAK_8(12,255), $ XOB,YOB,DHR,TYP,NLEV COMMON /GBEVBB/ PVCD,VTCD COMMON /GBEVCC/ DOVTMP,DOFCST,SOME_FCST,DOBERR,FCST,VIRT, - $ QTOP_REJ,SATMQC,ADPUPA_VIRT,RECALC_Q,DOPREV,dopmsl,PG4243 + $ QTOP_REJ,SATMQC,ADPUPA_VIRT,RECALC_Q,DOPREV,dopmsl,PG4243,ACARSH COMMON /GBEVEE/PSG01,ZSG01,TG01(500),UG01(500),VG01(500), x QG01(500),zint(500),pint(500),pintlog(500),plev(500), x plevlog(500) @@ -2185,13 +2201,13 @@ SUBROUTINE GBLEVN08(IUNITP,SUBSET) ! FORMERLY SUBROUTINE VTPEVN LOGICAL EVNQ,EVNV,DOVTMP,TROP,ADPUPA_VIRT,DOBERR,DOFCST, $ SOME_FCST,FCST,VIRT,SATMQC,RECALC_Q,DOPREV, - $ evnp,dopmsl,surf,PG4243 + $ evnp,dopmsl,surf,PG4243,ACARSH COMMON /GBEVAA/ SID_8,OBS_8(13,255),QMS_8(12,255),BAK_8(12,255), $ XOB,YOB,DHR,TYP,NLEV COMMON /GBEVBB/ PVCD,VTCD COMMON /GBEVCC/ DOVTMP,DOFCST,SOME_FCST,DOBERR,FCST,VIRT, - $ QTOP_REJ,SATMQC,ADPUPA_VIRT,RECALC_Q,DOPREV,dopmsl,PG4243 + $ QTOP_REJ,SATMQC,ADPUPA_VIRT,RECALC_Q,DOPREV,dopmsl,PG4243,ACARSH COMMON /GBEVFF/ BMISS DATA EVNSTQ /'QOB QQM QPC QRC'/ @@ -2605,3 +2621,52 @@ subroutine hflip2 ( q,im,jm,dum ) q(:,j) = dum(:) enddo end subroutine hflip2 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! NASA/GSFC, Global Modeling and Assimilation Office, Code 610.1 ! +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: ACARSFIX - modify std atm height for ACARS obs +! +! !INTERFACE: + + subroutine acarsfix(IUNITP) +! +! !INPUT PARAMETERS + INTEGER IUNITP ! BUFR OUTPUT UNIT NUMBER + +! !DESCRIPTION: Replace incorrect ACARS standard atmosphere heights +! that were written to MERRA obs files prior to WCOSS transition +! +! !REVISION HISTORY: +! +! 25Oct2016 M.Sienkiewicz Initial version +! +!EOP +!----------------------------------------------------------------------- + + real(8) zev_8(4) + integer iret + + COMMON /GBEVAA/ SID_8,OBS_8(13,255),QMS_8(12,255),BAK_8(12,255), + $ XOB,YOB,DHR,TYP,NLEV + COMMON /GBEVFF/ BMISS + COMMON /GBEVBB/ PVCD,VTCD + HGTF_HI(P) = 11000 - ALOG(P/226.3)/1.576106E-4 + + if (nlev.eq.1) then + pob = obs_8(1,1) + if (pob .lt. 226.3) then + zob = hgtf_hi(pob) + zev_8(1) = zob + zev_8(2) = qms_8(4,1) + zev_8(3) = pvcd + zev_8(4) = 43 + CALL UFBINT(IUNITP,ZEV_8,4,1,iret,' ZOB ZQM ZPC ZRC ') + CALL UFBINT(IUNITP,ZEV_8(1),1,1,iret,' ELV ') + end if + end if + return + end + diff --git a/src/Applications/NCEP_Paqc/oiqc/gmao_prepqc b/src/Applications/NCEP_Paqc/oiqc/gmao_prepqc index 05db315d..1e976e33 100755 --- a/src/Applications/NCEP_Paqc/oiqc/gmao_prepqc +++ b/src/Applications/NCEP_Paqc/oiqc/gmao_prepqc @@ -21,6 +21,9 @@ # 'gmao_prepqc' without fv2ss step. # 20Mar2009 Todling Remove DASPERL (per da Silva) # 17Nov2015 Meta Clean up some unused (old) fort.XX assignments +# 27Oct2016 Meta Some modifications for new NRL QC +# 02Feb2017 Meta Plumbing fixes for NRL QC - save profile file where it +# can be found by DAS, few other tweaks #------------------------------------------------------------------ # make env vars readily available @@ -83,14 +86,14 @@ use File::Copy; # PREPACQC (Aircraft/AMDAR QC) # -------- $rc1 = system("zeit_ci.x -r $fvwork/.zeit pqc_arqc"); - acqc() if ($doACQC) ; + newacqc() if ($doACQC) ; $rc1 = system("zeit_co.x -r $fvwork/.zeit pqc_arqc"); # ACARSQC (ACARS QC) # ------- - $rc1 = system("zeit_ci.x -r $fvwork/.zeit pqc_acarsqc"); - acarsqc() if ($doACARSQC) ; - $rc1 = system("zeit_co.x -r $fvwork/.zeit pqc_acarsqc"); +# $rc1 = system("zeit_ci.x -r $fvwork/.zeit pqc_acarsqc"); +# acarsqc() if ($doACARSQC) ; +# $rc1 = system("zeit_co.x -r $fvwork/.zeit pqc_acarsqc"); # CQCVAD (Radar VAD wind QC) # ------ @@ -107,6 +110,7 @@ use File::Copy; chdir($prepqcdir); copy("next.$nymd.$hh","$bfr"); + copy("acprof.$nymd.$hh","$cft"); # All done # -------- @@ -152,6 +156,7 @@ sub init { $dd = substr($nymd,6,2); $bfr1 = "$expid.prepqc.obs.${nymd}.t${hh}z.bfr" unless ( $bfr1 ); + $cft1 = "$expid.acft_profl.${nymd}.t${hh}z.bfr"; $spc = 254 unless ( $spc ); @@ -161,6 +166,7 @@ sub init { # Get full pathnames # ------------------ $bfr = fullpath($bfr1); + $cft = fullpath($cft1); $pref = fullpath($pref1); $dynf = fullpath($dynf1); if (! -e $dynf ) { @@ -453,7 +459,6 @@ sub cqcht { Assign("cqc_blktot.$nymd.$hh", 15 ); Assign("cqc_stnlst.$nymd.$hh", 16 ); - Assign("$expid.prog.cqcstats.$nymd", 21 ); Assign("cqc_winderr.$nymd.$hh", 22 ); Assign("$rcdir/prepobs_cqc_statbge", 23 ); @@ -598,6 +603,41 @@ sub profcqc { # copy output file to 'next' so next routine will use it copy("prepprf.$nymd.$hh", "$prepqcdir/next.$nymd.$hh"); +} +#...................................................................... + +sub newacqc { + + $acqcdir = "$prepqcdir/acqc"; # PREPQC working directory + $rc = system("/bin/mkdir -p $acqcdir" ); + die ">>> ERROR <<< cannot create $acqcdir " if ( $rc ); + chdir("$acqcdir"); + system("/bin/touch .no_archiving"); # working prepqc dir not to be archived + +# Assign FORTRAN units for acqc +# ------------------------------------------------------------ + +# NOTE: these files do not follow the fv file name conventions +# Many of the output files are discarded +# ------------------------------------------------------------ + Assign("$prepqcdir/next.$nymd.$hh", 11 ); + Assign("$rcdir/prepobs_prep.bufrtable", 12 ); + + Assign("acftqc_${nymd}${hh}.vvl", 41 ); + Assign("prepaqc.$nymd.$hh", 61 ); + Assign("prepacqc_merge.$nymd.$hh", 62 ); + +# Run prepacqc +# ------- + $cmd = "prepacqc_profl.x < $rcdir/prepobs_prepacqc.merra.parm"; + print "$0: $cmd\n" unless ( $opt_q ); + $rc = system ( $cmd ) unless ( $opt_n ) ; + die ">>>> ERROR <<< running prepacqc.x" if ( $rc ); + +# copy output file to 'next' so next routine will use it + copy("prepaqc.$nymd.$hh", "$prepqcdir/next.$nymd.$hh"); + copy("prepacqc_merge.$nymd.$hh","$prepqcdir/acprof.$nymd.$hh"); + } #...................................................................... @@ -772,8 +812,7 @@ DESCRIPTION gmao_prevents.x - computes O-F cqcbufr.x - radiosonde QC profcqc.x - profiler CQC - prepacqc.x - aircraft qc (other than ACARS) - acarsqc.x - ACARS (MDCARS) aircraft qc + prepacqc_prof.x - aircraft qc oiqcbufr.x - performs actual OIQC The following parameters are required From f06f08726d503dccce6e75e52f9287a8b9244448 Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz Date: Tue, 20 Aug 2019 18:15:23 -0400 Subject: [PATCH 005/205] New README file --- src/Applications/NCEP_Paqc/README | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) create mode 100644 src/Applications/NCEP_Paqc/README diff --git a/src/Applications/NCEP_Paqc/README b/src/Applications/NCEP_Paqc/README new file mode 100644 index 00000000..e338ae82 --- /dev/null +++ b/src/Applications/NCEP_Paqc/README @@ -0,0 +1,16 @@ +README for NCEP_Paqc + - preprocessing QC programs from NCEP and some BUFR utilities + + * block-unblock add/remove f77 filemarkers on BUFR files + (not needed with current BUFR library) + * combine_bfr utilities and notes about combining BUFR files + * GMAOprev GMAO version of NCEP 'prevents' code modified to + read g5-eta files directly. + * modify_bufr utility programs to act on BUFR files + * oiqc NCEP OIQC Optimal interpolation quality control + * prepobs_cqcbufr.fd Raob Complex Quality Control from NCEP + * prepobs_cqcvad.fd VAD wind QC routine from NCEP + * prepobs_prepacqc.fd NCEP aircraft quality control base on NRL QC + * prepobs_profcqc.fd Wind Profiler QC routine from NCEP + * radcor Chris Redder's routines for applying Haimberger + radiosonde adjustments and NCEP radiation correction From fc847d94ee83de237dcd59bbf201d20f32394c0d Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz Date: Thu, 29 Aug 2019 17:54:51 -0400 Subject: [PATCH 006/205] New prepbufr table needed for use with NRL ACQC --- .../GSI_App/prepobs_prep.bufrtable | 1502 +++++++++++------ 1 file changed, 947 insertions(+), 555 deletions(-) diff --git a/src/Applications/GSI_App/prepobs_prep.bufrtable b/src/Applications/GSI_App/prepobs_prep.bufrtable index d4d21346..670f493d 100755 --- a/src/Applications/GSI_App/prepobs_prep.bufrtable +++ b/src/Applications/GSI_App/prepobs_prep.bufrtable @@ -7,134 +7,176 @@ * | * THE FOLLOWING ARE TABLE A ENTRIES FOR PREPBUFR MESSAGE TYPES | * | -| ADPUPA | A60240 | UPPER-AIR (RAOB, PIBAL, RECCO, DROPS) REPORTS | -| AIRCAR | A60241 | ACARS AIRCRAFT REPORTS | -| AIRCFT | A60242 | CONVENTIONAL (AIREP, PIREP) AND ASDAR AIRCRAFT REPORTS | -| SATWND | A60243 | SATELLITE-DERIVED WIND REPORTS | -| PROFLR | A60244 | WIND PROFILER REPORTS | -| VADWND | A60245 | VAD (NEXRAD) WIND REPORTS | -| SATEMP | A60246 | TOVS SATELLITE DATA (SOUNDINGS, RETRIEVALS, RADIANCES) | -| ADPSFC | A60247 | SURFACE LAND (SYNOPTIC, METAR) REPORTS | -| SFCSHP | A60248 | SURFACE MARINE (SHIP, BUOY, C-MAN PLATFORM) REPORTS | -| SFCBOG | A60249 | MEAN SEA-LEVEL PRESSURE BOGUS REPORTS | -| SPSSMI | A60250 | SSM/I RETRIEVAL PRODUCTS (REPROCESSED WIND SPEED, TPW) | -| SYNDAT | A60251 | SYNTHETIC TROPICAL CYCLONE BOGUS REPORTS | -| ERS1DA | A60252 | ERS SCATTEROMETER DATA (REPROCESSED WIND SPEED) | -| GOESND | A60253 | GOES SATELLITE DATA (SOUNDINGS, RETRIEVALS, RADIANCES) | -| QKSWND | A60254 | QUIKSCAT SCATTEROMETER DATA (REPROCESSED WIND SPEED) | +| ADPUPA | A48102 | UPPER-AIR (RAOB, PIBAL, RECCO, DROPS) REPORTS | +| AIRCAR | A48103 | MDCRS ACARS AIRCRAFT REPORTS | +| AIRCFT | A48104 | AIREP, PIREP, AMDAR, TAMDAR AIRCRAFT REPORTS | +| SATWND | A48105 | SATELLITE-DERIVED WIND REPORTS | +| PROFLR | A48106 | WIND PROFILER REPORTS | +| VADWND | A48107 | VAD (NEXRAD) WIND REPORTS | +| SATEMP | A48108 | TOVS SATELLITE DATA (SOUNDINGS, RETRIEVALS, RADIANCES) | +| ADPSFC | A48109 | SURFACE LAND (SYNOPTIC, METAR) REPORTS | +| SFCSHP | A48110 | SURFACE MARINE (SHIP, BUOY, C-MAN PLATFORM) REPORTS | +| SFCBOG | A48111 | MEAN SEA-LEVEL PRESSURE BOGUS REPORTS | +| SPSSMI | A48112 | SSM/I RETRIEVAL PRODUCTS (REPROCESSED WIND SPEED, TPW) | +| SYNDAT | A48113 | SYNTHETIC TROPICAL CYCLONE BOGUS REPORTS | +| ERS1DA | A48114 | ERS SCATTEROMETER DATA (REPROCESSED WIND SPEED) | +| GOESND | A48115 | GOES SATELLITE DATA (SOUNDINGS, RETRIEVALS, RADIANCES) | +| QKSWND | A48116 | QUIKSCAT SCATTEROMETER DATA (REPROCESSED) | +| MSONET | A48117 | MESONET SURFACE REPORTS (COOPERATIVE NETWORKS) | +| GPSIPW | A48118 | GLOBAL POSITIONING SATELLITE-INTEGRATED PRECIP. WATER | +| RASSDA | A48119 | RADIO ACOUSTIC SOUNDING SYSTEM (RASS) TEMP PROFILE RPTS | +| WDSATR | A48120 | WINDSAT SCATTEROMETER DATA (REPROCESSED) | +| ASCATW | A48121 | ASCAT SCATTEROMETER DATA (REPROCESSED) | * | * | * THE FOLLOWING ARE TABLE D ENTRIES FOR SEQUENCES DEFINED IN TABLE A ENTRIES | * | -| HEADR | 361001 | REPORT HEADER SEQUENCE | -| PLEVL | 361002 | PRESSURE LEVEL SEQUENCE (ALL TYPES EXCEPT GOESND) | -| PMSL | 361003 | MEAN SEA LEVEL PRESSURE SEQUENCE | -| BTLEVL | 361004 | BRIGHTNESS TEMPERATURE "LEVEL" SEQUENCE | -| ALTMSQ | 361005 | ALTIMETER SETTING SEQUENCE | -| TURB1SQ | 361006 | AIREP, PIREP, AMDAR AIRCRAFT DEGREE OF TURBULENCE SEQ | -| TURB2SQ | 361007 | ACARS AIRCRAFT DEGREE OF TURBULENCE SEQUENCE | -| ACFSUP | 361008 | AIRCRAFT SUPPLEMENTARY DATA SEQUENCE | -| RFFLSQ | 361009 | NESDIS RECURSIVE FILTER FLAG SEQUENCE | -| WSPDSQ | 361010 | WIND SPEED SEQUENCE | -| PLEVLG | 361011 | GOESND PRESSURE LEVEL SEQUENCE | +| HEADR | 348001 | REPORT HEADER SEQUENCE | +| PRSLEVEL | 348002 | PRESSURE LEVEL SEQUENCE (EXCEPT GOESND, AIRCFT/AIRCAR) | +| PMSL_SEQ | 348003 | MEAN SEA LEVEL PRESSURE SEQUENCE | +| BTMPLEVL | 348004 | BRIGHTNESS TEMPERATURE "LEVEL" SEQUENCE | +| ALTIMSEQ | 348005 | ALTIMETER SETTING SEQUENCE | +| TURB1SEQ | 348006 | TURBULENCE SEQUENCE # 1 | +| TURB2SEQ | 348007 | TURBULENCE SEQUENCE # 2 | +| ACFT_SEQ | 348008 | AIRCRAFT SUPPLEMENTARY DATA SEQUENCE | +| PCCF_SEQ | 348009 | SATELLITE WIND PERCENT CONFIDENCE SEQUENCE | +| PRSLEVLG | 348011 | GOESND PRESSURE LEVEL SEQUENCE | +| TOPC_SEQ | 348012 | TOTAL PRECIPITATION/TOTAL WATER EQUIVALENT SEQUENCE | +| PREWXSEQ | 348013 | PRESENT WEATHER SEQUENCE | +| CLOUDSEQ | 348014 | OBSERVED CLOUD SEQUENCE # 1 | +| HOCT_SEQ | 348015 | HEIGHT OF TOP OF CLOUD SEQUENCE | +| TMXMNSEQ | 348016 | MAXIMUM/MINIMUM TEMPERATURE SEQUENCE | +| SWELLSEQ | 348017 | SWELL WAVE SEQUENCE | +| DBSS_SEQ | 348018 | DEPTH BELOW SEA SURFACE SEQUENCE | +| VISB1SEQ | 348019 | VISIBILITY SEQUENCE # 1 | +| VISB2SEQ | 348020 | VISIBILITY SEQUENCE # 2 | +| VTVI_SEQ | 348021 | VERTICAL VISIBILITY SEQUENCE | +| PSTWXSEQ | 348022 | PAST WEATHER SEQUENCE | +| PKWNDSEQ | 348023 | PEAK WIND SEQUENCE | +| GUST1SEQ | 348024 | MAXIMUM WIND GUST SEQUENCE # 1 | +| GUST2SEQ | 348025 | MAXIMUM WIND GUST SEQUENCE # 2 | +| TPRECSEQ | 348026 | TOTAL PRECIPITATION SEQUENCE | +| TP12_SEQ | 348027 | TOTAL PRECIPITATION PAST 12 HOURS SEQUENCE | +| SUNSHSEQ | 348028 | TOTAL SUNSHINE SEQUENCE | +| CLOU2SEQ | 348029 | OBSERVED CLOUD SEQUENCE # 2 | +| XWSPDSEQ | 348030 | EXTRAPOLATED WIND SPEED SEQUENCE | +| SWINDSEQ | 348031 | SURFACE WIND SEQUENCE | +| SNOW_SEQ | 348032 | SNOW DEPTH SEQUENCE | +| WAVE_SEQ | 348033 | WAVE SEQUENCE | +| SHIP_SEQ | 348034 | SHIP DIRECTION/SPEED SEQUENCE | +| PTENDSEQ | 348035 | PRESSURE TENDENCY SEQUENCE | +| PTE24SEQ | 348036 | 24 HOUR PRESSURE TENDENCY SEQUENCE | +| ACID_SEQ | 348037 | AIRCRAFT FLIGHT NUMBER SEQUENCE | +| AFIC_SEQ | 348038 | AIRCRAFT ICING SEQUENCE | +| TURB3SEQ | 348039 | TURBULENCE SEQUENCE # 3 | +| PRSLEVLA | 348040 | AIRCRAFT (AIRCFT/AIRCAR) PRESSURE LEVEL SEQUENCE | +| LATCORSQ | 348041 | LATITUDE CORRECTION SEQUENCE | +| LONCORSQ | 348042 | LONGITUDE CORRECTION SEQUENCE | +| CLOU3SEQ | 348043 | OBSERVED CLOUD SEQUENCE # 3 (CEILING) | +| APDS_SEQ | 348044 | ATMOSPHERIC PATH DELAY SEQUENCE | * | * | * THE FOLLOWING ARE TABLE D ENTRIES FOR SEQUENCES IN REPORT HEADER | * | -| RSRDSQ | 361012 | RESTRICTIONS ON REDISTRIBUTION SEQUENCE | +| RSRD_SEQ | 348081 | RESTRICTIONS ON REDISTRIBUTION SEQUENCE | * | * | * THE FOLLOWING ARE TABLE D ENTRIES FOR DATA "INFORMATION" SEQUENCES | * | -| PINFO | 362001 | PRESSURE INFORMATION | -| QINFO | 362002 | SPECIFIC HUMIDITY INFORMATION | -| TINFO | 362003 | TEMPERATURE INFORMATION | -| ZINFO | 362004 | HEIGHT INFORMATION | -| WINFO | 362005 | WIND INFORMATION | -| PWINFO | 362006 | PRECIPITABLE WATER INFORMATION | -| PWTINF | 362007 | TOTAL PRECIPITABLE WATER INFORMATION | -| PWLINF | 362008 | LAYER PRECIPITABLE WATER INFORMATION | -| PW1INF | 362009 | 1.0 TO 0.9 SIGMA LAYER PRECIPITABLE WATER INFORMATION | -| PW2INF | 362010 | 0.9 TO 0.7 SIGMA LAYER PRECIPITABLE WATER INFORMATION | -| PW3INF | 362011 | 0.7 TO 0.3 SIGMA LAYER PRECIPITABLE WATER INFORMATION | -| PW4INF | 362012 | 0.3 TO 0.0 SIGMA LAYER PRECIPITABLE WATER INFORMATION | -| BTINFO | 362014 | TOVS OR GOES BRIGHTNESS TEMPERATURE INFORMATION | -| SCINFO | 362015 | SCATTEROMETER DATA INFORMATION | -| DRINFO | 362016 | RADIOSONDE DRIFT INFORMATION | -| RRINFO | 362017 | RAIN RATE INFORMATION | -| CTINFO | 362018 | CLOUD TOP INFORMATION | +| P___INFO | 348141 | PRESSURE INFORMATION | +| Q___INFO | 348142 | SPECIFIC HUMIDITY INFORMATION | +| T___INFO | 348143 | TEMPERATURE INFORMATION | +| Z___INFO | 348144 | HEIGHT INFORMATION | +| W___INFO | 348145 | WIND INFORMATION | +| PW__INFO | 348146 | PRECIPITABLE WATER INFORMATION | +| PWT_INFO | 348147 | TOTAL PRECIPITABLE WATER INFORMATION | +| PWL_INFO | 348148 | LAYER PRECIPITABLE WATER INFORMATION | +| PW1_INFO | 348149 | 1.0 TO 0.9 SIGMA LAYER PRECIPITABLE WATER INFORMATION | +| PW2_INFO | 348150 | 0.9 TO 0.7 SIGMA LAYER PRECIPITABLE WATER INFORMATION | +| PW3_INFO | 348151 | 0.7 TO 0.3 SIGMA LAYER PRECIPITABLE WATER INFORMATION | +| PW4_INFO | 348152 | 0.3 TO 0.0 SIGMA LAYER PRECIPITABLE WATER INFORMATION | +| BTMPINFO | 348153 | TOVS OR GOES BRIGHTNESS TEMPERATURE INFORMATION | +| SCATINFO | 348154 | SCATTEROMETER DATA INFORMATION | +| DRFTINFO | 348155 | PROFILE LEVEL TIME/LOCATION INFORMATION | +| RRT_INFO | 348156 | RAIN RATE INFORMATION | +| CTP_INFO | 348157 | CLOUD TOP INFORMATION | +| SST_INFO | 348158 | SEA TEMPERATURE INFORMATION | * | * | * THE FOLLOWING ARE TABLE D ENTRIES FOR DATA "EVENT" SEQUENCES | * | -| PEVN | 362101 | PRESSURE EVENT SEQUENCE | -| QEVN | 362102 | SPECIFIC HUMIDITY EVENT SEQUENCE | -| TEVN | 362103 | TEMPERATURE EVENT SEQUENCE | -| ZEVN | 362104 | HEIGHT EVENT SEQUENCE | -| WEVN | 362105 | WIND EVENT SEQUENCE | -| DFEVN | 362106 | WIND (DIRECTION/SPEED) EVENT SEQUENCE | -| PWTEVN | 362107 | TOTAL PRECIPITABLE WATER EVENT SEQUENCE | -| PW1EVN | 362108 | 1.0 TO 0.9 PRECIPITABLE WATER EVENT SEQUENCE | -| PW2EVN | 362109 | 0.9 TO 0.7 PRECIPITABLE WATER EVENT SEQUENCE | -| PW3EVN | 362110 | 0.7 TO 0.3 PRECIPITABLE WATER EVENT SEQUENCE | -| PW4EVN | 362111 | 0.3 TO 0.0 PRECIPITABLE WATER EVENT SEQUENCE | -| RREVN | 362112 | RATE RATE EVENT SEQUENCE | -| CTPEVN | 362113 | CLOUD TOP PRESSURE EVENT SEQUENCE | +| P__EVENT | 348171 | PRESSURE EVENT SEQUENCE | +| Q__EVENT | 348172 | SPECIFIC HUMIDITY EVENT SEQUENCE | +| T__EVENT | 348173 | TEMPERATURE EVENT SEQUENCE | +| Z__EVENT | 348174 | HEIGHT EVENT SEQUENCE | +| W__EVENT | 348175 | WIND EVENT SEQUENCE | +| PWTEVENT | 348177 | TOTAL PRECIPITABLE WATER EVENT SEQUENCE | +| PW1EVENT | 348178 | 1.0 TO 0.9 PRECIPITABLE WATER EVENT SEQUENCE | +| PW2EVENT | 348179 | 0.9 TO 0.7 PRECIPITABLE WATER EVENT SEQUENCE | +| PW3EVENT | 348180 | 0.7 TO 0.3 PRECIPITABLE WATER EVENT SEQUENCE | +| PW4EVENT | 348181 | 0.3 TO 0.0 PRECIPITABLE WATER EVENT SEQUENCE | +| RRTEVENT | 348182 | RATE RATE EVENT SEQUENCE | +| CTPEVENT | 348183 | CLOUD TOP PRESSURE EVENT SEQUENCE | +| SSTEVENT | 348184 | SEA TEMPERATURE EVENT SEQUENCE | +| W1_EVENT | 348185 | WIND {DIRECTION/SPEED(kts)} EVENT SEQUENCE | +| W2_EVENT | 348186 | WIND {DIRECTION/SPEED(m/s)} EVENT SEQUENCE | * | * | * THE FOLLOWING ARE TABLE D ENTRIES FOR DATA "BACKGROUND" SEQUENCES | * | -| PBACKG | 362201 | PRESSURE BACKGROUND SEQUENCE | -| QBACKG | 362202 | SPECIFIC HUMIDITY BACKGROUND SEQUENCE | -| TBACKG | 362203 | TEMPERATURE BACKGROUND SEQUENCE | -| ZBACKG | 362204 | HEIGHT BACKGROUND SEQUENCE | -| WBACKG | 362205 | WIND BACKGROUND SEQUENCE | -| PWTBAK | 362206 | TOTAL PRECIPITABLE WATER BACKGROUND SEQUENCE | -| PW1BAK | 362207 | 1.0 TO 0.9 SIGMA LAYER PRECIP WATER BACKGROUND SEQUENCE | -| PW2BAK | 362208 | 0.9 TO 0.7 SIGMA LAYER PRECIP WATER BACKGROUND SEQUENCE | -| PW3BAK | 362209 | 0.7 TO 0.3 SIGMA LAYER PRECIP WATER BACKGROUND SEQUENCE | -| PW4BAK | 362210 | 0.3 TO 0.0 SIGMA LAYER PRECIP WATER BACKGROUND SEQUENCE | -| RRBACKG | 362211 | RAIN RATE BACKGROUND SEQUENCE | -| CTPBAK | 362212 | CLOUD TOP PRESSURE BACKGROUND SEQUENCE | +| P__BACKG | 348191 | PRESSURE BACKGROUND SEQUENCE | +| Q__BACKG | 348192 | SPECIFIC HUMIDITY BACKGROUND SEQUENCE | +| T__BACKG | 348193 | TEMPERATURE BACKGROUND SEQUENCE | +| Z__BACKG | 348194 | HEIGHT BACKGROUND SEQUENCE | +| W__BACKG | 348195 | WIND BACKGROUND SEQUENCE | +| PWTBACKG | 348196 | TOTAL PRECIPITABLE WATER BACKGROUND SEQUENCE | +| PW1BACKG | 348197 | 1.0 TO 0.9 SIGMA LAYER PRECIP WATER BACKGROUND SEQUENCE | +| PW2BACKG | 348198 | 0.9 TO 0.7 SIGMA LAYER PRECIP WATER BACKGROUND SEQUENCE | +| PW3BACKG | 348199 | 0.7 TO 0.3 SIGMA LAYER PRECIP WATER BACKGROUND SEQUENCE | +| PW4BACKG | 348200 | 0.3 TO 0.0 SIGMA LAYER PRECIP WATER BACKGROUND SEQUENCE | +| RRTBACKG | 348201 | RAIN RATE BACKGROUND SEQUENCE | +| CTPBACKG | 348202 | CLOUD TOP PRESSURE BACKGROUND SEQUENCE | +| SSTBACKG | 348203 | SEA TEMPERATURE BACKGROUND SEQUENCE | * | * | * THE FOLLOWING ARE TABLE D ENTRIES FOR DATA "POSTPROCESSING" SEQUENCES | * | -| PPOSTP | 362221 | PRESSURE POSTPROCESSING SEQUENCE | -| QPOSTP | 362222 | SPECIFIC HUMIDITY POSTPROCESSING SEQUENCE | -| TPOSTP | 362223 | TEMPERATURE POSTPROCESSING SEQUENCE | -| ZPOSTP | 362224 | HEIGHT POSTPROCESSING SEQUENCE | -| WPOSTP | 362225 | WIND POSTPROCESSING SEQUENCE | -| PWTPST | 362226 | TOTAL PRECIPITABLE WATER POSTPROCESSING SEQUENCE | -| PW1PST | 362227 | 1.0 TO 0.9 SIGMA LAYER PRECIP WATER POSTPROCESSING SEQ. | -| PW2PST | 362228 | 0.9 TO 0.7 SIGMA LAYER PRECIP WATER POSTPROCESSING SEQ. | -| PW3PST | 362229 | 0.7 TO 0.3 SIGMA LAYER PRECIP WATER POSTPROCESSING SEQ. | -| PW4PST | 362230 | 0.3 TO 0.0 SIGMA LAYER PRECIP WATER POSTPROCESSING SEQ. | -| RRPOSTP | 362231 | RAIN RATE POSTPROCESSING SEQUENCE | -| CTPPST | 362232 | CLOUD TOP PRESSURE POSTPROCESSING SEQUENCE | +| P__POSTP | 348211 | PRESSURE POSTPROCESSING SEQUENCE | +| Q__POSTP | 348212 | SPECIFIC HUMIDITY POSTPROCESSING SEQUENCE | +| T__POSTP | 348213 | TEMPERATURE POSTPROCESSING SEQUENCE | +| Z__POSTP | 348214 | HEIGHT POSTPROCESSING SEQUENCE | +| W__POSTP | 348215 | WIND POSTPROCESSING SEQUENCE | +| PWTPOSTP | 348216 | TOTAL PRECIPITABLE WATER POSTPROCESSING SEQUENCE | +| PW1POSTP | 348217 | 1.0 TO 0.9 SIGMA LAYER PRECIP WATER POSTPROCESSING SEQ. | +| PW2POSTP | 348218 | 0.9 TO 0.7 SIGMA LAYER PRECIP WATER POSTPROCESSING SEQ. | +| PW3POSTP | 348219 | 0.7 TO 0.3 SIGMA LAYER PRECIP WATER POSTPROCESSING SEQ. | +| PW4POSTP | 348220 | 0.3 TO 0.0 SIGMA LAYER PRECIP WATER POSTPROCESSING SEQ. | +| RRTPOSTP | 348221 | RAIN RATE POSTPROCESSING SEQUENCE | +| CTPPOSTP | 348222 | CLOUD TOP PRESSURE POSTPROCESSING SEQUENCE | +| SSTPOSTP | 348223 | SEA TEMPERATURE POSTPROCESSING SEQUENCE | * | * | * THE FOLLOWING ARE TABLE D ENTRIES FOR DATA "CLIMATOLOGY" SEQUENCES | * | -| PCLIM | 362241 | PRESSURE CLIMATOLOGY SEQUENCE | -| QCLIM | 362242 | SPECIFIC HUMIDITY CLIMATOLOGY SEQUENCE | -| TCLIM | 362243 | TEMPERATURE CLIMATOLOGY SEQUENCE | -| ZCLIM | 362244 | HEIGHT CLIMATOLOGY SEQUENCE | -| WCLIM | 362245 | WIND CLIMATOLOGY SEQUENCE | +| PCLIMATO | 348231 | PRESSURE CLIMATOLOGY SEQUENCE | +| QCLIMATO | 348232 | SPECIFIC HUMIDITY CLIMATOLOGY SEQUENCE | +| TCLIMATO | 348233 | TEMPERATURE CLIMATOLOGY SEQUENCE | +| ZCLIMATO | 348234 | HEIGHT CLIMATOLOGY SEQUENCE | +| WCLIMATO | 348235 | WIND CLIMATOLOGY SEQUENCE | * | * | * THE FOLLOWING ARE TABLE D ENTRIES FOR TEMPRY CURRENT MODEL GUESS SEQUENCES | * | -| PFC_MSQ | 363201 | MODEL PRESSURE FORECAST SEQUENCE | -| QFC_MSQ | 363202 | MODEL SPECIFIC HUMIDITY FORECAST SEQUENCE | -| TFC_MSQ | 363203 | MODEL TEMPERATURE FORECAST SEQUENCE | -| ZFC_MSQ | 363204 | MODEL HEIGHT FORECAST SEQUENCE | -| WFC_MSQ | 363205 | MODEL WIND FORECAST SEQUENCE | -| PWF_MSQ | 363206 | MODEL TOTAL PRECIPITABLE WATER FORECAST SEQUENCE | -| PW1F_MSQ | 363207 | MODEL 1.0 TO 0.9 SIGMA LAYER PRECIP WATER FORECAST SEQ. | -| PW2F_MSQ | 363208 | MODEL 0.9 TO 0.7 SIGMA LAYER PRECIP WATER FORECAST SEQ. | -| PW3F_MSQ | 363209 | MODEL 0.7 TO 0.3 SIGMA LAYER PRECIP WATER FORECAST SEQ. | -| PW4F_MSQ | 363210 | MODEL 0.3 TO 0.0 SIGMA LAYER PRECIP WATER FORECAST SEQ. | +| PFC__MSQ | 348241 | MODEL PRESSURE FORECAST SEQUENCE | +| QFC__MSQ | 348242 | MODEL SPECIFIC HUMIDITY FORECAST SEQUENCE | +| TFC__MSQ | 348243 | MODEL TEMPERATURE FORECAST SEQUENCE | +| ZFC__MSQ | 348244 | MODEL HEIGHT FORECAST SEQUENCE | +| WFC__MSQ | 348245 | MODEL WIND FORECAST SEQUENCE | +| PWF__MSQ | 348246 | MODEL TOTAL PRECIPITABLE WATER FORECAST SEQUENCE | +| PW1F_MSQ | 348247 | MODEL 1.0 TO 0.9 SIGMA LAYER PRECIP WATER FORECAST SEQ. | +| PW2F_MSQ | 348248 | MODEL 0.9 TO 0.7 SIGMA LAYER PRECIP WATER FORECAST SEQ. | +| PW3F_MSQ | 348249 | MODEL 0.7 TO 0.3 SIGMA LAYER PRECIP WATER FORECAST SEQ. | +| PW4F_MSQ | 348250 | MODEL 0.3 TO 0.0 SIGMA LAYER PRECIP WATER FORECAST SEQ. | * | * | * THE FOLLOWING ARE TABLE D ENTRIES FOR EVENTS CODES FOR THE VARIOUS | @@ -142,574 +184,924 @@ * THE LAST THREE DIGITS OF THE DESCRIPTOR NUMBER BECOMES THE "PROGRAM CODE" | * | | PREPRO | 363001 | INITIAL PREPBUFR PROCESSING STEP | -* | | (PREPDATA PROGRAM, PRIOR TO PREVENTS OR VTPEVN SUBR.) | +* | | (PREPDATA program, prior to PREVENTS program or VTPEVN | +* subr. in subr. GBLEVENTS) | | SYNDATA | 363002 | SYNTHETIC TROPICAL CYCLONE BOGUS PROCESSING STEP | -* | | (SYNDATA PROGRAM, PRIOR TO PREVENTS SUBROUTINE) | -| CLIMO | 363003 | CLIMO PROGRAM | -* | -| PREVENT | 363004 | PRE-EVENTS BACKGROUND/OBS. ERROR PROCESSING STEP | -* | | (PREVENTS SUBROUTINE IN PREPDATA OR SYNDATA PROGRAM; | -* | | PREVENTS PROGRAM IN CDAS NETWORK RUNS) | +* | | (SYNDATA program, prior to PREVENTS program or VTPEVN | +* subr. in subr. GBLEVENTS) | +| CLIMO | 363003 | CLIMOTOLOGICAL PROCESSING STEP | +* (not yet available) | +| PREVENT | 363004 | PRE-EVENTS BACKGROUND/OBSERVATION ERROR PROCESSING STEP | +* | | (PREVENTS program or GBLEVENTS subroutine in PREPDATA | +* or SYNDATA program) | | CQCHT | 363005 | RAWINSONDE HEIGHT/TEMP COMPLEX QUALITY CONTROL STEP | -* | | (CQCBUFR PROGRAM) | -| RADCOR | 363006 | RAWINSONDE HEIGHT/TEMP RADIATION CORRECTION STEP | -* | | (RADEVN SUBROUTINE IN CQCBUFR PROGRAM) | -| PREPACQC | 363007 | AIREP/PIREP/AMDAR/ASDAR AIRCRAFT QUALITY CONTROL STEP | -* | | (PREPACQC PROGRAM) | +* | | (CQCBUFR program) | +| RADCOR | 363006 | RAWINSONDE HEIGHT/TEMP INTERSONDE(RADIATION) CORR. STEP | +* | | (RADEVN subroutine in CQCBUFR program) | +| PREPACQC | 363007 | AIRCRAFT QUALITY CONTROL STEP (NOT INCL. MDCRS ACARS) | +* | | (obsolete PREPACQC program) | | VIRTMP | 363008 | VIRTUAL TEMPERATURE/SPECIFIC HUMIDITY PROCESSING STEP | -* | | (VTPEVN SUBROUTINE IN PREPDATA, CQCBUFR OR PREVENTS | -* | | PROGRAM; DEPENDING UPON DATA TYPE) | +* | | (PREVENTS program or VTPEVN subr. in subr. GBLEVENTS in | +* PREPDATA program for all obs. types except RAOBS/DROPS;| +* VTPEVN subr. in CQCBUFR program for RAOBS/DROPS) | | CQCPROF | 363009 | WIND PROFILER QUALITY CONTROL STEP | -* | | (PROFCQC PROGRAM) | -| OIQC | 363010 | OI-QUALITY CONTROL STEP | -* | | (OIQCBUFR PROGRAM - GLOBAL VERSION ONLY) | -| SSI | 363011 | SSI ANALYSIS STEP | -* | | (SSIANL PROGRAM - GLOBAL VERSION ONLY) | +* | | (PROFCQC program) | +| OIQC | 363010 | OI-QUALITY MULTI-PLATFROM CONTROL STEP | +* | | (OIQCBUFR program) | +| SSI | 363011 | SSI GLOBAL ANALYSIS STEP | +* | | (SSIANL program) | | CQCVAD | 363012 | VAD WIND QUALITY CONTROL STEP | -* | | (CQCVAD PROGRAM) | -| R3DVAR | 363013 | 3DVAR ANALYSIS STEP | -* | | (R3DVAR PROGRAM - ETA VERSION ONLY) | -| ACARSQC | 363014 | ACARS AIRCRAFT QUALITY CONTROL STEP | -* | | (ACARSQC PROGRAM) | +* | | (CQCVAD program) | +| R3DVAR | 363013 | 3DVAR REGIONAL ANALYSIS STEP | +* | | (R3DVAR program) | +| ACARSQC | 363014 | MDCRS ACARS AIRCRAFT QUALITY CONTROL STEP | +* | | (ACARSQC program) | +| NRLACQC | 363015 | NRL AIRCRAFT QUALITY CONTROL STEP | +* | | (PREPACQC program) | +| GSI | 363016 | GSI ANALYSIS STEP | +* | | (various GSI programs) | +| GLERL | 363017 | GLERL OBSERVATION ADJUSTMENT PROCESSING STEP | +* | | (GLERLADJ program) | +| DEFAULT | 363099 | NON-DEFINED STEP (DEFAULT) | * | * | * THE FOLLOWING ARE TABLE B ENTRIES FOR THE REPORT HEADER | * | -| SID | 001192 | STATION IDENTIFICATION | -| TYP | 001193 | PREPBUFR REPORT TYPE | -| ITP | 002001 | INSTRUMENT TYPE | +| ACID | 001006 | AIRCRAFT FLIGHT NUMBER | +| SAID | 001007 | SATELLITE IDENTIFIER (SATELLITE REPORTS ONLY) | +| SID | 001194 | STATION IDENTIFICATION | +| | | | | SIRC | 002013 | RAWINSONDE SOLAR & INFRARED RADIATION CORR. INDICATOR | -| RPT | 004194 | REPORTED OBSERVATION TIME | -| DHR | 004192 | OBSERVATION TIME MINUS CYCLE TIME | -| TCOR | 004195 | INDICATOR WHETHER OBS. TIME IN "DHR" WAS CORRECTED | -| RCT | 004193 | RECEIPT TIME | +| MSST | 002038 | METHOD OF SEA SURFACE TEMPERATURE MEASUREMENT | +| ITP | 002195 | INSTRUMENT TYPE | +| | | | +| RPT | 004214 | REPORTED OBSERVATION TIME | +| DHR | 004215 | OBSERVATION TIME MINUS CYCLE TIME | +| TCOR | 004216 | INDICATOR WHETHER OBS. TIME IN "DHR" WAS CORRECTED | +| | | | | YOB | 005002 | LATITUDE | -| XOB | 006002 | LONGITUDE | -| ELV | 010194 | STATION ELEVATION | -| SQN | 050001 | REPORT SEQUENCE NUMBER | -| PROCN | 050002 | PROCESS NUMBER FOR THIS MPI RUN (OBTAINED FROM SCRIPT) | -| T29 | 055006 | INPUT REPORT TYPE | -| TSB | 055192 | REPORT SUBTYPE (HAS VARIOUS MEANINGS DEPENDING ON TYPE) | -| ACAV | 008022 | TOTAL # W.R.T. ACCUMULATION OR AVGE (GOES SNDGS ONLY) | +| BEARAZ | 005021 | BEARING OR AZIMUTH | | ATRN | 005034 | ALONG TRACK ROW NUMBER (QUIKSCAT REPORTS ONLY) | -| CTCN | 006034 | CROSS TRACK CELL NUMBER (QUIKSCAT REPORTS ONLY) | +| | | | +| CTCN | 006034 | CROSS TRACK CELL NUMBER (QUIKSCAT & ASCAT REPORTS ONLY) | +| XOB | 006240 | LONGITUDE | +| | | | +| VSSO | 008002 | VERT. SIGNIFICANCE (SFC OBSERVATION) | +| ACAV | 008022 | TOTAL NUMBER WITH RESPECT TO ACCUMULATION OR AVERAGE | +| | | | +| IALR | 010082 | INSTANTANEOUS ALTITUDE RATE | +| ELV | 010199 | STATION ELEVATION | +| | | | | SPRR | 021120 | SEAWINDS PROBABILITY OF RAIN (QUIKSCAT REPORTS ONLY) | -| SAID | 001007 | SATELLITE IDENTIFIER (SATELLITE REPORTS ONLY) | +| | | | +| NRLQMS | 033249 | NRL AIRCRAFT QUALITY CNTRL MARK (ADDED BY PGM PREPACQC) | +| | | | | RSRD | 035200 | RESTRICTIONS ON REDISTRIBUTION | | EXPRSRD | 035201 | EXPIRATION OF RESTRICTIONS ON REDISTRIBUTION | +| | | | +| SQN | 050001 | REPORT SEQUENCE NUMBER | +| PROCN | 050003 | PROCESS NUMBER FOR THIS MPI RUN (OBTAINED FROM SCRIPT) | +| | | | +| TYP | 055007 | PREPBUFR REPORT TYPE | +| T29 | 055008 | DATA DUMP REPORT TYPE | +| TSB | 055009 | REPORT SUBTYPE (HAS VARIOUS MEANINGS DEPENDING ON TYPE) | +| | | | +| PRVSTG | 058009 | MESONET PROVIDER ID STRING | +| SPRVSTG | 058010 | MESONET SUBPROVIDER ID STRING | * | * | * THE FOLLOWING ARE TABLE B ENTRIES FOR THE REPORT LEVEL DATA | * | -| CAT | 001194 | PREPBUFR DATA LEVEL CATEGORY | +| TDMP | 001193 | TRUE DIRECTION OF SHIP DURING PAST 3 HOURS | +| ASMP | 001200 | AVG SPD OF SHIP DURING PAST 3 HOURS | | | | | | PCAT | 002005 | PRECISION OF TEMPERATURE OBSERVATION | +| ROLF | 002199 | AIRCRAFT ROLL ANGLE FLAG | +| AFIC | 020041 | AIRFRAME ICING | +| HBOI | 020194 | HEIGHT OF BASE OF ICING | +| HTOI | 020195 | HEIGHT OF TOP OF ICING | | | | | -| POB | 007192 | PRESSURE OBSERVATION | -| PQM | 007193 | PRESSURE (QUALITY) MARKER | -| PPC | 007194 | PRESSURE PROGRAM CODE | -| PRC | 007195 | PRESSURE REASON CODE | -| PFC | 007196 | PRESSURE FORECAST VALUE | -| POE | 007197 | PRESSURE OBSERVATION ERROR | -| PAN | 007198 | PRESSURE ANALYZED VALUE | -| PCL | 007199 | PRESSURE CLIMATOLOGY | -| PCS | 007200 | PRESSURE CLIMATOLOGY STANDARD DEVIATION | +| .DTH.... | 004031 | DURATION OF TIME IN HOURS RELATED TO FOLLOWING VALUE | +| .DTM.... | 004032 | DURATION OF TIME IN MINS RELATED TO FOLLOWING VALUE | +| RCT | 004217 | RECEIPT TIME | +| HRDR | 004218 | PROFILE LVL TIME-CYCLE (FOR RAOB/PIBAL, BASED ON B DFT) | +| | | | +| CHNM | 005042 | CHANNEL NUMBER | +| YORG | 005214 | REPORTED (ORIGINAL) LATITUDE | +| YCOR | 005216 | INDICATOR WHETHER LAT IN "YOB" WAS CORRECTED FRM "YORG" | +| YDR | 005241 | PROFILE LEVEL LAT (FOR RAOB/PIBAL BASED ON BALLOON DFT) | +| | | | +| XORG | 006214 | REPORTED (ORIGINAL) LONGITUDE | +| XCOR | 006216 | INDICATOR WHETHER LON IN "XOB" WAS CORRECTED FRM "XORG" | +| XDR | 006241 | PROFILE LEVEL LON (FOR RAOB/PIBAL BASED ON BALLOON DFT) | +| | | | +| ELEV | 007021 | SATELLITE ELEVATION (ZENITH ANGLE) | +| SOEL | 007022 | SOLAR ELEVATION (ZENITH ANGLE) | +| SAZA | 007024 | SATELLITE ZENITH ANGLE | +| DBSS | 007062 | DEPTH BELOW SEA SURFACE | +| POB | 007245 | PRESSURE OBSERVATION | +| PQM | 007246 | PRESSURE (QUALITY) MARKER | +| PPC | 007247 | PRESSURE EVENT PROGRAM CODE | +| PRC | 007248 | PRESSURE EVENT REASON CODE | +| PFC | 007249 | FORECAST (BACKGROUND) PRESSURE VALUE | +| POE | 007250 | PRESSURE OBSERVATION ERROR | +| PAN | 007251 | ANALYZED PRESSURE VALUE | +| PCL | 007252 | CLIMATOLOGICAL PRESSURE VALUE | +| PCS | 007253 | STANDARD DEVIATION OF CLIMATOLOGICAL PRESSURE VALUE | +| POETU | 007254 | ANALYSIS-TUNED PRESSURE OBSERVATION ERROR | | | | | | POAF | 008004 | PHASE OF AIRCRAFT FLIGHT | +| CAT | 008193 | PREPBUFR DATA LEVEL CATEGORY | +| .RE.... | 008201 | RELATIONSHIP TO THE FOLLOWING VALUE | | | | | +| ZOB | 010007 | HEIGHT OBSERVATION | | ALSE | 010052 | ALTIMETER SETTING OBSERVATION | -| PMO | 010192 | MEAN SEA-LEVEL PRESSURE OBSERVATION | -| PMQ | 010193 | MEAN SEA-LVL PRESSURE (QUALITY) MARKER | +| 3HPC | 010061 | 3 HOUR PRESSURE CHANGE | +| 24PC | 010062 | 24 HOUR PRESSURE CHANGE | +| CHPT | 010063 | CHARACTERISTIC OF PRESSURE TENDENCY | | PRSS | 010195 | SURFACE PRESSURE OBSERVATION | -| ZOB | 010196 | HEIGHT OBSERVATION | -| ZQM | 010197 | HEIGHT (QUALITY) MARKER | -| ZPC | 010198 | HEIGHT PROGRAM CODE | -| ZRC | 010199 | HEIGHT REASON CODE | -| ZFC | 010200 | HEIGHT FORECAST VALUE | -| ZAN | 010201 | HEIGHT ANALYZED VALUE | -| ZOE | 010202 | HEIGHT OBSERVATION ERROR | -| ZCL | 010203 | HEIGHT CLIMATOLOGY | -| ZCS | 010204 | HEIGHT CLIMATOLOGY STANDARD DEVIATION | +| PMO | 010243 | MEAN SEA-LEVEL PRESSURE OBSERVATION | +| PMQ | 010244 | MEAN SEA-LEVEL PRESSURE (QUALITY) MARKER | +| PMIN | 010245 | MEAN SEA-LEVEL PRESSURE INDICATOR | +| ZQM | 010246 | HEIGHT (QUALITY) MARKER | +| ZPC | 010247 | HEIGHT EVENT PROGRAM CODE | +| ZRC | 010248 | HEIGHT EVENT REASON CODE | +| ZFC | 010249 | FORECAST (BACKGROUND) HEIGHT VALUE | +| ZOE | 010250 | HEIGHT OBSERVATION ERROR | +| ZAN | 010251 | ANALYZED HEIGHT VALUE | +| ZCL | 010252 | CLIMATOLOGICAL HEIGHT VALUE | +| ZCS | 010253 | STANDARD DEVIATION OF CLIMATOLOGICAL HEIGHT VALUE | | | | | +| DDO | 011001 | WIND DIRECTION OBSERVATION (NOT ASSIMILATED) | +* | | (stored for all reports, currently used only by | +* | | "NRLACQC" step for aircraft reports, but will some | +* | | day be used by analysis for surface reports) | +| SOB | 011002 | WIND SPEED OBSERVATION (m/s) (NOT ASSIMILATED) | +* | | (stored only for surface reports, will some day be | +* | | used by analysis) | | UOB | 011003 | U-COMPONENT WIND OBSERVATION | | VOB | 011004 | V-COMPONENT WIND OBSERVATION | -| WQM | 011192 | WIND (QUALITY) MARKER | -| WPC | 011193 | WIND PROGRAM CODE | -| WRC | 011194 | WIND REASON CODE | -| UFC | 011195 | U-COMPONENT FORECAST VALUE | -| VFC | 011196 | V-COMPONENT FORECAST VALUE | -| UAN | 011197 | U-COMPONENT ANALYZED VALUE | -| VAN | 011198 | V-COMPONENT ANALYZED VALUE | -| WOE | 011199 | WIND OBSERVATION ERROR | -| UCL | 011200 | U-COMPONENT CLIMATOLOGY | -| VCL | 011201 | V-COMPONENT CLIMATOLOGY | -| UCS | 011202 | U-COMPONENT CLIMATOLOGY STANDARD DEVIATION | -| VCS | 011203 | V-COMPONENT CLIMATOLOGY STANDARD DEVIATION | -| | | | -| DDO | 011001 | WIND DIRECTION OBSERVATION (NOT ASSIMILATED) | -* | | (AFTER "PREPACQC" STEP ONLY - SUBSEQUENT CODES DO NOT | -* | | PROCESS) | -| SOB | 011002 | WIND SPEED OBSERVATION | -* | | (STORED WHEN DIRECTION IS MISSING; E.G. METARS) | -| FFO | 011191 | WIND SPEED OBSERVATION (NOT ASSIMILATED) | -* | | (AFTER "PREPACQC" STEP ONLY - SUBSEQUENT CODES DO NOT | -* | | PROCESS) | -| DFQ | 011204 | WIND (DIRECTION/SPEED) (QUALITY) MARKER | -| DFP | 011205 | WIND (DIRECTION/SPEED) PROGRAM CODE | -| DFR | 011206 | WIND (DIRECTION/SPEED) REASON CODE | -| | | | -| SQM | 011209 | WIND SPEED (QUALITY) MARKER | -* | | (STORED WHEN DIRECTION IS MISSING; E.G. METARS) | -| | | | | DGOT | 011031 | DEGREE OF TURBULENCE | +| HBOT | 011032 | HEIGHT OF BASE OF TURBULENCE | +| HTOT | 011033 | HEIGHT OF TOP OF TURBULENCE | +| MXGS | 011041 | MAXIMUM WIND SPEED (GUSTS) | +| MXGD | 011043 | MAXIMUM WIND GUST DIRECTION | +| MWD10 | 011081 | MODEL WIND DIRECTION AT 10 M | +| MWS10 | 011082 | MODEL WIND SPEED AT 10 M | +| WDIR1 | 011200 | SURFACE WIND DIRECTION | +| WSPD1 | 011201 | SURFACE WIND SPEED | +| PKWDDR | 011202 | PEAK WIND DIRECTION | +| PKWDSP | 011203 | PEAK WIND SPEED | +| DFQ | 011218 | WIND DIRECTION(DDO)/SPEED(FFO or SOB) (QUALITY) MARKER | +| DFP | 011219 | WIND DIRECTION(DDO)/SPEED(FFO or SOB) EVENT PGM CODE | +| DFR | 011220 | WIND DIRECTION(DDO)/SPEED(FFO or SOB) EVENT REASON CODE | +| XS10 | 011223 | 10 METER EXTRAPOLATED WIND SPEED | +| XS20 | 011224 | 20 METER EXTRAPOLATED WIND SPEED | +| RF10M | 011225 | 10 METER WIND REDUCTION FACTOR | +| TRBX | 011235 | TURBULENCE INDEX | | TRBX10 | 011236 | TURBULENCE INDEX FOR PERIOD (TOB-1 MIN) -> TOB | | TRBX21 | 011237 | TURBULENCE INDEX FOR PERIOD (TOB-2 MIN) -> (TOB-1 MIN) | | TRBX32 | 011238 | TURBULENCE INDEX FOR PERIOD (TOB-3 MIN) -> (TOB-2 MIN) | | TRBX43 | 011239 | TURBULENCE INDEX FOR PERIOD (TOB-4 MIN) -> (TOB-3 MIN) | +| WQM | 011240 | U-, V-COMPONENT WIND (UOB/VOB) (QUALITY) MARKER | +| WPC | 011241 | U-, V-COMPONENT WIND (UOB/VOB) EVENT PROGRAM CODE | +| WRC | 011242 | U-, V-COMPONENT WIND (UOB/VOB) EVENT REASON CODE | +| UFC | 011243 | FORECAST (BACKGROUND) U-COMPONENT WIND VALUE | +| VFC | 011244 | FORECAST (BACKGROUND) V-COMPONENT WIND VALUE | +| WOE | 011245 | U-, V-COMPONENT WIND (UOB/VOB) OBSERVATION ERROR | +| UAN | 011246 | ANALYZED U-COMPONENT WIND VALUE | +| VAN | 011247 | ANALYZED V-COMPONENT WIND VALUE | +| UCL | 011248 | CLIMATOLOGICAL U-COMPONENT WIND VALUE | +| VCL | 011249 | CLIMATOLOGICAL V-COMPONENT WIND VALUE | +| UCS | 011250 | STANDARD DEVIATION OF CLIMATOLOGICAL U-COMP WIND VALUE | +| VCS | 011251 | STANDARD DEVIATION OF CLIMATOLOGICAL V-COMP WIND VALUE | +| FFO | 011252 | WIND SPEED OBSERVATION (kts) (NOT ASSIMILATED) | +* | | (stored only for all non-surface reports, currently | +* | | used only by "NRLACQC" step for aircraft reports) | +| WOETU | 011253 | ANALYSIS-TUNED WIND OBSERVATION ERROR | | | | | -| TOB | 012192 | TEMPERATURE OBSERVATION | -* | | (AFTER "PREPRO" STEP - REPORTED TEMP, EITHER SENSIBLE | -* | | OR VIRTUAL DEPENDING UPON DATA TYPE; | -* | | AFTER "VIRTMP" STEP - VIRTUAL TEMPERATURE IF MOISTURE | -* | | AVAILABLE, OTHERWISE SENSIBLE) | -| TQM | 012195 | TEMPERATURE (QUALITY) MARKER | -| TPC | 012196 | TEMPERATURE PROGRAM CODE | -| TRC | 012197 | TEMPERATURE REASON CODE | -| TFC | 012198 | TEMPERATURE FORECAST VALUE | -| TAN | 012199 | TEMPERATURE ANALYZED VALUE | -| TOE | 012200 | TEMPERATURE OBSERVATION ERROR | -| TCL | 012201 | TEMPERATURE CLIMATOLOGY | -| TCS | 012202 | TEMPERATURE CLIMATOLOGY STANDARD DEVIATION | -| | | | -| TDO | 012194 | DEWPOINT TEMPERATURE OBSERVATION (NOT ASSIMILATED) | -* | | (AFTER "VIRTMP" STEP ONLY - SUBSEQUENT CODES DO NOT | -* | | PROCESS) | -| TVO | 012193 | NON-Q. CONTROLLED VIRTUAL TEMP OBS (NOT ASSIMILATED) | -* | | (AFTER "PREPRO" STEP ONLY - SUBSEQUENT CODES DO NOT | -* | | PROCESS) | +| MXTM | 012111 | MAXIMUM TEMPERATURE | +| MITM | 012112 | MINIMUM TEMPERATURE | +| TMSK | 012161 | SKIN TEMPERATURE | +| TMBR | 012163 | BRIGHTNESS TEMPERATURE | | GCDTT | 012210 | GOES CLOUD TOP TEMPERATURE OBSERVATION | +| TVO | 012243 | NON-Q. CONTROLLED VIRTUAL TEMP OBS (NOT ASSIMILATED) | +* | | (currently not used by any steps beyond "PREPRO") | +| TDO | 012244 | DEWPOINT TEMPERATURE OBSERVATION (NOT ASSIMILATED) | +* | | (used only by "VIRTMP" step) | +| TOB | 012245 | TEMPERATURE OBSERVATION | +* | | {after "PREPRO" step: reported T, either Ts or Tv | +* | | depending upon data type; after "VIRTMP" step: Tv if | +* | | moisture available and T after "PREPRO" step is Ts | +* | | (except for aircraft), otherwise as defined after | +* | | "PREPRO" step} | +| TQM | 012246 | TEMPERATURE (QUALITY) MARKER | +| TPC | 012247 | TEMPERATURE EVENT PROGRAM CODE | +| TRC | 012248 | TEMPERATURE EVENT REASON CODE | +| TFC | 012249 | FORECAST (BACKGROUND) TEMPERATURE VALUE | +| TOE | 012250 | TEMPERATURE OBSERVATION ERROR | +| TAN | 012251 | ANALYZED TEMPERATURE VALUE | +| TCL | 012252 | CLIMATOLOGICAL TEMPERATURE VALUE | +| TCS | 012253 | STANDARD DEVIATION OF CLIMATOLOGICAL TEMPERATURE VALUE | +| TOETU | 012254 | ANALYSIS-TUNED TEMPERATURE OBSERVATION ERROR | | | | | -| QOB | 013192 | SPECIFIC HUMIDITY OBSERVATION | -* | | (AFTER "VIRTMP" STEP - ALWAYS RECALCULATED FROM QUALITY | -* | | CONTROLLED VIRTUAL TEMPERATURE DATA) | -| QQM | 013193 | SPECIFIC HUMIDITY (QUALITY) MARKER | -| QPC | 013194 | SPECIFIC HUMIDITY PROGRAM CODE | -| QRC | 013195 | SPECIFIC HUMIDITY REASON CODE | -| QFC | 013196 | SPECIFIC HUMIDITY FORECAST VALUE | -| QAN | 013197 | SPECIFIC HUMIDITY ANALYZED VALUE | -| QOE | 013198 | RELATIVE HUMIDITY OBSERVATION ERROR | -| QCL | 013199 | SPECIFIC HUMIDITY CLIMATOLOGY | -| QCS | 013200 | SPECIFIC HUMIDITY CLIMATOLOGY STANDARD DEVIATION | -| | | | -| REQ6 | 013206 | RAINFALL/WATER EQUIVALENT OF SNOW (AVERAGE RATE) | -| REQ6_QM | 013207 | RAINFALL (AVERAGE RATE) (QUALITY) MARKER | -| REQ6_PC | 013208 | RAINFALL (AVERAGE RATE) PROGRAM CODE | -| REQ6_RC | 013209 | RAINFALL (AVERAGE RATE) REASON CODE | -| REQ6_FC | 013210 | RAINFALL (AVERAGE RATE) FORECAST VALUE | -| REQ6_AN | 013211 | RAINFALL (AVERAGE RATE) ANALYZED VALUE | -| REQ6_OE | 013212 | RAINFALL (AVERAGE RATE) OBSERVATION ERROR | -| | | | -| PWO | 013213 | TOTAL PRECIPITABLE WATER OBSERVATION | -| PWQ | 013214 | TOTAL PRECIPITABLE WATER (QUALITY) MARKER | -| PWP | 013215 | TOTAL PRECIPITABLE WATER PROGRAM CODE | -| PWR | 013216 | TOTAL PRECIPITABLE WATER REASON CODE | -| PWF | 013217 | TOTAL PRECIPITABLE WATER FORECAST VALUE | -| PWA | 013218 | TOTAL PRECIPITABLE WATER ANALYZED VALUE | -| PWE | 013219 | TOTAL PRECIPITABLE WATER OBSERVATION ERROR | -| PW1O | 013220 | 1.0 TO 0.9 SIGMA LAYER PRECIPITABLE WATER OBSERVATION | -| PW1Q | 013221 | 1.0 TO 0.9 SIGMA LAYER PRECIPITABLE WATER MARKER | -| PW1P | 013222 | 1.0 TO 0.9 SIGMA LAYER PRECIPITABLE WATER PROGRAM CODE | -| PW1R | 013223 | 1.0 TO 0.9 SIGMA LAYER PRECIPITABLE WATER REASON CODE | -| PW1F | 013224 | 1.0 TO 0.9 SIGMA LAYER PRECIPITABLE WATER FORECAST VAL | -| PW1A | 013225 | 1.0 TO 0.9 SIGMA LAYER PRECIPITABLE WATER ANALYZED VAL | -| PW1E | 013226 | 1.0 TO 0.9 SIGMA LAYER PRECIPITABLE WATER OBS. ERROR | -| PW2O | 013227 | 0.9 TO 0.7 SIGMA LAYER PRECIPITABLE WATER OBSERVATION | -| PW2Q | 013228 | 0.9 TO 0.7 SIGMA LAYER PRECIPITABLE WATER MARKER | -| PW2P | 013229 | 0.9 TO 0.7 SIGMA LAYER PRECIPITABLE WATER PROGRAM CODE | -| PW2R | 013230 | 0.9 TO 0.7 SIGMA LAYER PRECIPITABLE WATER REASON CODE | -| PW2F | 013231 | 0.9 TO 0.7 SIGMA LAYER PRECIPITABLE WATER FORECAST VAL | -| PW2A | 013232 | 0.9 TO 0.7 SIGMA LAYER PRECIPITABLE WATER ANALYZED VAL | -| PW2E | 013233 | 0.9 TO 0.7 SIGMA LAYER PRECIPITABLE WATER OBS. ERROR | -| PW3O | 013234 | 0.7 TO 0.3 SIGMA LAYER PRECIPITABLE WATER OBSERVATION | -| PW3Q | 013235 | 0.7 TO 0.3 SIGMA LAYER PRECIPITABLE WATER MARKER | -| PW3P | 013236 | 0.7 TO 0.3 SIGMA LAYER PRECIPITABLE WATER PROGRAM CODE | -| PW3R | 013237 | 0.7 TO 0.3 SIGMA LAYER PRECIPITABLE WATER REASON CODE | -| PW3F | 013238 | 0.7 TO 0.3 SIGMA LAYER PRECIPITABLE WATER FORECAST VAL | -| PW3A | 013239 | 0.7 TO 0.3 SIGMA LAYER PRECIPITABLE WATER ANALYZED VAL | -| PW3E | 013240 | 0.7 TO 0.3 SIGMA LAYER PRECIPITABLE WATER OBS. ERROR | -| PW4O | 013241 | 0.3 TO 0.0 SIGMA LAYER PRECIPITABLE WATER OBSERVATION | -| PW4Q | 013242 | 0.3 TO 0.0 SIGMA LAYER PRECIPITABLE WATER MARKER | -| PW4P | 013243 | 0.3 TO 0.0 SIGMA LAYER PRECIPITABLE WATER PROGRAM CODE | -| PW4R | 013244 | 0.3 TO 0.0 SIGMA LAYER PRECIPITABLE WATER REASON CODE | -| PW4F | 013245 | 0.3 TO 0.0 SIGMA LAYER PRECIPITABLE WATER FORECAST VAL | -| PW4A | 013246 | 0.3 TO 0.0 SIGMA LAYER PRECIPITABLE WATER ANALYZED VAL | -| PW4E | 013247 | 0.3 TO 0.0 SIGMA LAYER PRECIPITABLE WATER OBS. ERROR | -| | | | -| TOCC | 020010 | CLOUD COVER (TOTAL) | -| CDTP | 020016 | CLOUD TOP PRESSURE OBSERVATION | -| CDTP_QM | 020207 | CLOUD TOP PRESSURE (QUALITY) MARKER | -| CDTP_PC | 020208 | CLOUD TOP PRESSURE PROGRAM CODE | -| CDTP_RC | 020209 | CLOUD TOP PRESSURE REASON CODE | -| CDTP_FC | 020210 | CLOUD TOP PRESSURE FORECAST VALUE | -| CDTP_AN | 020211 | CLOUD TOP PRESSURE ANALYZED VALUE | -| CDTP_OE | 020212 | CLOUD TOP PRESSURE OBSERVATION ERROR | +| TOPC | 013011 | TOTAL PRECIPITATION/TOTAL WATER EQUIVALENT | +| DOFS | 013012 | DEPTH OF FRESH SNOW | +| TOSD | 013013 | TOTAL SNOW DEPTH | +| REQV | 013014 | RAINFALL (AVERAGE RATE) OBSERVATION | +| TP01 | 013019 | TOTAL PRECIPITATION PAST 1 HOUR | +| TP03 | 013020 | TOTAL PRECIPITATION PAST 3 HOURS | +| TP06 | 013021 | TOTAL PRECIPITATION PAST 6 HOURS | +| TP12 | 013022 | TOTAL PRECIPITATION PAST 12 HOURS | +| TP24 | 013023 | TOTAL PRECIPITATION PAST 24 HOURS | +| MRWVC | 013096 | MWR WATER VAPOR CONTENT (TOTAL WATER VAPOR) | +| MRLWC | 013097 | MWR LIQUID WATER CONTENT (TOTAL CLOUD LIQUID WATER) | +| PWO | 013193 | TOTAL PRECIPITABLE WATER OBSERVATION | +| PW1O | 013202 | 1.0 TO 0.9 SIGMA LAYER PRECIPITABLE WATER OBSERVATION | +| PW2O | 013203 | 0.9 TO 0.7 SIGMA LAYER PRECIPITABLE WATER OBSERVATION | +| PW3O | 013204 | 0.7 TO 0.3 SIGMA LAYER PRECIPITABLE WATER OBSERVATION | +| QOB | 013245 | SPECIFIC HUMIDITY OBSERVATION | +* | | (after "VIRTMP" step: always recalculated from QC'd Tv) | +| ESBAK | 013242 | FORECAST(BACKGROUND) SATURATION SPECIFIC HUMIDITY VALUE | +| QQM | 013246 | SPECIFIC HUMIDITY (QUALITY) MARKER | +| QPC | 013247 | SPECIFIC HUMIDITY EVENT PROGRAM CODE | +| QRC | 013248 | SPECIFIC HUMIDITY EVENT REASON CODE | +| QFC | 013249 | FORECAST (BACKGROUND) SPECIFIC HUMIDITY VALUE | +| QOE | 013250 | RELATIVE HUMIDITY OBSERVATION ERROR | +| QAN | 013251 | ANALYZED SPECIFIC HUMIDITY VALUE | +| QCL | 013252 | CLIMATOLOGICAL SPECIFIC HUMIDITY VALUE | +| QCS | 013253 | STANDARD DEV OF CLIMATOLOGICAL SPECIFIC HUMIDITY VALUE | +| QOETU | 013254 | ANALYSIS-TUNED RELATIVE HUMIDITY OBSERVATION ERROR | | | | | -| RFFL | 025202 | NESDIS RECURSIVE FILTER FLAG | +| TOSS | 014031 | TOTAL SUNSHINE | | | | | -| ELEV | 007021 | SATELLITE ELEVATION (ZENITH ANGLE) | -| SOEL | 007022 | SOLAR ELEVATION (ZENITH ANGLE) | | OZON | 015001 | OZONE | -| TMSK | 012061 | SKIN TEMPERATURE | -| CLAM | 020011 | CLOUD AMOUNT | -| CHNM | 005042 | CHANNEL NUMBER | -| TMBR | 012063 | BRIGHTNESS TEMPERATURE | +| APDS | 015031 | ATMOSPHERIC PATH DELAY IN SATELLITE SIGNAL | +| APDE | 015032 | ESTIMATED ERROR IN ATMOSPHERIC PATH DELAY | | | | | -| A1 | 048001 | ERS INCIDENT ANGLE #1 | -| A2 | 048002 | ERS INCIDENT ANGLE #2 | -| A3 | 048003 | ERS INCIDENT ANGLE #3 | +| HOVI | 020001 | HORIZONTAL VISIBILITY | +| VTVI | 020002 | VERTICAL VISIBILITY | +| PRWE | 020003 | PRESENT WEATHER | +| PSW1 | 020004 | PAST WEATHER (1) | +| PSW2 | 020005 | PAST WEATHER (2) | +| TOCC | 020010 | CLOUD COVER (TOTAL) | +| CLAM | 020011 | CLOUD AMOUNT | +| CLTP | 020012 | CLOUD TYPE | +| HOCB | 020013 | HEIGHT OF BASE OF CLOUD | +| HOCT | 020014 | HEIGHT OF TOP OF CLOUD | +| CDTP | 020016 | CLOUD TOP PRESSURE OBSERVATION | +| HBLCS | 020201 | HEIGHT ABOVE SURFACE OF BASE OF LOWEST CLOUD SEEN | +| CEILING | 020204 | CLOUD CEILING (DERIVATIVE OF HOCB - HGT OF CLOUD BASE) | +| WSST | 020219 | WINDSAT SURFACE TYPE | +| CTPQM | 020246 | CLOUD TOP PRESSURE (QUALITY) MARKER | +| CTPPC | 020247 | CLOUD TOP PRESSURE EVENT PROGRAM CODE | +| CTPRC | 020248 | CLOUD TOP PRESSURE EVENT REASON CODE | +| CTPFC | 020249 | FORECAST (BACKGROUND) CLOUD TOP PRESSURE VALUE | +| CTPOE | 020250 | CLOUD TOP PRESSURE OBSERVATION ERROR | +| CTPAN | 020251 | ANALYZED CLOUD TOP PRESSURE VALUE | | | | | -| B1 | 048004 | ERS AZIMUTH ANGLE #1 | -| B2 | 048005 | ERS AZIMUTH ANGLE #2 | -| B3 | 048006 | ERS AZIMUTH ANGLE #3 | +| LKCS | 021104 | LIKELIHOOD COMPUTED FOR SOLUTION (ASCAT REPORTS ONLY) | +| WVCQ | 021155 | WIND VECTOR CELL QUALITY (ASCAT REPORTS ONLY) | +| BSCD | 021156 | BACKSCATTER DISTANCE (ASCAT REPORTS ONLY) | +| A1 | 021226 | ERS INCIDENT ANGLE NUMBER 1 | +| A2 | 021227 | ERS INCIDENT ANGLE NUMBER 2 | +| A3 | 021228 | ERS INCIDENT ANGLE NUMBER 3 | +| B1 | 021231 | ERS AZIMUTH ANGLE NUMBER 1 | +| B2 | 021232 | ERS AZIMUTH ANGLE NUMBER 2 | +| B3 | 021233 | ERS AZIMUTH ANGLE NUMBER 3 | +| S1 | 021236 | ERS BACKSCATTER NUMBER 1 | +| S2 | 021237 | ERS BACKSCATTER NUMBER 2 | +| S3 | 021238 | ERS BACKSCATTER NUMBER 3 | +| E1 | 021241 | ERS ERROR ESTIMATE NUMBER 1 | +| E2 | 021242 | ERS ERROR ESTIMATE NUMBER 2 | +| E3 | 021243 | ERS ERROR ESTIMATE NUMBER 3 | | | | | -| S1 | 048007 | ERS BACKSCATTER #1 | -| S2 | 048008 | ERS BACKSCATTER #2 | -| S3 | 048009 | ERS BACKSCATTER #3 | +| DOSW | 022003 | DIRECTION OF SWELL WAVES | +| POWV | 022011 | PERIOD OF WAVES | +| POWW | 022012 | PERIOD OF WIND WAVES | +| POSW | 022013 | PERIOD OF SWELL WAVES | +| HOWV | 022021 | HEIGHT OF WAVES | +| HOWW | 022022 | HEIGHT OF WIND WAVES | +| HOSW | 022023 | HEIGHT OF SWELL WAVES | +| SST1 | 022043 | SEA TEMPERATURE | +| SSTQM | 022246 | SEA TEMPERATURE (QUALITY) MARKER | +| SSTPC | 022247 | SEA TEMPERATURE EVENT PROGRAM CODE | +| SSTRC | 022248 | SEA TEMPERATURE EVENT REASON CODE | +| SSTFC | 022249 | FORECAST (BACKGROUND) SEA TEMPERATURE VALUE | +| SSTOE | 022250 | SEA TEMPERATURE OBSERVATION ERROR | +| SSTAN | 022251 | ANALYZED SEA TEMPERATURE VALUE | | | | | -| E1 | 048010 | ERS ERROR ESTIMATE #1 | -| E2 | 048011 | ERS ERROR ESTIMATE #2 | -| E3 | 048012 | ERS ERROR ESTIMATE #3 | +| MSTQ | 033026 | MOISTURE QUALITY | +| RFFL | 033196 | PERCENT CONFIDENCE BASED ON NESDIS RECURSIVE FILTER FCN | +| QIFY | 033197 | PERCENT CONFIDENCE BASED ON EUMETSAT QUAL INDX W/ FCST | +| QIFN | 033198 | PERCENT CONFIDENCE BASED ON EUMETSAT QUAL INDX W/O FCST | +| CHSQ | 033199 | CHI-SQUARED (OF THE WIND VECTOR RETRIEVAL) | +| WSEQC1 | 033200 | WINDSAT EDR QC FLAG #1 | +| PHER | 033201 | EST. ERROR COVARIANCE FOR WIND DIRECTION RETRIEVAL | +| EEQF | 033203 | PERCENT CONFIDENCE BASED ON NESDIS EXPECTED ERROR | +| PVWTG | 033204 | ANAL VARIATIONAL QC WEIGHT ON PRESS. OBS BASED ON GUESS | +| PVWTA | 033205 | ANAL VARIATIONAL QC WEIGHT ON PRESS. OBS BASED ON ANAL | +| TVWTG | 033206 | ANAL VARIATIONAL QC WEIGHT ON TEMP. OBS BASED ON GUESS | +| TVWTA | 033209 | ANAL VARIATIONAL QC WEIGHT ON TEMP. OBS BASED ON ANAL | +| QVWTG | 033210 | ANAL VARIATIONAL QC WEIGHT ON MOIST. OBS BASED ON GUESS | +| QVWTA | 033211 | ANAL VARIATIONAL QC WEIGHT ON MOIST. OBS BASED ON ANAL | +| WVWTG | 033212 | ANAL VARIATIONAL QC WEIGHT ON WIND OBS BASED ON GUESS | +| WVWTA | 033213 | ANAL VARIATIONAL QC WEIGHT ON WIND OBS BASED ON ANAL | +| PWTVWTG | 033214 | ANAL VARIAT. QC WGHT ON TOT PREC. WTR OBS BASED ON GESS | +| PWTVWTA | 033228 | ANAL VARIAT. QC WGHT ON TOT PREC. WTR OBS BASED ON ANAL | +| SSTE | 033245 | EST. ERROR COVARIANCE FOR SEA SURFACE TEMP RETRIEVAL | +| SPDE | 033246 | EST. ERROR COVARIANCE FOR WIND SPEED RETRIEVAL | +| VPRE | 033247 | EST. ERROR COVARIANCE FOR TOTAL WATER VAPOR RETRIEVAL | +| CLDE | 033248 | EST. ERROR COVARIANCE FOR TOTAL CLD LIQUID WATER RETR. | | | | | -| HRDR | 004202 | RADIOSONDE BALLOON DRIFT TIME MINUS CYCLE TIME | -| YDR | 005202 | RADIOSONDE BALLOON DRIFT LATITUDE | -| XDR | 006202 | RADIOSONDE BALLOON DRIFT LONGITUDE | +| RRTQM | 051001 | RAINFALL (AVERAGE RATE) (QUALITY) MARKER | +| RRTPC | 051002 | RAINFALL (AVERAGE RATE) EVENT PROGRAM CODE | +| RRTRC | 051003 | RAINFALL (AVERAGE RATE) EVENT REASON CODE | +| RRTFC | 051004 | FORECAST (BACKGROUND) RAINFALL (AVERAGE RATE) VALUE | +| RRTOE | 051005 | RAINFALL (AVERAGE RATE) OBSERVATION ERROR | +| RRTAN | 051006 | ANALYZED RAINFALL (AVERAGE RATE) VALUE | +| PWQ | 051021 | TOTAL PRECIPITABLE WATER (QUALITY) MARKER | +| PWP | 051022 | TOTAL PRECIPITABLE WATER EVENT PROGRAM CODE | +| PWR | 051023 | TOTAL PRECIPITABLE WATER EVENT REASON CODE | +| PWF | 051024 | FORECAST (BACKGROUND) TOTAL PRECIPITABLE WATER VALUE | +| PWE | 051025 | TOTAL PRECIPITABLE WATER OBSERVATION ERROR | +| PWA | 051026 | ANALYZED TOTAL PRECIPITABLE WATER VALUE | +| PWETU | 051027 | ANALYSIS-TUNED TOTAL PRECIPITABLE WATER OBS ERROR | +| PW1Q | 051032 | 1.0 TO 0.9 SIGMA LAYER PRECIP. WATER (QUALITY) MARKER | +| PW1P | 051033 | 1.0 TO 0.9 SIGMA LAYER PRECIP. WATER EVENT PROGRAM CODE | +| PW1R | 051034 | 1.0 TO 0.9 SIGMA LAYER PRECIP. WATER EVENT REASON CODE | +| PW1F | 051035 | FCST(BACKGRND) 1.0 TO 0.9 SIGMA LYR PRECIP. WATER VALUE | +| PW1E | 051036 | 1.0 TO 0.9 SIGMA LAYER PRECIP. WATER OBSERVATION ERROR | +| PW1A | 051037 | ANALYZED 1.0 TO 0.9 SIGMA LAYER PRECIP. WATER VALUE | +| PW2Q | 051042 | 0.9 TO 0.7 SIGMA LAYER PRECIP. WATER (QUALITY) MARKER | +| PW2P | 051043 | 0.9 TO 0.7 SIGMA LAYER PRECIP. WATER EVENT PROGRAM CODE | +| PW2R | 051044 | 0.9 TO 0.7 SIGMA LAYER PRECIP. WATER EVENT REASON CODE | +| PW2F | 051045 | FCST(BACKGRND) 0.9 TO 0.7 SIGMA LYR PRECIP. WATER VALUE | +| PW2E | 051046 | 0.9 TO 0.7 SIGMA LAYER PRECIP. WATER OBSERVATION ERROR | +| PW2A | 051047 | ANALYZED 0.9 TO 0.7 SIGMA LAYER PRECIP. WATER VALUE | +| PW3Q | 051052 | 0.7 TO 0.3 SIGMA LAYER PRECIP. WATER (QUALITY) MARKER | +| PW3P | 051053 | 0.7 TO 0.3 SIGMA LAYER PRECIP. WATER EVENT PROGRAM CODE | +| PW3R | 051054 | 0.7 TO 0.3 SIGMA LAYER PRECIP. WATER EVENT REASON CODE | +| PW3F | 051055 | FCST(BACKGRND) 0.7 TO 0.3 SIGMA LYR PRECIP. WATER VALUE | +| PW3E | 051056 | 0.7 TO 0.3 SIGMA LAYER PRECIP. WATER OBSERVATION ERROR | +| PW3A | 051057 | ANALYZED 0.7 TO 0.3 SIGMA LAYER PRECIP. WATER VALUE | +| PW4O | 051061 | 0.3 TO 0.0 SIGMA LAYER PRECIPITABLE WATER OBSERVATION | +| PW4Q | 051062 | 0.3 TO 0.0 SIGMA LAYER PRECIP. WATER (QUALITY) MARKER | +| PW4P | 051063 | 0.3 TO 0.0 SIGMA LAYER PRECIP. WATER EVENT PROGRAM CODE | +| PW4R | 051064 | 0.3 TO 0.0 SIGMA LAYER PRECIP. WATER EVENT REASON CODE | +| PW4F | 051065 | FCST(BACKGRND) 0.3 TO 0.0 SIGMA LYR PRECIP. WATER VALUE | +| PW4E | 051066 | 0.3 TO 0.0 SIGMA LAYER PRECIP. WATER OBSERVATION ERROR | +| PW4A | 051067 | ANALYZED 0.3 TO 0.0 SIGMA LAYER PRECIP. WATER VALUE | | | | | * The following are added temporarily until PFC, ZFC, etc. contain current | * model guess instead of Global guess (applies for all models except Global) | | | | | -| PFC_MOD | 007201 | MODEL PRESSURE FORECAST VALUE (GLOBAL MODEL SEE PFC) | -| ZFC_MOD | 010205 | MODEL HEIGHT FORECAST VALUE (GLOBAL MODEL SEE ZFC) | -| UFC_MOD | 011207 | MODEL U-COMPONENT FORECAST VALUE (GLOBAL MODEL SEE UFC) | -| VFC_MOD | 011208 | MODEL V-COMPONENT FORECAST VALUE (GLOBAL MODEL SEE VFC) | -| TFC_MOD | 012203 | MODEL TEMPERATURE FORECAST VALUE (GLOBAL MODEL SEE TFC) | -| QFC_MOD | 013248 | MODEL S. HUMIDITY FORECAST VALUE (GLOBAL MODEL SEE QFC) | -| PWF_MOD | 013249 | MODEL TOTAL PWATER FORECAST VALUE (GLOBAL MODEL SEE PWC) | -| PW1F_MOD | 013250 | MODEL 1.-.9 SIG. LYR PWATER FCST (GLOBAL MODEL SEE PW1F) | -| PW2F_MOD | 013251 | MODEL .9-.7 SIG. LYR PWATER FCST (GLOBAL MODEL SEE PW2F) | -| PW3F_MOD | 013252 | MODEL .7-.3 SIG. LYR PWATER FCST (GLOBAL MODEL SEE PW3F) | -| PW4F_MOD | 013253 | MODEL .3-0. SIG. LYR PWATER FCST (GLOBAL MODEL SEE PW4F) | +| PFCMOD | 007255 | MODEL PRESSURE FORECAST VALUE (GLOBAL MODEL SEE PFC) | +| ZFCMOD | 010255 | MODEL HEIGHT FORECAST VALUE (GLOBAL MODEL SEE ZFC) | +| UFCMOD | 011254 | MODEL U-COMPONENT FORECAST VALUE (GLOBAL MODEL SEE UFC) | +| VFCMOD | 011255 | MODEL V-COMPONENT FORECAST VALUE (GLOBAL MODEL SEE VFC) | +| TFCMOD | 012255 | MODEL TEMPERATURE FORECAST VALUE (GLOBAL MODEL SEE TFC) | +| QFCMOD | 013255 | MODEL S. HUMIDITY FORECAST VALUE (GLOBAL MODEL SEE QFC) | +| PWFMOD | 051030 | MODEL TOTAL PWATER FORECAST VALUE(GLOBAL MODEL SEE PWC) | +| PW1FMOD | 051040 | MODEL 1.-.9 SIG. LYR PWATER FCST(GLOBAL MODEL SEE PW1F) | +| PW2FMOD | 051050 | MODEL .9-.7 SIG. LYR PWATER FCST(GLOBAL MODEL SEE PW2F) | +| PW3FMOD | 051060 | MODEL .7-.3 SIG. LYR PWATER FCST(GLOBAL MODEL SEE PW3F) | +| PW4FMOD | 051070 | MODEL .3-0. SIG. LYR PWATER FCST(GLOBAL MODEL SEE PW4F) | | | | | |------------------------------------------------------------------------------| | MNEMONIC | SEQUENCE | |----------|-------------------------------------------------------------------| | | | -| ADPUPA | HEADR {PLEVL} SIRC | -| AIRCAR | HEADR PLEVL | -| AIRCFT | HEADR PLEVL RCT | -| SATWND | HEADR PLEVL SAID | -| PROFLR | HEADR {PLEVL} | -| VADWND | HEADR {PLEVL} | -| SATEMP | HEADR {PLEVL} SAID {BTLEVL} | -| GOESND | HEADR {PLEVLG} SAID {BTLEVL} ACAV | -| ADPSFC | HEADR PLEVL | -| SFCSHP | HEADR PLEVL | -| SFCBOG | HEADR PLEVL | -| SPSSMI | HEADR CAT SAID | -| SPSSMI | {BTLEVL} | -| SYNDAT | HEADR {PLEVL} | -| ERS1DA | HEADR CAT SAID | -| QKSWND | HEADR CAT SAID CTCN ATRN SPRR | -| | | -| HEADR | SID XOB YOB DHR ELV TYP T29 TSB ITP SQN | -| HEADR | PROCN RPT TCOR | -| PLEVL | CAT | -| PLEVLG | CAT | -| BTLEVL | CHNM TMBR | -| | | -| RSRDSQ | RSRD EXPRSRD | -| | | -| PINFO | [PEVN] | -| QINFO | [QEVN] TDO | -| TINFO | [TEVN] TVO | -| ZINFO | [ZEVN] | -| WINFO | [WEVN] [DFEVN] | -| PWINFO | | -| PWTINF | [PWTEVN] | -| PWLINF | PRSS | -| PW1INF | [PW1EVN] | -| PW2INF | [PW2EVN] | -| PW3INF | [PW3EVN] | -| PW4INF | [PW4EVN] | -| BTINFO | ELEV SOEL OZON TMSK CLAM | -| SCINFO | A1 A2 A3 B1 B2 B3 S1 S2 S3 E1 E2 E3 | -| PMSL | PMO PMQ | -| ALTMSQ | ALSE | -| WSPDSQ | SOB SQM | -| TURB1SQ | DGOT | -| TURB2SQ | TRBX10 TRBX21 TRBX32 TRBX43 | -| RFFLSQ | RFFL | -| ACFSUP | PCAT POAF | -| DRINFO | XDR YDR HRDR | -| RRINFO | [RREVN] | -| CTINFO | [CTPEVN] TOCC GCDTT | -| | | -| PEVN | POB PQM PPC PRC | -| QEVN | QOB QQM QPC QRC | -| TEVN | TOB TQM TPC TRC | -| ZEVN | ZOB ZQM ZPC ZRC | -| WEVN | UOB WQM WPC WRC VOB | -| DFEVN | DDO FFO DFQ DFP DFR | -| PWTEVN | PWO PWQ PWP PWR | -| PW1EVN | PW1O PW1Q PW1P PW1R | -| PW2EVN | PW2O PW2Q PW2P PW2R | -| PW3EVN | PW3O PW3Q PW3P PW3R | -| PW4EVN | PW4O PW4Q PW4P PW4R | -| RREVN | REQ6 REQ6_QM REQ6_PC REQ6_RC | -| CTPEVN | CDTP CDTP_QM CDTP_PC CDTP_RC | -| | | -| PBACKG | POE PFC | -| QBACKG | QOE QFC | -| TBACKG | TOE TFC | -| ZBACKG | ZOE ZFC | -| WBACKG | WOE UFC VFC | -| PWTBAK | PWE PWF | -| PW1BAK | PW1E PW1F | -| PW2BAK | PW2E PW2F | -| PW3BAK | PW3E PW3F | -| PW4BAK | PW4E PW4F | -| RRBACKG | REQ6_OE REQ6_FC | -| CTPBAK | CDTP_OE CDTP_FC | -| | | -| PPOSTP | PAN | -| QPOSTP | QAN | -| TPOSTP | TAN | -| ZPOSTP | ZAN | -| WPOSTP | UAN VAN | -| PWTPST | PWA | -| PW1PST | PW1A | -| PW2PST | PW2A | -| PW3PST | PW3A | -| PW4PST | PW4A | -| RRPOSTP | REQ6_AN | -| CTPPST | CDTP_AN | -| | | -| PCLIM | PCL PCS | -| QCLIM | QCL QCS | -| TCLIM | TCL TCS | -| ZCLIM | ZCL ZCS | -| WCLIM | UCL UCS VCL VCS | -| | | -| PFC_MSQ | PFC_MOD | -| QFC_MSQ | QFC_MOD | -| TFC_MSQ | TFC_MOD | -| ZFC_MSQ | ZFC_MOD | -| WFC_MSQ | UFC_MOD VFC_MOD | -| PWF_MSQ | PWF_MOD | -| PW1F_MSQ | PW1F_MOD | -| PW2F_MSQ | PW2F_MOD | -| PW3F_MSQ | PW3F_MOD | -| PW4F_MSQ | PW4F_MOD | +| ADPUPA | HEADR SIRC {PRSLEVEL} {CLOUDSEQ} | +| ADPUPA | | +| | | +| AIRCAR | HEADR ACID {PRSLEVLA} | +| | | +| AIRCFT | HEADR {PRSLEVLA} | +| | | +| SATWND | HEADR SAID PRSLEVEL SAZA | +| | | +| PROFLR | HEADR {PRSLEVEL} | +| | | +| VADWND | HEADR {PRSLEVEL} | +| | | +| SATEMP | HEADR SAID {PRSLEVEL} {BTMPLEVL} | +| | | +| GOESND | HEADR SAID ACAV {PRSLEVLG} {BTMPLEVL} | +| | | +| ADPSFC | HEADR CAT | +| ADPSFC | [W2_EVENT] | +| ADPSFC | {PREWXSEQ} {CLOUDSEQ} {TMXMNSEQ} {SWELLSEQ} | +| ADPSFC | | +| ADPSFC | | +| ADPSFC | | +| | | +| SFCSHP | HEADR CAT | +| SFCSHP | [W2_EVENT] | +| SFCSHP | {CLOUDSEQ} {SWELLSEQ} | +| SFCSHP | | +| SFCSHP | | +| | | +| SFCBOG | HEADR CAT | +| | | +| SPSSMI | HEADR CAT SAID | +| SPSSMI | {BTMPLEVL} | +| | | +| SYNDAT | HEADR {PRSLEVEL} | +| | | +| ERS1DA | HEADR CAT SAID | +| | | +| QKSWND | HEADR CAT SAID CTCN ATRN SPRR | +| | | +| MSONET | HEADR PRVSTG SPRVSTG CAT | +| MSONET | [W2_EVENT] | +| MSONET | {TOPC_SEQ} | +| | | +| GPSIPW | HEADR CAT PW__INFO | +| | | +| RASSDA | HEADR {PRSLEVEL} | +| | | +| WDSATR | HEADR CAT SAID ACAV REQV SST1 | +| WDSATR | MWD10 MWS10 MRWVC MRLWC WSST CHSQ | +| WDSATR | WSEQC1 PHER SSTE SPDE VPRE CLDE | +| | | +| ASCATW | HEADR CAT SAID CTCN WVCQ BSCD LKCS | +| | | +| HEADR | SID 207003 XOB YOB 207000 DHR ELV TYP T29 | +| HEADR | TSB ITP SQN PROCN RPT TCOR | +| | | +| PRSLEVEL | CAT | +| PRSLEVEL | [W1_EVENT] | +| | | +| PRSLEVLG | CAT | +| PRSLEVLG | | +| | | +| PRSLEVLA | RCT ROLF MSTQ IALR | +| PRSLEVLA | CAT | +| PRSLEVLA | [W1_EVENT] | +| PRSLEVLA | {TURB3SEQ} {PREWXSEQ} {CLOUDSEQ} {AFIC_SEQ} NRLQMS | +| | | +| BTMPLEVL | CHNM TMBR | +| | | +| P___INFO | [P__EVENT] | +| Q___INFO | [Q__EVENT] TDO | +| T___INFO | [T__EVENT] TVO | +| Z___INFO | [Z__EVENT] | +| W___INFO | [W__EVENT] | +| PW__INFO | PRSS | +| PWT_INFO | [PWTEVENT] | +| PWL_INFO | | +| PW1_INFO | [PW1EVENT] | +| PW2_INFO | [PW2EVENT] | +| PW3_INFO | [PW3EVENT] | +| PW4_INFO | [PW4EVENT] | +| RRT_INFO | [RRTEVENT] | +| CTP_INFO | [CTPEVENT] TOCC GCDTT | +| SST_INFO | [SSTEVENT] MSST | +| BTMPINFO | ELEV SOEL OZON TMSK CLAM | +| DRFTINFO | 207003 XDR YDR 207000 HRDR | +| SCATINFO | A1 A2 A3 B1 B2 B3 S1 S2 S3 E1 E2 E3 | +| | | +| TURB1SEQ | TRBX | +| TURB2SEQ | TRBX10 TRBX21 TRBX32 TRBX43 | +| PCCF_SEQ | RFFL QIFY QIFN EEQF | +| ACFT_SEQ | PCAT POAF | +| RSRD_SEQ | RSRD EXPRSRD | +| PMSL_SEQ | PMO PMQ PMIN | +| ALTIMSEQ | ALSE | +| TOPC_SEQ | .DTHTOPC TOPC | +| PREWXSEQ | PRWE | +| CLOUDSEQ | VSSO CLAM CLTP HOCB | +| HOCT_SEQ | HOCT | +| TMXMNSEQ | .DTHMXTM MXTM .DTHMITM MITM | +| SWELLSEQ | DOSW HOSW POSW | +| DBSS_SEQ | DBSS | +| VISB1SEQ | .REHOVI HOVI | +| VISB2SEQ | HOVI | +| VTVI_SEQ | VTVI | +| PSTWXSEQ | PSW1 PSW2 | +| PKWNDSEQ | PKWDSP PKWDDR | +| GUST1SEQ | .DTMMXGS MXGS | +| GUST2SEQ | MXGS MXGD | +| TPRECSEQ | TP01 TP03 TP06 TP24 | +| TP12_SEQ | TP12 | +| SUNSHSEQ | TOSS | +| CLOU2SEQ | TOCC HBLCS | +| XWSPDSEQ | XS10 XS20 | +| SWINDSEQ | WDIR1 WSPD1 | +| SNOW_SEQ | .DTHDOFS DOFS TOSD | +| WAVE_SEQ | HOWV POWV HOWW POWW | +| SHIP_SEQ | TDMP ASMP | +| PTENDSEQ | CHPT 3HPC | +| PTE24SEQ | 24PC | +| ACID_SEQ | ACID | +| AFIC_SEQ | AFIC HBOI HTOI | +| TURB3SEQ | DGOT HBOT HTOT | +| LATCORSQ | 207003 YORG 207000 YCOR | +| LONCORSQ | 207003 XORG 207000 XCOR | +| CLOU3SEQ | CEILING | +| APDS_SEQ | BEARAZ ELEV APDS APDE | +| | | +| P__EVENT | POB PQM PPC PRC | +| Q__EVENT | QOB QQM QPC QRC | +| T__EVENT | TOB TQM TPC TRC | +| Z__EVENT | ZOB ZQM ZPC ZRC | +| W__EVENT | UOB VOB WQM WPC WRC | +| W1_EVENT | DDO FFO DFQ DFP DFR | +| W2_EVENT | DDO SOB DFQ DFP DFR | +| PWTEVENT | PWO PWQ PWP PWR | +| PW1EVENT | PW1O PW1Q PW1P PW1R | +| PW2EVENT | PW2O PW2Q PW2P PW2R | +| PW3EVENT | PW3O PW3Q PW3P PW3R | +| PW4EVENT | PW4O PW4Q PW4P PW4R | +| RRTEVENT | 202130 201134 REQV 201000 202000 RRTQM RRTPC RRTRC | +| CTPEVENT | CDTP CTPQM CTPPC CTPRC | +| SSTEVENT | SST1 SSTQM SSTPC SSTRC | +| | | +| P__BACKG | POE PFC | +| Q__BACKG | QOE QFC | +| T__BACKG | TOE TFC | +| Z__BACKG | ZFC | +| W__BACKG | WOE UFC VFC | +| PWTBACKG | PWE PWF | +| PW1BACKG | PW1E PW1F | +| PW2BACKG | PW2E PW2F | +| PW3BACKG | PW3E PW3F | +| PW4BACKG | PW4E PW4F | +| RRTBACKG | RRTOE RRTFC | +| CTPBACKG | CTPOE CTPFC | +| SSTBACKG | SSTOE SSTFC | +| | | +| P__POSTP | PAN POETU PVWTG PVWTA | +| Q__POSTP | QAN QOETU QVWTG QVWTA ESBAK | +| T__POSTP | TAN TOETU TVWTG TVWTA | +| Z__POSTP | ZAN | +| W__POSTP | UAN VAN WOETU WVWTG WVWTA RF10M | +| PWTPOSTP | PWA PWETU PWTVWTG PWTVWTA | +| PW1POSTP | PW1A | +| PW2POSTP | PW2A | +| PW3POSTP | PW3A | +| PW4POSTP | PW4A | +| RRTPOSTP | RRTAN | +| CTPPOSTP | CTPAN | +| SSTPOSTP | SSTAN | +| | | +| PCLIMATO | PCL PCS | +| QCLIMATO | QCL QCS | +| TCLIMATO | TCL TCS | +| ZCLIMATO | ZCL ZCS | +| WCLIMATO | UCL UCS VCL VCS | +| | | +| PFC__MSQ | PFCMOD | +| QFC__MSQ | QFCMOD | +| TFC__MSQ | TFCMOD | +| ZFC__MSQ | ZFCMOD | +| WFC__MSQ | UFCMOD VFCMOD | +| PWF__MSQ | PWFMOD | +| PW1F_MSQ | PW1FMOD | +| PW2F_MSQ | PW2FMOD | +| PW3F_MSQ | PW3FMOD | +| PW4F_MSQ | PW4FMOD | | | | |------------------------------------------------------------------------------| | MNEMONIC | SCAL | REFERENCE | BIT | UNITS |-------------| |----------|------|-------------|-----|--------------------------|-------------| | | | | | |-------------| +| ACID | 0 | 0 | 64 | CCITT IA5 |-------------| +| SAID | 0 | 0 | 10 | CODE TABLE |-------------| | SID | 0 | 0 | 64 | CCITT IA5 |-------------| -| XOB | 2 | -18000 | 16 | DEG E |-------------| -| XDR | 2 | -18000 | 16 | DEG E |-------------| -| YOB | 2 | -9000 | 15 | DEG N |-------------| -| YDR | 2 | -9000 | 15 | DEG N |-------------| -| RPT | 3 | 0 | 16 | HOURS |-------------| -| DHR | 3 | -24000 | 16 | HOURS |-------------| -| TCOR | 0 | 0 | 2 | CODE TABLE |-------------| -| RCT | 2 | 0 | 12 | HOURS |-------------| -| HRDR | 3 | -24000 | 16 | HOURS |-------------| -| ELV | 0 | -1000 | 17 | METER |-------------| -| TYP | 0 | 0 | 9 | CODE TABLE |-------------| -| T29 | 0 | 0 | 10 | CODE TABLE |-------------| -| TSB | 0 | 0 | 2 | CODE TABLE |-------------| -| ITP | 0 | 0 | 8 | CODE TABLE |-------------| +| | | | | |-------------| | SIRC | 0 | 0 | 4 | CODE TABLE |-------------| -| SQN | 0 | 0 | 19 | NUMERIC |-------------| -| PROCN | 0 | 0 | 7 | NUMERIC |-------------| -| ACAV | 0 | 0 | 16 | NUMERIC |-------------| +| MSST | 0 | 0 | 3 | CODE TABLE |-------------| +| ITP | 0 | 0 | 8 | CODE TABLE |-------------| +| | | | | |-------------| +| RPT | 5 | 0 | 22 | HOURS |-------------| +| DHR | 5 | -2400000 | 23 | HOURS |-------------| +| TCOR | 0 | 0 | 3 | CODE TABLE |-------------| +| | | | | |-------------| +| YOB | 2 | -9000 | 15 | DEG N |-------------| +* YOB stored 5 * -9000000 * 25 * * +| | | | | |-------------| +| BEARAZ | 2 | 0 | 16 | DEGREE TRUE |-------------| | ATRN | 0 | 0 | 11 | NUMERIC |-------------| +| | | | | |-------------| | CTCN | 0 | 0 | 7 | NUMERIC |-------------| +* IMPORTANT: XOB is a local descriptor here even though it has the same * +* attributes as CLON (0-06-002) - this is because it is coded here * +* with the range 0 to 360 degrees east unlike CLON which has the * +* range -180 to +180 degrees, where east is + and west is - * +* (it can still be held here in 16 bits) * +| XOB | 2 | -18000 | 16 | DEG E |-------------| +* XOB stored 5 * -18000000 * 26 * * +| | | | | |-------------| +| VSSO | 0 | 0 | 6 | CODE TABLE |-------------| +| ACAV | 0 | 0 | 16 | NUMERIC |-------------| +| | | | | |-------------| +| IALR | 3 | -65536 | 17 | M/S |-------------| +| ELV | 0 | -1000 | 17 | METER |-------------| +| | | | | |-------------| | SPRR | 3 | 0 | 10 | NUMERIC |-------------| -| SAID | 0 | 0 | 10 | CODE TABLE |-------------| +| | | | | |-------------| +| NRLQMS | 0 | 0 | 88 | CCITT IA5 |-------------| +| | | | | |-------------| | RSRD | 0 | 0 | 9 | FLAG TABLE |-------------| | EXPRSRD | 0 | 0 | 8 | HOURS |-------------| | | | | | |-------------| -| CAT | 0 | 0 | 6 | CODE TABLE |-------------| +| SQN | 0 | 0 | 19 | NUMERIC |-------------| | | | | | |-------------| -| POB | 1 | 0 | 14 | MB |-------------| -| PFC | 1 | 0 | 14 | MB |-------------| -| PAN | 1 | 0 | 14 | MB |-------------| -| PCL | 1 | 0 | 14 | MB |-------------| -| POE | 1 | 0 | 14 | MB |-------------| -| PCS | 1 | 0 | 14 | MB |-------------| -| PMO | 1 | 0 | 14 | MB |-------------| -| PQM | 0 | 0 | 5 | CODE TABLE |-------------| -| PMQ | 0 | 0 | 5 | CODE TABLE |-------------| -| PPC | 0 | 0 | 4 | CODE TABLE |-------------| -| PRC | 0 | 0 | 10 | CODE TABLE |-------------| +| PROCN | 0 | 0 | 7 | NUMERIC |-------------| | | | | | |-------------| -| PRSS | -1 | 0 | 14 | PASCALS |-------------| +| TYP | 0 | 0 | 10 | CODE TABLE |-------------| +| T29 | 0 | 0 | 10 | CODE TABLE |-------------| +| TSB | 0 | 0 | 14 | CODE TABLE |-------------| | | | | | |-------------| -| ALSE | -1 | 0 | 14 | PASCALS |-------------| +| PRVSTG | 0 | 0 | 64 | CCITT IA5 |-------------| +| SPRVSTG | 0 | 0 | 64 | CCITT IA5 |-------------| | | | | | |-------------| -| RFFL | 0 | 0 | 8 | NUMERIC |-------------| +| TDMP | 0 | 0 | 4 | CODE TABLE |-------------| +| ASMP | 0 | 0 | 4 | CODE TABLE |-------------| | | | | | |-------------| -| PCAT | 2 | 0 | 7 | DEGREES KELVIN |-------------| -| POAF | 0 | 0 | 3 | CODE TABLE |-------------| -| DGOT | 0 | 0 | 4 | CODE TABLE |-------------| -| TRBX10 | 0 | 0 | 6 | CODE TABLE |-------------| -| TRBX21 | 0 | 0 | 6 | CODE TABLE |-------------| -| TRBX32 | 0 | 0 | 6 | CODE TABLE |-------------| -| TRBX43 | 0 | 0 | 6 | CODE TABLE |-------------| +| PCAT | 2 | 0 | 7 | KELVIN |-------------| +| ROLF | 0 | 0 | 3 | CODE TABLE |-------------| +| AFIC | 0 | 0 | 4 | CODE TABLE |-------------| +| HBOI | -1 | -40 | 16 | METER |-------------| +| HTOI | -1 | -40 | 16 | METER |-------------| | | | | | |-------------| -| QOB | 0 | 0 | 16 | MG/KG |-------------| -| QFC | 0 | 0 | 16 | MG/KG |-------------| -| QAN | 0 | 0 | 16 | MG/KG |-------------| -| QCL | 0 | 0 | 16 | MG/KG |-------------| -| QOE | 0 | 0 | 16 | PERCENT DIVIDED BY 10 |-------------| -| QCS | 0 | 0 | 16 | MG/KG |-------------| -| QQM | 0 | 0 | 5 | CODE TABLE |-------------| -| QPC | 0 | 0 | 4 | CODE TABLE |-------------| -| QRC | 0 | 0 | 10 | CODE TABLE |-------------| +| .DTH.... | 0 | 0 | 8 | HOURS |-------------| +| .DTM.... | 0 | 0 | 6 | MINUTES |-------------| +| RCT | 2 | 0 | 12 | HOURS |-------------| +| HRDR | 5 | -2400000 | 23 | HOURS |-------------| | | | | | |-------------| -| TOB | 1 | -2732 | 14 | DEG C |-------------| -| TVO | 1 | -2732 | 14 | DEG C |-------------| -| TDO | 1 | -2732 | 14 | DEG C |-------------| -| TFC | 1 | -2732 | 14 | DEG C |-------------| -| TAN | 1 | -2732 | 14 | DEG C |-------------| -| TCL | 1 | -2732 | 14 | DEG C |-------------| -| TOE | 1 | 0 | 10 | DEG C |-------------| -| TCS | 1 | 0 | 10 | DEG C |-------------| -| TQM | 0 | 0 | 5 | CODE TABLE |-------------| -| TPC | 0 | 0 | 4 | CODE TABLE |-------------| -| TRC | 0 | 0 | 10 | CODE TABLE |-------------| +| CHNM | 0 | 0 | 6 | NUMERIC |-------------| +| YORG | 2 | -9000 | 15 | DEG N |-------------| +* YORG stored 5 * -9000000 * 25 * * +| | | | | |-------------| +| YCOR | 0 | 0 | 3 | CODE TABLE |-------------| +| YDR | 2 | -9000 | 15 | DEG N |-------------| +* YDR stored 5 * -9000000 * 25 * * +| | | | | |-------------| +| XORG | 2 | -18000 | 16 | DEG E |-------------| +* XORG stored 5 * -18000000 * 26 * * +| | | | | |-------------| +| XCOR | 0 | 0 | 3 | CODE TABLE |-------------| +| XDR | 2 | -18000 | 16 | DEG E |-------------| +* XDR stored 5 * -18000000 * 26 * * +| | | | | |-------------| +| ELEV | 2 | -9000 | 15 | DEGREE |-------------| +| SOEL | 2 | -9000 | 15 | DEGREE |-------------| +| SAZA | 2 | -9000 | 15 | DEGREES |-------------| +| DBSS | 1 | 0 | 17 | METER |-------------| +| POB | 1 | 0 | 14 | MB |-------------| +| PQM | 0 | 0 | 5 | CODE TABLE |-------------| +| PPC | 0 | 0 | 5 | CODE TABLE |-------------| +| PRC | 0 | 0 | 10 | CODE TABLE |-------------| +| PFC | 1 | 0 | 14 | MB |-------------| +| POE | 2 | 0 | 14 | MB |-------------| +| PAN | 1 | 0 | 14 | MB |-------------| +| PCL | 1 | 0 | 14 | MB |-------------| +| PCS | 1 | 0 | 14 | MB |-------------| +| POETU | 2 | 0 | 14 | MB |-------------| | | | | | |-------------| -| GCDTT | 2 | 0 | 16 | DEGREES KELVIN |-------------| +| POAF | 0 | 0 | 3 | CODE TABLE |-------------| +| CAT | 0 | 0 | 6 | CODE TABLE |-------------| +| .RE.... | 0 | 0 | 3 | CODE TABLE |-------------| | | | | | |-------------| | ZOB | 0 | -1000 | 17 | METER |-------------| +| ALSE | -1 | 0 | 14 | PASCALS |-------------| +| 3HPC | -1 | -500 | 10 | PASCALS |-------------| +| 24PC | -1 | -1000 | 11 | PASCALS |-------------| +| CHPT | 0 | 0 | 4 | CODE TABLE |-------------| +| PRSS | -1 | 0 | 14 | PASCALS |-------------| +| PMO | 1 | 0 | 14 | MB |-------------| +| PMQ | 0 | 0 | 5 | CODE TABLE |-------------| +| PMIN | 0 | 0 | 3 | CODE TABLE |-------------| +| ZQM | 0 | 0 | 5 | CODE TABLE |-------------| +| ZPC | 0 | 0 | 5 | CODE TABLE |-------------| +| ZRC | 0 | 0 | 10 | CODE TABLE |-------------| | ZFC | 0 | -1000 | 17 | METER |-------------| +| ZOE | 0 | 0 | 10 | METER |-------------| | ZAN | 0 | -1000 | 17 | METER |-------------| | ZCL | 0 | -1000 | 17 | METER |-------------| -| ZOE | 0 | 0 | 10 | METER |-------------| | ZCS | 0 | 0 | 10 | METER |-------------| -| ZQM | 0 | 0 | 5 | CODE TABLE |-------------| -| ZPC | 0 | 0 | 4 | CODE TABLE |-------------| -| ZRC | 0 | 0 | 10 | CODE TABLE |-------------| | | | | | |-------------| -| DDO | 0 | 0 | 9 | DEGREES |-------------| +| DDO | 0 | 0 | 9 | DEGREES TRUE |-------------| | SOB | 1 | 0 | 12 | M/S |-------------| | UOB | 1 | -4096 | 13 | M/S |-------------| | VOB | 1 | -4096 | 13 | M/S |-------------| -| FFO | 0 | 0 | 9 | KNOTS |-------------| +| DGOT | 0 | 0 | 4 | CODE TABLE |-------------| +| HBOT | -1 | -40 | 16 | METERS |-------------| +| HTOT | -1 | -40 | 16 | METERS |-------------| +| MXGS | 1 | 0 | 12 | M/S |-------------| +| MXGD | 0 | 0 | 9 | DEGREES TRUE |-------------| +| MWD10 | 2 | 0 | 16 | DEGREES TRUE |-------------| +| MWS10 | 2 | 0 | 14 | M/S |-------------| +| WDIR1 | 0 | 0 | 9 | DEGREES TRUE |-------------| +| WSPD1 | 1 | 0 | 12 | M/S |-------------| +| PKWDDR | 0 | 0 | 9 | DEGREES TRUE |-------------| +| PKWDSP | 1 | 0 | 12 | M/S |-------------| +| DFQ | 0 | 0 | 5 | CODE TABLE |-------------| +| DFP | 0 | 0 | 5 | CODE TABLE |-------------| +| DFR | 0 | 0 | 10 | CODE TABLE |-------------| +| XS10 | 1 | 0 | 12 | M/S |-------------| +| XS20 | 1 | 0 | 12 | M/S |-------------| +| RF10M | 4 | 0 | 16 | NUMERIC |-------------| +| TRBX | 0 | 0 | 6 | CODE TABLE |-------------| +| TRBX10 | 0 | 0 | 6 | CODE TABLE |-------------| +| TRBX21 | 0 | 0 | 6 | CODE TABLE |-------------| +| TRBX32 | 0 | 0 | 6 | CODE TABLE |-------------| +| TRBX43 | 0 | 0 | 6 | CODE TABLE |-------------| +| WQM | 0 | 0 | 5 | CODE TABLE |-------------| +| WPC | 0 | 0 | 5 | CODE TABLE |-------------| +| WRC | 0 | 0 | 10 | CODE TABLE |-------------| | UFC | 1 | -4096 | 13 | M/S |-------------| | VFC | 1 | -4096 | 13 | M/S |-------------| +| WOE | 1 | 0 | 10 | M/S |-------------| | UAN | 1 | -4096 | 13 | M/S |-------------| | VAN | 1 | -4096 | 13 | M/S |-------------| | UCL | 1 | -4096 | 13 | M/S |-------------| | VCL | 1 | -4096 | 13 | M/S |-------------| -| WOE | 1 | 0 | 10 | M/S |-------------| | UCS | 1 | 0 | 10 | M/S |-------------| | VCS | 1 | 0 | 10 | M/S |-------------| -| WQM | 0 | 0 | 5 | CODE TABLE |-------------| -| WPC | 0 | 0 | 4 | CODE TABLE |-------------| -| WRC | 0 | 0 | 10 | CODE TABLE |-------------| -| DFQ | 0 | 0 | 5 | CODE TABLE |-------------| -| DFP | 0 | 0 | 4 | CODE TABLE |-------------| -| DFR | 0 | 0 | 10 | CODE TABLE |-------------| -| SQM | 0 | 0 | 5 | CODE TABLE |-------------| +| FFO | 0 | 0 | 9 | KNOTS |-------------| +| WOETU | 1 | 0 | 10 | M/S |-------------| | | | | | |-------------| -| PWO | 1 | 0 | 10 | MM |-------------| -| PWF | 1 | 0 | 10 | MM |-------------| -| PWA | 1 | 0 | 10 | MM |-------------| -| PWE | 1 | 0 | 10 | MM |-------------| -| PWQ | 0 | 0 | 5 | CODE TABLE |-------------| -| PWP | 0 | 0 | 4 | CODE TABLE |-------------| -| PWR | 0 | 0 | 10 | CODE TABLE |-------------| -| PW1O | 1 | 0 | 10 | MM |-------------| -| PW1F | 1 | 0 | 10 | MM |-------------| -| PW1A | 1 | 0 | 10 | MM |-------------| -| PW1E | 1 | 0 | 10 | MM |-------------| -| PW1Q | 0 | 0 | 5 | CODE TABLE |-------------| -| PW1P | 0 | 0 | 4 | CODE TABLE |-------------| -| PW1R | 0 | 0 | 10 | CODE TABLE |-------------| -| PW2O | 1 | 0 | 10 | MM |-------------| -| PW2F | 1 | 0 | 10 | MM |-------------| -| PW2A | 1 | 0 | 10 | MM |-------------| -| PW2E | 1 | 0 | 10 | MM |-------------| -| PW2Q | 0 | 0 | 5 | CODE TABLE |-------------| -| PW2P | 0 | 0 | 4 | CODE TABLE |-------------| -| PW2R | 0 | 0 | 10 | CODE TABLE |-------------| -| PW3O | 1 | 0 | 10 | MM |-------------| -| PW3F | 1 | 0 | 10 | MM |-------------| -| PW3A | 1 | 0 | 10 | MM |-------------| -| PW3E | 1 | 0 | 10 | MM |-------------| -| PW3Q | 0 | 0 | 5 | CODE TABLE |-------------| -| PW3P | 0 | 0 | 4 | CODE TABLE |-------------| -| PW3R | 0 | 0 | 10 | CODE TABLE |-------------| -| PW4O | 1 | 0 | 10 | MM |-------------| -| PW4F | 1 | 0 | 10 | MM |-------------| -| PW4A | 1 | 0 | 10 | MM |-------------| -| PW4E | 1 | 0 | 10 | MM |-------------| -| PW4Q | 0 | 0 | 5 | CODE TABLE |-------------| -| PW4P | 0 | 0 | 4 | CODE TABLE |-------------| -| PW4R | 0 | 0 | 10 | CODE TABLE |-------------| +| MXTM | 2 | 0 | 16 | KELVIN |-------------| +| MITM | 2 | 0 | 16 | KELVIN |-------------| +| TMSK | 2 | 0 | 16 | KELVIN |-------------| +| TMBR | 2 | 0 | 16 | KELVIN |-------------| +| GCDTT | 2 | 0 | 16 | KELVIN |-------------| +| TVO | 1 | -2732 | 14 | DEG C |-------------| +| TDO | 1 | -2732 | 14 | DEG C |-------------| +| TOB | 1 | -2732 | 14 | DEG C |-------------| +| TQM | 0 | 0 | 5 | CODE TABLE |-------------| +| TPC | 0 | 0 | 5 | CODE TABLE |-------------| +| TRC | 0 | 0 | 10 | CODE TABLE |-------------| +| TFC | 1 | -2732 | 14 | DEG C |-------------| +| TOE | 1 | 0 | 10 | DEG C |-------------| +| TAN | 1 | -2732 | 14 | DEG C |-------------| +| TCL | 1 | -2732 | 14 | DEG C |-------------| +| TCS | 1 | 0 | 10 | DEG C |-------------| +| TOETU | 1 | 0 | 10 | DEG C |-------------| | | | | | |-------------| -| REQ6 | 6 | 0 | 18 | KG / ((M ** 2)*SEC) |-------------| -| REQ6_FC | 6 | 0 | 18 | KG / ((M ** 2)*SEC) |-------------| -| REQ6_AN | 6 | 0 | 18 | KG / ((M ** 2)*SEC) |-------------| -| REQ6_OE | 6 | 0 | 18 | KG / ((M ** 2)*SEC) |-------------| -| REQ6_QM | 0 | 0 | 5 | CODE TABLE |-------------| -| REQ6_PC | 0 | 0 | 4 | CODE TABLE |-------------| -| REQ6_RC | 0 | 0 | 10 | CODE TABLE |-------------| +| PWO | 1 | 0 | 11 | KG/M**2 (or MM) |-------------| +| PW1O | 1 | 0 | 11 | KG/M**2 (or MM) |-------------| +| PW2O | 1 | 0 | 11 | KG/M**2 (or MM) |-------------| +| PW3O | 1 | 0 | 11 | KG/M**2 (or MM) |-------------| +| TOPC | 1 | -1 | 14 | KG/M**2 |-------------| +| DOFS | 2 | -2 | 12 | METER |-------------| +| TOSD | 2 | -2 | 16 | METER |-------------| +* REQV stored at a higher precision than standard via operatior descriptors * +* for message type SPSSMI (scale=6, bit width=18) * +| REQV | 4 | 0 | 12 | KG/((METER**2)*SECOND) |-------------| +| TP01 | 1 | -1 | 14 | KG/M**2 |-------------| +| TP03 | 1 | -1 | 14 | KG/M**2 |-------------| +| TP06 | 1 | -1 | 14 | KG/M**2 |-------------| +| TP12 | 1 | -1 | 14 | KG/M**2 |-------------| +| TP24 | 1 | -1 | 14 | KG/M**2 |-------------| +| MRWVC | 2 | 0 | 14 | KG/M**2 |-------------| +| MRLWC | 2 | 0 | 14 | KG/M**2 |-------------| +| QOB | 0 | 0 | 16 | MG/KG |-------------| +| ESBAK | 0 | 0 | 16 | MG/KG |-------------| +| QQM | 0 | 0 | 5 | CODE TABLE |-------------| +| QPC | 0 | 0 | 5 | CODE TABLE |-------------| +| QRC | 0 | 0 | 10 | CODE TABLE |-------------| +| QFC | 0 | 0 | 16 | MG/KG |-------------| +| QOE | 1 | 0 | 10 | PERCENT DIVIDED BY 10 |-------------| +| QAN | 0 | 0 | 16 | MG/KG |-------------| +| QCL | 0 | 0 | 16 | MG/KG |-------------| +| QCS | 0 | 0 | 16 | MG/KG |-------------| +| QOETU | 1 | 0 | 10 | PERCENT DIVIDED BY 10 |-------------| | | | | | |-------------| -| TOCC | 0 | 0 | 7 | PERCENT |-------------| -| CDTP | -1 | 0 | 14 | PASCALS |-------------| -| CDTP_FC | -1 | 0 | 14 | PASCALS |-------------| -| CDTP_AN | -1 | 0 | 14 | PASCALS |-------------| -| CDTP_OE | -1 | 0 | 14 | PASCALS |-------------| -| CDTP_QM | 0 | 0 | 5 | CODE TABLE |-------------| -| CDTP_PC | 0 | 0 | 4 | CODE TABLE |-------------| -| CDTP_RC | 0 | 0 | 10 | CODE TABLE |-------------| +| TOSS | 0 | 0 | 11 | MINUTE |-------------| | | | | | |-------------| -| ELEV | 2 | -9000 | 15 | DEGREE |-------------| -| SOEL | 2 | -9000 | 15 | DEGREE |-------------| | OZON | 0 | 0 | 10 | DOBSON UNITS |-------------| -| TMSK | 1 | 0 | 12 | DEGREES KELVIN |-------------| +| APDS | 4 | 10000 | 15 | METER |-------------| +| APDE | 4 | 0 | 10 | METER |-------------| +| | | | | |-------------| +| HOVI | -1 | 0 | 13 | METER |-------------| +| VTVI | -1 | 0 | 7 | METER |-------------| +| PRWE | 0 | 0 | 9 | CODE TABLE |-------------| +| PSW1 | 0 | 0 | 5 | CODE TABLE |-------------| +| PSW2 | 0 | 0 | 5 | CODE TABLE |-------------| +| TOCC | 0 | 0 | 7 | PERCENT |-------------| | CLAM | 0 | 0 | 4 | CODE TABLE |-------------| -| CHNM | 0 | 0 | 6 | NUMERIC |-------------| -| TMBR | 2 | 0 | 19 | KELVIN |-------------| +| CLTP | 0 | 0 | 6 | CODE TABLE |-------------| +| HOCB | -1 | -40 | 11 | METER |-------------| +| HOCT | -1 | -40 | 11 | METER |-------------| +| CDTP | -1 | 0 | 14 | PASCALS |-------------| +| HBLCS | 0 | 0 | 4 | CODE TABLE |-------------| +| CEILING | -1 | -40 | 11 | METER |-------------| +| WSST | 0 | 0 | 3 | CODE TABLE |-------------| +| CTPQM | 0 | 0 | 5 | CODE TABLE |-------------| +| CTPPC | 0 | 0 | 5 | CODE TABLE |-------------| +| CTPRC | 0 | 0 | 10 | CODE TABLE |-------------| +| CTPFC | -1 | 0 | 14 | PASCALS |-------------| +| CTPOE | -1 | 0 | 10 | PASCALS |-------------| +| CTPAN | -1 | 0 | 14 | PASCALS |-------------| | | | | | |-------------| +| LKCS | 3 | -30000 | 15 | NUMERIC |-------------| +| WVCQ | 0 | 0 | 24 | FLAG TABLE |-------------| +| BSCD | 1 | -4096 | 13 | NUMERIC |-------------| | A1 | 1 | 0 | 12 | DEGREE |-------------| | A2 | 1 | 0 | 12 | DEGREE |-------------| | A3 | 1 | 0 | 12 | DEGREE |-------------| -| | | | | |-------------| | B1 | 1 | 0 | 12 | DEGREE |-------------| | B2 | 1 | 0 | 12 | DEGREE |-------------| | B3 | 1 | 0 | 12 | DEGREE |-------------| -| | | | | |-------------| -| S1 | 2 | -5000 | 13 | BACKSCATTER |-------------| -| S2 | 2 | -5000 | 13 | BACKSCATTER |-------------| -| S3 | 2 | -5000 | 13 | BACKSCATTER |-------------| -| | | | | |-------------| +| S1 | 2 | -5000 | 13 | DECIBEL |-------------| +| S2 | 2 | -5000 | 13 | DECIBEL |-------------| +| S3 | 2 | -5000 | 13 | DECIBEL |-------------| | E1 | 0 | 0 | 7 | PERCENT |-------------| | E2 | 0 | 0 | 7 | PERCENT |-------------| | E3 | 0 | 0 | 7 | PERCENT |-------------| | | | | | |-------------| -| PFC_MOD | 1 | 0 | 14 | MB |-------------| -| ZFC_MOD | 0 | -1000 | 17 | METER |-------------| -| UFC_MOD | 1 | -4096 | 13 | M/S |-------------| -| VFC_MOD | 1 | -4096 | 13 | M/S |-------------| -| TFC_MOD | 1 | -2732 | 14 | DEG C |-------------| -| QFC_MOD | 0 | 0 | 16 | MG/KG |-------------| -| PWF_MOD | 1 | 0 | 10 | MM |-------------| -| PW1F_MOD | 1 | 0 | 10 | MM |-------------| -| PW2F_MOD | 1 | 0 | 10 | MM |-------------| -| PW3F_MOD | 1 | 0 | 10 | MM |-------------| -| PW4F_MOD | 1 | 0 | 10 | MM |-------------| +| DOSW | 0 | 0 | 9 | DEGREES TRUE |-------------| +| POWV | 0 | 0 | 6 | SECONDS |-------------| +| POWW | 0 | 0 | 6 | SECONDS |-------------| +| POSW | 0 | 0 | 6 | SECONDS |-------------| +| HOWV | 1 | 0 | 10 | METER |-------------| +| HOWW | 1 | 0 | 10 | METER |-------------| +| HOSW | 1 | 0 | 10 | METER |-------------| +| SST1 | 2 | 0 | 15 | KELVIN |-------------| +| SSTQM | 0 | 0 | 5 | CODE TABLE |-------------| +| SSTPC | 0 | 0 | 5 | CODE TABLE |-------------| +| SSTRC | 0 | 0 | 10 | CODE TABLE |-------------| +| SSTFC | 2 | 0 | 15 | KELVIN |-------------| +| SSTOE | 1 | 0 | 10 | KELVIN |-------------| +| SSTAN | 2 | 0 | 15 | KELVIN |-------------| +| | | | | |-------------| +| MSTQ | 0 | 0 | 6 | CODE TABLE |-------------| +| RFFL | 0 | 0 | 8 | PERCENT |-------------| +| QIFY | 0 | 0 | 8 | PERCENT |-------------| +| QIFN | 0 | 0 | 8 | PERCENT |-------------| +| CHSQ | 2 | 0 | 17 | NUMERIC |-------------| +| WSEQC1 | 0 | 0 | 31 | FLAG TABLE |-------------| +| PHER | 1 | 0 | 12 | DEGREES TRUE |-------------| +| EEQF | 0 | 0 | 8 | PERCENT |-------------| +| PVWTG | 0 | 0 | 7 | PERCENT |-------------| +| PVWTA | 0 | 0 | 7 | PERCENT |-------------| +| TVWTG | 0 | 0 | 7 | PERCENT |-------------| +| TVWTA | 0 | 0 | 7 | PERCENT |-------------| +| QVWTG | 0 | 0 | 7 | PERCENT |-------------| +| QVWTA | 0 | 0 | 7 | PERCENT |-------------| +| WVWTG | 0 | 0 | 7 | PERCENT |-------------| +| WVWTA | 0 | 0 | 7 | PERCENT |-------------| +| PWTVWTG | 0 | 0 | 7 | PERCENT |-------------| +| PWTVWTA | 0 | 0 | 7 | PERCENT |-------------| +| SSTE | 2 | 0 | 16 | KELVIN |-------------| +| SPDE | 2 | 0 | 15 | M/S |-------------| +| VPRE | 2 | 0 | 14 | KG/M**2 |-------------| +| CLDE | 3 | 0 | 14 | KG/M**2 |-------------| +| | | | | |-------------| +| RRTQM | 0 | 0 | 5 | CODE TABLE |-------------| +| RRTPC | 0 | 0 | 5 | CODE TABLE |-------------| +| RRTRC | 0 | 0 | 10 | CODE TABLE |-------------| +| RRTFC | 6 | 0 | 18 | KG/((M**2)*S) (or MM/S) |-------------| +| RRTOE | 6 | 0 | 18 | KG/((M**2)*S) (or MM/S) |-------------| +| RRTAN | 6 | 0 | 18 | KG/((M**2)*S) (or MM/S) |-------------| +| PWQ | 0 | 0 | 5 | CODE TABLE |-------------| +| PWP | 0 | 0 | 5 | CODE TABLE |-------------| +| PWR | 0 | 0 | 10 | CODE TABLE |-------------| +| PWF | 1 | 0 | 11 | KG/M**2 (or MM) |-------------| +| PWE | 1 | 0 | 10 | KG/M**2 (or MM) |-------------| +| PWA | 1 | 0 | 11 | KG/M**2 (or MM) |-------------| +| PWETU | 1 | 0 | 10 | KG/M**2 (or MM) |-------------| +| PW1Q | 0 | 0 | 5 | CODE TABLE |-------------| +| PW1P | 0 | 0 | 5 | CODE TABLE |-------------| +| PW1R | 0 | 0 | 10 | CODE TABLE |-------------| +| PW1F | 1 | 0 | 11 | KG/M**2 (or MM) |-------------| +| PW1E | 1 | 0 | 10 | KG/M**2 (or MM) |-------------| +| PW1A | 1 | 0 | 11 | KG/M**2 (or MM) |-------------| +| PW2Q | 0 | 0 | 5 | CODE TABLE |-------------| +| PW2P | 0 | 0 | 5 | CODE TABLE |-------------| +| PW2R | 0 | 0 | 10 | CODE TABLE |-------------| +| PW2F | 1 | 0 | 11 | KG/M**2 (or MM) |-------------| +| PW2E | 1 | 0 | 10 | KG/M**2 (or MM) |-------------| +| PW2A | 1 | 0 | 11 | KG/M**2 (or MM) |-------------| +| PW3Q | 0 | 0 | 5 | CODE TABLE |-------------| +| PW3P | 0 | 0 | 5 | CODE TABLE |-------------| +| PW3R | 0 | 0 | 10 | CODE TABLE |-------------| +| PW3F | 1 | 0 | 11 | KG/M**2 (or MM) |-------------| +| PW3E | 1 | 0 | 10 | KG/M**2 (or MM) |-------------| +| PW3A | 1 | 0 | 11 | KG/M**2 (or MM) |-------------| +| PW4O | 1 | 0 | 11 | KG/M**2 (or MM) |-------------| +| PW4Q | 0 | 0 | 5 | CODE TABLE |-------------| +| PW4P | 0 | 0 | 5 | CODE TABLE |-------------| +| PW4R | 0 | 0 | 10 | CODE TABLE |-------------| +| PW4F | 1 | 0 | 11 | KG/M**2 (or MM) |-------------| +| PW4E | 1 | 0 | 10 | KG/M**2 (or MM) |-------------| +| PW4A | 1 | 0 | 11 | KG/M**2 (or MM) |-------------| +| | | | | |-------------| +| | | | | |-------------| +| PFCMOD | 1 | 0 | 14 | MB |-------------| +| ZFCMOD | 0 | -1000 | 17 | METER |-------------| +| UFCMOD | 1 | -4096 | 13 | M/S |-------------| +| VFCMOD | 1 | -4096 | 13 | M/S |-------------| +| TFCMOD | 1 | -2732 | 14 | DEG C |-------------| +| QFCMOD | 0 | 0 | 16 | MG/KG |-------------| +| PWFMOD | 1 | 0 | 11 | KG/M**2 (or MM) |-------------| +| PW1FMOD | 1 | 0 | 11 | KG/M**2 (or MM) |-------------| +| PW2FMOD | 1 | 0 | 11 | KG/M**2 (or MM) |-------------| +| PW3FMOD | 1 | 0 | 11 | KG/M**2 (or MM) |-------------| +| PW4FMOD | 1 | 0 | 11 | KG/M**2 (or MM) |-------------| `------------------------------------------------------------------------------' From c5b76e227e79576b5a0917a00de577fd9151276c Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz Date: Tue, 3 Sep 2019 14:52:34 -0400 Subject: [PATCH 007/205] Remove files associated with old ACQC and ACARSQC from list --- src/Applications/GEOSdas_App/fvsetup | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index 30676e41..4327a4c0 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -732,17 +732,14 @@ sub defaults { gsi_sens.rc.tmpl noreplay.acq odsmatch.rc - prepobs_acarsqc.merra.parm prepobs_cqc_statbge prepobs_cqcbufr.merra.parm prepobs_errtable.global - prepobs_landc prepobs_oiqc.oberrs prepobs_prep.bufrtable prepobs_prepacqc.merra.parm prepobs_prevents.merra.parm prepobs_profcqc.merra.parm - prepobs_waypoints sac.nl.tmpl vtrack.ctl.tmpl vtrack.rc From c6d54f71e69b013e7495a70f6da0f92976be9b66 Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz Date: Thu, 12 Sep 2019 13:05:28 -0400 Subject: [PATCH 008/205] Add CMake change from hotfix/mathomp4/#43-add-extended-source-to-radcor --- src/Applications/NCEP_Paqc/radcor/CMakeLists.txt | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Applications/NCEP_Paqc/radcor/CMakeLists.txt b/src/Applications/NCEP_Paqc/radcor/CMakeLists.txt index 8907769a..2c945f54 100644 --- a/src/Applications/NCEP_Paqc/radcor/CMakeLists.txt +++ b/src/Applications/NCEP_Paqc/radcor/CMakeLists.txt @@ -69,3 +69,7 @@ foreach (target ${this} raobcore.x hradcor.x read_prepbufr.x) endforeach () endforeach () +if (EXTENDED_SOURCE) + set_target_properties (${this} PROPERTIES COMPILE_FLAGS ${EXTENDED_SOURCE}) +endif() + From fe7e4fdb625f746ac8d64921a0f7de1dcfa30c26 Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz Date: Thu, 12 Sep 2019 15:52:37 -0400 Subject: [PATCH 009/205] call maxout() to increase maximum record size - some soundings in MERRA2 data are exceeding the maximum record size after the background values are added to the file. --- src/Applications/NCEP_Paqc/GMAOprev/prevents.f | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Applications/NCEP_Paqc/GMAOprev/prevents.f b/src/Applications/NCEP_Paqc/GMAOprev/prevents.f index ad93f7ca..8fb97120 100644 --- a/src/Applications/NCEP_Paqc/GMAOprev/prevents.f +++ b/src/Applications/NCEP_Paqc/GMAOprev/prevents.f @@ -75,6 +75,8 @@ C STANDARD GET_ENVIRONMENT_VARIABLE; USE FORMATTED PRINT C STATEMENTS WHERE PREVIOUSLY UNFORMATTED PRINT WAS > 80 C CHARACTERS +C 2017-05-22 M. SIENKIEWICZ - CALL MAXOUT TO INCREASE MAX RECORD SIZE +C TO AVOID LOSING SOUNDING RECORDS THAT SLIGHTLY EXCEED MAX c c rename all REAL(8) variables as C *_8 @@ -232,6 +234,7 @@ PROGRAM PREPOBS_PREVENTS CALL OPENBF(IUNITI,'IN ',IUNITI) CALL OPENBF(IUNITP,'OUT',IUNITI) + call maxout(15000) C DETERMINE WHICH NETWORK WE ARE RUNNING UNDER C -------------------------------------------- From c958afd1544a22d38b3f9079d729c59ab8f14940 Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz Date: Thu, 12 Sep 2019 15:53:53 -0400 Subject: [PATCH 010/205] Needed to change the name of the executable. For NRL Aircraft QC we are using 'prepacqc_profl.x' to differentiate it from the old version --- src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/CMakeLists.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/CMakeLists.txt b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/CMakeLists.txt index 4e235069..ec5a9ec4 100644 --- a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/CMakeLists.txt +++ b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/CMakeLists.txt @@ -4,7 +4,7 @@ if (CMAKE_Fortran_COMPILER_ID MATCHES Intel) endif () ecbuild_add_executable ( - TARGET prepacqc.x + TARGET prepacqc_profl.x SOURCES prepacqc.f acftobs_qc.f indexc40.f input_acqc.f output_acqc_noprof.f output_acqc_prof.f sub2mem_mer.f sub2mem_um.f tranQCflags.f pmat.f90 pmat2.f90 pmat3.f90 pietc.f90 pspl.f90 pkind.f90 LIBS NCEP_bufr_r4i4 NCEP_w3_r4i4) From 8300254ea66fd3c2748a2188ea27a1e3eaee0c60 Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz Date: Mon, 5 Aug 2019 11:00:36 -0400 Subject: [PATCH 011/205] OIQC fix from NCEP for obs with press=0 --- src/Applications/NCEP_Paqc/oiqc/oiqcbufr.f | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Applications/NCEP_Paqc/oiqc/oiqcbufr.f b/src/Applications/NCEP_Paqc/oiqc/oiqcbufr.f index 8e26c3b1..0b553c10 100644 --- a/src/Applications/NCEP_Paqc/oiqc/oiqcbufr.f +++ b/src/Applications/NCEP_Paqc/oiqc/oiqcbufr.f @@ -958,7 +958,8 @@ SUBROUTINE DRCTSL(FA,RA,DP,NDIM,NXXYY) C C PROGRAM HISTORY LOG: C 1992-07-29 J. WOOLLEN - ORIGINAL AUTHOR -C +C 2019-06-18 SIENKIEWICZ - NCEP CHANGE TO HANDLE OBS WITH PRES<1 +C C USAGE: CALL GETZER(SLAT,SLON,PRES) - (RETURNS HEIGHT ERROR) C CALL GETWER(SLAT,SLON,PRES) - (RETURNS WIND ERROR) C INPUT ARGUMENT LIST: @@ -1024,7 +1025,7 @@ FUNCTION GETFCER(SLAT,SLON,PRES) C --------------------------------------------- TRPWER = PILNLNP(PRES,PMAND,TROPUV,21) - SRWW0 = SQRT(2.0*CHLP(IFIX(PRES))) + SRWW0 = SQRT(2.0*CHLP(MAX(IFIX(PRES),1))) IF(SLAT.EQ.0.) ALPHA = 0. IF(SLAT.NE.0.) ALPHA = GRAV/(2.*OMEGA*SIN(ABS(SLAT)*PI180)*RADE) IY = ABS(SLAT)+1.5 From fe7d15b6763496403be650a1dd5d8dfd504435a6 Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz Date: Thu, 17 Oct 2019 18:16:19 -0400 Subject: [PATCH 012/205] Remove use of CPAN::Shell --- src/Applications/NCEP_Paqc/oiqc/gmao_prepqc | 1 - src/Applications/NCEP_Paqc/oiqc/prepqc.pl | 3 +-- src/Applications/NCEP_Paqc/oiqc/prepqc_daemon.pl | 3 +-- 3 files changed, 2 insertions(+), 5 deletions(-) diff --git a/src/Applications/NCEP_Paqc/oiqc/gmao_prepqc b/src/Applications/NCEP_Paqc/oiqc/gmao_prepqc index 05db315d..050e27b1 100755 --- a/src/Applications/NCEP_Paqc/oiqc/gmao_prepqc +++ b/src/Applications/NCEP_Paqc/oiqc/gmao_prepqc @@ -29,7 +29,6 @@ use Env qw(STRICT NCPUS EXPID PROFQC ACFTQC ACARSQC RADCOR FVWORK FORT_CONVERT12 FORT_CONVERT13 FORT_CONVERT15 ); use File::Basename; # for basename(), dirname() use Getopt::Long; # command line options -use Shell qw(cat); # cat command use File::Copy; # Command line options diff --git a/src/Applications/NCEP_Paqc/oiqc/prepqc.pl b/src/Applications/NCEP_Paqc/oiqc/prepqc.pl index bac7b647..1b08ed7a 100755 --- a/src/Applications/NCEP_Paqc/oiqc/prepqc.pl +++ b/src/Applications/NCEP_Paqc/oiqc/prepqc.pl @@ -12,7 +12,6 @@ use File::Basename; # for basename(), dirname() use File::Copy "cp"; # for cp() use Getopt::Long; # command line options -use Shell qw(cat rm); # cat and rm commands # Command line options # -------------------- @@ -104,7 +103,7 @@ sub prepqc { # runs NCEP preprocessing QC subsystem # Rename original prepqc file to serve as input to PREPQC # ------------------------------------------------------- cp("$prepqc_new","$prepqc_old"); - rm("$prepqc_new"); + unlink("$prepqc_new"); $cmd = "gmao_prepqc -r $fvhome/run -o $prepqc_new $nymd $nhms $prepqc_old $dynf"; print "$0: $cmd\n" unless ( $opt_q ); diff --git a/src/Applications/NCEP_Paqc/oiqc/prepqc_daemon.pl b/src/Applications/NCEP_Paqc/oiqc/prepqc_daemon.pl index 90a5ab65..fcaee1dc 100755 --- a/src/Applications/NCEP_Paqc/oiqc/prepqc_daemon.pl +++ b/src/Applications/NCEP_Paqc/oiqc/prepqc_daemon.pl @@ -27,7 +27,6 @@ use lib ( "${FVROOT}/bin" ); use File::Basename; # for basename(), dirname() use File::Copy; # for cp() and move -use Shell qw(cat rm); # cat and rm commands use Manipulate_time; # token_resolve() while(1) { # Start the daemon @@ -179,7 +178,7 @@ sub prepqc { # runs NCEP preprocessing QC subsystem # Rename original prepqc file to serve as input to PREPQC #-------------------------------------------------------- copy("$prepqc_new","$prepqc_old"); - rm("$prepqc_new"); + unlink("$prepqc_new"); $cmd = "gmao_prepqc -r $fvhome/run -o $prepqc_new $nymd $nhms $prepqc_old $dynf"; print "$0: $cmd\n" unless ( $opt_q ); From b4f071e5c883705628650ed95b61cc664c3e0c07 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Thu, 12 Sep 2019 09:28:01 -0400 Subject: [PATCH 013/205] Sigh. You have to have a this before you can refer to it. --- src/Applications/NCEP_Paqc/radcor/CMakeLists.txt | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Applications/NCEP_Paqc/radcor/CMakeLists.txt b/src/Applications/NCEP_Paqc/radcor/CMakeLists.txt index 8907769a..2c945f54 100644 --- a/src/Applications/NCEP_Paqc/radcor/CMakeLists.txt +++ b/src/Applications/NCEP_Paqc/radcor/CMakeLists.txt @@ -69,3 +69,7 @@ foreach (target ${this} raobcore.x hradcor.x read_prepbufr.x) endforeach () endforeach () +if (EXTENDED_SOURCE) + set_target_properties (${this} PROPERTIES COMPILE_FLAGS ${EXTENDED_SOURCE}) +endif() + From 2f21686e2d342b524e01292c12a86069ac26d211 Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz Date: Fri, 18 Oct 2019 13:13:48 -0400 Subject: [PATCH 014/205] Remove reference to Shell.pm - replace 'rm' with 'unlink' --- src/Applications/NCEP_Paqc/oiqc/prepqc.pl | 3 +-- src/Applications/NCEP_Paqc/oiqc/prepqc_daemon.pl | 3 +-- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/src/Applications/NCEP_Paqc/oiqc/prepqc.pl b/src/Applications/NCEP_Paqc/oiqc/prepqc.pl index bac7b647..1b08ed7a 100755 --- a/src/Applications/NCEP_Paqc/oiqc/prepqc.pl +++ b/src/Applications/NCEP_Paqc/oiqc/prepqc.pl @@ -12,7 +12,6 @@ use File::Basename; # for basename(), dirname() use File::Copy "cp"; # for cp() use Getopt::Long; # command line options -use Shell qw(cat rm); # cat and rm commands # Command line options # -------------------- @@ -104,7 +103,7 @@ sub prepqc { # runs NCEP preprocessing QC subsystem # Rename original prepqc file to serve as input to PREPQC # ------------------------------------------------------- cp("$prepqc_new","$prepqc_old"); - rm("$prepqc_new"); + unlink("$prepqc_new"); $cmd = "gmao_prepqc -r $fvhome/run -o $prepqc_new $nymd $nhms $prepqc_old $dynf"; print "$0: $cmd\n" unless ( $opt_q ); diff --git a/src/Applications/NCEP_Paqc/oiqc/prepqc_daemon.pl b/src/Applications/NCEP_Paqc/oiqc/prepqc_daemon.pl index 90a5ab65..fcaee1dc 100755 --- a/src/Applications/NCEP_Paqc/oiqc/prepqc_daemon.pl +++ b/src/Applications/NCEP_Paqc/oiqc/prepqc_daemon.pl @@ -27,7 +27,6 @@ use lib ( "${FVROOT}/bin" ); use File::Basename; # for basename(), dirname() use File::Copy; # for cp() and move -use Shell qw(cat rm); # cat and rm commands use Manipulate_time; # token_resolve() while(1) { # Start the daemon @@ -179,7 +178,7 @@ sub prepqc { # runs NCEP preprocessing QC subsystem # Rename original prepqc file to serve as input to PREPQC #-------------------------------------------------------- copy("$prepqc_new","$prepqc_old"); - rm("$prepqc_new"); + unlink("$prepqc_new"); $cmd = "gmao_prepqc -r $fvhome/run -o $prepqc_new $nymd $nhms $prepqc_old $dynf"; print "$0: $cmd\n" unless ( $opt_q ); From 0868c0d097ade48dcfd3260778025e89b3ed2fc3 Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz Date: Fri, 18 Oct 2019 13:15:19 -0400 Subject: [PATCH 015/205] Remove reference to Shell.pm; remove code for old ACQC, ACARSQC --- src/Applications/NCEP_Paqc/oiqc/gmao_prepqc | 88 +-------------------- 1 file changed, 2 insertions(+), 86 deletions(-) diff --git a/src/Applications/NCEP_Paqc/oiqc/gmao_prepqc b/src/Applications/NCEP_Paqc/oiqc/gmao_prepqc index 1e976e33..6c58c049 100755 --- a/src/Applications/NCEP_Paqc/oiqc/gmao_prepqc +++ b/src/Applications/NCEP_Paqc/oiqc/gmao_prepqc @@ -24,6 +24,8 @@ # 27Oct2016 Meta Some modifications for new NRL QC # 02Feb2017 Meta Plumbing fixes for NRL QC - save profile file where it # can be found by DAS, few other tweaks +# 18Oct2019 Meta Removed reference to 'Shell'; cleaned out +# code for old ACQC, ACARSQC #------------------------------------------------------------------ # make env vars readily available @@ -32,7 +34,6 @@ use Env qw(STRICT NCPUS EXPID PROFQC ACFTQC ACARSQC RADCOR FVWORK FORT_CONVERT12 FORT_CONVERT13 FORT_CONVERT15 ); use File::Basename; # for basename(), dirname() use Getopt::Long; # command line options -use Shell qw(cat); # cat command use File::Copy; # Command line options @@ -89,12 +90,6 @@ use File::Copy; newacqc() if ($doACQC) ; $rc1 = system("zeit_co.x -r $fvwork/.zeit pqc_arqc"); - # ACARSQC (ACARS QC) - # ------- -# $rc1 = system("zeit_ci.x -r $fvwork/.zeit pqc_acarsqc"); -# acarsqc() if ($doACARSQC) ; -# $rc1 = system("zeit_co.x -r $fvwork/.zeit pqc_acarsqc"); - # CQCVAD (Radar VAD wind QC) # ------ $rc1 = system("zeit_ci.x -r $fvwork/.zeit pqc_cqcvad"); @@ -642,85 +637,6 @@ sub newacqc { #...................................................................... -sub acqc { - - $acqcdir = "$prepqcdir/acqc"; # PREPQC working directory - $rc = system("/bin/mkdir -p $acqcdir" ); - die ">>> ERROR <<< cannot create $acqcdir " if ( $rc ); - chdir("$acqcdir"); - system("/bin/touch .no_archiving"); # working prepqc dir not to be archived - -# Assign FORTRAN units for acqc -# ------------------------------------------------------------ - -# NOTE: these files do not follow the fv file name conventions -# Many of the output files are discarded -# ------------------------------------------------------------ - Assign("$prepqcdir/next.$nymd.$hh", 14 ); - Assign("$rcdir/prepobs_landc", 15 ); - Assign("$rcdir/prepobs_waypoints", 23 ); - - Assign("prepaqc.$nymd.$hh", 61 ); - Assign("aqc_sdmisol.$nymd.$hh", 52 ); - Assign("aqc_sdmxlim.$nymd.$hh", 53 ); - - $FORT_CONVERT15 = "BIG_ENDIAN"; - -# Run prepacqc -# ------- - $cmd = "prepacqc.x < $rcdir/prepobs_prepacqc.merra.parm"; - print "$0: $cmd\n" unless ( $opt_q ); - $rc = system ( $cmd ) unless ( $opt_n ) ; - die ">>>> ERROR <<< running prepacqc.x" if ( $rc ); - -# copy output file to 'next' so next routine will use it - copy("prepaqc.$nymd.$hh", "$prepqcdir/next.$nymd.$hh"); - - undef $FORT_CONVERT15; - - -} - -#...................................................................... - -sub acarsqc { - - $arqcdir = "$prepqcdir/acarqc"; # PREPQC working directory - $rc = system("/bin/mkdir -p $arqcdir" ); - die ">>> ERROR <<< cannot create $arqcdir " if ( $rc ); - chdir("$arqcdir"); - system("/bin/touch .no_archiving"); # working prepqc dir not to be archived - - -# Assign FORTRAN units for acarsqc -# ------------------------------------------------------------ - -# NOTE: these files do not follow the fv file name conventions -# Many of the output files are discarded -# ------------------------------------------------------------ - Assign("$prepqcdir/next.$nymd.$hh", 14 ); - Assign("$rcdir/prepobs_landc", 15 ); - - Assign("prepacr.$nymd.$hh", 61 ); - Assign("acr_sdmlist.$nymd.$hh", 52 ); - - $FORT_CONVERT15 = "BIG_ENDIAN"; - -# Run acarsqc -# ------- - $cmd = "acarsqc.x < $rcdir/prepobs_acarsqc.merra.parm"; - print "$0: $cmd\n" unless ( $opt_q ); - $rc = system ( $cmd ) unless ( $opt_n ) ; - die ">>>> ERROR <<< running acarsqc.x" if ( $rc ); - -# copy output file to 'next' so next routine will use it - copy("prepacr.$nymd.$hh", "$prepqcdir/next.$nymd.$hh"); - - undef $FORT_CONVERT15; - -} -#...................................................................... - # # System: This routine saves stdout/stderr, redirects it to a specified file, # runs a shell command using this new stdout/stderr, and finally From c414623210a1d85c55e23f7b3acd3e75bd3f8973 Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz Date: Fri, 3 Jan 2020 18:22:38 -0500 Subject: [PATCH 016/205] Adding 'twindow.x' time windowing for satellite winds, used to reduce number of winds in SATWND file for use with MERRA2 --- .../NCEP_Paqc/modify_bufr/CMakeLists.txt | 12 +- .../NCEP_Paqc/modify_bufr/twindow.f | 603 ++++++++++++++++++ .../NCEP_Paqc/modify_bufr/twindow.rc | 61 ++ .../NCEP_Paqc/modify_bufr/twindow_m2.rc | 61 ++ 4 files changed, 736 insertions(+), 1 deletion(-) create mode 100644 src/Applications/NCEP_Paqc/modify_bufr/twindow.f create mode 100644 src/Applications/NCEP_Paqc/modify_bufr/twindow.rc create mode 100644 src/Applications/NCEP_Paqc/modify_bufr/twindow_m2.rc diff --git a/src/Applications/NCEP_Paqc/modify_bufr/CMakeLists.txt b/src/Applications/NCEP_Paqc/modify_bufr/CMakeLists.txt index 0798adc5..a90780d3 100644 --- a/src/Applications/NCEP_Paqc/modify_bufr/CMakeLists.txt +++ b/src/Applications/NCEP_Paqc/modify_bufr/CMakeLists.txt @@ -11,4 +11,14 @@ ecbuild_add_executable ( ecbuild_add_executable ( TARGET explode.x SOURCES explode.f - LIBS NCEP_bufr_r4i4) \ No newline at end of file + LIBS NCEP_bufr_r4i4) + +ecbuild_add_executable ( + TARGET twindow.x + SOURCES twindow.f + LIBS NCEP_bufr_r4i4 NCEP_w3_r4i4 GMAO_mpeu) + +if (EXTENDED_SOURCE) + set_target_properties (twindow.x PROPERTIES COMPILE_FLAGS ${EXTENDED_SOURCE}) +endif() + diff --git a/src/Applications/NCEP_Paqc/modify_bufr/twindow.f b/src/Applications/NCEP_Paqc/modify_bufr/twindow.f new file mode 100644 index 00000000..d4ddd40f --- /dev/null +++ b/src/Applications/NCEP_Paqc/modify_bufr/twindow.f @@ -0,0 +1,603 @@ + program twindow +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! NASA/GSFC, Global Modeling and Assimilation Office, Code 610.1 ! +!----------------------------------------------------------------------- +!BOP +! +! !ROUTINE: twindow: apply time window to satwind files +! +! !INTERFACE: +! +! Usage: twindow.x [-rc rcfile] input_bufr output_bufr +! +! !USES: +! + use m_inpak90 ! rc input handler + + implicit NONE +! +! link to libNCEP_w3_r4i4.a and libNCEP_bufr_r4i4.a libraries + +! !DESCRIPTION: simple routine to copy data from BUFR file to +! a second file, excluding GOES sounder satwinds +! outside of a specified time window +! +! !REVISION HISTORY: +! +! 15Jan2015 Meta Initial version +! 16Jan2015 Meta exclude AVHRR and SWIR data, replace 'if' +! with CASE to allow only specified (EU,JMA,MODIS) +! wind types to be copied +! 20May2015 Meta take out NC005066- EUMETSAT WV, for now, to +! reduce obs count for old runs +! 21May2015 Meta New version reads resource file to determine +! obs filtering. +! 22May2015 Meta deallocate table arrays at end, add I90_Release +! 13Dec2017 Meta Process GOES-R format and convert +! to format that M2 can read (use_flg = 2). +! Continue processing in if-block until subset +! read in from input file changes from prior one +! 3Jun2019 Meta Add screening by satellite ID for GOES-R+ +! (for GOES 5_12 only checks if satid==259 to +! assign subtype 15, can't screen other satIDs) +! 18Sep2019 Meta Add additional OPENMB calls after READMG - +! while 'subset' is the same, 'idate' may +! have changed so new message may be required. +! +!EOP +!----------------------------------------------------------------------- + + integer luin, luout ! unit numbers + + integer argc + integer(4) iargc + integer ireadsb + + character(len=120) inputfile + character(len=120) outputfile + character(len=120) rcfile + + character(len=8) subset ! name of BUFR subset read in + character(len=8) osubset ! prior subset name + + character(len=8),allocatable :: wsubsets(:),nsubsets(:) + integer,allocatable :: use_flg(:) + integer,allocatable :: dtmin(:) + integer,allocatable :: dtmax(:) + integer,allocatable :: ikeep(:,:) + integer,allocatable :: nkeep(:) + integer nsattype + + integer idate ! synoptic date/time YYYYMMDD + integer cdate ! center date *hopefully 1st in the file* + integer jdate(5) ! use for call to w3fs21 + integer itctr ! center date (min since 1 jan 78) + integer itmin, itmax ! window limits (min since 1 jan 78) + integer obtime ! obs time (min since 1 jan 78) + + integer iret ! subroutine return code + + integer klev, llev ! no. of levels in report + integer i, j + integer narg + integer idx + + integer rc + + integer no,ni,ne + + real(8) getbmiss, bmiss + + real(8) time(5) + character(len=80) timestr + character(len=8) unknown + + data timestr/'YEAR MNTH DAYS HOUR MINU'/ + + + data luin /8/, luout /9/ + +! Variables for GOES-16 conversion + real(8) hdrdat(13), obsdat(4) + real(8) qcdat(3,12), amvivr(2,2) + real pct1, qm + logical keep + + integer ilev, jlev, iqlev + + character(len=70) :: obstr,obstr0,hdrtr,hdrtr0 + character(len=50) :: qcstr + data hdrtr0 / 'SAID CLATH CLONH YEAR MNTH DAYS HOUR MINU SWCM SAZA OGCE SCCF SWQM' / + data hdrtr / 'SAID CLAT CLON YEAR MNTH DAYS HOUR MINU SWCM SAZA OGCE SCCF SWQM' / + data obstr0 / 'EHAM PRLC WDIR WSPD' / + data obstr / 'HAMD PRLC WDIR WSPD' / + data qcstr / 'GNAP PCCF' / + + no=0 + ni=0 + ne=0 + unknown = '' + narg = 0 + bmiss = getbmiss() + + + argc = iargc() + if (argc .lt. 2) then + call usage() + stop + endif + + rcfile = 'twindow.rc' + + call GetArg( 1_4, inputfile) + if (inputfile == '-rc') then + if (argc .lt. 4) then + call usage() + stop + end if + narg = narg + 2 + call GetArg(2_4,rcfile) + call GetArg(3_4,inputfile) + end if + call GetArg( 2_4+narg, outputfile) + + rc = 0 + call read_table(rcfile,wsubsets,use_flg,dtmin,dtmax, + & nkeep,ikeep,nsubsets,nsattype,rc) + + if (rc /= 0) then + print *,'twindow: could not read config table, exiting.' + stop + end if + + open(unit=luin,file=trim(inputfile),form='unformatted') + open(unit=luout,file=trim(outputfile),form='unformatted') + call openbf(luin,'IN ',luin) + call openbf(luout,'OUT',luin) + + call datelen(10) + call cmpmsg('Y') + +! get center date from first message in BUFR file + call readmg(luin,subset,idate,iret) + + if (iret /= 0) then + print *,'twindow, error reading ',trim(inputfile) + stop + end if + + cdate = idate + jdate(5) = 0 + jdate(1) = cdate/1000000 + jdate(2) = mod(cdate,1000000)/10000 + jdate(3) = mod(cdate,10000)/100 + jdate(4) = mod(cdate,100) + call w3fs21(jdate,itctr) + + idx = 0 + main: do while(iret .eq. 0) + + idx = find_subset(subset,wsubsets,nsattype,idx) + + if (idx == 0) then + if (subset /= unknown) then + print *,'twindow: error, ',subset, + & ' not found in subset table' + unknown = subset + end if + do while (subset == unknown .and. iret == 0) + call readmg(luin,subset,idate,iret) + end do + cycle + end if + + if (use_flg(idx) == 1) then + + itmin = dtmin(idx) + itctr + itmax = dtmax(idx) + itctr + +! case of windowed obs (NESDIS GOES hourly wind): +! get time and compare to time window, copy obs inside time window +! to output file, process all messages that match this subset + + osubset = subset + + call openmb(luout,subset,idate) + + flg1: do while ( iret .eq. 0 ) + + do while ( ireadsb(luin) .eq. 0 ) + + call ufbint(luin,time,5,1,klev,timestr) + do j = 1,5 + jdate(j) = int(time(j)) + end do + call w3fs21(jdate,obtime) + if (obtime .ge. itmin .and. obtime .le. itmax) then + ni=ni+1 + call openmb(luout,subset,idate) + call ufbcpy(luin, luout) + call writsb(luout) + else + ne=ne+1 + end if + enddo + + call readmg(luin, subset, idate, iret) + + if (iret /= 0 .or. subset /= osubset) exit flg1 + call openmb(luout,subset,idate) + + end do flg1 + + call closmg(luout) + + else if ( use_flg(idx) == 2 ) then + + itmin = dtmin(idx) + itctr + itmax = dtmax(idx) + itctr + +! case of new GOES format that needs to be rewritten for MERRA2 +! get time and compare to time window, qc obs inside time window +! and rewrite in old GOES format to output file - process all +! the messages that match this subset + +! We are lucky in that the defs for the old GOES wind formats +! are contained in the BUFR dictionary used for the new winds + + osubset = subset + + call openmb(luout,nsubsets(idx),idate) + + flg2: do while ( iret .eq. 0 ) + + readsb: do while ( ireadsb(luin) .eq. 0 ) + + call ufbint(luin,time,5,1,klev,timestr) + do j = 1,5 + jdate(j) = int(time(j)) + end do + call w3fs21(jdate,obtime) + if (obtime .ge. itmin .and. obtime .le. itmax) then + ni=ni+1 + +! Read in data from new format file + hdrdat = bmiss + obsdat = bmiss + qcdat = bmiss + qm = 2 + + call ufbint(luin,hdrdat,13,1,ilev,hdrtr0) + call ufbint(luin,obsdat,4,1,ilev,obstr0) + call ufbrep(luin,qcdat,2,12,iqlev,qcstr) + call ufbrep(luin,amvivr,2,2,ilev,'TCOV CVWD') + + if ( nkeep(idx) > 0 ) then ! screen satIDs + keep = .false. + do j = 1,nkeep(idx) + if (nint(hdrdat(1)) .eq. ikeep(j,idx)) then + keep = .true. + exit + end if + end do + + if ( .not. keep ) cycle readsb ! skip if satID not found + + end if + + +! using QM=14 so read_satwnd will skip these data + pct1 = amvivr(2,1) + if (pct1 < 0.04) qm=14 + if (pct1 > 0.50) qm=14 + + hdrdat(13) = qm + +! write out a record with data in old format, just including +! data read in by MERRA2 code + + call ufbint(luout,hdrdat,13,1,ilev,hdrtr) + call ufbint(luout,obsdat,4,1,ilev,obstr) + call ufbrep(luout,qcdat,2,iqlev,jlev,qcstr) + + call writsb(luout) + + else ! data not in time window + ne=ne+1 + end if + + end do readsb + + call readmg(luin, subset, idate, iret) + + if (iret /= 0 .or. subset /= osubset) exit flg2 + call openmb(luout,nsubsets(idx),idate) + + end do flg2 + + call closmg(luout) + + + else if ( use_flg(idx) == 0 ) then + +! case of nonwindowed (EUMETSAT, JMA, MODIS) - just copy the winds as they are +! for all of the messages matching this subset + osubset = subset + + flg0: do while ( iret .eq. 0 ) + + no = no + 1 + call copymg(luin,luout) + call readmg(luin,subset,idate,iret) + if (iret /= 0 .or. subset /= osubset) exit flg0 + + end do flg0 + + else ! other cases - just skip the messages matching this subset + + osubset = subset + + flgX: do while ( iret .eq. 0 ) + + call readmg(luin, subset, idate, iret) + if (iret /= 0 .or. subset /= osubset) exit flgX + + end do flgx + + end if + + + end do main + + call closbf(luin) + call closbf(luout) + + deallocate(wsubsets,use_flg,dtmin,dtmax,stat=iret) + + stop + + contains + +!------------------------------------------------------------------------- +! NASA/GSFC, Data Assimilation Office, Code 610.1, GEOS/DAS ! +!------------------------------------------------------------------------- +!BOP +! +! !IROUTINE: usage - print the usage instructions +! +! !INTERFACE: + + subroutine usage() +! +!EOP +!------------------------------------------------------------------------- + print *,'usage: twindow.x [-rc rcfile] inputbufr outputbufr' + stop + end subroutine usage + +!------------------------------------------------------------------------- +! NASA/GSFC, Data Assimilation Office, Code 610.1, GEOS/DAS ! +!------------------------------------------------------------------------- +!BOP +! +! !IROUTINE: read_table -- read the configuration table +! +! +! !INTERFACE: + + subroutine read_table(tablefile,wsubsets,use_flg,dtmin,dtmax, + & nkeep, ikeep, nsubsets,nsattype,rc) + +! !INPUT PARAMETERS: +! + character(len=*),intent(in) :: tablefile + +! !OUTPUT PARAMETERS: +! + character(len=8),allocatable,intent(out) :: wsubsets(:) + integer,allocatable,intent(out) :: use_flg(:) + integer,allocatable,intent(out) :: dtmin(:) + integer,allocatable,intent(out) :: dtmax(:) + integer,allocatable,intent(out) :: nkeep(:) + integer,allocatable,intent(out) :: ikeep(:,:) + character(len=8),allocatable,intent(out) :: nsubsets(:) + integer,intent(out) :: nsattype + integer,intent(out) :: rc + +! !DESCRIPTION: +! +! load resource file 'tablefile' and read configuration for satellite +! wind data processing +! +! !REVISION HISTORY: +! +! 21May2015 Meta New routine +! 22May2015 Meta add I90_Release to free memory +! 13Dec2017 Meta Changes for GOES-16 processing, add column for +! new subset name +! +! +!EOP +!------------------------------------------------------------------------- + + integer iret + integer i, ii, j + + character(len=8) str + rc = 0 + + call i90_LoadF (tablefile, iret) + + if (iret .ne. 0) then + print * ,'twindow: failed to load table file ', + & trim(tablefile), ' rc = ',iret + rc = -1 + return + end if + + call i90_label('action_table::', iret) + + if (iret .ne. 0) then + print *,'twindow: action table read failed, rc = ', iret + rc = -1 + return + end if +! +! count the number of lines in the table, then allocate space + + iret = 0 + nsattype = 0 + call i90_gline(iret) + do while (iret == 0 ) + nsattype = nsattype + 1 + call i90_gline(iret) + end do + + allocate(wsubsets(nsattype),use_flg(nsattype), + & dtmin(nsattype), dtmax(nsattype), nsubsets(nsattype), + & nkeep(nsattype), ikeep(4,nsattype), stat=iret) + + if (iret /= 0) then + print *,'twindow: unable to allocate space' + rc = -1 + return + end if + + use_flg = 0 + dtmin = 0 + dtmax = 0 + + if (iret /= 0) then + print *,'twindow: error allocating memory for arrays' + rc = -1 + return + end if + + call i90_label('action_table::', iret) + + do i = 1, nsattype + call i90_gline(iret) + if (iret /= 0) then + print *,'twindow: error reading line ',i + rc = -1 + return + end if + call i90_gtoken(str,iret) + if (iret /= 0) then + print *,'twindow: Error reading subset name, line ',i + rc = -1 + return + end if + wsubsets(i) = str + ii = i90_gint(iret) + if (iret /= 0) then + print *,'twindow: Error reading use_flag for subset ', + & wsubsets(i) + rc = -1 + return + end if + use_flg(i) = ii +! +! read time window parameters if use_flg == 1 or == 2 + if (use_flg(i) == 1 .or. use_flg(i) == 2) then + ii = i90_gint(iret) + if (iret /= 0) then + print *,'twindow: error reading time window ', + & 'for subset ', wsubsets(i) + rc = -1 + return + end if + dtmin(i) = ii + ii = i90_gint(iret) + if (iret /= 0) then + print *,'twindow: error reading time window ', + & 'for subset ', wsubsets(i) + rc = -1 + return + end if + dtmax(i) = ii + if (use_flg(i) == 2) then + call i90_gtoken(str,iret) + if (iret /= 0) then + print *,'twindow: Error reading new subset name,', + & ' line ',i + rc = -1 + return + end if + nsubsets(i) = str +! check for additional fields + iret = 0 + j = 0 + do while( iret == 0 .and. j < 4) + ii = i90_gint(iret) + if (iret /= 0) exit + j = j + 1 + ikeep(j,i) = ii + end do + nkeep(i) = j + end if + end if + + end do + + call I90_Release(iret) + + return + + end subroutine read_table + +!------------------------------------------------------------------------- +! NASA/GSFC, Data Assimilation Office, Code 610.1, GEOS/DAS ! +!------------------------------------------------------------------------- +!BOP +! +! !IROUTINE: find_subset - search for subset name in table +! +! +! !INTERFACE: + + integer function find_subset(subset,wsubsets,nsattype,idx) + +! !INPUT PARAMETERS: +! + integer nsattype + character(len=8) wsubsets(nsattype) + character(len=8) subset + integer idx + + +! !DESCRIPTION: +! +! Look for matching subset name in table. If 'idx' is set nonzero, +! check wsubsets(idx) first for a match. +! +! +! !REVISION HISTORY: +! +! 21May2015 Meta New routine +! +! +!EOP +!------------------------------------------------------------------------- + integer i + + if (idx .ne. 0) then + if (wsubsets(idx) == subset) then + find_subset = idx + return + end if + end if + + do i = 1,nsattype + if (wsubsets(i) == subset) then + find_subset = i + return + end if + end do + + find_subset = 0 + return + + end function find_subset + + end program twindow diff --git a/src/Applications/NCEP_Paqc/modify_bufr/twindow.rc b/src/Applications/NCEP_Paqc/modify_bufr/twindow.rc new file mode 100644 index 00000000..74ef0616 --- /dev/null +++ b/src/Applications/NCEP_Paqc/modify_bufr/twindow.rc @@ -0,0 +1,61 @@ +# +# twindow.rc - time windowing resource file +# +# !HISTORY: +# +# 2015-05-21 Meta - Initial version with configuration from prior +# version of twindow.f +# 2015-08-10 Meta - Add NC005090 (VIIRS IR) to configuration, omitted +# to keep files as they were +# 2017-12-13 Meta - New defintions for GOES-16 data, to be rewritten in +# old GOES format +# 2017-12-21 Meta - Copy configuration for METEOSAT winds from OPS config +# +# 2019-06-04 Meta - Add column in GOES-16 specification to indicate the +# satIDs to copy to output (other satIDs will be dropped) + + +action_table:: + +# input destination GOES-R +# subset use_flg dtime_min dtime_max subset satIDs # description + +NC005010 1 -60 0 # GOES IR(245) +NC005011 1 -60 0 # GOES WV(246,247) +NC005012 1 -60 0 # GOES VIS(251) +NC005019 -1 0 0 # GOES SWIR(240) +NC005024 -1 0 0 # India INSAT IR +NC005025 -1 0 0 # India INSAT VIS +NC005026 -1 0 0 # India INSAT WV +NC005030 2 -60 0 NC005010 270 # GOES-16+ IR LW(245) +NC005031 2 -60 0 NC005011 270 # GOES-16+ WV clear sky/deep layer(247) +NC005032 2 -60 0 NC005012 270 # GOES-16+ VIS(251) +NC005034 2 -60 0 NC005011 270 # GOES-16+ WV cloud-top(246) +#C005039 -1 0 0 NC005019 270 # GOES-16+ SWIR(240) +NC005039 -1 0 0 # GOES-16+ SWIR(240) +NC005044 0 0 0 # JMA IR +NC005045 0 0 0 # JMA VIS +NC005046 0 0 0 # JMA WV +NC005064 1 -120 120 # METEOSAT IR +NC005065 1 -120 120 # METEOSAT VIS +NC005066 -1 0 0 # METEOSAT WV +NC005070 0 0 0 # MODIS IR +NC005071 0 0 0 # MODIS WV +NC005080 0 0 0 # AVHRR IR +NC005090 -1 0 0 # VIIRS IR + +:: + +# use flag: -1 omit +# 0 keep as is +# 1 apply time windowing +# 2 time windowing and rewrite GOES-R in old GOES wind format + +# GOES winds: time window from -1 hr to center time, to +# mimic what was used prior to hourly wind switchover +# +# other winds passed as is or are excluded (to avoid array overflow +# and duplication of data) +# +# for RPIT some Meteosat winds are excluded to allow extra buffer +# size for AVHRR winds diff --git a/src/Applications/NCEP_Paqc/modify_bufr/twindow_m2.rc b/src/Applications/NCEP_Paqc/modify_bufr/twindow_m2.rc new file mode 100644 index 00000000..61e4f3df --- /dev/null +++ b/src/Applications/NCEP_Paqc/modify_bufr/twindow_m2.rc @@ -0,0 +1,61 @@ +# +# twindow.rc - time windowing resource file +# +# !HISTORY: +# +# 2015-05-21 Meta - Initial version with configuration from prior +# version of twindow.f +# 2015-08-10 Meta - Add NC005090 (VIIRS IR) to configuration, omitted +# to keep files as they were +# 2017-12-13 Meta - New defintions for GOES-16 data, to be rewritten in +# old GOES format +# 2017-12-21 Meta - Copy configuration for METEOSAT winds from OPS config +# +# 2019-06-04 Meta - Add column in GOES-16 specification to indicate the +# satIDs to copy to output (other satIDs will be dropped) + + +action_table:: + +# input destination GOES-R +# subset use_flg dtime_min dtime_max subset satIDs # description + +NC005010 1 -60 0 # GOES IR(245) +NC005011 1 -60 0 # GOES WV(246,247) +NC005012 1 -60 0 # GOES VIS(251) +NC005019 -1 0 0 # GOES SWIR(240) +NC005024 -1 0 0 # India INSAT IR +NC005025 -1 0 0 # India INSAT VIS +NC005026 -1 0 0 # India INSAT WV +NC005030 2 -60 0 NC005010 270 # GOES-16+ IR LW(245) +NC005031 2 -60 0 NC005011 270 # GOES-16+ WV clear sky/deep layer(247) +NC005032 2 -60 0 NC005012 270 # GOES-16+ VIS(251) +NC005034 2 -60 0 NC005011 270 # GOES-16+ WV cloud-top(246) +#C005039 -1 0 0 NC005019 270 # GOES-16+ SWIR(240) +NC005039 -1 0 0 # GOES-16+ SWIR(240) +NC005044 0 0 0 # JMA IR +NC005045 0 0 0 # JMA VIS +NC005046 0 0 0 # JMA WV +NC005064 0 0 0 # METEOSAT IR +NC005065 0 0 0 # METEOSAT VIS +NC005066 -1 0 0 # METEOSAT WV +NC005070 0 0 0 # MODIS IR +NC005071 0 0 0 # MODIS WV +NC005080 -1 0 0 # AVHRR IR +NC005090 -1 0 0 # VIIRS IR + +:: + +# use flag: -1 omit +# 0 keep as is +# 1 apply time windowing +# 2 time windowing and rewrite GOES-R in old GOES wind format + +# GOES winds: time window from -1 hr to center time, to +# mimic what was used prior to hourly wind switchover +# +# other winds passed as is or are excluded (to avoid array overflow +# and duplication of data) +# +# for RPIT some Meteosat winds are excluded to allow extra buffer +# size for AVHRR winds From 5cea45d6df05b46166b79e4c0707318492f3f570 Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz Date: Fri, 3 Jan 2020 18:25:14 -0500 Subject: [PATCH 017/205] This version removes the restriction on GOES-R wind types so that both GOES-16 and GOES-17 winds will be reformatted and passed to MERRA2/FPIT --- src/Applications/NCEP_Paqc/modify_bufr/twindow.rc | 15 ++++++++++----- .../NCEP_Paqc/modify_bufr/twindow_m2.rc | 15 ++++++++++----- 2 files changed, 20 insertions(+), 10 deletions(-) diff --git a/src/Applications/NCEP_Paqc/modify_bufr/twindow.rc b/src/Applications/NCEP_Paqc/modify_bufr/twindow.rc index 74ef0616..8358899b 100644 --- a/src/Applications/NCEP_Paqc/modify_bufr/twindow.rc +++ b/src/Applications/NCEP_Paqc/modify_bufr/twindow.rc @@ -13,6 +13,10 @@ # # 2019-06-04 Meta - Add column in GOES-16 specification to indicate the # satIDs to copy to output (other satIDs will be dropped) +# +# 2020-01-02 Meta - Remove restriction on satID for GOES-16+, to allow both +# GOES-16 and GOES-17 winds to be processed. Add entry +# for new VIIRS IR subset action_table:: @@ -27,11 +31,11 @@ NC005019 -1 0 0 # GOES SWI NC005024 -1 0 0 # India INSAT IR NC005025 -1 0 0 # India INSAT VIS NC005026 -1 0 0 # India INSAT WV -NC005030 2 -60 0 NC005010 270 # GOES-16+ IR LW(245) -NC005031 2 -60 0 NC005011 270 # GOES-16+ WV clear sky/deep layer(247) -NC005032 2 -60 0 NC005012 270 # GOES-16+ VIS(251) -NC005034 2 -60 0 NC005011 270 # GOES-16+ WV cloud-top(246) -#C005039 -1 0 0 NC005019 270 # GOES-16+ SWIR(240) +NC005030 2 -60 0 NC005010 # GOES-16+ IR LW(245) +NC005031 2 -60 0 NC005011 # GOES-16+ WV clear sky/deep layer(247) +NC005032 2 -60 0 NC005012 # GOES-16+ VIS(251) +NC005034 2 -60 0 NC005011 # GOES-16+ WV cloud-top(246) +#C005039 -1 0 0 NC005019 # GOES-16+ SWIR(240) NC005039 -1 0 0 # GOES-16+ SWIR(240) NC005044 0 0 0 # JMA IR NC005045 0 0 0 # JMA VIS @@ -43,6 +47,7 @@ NC005070 0 0 0 # MODIS IR NC005071 0 0 0 # MODIS WV NC005080 0 0 0 # AVHRR IR NC005090 -1 0 0 # VIIRS IR +NC005091 -1 0 0 # new VIIRS IR :: diff --git a/src/Applications/NCEP_Paqc/modify_bufr/twindow_m2.rc b/src/Applications/NCEP_Paqc/modify_bufr/twindow_m2.rc index 61e4f3df..58703784 100644 --- a/src/Applications/NCEP_Paqc/modify_bufr/twindow_m2.rc +++ b/src/Applications/NCEP_Paqc/modify_bufr/twindow_m2.rc @@ -13,6 +13,10 @@ # # 2019-06-04 Meta - Add column in GOES-16 specification to indicate the # satIDs to copy to output (other satIDs will be dropped) +# +# 2020-01-02 Meta - Remove restriction on satID for GOES-16+, to allow both +# GOES-16 and GOES-17 winds to be processed. Add entry +# for new VIIRS IR subset action_table:: @@ -27,11 +31,11 @@ NC005019 -1 0 0 # GOES SWI NC005024 -1 0 0 # India INSAT IR NC005025 -1 0 0 # India INSAT VIS NC005026 -1 0 0 # India INSAT WV -NC005030 2 -60 0 NC005010 270 # GOES-16+ IR LW(245) -NC005031 2 -60 0 NC005011 270 # GOES-16+ WV clear sky/deep layer(247) -NC005032 2 -60 0 NC005012 270 # GOES-16+ VIS(251) -NC005034 2 -60 0 NC005011 270 # GOES-16+ WV cloud-top(246) -#C005039 -1 0 0 NC005019 270 # GOES-16+ SWIR(240) +NC005030 2 -60 0 NC005010 # GOES-16+ IR LW(245) +NC005031 2 -60 0 NC005011 # GOES-16+ WV clear sky/deep layer(247) +NC005032 2 -60 0 NC005012 # GOES-16+ VIS(251) +NC005034 2 -60 0 NC005011 # GOES-16+ WV cloud-top(246) +#C005039 -1 0 0 NC005019 # GOES-16+ SWIR(240) NC005039 -1 0 0 # GOES-16+ SWIR(240) NC005044 0 0 0 # JMA IR NC005045 0 0 0 # JMA VIS @@ -43,6 +47,7 @@ NC005070 0 0 0 # MODIS IR NC005071 0 0 0 # MODIS WV NC005080 -1 0 0 # AVHRR IR NC005090 -1 0 0 # VIIRS IR +NC005091 -1 0 0 # new VIIRS IR :: From 538aa9a0ea43a8db1cffab05ba1fcf54ae3d1275 Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz Date: Wed, 8 Jul 2020 10:07:57 -0400 Subject: [PATCH 018/205] Merge in changes from NCEP obsproc_prep.v5.2.2 time window changes for two digit BUFR years - prevents.f, profcqc.f modification for debug compile - cqcbufr.f prevents.f also added increase in bufr record size (from CVS) profcqc.f also added increase in max number of records from a station (from a previous NCEP update in CVS) --- .../NCEP_Paqc/GMAOprev/prevents.f | 16 +- .../NCEP_Paqc/prepobs_cqcbufr.fd/cqcbufr.f | 28 +++- .../NCEP_Paqc/prepobs_profcqc.fd/profcqc.f | 154 +++++++++++++----- 3 files changed, 142 insertions(+), 56 deletions(-) diff --git a/src/Applications/NCEP_Paqc/GMAOprev/prevents.f b/src/Applications/NCEP_Paqc/GMAOprev/prevents.f index ad93f7ca..8c50054b 100644 --- a/src/Applications/NCEP_Paqc/GMAOprev/prevents.f +++ b/src/Applications/NCEP_Paqc/GMAOprev/prevents.f @@ -1,7 +1,7 @@ C$$$ MAIN PROGRAM DOCUMENTATION BLOCK C C MAIN PROGRAM: PREPOBS_PREVENTS -C PRGMMR: KEYSER ORG: NP22 DATE: 2013-02-13 +C PRGMMR: DONG ORG: NP22 DATE: 2020-01-09 C C ABSTRACT: PREPARES OBSERVATIONAL PREPBUFR FILE FOR SUBSEQUENT C QUALITY CONTROL AND ANALYSIS PROGRAMS. THIS IS DONE THROUGH THE @@ -75,10 +75,15 @@ C STANDARD GET_ENVIRONMENT_VARIABLE; USE FORMATTED PRINT C STATEMENTS WHERE PREVIOUSLY UNFORMATTED PRINT WAS > 80 C CHARACTERS +C 2017-05-22 M. SIENKIEWICZ - CALL MAXOUT TO INCREASE MAX RECORD SIZE +C TO AVOID LOSING SOUNDING RECORDS THAT SLIGHTLY EXCEED MAX c c rename all REAL(8) variables as C *_8 +C 2020-01-06 J. Dong -- In program PREPOBS_PREVENTS, changed the +C windowing decade from 20 to 40 for cases when the year +C is represented by 2 digits instead of 4. C C USAGE: C INPUT FILES: @@ -151,11 +156,11 @@ PROGRAM PREPOBS_PREVENTS DATA LAST/'XXXXXXXX'/ - CALL W3TAGB('PREPOBS_PREVENTS',2013,0044,0061,'NP22') + CALL W3TAGB('PREPOBS_PREVENTS',2020,0009,0061,'NP22') PRINT 700 700 FORMAT(/' =====> WELCOME TO PREVENTS PROGRAM -- LAST UPDATED ', - $ '2013-02-13'/) + $ '2020-01-09'/) C On WCOSS should always set BUFRLIB missing (BMISS) to 10E8 to avoid C overflow when either an INTEGER*4 variable is set to BMISS or a @@ -202,7 +207,9 @@ PROGRAM PREPOBS_PREVENTS PRINT'(" ##> 2-DIGIT YEAR IN IDATEP RETURNED FROM READMG ", $ "(IDATEP IS: ",I0,") - USE WINDOWING TECHNIQUE TO OBTAIN ", $ "4-DIGIT YEAR")', IDATEP - IF(IDATEP/1000000.GT.20) THEN +C IF IDATEP=41~99 THEN IDATEP=1941~1999 +C IF IDATEP=00~40 THEN IDATEP=2000~2040 + IF(IDATEP/1000000.GT.40) THEN IDATEP = 1900000000 + IDATEP ELSE IDATEP = 2000000000 + IDATEP @@ -232,6 +239,7 @@ PROGRAM PREPOBS_PREVENTS CALL OPENBF(IUNITI,'IN ',IUNITI) CALL OPENBF(IUNITP,'OUT',IUNITI) + call maxout(15000) C DETERMINE WHICH NETWORK WE ARE RUNNING UNDER C -------------------------------------------- diff --git a/src/Applications/NCEP_Paqc/prepobs_cqcbufr.fd/cqcbufr.f b/src/Applications/NCEP_Paqc/prepobs_cqcbufr.fd/cqcbufr.f index 3d47bc1f..db11ebdb 100644 --- a/src/Applications/NCEP_Paqc/prepobs_cqcbufr.fd/cqcbufr.f +++ b/src/Applications/NCEP_Paqc/prepobs_cqcbufr.fd/cqcbufr.f @@ -1,7 +1,7 @@ C$$$ MAIN PROGRAM DOCUMENTATION BLOCK C C MAIN PROGRAM: PREPOBS_CQCBUFR -C PRGMMR: KEYSER ORG: NP22 DATE: 2016-05-18 +C PRGMMR: MELCHIOR ORG: NP22 DATE: 2020-01-09 C C ABSTRACT: Perform complex quality control of rawinsonde heights C and temperatures. Errors are detected and many corrected. @@ -241,6 +241,10 @@ C 2017-05-16 Sienkiewicz - adjust maximum BUFR record size (call MAXOUT) C to avoid losing soundings that just barely exceed max after CQC C changes are added to the record. +C 2020-08-09 S. Melchior - In subroutine TMPCHK, explicitly defined ICK +C as an integer. Moved ICK.NE.0 logic inside ITI.NE.0 logic. +C BENEFIT: corrects problems when compiled and run with full DEBUG +C options enabled. C C USAGE: C INPUT FILES: @@ -340,7 +344,7 @@ PROGRAM PREPOBS_CQCBUFR NAMELIST /NAMLST/ TEST, DOVTMP, USESQN, DOHOR, DOTMP, DOT40, & WRT23,RADCOR - CALL W3TAGB('PREPOBS_CQCBUFR',2016,0139,0067,'NP22') + CALL W3TAGB('PREPOBS_CQCBUFR',2020,0009,0067,'NP22') TEST = .TRUE. ! Set .T. for tests to give more print !!! #### BE CAREFUL ##### in subr. POBERR, @@ -357,7 +361,7 @@ PROGRAM PREPOBS_CQCBUFR SINGLE = .FALSE. IF(.NOT.SINGLE) READ(5,NAMLST) WRITE(6,700) TEST, DOVTMP, USESQN, DOHOR, DOTMP, DOT40, WRT23 - 700 FORMAT(/' WELCOME TO PREPOBS_CQCBUFR, LAST UPDATED 2016-05-18'/ + 700 FORMAT(/' WELCOME TO PREPOBS_CQCBUFR, LAST UPDATED 2020-01-09'/ & ' SWITCHES: TEST =',L2,' DOVTMP =',L2,' USESQN =',L2, & ' DOHOR =',L2,' DOTMP =',L2,' DOT40 =',L2,' WRT23 =',L2/) @@ -14188,6 +14192,10 @@ SUBROUTINE T240(L,LM) C C PROGRAM HISTORY LOG: C UNKNOWN W. Collins Original author. +C 2020-08-09 S. Melchior - explicitly defined ICK as an +C integer. Moved ICK.NE.0 logic inside ITI.NE.0 logic. +C BENEFIT: corrects problems when compiled and run with +C full DEBUG options enabled. C C USAGE: CALL TMPCHK C @@ -14223,7 +14231,7 @@ SUBROUTINE TMPCHK COMMON /BUFRLIB_MISSING/BMISS,XMISS,IMISS LOGICAL PRNT - INTEGER IND(5) + INTEGER IND(5), ICK DO IS=1,NOBS DO IV=1,2 @@ -14279,11 +14287,13 @@ SUBROUTINE TMPCHK ITI = 20.*ABS(TMP(L,IS,IV)) & /(TMPSTD(L,IV)*TFACT(L,IV)) ITI = MIN(ITI,20) - IF(ITI.NE.0) CALL CHKTMP(OIT(L,IS,IM,IV), - & OIT(L,IS,IP,IV),TMPSTD(L,IV)*TFACT(L,IV),ICK) - IF(ICK.NE.0) THEN - ITI = 0 - TMP(L,IS,IV) = BMISS + IF(ITI.NE.0) THEN + CALL CHKTMP(OIT(L,IS,IM,IV),OIT(L,IS,IP,IV), + & TMPSTD(L,IV)*TFACT(L,IV),ICK) + IF(ICK.NE.0) THEN + ITI = 0 + TMP(L,IS,IV) = BMISS + ENDIF ENDIF ENDIF NTMP(L,IS,IV) = ITI diff --git a/src/Applications/NCEP_Paqc/prepobs_profcqc.fd/profcqc.f b/src/Applications/NCEP_Paqc/prepobs_profcqc.fd/profcqc.f index d45f7c41..588de639 100755 --- a/src/Applications/NCEP_Paqc/prepobs_profcqc.fd/profcqc.f +++ b/src/Applications/NCEP_Paqc/prepobs_profcqc.fd/profcqc.f @@ -1,7 +1,7 @@ C$$$ MAIN PROGRAM DOCUMENTATION BLOCK C C MAIN PROGRAM: PREPOBS_PROFCQC -C PRGMMR: KEYSER ORG: NP22 DATE: 2013-02-05 +C PRGMMR: DONG ORG: NP22 DATE: 2020-01-09 C C ABSTRACT: PERFORMS COMPLEX QUALITY CONTROL OF PROFILER DOPPLER C WINDS. THE INPUT AND OUTPUT ARE IN PREPBUFR FORMAT. THE @@ -69,6 +69,12 @@ C overflow; rename all REAL(8) variables as *_8; use formatted C print statements where previously unformatted print was > 80 C characters. +C 2016-12-20 Stokes/Keyser Increase the max allowable number of times +C per station. Skip reports and print warning if that limit is +C exceeded. +C 2020-01-09 J. Dong In subroutine READPROF, changed the windowing +C decade from 20 to 40 for cases when the years is represented by +C 2 digits instead of 4. C C USAGE: C INPUT FILES: @@ -93,6 +99,7 @@ C OVER ALL TIMES COMBINED) C C SUBPROGRAMS CALLED: +C SYSTEM: - SYSTEM C UNIQUE: - WRITBUFR CHECKS CSTATS DIFS C DMA EVENT INCR INDICATE INIT C ISDONE MODQUAL PLINT PRNTDATA @@ -233,12 +240,12 @@ C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 -C MACHINE: NCEP WCOSS +C MACHINE: NCEP WCOSS (iDataPlex and Cray-XC40) C C$$$ PROGRAM PREPOBS_PROFCQC - PARAMETER (NL=150,NT=26,NS=120) ! (levels,times,stations) + PARAMETER (NL=150,NT=100,NS=120) ! (levels,times,stations) LOGICAL DONE,STATS,MEAN,STDDEV,SKEW,KURT CHARACTER*8 STN @@ -261,7 +268,7 @@ PROGRAM PREPOBS_PROFCQC NAMELIST/RDATA/IPRINT,TIMWIN_E,TIMWIN_L,STATS,MEAN,STDDEV,SKEW, $ KURT - CALL W3TAGB('PREPOBS_PROFCQC',2013,0036,0078,'NP22') + CALL W3TAGB('PREPOBS_PROFCQC',2020,0009,1200,'NP22') WRITE(6,100) @@ -321,7 +328,7 @@ PROGRAM PREPOBS_PROFCQC STOP - 100 FORMAT(' WELCOME TO PREPOBS_PROFCQC -- VERSION 02/05/2013'//) + 100 FORMAT(' WELCOME TO PREPOBS_PROFCQC -- VERSION 01/09/2020'//) 101 FORMAT(1X,128('*')) 102 FORMAT(/'xxxxxxxxxxxxxxxxxxxxxxxxxxx'/'Process Stn. ',A8) @@ -330,7 +337,7 @@ PROGRAM PREPOBS_PROFCQC C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: BLOCK DATA -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2004-09-09 +C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2016-12-20 C C ABSTRACT: BLOCK DATA FOR PREPOBS_PROFCQC. C @@ -338,6 +345,8 @@ PROGRAM PREPOBS_PROFCQC C 1996-11-20 W. Collins -- Original author. C 2004-09-09 D. Keyser -- XI, XT, XV now expanded to cover all C possible levels. +C 2016-12-20 D. Stokes Increase the max allowable number of times +C per station. C C C ATTRIBUTES: @@ -348,7 +357,7 @@ PROGRAM PREPOBS_PROFCQC BLOCK DATA - PARAMETER (NL=150,NT=26,NS=120) ! (levels,times,stations) + PARAMETER (NL=150,NT=100,NS=120) ! (levels,times,stations) COMMON/PST/IOFFSET(3:8),LVLINCR(3:8),ILEVELS(3:8),STATS,MEAN, $ STDDEV,SKEW,KURT @@ -440,7 +449,7 @@ PROGRAM PREPOBS_PROFCQC C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: WRITBUFR -C PRGMMR: D. KEYSER ORG: NP22 DATE: 2004-09-09 +C PRGMMR: D. KEYSER ORG: NP22 DATE: 2016-12-20 C C ABSTRACT: WRITE OUTPUT PREPBUFR FILE, IDENTICAL TO INPUT C EXCEPT FOR THE ADDITION OF WIND PROFILER Q.C. EVENTS. @@ -452,6 +461,8 @@ PROGRAM PREPOBS_PROFCQC C chk at all output times can be based on 2-sided diff {before C temporal chk on output rpts on time (assimilation) bdry based on C 1-sided diff}. +C 2016-12-20 D. Stokes Increase the max allowable number of times +C per station. C C USAGE: CALL WRITBUFR C INPUT FILES: @@ -470,7 +481,7 @@ PROGRAM PREPOBS_PROFCQC SUBROUTINE WRITBUFR - PARAMETER (NL=150,NT=26,NS=120) ! (levels,times,stations) + PARAMETER (NL=150,NT=100,NS=120) ! (levels,times,stations) LOGICAL FIRST CHARACTER*8 STN,LAST,SUBSET,CID @@ -749,7 +760,7 @@ SUBROUTINE WRITBUFR C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: CHECKS -C PRGMMR: D. KEYSER ORG: NP22 DATE: 2004-09-09 +C PRGMMR: D. KEYSER ORG: NP22 DATE: 2016-12-20 C C ABSTRACT: PERFORM INCREMENT, TEMPORAL AND VERTICAL CHECKS FOR C A SINGLE UNIQUE STATION. @@ -768,6 +779,8 @@ SUBROUTINE WRITBUFR C temporal check not performed. Max. del-time on one side is 2-hrs C for all rpts. DO-LOOP logic more concise (esp. in temporal & C vert. chks.) +C 2016-12-20 D. Stokes Increase the max allowable number of times +C per station. C C USAGE: SUBROUTINE CHECKS(IS) C INPUT ARGUMENT LIST: @@ -795,7 +808,7 @@ SUBROUTINE WRITBUFR C$$$ SUBROUTINE CHECKS(IS) - PARAMETER (NL=150,NT=26,NS=120) ! (levels,times,stations) + PARAMETER (NL=150,NT=100,NS=120) ! (levels,times,stations) CHARACTER*8 STN REAL(8) BMISS @@ -1097,7 +1110,7 @@ SUBROUTINE CHECKS(IS) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: CSTATS -C PRGMMR: D. KEYSER ORG: NP22 DATE: 2004-09-09 +C PRGMMR: D. KEYSER ORG: NP22 DATE: 2016-12-20 C C ABSTRACT: CALCULATE MOMENTS FOR RESIDUALS FOR A SINGLE STATION. C @@ -1105,6 +1118,8 @@ SUBROUTINE CHECKS(IS) C 1995-04-04 W. Collins -- Original author. C 2004-09-09 D. Keyser -- Stats generated separately for NPN, CAP & C JMA rpts and stratified according to hgt above ground. +C 2016-12-20 D. Stokes Increase the max allowable number of times +C per station. C C USAGE: SUBROUTINE CSTATS(IS) C @@ -1140,7 +1155,7 @@ SUBROUTINE CHECKS(IS) C$$$ SUBROUTINE CSTATS(IS) - PARAMETER (NL=150,NT=26,NS=120) ! (levels,times,stations) + PARAMETER (NL=150,NT=100,NS=120) ! (levels,times,stations) CHARACTER*8 STN REAL(8) BMISS @@ -1419,7 +1434,7 @@ SUBROUTINE CSTATS(IS) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: DIFS -C PRGMMR: D. KEYSER ORG: NP22 DATE: 2004-09-09 +C PRGMMR: D. KEYSER ORG: NP22 DATE: 2016-12-20 C C ABSTRACT: COMPUTE DIFFERENCES OF RESIDUALS, USED IN DMA. C @@ -1428,6 +1443,8 @@ SUBROUTINE CSTATS(IS) C 2004-09-09 D. Keyser -- Excessive stdout print of differencing C results can be removed w/ new namelist switch which controls the C degree of printout. +C 2016-12-20 D. Stokes Increase the max allowable number of times +C per station. C C USAGE: CALL DIFS(IS,IPRINT) C @@ -1467,7 +1484,7 @@ SUBROUTINE CSTATS(IS) C$$$ SUBROUTINE DIFS(IS,IPRINT) - PARAMETER (NL=150,NT=26,NS=120) ! (levels,times,stations) + PARAMETER (NL=150,NT=100,NS=120) ! (levels,times,stations) CHARACTER*8 STN REAL(8) BMISS @@ -1564,7 +1581,7 @@ SUBROUTINE DIFS(IS,IPRINT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: DMA -C PRGMMR: D. KEYSER ORG: NP22 DATE: 2004-09-09 +C PRGMMR: D. KEYSER ORG: NP22 DATE: 2016-12-20 C C ABSTRACT: DECISION MAKING ALGORITHM FOR PROFILER WIND QC. C @@ -1572,6 +1589,8 @@ SUBROUTINE DIFS(IS,IPRINT) C 1995-04-05 W. Collins -- Original author. C 2004-09-09 D. Keyser -- Reason codes are expanded (see MAIN program C remarks). +C 2016-12-20 D. Stokes Increase the max allowable number of times +C per station. C C USAGE: CALL DMA(IS) C INPUT ARGUMENT LIST: @@ -1602,7 +1621,7 @@ SUBROUTINE DIFS(IS,IPRINT) C$$$ SUBROUTINE DMA(IS) - PARAMETER (NL=150,NT=26,NS=120) ! (levels,times,stations) + PARAMETER (NL=150,NT=100,NS=120) ! (levels,times,stations) CHARACTER*8 STN,CID REAL(8) BMISS @@ -1910,7 +1929,7 @@ SUBROUTINE EVENT(LUNIT,EVNSTR,NLV,OBS,QMS,RCS,IND,NEVN,QCPC) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: INCR -C PRGMMR: W. COLLINS ORG: NP22 DATE: 1996-11-20 +C PRGMMR: W. COLLINS ORG: NP22 DATE: 2016-12-20 C C ABSTRACT: CALCULATE FORECAST INCREMENTS, I.E. THE DIFFERENCE C BETWEEN THE OBSERVED VALUE AND THE FORECAST VALUE (OF THE @@ -1918,6 +1937,8 @@ SUBROUTINE EVENT(LUNIT,EVNSTR,NLV,OBS,QMS,RCS,IND,NEVN,QCPC) C C PROGRAM HISTORY LOG: C 1996-11-20 W. Collins -- Original author. +C 2016-12-20 D. Stokes Increase the max allowable number of times +C per station. C C USAGE: CALL INCR C OUTPUT FILES: @@ -1930,7 +1951,7 @@ SUBROUTINE EVENT(LUNIT,EVNSTR,NLV,OBS,QMS,RCS,IND,NEVN,QCPC) C$$$ SUBROUTINE INCR - PARAMETER (NL=150,NT=26,NS=120) ! (levels,times,stations) + PARAMETER (NL=150,NT=100,NS=120) ! (levels,times,stations) CHARACTER*8 STN REAL(8) BMISS @@ -1980,7 +2001,7 @@ SUBROUTINE INCR C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: INDICATE -C PRGMMR: D. KEYSER ORG: NP22 DATE: 2004-09-09 +C PRGMMR: D. KEYSER ORG: NP22 DATE: 2016-12-20 C C ABSTRACT: COMPUTE NORMALIZED RESIDUALS FOR A SINGLE UNIQUE C STATION. @@ -1992,6 +2013,8 @@ SUBROUTINE INCR C than w/ lvl index in arrays (ensures proper error limit used at C all lvls & eliminates hgt above ground vs. hgt above sea lvl C discrepancy - error limits values remain unchanged). +C 2016-12-20 D. Stokes Increase the max allowable number of times +C per station. C C USAGE: CALL INDICATE(IS) C INPUT ARGUMENT LIST: @@ -2019,7 +2042,7 @@ SUBROUTINE INCR C$$$ SUBROUTINE INDICATE(IS) - PARAMETER (NL=150,NT=26,NS=120) ! (levels,times,stations) + PARAMETER (NL=150,NT=100,NS=120) ! (levels,times,stations) CHARACTER*8 STN REAL(8) BMISS @@ -2109,12 +2132,14 @@ SUBROUTINE INDICATE(IS) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: INIT -C PRGMMR: W. COLLINS ORG: NP22 DATE: 1996-11-20 +C PRGMMR: W. COLLINS ORG: NP22 DATE: 2016-12-20 C C ABSTRACT: INITIALIZES SEVERAL VARIABLES. C C PROGRAM HISTORY LOG: C 1996-11-20 W. Collins -- Original author. +C 2016-12-20 D. Stokes Increase the max allowable number of times +C per station. C C USAGE: CALL INIT C @@ -2126,7 +2151,7 @@ SUBROUTINE INDICATE(IS) SUBROUTINE INIT - PARAMETER (NL=150,NT=26,NS=120) ! (levels,times,stations) + PARAMETER (NL=150,NT=100,NS=120) ! (levels,times,stations) CHARACTER*8 STN REAL(8) BMISS @@ -2319,7 +2344,7 @@ SUBROUTINE ISORT(IA,INDX,N) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: MODQUAL -C PRGMMR: W. COLLINS ORG: NP22 DATE: 1995-04-05 +C PRGMMR: W. COLLINS ORG: NP22 DATE: 2016-12-20 C C ABSTRACT: CONVERTS THIS PROGRAM'S DMA INDEX FOR WIND QUALITY C CONTROL FOR SUSPECT OR BAD (1 OR 2, RESP.) TO PREPBUFR @@ -2328,6 +2353,8 @@ SUBROUTINE ISORT(IA,INDX,N) C C PROGRAM HISTORY LOG: C 1995-04-05 W. Collins -- Original author. +C 2016-12-20 D. Stokes Increase the max allowable number of times +C per station. C C USAGE: CALL MODQUAL(IS) C INPUT ARGUMENT LIST: @@ -2350,7 +2377,7 @@ SUBROUTINE ISORT(IA,INDX,N) C$$$ SUBROUTINE MODQUAL(IS) - PARAMETER (NL=150,NT=26,NS=120) ! (levels,times,stations) + PARAMETER (NL=150,NT=100,NS=120) ! (levels,times,stations) CHARACTER*8 STN @@ -2505,7 +2532,7 @@ SUBROUTINE PLINT(FIN,FUT,BMISS) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: PRNTDATA -C PRGMMR: D. KEYSER ORG: NP22 DATE: 2004-09-09 +C PRGMMR: D. KEYSER ORG: NP22 DATE: 2016-12-20 C C ABSTRACT: WRITE WIND PROFILER DATA TO VARIOUS UNITS FOR A SINGLE C UNIQUE STATION. @@ -2517,6 +2544,8 @@ SUBROUTINE PLINT(FIN,FUT,BMISS) C containing both all data lvls & only lvls w/ either suspect or C bad q. marks; output written to text files but not incl. in C stdout. +C 2016-12-20 D. Stokes Increase the max allowable number of times +C per station. C C USAGE: CALL PRNTDATA(IS) C INPUT ARGUMENT LIST: @@ -2540,7 +2569,7 @@ SUBROUTINE PLINT(FIN,FUT,BMISS) C$$$ SUBROUTINE PRNTDATA(IS) - PARAMETER (NL=150,NT=26,NS=120) ! (levels,times,stations) + PARAMETER (NL=150,NT=100,NS=120) ! (levels,times,stations) CHARACTER*8 STN CHARACTER*1 CEVN @@ -2696,7 +2725,7 @@ SUBROUTINE PRNTDATA(IS) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: PUTDATA -C PRGMMR: D. KEYSER ORG: NP22 DATE: 2004-09-09 +C PRGMMR: D. KEYSER ORG: NP22 DATE: 2016-12-20 C C ABSTRACT: PLACE DATA FOR A SINGLE REPORT INTO COMMON BLOCKS FOR C USE. THE ORIGINAL REPORTED LEVELS ARE SPLIT FROM THE AUXILIARY @@ -2711,6 +2740,9 @@ SUBROUTINE PRNTDATA(IS) C 2004-09-09 D. Keyser -- Max. no. of sites processed incr. from 40 C to 120. No. of time periods input now site specific (was C hardwired to be same for all rpts). +C 2016-12-20 Stokes/Keyser Increase the max allowable number of times +C per station. Skip reports and print warning if that limit is +C exceeded. C C USAGE: CALL PUTDATA C OUTPUT FILES: @@ -2724,9 +2756,9 @@ SUBROUTINE PRNTDATA(IS) SUBROUTINE PUTDATA - PARAMETER (NL=150,NT=26,NS=120) ! (levels,times,stations) + PARAMETER (NL=150,NT=100,NS=120) ! (levels,times,stations) - CHARACTER*8 STN,CID + CHARACTER*8 STN,CID,cNT REAL RINC(5) REAL(8) SID_8 INTEGER IDAT(8),JDAT(8) @@ -2750,6 +2782,8 @@ SUBROUTINE PUTDATA EQUIVALENCE (SID_8,CID) + data ifirst/0/ + NREP1 = NREP1 + 1 C FIND A STATION MATCH @@ -2781,7 +2815,23 @@ SUBROUTINE PUTDATA 10 CONTINUE +C PRINT WARNING IF NUMBER OF OB TIMES > LIMIT FOR A PARTICULAR STATION +C -------------------------------------------------------------------- + NTIMES(N) = NTIMES(N) + 1 + IF(NTIMES(N).GT.NT) THEN + WRITE(6,105) CID,NT,DHR + NTIMES(N) = NT +c$$$ if(ifirst.eq.0) then +c$$$ write(cNT,'(i8)') NT +c$$$ call system('[ -n "$jlogfile" ] && $DATA/postmsg'// +c$$$ $ ' "$jlogfile" "***WARNING: THE NUMBER OF OB TIMES FOR 1'// +c$$$ $ ' OR MORE IDs EXCEEDS LIMIT OF '//cNT//', SOME REPORTS '// +c$$$ $ 'NOT PROCESSED - INCR. SIZE OF NT"') +c$$$ ifirst = 1 +c$$$ endif + RETURN + ENDIF TIM(NTIMES(N),N) = DHR cdak WRITE(6,101) N,CID @@ -2842,13 +2892,15 @@ SUBROUTINE PUTDATA 100 FORMAT(/'##PUTDATA: ID ',A8,' CANNOT BE Q.C.-d BECAUSE THE ', $ 'NUMBER OF UNIQUE STATIONS EXCEEDS THE LIMIT OF',I4/) 101 FORMAT(' PUTDATA: N,CID: ',I5,2X,A8) + 105 FORMAT(/'##PUTDATA: THE NUMBER OF OB TIMES FOR ID ',A8, + $ ' EXCEEDS THE LIMIT OF ',I0,'. SKIP REPORT FOR DHR=',F7.3/) END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: READPROF -C PRGMMR: D. KEYSER ORG: NP22 DATE: 2004-09-09 +C PRGMMR: D. KEYSER ORG: NP22 DATE: 2016-12-20 C C ABSTRACT: READ PROFILER REPORTS FROM THE PREPBUFR FILE AND STORE C INTO MEMORY. @@ -2857,6 +2909,10 @@ SUBROUTINE PUTDATA C 1996-11-20 W. Collins -- Original author. C 2004-09-09 D. Keyser -- Namelist switches added to specify output C time window. +C 2016-12-20 D. Stokes Increase the max allowable number of times +C per station. +C 2020-01-09 J. Dong Changed the windowing decade from 20 to 40 +C for cases when the year is represented by 2 digits instead of 4. C C USAGE: CALL READPROF C OUTPUT FILES: @@ -2870,7 +2926,7 @@ SUBROUTINE PUTDATA SUBROUTINE READPROF - PARAMETER (NL=150,NT=26,NS=120) ! (levels,times,stations) + PARAMETER (NL=150,NT=100,NS=120) ! (levels,times,stations) LOGICAL FIRST CHARACTER*8 SUBSET,CID @@ -2917,7 +2973,9 @@ SUBROUTINE READPROF PRINT'("##2-DIGIT YEAR IN IDATEP RETURNED FROM ", $ "READMG (IDATEP IS: ",I0,") - USE WINDOWING TECHNIQUE", $ " TO OBTAIN 4-DIGIT YEAR")', IDATEP - IF(IDATEP/1000000.GT.20) THEN +C IF IDATEP=41~99 THEN IDATEP=1941~1999 +C IF IDATEP=00~40 THEN IDATEP=2000~2040 + IF(IDATEP/1000000.GT.40) THEN IDATEP = 1900000000 + IDATEP ELSE IDATEP = 2000000000 + IDATEP @@ -3055,12 +3113,14 @@ SUBROUTINE READPROF C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: RESIDUAL -C PRGMMR: W. COLLINS ORG: NP22 DATE: 1996-11-20 +C PRGMMR: W. COLLINS ORG: NP22 DATE: 2016-12-20 C C ABSTRACT: CALCULATE ALL RESIDUALS FOR A SINGLE UNIQUE STATION. C C PROGRAM HISTORY LOG: C 1996-11-20 W. Collins -- Original author. +C 2016-12-20 D. Stokes Increase the max allowable number of times +C per station. C C USAGE: CALL RESIDUAL(IS) C INPUT ARGUMENT LIST: @@ -3075,7 +3135,7 @@ SUBROUTINE READPROF SUBROUTINE RESIDUAL(IS) - PARAMETER (NL=150,NT=26,NS=120) ! (levels,times,stations) + PARAMETER (NL=150,NT=100,NS=120) ! (levels,times,stations) COMMON/PROFZ/ZZ(NL,NT,NS),UZ(NL,NT,NS),VZ(NL,NT,NS),QZ(NL,NT,NS), $ PZ(NL,NT,NS),UFZ(NL,NT,NS),VFZ(NL,NT,NS),SZ(NL,NT,NS), @@ -3108,7 +3168,7 @@ SUBROUTINE RESIDUAL(IS) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: RESTRUCT -C PRGMMR: D. KEYSER ORG: NP22 DATE: 2004-09-09 +C PRGMMR: D. KEYSER ORG: NP22 DATE: 2016-12-20 C C ABSTRACT: VERTICALLY AND TEMPORALLY RESTRUCTURE THE DATA. C @@ -3120,6 +3180,8 @@ SUBROUTINE RESIDUAL(IS) C site examined over all rpt times to generate hgt profile C containing all possible lvls, times w/ new lvls inserted get C missing wind). +C 2016-12-20 D. Stokes Increase the max allowable number of times +C per station. C C USAGE: CALL RESTRUCT C OUTPUT FILES: @@ -3133,7 +3195,7 @@ SUBROUTINE RESIDUAL(IS) SUBROUTINE RESTRUCT - PARAMETER (NL=150,NT=26,NS=120) ! (levels,times,stations) + PARAMETER (NL=150,NT=100,NS=120) ! (levels,times,stations) CHARACTER*8 STN REAL(8) BMISS @@ -3400,7 +3462,7 @@ SUBROUTINE SORT(RA,INDX,N) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: TWODIM -C PRGMMR: D. KEYSER ORG: NP22 DATE: 2004-09-09 +C PRGMMR: D. KEYSER ORG: NP22 DATE: 2016-12-20 C C ABSTRACT: COMPUTE MEDIAN RESIDUALS FOR A SINGLE UNIQUE C STATION. @@ -3411,6 +3473,8 @@ SUBROUTINE SORT(RA,INDX,N) C to allow proper temporal checking at each individual site times C w/ new lvls inserted get missing wind). No. of time periods input C now site specific (was hardwired to be same for all rpts). +C 2016-12-20 D. Stokes Increase the max allowable number of times +C per station. C C USAGE: CALL TWODIM(IS) C INPUT ARGUMENT LIST: @@ -3432,7 +3496,7 @@ SUBROUTINE SORT(RA,INDX,N) C$$$ SUBROUTINE TWODIM(IS) - PARAMETER (NL=150,NT=26,NS=120) ! (levels,times,stations) + PARAMETER (NL=150,NT=100,NS=120) ! (levels,times,stations) CHARACTER*8 STN REAL U(NL,NT),V(NL,NT),TIN(3,3),TUT(NL,NT) @@ -3535,7 +3599,7 @@ SUBROUTINE TWODIM(IS) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: PSTAT -C PRGMMR: D. KEYSER ORG: NP22 DATE: 2004-09-09 +C PRGMMR: D. KEYSER ORG: NP22 DATE: 2016-12-20 C C ABSTRACT: DRIVER SUBROUTINE TO COMPUTE AND PRINT MOMENT C STATISTICS. CALLS SUBROUTINE MSTATS TO ACTUALLY DO THE WORK @@ -3545,6 +3609,8 @@ SUBROUTINE TWODIM(IS) C 1995-04-05 W. Collins -- Original author. C 2004-09-09 D. Keyser -- Stats generated separately for NPN, CAP & C JMA rpts. +C 2016-12-20 D. Stokes Increase the max allowable number of times +C per station. C C USAGE: CALL PSTAT C @@ -3555,7 +3621,7 @@ SUBROUTINE TWODIM(IS) C$$$ SUBROUTINE PSTAT - PARAMETER (NL=150,NT=26,NS=120) ! (levels,times,stations) + PARAMETER (NL=150,NT=100,NS=120) ! (levels,times,stations) LOGICAL STATS,MEAN,STDDEV,SKEW,KURT CHARACTER*8 STN @@ -3636,7 +3702,7 @@ SUBROUTINE PSTAT C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: MSTATS -C PRGMMR: D. KEYSER ORG: NP22 DATE: 2004-09-09 +C PRGMMR: D. KEYSER ORG: NP22 DATE: 2016-12-20 C C ABSTRACT: COMPUTES THE VARIOUS MOMENT STATISTICS AND PRINTS C TO FILES. @@ -3649,6 +3715,8 @@ SUBROUTINE PSTAT C of stat types printed out controlled via new namelist switches. C Stats generated separately for NPN, CAP & JMA rpts and stratified C according to hgt above ground. +C 2016-12-20 D. Stokes Increase the max allowable number of times +C per station. C C USAGE: CALL MSTATS(FIELD,ITYPE,TITLE,NUM) C INPUT ARGUMENT LIST: @@ -3676,7 +3744,7 @@ SUBROUTINE PSTAT C$$$ SUBROUTINE MSTATS(FIELD,ITYPE,TITLE,IFLD) - PARAMETER (NL=150,NT=26,NS=120) ! (levels,times,stations) + PARAMETER (NL=150,NT=100,NS=120) ! (levels,times,stations) LOGICAL STATS,LPRNT CHARACTER*8 STATISTIC(4) From 3e92f1ec58b989cd2be7897a5f95cfbabddfcb74 Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz Date: Wed, 4 Nov 2020 17:51:31 -0500 Subject: [PATCH 019/205] Increase field length for record count so larger files can be processed --- src/Applications/NCEP_Paqc/combine_bfr/scanbuf2.f | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Applications/NCEP_Paqc/combine_bfr/scanbuf2.f b/src/Applications/NCEP_Paqc/combine_bfr/scanbuf2.f index ced18423..8e05bbe6 100644 --- a/src/Applications/NCEP_Paqc/combine_bfr/scanbuf2.f +++ b/src/Applications/NCEP_Paqc/combine_bfr/scanbuf2.f @@ -55,12 +55,12 @@ program scanbuf knt = knt + ksub call readmg(lunit,subset,idat10,iret) if (subset .ne. saved) then - if (knt .gt. 0) write(lprint,'(a8,i8)') saved,knt + if (knt .gt. 0) write(lprint,'(a8,i10)') saved,knt knt = 0 saved = subset endif enddo - if (knt .gt. 0) write(lprint,'(a8,i8)') saved,knt + if (knt .gt. 0) write(lprint,'(a8,i10)') saved,knt stop end From 62c83c6579d297e0b43fef28df0d0fc3b72eb982 Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz Date: Mon, 16 Nov 2020 18:22:40 -0500 Subject: [PATCH 020/205] Code modified to split some data reads, to allow reading of aircraft data that is using the current operational table. --- src/Applications/NCEP_Paqc/radcor/read_prepbufr.f | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/src/Applications/NCEP_Paqc/radcor/read_prepbufr.f b/src/Applications/NCEP_Paqc/radcor/read_prepbufr.f index 87d5e9a3..adac00fc 100644 --- a/src/Applications/NCEP_Paqc/radcor/read_prepbufr.f +++ b/src/Applications/NCEP_Paqc/radcor/read_prepbufr.f @@ -19,6 +19,9 @@ C OBS.) HAS BEEN ADDED TO PREPBUFR FILE FOR C "AIRCFT" AND "AIRCAR" MESSAGE TYPES, ADDED C THIS TO LISTING +C 2015-12-02 SIENKIEWICZ PATCHED TO RESOLVE PROBLEM WITH READING +C AIRCRAFT HEADER SINCE SOME MNEMONICS NOW +C STORED ON DIFFERENT BUFR NODES C C USAGE: C INPUT FILES: @@ -653,7 +656,9 @@ SUBROUTINE READPB ( lunit, msgtyp, idate, iret ) CALL UFBINT(lunit,aircar_hdr,6,1,jret, + 'PCAT POAF TRBX10 TRBX21 TRBX32 TRBX43 ') ELSE IF( msgtyp .eq. 'AIRCFT') THEN - CALL UFBINT(lunit,aircft_hdr,4,1,jret,'RCT PCAT POAF DGOT ') + CALL UFBINT(lunit,aircft_hdr,1,1,jret,'RCT ') + CALL UFBINT(lunit,aircft_hdr(2:3),2,1,jret,'PCAT POAF ') + CALL UFBINT(lunit,aircft_hdr(4),1,1,jret,'DGOT ') ELSE IF( msgtyp .eq. 'ADPUPA') THEN CALL UFBINT(lunit,adpupa_hdr,1,1,jret,'SIRC ') ELSE IF( msgtyp .eq. 'GOESND' .or. msgtyp .eq. 'SATEMP' ) THEN @@ -853,7 +858,9 @@ SUBROUTINE READPB ( lunit, msgtyp, idate, iret ) CALL UFBINT(lunit,aircar_hdr2,6,1,jret, + 'PCAT POAF TRBX10 TRBX21 TRBX32 TRBX43 ') ELSE IF( msgtp2 .eq. 'AIRCFT') THEN - CALL UFBINT(lunit,aircft_hdr2,4,1,jret,'RCT PCAT POAF DGOT ') + CALL UFBINT(lunit,aircft_hdr2,1,1,jret,'RCT ') + CALL UFBINT(lunit,aircft_hdr2(2:3),2,1,jret,'PCAT POAF ') + CALL UFBINT(lunit,aircft_hdr2(4),1,1,jret,'DGOT ') ELSE IF( msgtp2 .eq. 'ADPUPA') THEN CALL UFBINT(lunit,adpupa_hdr2,1,1,jret,'SIRC ') ELSE IF( msgtp2 .eq. 'GOESND' .or. msgtp2 .eq. 'SATEMP' ) THEN From fb21c3b8fc5381b12c965e69439c86f5274f3e7e Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz Date: Wed, 20 Jan 2021 10:44:05 -0500 Subject: [PATCH 021/205] Change code to use 10 digit date from BUFR library - avoid any problem with Y2K time windowing of 2 digit dates --- src/Applications/NCEP_Paqc/oiqc/oiqcbufr.f | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Applications/NCEP_Paqc/oiqc/oiqcbufr.f b/src/Applications/NCEP_Paqc/oiqc/oiqcbufr.f index b8da24a8..a443c8f7 100644 --- a/src/Applications/NCEP_Paqc/oiqc/oiqcbufr.f +++ b/src/Applications/NCEP_Paqc/oiqc/oiqcbufr.f @@ -4215,9 +4215,11 @@ SUBROUTINE STORE(LUDAT,LUBFI) C CHECK THE DATA DATE - PROCEED ANYWAY IF NO NMCDATE FILE TO BE FOUND C ------------------------------------------------------------------- + + call datelen(10) CALL DATEBF(LUBFI,IY,IM,ID,IH,IDATE) - READ(LUDAT,'(8X,I8)',END=1,ERR=900) JDATE + READ(LUDAT,'(6X,I10)',END=1,ERR=900) JDATE IF(IDATE.NE.JDATE) GOTO 901 1 IF(IDATE.NE.JDATE) THEN REWIND LUDAT From 9e66a8e70b072bb8e28fd80c1cf3352d67185c7e Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz Date: Fri, 22 Jan 2021 12:26:13 -0500 Subject: [PATCH 022/205] Code to apply time window to satellite winds, and to rewrite winds in newer BUFR formats into formats used in MERRA2/RPIT 5_12 to enable them to be assimilated in runs with the older DAS tags. --- src/Applications/NCEP_Paqc/modify_bufr/twindow.f | 1 + src/Applications/NCEP_Paqc/modify_bufr/twindow.rc | 1 + src/Applications/NCEP_Paqc/modify_bufr/twindow_m2.rc | 1 + 3 files changed, 3 insertions(+) create mode 100644 src/Applications/NCEP_Paqc/modify_bufr/twindow.f create mode 100644 src/Applications/NCEP_Paqc/modify_bufr/twindow.rc create mode 100644 src/Applications/NCEP_Paqc/modify_bufr/twindow_m2.rc diff --git a/src/Applications/NCEP_Paqc/modify_bufr/twindow.f b/src/Applications/NCEP_Paqc/modify_bufr/twindow.f new file mode 100644 index 00000000..a652dcf2 --- /dev/null +++ b/src/Applications/NCEP_Paqc/modify_bufr/twindow.f @@ -0,0 +1 @@ +U twindow.f diff --git a/src/Applications/NCEP_Paqc/modify_bufr/twindow.rc b/src/Applications/NCEP_Paqc/modify_bufr/twindow.rc new file mode 100644 index 00000000..b0052319 --- /dev/null +++ b/src/Applications/NCEP_Paqc/modify_bufr/twindow.rc @@ -0,0 +1 @@ +U twindow.rc diff --git a/src/Applications/NCEP_Paqc/modify_bufr/twindow_m2.rc b/src/Applications/NCEP_Paqc/modify_bufr/twindow_m2.rc new file mode 100644 index 00000000..9856fddd --- /dev/null +++ b/src/Applications/NCEP_Paqc/modify_bufr/twindow_m2.rc @@ -0,0 +1 @@ +U twindow_m2.rc From cd0dab8a99cf43f456c250f6ce96273932715af6 Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz Date: Fri, 22 Jan 2021 12:36:13 -0500 Subject: [PATCH 023/205] Modifications to handle new EUMETSAT format winds --- .../NCEP_Paqc/modify_bufr/twindow.f | 604 +++++++++++++++++- .../NCEP_Paqc/modify_bufr/twindow.rc | 62 +- .../NCEP_Paqc/modify_bufr/twindow_m2.rc | 62 +- 3 files changed, 725 insertions(+), 3 deletions(-) diff --git a/src/Applications/NCEP_Paqc/modify_bufr/twindow.f b/src/Applications/NCEP_Paqc/modify_bufr/twindow.f index a652dcf2..d4ddd40f 100644 --- a/src/Applications/NCEP_Paqc/modify_bufr/twindow.f +++ b/src/Applications/NCEP_Paqc/modify_bufr/twindow.f @@ -1 +1,603 @@ -U twindow.f + program twindow +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! NASA/GSFC, Global Modeling and Assimilation Office, Code 610.1 ! +!----------------------------------------------------------------------- +!BOP +! +! !ROUTINE: twindow: apply time window to satwind files +! +! !INTERFACE: +! +! Usage: twindow.x [-rc rcfile] input_bufr output_bufr +! +! !USES: +! + use m_inpak90 ! rc input handler + + implicit NONE +! +! link to libNCEP_w3_r4i4.a and libNCEP_bufr_r4i4.a libraries + +! !DESCRIPTION: simple routine to copy data from BUFR file to +! a second file, excluding GOES sounder satwinds +! outside of a specified time window +! +! !REVISION HISTORY: +! +! 15Jan2015 Meta Initial version +! 16Jan2015 Meta exclude AVHRR and SWIR data, replace 'if' +! with CASE to allow only specified (EU,JMA,MODIS) +! wind types to be copied +! 20May2015 Meta take out NC005066- EUMETSAT WV, for now, to +! reduce obs count for old runs +! 21May2015 Meta New version reads resource file to determine +! obs filtering. +! 22May2015 Meta deallocate table arrays at end, add I90_Release +! 13Dec2017 Meta Process GOES-R format and convert +! to format that M2 can read (use_flg = 2). +! Continue processing in if-block until subset +! read in from input file changes from prior one +! 3Jun2019 Meta Add screening by satellite ID for GOES-R+ +! (for GOES 5_12 only checks if satid==259 to +! assign subtype 15, can't screen other satIDs) +! 18Sep2019 Meta Add additional OPENMB calls after READMG - +! while 'subset' is the same, 'idate' may +! have changed so new message may be required. +! +!EOP +!----------------------------------------------------------------------- + + integer luin, luout ! unit numbers + + integer argc + integer(4) iargc + integer ireadsb + + character(len=120) inputfile + character(len=120) outputfile + character(len=120) rcfile + + character(len=8) subset ! name of BUFR subset read in + character(len=8) osubset ! prior subset name + + character(len=8),allocatable :: wsubsets(:),nsubsets(:) + integer,allocatable :: use_flg(:) + integer,allocatable :: dtmin(:) + integer,allocatable :: dtmax(:) + integer,allocatable :: ikeep(:,:) + integer,allocatable :: nkeep(:) + integer nsattype + + integer idate ! synoptic date/time YYYYMMDD + integer cdate ! center date *hopefully 1st in the file* + integer jdate(5) ! use for call to w3fs21 + integer itctr ! center date (min since 1 jan 78) + integer itmin, itmax ! window limits (min since 1 jan 78) + integer obtime ! obs time (min since 1 jan 78) + + integer iret ! subroutine return code + + integer klev, llev ! no. of levels in report + integer i, j + integer narg + integer idx + + integer rc + + integer no,ni,ne + + real(8) getbmiss, bmiss + + real(8) time(5) + character(len=80) timestr + character(len=8) unknown + + data timestr/'YEAR MNTH DAYS HOUR MINU'/ + + + data luin /8/, luout /9/ + +! Variables for GOES-16 conversion + real(8) hdrdat(13), obsdat(4) + real(8) qcdat(3,12), amvivr(2,2) + real pct1, qm + logical keep + + integer ilev, jlev, iqlev + + character(len=70) :: obstr,obstr0,hdrtr,hdrtr0 + character(len=50) :: qcstr + data hdrtr0 / 'SAID CLATH CLONH YEAR MNTH DAYS HOUR MINU SWCM SAZA OGCE SCCF SWQM' / + data hdrtr / 'SAID CLAT CLON YEAR MNTH DAYS HOUR MINU SWCM SAZA OGCE SCCF SWQM' / + data obstr0 / 'EHAM PRLC WDIR WSPD' / + data obstr / 'HAMD PRLC WDIR WSPD' / + data qcstr / 'GNAP PCCF' / + + no=0 + ni=0 + ne=0 + unknown = '' + narg = 0 + bmiss = getbmiss() + + + argc = iargc() + if (argc .lt. 2) then + call usage() + stop + endif + + rcfile = 'twindow.rc' + + call GetArg( 1_4, inputfile) + if (inputfile == '-rc') then + if (argc .lt. 4) then + call usage() + stop + end if + narg = narg + 2 + call GetArg(2_4,rcfile) + call GetArg(3_4,inputfile) + end if + call GetArg( 2_4+narg, outputfile) + + rc = 0 + call read_table(rcfile,wsubsets,use_flg,dtmin,dtmax, + & nkeep,ikeep,nsubsets,nsattype,rc) + + if (rc /= 0) then + print *,'twindow: could not read config table, exiting.' + stop + end if + + open(unit=luin,file=trim(inputfile),form='unformatted') + open(unit=luout,file=trim(outputfile),form='unformatted') + call openbf(luin,'IN ',luin) + call openbf(luout,'OUT',luin) + + call datelen(10) + call cmpmsg('Y') + +! get center date from first message in BUFR file + call readmg(luin,subset,idate,iret) + + if (iret /= 0) then + print *,'twindow, error reading ',trim(inputfile) + stop + end if + + cdate = idate + jdate(5) = 0 + jdate(1) = cdate/1000000 + jdate(2) = mod(cdate,1000000)/10000 + jdate(3) = mod(cdate,10000)/100 + jdate(4) = mod(cdate,100) + call w3fs21(jdate,itctr) + + idx = 0 + main: do while(iret .eq. 0) + + idx = find_subset(subset,wsubsets,nsattype,idx) + + if (idx == 0) then + if (subset /= unknown) then + print *,'twindow: error, ',subset, + & ' not found in subset table' + unknown = subset + end if + do while (subset == unknown .and. iret == 0) + call readmg(luin,subset,idate,iret) + end do + cycle + end if + + if (use_flg(idx) == 1) then + + itmin = dtmin(idx) + itctr + itmax = dtmax(idx) + itctr + +! case of windowed obs (NESDIS GOES hourly wind): +! get time and compare to time window, copy obs inside time window +! to output file, process all messages that match this subset + + osubset = subset + + call openmb(luout,subset,idate) + + flg1: do while ( iret .eq. 0 ) + + do while ( ireadsb(luin) .eq. 0 ) + + call ufbint(luin,time,5,1,klev,timestr) + do j = 1,5 + jdate(j) = int(time(j)) + end do + call w3fs21(jdate,obtime) + if (obtime .ge. itmin .and. obtime .le. itmax) then + ni=ni+1 + call openmb(luout,subset,idate) + call ufbcpy(luin, luout) + call writsb(luout) + else + ne=ne+1 + end if + enddo + + call readmg(luin, subset, idate, iret) + + if (iret /= 0 .or. subset /= osubset) exit flg1 + call openmb(luout,subset,idate) + + end do flg1 + + call closmg(luout) + + else if ( use_flg(idx) == 2 ) then + + itmin = dtmin(idx) + itctr + itmax = dtmax(idx) + itctr + +! case of new GOES format that needs to be rewritten for MERRA2 +! get time and compare to time window, qc obs inside time window +! and rewrite in old GOES format to output file - process all +! the messages that match this subset + +! We are lucky in that the defs for the old GOES wind formats +! are contained in the BUFR dictionary used for the new winds + + osubset = subset + + call openmb(luout,nsubsets(idx),idate) + + flg2: do while ( iret .eq. 0 ) + + readsb: do while ( ireadsb(luin) .eq. 0 ) + + call ufbint(luin,time,5,1,klev,timestr) + do j = 1,5 + jdate(j) = int(time(j)) + end do + call w3fs21(jdate,obtime) + if (obtime .ge. itmin .and. obtime .le. itmax) then + ni=ni+1 + +! Read in data from new format file + hdrdat = bmiss + obsdat = bmiss + qcdat = bmiss + qm = 2 + + call ufbint(luin,hdrdat,13,1,ilev,hdrtr0) + call ufbint(luin,obsdat,4,1,ilev,obstr0) + call ufbrep(luin,qcdat,2,12,iqlev,qcstr) + call ufbrep(luin,amvivr,2,2,ilev,'TCOV CVWD') + + if ( nkeep(idx) > 0 ) then ! screen satIDs + keep = .false. + do j = 1,nkeep(idx) + if (nint(hdrdat(1)) .eq. ikeep(j,idx)) then + keep = .true. + exit + end if + end do + + if ( .not. keep ) cycle readsb ! skip if satID not found + + end if + + +! using QM=14 so read_satwnd will skip these data + pct1 = amvivr(2,1) + if (pct1 < 0.04) qm=14 + if (pct1 > 0.50) qm=14 + + hdrdat(13) = qm + +! write out a record with data in old format, just including +! data read in by MERRA2 code + + call ufbint(luout,hdrdat,13,1,ilev,hdrtr) + call ufbint(luout,obsdat,4,1,ilev,obstr) + call ufbrep(luout,qcdat,2,iqlev,jlev,qcstr) + + call writsb(luout) + + else ! data not in time window + ne=ne+1 + end if + + end do readsb + + call readmg(luin, subset, idate, iret) + + if (iret /= 0 .or. subset /= osubset) exit flg2 + call openmb(luout,nsubsets(idx),idate) + + end do flg2 + + call closmg(luout) + + + else if ( use_flg(idx) == 0 ) then + +! case of nonwindowed (EUMETSAT, JMA, MODIS) - just copy the winds as they are +! for all of the messages matching this subset + osubset = subset + + flg0: do while ( iret .eq. 0 ) + + no = no + 1 + call copymg(luin,luout) + call readmg(luin,subset,idate,iret) + if (iret /= 0 .or. subset /= osubset) exit flg0 + + end do flg0 + + else ! other cases - just skip the messages matching this subset + + osubset = subset + + flgX: do while ( iret .eq. 0 ) + + call readmg(luin, subset, idate, iret) + if (iret /= 0 .or. subset /= osubset) exit flgX + + end do flgx + + end if + + + end do main + + call closbf(luin) + call closbf(luout) + + deallocate(wsubsets,use_flg,dtmin,dtmax,stat=iret) + + stop + + contains + +!------------------------------------------------------------------------- +! NASA/GSFC, Data Assimilation Office, Code 610.1, GEOS/DAS ! +!------------------------------------------------------------------------- +!BOP +! +! !IROUTINE: usage - print the usage instructions +! +! !INTERFACE: + + subroutine usage() +! +!EOP +!------------------------------------------------------------------------- + print *,'usage: twindow.x [-rc rcfile] inputbufr outputbufr' + stop + end subroutine usage + +!------------------------------------------------------------------------- +! NASA/GSFC, Data Assimilation Office, Code 610.1, GEOS/DAS ! +!------------------------------------------------------------------------- +!BOP +! +! !IROUTINE: read_table -- read the configuration table +! +! +! !INTERFACE: + + subroutine read_table(tablefile,wsubsets,use_flg,dtmin,dtmax, + & nkeep, ikeep, nsubsets,nsattype,rc) + +! !INPUT PARAMETERS: +! + character(len=*),intent(in) :: tablefile + +! !OUTPUT PARAMETERS: +! + character(len=8),allocatable,intent(out) :: wsubsets(:) + integer,allocatable,intent(out) :: use_flg(:) + integer,allocatable,intent(out) :: dtmin(:) + integer,allocatable,intent(out) :: dtmax(:) + integer,allocatable,intent(out) :: nkeep(:) + integer,allocatable,intent(out) :: ikeep(:,:) + character(len=8),allocatable,intent(out) :: nsubsets(:) + integer,intent(out) :: nsattype + integer,intent(out) :: rc + +! !DESCRIPTION: +! +! load resource file 'tablefile' and read configuration for satellite +! wind data processing +! +! !REVISION HISTORY: +! +! 21May2015 Meta New routine +! 22May2015 Meta add I90_Release to free memory +! 13Dec2017 Meta Changes for GOES-16 processing, add column for +! new subset name +! +! +!EOP +!------------------------------------------------------------------------- + + integer iret + integer i, ii, j + + character(len=8) str + rc = 0 + + call i90_LoadF (tablefile, iret) + + if (iret .ne. 0) then + print * ,'twindow: failed to load table file ', + & trim(tablefile), ' rc = ',iret + rc = -1 + return + end if + + call i90_label('action_table::', iret) + + if (iret .ne. 0) then + print *,'twindow: action table read failed, rc = ', iret + rc = -1 + return + end if +! +! count the number of lines in the table, then allocate space + + iret = 0 + nsattype = 0 + call i90_gline(iret) + do while (iret == 0 ) + nsattype = nsattype + 1 + call i90_gline(iret) + end do + + allocate(wsubsets(nsattype),use_flg(nsattype), + & dtmin(nsattype), dtmax(nsattype), nsubsets(nsattype), + & nkeep(nsattype), ikeep(4,nsattype), stat=iret) + + if (iret /= 0) then + print *,'twindow: unable to allocate space' + rc = -1 + return + end if + + use_flg = 0 + dtmin = 0 + dtmax = 0 + + if (iret /= 0) then + print *,'twindow: error allocating memory for arrays' + rc = -1 + return + end if + + call i90_label('action_table::', iret) + + do i = 1, nsattype + call i90_gline(iret) + if (iret /= 0) then + print *,'twindow: error reading line ',i + rc = -1 + return + end if + call i90_gtoken(str,iret) + if (iret /= 0) then + print *,'twindow: Error reading subset name, line ',i + rc = -1 + return + end if + wsubsets(i) = str + ii = i90_gint(iret) + if (iret /= 0) then + print *,'twindow: Error reading use_flag for subset ', + & wsubsets(i) + rc = -1 + return + end if + use_flg(i) = ii +! +! read time window parameters if use_flg == 1 or == 2 + if (use_flg(i) == 1 .or. use_flg(i) == 2) then + ii = i90_gint(iret) + if (iret /= 0) then + print *,'twindow: error reading time window ', + & 'for subset ', wsubsets(i) + rc = -1 + return + end if + dtmin(i) = ii + ii = i90_gint(iret) + if (iret /= 0) then + print *,'twindow: error reading time window ', + & 'for subset ', wsubsets(i) + rc = -1 + return + end if + dtmax(i) = ii + if (use_flg(i) == 2) then + call i90_gtoken(str,iret) + if (iret /= 0) then + print *,'twindow: Error reading new subset name,', + & ' line ',i + rc = -1 + return + end if + nsubsets(i) = str +! check for additional fields + iret = 0 + j = 0 + do while( iret == 0 .and. j < 4) + ii = i90_gint(iret) + if (iret /= 0) exit + j = j + 1 + ikeep(j,i) = ii + end do + nkeep(i) = j + end if + end if + + end do + + call I90_Release(iret) + + return + + end subroutine read_table + +!------------------------------------------------------------------------- +! NASA/GSFC, Data Assimilation Office, Code 610.1, GEOS/DAS ! +!------------------------------------------------------------------------- +!BOP +! +! !IROUTINE: find_subset - search for subset name in table +! +! +! !INTERFACE: + + integer function find_subset(subset,wsubsets,nsattype,idx) + +! !INPUT PARAMETERS: +! + integer nsattype + character(len=8) wsubsets(nsattype) + character(len=8) subset + integer idx + + +! !DESCRIPTION: +! +! Look for matching subset name in table. If 'idx' is set nonzero, +! check wsubsets(idx) first for a match. +! +! +! !REVISION HISTORY: +! +! 21May2015 Meta New routine +! +! +!EOP +!------------------------------------------------------------------------- + integer i + + if (idx .ne. 0) then + if (wsubsets(idx) == subset) then + find_subset = idx + return + end if + end if + + do i = 1,nsattype + if (wsubsets(i) == subset) then + find_subset = i + return + end if + end do + + find_subset = 0 + return + + end function find_subset + + end program twindow diff --git a/src/Applications/NCEP_Paqc/modify_bufr/twindow.rc b/src/Applications/NCEP_Paqc/modify_bufr/twindow.rc index b0052319..05bb104a 100644 --- a/src/Applications/NCEP_Paqc/modify_bufr/twindow.rc +++ b/src/Applications/NCEP_Paqc/modify_bufr/twindow.rc @@ -1 +1,61 @@ -U twindow.rc +# +# twindow.rc - time windowing resource file +# +# !HISTORY: +# +# 2015-05-21 Meta - Initial version with configuration from prior +# version of twindow.f +# 2015-08-10 Meta - Add NC005090 (VIIRS IR) to configuration, omitted +# to keep files as they were +# 2017-12-13 Meta - New defintions for GOES-16 data, to be rewritten in +# old GOES format +# 2017-12-21 Meta - Copy configuration for METEOSAT winds from OPS config +# +# 2019-06-04 Meta - Add column in GOES-16 specification to indicate the +# satIDs to copy to output (other satIDs will be dropped) + + +action_table:: + +# input destination GOES-R +# subset use_flg dtime_min dtime_max subset satIDs # description + +NC005010 1 -60 0 # GOES IR(245) +NC005011 1 -60 0 # GOES WV(246,247) +NC005012 1 -60 0 # GOES VIS(251) +NC005019 -1 0 0 # GOES SWIR(240) +NC005024 -1 0 0 # India INSAT IR +NC005025 -1 0 0 # India INSAT VIS +NC005026 -1 0 0 # India INSAT WV +NC005030 2 -60 0 NC005010 270 # GOES-16+ IR LW(245) +NC005031 2 -60 0 NC005011 270 # GOES-16+ WV clear sky/deep layer(247) +NC005032 2 -60 0 NC005012 270 # GOES-16+ VIS(251) +NC005034 2 -60 0 NC005011 270 # GOES-16+ WV cloud-top(246) +#C005039 -1 0 0 NC005019 270 # GOES-16+ SWIR(240) +NC005039 -1 0 0 # GOES-16+ SWIR(240) +NC005044 0 0 0 # JMA IR +NC005045 0 0 0 # JMA VIS +NC005046 0 0 0 # JMA WV +NC005064 1 -120 120 # METEOSAT IR +NC005065 1 -120 120 # METEOSAT VIS +NC005066 -1 0 0 # METEOSAT WV +NC005070 0 0 0 # MODIS IR +NC005071 0 0 0 # MODIS WV +NC005080 0 0 0 # AVHRR IR +NC005090 -1 0 0 # VIIRS IR + +:: + +# use flag: -1 omit +# 0 keep as is +# 1 apply time windowing +# 2 time windowing and rewrite GOES-R in old GOES wind format + +# GOES winds: time window from -1 hr to center time, to +# mimic what was used prior to hourly wind switchover +# +# other winds passed as is or are excluded (to avoid array overflow +# and duplication of data) +# +# for RPIT some Meteosat winds are excluded to allow extra buffer +# size for AVHRR winds diff --git a/src/Applications/NCEP_Paqc/modify_bufr/twindow_m2.rc b/src/Applications/NCEP_Paqc/modify_bufr/twindow_m2.rc index 9856fddd..8c2d3653 100644 --- a/src/Applications/NCEP_Paqc/modify_bufr/twindow_m2.rc +++ b/src/Applications/NCEP_Paqc/modify_bufr/twindow_m2.rc @@ -1 +1,61 @@ -U twindow_m2.rc +# +# twindow.rc - time windowing resource file +# +# !HISTORY: +# +# 2015-05-21 Meta - Initial version with configuration from prior +# version of twindow.f +# 2015-08-10 Meta - Add NC005090 (VIIRS IR) to configuration, omitted +# to keep files as they were +# 2017-12-13 Meta - New defintions for GOES-16 data, to be rewritten in +# old GOES format +# 2017-12-21 Meta - Copy configuration for METEOSAT winds from OPS config +# +# 2019-06-04 Meta - Add column in GOES-16 specification to indicate the +# satIDs to copy to output (other satIDs will be dropped) + + +action_table:: + +# input destination GOES-R +# subset use_flg dtime_min dtime_max subset satIDs # description + +NC005010 1 -60 0 # GOES IR(245) +NC005011 1 -60 0 # GOES WV(246,247) +NC005012 1 -60 0 # GOES VIS(251) +NC005019 -1 0 0 # GOES SWIR(240) +NC005024 -1 0 0 # India INSAT IR +NC005025 -1 0 0 # India INSAT VIS +NC005026 -1 0 0 # India INSAT WV +NC005030 2 -60 0 NC005010 270 # GOES-16+ IR LW(245) +NC005031 2 -60 0 NC005011 270 # GOES-16+ WV clear sky/deep layer(247) +NC005032 2 -60 0 NC005012 270 # GOES-16+ VIS(251) +NC005034 2 -60 0 NC005011 270 # GOES-16+ WV cloud-top(246) +#C005039 -1 0 0 NC005019 270 # GOES-16+ SWIR(240) +NC005039 -1 0 0 # GOES-16+ SWIR(240) +NC005044 0 0 0 # JMA IR +NC005045 0 0 0 # JMA VIS +NC005046 0 0 0 # JMA WV +NC005064 0 0 0 # METEOSAT IR +NC005065 0 0 0 # METEOSAT VIS +NC005066 -1 0 0 # METEOSAT WV +NC005070 0 0 0 # MODIS IR +NC005071 0 0 0 # MODIS WV +NC005080 -1 0 0 # AVHRR IR +NC005090 -1 0 0 # VIIRS IR + +:: + +# use flag: -1 omit +# 0 keep as is +# 1 apply time windowing +# 2 time windowing and rewrite GOES-R in old GOES wind format + +# GOES winds: time window from -1 hr to center time, to +# mimic what was used prior to hourly wind switchover +# +# other winds passed as is or are excluded (to avoid array overflow +# and duplication of data) +# +# for RPIT some Meteosat winds are excluded to allow extra buffer +# size for AVHRR winds From 9f9ec0da51f58c189806fe919ba3c406584274dd Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz Date: Fri, 26 Feb 2021 14:17:34 -0500 Subject: [PATCH 024/205] Copy of code and resource files with changes for new EUMETSAT wind format --- .../NCEP_Paqc/modify_bufr/twindow.f | 101 ++++++++++++++++-- .../NCEP_Paqc/modify_bufr/twindow.rc | 7 ++ .../NCEP_Paqc/modify_bufr/twindow_m2.rc | 9 ++ 3 files changed, 109 insertions(+), 8 deletions(-) diff --git a/src/Applications/NCEP_Paqc/modify_bufr/twindow.f b/src/Applications/NCEP_Paqc/modify_bufr/twindow.f index d4ddd40f..fd41a205 100644 --- a/src/Applications/NCEP_Paqc/modify_bufr/twindow.f +++ b/src/Applications/NCEP_Paqc/modify_bufr/twindow.f @@ -43,6 +43,8 @@ program twindow ! 18Sep2019 Meta Add additional OPENMB calls after READMG - ! while 'subset' is the same, 'idate' may ! have changed so new message may be required. +! 4Jan2021 Meta Add code to read new format EUMETSAT winds and +! rewrite in old format used by MERRA2 ! !EOP !----------------------------------------------------------------------- @@ -99,9 +101,10 @@ program twindow ! Variables for GOES-16 conversion real(8) hdrdat(13), obsdat(4) - real(8) qcdat(3,12), amvivr(2,2) + real(8) qcdat(2,12), amvivr(2,2) + real(8) amvqic(2,4) real pct1, qm - logical keep + logical keep, window_t integer ilev, jlev, iqlev @@ -260,6 +263,7 @@ program twindow call w3fs21(jdate,obtime) if (obtime .ge. itmin .and. obtime .le. itmax) then ni=ni+1 + call openmb(luout,nsubsets(idx),idate) ! Read in data from new format file hdrdat = bmiss @@ -299,7 +303,7 @@ program twindow call ufbint(luout,hdrdat,13,1,ilev,hdrtr) call ufbint(luout,obsdat,4,1,ilev,obstr) call ufbrep(luout,qcdat,2,iqlev,jlev,qcstr) - + call writsb(luout) else ! data not in time window @@ -312,15 +316,94 @@ program twindow if (iret /= 0 .or. subset /= osubset) exit flg2 call openmb(luout,nsubsets(idx),idate) - + end do flg2 call closmg(luout) + else if ( use_flg(idx) == 3 ) then + + if (dtmin(idx) == 0.0 .and. dtmax(idx) == 0.0) then + window_t = .false. + itmin = -180 + itmax = 180 + else + itmin = dtmin(idx) + itctr + itmax = dtmax(idx) + itctr + window_t = .true. + endif + +! case of new EUMETSAT format that needs to be rewritten for MERRA2 +! get time and compare to time window, qc obs inside time window +! and rewrite in old EUMETSAT format to output file - process all +! the messages that match this subset. Allow for case without +! time windowing. + +! We are lucky in that the defs for the old wind formats +! are contained in the BUFR dictionary used for the new winds + + osubset = subset + + call openmb(luout,nsubsets(idx),idate) + + flg3: do while ( iret .eq. 0 ) + readsbe: do while ( ireadsb(luin) .eq. 0 ) + + call ufbint(luin,time,5,1,klev,timestr) + do j = 1,5 + jdate(j) = int(time(j)) + end do + call w3fs21(jdate,obtime) + if ((obtime .ge. itmin .and. obtime .le. itmax) .or. + & .not. window_t) then + ni=ni+1 + call openmb(luout,nsubsets(idx),idate) + +! Read in data from new format file + hdrdat = bmiss + obsdat = bmiss + qcdat = bmiss + qm = 2 + + call ufbint(luin,hdrdat,13,1,ilev,hdrtr0) + call ufbint(luin,obsdat,4,1,ilev,obstr0) +! +! skipping read of 'pct1' information since it is not used in QC of EU winds (yet) +! read other quality information + call ufbseq(luin,amvqic,2,4,iret, 'AMVQIC') ! AMVQIC:: GNAPS PCCF +! qifn = amvqic(2,2) ! QI w/ fcst does not exist in this BUFR +! ee = amvqic(2,4) ! NOTE: GOES-R's ee is in [m/s] + qcdat(1,4) = 2.0 + qcdat(2,4) = amvqic(2,2) ! qifn + qcdat(1,5) = 3.0 + qcdat(2,5) = amvqic(2,4) ! "ee" + if ( amvqic(2,2) < 85.0 ) then + qm = 15 + end if + + call ufbint(luout,hdrdat,13,1,ilev,hdrtr) + call ufbint(luout,obsdat,4,1,ilev,obstr) + call ufbrep(luout,qcdat,2,12,jlev,qcstr) + + call writsb(luout) + + else ! data not in time window + ne = ne + 1 + end if + end do readsbe + call readmg(luin, subset, idate, iret) + + if (iret /= 0 .or. subset /= osubset) exit flg3 + call openmb(luout,nsubsets(idx),idate) + + end do flg3 + + call closmg(luout) +! else if ( use_flg(idx) == 0 ) then -! case of nonwindowed (EUMETSAT, JMA, MODIS) - just copy the winds as they are +! case of nonwindowed old format (EUMETSAT, JMA, MODIS) - just copy the winds as they are ! for all of the messages matching this subset osubset = subset @@ -498,8 +581,8 @@ subroutine read_table(tablefile,wsubsets,use_flg,dtmin,dtmax, end if use_flg(i) = ii ! -! read time window parameters if use_flg == 1 or == 2 - if (use_flg(i) == 1 .or. use_flg(i) == 2) then +! read time window parameters if use_flg == 1, 2, or 3 + if (use_flg(i) >= 1 .and. use_flg(i) <= 3) then ii = i90_gint(iret) if (iret /= 0) then print *,'twindow: error reading time window ', @@ -516,7 +599,9 @@ subroutine read_table(tablefile,wsubsets,use_flg,dtmin,dtmax, return end if dtmax(i) = ii - if (use_flg(i) == 2) then +! +! read subset name for converting new types to old + if (use_flg(i) == 2 .or. use_flg(i) == 3) then call i90_gtoken(str,iret) if (iret /= 0) then print *,'twindow: Error reading new subset name,', diff --git a/src/Applications/NCEP_Paqc/modify_bufr/twindow.rc b/src/Applications/NCEP_Paqc/modify_bufr/twindow.rc index 8358899b..5d414162 100644 --- a/src/Applications/NCEP_Paqc/modify_bufr/twindow.rc +++ b/src/Applications/NCEP_Paqc/modify_bufr/twindow.rc @@ -17,6 +17,9 @@ # 2020-01-02 Meta - Remove restriction on satID for GOES-16+, to allow both # GOES-16 and GOES-17 winds to be processed. Add entry # for new VIIRS IR subset +# +# 2021-01-04 Meta - Add specification for converting new format EUMETSAT +# winds (NC005067,NC005068) to old format for 5_12 action_table:: @@ -43,6 +46,9 @@ NC005046 0 0 0 # JMA WV NC005064 1 -120 120 # METEOSAT IR NC005065 1 -120 120 # METEOSAT VIS NC005066 -1 0 0 # METEOSAT WV +NC005067 3 -120 120 NC005064 # METEOSAT IR +NC005068 3 -120 120 NC005065 # METEOSAT VIS +NC005069 -1 0 0 # METEOSAT WV NC005070 0 0 0 # MODIS IR NC005071 0 0 0 # MODIS WV NC005080 0 0 0 # AVHRR IR @@ -55,6 +61,7 @@ NC005091 -1 0 0 # new VIIR # 0 keep as is # 1 apply time windowing # 2 time windowing and rewrite GOES-R in old GOES wind format +# 3 time windowing and rewrite EUMETSAT in old format # GOES winds: time window from -1 hr to center time, to # mimic what was used prior to hourly wind switchover diff --git a/src/Applications/NCEP_Paqc/modify_bufr/twindow_m2.rc b/src/Applications/NCEP_Paqc/modify_bufr/twindow_m2.rc index 58703784..47feda31 100644 --- a/src/Applications/NCEP_Paqc/modify_bufr/twindow_m2.rc +++ b/src/Applications/NCEP_Paqc/modify_bufr/twindow_m2.rc @@ -17,6 +17,9 @@ # 2020-01-02 Meta - Remove restriction on satID for GOES-16+, to allow both # GOES-16 and GOES-17 winds to be processed. Add entry # for new VIIRS IR subset +# +# 2021-01-04 Meta - Add specification for converting new format EUMETSAT +# winds (NC005067,NC005068) to old format for 5_12 action_table:: @@ -43,6 +46,10 @@ NC005046 0 0 0 # JMA WV NC005064 0 0 0 # METEOSAT IR NC005065 0 0 0 # METEOSAT VIS NC005066 -1 0 0 # METEOSAT WV +NC005067 3 0 0 NC005064 # METEOSAT IR +NC005068 3 0 0 NC005065 # METEOSAT VIS +#C005069 3 0 0 NC005066 # METEOSAT WV +NC005069 -1 0 0 # METEOSAT WV NC005070 0 0 0 # MODIS IR NC005071 0 0 0 # MODIS WV NC005080 -1 0 0 # AVHRR IR @@ -55,6 +62,8 @@ NC005091 -1 0 0 # new VIIR # 0 keep as is # 1 apply time windowing # 2 time windowing and rewrite GOES-R in old GOES wind format +# 3 time windowing and rewrite EUMETSAT in old format + # GOES winds: time window from -1 hr to center time, to # mimic what was used prior to hourly wind switchover From 6487e6d62427727017275f68b6354b6cf7e6a595 Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz Date: Tue, 2 Mar 2021 17:55:24 -0500 Subject: [PATCH 025/205] Adding new program 'scanbuf0_accum' - like 'scanbuf0' but prints the cumulative count of each subset at the end rather than counting subset chunks as they are read in. --- .../NCEP_Paqc/combine_bfr/CMakeLists.txt | 7 +- .../NCEP_Paqc/combine_bfr/scanbuf0_accum.f | 133 ++++++++++++++++++ 2 files changed, 139 insertions(+), 1 deletion(-) create mode 100644 src/Applications/NCEP_Paqc/combine_bfr/scanbuf0_accum.f diff --git a/src/Applications/NCEP_Paqc/combine_bfr/CMakeLists.txt b/src/Applications/NCEP_Paqc/combine_bfr/CMakeLists.txt index 3d53cbe3..08856570 100644 --- a/src/Applications/NCEP_Paqc/combine_bfr/CMakeLists.txt +++ b/src/Applications/NCEP_Paqc/combine_bfr/CMakeLists.txt @@ -22,6 +22,11 @@ ecbuild_add_executable ( SOURCES scanbuf0.f LIBS NCEP_bufr_r4i4 GMAO_mpeu) +ecbuild_add_executable ( + TARGET scanbuf0_accum.x + SOURCES scanbuf0_accum.f + LIBS NCEP_bufr_r4i4 GMAO_mpeu) + ecbuild_add_executable ( TARGET scanbuf2.x SOURCES scanbuf2.f @@ -35,4 +40,4 @@ ecbuild_add_executable ( ecbuild_add_executable ( TARGET cp_2ssi.x SOURCES cp_2ssi.f - LIBS NCEP_bufr_r4i4 GMAO_mpeu) \ No newline at end of file + LIBS NCEP_bufr_r4i4 GMAO_mpeu) diff --git a/src/Applications/NCEP_Paqc/combine_bfr/scanbuf0_accum.f b/src/Applications/NCEP_Paqc/combine_bfr/scanbuf0_accum.f new file mode 100644 index 00000000..106f84f1 --- /dev/null +++ b/src/Applications/NCEP_Paqc/combine_bfr/scanbuf0_accum.f @@ -0,0 +1,133 @@ + program scanbuf_accum + + implicit none + +! +! Scan NCEP BUFR files and write out how many reports of each type +! This version saves counts for each subset types and writes out a +! cumulative count of each type at the end. +! + integer,parameter :: maxsubs = 15 + + character*8 subset, saved ! subset names (current & prev.) + character*55 descr ! Table A description of subset + character*255 cfile, argv ! file name from command line + integer idat10 ! 10 digit date/time from subset + integer iret ! return code + integer lunit ! input unit number + integer lprint ! output unit number + integer argc ! used to get args from command line + integer knt ! count of records in current subset + integer kmsg, ksub + integer nmsub + + character*8 subs(maxsubs) ! names for cumulative counts + integer knts(maxsubs) ! cumulative counts per subset type + integer nsubs ! number of unique subsets types found + integer ii, i + + integer*4 iargc + + lunit = 35 ! input data file + + + + argc = iargc() + if ( argc < 1 ) then + print *, 'program needs a BUFR filename as input' + stop + endif + call GetArg ( 1_4, argv ) + cfile = argv + open( unit=lunit, file=cfile,form='unformatted') + if (argc .ge. 2) then +! second arg is output print file + call GetArg ( 2_4, argv ) + lprint = 36 + open( unit=lprint,file=argv,form='formatted') + else + lprint = 6 + endif + + subs = ' ' + knts = 0 + nsubs = 0 + + call datelen(10) + CALL OPENBF(LUNIT,'IN',LUNIT) + call readmg(lunit,subset,idat10,iret) + write(lprint,*) 'date:',idat10, iret + saved = subset + knt = 0 + do while (iret .eq. 0) + ksub = nmsub(lunit) + knt = knt + ksub + call readmg(lunit,subset,idat10,iret) + if (subset .ne. saved) then +! if (knt .gt. 0) write(lprint,'(a8,i8)') saved,knt + if (knt .gt. 0) then + if (nsubs < 1) then + nsubs = 1 + subs(nsubs) = saved + knts(nsubs) = knt + else + ii = 0 + do i = 1,nsubs + if (saved .eq. subs(i)) then + ii = i + exit + end if + end do + if (ii .ne. 0) then + knts(ii) = knts(ii) + knt + else + nsubs = nsubs + 1 + if (nsubs .gt. maxsubs) then + print *,'too many unique subsets' + print *,'recompile with larger maxsubs' + stop + end if + subs(nsubs) = saved + knts(nsubs) = knt + end if + end if + end if + + knt = 0 + saved = subset + endif + enddo +! if (knt .gt. 0) write(lprint,'(a8,i8)') saved,knt + if (knt .gt. 0) then + if (nsubs < 1) then + nsubs = 1 + subs(nsubs) = saved + knts(nsubs) = knt + else + ii = 0 + do i = 1,nsubs + if (saved .eq. subs(i)) then + ii = i + exit + end if + end do + if (ii .ne. 0) then + knts(ii) = knts(ii) + knt + else + nsubs = nsubs + 1 + if (nsubs .gt. maxsubs) then + print *,'too many unique subsets' + print *,'recompile with larger maxsubs' + stop + end if + subs(nsubs) = saved + knts(nsubs) = knt + end if + end if + end if + do i = 1,nsubs + write(lprint,'(a8,i8)') subs(i),knts(i) + end do + stop + end + From ac1e7b6c51025cb2e249754025eb507049aaef7f Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz Date: Wed, 3 Mar 2021 02:06:21 -0500 Subject: [PATCH 026/205] bring cqcvad.f to NCEP 2016 version - increses max number of stations --- .../NCEP_Paqc/prepobs_cqcvad.fd/cqcvad.f | 106 ++++++++++++------ 1 file changed, 70 insertions(+), 36 deletions(-) diff --git a/src/Applications/NCEP_Paqc/prepobs_cqcvad.fd/cqcvad.f b/src/Applications/NCEP_Paqc/prepobs_cqcvad.fd/cqcvad.f index 637f5d65..c553e822 100755 --- a/src/Applications/NCEP_Paqc/prepobs_cqcvad.fd/cqcvad.f +++ b/src/Applications/NCEP_Paqc/prepobs_cqcvad.fd/cqcvad.f @@ -1,7 +1,7 @@ C$$$ MAIN PROGRAM DOCUMENTATION BLOCK C C MAIN PROGRAM: PREPOBS_CQCVAD -C PRGMMR: MELCHIOR ORG: NP22 DATE: 2014-01-15 +C PRGMMR: MELCHIOR ORG: NP22 DATE: 2016-12-18 C C ABSTRACT: PERFORM COMPLEX QUALITY CONTROL OF VAD WINDS FROM C WSR-88D RADARS. @@ -65,6 +65,8 @@ C number of events amongst all VAD reports that can be processed) C both from 160000 to 500000 to accommodate VAD wind reports from C Level 2 decoder. +C 2016-12-18 D. Stokes Increased NSTN (maximum number of stations to +C process) from 200 to 300. Made minor correction in GETDAT. C C USAGE: C INPUT FILES: @@ -138,9 +140,9 @@ PROGRAM PREPOBS_CQCVAD NAMELIST /NAMLST/ HONOR_FLAGS, PRINT_52, PRINT_53, PRINT_60, TEST - CALL W3TAGB('PREPOBS_CQCVAD',2014,0015,0031,'NP22') + CALL W3TAGB('PREPOBS_CQCVAD',2016,0353,1200,'NP22') - PRINT *, ' ==> WELCOME TO CQCVAD, VERSION 2014-01-15 <==' + PRINT *, ' ==> WELCOME TO CQCVAD, VERSION 2016-12-18 <==' PRINT *, ' ' C Set up default values for namelist switches @@ -324,7 +326,7 @@ PROGRAM PREPOBS_CQCVAD C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: COMSTAT -C PRGMMR: S. Melchior ORG: NP22 DATE: 2014-01-15 +C PRGMMR: S. Melchior ORG: NP22 DATE: 2016-12-18 C C ABSTRACT: COMPUTE STATISTICS FOR HEIGHT-TIME INCREMENT INTERPOLATION. C @@ -339,6 +341,8 @@ PROGRAM PREPOBS_CQCVAD C 2014-01-15 S. Melchior Increased NRPT (total number of levels C amongst all VAD reports that can be processed) from 160000 to C 500000 to accommodate VAD wind reports from Level 2 decoder. +C 2016-12-18 D. Stokes Increased NSTN (maximum number of stations to +C process) from 200 to 300. C C USAGE: CALL COMSTAT C @@ -349,7 +353,7 @@ PROGRAM PREPOBS_CQCVAD C$$$ SUBROUTINE COMSTAT - PARAMETER (NL=34,NTIM=5,NTIMES=6,NRPT=500000,NSTN=200) + PARAMETER (NL=34,NTIM=5,NTIMES=6,NRPT=500000,NSTN=300) PARAMETER (NLEV=35,NINC=3) INTEGER N12(0:NL,0:NTIM) REAL U1(0:NL,0:NTIM), V1(0:NL,0:NTIM), @@ -415,7 +419,7 @@ SUBROUTINE COMSTAT C COLLECT STATISTICS BY TIME AND HEIGHT DIFFERENCES C ------------------------------------------------- - DO IS=1,NST ! nst max is nstn=200 + DO IS=1,NST ! nst max is nstn=300 DO L=1,NLEV ! nlev max is 35 DO I=1,NTIMES ! ntimes max is 6 DO IT=1,NIN(L,I,IS) ! nin(L,I,IS) max is 3 @@ -879,12 +883,14 @@ SUBROUTINE DISTR(X,MSK,XLIM,XMSG,NX,N,NDIV,DDIV,NZERO,DZERO,NS,X1, C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: DRCTSL -C PRGMMR: WOOLLEN ORG: NP22 DATE: 1990-11-06 +C PRGMMR: WOOLLEN ORG: NP22 DATE: 2016-12-18 C C ABSTRACT: DRIVER FOR CHOLESKY TYPE LINEAR EQUATION SOLVER. C C PROGRAM HISTORY LOG: C 1990-11-06 J. WOOLLEN +C 2016-12-18 D. Stokes Increased NSTN (maximum number of stations to +C process) from 200 to 300. C C USAGE: C INPUT ARGUMENTS: @@ -911,11 +917,11 @@ SUBROUTINE DISTR(X,MSK,XLIM,XMSG,NX,N,NDIV,DDIV,NZERO,DZERO,NS,X1, C$$$ SUBROUTINE DRCTSL(FAALL,RAALL,DOTPRD,NDIM,MAXDIM,NXXYY,NFT) - PARAMETER(NSTN=200) + PARAMETER(NSTN=300) DIMENSION FAALL(NSTN,45), DOTPRD(NSTN,1), RAALL(NSTN,9,1), & NDIM(NSTN) - LOGICAL BAD DIMENSION A(NSTN,45),B(NSTN,9,1),BAD(NSTN),SMOOTH(6) + LOGICAL BAD DATA SMOOTH /1.00,1.01,1.02,1.05,1.10,2.00/ C---------------------------------------------------------------------- @@ -1007,7 +1013,7 @@ SUBROUTINE DRCTSL(FAALL,RAALL,DOTPRD,NDIM,MAXDIM,NXXYY,NFT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: EVNOUT -C PRGMMR: S. Melchior ORG: NP22 DATE: 2014-01-15 +C PRGMMR: S. Melchior ORG: NP22 DATE: 2016-12-18 C C ABSTRACT: THE PRESENT REPORT IS IN /SINGLE/ AND STNID WITH INDICES C FROM NUM1 TO NUM2. FOLLOWING CODE WILL LOOK AT THE EVENTS @@ -1042,6 +1048,8 @@ SUBROUTINE DRCTSL(FAALL,RAALL,DOTPRD,NDIM,MAXDIM,NXXYY,NFT) C number of events amongst all VAD reports that can be processed) C both from 160000 to 500000 to accommodate VAD wind reports from C Level 2 decoder. +C 2016-12-18 D. Stokes Increased NSTN (maximum number of stations to +C process) from 200 to 300. C C USAGE: CALL EVNOUT(NUM1,NUM2,NLV) C INPUT ARGUMENT LIST: @@ -1056,7 +1064,7 @@ SUBROUTINE DRCTSL(FAALL,RAALL,DOTPRD,NDIM,MAXDIM,NXXYY,NFT) C$$$ SUBROUTINE EVNOUT(NUM1,NUM2,NLV) - PARAMETER (NRPT=500000,NSTN=200,NLEV=35) + PARAMETER (NRPT=500000,NSTN=300,NLEV=35) parameter (nevnt=500000) REAL(8) BMISS @@ -1278,7 +1286,7 @@ SUBROUTINE EVENTW(LUNIT,EVNSTR,NLV,UOBS,VOBS,QMS,RCS,IND,NEVN, C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: GETDAT -C PRGMMR: S. Melchior ORG: NP22 DATE: 2014-01-15 +C PRGMMR: S. Melchior ORG: NP22 DATE: 2016-12-18 C C ABSTRACT: READ PREPBUFR DATA C @@ -1300,6 +1308,10 @@ SUBROUTINE EVENTW(LUNIT,EVNSTR,NLV,UOBS,VOBS,QMS,RCS,IND,NEVN, C 2014-01-15 S. Melchior Increased NRPT (total number of levels C amongst all VAD reports that can be processed) from 160000 to C 500000 to accommodate VAD wind reports from Level 2 decoder. +C 2016-12-18 D. Stokes Increased NSTN (maximum number of stations to +C process) from 200 to 300. Also made a minor logic correction +C so that the station info for the "NSTN'th" id is stored if +C there are at least that many unique ids. C C USAGE: CALL GETDAT(ITIME) C INPUT ARGUMENT LIST: @@ -1312,7 +1324,7 @@ SUBROUTINE EVENTW(LUNIT,EVNSTR,NLV,UOBS,VOBS,QMS,RCS,IND,NEVN, C$$$ SUBROUTINE GETDAT(ITIME) - PARAMETER (NRPT=500000,NSTN=200,NLEV=35,NTIMES=6,NINC=3) + PARAMETER (NRPT=500000,NSTN=300,NLEV=35,NTIMES=6,NINC=3) PARAMETER (MLV=255) ! no. of possible levels INTEGER IDAT(8), JDAT(8), ITIMES(8,4) REAL TDIF(5,4), RINC(5) @@ -1585,11 +1597,11 @@ SUBROUTINE GETDAT(ITIME) LOOP1n1: DO IS=1,NSTN IF(SIDS(IS).EQ.STNID(I)) CYCLE LOOP1 ENDDO LOOP1n1 - NST = NST + 1 if(nst.ge.nstn) then print *, 'WARNING: NST>=NSTN, EXIT LOOP' exit LOOP1 endif + NST = NST + 1 SIDS(NST) = STNID(I) SLAT(NST) = XLA(I) SLON(NST) = XLO(I) @@ -1722,7 +1734,7 @@ SUBROUTINE HT(Z,IHT,IER) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: INCDIST -C PRGMMR: S. Melchior ORG: NP22 DATE: 2014-01-15 +C PRGMMR: S. Melchior ORG: NP22 DATE: 2016-12-18 C C ABSTRACT: COMPUTE STATISTICS AND DISTRIBUTIONS FOR INCREMENTS C @@ -1754,6 +1766,8 @@ SUBROUTINE HT(Z,IHT,IER) C explicitly setting the array size at 3600. "icntmx" is no C longer necessary but will be retained because it may prove C useful for future debugging. +C 2016-12-18 D. Stokes Increased NSTN (maximum number of stations to +C process) from 200 to 300. C C USAGE: CALL INCDIST C @@ -1767,7 +1781,7 @@ SUBROUTINE HT(Z,IHT,IER) C$$$ SUBROUTINE INCDIST - PARAMETER (NRPT=500000,NSTN=200,NLEV=35,NDIV=23,NTIMES=6,NINC=3) + PARAMETER (NRPT=500000,NSTN=300,NLEV=35,NDIV=23,NTIMES=6,NINC=3) COMMON /STN/ SLAT(NSTN), SLON(NSTN), SIDS(NSTN), STNID(NRPT), & ZSTN(NSTN) @@ -1921,7 +1935,7 @@ SUBROUTINE INCDIST C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: INCR -C PRGMMR: S. Melchior ORG: NP22 DATE: 2014-01-15 +C PRGMMR: S. Melchior ORG: NP22 DATE: 2016-12-18 C C ABSTRACT: Compute increments (observation - guess) C @@ -1935,6 +1949,8 @@ SUBROUTINE INCDIST C 2014-01-15 S. Melchior Increased NRPT (total number of levels C amongst all VAD reports that can be processed) from 160000 to C 500000 to accommodate VAD wind reports from Level 2 decoder. +C 2016-12-18 D. Stokes Increased NSTN (maximum number of stations to +C process) from 200 to 300. C C USAGE: CALL INCR C @@ -1945,7 +1961,7 @@ SUBROUTINE INCDIST C$$$ SUBROUTINE INCR - PARAMETER (NRPT=500000,NSTN=200,NLEV=35,NTIMES=6,NINC=3) + PARAMETER (NRPT=500000,NSTN=300,NLEV=35,NTIMES=6,NINC=3) REAL(8) BMISS @@ -2151,7 +2167,7 @@ SUBROUTINE indexx(n,arr,indx) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: INIT -C PRGMMR: W. COLLINS ORG: NP22 DATE: 1999-08-18 +C PRGMMR: W. COLLINS ORG: NP22 DATE: 2016-12-18 C C ABSTRACT: Initialize some quantities. C @@ -2161,6 +2177,8 @@ SUBROUTINE indexx(n,arr,indx) C TIDY UP THE CODE. RENAMED NE TO NME FOR EASE OF C NAVIGATION AND FOR CLARIFICATION AS NE IS USED FOR C INEQUALITY TESTING (.NE.). +C 2016-12-18 D. Stokes Increased NSTN (maximum number of stations to +C process) from 200 to 300. C C USAGE: CALL INIT C @@ -2171,7 +2189,7 @@ SUBROUTINE indexx(n,arr,indx) C$$$ SUBROUTINE INIT - PARAMETER(NSTN=200,NLEV=35,NTIMES=6,NINC=3) + PARAMETER(NSTN=300,NLEV=35,NTIMES=6,NINC=3) REAL(8) BMISS @@ -2202,7 +2220,7 @@ SUBROUTINE INIT C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: MATR -C PRGMMR: W. COLLINS ORG: NP22 DATE: 1999-08-18 +C PRGMMR: W. COLLINS ORG: NP22 DATE: 2016-12-18 C C ABSTRACT: SET UP THE MATRICES FOR THE HEIGHT-TIME OI ANALYSIS C THE ANALYSIS EQUATION IS AW=C @@ -2213,6 +2231,8 @@ SUBROUTINE INIT C TIDY UP THE CODE. RENAMED NE TO NME FOR EASE OF C NAVIGATION AND ALSO FOR CLARIFICATION AS NE IS USED FOR C INEQUALITY TESTING (.NE.). +C 2016-12-18 D. Stokes Increased NSTN (maximum number of stations to +C process) from 200 to 300. C C USAGE: CALL MATR(IS,IT) C INPUT ARGUMENT LIST: @@ -2226,7 +2246,7 @@ SUBROUTINE INIT C$$$ SUBROUTINE MATR(IS,IT) - PARAMETER(NSTN=200,NLEV=35,NTIMES=6,NINC=3) + PARAMETER(NSTN=300,NLEV=35,NTIMES=6,NINC=3) COMMON /MATRIC/ A(NSTN,45), C(NSTN,9), NMAT(NSTN), NM COMMON /COLECT/ LS(NSTN,NLEV,NINC), JS(NSTN,NLEV,NINC), $ NS(NSTN,NLEV,NINC), NC(NLEV,NINC), @@ -2323,7 +2343,7 @@ SUBROUTINE MATR(IS,IT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: DMA -C PRGMMR: S. Melchior ORG: NP22 DATE: 2014-01-15 +C PRGMMR: S. Melchior ORG: NP22 DATE: 2016-12-18 C C ABSTRACT: THIS IS THE DECISION MAKING ALGORITHM. IT DETERMINES C THE DATA QUALITY. @@ -2347,6 +2367,8 @@ SUBROUTINE MATR(IS,IT) C number of events amongst all VAD reports that can be processed) C both from 160000 to 500000 to accommodate VAD wind reports from C Level 2 decoder. +C 2016-12-18 D. Stokes Increased NSTN (maximum number of stations to +C process) from 200 to 300. C C USAGE: CALL DMA(HONOR_FLAGS) C INPUT ARGUMENT LIST: @@ -2359,7 +2381,7 @@ SUBROUTINE MATR(IS,IT) C$$$ SUBROUTINE DMA(HONOR_FLAGS) - PARAMETER (NRPT=500000,NSTN=200,NLEV=35,NTIMES=6,NINC=3) + PARAMETER (NRPT=500000,NSTN=300,NLEV=35,NTIMES=6,NINC=3) PARAMETER (nevnt=500000) CHARACTER*8 SIDS, STNID, SIDEV @@ -2637,7 +2659,7 @@ SUBROUTINE DMA(HONOR_FLAGS) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: RESDIST -C PRGMMR: W. COLLINS ORG: NP22 DATE: 1999-08-18 +C PRGMMR: W. COLLINS ORG: NP22 DATE: 2016-12-18 C C ABSTRACT: COMPUTE STATISTICS AND DISTRIBUTIONS OF RESIDUALS OF C CHECKS. @@ -2665,6 +2687,8 @@ SUBROUTINE DMA(HONOR_FLAGS) C explicitly setting the array size at 3600. "icntmx" is no C longer necessary but will be retained because it may prove C useful for future debugging. +C 2016-12-18 D. Stokes Increased NSTN (maximum number of stations to +C process) from 200 to 300. C C USAGE: CALL RESDIST C @@ -2678,7 +2702,7 @@ SUBROUTINE DMA(HONOR_FLAGS) C$$$ SUBROUTINE RESDIST - PARAMETER(NSTN=200,NLEV=35,NDIV=23,NTIMES=6,NINC=3) + PARAMETER(NSTN=300,NLEV=35,NDIV=23,NTIMES=6,NINC=3) COMMON /INCS/ UIN(NLEV,NTIMES,NINC,NSTN), & VIN(NLEV,NTIMES,NINC,NSTN), @@ -2771,7 +2795,7 @@ SUBROUTINE RESDIST C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: SELECT -C PRGMMR: W. COLLINS ORG: NP22 DATE: 1999-08-18 +C PRGMMR: W. COLLINS ORG: NP22 DATE: 2016-12-18 C C ABSTRACT: SELECT DATA TO BE USED IN Z-T OI ANALYSIS C @@ -2781,6 +2805,8 @@ SUBROUTINE RESDIST C TIDY UP THE CODE. RENAMED NE TO NME FOR EASE OF C NAVIGATION AND FOR CLARIFICATION SINCE NE IS USED FOR C INEQUALITY TESTING (.NE.). +C 2016-12-18 D. Stokes Increased NSTN (maximum number of stations to +C process) from 200 to 300. C C USAGE: CALL SELECT(IS,IT) C INPUT ARGUMENT LIST: @@ -2794,7 +2820,7 @@ SUBROUTINE RESDIST C$$$ SUBROUTINE SELECT(IS,IT) - PARAMETER(NSTN=200,NLEV=35,NTIMES=6,NINC=3) + PARAMETER(NSTN=300,NLEV=35,NTIMES=6,NINC=3) COMMON /INCS/ UIN(NLEV,NTIMES,NINC,NSTN), & VIN(NLEV,NTIMES,NINC,NSTN), & UUU(NLEV,NTIMES,NINC,NSTN), @@ -2873,7 +2899,7 @@ SUBROUTINE SELECT(IS,IT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: SOLVE -C PRGMMR: W. COLLINS ORG: NP22 DATE: 1999-08-18 +C PRGMMR: W. COLLINS ORG: NP22 DATE: 2016-12-18 C C ABSTRACT: SOLVE THE MATRIX PROBLEMS C A IS THE SYMMETRIC MATRIX (IN TRIANGULAR FORM) @@ -2886,6 +2912,8 @@ SUBROUTINE SELECT(IS,IT) C TIDY UP THE CODE. RENAMED NE TO NME FOR EASE OF C NAVIGATION AND FOR CLARIFICATION AS NE IS USED FOR C INEQUALITY TESTING (.NE.). +C 2016-12-18 D. Stokes Increased NSTN (maximum number of stations to +C process) from 200 to 300. C C USAGE: CALL SOLVE C @@ -2896,7 +2924,7 @@ SUBROUTINE SELECT(IS,IT) C$$$ SUBROUTINE SOLVE - PARAMETER(NSTN=200,NLEV=35,NTIMES=6,NINC=3) + PARAMETER(NSTN=300,NLEV=35,NTIMES=6,NINC=3) REAL DPR(NSTN,1) COMMON /INCS/ UIN(NLEV,NTIMES,NINC,NSTN), & VIN(NLEV,NTIMES,NINC,NSTN), @@ -2924,7 +2952,9 @@ SUBROUTINE SOLVE C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: SORTD -C PRGMMR: W. COLLINS ORG: NP22 DATE: 1999-08-18 +C PRGMMR: W. COLLINS ORG: NP22 DATE: 2016-12-18 +C 2016-12-18 D. Stokes Increased NSTN (maximum number of stations to +C process) from 200 to 300. C C ABSTRACT: SORT D, L, J, N, ALL ACCORDING TO ORDER OF D. C @@ -2952,7 +2982,7 @@ SUBROUTINE SOLVE C$$$ SUBROUTINE SORTD(D,L,J,N,NC) - PARAMETER(NSTN=200) + PARAMETER(NSTN=300) REAL D(*), W(NSTN) INTEGER L(*), J(*), N(*), INDX(NSTN), IW(NSTN) INDX = 0 @@ -2977,13 +3007,15 @@ SUBROUTINE SORTD(D,L,J,N,NC) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: VSOLVE -C PRGMMR: WOOLLEN ORG: NMC22 DATE: 1990-11-06 +C PRGMMR: WOOLLEN ORG: NMC22 DATE: 2016-12-18 C C ABSTRACT: CHOLESKY TYPE SOLUTION FOR ARRAYS OF POSITIVE DEFINITE C SYMMETRIC MATRIXES. C C PROGRAM HISTORY LOG: C 90-11-06 J. WOOLLEN +C 2016-12-18 D. Stokes Increased NSTN (maximum number of stations to +C process) from 200 to 300. C C USAGE: C INPUT ARGUMENTS: @@ -3008,7 +3040,7 @@ SUBROUTINE SORTD(D,L,J,N,NC) C$$$ SUBROUTINE VSOLVE (A,B,NDIM,BAD,NFT,NS,MAXDIM) - PARAMETER(NSTN=200) + PARAMETER(NSTN=300) DIMENSION A(NSTN,45),B(NSTN,9,1),NDIM(NSTN),BAD(NSTN),T(NSTN) LOGICAL BAD @@ -3147,7 +3179,7 @@ SUBROUTINE ZTOI C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: ZTRES -C PRGMMR: W. COLLINS ORG: NP22 DATE: 1999-08-18 +C PRGMMR: W. COLLINS ORG: NP22 DATE: 2016-12-18 C C ABSTRACT: SOLVE FOR THE HEIGHT-TIME OI ANALYSIS RESIDUALS C @@ -3157,6 +3189,8 @@ SUBROUTINE ZTOI C TIDY UP THE CODE. RENAMED NE TO NME FOR EASE OF C NAVIGATION AND FOR CLARIFICATION AS NE IS USED FOR C INEQUALITY TESTING (.NE.). +C 2016-12-18 D. Stokes Increased NSTN (maximum number of stations to +C process) from 200 to 300. C C USAGE: CALL ZTRES(IS,IT) C INPUT ARGUMENT LIST: @@ -3170,7 +3204,7 @@ SUBROUTINE ZTOI C$$$ SUBROUTINE ZTRES(IS,IT) - PARAMETER(NSTN=200,NLEV=35,NTIMES=6,NINC=3) + PARAMETER(NSTN=300,NLEV=35,NTIMES=6,NINC=3) REAL WU(NSTN), WV(NSTN) COMMON /MATRIC/ A(NSTN,45), C(NSTN,9), NMAT(NSTN), NM From a87eba4fc6d3c8647fbf55dad96e361a43056cbc Mon Sep 17 00:00:00 2001 From: saraqzhang Date: Tue, 16 Mar 2021 09:46:11 -0400 Subject: [PATCH 027/205] add option for coupling LDAS with ADAS modified: src/Applications/GEOSdas_App/GEOSdas.csm modified: src/Applications/GEOSdas_App/fvpsas modified: src/Applications/GEOSdas_App/fvsetup modified: src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atm_ens.j new file: src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmos_eldas.csh modified: src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/AGCM.rc.tmpl modified: src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/HISTAENS.rc.tmpl --- src/Applications/GEOSdas_App/GEOSdas.csm | 143 ++++++++++---- src/Applications/GEOSdas_App/fvpsas | 48 +++++ src/Applications/GEOSdas_App/fvsetup | 88 +++++++-- .../NCEP_Etc/NCEP_enkf/scripts/gmao/atm_ens.j | 20 +- .../NCEP_enkf/scripts/gmao/atmos_eldas.csh | 186 ++++++++++++++++++ .../NCEP_enkf/scripts/gmao/etc/AGCM.rc.tmpl | 5 + .../scripts/gmao/etc/HISTAENS.rc.tmpl | 41 +++- 7 files changed, 472 insertions(+), 59 deletions(-) create mode 100755 src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmos_eldas.csh diff --git a/src/Applications/GEOSdas_App/GEOSdas.csm b/src/Applications/GEOSdas_App/GEOSdas.csm index 9fc84256..c888a681 100755 --- a/src/Applications/GEOSdas_App/GEOSdas.csm +++ b/src/Applications/GEOSdas_App/GEOSdas.csm @@ -1876,6 +1876,15 @@ exit 1 /bin/cp $FVHOME/recycle/$EXPID.ana_radstat_rst.*.tar radstat endif +#sqz--merge--start + # lfo files held from last segment for ldas coupling + #--------------------------------------------------- + if( $LDAS_ANA ) then + /bin/mv $FVHOME/recycle/holdforc/*2d_lfo*nc4 $FVWORK/. + endif +#sqz---merge-end + + # GAAS restart files #------------------- if ( ! $DO4DVAR ) then @@ -3189,53 +3198,100 @@ endif # ------------------------------ Sub LandAnalysisRun_() # ------------------------------ + +#sqz--merge--start + if ( $?ECHO___ ) set echo - cd $FVWORK + if ( ! $LDAS_ANA ) exit 0 + + cd $FVWORK +# link $FVWORK for ldas met_forcing access + /bin/rm -f $FVHOME/lana/forc + /bin/ln -s $FVWORK $FVHOME/lana/forc + set rstdate = ( `rst_date ./d_rst` ) - set mydate = (`tick $rstdate -21600`) # tick back 6 hours - - set DURATION = "060000" - set SUBDIR = "ldas.$mydate[1].$mydate[2]" - set LDINPUT_FORCE = "$FVWORK" - set EXPDOMAIN = "GLOBAL" - set RESOLUTION = "144x91" - set THREEHOURS = 10800 - - ldsetup -expid $EXPID \ - -nymd $mydate[1] \ - -nhms $mydate[2] \ - -duration $DURATION \ - -fvroot $FVROOT \ - -fvhome $FVHOME \ - -fvwork $FVWORK \ - -fvwork_subdir $SUBDIR \ - -expdomain $EXPDOMAIN \ - -resolution $RESOLUTION \ - -ldinput_force $FVWORK \ - -mettag $EXPID \ - -forcedtstep $THREEHOURS \ - -rstrtdir $FVWORK \ - -rstrtid $EXPID \ - -gid $GID \ - -noprompt - - echo y | lenkf.pl - -# Move output to top FVWORK directory -# ----------------------------------- - cd $FVWORK - foreach file ( `find $SUBDIR -name $EXPID\*.txt`) - /bin/mv $file . - end - foreach file ( `find $SUBDIR -name $EXPID\.ens\*`) - /bin/mv $file . - end + set enddate = (`tick $rstdate 21600`) + +# go to LDHOME to run ldas + cd $LDHOME/run +# compare the starting time + echo "ldas_home_dir: ", $LDHOME + set lcapdat = `cat cap_restart | cut -c1-8` + set lcaptim = `cat cap_restart | cut -c10-15` + echo "ldas_6h_window starting at: ", $lcapdat, $lcaptim + echo "adas_anal_window starting at: ", $rstdate[1], $rstdate[2] + +# submit job and capture job ID + + set jobldas = "lenkf.j" + set jobIDlong = `$PBS_BIN/sbatch $jobldas` + set jobID = `echo $jobIDlong |awk -F'[ ]' '{print $4}'` + cd - + setenv ldasJobIDs $jobID + echo $ldasJobIDs ": LDAS coupling lenkf jobID in LandAnalysisRun" + cd $FVWORK # Last line of LandAnalysisRun_() \end +#sqz---merge--end +#............................................................................. + +## sqz--merge--start +#------------------------ + Sub StageLdasIncr_() +#----------------------- + if ( $?ECHO___ ) set echo + + cd $FVWORK + + set LINC_DIR=$LDHOME/output/*/cat/ens_avg/ + + # default: + set ldas_int = 10800 + set adas_int = 21600 + + set lincr_native_name = catch_progn_incr + set lincr_default_name = ldas_incr + + /bin/rm -f ${FVWORK}/${lincr_default_name}.* + + + @ cent_int = ($ldas_int / 2) + set adas_strt = ( `rst_date ./d_rst` ) + + set secs = 0 + + while ( $secs < $adas_int ) + # the begining time of the window secs=0 + set ldas_strt = ( `tick $adas_strt $secs` ) + # for ldas_incr, use centered time + set ldas_cntr = ( `tick $ldas_strt $cent_int` ) + # ldas anal time + set ldas_anlt = ( `tick $ldas_strt $ldas_int` ) + + set yyyy_a=`echo $ldas_anlt[1] | cut -c1-4` + set mm_a=`echo $ldas_anlt[1] | cut -c5-6` + set dd_a=`echo $ldas_anlt[1] | cut -c7-8` + set tttt_a=`echo $ldas_anlt[2] | cut -c1-4` + set tttt_c=`echo $ldas_cntr[2] | cut -c1-4` + +# default name for AGCM: ldas_inc.yyyymmdd_hhnn00 + /bin/cp ${LINC_DIR}/Y${yyyy_a}/M${mm_a}/*.${lincr_native_name}.$ldas_anlt[1]_${tttt_a}z.nc4\ + ${FVWORK}/ldas_inc.$ldas_cntr[1]_${tttt_c}00 + + /bin/ln -s ${LINC_DIR}/Y${yyyy_a}/M${mm_a}/*.${lincr_native_name}.$ldas_anlt[1]_${tttt_a}z.nc4\ + ${FVHOME}/lana/ldas_inc.$ldas_cntr[1]_${tttt_c}00 + + @ secs = $secs + $ldas_int + end + + # Last line of StageLdasIncr +\end + #............................................................................. +#sqz---merge--end # ------------------------------ Sub EvolveAinc0_( Viter_, Final_ ) @@ -5695,6 +5751,15 @@ endif /bin/cp $EXPID.ana_radstat_rst.$rtag.tar $RSTHOLD/ & endif +#sqz--merge--start + # hold lfo files for the next segment of ldas coupling + #---------------------------------------------------------- + if ( $LDAS_ANA ) then + mkdir -p $FVHOME/recycle/holdforc + /bin/cp *2d_lfo*nc4 $FVHOME/recycle/holdforc/. + endif +#--------- + # local copy to be moved by pesto, 2nd copy to be dealt w/ by recycle #-------------------------------------------------------------------- if ( -e biasinp.$RSTSUFFIX ) then diff --git a/src/Applications/GEOSdas_App/fvpsas b/src/Applications/GEOSdas_App/fvpsas index a6548a51..957c8eb6 100755 --- a/src/Applications/GEOSdas_App/fvpsas +++ b/src/Applications/GEOSdas_App/fvpsas @@ -112,6 +112,7 @@ # 30May2013 Todling Add GetAODinfo4Fcst_ to retrieve AOD fields for fcsts # 13Jun2020 Todling Time aerosol analysis # 19Oct2020 Todling Call to JEDI analysis +# 10Mar2021 sqzhang Add call to LandAnalysis when coupling # #----------------------------------------------------------------------------- @@ -416,6 +417,21 @@ endif +## sqz--merge---start ldas-coupling +# Run Land analysis +# ----------------- + + if ( $LDAS_ANA ) then + echo " LDAS coupling: fvpsas LDAS_ANA run lenkf " + + zeit_ci.x LandAnalysisRun + Call LandAnalysisRun_() + zeit_co.x LandAnalysisRun + endif + +##----------sqz-merge---end + + # Run the analysis if not doing replay # ----------------------------------- if ( ! -e replay.acq ) then @@ -474,6 +490,38 @@ endif endif +# sqz-merge---start for ldas-coupling +# Wait here for Land analysis if it is being fed back to GCM +# ------------------------------------------------------------- + + if ( ( $LDAS_ANA ) && ( $LDASFDBK ) ) then + echo " LDAS coupling:fvpsas job status and Increments files " + + if ($?ldasJobIDs) then + $FVROOT/bin/jobIDfilter -w $ldasJobIDs + unsetenv ldasJobIDs + endif + set lenkf_status_file = ${FVHOME}/lana/lenkf_job_completed.txt + rm -f $lenkf_status_file + cp $LDHOME/run/lenkf_job_completed.txt $lenkf_status_file + + set lenkf_status = `cat $lenkf_status_file` + echo $lenkf_status + echo $lenkf_status ": lenkf_status" + if ($lenkf_status =~ SUCCEEDED ) then + + echo "LDAS coupling fvpsas Lenkf job SUCCEEDED, stageLdasIncr" + zeit_ci.x StageLdasIncr + Call StageLdasIncr_() + zeit_co.x StageLdasIncr + else + echo "LDAS coupling fvpsas Lenkf job failed" + exit 90 + + endif + endif +#--sqz-merge--end + # Convert analysis eta file into GCM restart # ------------------------------------------ zeit_ci.x AnaToGcm diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index 62b9597e..834cd1b4 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -375,7 +375,8 @@ my $SECS_PER_DAY = $SECS_PER_HR * $HRS_PER_DAY; my ($res, $hres); my ($g5hist_rc, $g5prog_rc); -my ($gocart_tracers, $radcor, $emiss, $lsmodel_flag, $rroute_flag); +#!-sqz--merge add $ldas_flag +my ($gocart_tracers, $radcor, $emiss, $lsmodel_flag, $ldas_flag, $rroute_flag); my ($agcm_rst_flg, $sensdeg, %setupfile, @otherheaders); my ($checkFLG, $dbqueue, $runjobFLG, $saveFLG, $stopFLG); my (@fvprompt, @fvANS1, @fvANS2, $fvsetupflags); @@ -478,7 +479,7 @@ $ENV{"PATH"} = $FindBin::Bin .":$ENV{PATH}"; while3 ( \&set_rcov ); while3 ( \&set_acftbias ); while3 ( \&set_newradbc ); - while3 ( \&set_ldasANA ); + while3 ( \&set_ldasANA ); #sqz option for lana while3 ( \&get_forecast ); if ($DAO == 0) { while3 ( \&get_mhost ) } while3 ( \&get_output ); @@ -488,7 +489,7 @@ $ENV{"PATH"} = $FindBin::Bin .":$ENV{PATH}"; # Create subdirectories in FVHOME # ------------------------------- - mkdir_fvhome(); + mkdir_fvhome(); #sqz--merge addition of $fvhome/lana # Create Namelists/tables for main DAS run # ---------------------------------------- @@ -538,6 +539,22 @@ $ENV{"PATH"} = $FindBin::Bin .":$ENV{PATH}"; $rc = system("$fvbin/fix_gocart_rc.csh $vres $fvhome/run/gocart"); die "Failed to fix GOCART levels-referencing $!" if ( $rc ); +# sqz-merge ---- +# LDAS Setup is done seperately, follow instructions in GEOS ldas +#----------------------------------------------------------------- + print "\n checkprintout ldas_ana == 1 ($ldas_ana)\n"; + if ($ldas_ana == 1 ) { + print "\n please run ldas_setup in the GEOS ldas setup directory\n"; + print "\n requires prepared exp_exeinp.txt exp_batinp.txt\n" ; + print "\n example LDROOT: /discover/nobackup/$user/GEOSldas\n" ; + print "\n example LDHOME: /discover/nobackup/$user/ldascoup_C180\n" ; + print "\n example cd $LDROOT/install/bin/ \n"; + print "\n example salloc \n"; + print "\n example source g5_modules \n" ; + print "\n example ldas_setup setup $LDHOME exp_exeinp.txt exp_batinp.txt \n" ; + } +# sqz-merge end --- + # Monthly Setup # ------------------------------------------------------------- # [this must be after HISTORY.rc.tmpl and silo.arc are created] @@ -3257,25 +3274,45 @@ sub set_newradbc { } #======================================================================= sub set_ldasANA { +#sqz--merge--start # initialize Land DAS processing flag - #------------------------------------ - $ldasANA = 0; - - # query for processing flag, if LDAS executable found - #---------------------------------------------------- - if (-e "$fvbin/LDASsa_assim_seq.x") { + #------------------------------------ + my($dflt, $ans1, $ans2, $ans3, $ans4); + $ldas_ana = 0; + $ldasfdbk = 0; + $ldas_flag = 0; + $dflt = "n"; print "\n-------------\n"; print "LDAS Analysis\n"; print "-------------\n\n"; - $ans = query(" Land DAS Analysis (y/n)?", "n"); - $ldasANA = 1 if yes($ans); - } + $ans1 = query(" Land DAS Analysis (y/n)?", $dflt) ; + $ldas_ana = 1 if yes($ans1); + print " ldas_ana ($ldas_ana)\n " ; + + if ($ldas_ana == 1) { + $ans2 = query(" Enable LDAS feedback to model y/n ? ", $dflt); + $ldasfdbk = 1 if yes($ans2); + print " ldasfdbk ($ldasfdbk)\n" ; + + if ($ldasfdbk ==1 ) { + $ldas_flag = 1 + } + + $ans3 = query("LDAS HOME = /discover/nobackup/$user/$ldasexp, full path? "); + $ldashome = $ans3 ; + + $ans4 = query("LDAS HOME for atm_ens = /discover/nobackup/$user/$ldasexp4ens, full path? "); + $ldashome4ens = $ans4 ; + + } return 0; } +# sqz---merge---end + #======================================================================= sub get_setgsi { @@ -3490,6 +3527,10 @@ EOF $replace{">>>EXPID<<<"} = $expid; $replace{">>>JOBNJ<<<"} = "$jobn.j"; $replace{">>>FVHOME<<<"} = "$fvhome"; +#sqz---merge--start + $replace{">>>LDAS_ANA<<<"} = $ldas_ana; + $replace{">>>LDHOME4ens<<<"} = "$ldashome4ens"; +#---end $atm_ens_j = "$fvhome/run/atm_ens.j"; $atm_ens_j_tilde = "${atm_ens_j}~"; @@ -4188,9 +4229,10 @@ sub get_history { # verify that HISTORY.rc.tmpl has collections needed by LDAS #----------------------------------------------------------- - if ( $ldasANA ) { +#sqz---merge--start + if ( $ldas_ana == 1 ) { $verify = 0; - @ldasinputs = qw / diag_sfc bkg.eta /; + @ldasinputs = qw / tavg1_2d_lfo inst1_2d_lfo /; foreach $prod ( @ldasinputs ) { open HIST, "< $fvroot/etc/$g5hist_rc"; unless ( grep /$prod/, ) { @@ -4207,9 +4249,10 @@ sub get_history { . " 2. Select again\n\n"; $ans = query(" Choose option 1 or 2:", "2"); return 1 unless $ans eq "1"; - } + } } print " Using HISTORY template: $g5hist_rc\n"; +#sqz-merge-end # query for GCMPROG.rc.tmpl (fcst HISTORY file) #---------------------------------------------- @@ -5084,9 +5127,9 @@ sub secs2hhmmss { #========================================================================= sub mkdir_fvhome { # create directories on FVHOME - +#sqz--merge add lana print "\nSetting up FVHOME directory for $expid experiment ...\n"; - foreach $dir (qw(ana diag daotovs etc obs prog rs run recycle fcst asens anasa)) { + foreach $dir (qw(ana diag daotovs etc obs prog rs run recycle fcst lana asens anasa)) { mkpath("$fvhome/$dir") or die ">>> ERROR <<< creating directory $fvhome/$dir;"; } @@ -7528,7 +7571,12 @@ print SCRIPT <<"EOF"; setenv GAAS_ANA $gaas_ana # 1 = aerosol analysis, 0 = disables it setenv GAASFDBK $gaasfdbk # 1 = feedback aerosol analysis into GCM, 0 = don't setenv SKIP_PSAS 0 # sets do_you_want_to_skip_PSAS in ana.rc.tmpl; 0 = no, 1 = yes - setenv LDAS_ANA $ldasANA # 0 = don't run Land DAS Analysis; 1 = run LDAS +#sqz--merge--start + setenv LDAS_ANA $ldas_ana # 1 = land analysis, 0 = disables it + setenv LDASFDBK $ldasfdbk # 1 = feedback land analysis into GCM, 0 = don't + setenv LDHOME $ldashome # land analysis home dir (ldas_exp/) for central + setenv LDHOME4ens $ldashome4ens # land analysis home dir for atm_ens +#sqz---merge--end setenv IGNORE_0 1 # 1 = ignore 0 length obs files in acquire setenv ACFTBIAS $acftbias setenv USE_MODIS_STAGE 0 # 1 = use MODIS data from MODIS_STAGE_DIR; 0 = don't @@ -9313,6 +9361,8 @@ sub init_agcm_rc { $flags{"iau"} = $doiau; $flags{"pcp_forced"} = $pcp_forced; $flags{"lsmodel_flag"} = $lsmodel_flag; + #sqz--merge + $flags{"ldas_flag"} = $ldas_flag; set_AGCM_flags(%flags); # $num_readers must divide evenly into $ny @@ -9421,6 +9471,8 @@ sub init_agcm_rc { AGCM_label_subst("\@LSM_CHOICE" , $lsmodel_flag); AGCM_label_subst("\@RUN_ROUTE" , $rroute_flag); AGCM_label_subst("\@NUM_READERS" , "1"); +#sqz---merge-- + AGCM_label_subst("\@LDAS_INCR" , $ldas_flag); # Choice of LSM parameters if ( "$landbcs" eq "Icarus-NLv3" ) { diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atm_ens.j b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atm_ens.j index 11e3fa03..5151bf1d 100755 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atm_ens.j +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atm_ens.j @@ -141,6 +141,11 @@ setenv SPECRES 62 # should be able to revisit analyzer to avoid needing this setenv GAAS_ANA 1 +#sqz---merge--start + setenv LDAS_ANA >>>LDAS_ANA<<< + setenv LDHOME4ens >>>LDHOME4ens<<< +#---end + # Run-time mpi-related options # ---------------------------- @@ -150,7 +155,6 @@ setenv DAPL_RNR_TIMER 28 setenv I_MPI_MPD_TMPDIR /tmp setenv I_MPI_USE_DYNAMIC_CONNECTIONS 0 - setenv I_MPI_JOB_STARTUP_TIMEOUT 10000 setenv I_MPI_RDMA_RNDV_WRITE 1 # MVAPICH variables @@ -449,6 +453,20 @@ zeit_co.x eaod endif endif + +# sqz---merge--start +# LDAS ens analysis at ens gcm resolution +# ----------------------------------- + if ( $LDAS_ANA ) then + zeit_ci.x eldas + atmos_eldas.csh $EXPID $anymd $anhms 030000 |& tee -a atm_ens.log + if( $status) then + echo "eldas failed" + exit(1) + endif + zeit_co.x eldas + endif +#---end # Run ensemble of atmospheric analyses # ------------------------------------ diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmos_eldas.csh b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmos_eldas.csh new file mode 100755 index 00000000..2b467ba9 --- /dev/null +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmos_eldas.csh @@ -0,0 +1,186 @@ +#!/bin/csh -f + +if ( !($?ATMENS_VERBOSE) ) then + setenv ATMENS_VERBOSE 0 +else + if ( $ATMENS_VERBOSE ) set echo +endif + +setenv MYNAME atmos_eldas.csh + +if ( $#argv < 4 ) then + echo " " + echo " \\begin{verbatim} " + echo " " + echo " NAME " + echo " " + echo " $MYNAME - entry point to obtain LDAS4en increments" + echo " " + echo " SYNOPSIS " + echo " " + echo " $MYNAME expid nymd nhms freq " + echo " " + echo " where" + echo " expid - usual experiment name, e.g., b541iau" + echo " nymd - date of current anal as in YYYYMMDD" + echo " nhms - time of current anal as in HHMMSS" + echo " freq - frequency of LDAS4en analysis, as in HHMMSS" + echo " " + echo " " + echo " This procedures handles the LDAS coupling in the ensembe DAS. In its simplest form " + echo " this procedure makes the LDAS4ens ensavg analysis available to each of the members of the " + echo " ensemble." + echo " " + echo " Example of valid command line:" + echo " $MYNAME b541iau 20091019 000000 030000 " + echo " " + echo " REQUIRED ENVIRONMENT VARIABLES" + echo " " + echo " FVHOME - location of experiment " + echo " FVROOT - location of DAS build " + echo " FVWORK - location of work directory " + echo " LDHOME4ens - location of LDAS4ens experiment " + echo " \\end{verbatim} " + echo " \\clearpage " + exit(0) +endif + +##source $FVROOT/bin/g5_modules +set path = ( . $FVHOME/run $FVROOT/bin $path ) + +setenv FAILED 0 +if ( !($?FVHOME) ) setenv FAILED 1 +if ( !($?FVROOT) ) setenv FAILED 1 +if ( !($?FVWORK) ) setenv FAILED 1 +if ( !($?LDHOME4ens) ) setenv FAILED 1 + +if ( $FAILED ) then + env + echo " ${MYNAME}: not all required env vars defined" + exit 1 +endif + +set expid = $1 +set nymd = $2 +set nhms = $3 +set freq = $4 +set hh = `echo $nhms | cut -c1-2` +set yyyymmddhh = ${nymd}${hh} + +setenv ENSWORK $FVWORK +if (-e $ENSWORK/.DONE_${MYNAME}.$yyyymmddhh ) then + echo " ${MYNAME}: already done" + exit(0) +endif + + echo " ${MYNAME}: LDAS4ENS coupling: run ldas for atmens coupling" + # ens forc access: $FVHOME/ensdiag/mem*** + # go to LDHOME to run ldas + cd $LDHOME4ens/run + echo "ldas_home_dir: ", $LDHOME4ens + # submit job and capture job ID + set jobldas = "$LDHOME4ens/run/lenkf.j" + set jobIDlong = `$PBS_BIN/sbatch $jobldas` + set jobID = `echo $jobIDlong |awk -F'[ ]' '{print $4}'` + setenv ldasJobIDs $jobID + echo $ldasJobIDs ": LDAS4ens coupling lenkf jobID in LandAnalysisRun" + +## back to fvwork + cd $FVWORK + + echo " ${MYNAME}: LDAS4ENS coupling: stage/link LdasIncr for eAGCM corrector " + setenv RSTSTAGE4AENS $FVHOME/atmens/RST + + if ($?ldasJobIDs) then + $FVROOT/bin/jobIDfilter -w $ldasJobIDs + unsetenv ldasJobIDs + endif + + set lenkf_status_file = ${FVWORK}/lenkf_job_completed.txt + rm -f $lenkf_status_file + + cp $LDHOME4ens/run/lenkf_job_completed.txt $lenkf_status_file + + set lenkf_status = `cat $lenkf_status_file` + echo $lenkf_status + echo $lenkf_status ": lenkf_status" + if ($lenkf_status =~ SUCCEEDED ) then + echo "LDAS4ens coupling Lenkf job SUCCEEDED, stageLdasIncr4ens" + +# current all member incr outputs in cat/ens_avg + set LINC_DIR = ${LDHOME4ens}/output/*/cat/ens_avg/ + +#make atmens/lana/mem* + cd ${FVHOME}/atmens + mkdir enslana + @ nmem = 0 + set dirs = (`/bin/ls -d mem0*`) + foreach dir ($dirs) + set nnn = `echo $dir | cut -c4-6` + mkdir ${FVHOME}/atmens/enslana/mem${nnn} + @ nmem ++ + end #foreach dir + cd - + + set ldas_int = 10800 + set adas_int = 21600 + + set lincr_native_name = catch_progn_incr + set lincr_default_name = ldas_inc + + + @ cent_int = ($ldas_int / 2) + + /bin/cp $RSTSTAGE4AENS/$EXPID.rst.lcv.*.bin my_d_rst + set adas_strt = ( `rst_date ./my_d_rst` ) + + set secs = 0 + + while ( $secs < $adas_int ) + # the begining time of the window secs=0 + set ldas_strt = ( `tick $adas_strt $secs` ) + # for ldas_incr, use centered time + set ldas_cntr = ( `tick $ldas_strt $cent_int` ) + # ldas anal time + set ldas_anlt = ( `tick $ldas_strt $ldas_int` ) + + set yyyy_a=`echo $ldas_anlt[1] | cut -c1-4` + set mm_a=`echo $ldas_anlt[1] | cut -c5-6` + set dd_a=`echo $ldas_anlt[1] | cut -c7-8` + set tttt_a=`echo $ldas_anlt[2] | cut -c1-4` + set tttt_c=`echo $ldas_cntr[2] | cut -c1-4` +# default name for AGCM: ldas_inc.yyyymmdd_hhnn00 + @ n = 0 +while ($n < $nmem) +set lentag = `echo $n | awk '{printf "%04d", $1}'` +echo $lentag +@ n++ +set memtag = `echo $n | awk '{printf "%03d", $1}'` +echo $memtag + /bin/ln -s ${LINC_DIR}/Y${yyyy_a}/M${mm_a}/*.${lincr_native_name}${lentag}.$ldas_anlt[1]_${tttt_a}z.nc4\ + ${FVHOME}/atmens/enslana/mem$memtag/ldas_inc.$ldas_cntr[1]_${tttt_c}00 + end + +## copy to FVWORK + cd ${FVWORK} + set dirs = (`/bin/ls -d mem0*`) + foreach dir ($dirs) + set nnn = `echo $dir | cut -c4-6` + /bin/cp ${FVHOME}/atmens/enslana/mem${nnn}/ldas_inc.$ldas_cntr[1]_${tttt_c}00\ + ${FVWORK}/mem${nnn}/ldas_inc.$ldas_cntr[1]_${tttt_c}00 + end #foreach dir +#--- + @ secs = $secs + $ldas_int + end #sec while loop + + else + echo " ${MYNAME}: WARNING: ldas4ens failed, no ldasIncr for this cycle to enAGCM " + exit 1 + endif #end ldas enkf succeeded + +# normal return +touch $FVWORK/.DONE_${MYNAME}.$yyyymmddhh +echo " ${MYNAME}: Complete " + exit 0 + + diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/AGCM.rc.tmpl b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/AGCM.rc.tmpl index 18bd46d7..aa089ff4 100644 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/AGCM.rc.tmpl +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/AGCM.rc.tmpl @@ -467,6 +467,11 @@ LSM_CHOICE: @LSM_CHOICE RUN_ROUTE: 0 +# Feedback Increments from ldas :1, no feedback: 0 +# --------------------------------------------------- +LDAS_INCR: 0 + + ############################################################################################## ############################################################################################## diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/HISTAENS.rc.tmpl b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/HISTAENS.rc.tmpl index 904e9779..aea492d9 100644 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/HISTAENS.rc.tmpl +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/HISTAENS.rc.tmpl @@ -52,7 +52,9 @@ COLLECTIONS: 'bkg.eta' # Land output # 'tavg1_2d_lfo_Nx' # 'inst1_2d_lfo_Nx' -# 'tavg1_2d_lnd_Nx' +# 'tavg1_2d_lnd_Nx' +# 'tavg1_2d_lfo_Nx+-' +# 'inst1_2d_lfo_Nx+-' # Vortex track/relocator # 'vtx.mix' # Cubed trajectory (background for JEDI) @@ -626,6 +628,43 @@ COLLECTIONS: 'bkg.eta' 'SPSNOW' , 'SURFACE' , :: + tavg1_2d_lfo_Nx+-.format: 'CFIO', + tavg1_2d_lfo_Nx+-.descr: '2d,1-Hourly,Time-Averaged,Single-Level,Forecast,Land forcing' , + tavg1_2d_lfo_Nx+-.template: '%y4%m2%d2_%h2%n2z.nc4', + tavg1_2d_lfo_Nx+-.mode: 'time-averaged', + tavg1_2d_lfo_Nx+-.ref_date: >>>IOBBKGD<<< , + tavg1_2d_lfo_Nx+-.ref_time: >>>IOBBKGT<<< , + tavg1_2d_lfo_Nx+-.end_date: >>>IOEBKGD<<< , + tavg1_2d_lfo_Nx+-.end_time: >>>IOEBKGT<<< , + tavg1_2d_lfo_Nx+-.frequency: 010000, + tavg1_2d_lfo_Nx+-.duration: 010000 , + tavg1_2d_lfo_Nx+-.fields: 'SLRSF' , 'SOLAR' , 'SWGDN' , + 'SWLAND' , 'SURFACE' , + 'LWS' , 'IRRAD' , 'LWGAB' , + 'PCU' , 'SURFACE' , 'PRECCU' , + 'PLS' , 'SURFACE' , 'PRECLS' , + 'SNO' , 'SURFACE' , 'PRECSNO' , + 'DFPAR' , 'SOLAR' , 'PARDF' , + 'DRPAR' , 'SOLAR' , 'PARDR' , + :: + + inst1_2d_lfo_Nx+-.format: 'CFIO', + inst1_2d_lfo_Nx+-.descr: '2d,1-Hourly,Instantaneous,Single-Level,Forecast,land forcing' + inst1_2d_lfo_Nx+-.template: '%y4%m2%d2_%h2%n2z.nc4', + inst1_2d_lfo_Nx+-.mode: 'instantaneous' , + inst1_2d_lfo_Nx+-.ref_date: >>>IOBBKGD<<< , + inst1_2d_lfo_Nx+-.ref_time: >>>IOBBKGT<<< , + inst1_2d_lfo_Nx+-.end_date: >>>IOEBKGD<<< , + inst1_2d_lfo_Nx+-.end_time: >>>IOEBKGT<<< , + inst1_2d_lfo_Nx+-.frequency: 010000, + inst1_2d_lfo_Nx+-.duration: 010000 , + inst1_2d_lfo_Nx+-.fields: 'DZ' , 'DYN' , 'HLML' , + 'TA' , 'DYN' , 'TLML' , + 'QA' , 'DYN' , 'QLML' , + 'SPEED' , 'DYN' , 'SPEEDLML' , + 'PS' , 'DYN' , + :: + # Caution: this stream does not follow convention of output from # ensemble - file does not carry member information ... From 343e1cef69f8583bd6b721bf1ea6657ef868adcf Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz Date: Thu, 18 Mar 2021 22:43:32 -0400 Subject: [PATCH 028/205] Change to 'write' statement to avoid awkward line breaks in output --- src/Applications/GSI_App/gsidiag_bin2txt.f90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Applications/GSI_App/gsidiag_bin2txt.f90 b/src/Applications/GSI_App/gsidiag_bin2txt.f90 index e427bda5..d50682ba 100644 --- a/src/Applications/GSI_App/gsidiag_bin2txt.f90 +++ b/src/Applications/GSI_App/gsidiag_bin2txt.f90 @@ -158,7 +158,8 @@ program gsidiag_bin2txt call abort end if - write(*,*)'File ', trim(infn), ' opened on lun=',inlun +! write(*,*)'File ', trim(infn), ' opened on lun=',inlun + write(*,'(''File '', a, '' opened on lun='',i5 )') trim(infn), inlun ! open(inlun,file=infn,form='unformatted',convert='big_endian') call read_radiag_header( inlun, npred_read, sst_ret, headfix, headchan, headname, iflag, debug ) From c542d694d55df78067d859fc8094100d39bb925b Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz Date: Thu, 18 Mar 2021 23:22:17 -0400 Subject: [PATCH 029/205] Noticed that the 'gross check' was checking the wrong number in the array (Probably doesn't make any difference, since gross limits so large. Also ASCAT is likely no longer flagged.) --- src/Applications/NCEP_Paqc/modify_bufr/fix_ascat.f | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Applications/NCEP_Paqc/modify_bufr/fix_ascat.f b/src/Applications/NCEP_Paqc/modify_bufr/fix_ascat.f index b53b9ffa..d79fdcd6 100644 --- a/src/Applications/NCEP_Paqc/modify_bufr/fix_ascat.f +++ b/src/Applications/NCEP_Paqc/modify_bufr/fix_ascat.f @@ -130,8 +130,8 @@ program fix_ascat mod = .false. do j = 1,klev if ( evn(3,j) .eq. 9. ) then - if ( abs(evn(3,j)) .lt. wmax .and. - & abs(evn(4,j)) .lt. wmax ) then + if ( abs(evn(1,j)) .lt. wmax .and. + & abs(evn(2,j)) .lt. wmax ) then mod = .true. evn(3,j) = 2. evn(4,j) = 1. From a83347ddb2700d1d90bb028253bd068dc38de9a3 Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz Date: Mon, 22 Mar 2021 11:24:12 -0400 Subject: [PATCH 030/205] Program to flag (QM=14) pressure observations (thus also excluding temperature and wind observtions) for fixed buoys with 90N (wrong) latitude --- .../NCEP_Paqc/modify_bufr/flag_NPbuoy.f | 153 ++++++++++++++++++ 1 file changed, 153 insertions(+) create mode 100644 src/Applications/NCEP_Paqc/modify_bufr/flag_NPbuoy.f diff --git a/src/Applications/NCEP_Paqc/modify_bufr/flag_NPbuoy.f b/src/Applications/NCEP_Paqc/modify_bufr/flag_NPbuoy.f new file mode 100644 index 00000000..adc8fb11 --- /dev/null +++ b/src/Applications/NCEP_Paqc/modify_bufr/flag_NPbuoy.f @@ -0,0 +1,153 @@ + program flag_NP_buoy +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! NASA/GSFC, Global Modeling and Assimilation Office, Code 610.1 ! +!----------------------------------------------------------------------- +!BOP +! +! !ROUTINE: flag_NP_buoy: Flag fixed buoys with bad latitude (90N) +! +! !INTERFACE: +! +! Usage: flag_NP_buoy.x input_prepbufr output_prepbufr +! +! !USES: +! + implicit NONE +! +! link to libbfr_r4i4.a library + +! !DESCRIPTION: simple routine to modify QM to purge buoy obs +! with bad locations +! (derived from code to tweak OIQC QMs) +! +! !REVISION HISTORY: +! +! 18Mar2021 Meta Initial version +! +!EOP +!----------------------------------------------------------------------- + + integer luin, luout ! unit numbers + + integer argc + integer(4) iargc + integer ireadmg + integer ireadsb + + character*120 inputfile + character*120 outputfile + + character*8 subset ! name of current BUFR subset + character*8 psubset ! name of previous BUFR subset + + integer idate ! synoptic date/time YYYYMMDD + + integer iret ! subroutine return code + + integer klev, llev, mlev ! no. of levels in report + + character*30 evnstr,hdstr, oestr + + logical mod ! flag indicating whether to modify report + logical flag ! flag indicating whether to give report a purge mark + + integer i,j ! loop counters + integer n ! report counter + + real*8 bmiss ! missing data value + + real*8 evn(4,255) ! wind profile from bufr file + real*8 hdr(5) + real*8 oes(1,255) ! obs error array + character*8 sid + + equivalence(hdr,sid) + real wmax ! gross check parameter for wind. + + data hdstr /'SID TYP T29 XOB YOB'/ + data evnstr /'POB PQM PPC PRC '/ + + data luin /8/, luout /9/ + + bmiss = 10.e10 + wmax = 300. ! gross check + + argc = iargc() + if (argc .lt. 2) then + print *,'usage: flag_NP_buoy.x inputbufr outputbufr' + stop + endif + call GetArg( 1_4, inputfile) + call GetArg( 2_4, outputfile) + + open(unit=luin,file=trim(inputfile),form='unformatted') + open(unit=luout,file=trim(outputfile),form='unformatted') + call openbf(luin,'IN ',luin) + call openbf(luout,'OUT',luin) + + psubset = '' + n = 0 + + oes = 3.50 ! obs error = 3.5 m/s + + do while (ireadmg(luin,subset,idate).eq. 0) + + if (subset .ne. psubset ) then + if (psubset .eq. 'SFCSHP') call closmg(luout) + psubset = subset + endif + + if (subset .ne. 'SFCSHP') then +! +! For non-SFCSHP data types, copy entire message buffer to output file +! + call copymg(luin,luout) + cycle + else + + call openmb(luout,subset,idate) + + do while ( ireadsb(luin) .eq. 0 ) + +! +! For SFCSHP, copy individual reports from input message buffer to +! output message buffer +! + call ufbcpy(luin, luout) + flag = .false. + + +! if observation matches criteria, replace pressure QM with blacklist value + call ufbint(luin,hdr,5,1,klev,hdstr) + if ( (hdr(2) == 180 .or. hdr(2) == 280.) .and. + & hdr(3) == 561 .and. hdr(5) >= 90.) then + call ufbint(luin,evn,4,255,klev,evnstr) + if (klev .ne. 1) then + print *,'multilevel report klev=',klev + endif + do j = 1,klev + if ( evn(2,j) .lt. 9. ) then + evn(2,j) = 14. + evn(3,j) = 1. + evn(4,j) = 1. + endif + enddo + call ufbint(luout,evn,4,klev,llev,evnstr) + if (llev .ne. klev) print *, 'error ',klev,llev + n = n + 1 + endif +! +! write output buffer to output file +! + call writsb(luout) + enddo + endif + call closmg(luout) + + enddo + call closbf(luout) + + print *,'modified ',n,' records' + + stop + end program flag_NP_buoy From 2719c381117a8cbc82ed4c60b19198948c23e4dd Mon Sep 17 00:00:00 2001 From: saraqzhang Date: Fri, 16 Apr 2021 23:54:28 -0400 Subject: [PATCH 031/205] remove old placeholder call LANDanal modified: src/Applications/GEOSdas_App/fvpsas --- src/Applications/GEOSdas_App/fvpsas | 8 -------- 1 file changed, 8 deletions(-) diff --git a/src/Applications/GEOSdas_App/fvpsas b/src/Applications/GEOSdas_App/fvpsas index 957c8eb6..ef0873fc 100755 --- a/src/Applications/GEOSdas_App/fvpsas +++ b/src/Applications/GEOSdas_App/fvpsas @@ -559,14 +559,6 @@ Call RenameRstCheckPoint_( 1 ) zeit_co.x RenameRstCheckPoint -# Run Land analysis -# ----------------- - if ( $LDAS_ANA ) then - zeit_ci.x LandAnalysisRun - Call LandAnalysisRun_() - zeit_co.x LandAnalysisRun - endif - # Run the vortex tracker # ---------------------- zeit_ci.x VortexTrack From d9a22722e35b59043bb8f23658cca1d206c39ee5 Mon Sep 17 00:00:00 2001 From: saraqzhang Date: Thu, 29 Apr 2021 15:00:27 -0400 Subject: [PATCH 032/205] =?UTF-8?q?=20=20=20=20=20=20=20=20revised=20scrip?= =?UTF-8?q?ts=20for=20application=20of=20LADAS=20=20=20=20=20=20=20=20=20*?= =?UTF-8?q?=20Zero-diff=20vs.=20GEOSadas=C2=A0develop=20=20=20=20=20=20=20?= =?UTF-8?q?=20=20*=20Infrastructure:=20=20=20=20=20=20=20=20=20=20=20=20?= =?UTF-8?q?=20remove=20LandAnalysisRun=20in=20GEOSdas.csm=C2=A0=20=20=20?= =?UTF-8?q?=20=20=20=20=20=20=20=20=20=20add=20ldas=5Frun.csh=C2=A0to=20ru?= =?UTF-8?q?n=20GEOS=20ldas=20and=20stage=20ldas=20increments=C2=A0=20=20?= =?UTF-8?q?=20=20=20=20=20=20=20=20=20=20=20replace=20call=20to=20LandAnal?= =?UTF-8?q?ysisRun=20by=20call=20to=20ldas=5Frun.csh=20in=20fvpsas=20=20?= =?UTF-8?q?=20=20=20=20=20=20=20*=20Minor=20changes=20and=20cleanup:=20=20?= =?UTF-8?q?=20=20=20=20=20=20=20=20=C2=A0=C2=A0=20add=20ldas=20analysis=20?= =?UTF-8?q?frequency=20to=20the=20augment=20list=20in=20=20=20=20=20=20=20?= =?UTF-8?q?=20=20=20=20=20=20=20=20=20=20fvpsas;=20ldas=5Frun.csh;=20atm?= =?UTF-8?q?=5Fens.j=C2=A0and=20atmos=5Feldas.csh=20=20=20=20=20=20=20=20?= =?UTF-8?q?=20=20=20=20=20remove=20"=20sqz---merge"=C2=A0=20comments=20?= =?UTF-8?q?=C2=A0?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Applications/GEOSdas_App/GEOSdas.csm | 107 ------------------ src/Applications/GEOSdas_App/fvpsas | 57 ++++------ src/Applications/GEOSdas_App/fvsetup | 18 +-- .../NCEP_Etc/NCEP_enkf/scripts/gmao/atm_ens.j | 3 +- .../NCEP_enkf/scripts/gmao/atmos_eldas.csh | 19 ++-- 5 files changed, 38 insertions(+), 166 deletions(-) diff --git a/src/Applications/GEOSdas_App/GEOSdas.csm b/src/Applications/GEOSdas_App/GEOSdas.csm index c888a681..1fcb205f 100755 --- a/src/Applications/GEOSdas_App/GEOSdas.csm +++ b/src/Applications/GEOSdas_App/GEOSdas.csm @@ -1876,14 +1876,6 @@ exit 1 /bin/cp $FVHOME/recycle/$EXPID.ana_radstat_rst.*.tar radstat endif -#sqz--merge--start - # lfo files held from last segment for ldas coupling - #--------------------------------------------------- - if( $LDAS_ANA ) then - /bin/mv $FVHOME/recycle/holdforc/*2d_lfo*nc4 $FVWORK/. - endif -#sqz---merge-end - # GAAS restart files #------------------- @@ -3195,103 +3187,6 @@ endif #............................................................................. -# ------------------------------ - Sub LandAnalysisRun_() -# ------------------------------ - -#sqz--merge--start - - if ( $?ECHO___ ) set echo - - if ( ! $LDAS_ANA ) exit 0 - - cd $FVWORK -# link $FVWORK for ldas met_forcing access - /bin/rm -f $FVHOME/lana/forc - /bin/ln -s $FVWORK $FVHOME/lana/forc - - set rstdate = ( `rst_date ./d_rst` ) - set enddate = (`tick $rstdate 21600`) - -# go to LDHOME to run ldas - cd $LDHOME/run -# compare the starting time - echo "ldas_home_dir: ", $LDHOME - set lcapdat = `cat cap_restart | cut -c1-8` - set lcaptim = `cat cap_restart | cut -c10-15` - echo "ldas_6h_window starting at: ", $lcapdat, $lcaptim - echo "adas_anal_window starting at: ", $rstdate[1], $rstdate[2] - -# submit job and capture job ID - - set jobldas = "lenkf.j" - set jobIDlong = `$PBS_BIN/sbatch $jobldas` - set jobID = `echo $jobIDlong |awk -F'[ ]' '{print $4}'` - cd - - setenv ldasJobIDs $jobID - echo $ldasJobIDs ": LDAS coupling lenkf jobID in LandAnalysisRun" - cd $FVWORK - - # Last line of LandAnalysisRun_() -\end - -#sqz---merge--end -#............................................................................. - -## sqz--merge--start -#------------------------ - Sub StageLdasIncr_() -#----------------------- - if ( $?ECHO___ ) set echo - - cd $FVWORK - - set LINC_DIR=$LDHOME/output/*/cat/ens_avg/ - - # default: - set ldas_int = 10800 - set adas_int = 21600 - - set lincr_native_name = catch_progn_incr - set lincr_default_name = ldas_incr - - /bin/rm -f ${FVWORK}/${lincr_default_name}.* - - - @ cent_int = ($ldas_int / 2) - set adas_strt = ( `rst_date ./d_rst` ) - - set secs = 0 - - while ( $secs < $adas_int ) - # the begining time of the window secs=0 - set ldas_strt = ( `tick $adas_strt $secs` ) - # for ldas_incr, use centered time - set ldas_cntr = ( `tick $ldas_strt $cent_int` ) - # ldas anal time - set ldas_anlt = ( `tick $ldas_strt $ldas_int` ) - - set yyyy_a=`echo $ldas_anlt[1] | cut -c1-4` - set mm_a=`echo $ldas_anlt[1] | cut -c5-6` - set dd_a=`echo $ldas_anlt[1] | cut -c7-8` - set tttt_a=`echo $ldas_anlt[2] | cut -c1-4` - set tttt_c=`echo $ldas_cntr[2] | cut -c1-4` - -# default name for AGCM: ldas_inc.yyyymmdd_hhnn00 - /bin/cp ${LINC_DIR}/Y${yyyy_a}/M${mm_a}/*.${lincr_native_name}.$ldas_anlt[1]_${tttt_a}z.nc4\ - ${FVWORK}/ldas_inc.$ldas_cntr[1]_${tttt_c}00 - - /bin/ln -s ${LINC_DIR}/Y${yyyy_a}/M${mm_a}/*.${lincr_native_name}.$ldas_anlt[1]_${tttt_a}z.nc4\ - ${FVHOME}/lana/ldas_inc.$ldas_cntr[1]_${tttt_c}00 - - @ secs = $secs + $ldas_int - end - - # Last line of StageLdasIncr -\end - -#............................................................................. -#sqz---merge--end # ------------------------------ Sub EvolveAinc0_( Viter_, Final_ ) @@ -5751,14 +5646,12 @@ endif /bin/cp $EXPID.ana_radstat_rst.$rtag.tar $RSTHOLD/ & endif -#sqz--merge--start # hold lfo files for the next segment of ldas coupling #---------------------------------------------------------- if ( $LDAS_ANA ) then mkdir -p $FVHOME/recycle/holdforc /bin/cp *2d_lfo*nc4 $FVHOME/recycle/holdforc/. endif -#--------- # local copy to be moved by pesto, 2nd copy to be dealt w/ by recycle #-------------------------------------------------------------------- diff --git a/src/Applications/GEOSdas_App/fvpsas b/src/Applications/GEOSdas_App/fvpsas index ef0873fc..3b91ccf6 100755 --- a/src/Applications/GEOSdas_App/fvpsas +++ b/src/Applications/GEOSdas_App/fvpsas @@ -417,19 +417,22 @@ endif -## sqz--merge---start ldas-coupling +#-------------------------------------- # Run Land analysis # ----------------- if ( $LDAS_ANA ) then echo " LDAS coupling: fvpsas LDAS_ANA run lenkf " - - zeit_ci.x LandAnalysisRun - Call LandAnalysisRun_() - zeit_co.x LandAnalysisRun + zeit_ci.x ldasRun + ldas_run.csh 0 030000 060000 |& tee -a ldasrun.log + if( $status) then + echo "ldasRun failed" + exit(1) + endif + zeit_co.x ldasRun endif -##----------sqz-merge---end +##--------------------------------- # Run the analysis if not doing replay @@ -490,37 +493,21 @@ endif endif -# sqz-merge---start for ldas-coupling -# Wait here for Land analysis if it is being fed back to GCM -# ------------------------------------------------------------- - +#------------------------------------------------ +# check ldas job status and stage ldas increments +#-------------------------------------------------- if ( ( $LDAS_ANA ) && ( $LDASFDBK ) ) then - echo " LDAS coupling:fvpsas job status and Increments files " - - if ($?ldasJobIDs) then - $FVROOT/bin/jobIDfilter -w $ldasJobIDs - unsetenv ldasJobIDs - endif - set lenkf_status_file = ${FVHOME}/lana/lenkf_job_completed.txt - rm -f $lenkf_status_file - cp $LDHOME/run/lenkf_job_completed.txt $lenkf_status_file - - set lenkf_status = `cat $lenkf_status_file` - echo $lenkf_status - echo $lenkf_status ": lenkf_status" - if ($lenkf_status =~ SUCCEEDED ) then - - echo "LDAS coupling fvpsas Lenkf job SUCCEEDED, stageLdasIncr" - zeit_ci.x StageLdasIncr - Call StageLdasIncr_() - zeit_co.x StageLdasIncr - else - echo "LDAS coupling fvpsas Lenkf job failed" - exit 90 + echo " LDAS coupling: stage 1" + zeit_ci.x ldasStage + ldas_run.csh 1 030000 060000 |& tee -a ldasrun.log + if( $status) then + echo "ldas_run stage 1 failed" + exit(1) + endif + zeit_co.x ldasStage + endif - endif - endif -#--sqz-merge--end +#----------------------- # Convert analysis eta file into GCM restart # ------------------------------------------ diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index 834cd1b4..ad002893 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -375,7 +375,6 @@ my $SECS_PER_DAY = $SECS_PER_HR * $HRS_PER_DAY; my ($res, $hres); my ($g5hist_rc, $g5prog_rc); -#!-sqz--merge add $ldas_flag my ($gocart_tracers, $radcor, $emiss, $lsmodel_flag, $ldas_flag, $rroute_flag); my ($agcm_rst_flg, $sensdeg, %setupfile, @otherheaders); my ($checkFLG, $dbqueue, $runjobFLG, $saveFLG, $stopFLG); @@ -479,7 +478,7 @@ $ENV{"PATH"} = $FindBin::Bin .":$ENV{PATH}"; while3 ( \&set_rcov ); while3 ( \&set_acftbias ); while3 ( \&set_newradbc ); - while3 ( \&set_ldasANA ); #sqz option for lana + while3 ( \&set_ldasANA ); while3 ( \&get_forecast ); if ($DAO == 0) { while3 ( \&get_mhost ) } while3 ( \&get_output ); @@ -489,7 +488,7 @@ $ENV{"PATH"} = $FindBin::Bin .":$ENV{PATH}"; # Create subdirectories in FVHOME # ------------------------------- - mkdir_fvhome(); #sqz--merge addition of $fvhome/lana + mkdir_fvhome(); # Create Namelists/tables for main DAS run # ---------------------------------------- @@ -539,7 +538,6 @@ $ENV{"PATH"} = $FindBin::Bin .":$ENV{PATH}"; $rc = system("$fvbin/fix_gocart_rc.csh $vres $fvhome/run/gocart"); die "Failed to fix GOCART levels-referencing $!" if ( $rc ); -# sqz-merge ---- # LDAS Setup is done seperately, follow instructions in GEOS ldas #----------------------------------------------------------------- print "\n checkprintout ldas_ana == 1 ($ldas_ana)\n"; @@ -553,7 +551,6 @@ $ENV{"PATH"} = $FindBin::Bin .":$ENV{PATH}"; print "\n example source g5_modules \n" ; print "\n example ldas_setup setup $LDHOME exp_exeinp.txt exp_batinp.txt \n" ; } -# sqz-merge end --- # Monthly Setup # ------------------------------------------------------------- @@ -3274,7 +3271,6 @@ sub set_newradbc { } #======================================================================= sub set_ldasANA { -#sqz--merge--start # initialize Land DAS processing flag #------------------------------------ @@ -3311,7 +3307,6 @@ sub set_ldasANA { return 0; } -# sqz---merge---end #======================================================================= sub get_setgsi { @@ -3527,10 +3522,8 @@ EOF $replace{">>>EXPID<<<"} = $expid; $replace{">>>JOBNJ<<<"} = "$jobn.j"; $replace{">>>FVHOME<<<"} = "$fvhome"; -#sqz---merge--start $replace{">>>LDAS_ANA<<<"} = $ldas_ana; $replace{">>>LDHOME4ens<<<"} = "$ldashome4ens"; -#---end $atm_ens_j = "$fvhome/run/atm_ens.j"; $atm_ens_j_tilde = "${atm_ens_j}~"; @@ -4229,7 +4222,6 @@ sub get_history { # verify that HISTORY.rc.tmpl has collections needed by LDAS #----------------------------------------------------------- -#sqz---merge--start if ( $ldas_ana == 1 ) { $verify = 0; @ldasinputs = qw / tavg1_2d_lfo inst1_2d_lfo /; @@ -4252,7 +4244,6 @@ sub get_history { } } print " Using HISTORY template: $g5hist_rc\n"; -#sqz-merge-end # query for GCMPROG.rc.tmpl (fcst HISTORY file) #---------------------------------------------- @@ -5127,7 +5118,6 @@ sub secs2hhmmss { #========================================================================= sub mkdir_fvhome { # create directories on FVHOME -#sqz--merge add lana print "\nSetting up FVHOME directory for $expid experiment ...\n"; foreach $dir (qw(ana diag daotovs etc obs prog rs run recycle fcst lana asens anasa)) { mkpath("$fvhome/$dir") @@ -7571,12 +7561,10 @@ print SCRIPT <<"EOF"; setenv GAAS_ANA $gaas_ana # 1 = aerosol analysis, 0 = disables it setenv GAASFDBK $gaasfdbk # 1 = feedback aerosol analysis into GCM, 0 = don't setenv SKIP_PSAS 0 # sets do_you_want_to_skip_PSAS in ana.rc.tmpl; 0 = no, 1 = yes -#sqz--merge--start setenv LDAS_ANA $ldas_ana # 1 = land analysis, 0 = disables it setenv LDASFDBK $ldasfdbk # 1 = feedback land analysis into GCM, 0 = don't setenv LDHOME $ldashome # land analysis home dir (ldas_exp/) for central setenv LDHOME4ens $ldashome4ens # land analysis home dir for atm_ens -#sqz---merge--end setenv IGNORE_0 1 # 1 = ignore 0 length obs files in acquire setenv ACFTBIAS $acftbias setenv USE_MODIS_STAGE 0 # 1 = use MODIS data from MODIS_STAGE_DIR; 0 = don't @@ -9361,7 +9349,6 @@ sub init_agcm_rc { $flags{"iau"} = $doiau; $flags{"pcp_forced"} = $pcp_forced; $flags{"lsmodel_flag"} = $lsmodel_flag; - #sqz--merge $flags{"ldas_flag"} = $ldas_flag; set_AGCM_flags(%flags); @@ -9471,7 +9458,6 @@ sub init_agcm_rc { AGCM_label_subst("\@LSM_CHOICE" , $lsmodel_flag); AGCM_label_subst("\@RUN_ROUTE" , $rroute_flag); AGCM_label_subst("\@NUM_READERS" , "1"); -#sqz---merge-- AGCM_label_subst("\@LDAS_INCR" , $ldas_flag); # Choice of LSM parameters diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atm_ens.j b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atm_ens.j index 5151bf1d..46763b7f 100755 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atm_ens.j +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atm_ens.j @@ -155,6 +155,7 @@ setenv DAPL_RNR_TIMER 28 setenv I_MPI_MPD_TMPDIR /tmp setenv I_MPI_USE_DYNAMIC_CONNECTIONS 0 + setenv I_MPI_JOB_STARTUP_TIMEOUT 10000 setenv I_MPI_RDMA_RNDV_WRITE 1 # MVAPICH variables @@ -459,7 +460,7 @@ # ----------------------------------- if ( $LDAS_ANA ) then zeit_ci.x eldas - atmos_eldas.csh $EXPID $anymd $anhms 030000 |& tee -a atm_ens.log + atmos_eldas.csh $EXPID $anymd $anhms 030000 060000 |& tee -a atm_ens.log if( $status) then echo "eldas failed" exit(1) diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmos_eldas.csh b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmos_eldas.csh index 2b467ba9..c58ff53b 100755 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmos_eldas.csh +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmos_eldas.csh @@ -8,7 +8,7 @@ endif setenv MYNAME atmos_eldas.csh -if ( $#argv < 4 ) then +if ( $#argv < 5 ) then echo " " echo " \\begin{verbatim} " echo " " @@ -18,13 +18,14 @@ if ( $#argv < 4 ) then echo " " echo " SYNOPSIS " echo " " - echo " $MYNAME expid nymd nhms freq " + echo " $MYNAME expid nymd nhms freql freqa " echo " " echo " where" echo " expid - usual experiment name, e.g., b541iau" echo " nymd - date of current anal as in YYYYMMDD" echo " nhms - time of current anal as in HHMMSS" - echo " freq - frequency of LDAS4en analysis, as in HHMMSS" + echo " freql - frequency of LDAS4en analysis, as in HHMMSS" + echo " freqa - frequency of ADASen analysis, as in HHMMSS" echo " " echo " " echo " This procedures handles the LDAS coupling in the ensembe DAS. In its simplest form " @@ -32,7 +33,7 @@ if ( $#argv < 4 ) then echo " ensemble." echo " " echo " Example of valid command line:" - echo " $MYNAME b541iau 20091019 000000 030000 " + echo " $MYNAME b541iau 20091019 000000 030000 060000" echo " " echo " REQUIRED ENVIRONMENT VARIABLES" echo " " @@ -63,7 +64,9 @@ endif set expid = $1 set nymd = $2 set nhms = $3 -set freq = $4 +set freql = $4 +set freqa = $5 + set hh = `echo $nhms | cut -c1-2` set yyyymmddhh = ${nymd}${hh} @@ -122,8 +125,10 @@ endif end #foreach dir cd - - set ldas_int = 10800 - set adas_int = 21600 + @ ldas_int = $freql / 10000 + @ ldas_int = $ldas_int * 3600 + @ adas_int = $freqa / 10000 + @ adas_int = $adas_int * 3600 set lincr_native_name = catch_progn_incr set lincr_default_name = ldas_inc From 13ffad823ba8ced8298649075c642b9afc9ae207 Mon Sep 17 00:00:00 2001 From: saraqzhang Date: Thu, 29 Apr 2021 15:19:18 -0400 Subject: [PATCH 033/205] add ldas_run.csh for application of LADAS new file: src/Applications/GEOSdas_App/ldas_run.csh --- src/Applications/GEOSdas_App/ldas_run.csh | 211 ++++++++++++++++++++++ 1 file changed, 211 insertions(+) create mode 100755 src/Applications/GEOSdas_App/ldas_run.csh diff --git a/src/Applications/GEOSdas_App/ldas_run.csh b/src/Applications/GEOSdas_App/ldas_run.csh new file mode 100755 index 00000000..7d883082 --- /dev/null +++ b/src/Applications/GEOSdas_App/ldas_run.csh @@ -0,0 +1,211 @@ +#!/bin/csh -f + +# ldas_run.csh - invokes the land analysis. +# +# !REVISION HISTORY: +# +# Apr2021 sqzhang Initial script +#------------------------------------- + +set echo + +setenv MYNAME ldas_run.csh + +if ( $#argv < 3 ) then + echo " " + echo " \\begin{verbatim} " + echo " " + echo " NAME " + echo " " + echo " $MYNAME - entry point to obtain LDAS increments" + echo " " + echo " SYNOPSIS " + echo " " + echo " $MYNAME stage freql freqa" + echo " " + echo " where" + echo " stage - 0 (run ldas) or 1 (stage ldas increments)" + echo " freql - frequency of ldas analysis increments, as in HHMMSS" + echo " freqa - frequency of adas analysis increments, as in HHMMSS" + echo " " + echo " DESCRIPTION" + echo " " + echo " This procedures handles the LDAS coupling in the central DAS. " + echo " " + echo " Example of valid command line:" + echo " $MYNAME 1 030000 060000" + echo " " + echo " REQUIRED ENVIRONMENT VARIABLES" + echo " " + echo " FVHOME - location of experiment " + echo " FVROOT - location of DAS build " + echo " FVWORK - location of work directory " + echo " LDHOME - location of LDAS experiment " + echo " \\end{verbatim} " + echo " \\clearpage " + exit(0) +endif + +set path = ( . $FVHOME/run $FVROOT/bin $path ) + +setenv FAILED 0 +if ( !($?FVHOME) ) setenv FAILED 1 +if ( !($?FVROOT) ) setenv FAILED 1 +if ( !($?FVWORK) ) setenv FAILED 1 +if ( !($?LDHOME) ) setenv FAILED 1 + +if ( $FAILED ) then + env + echo " ${MYNAME}: not all required env vars defined" + exit 1 +endif + +set stage = $1 +set freql = $2 +set freqa = $3 + + cd $FVWORK + set adas_strt = ( `rst_date ./d_rst` ) +set nymd = `echo $adas_strt[1] | cut -c1-8` +set hh = `echo $adas_strt[2] | cut -c1-2` +set yyyymmddhh = ${nymd}${hh} + +if (-e $FVWORK/.DONE_${MYNAME}.${yyyymmddhh} ) then + echo " ${MYNAME}: already done" + exit(0) +endif + +if ( $stage == 0 ) then + echo " ${MYNAME}: stage 0" + + @ adas_int = $freqa / 10000 + @ adas_int = $adas_int * 3600 + @ cent_int = 3600 + @ tavg1_tick0 = -1800 + @ inst1_tick0 = 0 + + set inst1_strt = ( `tick $adas_strt $inst1_tick0` ) + set tavg1_strt = ( `tick $adas_strt $tavg1_tick0` ) + + set secs = 0 + + while ( $secs < = $adas_int ) + set inst1_now = ( `tick $inst1_strt $secs` ) + set tavg1_now = ( `tick $tavg1_strt $secs` ) + + set tttt_i=`echo $inst1_now[2] | cut -c1-4` + set tttt_a=`echo $tavg1_now[2] | cut -c1-4` + + /bin/cp ${FVHOME}/recycle/holdforc/*.inst1_2d_lfo_Nx+-.$inst1_now[1]_${tttt_i}z.nc4\ + ${FVWORK} + /bin/cp ${FVHOME}/recycle/holdforc/*.tavg1_2d_lfo_Nx+-.$tavg1_now[1]_${tttt_a}z.nc4\ + ${FVWORK} + + @ secs = $secs + $cent_int + end + +#link $FVWORK for ldas met_forcing access + /bin/rm -f $FVHOME/lana/forc + /bin/ln -s $FVWORK $FVHOME/lana/forc + + ls -l $FVHOME/lana/forc/*lfo_Nx+* + + echo " ${MYNAME}: LDAS coupling: run ldas for central DAS coupling" + # go to LDHOME to submit ldas run + cd $LDHOME/run + echo "ldas_home_dir: ", $LDHOME + set lcapdat = `cat cap_restart | cut -c1-8` + set lcaptim = `cat cap_restart | cut -c10-15` + echo "ldas_6h_window starting at: ", $lcapdat, $lcaptim + echo "adas_anal_window starting at: ", $adas_strt[1], $adas_strt[2] + + # submit job and capture job ID + set jobldas = "$LDHOME/run/lenkf.j" + set jobIDlong = `$PBS_BIN/sbatch $jobldas` + set jobID = `echo $jobIDlong |awk -F'[ ]' '{print $4}'` + setenv ldasJobIDs $jobID + echo $ldasJobIDs ": LDAS coupling lenkf jobID in LandAnalysisRun" + +## back to fvwork + cd $FVWORK + +##stage incr + else + cd $FVWORK + echo " ${MYNAME}: LDAS coupling: stage/link LdasIncr for AGCM corrector " + if ($?ldasJobIDs) then + $FVROOT/bin/jobIDfilter -w $ldasJobIDs + unsetenv ldasJobIDs + endif + + set lenkf_status_file = ${FVWORK}/lenkf_job_completed.txt + rm -f $lenkf_status_file + + cp $LDHOME/run/lenkf_job_completed.txt $lenkf_status_file + + set lenkf_status = `cat $lenkf_status_file` + echo $lenkf_status + echo $lenkf_status ": lenkf_status" + if ($lenkf_status =~ SUCCEEDED ) then + echo "LDAS coupling Lenkf job SUCCEEDED, stageLdasIncr" + endif + + /bin/rm -f ${FVHOME}/recycle/holdforc/* + +# current all member incr outputs in cat/ens_avg + set LINC_DIR = ${LDHOME}/output/*/cat/ens_avg/ + + cd ${FVHOME}/lana + + @ ldas_int = $freql / 10000 + @ ldas_int = $ldas_int * 3600 + + @ adas_int = $freqa / 10000 + @ adas_int = $adas_int * 3600 + + set lincr_native_name = catch_progn_incr + set lincr_default_name = ldas_inc + + + @ cent_int = ($ldas_int / 2) + + set secs = 0 + + while ( $secs < $adas_int ) + # the begining time of the window secs=0 + set ldas_strt = ( `tick $adas_strt $secs` ) + # for ldas_incr, use centered time + set ldas_cntr = ( `tick $ldas_strt $cent_int` ) + # ldas anal time + set ldas_anlt = ( `tick $ldas_strt $ldas_int` ) + + set yyyy_a=`echo $ldas_anlt[1] | cut -c1-4` + set mm_a=`echo $ldas_anlt[1] | cut -c5-6` + set dd_a=`echo $ldas_anlt[1] | cut -c7-8` + set tttt_a=`echo $ldas_anlt[2] | cut -c1-4` + set tttt_c=`echo $ldas_cntr[2] | cut -c1-4` +# default name for AGCM: ldas_inc.yyyymmdd_hhnn00 + if ( -e ${LINC_DIR}/Y${yyyy_a}/M${mm_a}/*${lincr_native_name}.$ldas_anlt[1]_${tttt_a}z.nc4) then + + /bin/cp ${LINC_DIR}/Y${yyyy_a}/M${mm_a}/*.${lincr_native_name}.$ldas_anlt[1]_${tttt_a}z.nc4\ + ${FVWORK}/ldas_inc.$ldas_cntr[1]_${tttt_c}00 + + /bin/ln -s ${LINC_DIR}/Y${yyyy_a}/M${mm_a}/*${lincr_native_name}.$ldas_anlt[1]_${tttt_a}z.nc4\ + ${FVHOME}/lana/ldas_inc.$ldas_cntr[1]_${tttt_c}00 + else + echo " ${MYNAME}: WARNING: ldas incr file not found, no ldasIncr for this cycle" + exit 1 + endif + @ secs = $secs + $ldas_int + end + +# normal return +touch $FVWORK/.DONE_${MYNAME}.${yyyymmddhh} +echo " ${MYNAME}: Complete " + exit 0 + + endif #end stage=1 + + cd ${FVWORK} + + From b1e5a700a44e4f55b9de7cc6a7694585a13bd02f Mon Sep 17 00:00:00 2001 From: Joe Stassi Date: Wed, 26 May 2021 11:42:59 -0400 Subject: [PATCH 034/205] updates for running C90C_ens and C90C_replay test cases --- src/Applications/GEOSdas_App/fvsetup | 17 ++++++------ .../GEOSdas_App/testsuites/C90C_ens.input | 8 +++--- .../GEOSdas_App/testsuites/C90C_replay.input | 5 +--- .../NCEP_enkf/scripts/gmao/get_atmens_rst.pl | 26 +++++++++++++++---- 4 files changed, 34 insertions(+), 22 deletions(-) diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index 506e3794..bc083058 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -341,7 +341,7 @@ # 25Jul2017 Holdaway Added resource files associated with NGGPS FV3 tlm/adjoint, sens and svec # 19Jul2018 Wargan Additions for OMPS #------------------------------------------------------------------------- -use Cwd qw(cwd); +use Cwd qw(abs_path cwd); use English; use Env; # make env vars readily available use File::Basename qw(basename dirname); @@ -2278,29 +2278,28 @@ EOF #======================================================================= sub ed_aens_das_replay_acq { my($mydir) = @_; - my($replay_arcdir, $aens_replay_expid, $acq); + my($replay_arcdir, $replay_expid, $acq); - $aens_replay_expid = "x0044"; - $replay_arcdir = query("Replay exp name?", $aens_replay_expid); - $replay_arcdir = "/discover/nobackup/projects/gmao/advda/rtodling/archive/x0044"; + $replay_arcdir = "/discover/nobackup/projects/gmao/dadev/rtodling/archive/x0044"; $replay_arcdir = query("Replay archive directory?", $replay_arcdir); + $replay_expid = basename(abs_path($replay_arcdir)); $acq = "$fvhome/$mydir/atmens_replay.acq"; - open(SCRIPT,">$acq") or die ">>> ERROR <<< cannot write $acq"; + open(SCRIPT,">$acq") or die ">>> ERROR <<< cannot write $acq"; print SCRIPT <<"EOF"; -$replay_arcdir/atmens/Y%y4/M%m2/$aens_replay_expid.atmens_ebkg.%y4%m2%d2_%h2z.tar => $expid.atmens_ebkg.%y4%m2%d2_%h2z.tar +$replay_arcdir/atmens/Y%y4/M%m2/$replay_expid.atmens_ebkg.%y4%m2%d2_%h2z.tar => $expid.atmens_ebkg.%y4%m2%d2_%h2z.tar EOF if ( $mydir eq "run") { $acq = "$fvhome/anasa/atmens_replay.acq"; open(SCRIPT,">$acq") or die ">>> ERROR <<< cannot write $acq"; print SCRIPT <<"EOF"; -$replay_arcdir/atmens/Y%y4/M%m2/$aens_replay_expid.atmens_ebkg.%y4%m2%d2_%h2z.tar => $expid.atmens_ebkg.%y4%m2%d2_%h2z.tar +$replay_arcdir/atmens/Y%y4/M%m2/$replay_expid.atmens_ebkg.%y4%m2%d2_%h2z.tar => $expid.atmens_ebkg.%y4%m2%d2_%h2z.tar EOF $acq = "$fvhome/asens/atmens_asens.acq"; open(SCRIPT,">$acq") or die ">>> ERROR <<< cannot write $acq"; print SCRIPT <<"EOF"; -$replay_arcdir/atmens/Y%y4/M%m2/$aens_replay_expid.atmens_ebkg.%y4%m2%d2_%h2z.tar => $expid.atmens_ebkg.%y4%m2%d2_%h2z.tar +$replay_arcdir/atmens/Y%y4/M%m2/$replay_expid.atmens_ebkg.%y4%m2%d2_%h2z.tar => $expid.atmens_ebkg.%y4%m2%d2_%h2z.tar EOF } diff --git a/src/Applications/GEOSdas_App/testsuites/C90C_ens.input b/src/Applications/GEOSdas_App/testsuites/C90C_ens.input index 0ec400d2..28fec6ce 100644 --- a/src/Applications/GEOSdas_App/testsuites/C90C_ens.input +++ b/src/Applications/GEOSdas_App/testsuites/C90C_ens.input @@ -74,7 +74,7 @@ AeroCom? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/AeroCom] > FVICS? [/archive/u/jstassi/restarts/GEOSadas-5_24_0] -> /archive/u/jstassi/restarts/GEOSadas-5_25_0/C90CS_x0039_p6.rst.20190729_21z.tar +> /archive/u/jstassi/restarts/GEOSadas-5_27_0/C90CS_x0044.rst.20201215_21z.tar Run model-adjoint-related applications (0=no,1=yes)? [0] > 1 @@ -95,7 +95,7 @@ Verifying experiment id: [C90C_ens] > Ending year-month-day? [20190731] -> 20190801 +> 20201220 Length of FORECAST run segments (in hours)? [123] > @@ -143,7 +143,7 @@ Which main class of ObsSys (1: NRT; 2: MERRA; 3: MERRA-2)? [1] > OBSERVING SYSTEM CLASSES? -> ncep_prep_bufr,ncep_1bamua_bufr,disc_airs_bufr,disc_amsua_bufr,ncep_mhs_bufr,ncep_1bhrs4_bufr,ncep_goesfv_bufr,ncep_mtiasi_bufr,ncep_gpsro_bufr,ncep_aura_omi_bufr,ncep_satwnd_bufr,ncep_atms_bufr,ncep_sevcsr_bufr,ncep_ssmis_bufr,mls_nrt_nc,ncep_avcsam_bufr,ncep_avcspm_bufr,ncep_tcvitals,gmao_gmi_bufr,ncep_crisfsr_bufr,npp_ompsnm_bufr,ncep_acftpfl_bufr +> ncep_ssmis_bufr,ncep_1bamua_bufr,ncep_prep_bufr,ncep_tcvitals,ncep_mhs_bufr,ncep_1bhrs4_bufr,ncep_gpsro_bufr,ncep_mtiasi_bufr,ncep_atms_bufr,ncep_crisfsr_bufr,ncep_satwnd_bufr,ncep_sevcsr_bufr,ncep_avcsam_bufr,ncep_avcspm_bufr,ncep_aura_omi_bufr,disc_airs_bufr,disc_amsua_bufr,gmao_gmi_bufr,mls_nrt_nc,gmao_amsr2_bufr,npp_ompsnm_bufr,ncep_acftpfl_bufr CHECKING OBSYSTEM? [2] > @@ -227,7 +227,7 @@ Ensemble Vertical Levels? [72] > Experiment archive directory for ensemble restarts or 'later': [/archive/u/jstassi/C90C_ens] -> /archive/u/dao_it/x0039_p6 +> /discover/nobackup/projects/gmao/dadev/rtodling/archive/x0044 Edit COLLECTIONS list in run/HISTORY.rc.tmpl (y/n)? [n] > diff --git a/src/Applications/GEOSdas_App/testsuites/C90C_replay.input b/src/Applications/GEOSdas_App/testsuites/C90C_replay.input index 2fe0444c..051bceb7 100644 --- a/src/Applications/GEOSdas_App/testsuites/C90C_replay.input +++ b/src/Applications/GEOSdas_App/testsuites/C90C_replay.input @@ -217,11 +217,8 @@ Select group: [g0613] Replayed Ensemble (from OPS)? [yes] > -Replay exp name? [x0044] -> - Replay archive directory? [/discover/nobackup/projects/gmao/advda/rtodling/archive/x0044] -> +> /discover/nobackup/projects/gmao/dadev/rtodling/archive/x0044 Edit COLLECTIONS list in run/HISTORY.rc.tmpl (y/n)? [n] > diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/get_atmens_rst.pl b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/get_atmens_rst.pl index 81996f29..7967a844 100755 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/get_atmens_rst.pl +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/get_atmens_rst.pl @@ -1,10 +1,12 @@ #!/usr/bin/env perl use strict; use warnings; -use Cwd qw(cwd); +use Cwd qw(abs_path cwd); use File::Basename qw(basename dirname); use File::Copy qw(cp mv); use File::Path qw(mkpath rmtree); +use Getopt::Long qw(GetOptions); + use FindBin qw($Bin); use lib "$Bin"; use Manipulate_time qw(tick); @@ -30,7 +32,7 @@ my ($atmens_stat_dir, $atmens_ebkg_dir, $atmens_erst_dir, $atmens_ecbkg_dir); my ($tarfile, $tarpath, $label, $pid); my ($ens, $mem, $mfile, $mfile_new); - my (@tarList); + my (@archList, @tarList); init(); chdir($atmens_dir); @@ -52,12 +54,12 @@ foreach $label ("stat", "ebkg", "ecbkg", "erst") { $tarfile = "$expid.atmens_$label.${yyyymmdd}_${hh}z.tar"; $tarpath = "$atmens_date_dir/$tarfile"; + push @archList, $tarpath if archFile($tarpath); push @tarList, $tarpath; } - defined($pid = fork) or die "Error while attempting to fork;"; unless ($pid) { - system "dmget @tarList"; + system "dmget @archList"; exit; } foreach $tarpath (@tarList) { system_("tar xvf $tarpath") } @@ -88,7 +90,6 @@ # purpose - get runtime parameters and flags #======================================================================= sub init { - use Getopt::Long qw(GetOptions); my ($fvhome, $help, $exparcdir); GetOptions("fvhome=s" => \$fvhome, @@ -102,6 +103,7 @@ sub init { ($exparcdir, $newid, $yyyymmdd, $hh) = @ARGV; $exparcdir =~ s/[\s\/]*$//; + $exparcdir = abs_path($exparcdir); $arcdir = dirname($exparcdir); $expid = basename($exparcdir); @@ -123,6 +125,20 @@ sub init { } +#======================================================================= +# name - archFile +# purpose - Return true (1) if $file is an archive file; +# Return false (0) if not +#======================================================================= +sub archFile { + my ($file, $dmLine, $dmFLG); + $file = shift @_; + $dmLine = `dmls -l $file`; + $dmFLG = 1; + $dmFLG = 0 if $dmLine =~ m|(N/A)|; + return $dmFLG; +} + #======================================================================= # name - rename_new #======================================================================= From 562feb4447c73e45e482286a95b2d906572683fb Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Wed, 26 May 2021 14:21:29 -0400 Subject: [PATCH 035/205] edit as in 5_28_0 --- .../GEOSdas_App/testsuites/geos_it.input | 54 +++++++++---------- 1 file changed, 27 insertions(+), 27 deletions(-) diff --git a/src/Applications/GEOSdas_App/testsuites/geos_it.input b/src/Applications/GEOSdas_App/testsuites/geos_it.input index a88d5db4..93ae751d 100644 --- a/src/Applications/GEOSdas_App/testsuites/geos_it.input +++ b/src/Applications/GEOSdas_App/testsuites/geos_it.input @@ -2,12 +2,12 @@ # geos_it.input #-------------- -description: geos_it__GEOSadas-5_27_1_p4__agrid_C90__ogrid_CS +description: geos_it__GEOSadas-5_27_1_p4__agrid_C360__ogrid_C tag: GEOSadas-5_27_1_p4 ---ENDHEADERS--- -Remote account for Intranet plots? [rtodling@train] +Remote account for Intranet plots? [dao_ops@train] > Is this a MERRA2 experiment (y/n)? [n] @@ -20,22 +20,25 @@ AGCM Vertical Resolution? [72] > OGCM Resolution? [f] -> CS +> C -EXPID? [u000_C90] +EXPID? [u000_C360] > $expid Check for previous use of expid (y/n)? [y] > n -EXPDSC? [geos_it__GEOSadas-5_27_1_p4__agrid_C90__ogrid_CS] +EXPDSC? [geos_it__GEOSadas-5_27_1_p4__agrid_C360__ogrid_C] > Land Boundary Conditions? [Icarus_Updated] > Icarus-NLv3 +Catchment Model choice? [1] +> + FVHOME? [/discover/nobackup/rtodling/geos_it] -> /discover/nobackup/projects/gmao/dadev/rtodling/geos_it +> /discover/nobackup/dao_ops/$expid The directory /discover/nobackup/projects/gmao/dadev/rtodling/geos_it does not exist. Create it now? [y] > @@ -71,7 +74,7 @@ AeroCom? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/AeroCom] > FVICS? [/archive/u/jstassi/restarts/GEOSadas-5_24_0] -> /discover/nobackup/projects/gmao/dadev/rtodling/archive/x0044/rs/Y2020/M12/x0044.rst.20201215_21z.tar +> /discover/nobackup/projects/gmao/dadev/rtodling/archive/Restarts/5_28/geosit_test/rs/Y2017/M12/geosit_test.rst.20171215_21z.tar Run model-adjoint-related applications (0=no,1=yes)? [0] > @@ -79,23 +82,23 @@ Run model-adjoint-related applications (0=no,1=yes)? [0] Run analysis-sensitivity applications (0=no,1=yes)? [0] > -Ending year-month-day? [20201217] +Ending year-month-day? [20210117] > Length of FORECAST run segments (in hours)? [123] -> 27 +> Number of one-day DAS segments per PBS job? [1] > -Number of PEs in the zonal direction (NX)? [4] -> 6 +Number of PEs in the zonal direction (NX)? [8] +> -Number of PEs in the meridional direction (NY)? [24] -> 36 +Number of PEs in the meridional direction (NY)? [48] +> Job nickname? [g5das] -> geosit +> git Run in split executable mode (1=yes;0=no)? [1] > @@ -112,23 +115,23 @@ Analysis vertical levels (sig))? [72] GSI grid resolution? [NA] > -GEOS grid resolution instead? [c] -> d +GEOS grid resolution instead? [d] +> Ensemble Hybrid (<0;3=3dHyb;4=Hyb4d)? [-1] > -Number of procs in the zonal direction (NX)? [4] +Number of procs in the zonal direction (NX)? [12] > 6 -Number of procs in the meridional direction (NY)? [12] +Number of procs in the meridional direction (NY)? [20] > 36 Which main class of ObsSys (1: NRT; 2: MERRA; 3: MERRA-2)? [1] -> 1 +> OBSERVING SYSTEM CLASSES? -> disc_airs_bufr,disc_amsua_bufr,mls_nrt_nc,ncep_1bamua_bufr,ncep_1bhrs4_bufr,ncep_acftpfl_bufr,ncep_atms_bufr,ncep_aura_omi_bufr,ncep_avcsam_bufr,ncep_avcspm_bufr,ncep_crisfsr_bufr,ncep_goesfv_bufr,ncep_gpsro_bufr,ncep_mhs_bufr,ncep_mtiasi_bufr,ncep_prep_bufr,ncep_satwnd_bufr,ncep_sevcsr_bufr,ncep_ssmis_bufr,ncep_tcvitals,npp_ompsnp_nc,npp_ompsnmeff_nc,aura_omieff_nc +> ncep_ssmis_bufr,ncep_1bamua_bufr,ncep_prep_bufr,ncep_tcvitals,ncep_mhs_bufr,ncep_1bhrs4_bufr,ncep_goesfv_bufr,ncep_gpsro_bufr,ncep_mtiasi_bufr,ncep_atms_bufr,ncep_cris_bufr,ncep_crisfsr_bufr,ncep_satwnd_bufr,ncep_sevcsr_bufr,ncep_avcsam_bufr,ncep_avcspm_bufr,disc_airs_bufr,disc_amsua_bufr,ncep_acftpfl_bufr,aura_omieff_nc,npp_ompsnp_nc,npp_ompsnmeff_nc,ncep_osbuv_bufr CHECKING OBSYSTEM? [2] > 1 @@ -157,10 +160,10 @@ Frequency for surface (2D) DIAGNOSTIC fields? [010000] Frequency for upper air (3D) DIAGNOSTIC fields? [030000] > -Dimension of output in zonal direction? [288] +Dimension of output in zonal direction? [1152] > -Dimension of output in meridional direction? [181] +Dimension of output in meridional direction? [721] > Would you like 2D diagnostics? [y] @@ -176,7 +179,7 @@ Include GOCART tracers (CO,CO2,aerosols,etc) (y/n)? [y] > Select GOCART Emission Files to use: [OPS] -> OPS +> Do Aerosol Analysis (y/n)? [y] > @@ -200,10 +203,7 @@ Select group: [g0613] > Edit COLLECTIONS list in run/HISTORY.rc.tmpl (y/n)? [n] -> y - -COLLECTIONS? -> gaas_bkg.sfc,bkg.eta,bkg.sfc,cbkg.eta,vtx.mix,asm.eta,inst3_2d_gas_Nx,inst3_3d_gas_Nv,inst3_3d_asm_Np,inst3_3d_asm_Nv,tavg3_3d_cld_Cp,tavg3_3d_mst_Ne +> Edit COLLECTIONS list in fcst/HISTORY.rc.tmpl (y/n)? [n] > From 38acfc20f94cc82ebe843e1c09d8b4b45bb4e799 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Wed, 26 May 2021 20:21:35 -0400 Subject: [PATCH 036/205] for some reason this is not a c360 run --- src/Applications/GEOSdas_App/testsuites/geos_it.input | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Applications/GEOSdas_App/testsuites/geos_it.input b/src/Applications/GEOSdas_App/testsuites/geos_it.input index 93ae751d..e2de4e52 100644 --- a/src/Applications/GEOSdas_App/testsuites/geos_it.input +++ b/src/Applications/GEOSdas_App/testsuites/geos_it.input @@ -14,7 +14,7 @@ Is this a MERRA2 experiment (y/n)? [n] > AGCM Horizontal Resolution? [C48] -> C360 +> C180 AGCM Vertical Resolution? [72] > @@ -94,8 +94,8 @@ Number of one-day DAS segments per PBS job? [1] Number of PEs in the zonal direction (NX)? [8] > -Number of PEs in the meridional direction (NY)? [48] -> +Number of PEs in the meridional direction (NY)? [30] +> 48 Job nickname? [g5das] > git @@ -122,10 +122,10 @@ Ensemble Hybrid (<0;3=3dHyb;4=Hyb4d)? [-1] > Number of procs in the zonal direction (NX)? [12] -> 6 +> 16 Number of procs in the meridional direction (NY)? [20] -> 36 +> 24 Which main class of ObsSys (1: NRT; 2: MERRA; 3: MERRA-2)? [1] > From 45f6215daff164786fe231f20968c5e0096710fb Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Wed, 2 Jun 2021 14:13:16 -0400 Subject: [PATCH 037/205] something is messed up in the npp_ompsnmeff_nc in 201712 - only obs after the 20th get assimilated --- src/Applications/GEOSdas_App/testsuites/geos_it.input | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Applications/GEOSdas_App/testsuites/geos_it.input b/src/Applications/GEOSdas_App/testsuites/geos_it.input index e2de4e52..fb08d99f 100644 --- a/src/Applications/GEOSdas_App/testsuites/geos_it.input +++ b/src/Applications/GEOSdas_App/testsuites/geos_it.input @@ -74,7 +74,7 @@ AeroCom? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/AeroCom] > FVICS? [/archive/u/jstassi/restarts/GEOSadas-5_24_0] -> /discover/nobackup/projects/gmao/dadev/rtodling/archive/Restarts/5_28/geosit_test/rs/Y2017/M12/geosit_test.rst.20171215_21z.tar +> /discover/nobackup/projects/gmao/dadev/rtodling/archive/Restarts/5_28/geosit_test/rs/Y2017/M12/geosit_test.rst.20171219_21z.tar Run model-adjoint-related applications (0=no,1=yes)? [0] > From adb9420a8e8e99d487f2ad79fa08e513bf255c70 Mon Sep 17 00:00:00 2001 From: saraqzhang Date: Wed, 2 Jun 2021 19:46:09 -0400 Subject: [PATCH 038/205] add LDAS.rc parameter input option add time selection in holding forcing files --- src/Applications/GEOSdas_App/fvpsas | 4 +- src/Applications/GEOSdas_App/ldas_run.csh | 79 +++++++++---------- .../NCEP_Etc/NCEP_enkf/scripts/gmao/atm_ens.j | 6 +- .../NCEP_enkf/scripts/gmao/atmos_eldas.csh | 47 ++++++----- 4 files changed, 67 insertions(+), 69 deletions(-) diff --git a/src/Applications/GEOSdas_App/fvpsas b/src/Applications/GEOSdas_App/fvpsas index 3b91ccf6..40618a63 100755 --- a/src/Applications/GEOSdas_App/fvpsas +++ b/src/Applications/GEOSdas_App/fvpsas @@ -424,7 +424,7 @@ if ( $LDAS_ANA ) then echo " LDAS coupling: fvpsas LDAS_ANA run lenkf " zeit_ci.x ldasRun - ldas_run.csh 0 030000 060000 |& tee -a ldasrun.log + ldas_run.csh 0 060000 |& tee -a ldasrun.log if( $status) then echo "ldasRun failed" exit(1) @@ -499,7 +499,7 @@ if ( ( $LDAS_ANA ) && ( $LDASFDBK ) ) then echo " LDAS coupling: stage 1" zeit_ci.x ldasStage - ldas_run.csh 1 030000 060000 |& tee -a ldasrun.log + ldas_run.csh 1 060000 |& tee -a ldasrun.log if( $status) then echo "ldas_run stage 1 failed" exit(1) diff --git a/src/Applications/GEOSdas_App/ldas_run.csh b/src/Applications/GEOSdas_App/ldas_run.csh index 7d883082..a5a923fe 100755 --- a/src/Applications/GEOSdas_App/ldas_run.csh +++ b/src/Applications/GEOSdas_App/ldas_run.csh @@ -1,17 +1,10 @@ #!/bin/csh -f -# ldas_run.csh - invokes the land analysis. -# -# !REVISION HISTORY: -# -# Apr2021 sqzhang Initial script -#------------------------------------- - set echo setenv MYNAME ldas_run.csh -if ( $#argv < 3 ) then +if ( $#argv < 2 ) then echo " " echo " \\begin{verbatim} " echo " " @@ -21,19 +14,18 @@ if ( $#argv < 3 ) then echo " " echo " SYNOPSIS " echo " " - echo " $MYNAME stage freql freqa" + echo " $MYNAME stage freqa" echo " " echo " where" - echo " stage - 0 (run ldas) or 1 (stage ldas increments)" - echo " freql - frequency of ldas analysis increments, as in HHMMSS" - echo " freqa - frequency of adas analysis increments, as in HHMMSS" + echo " stage - run step 0 or stage step 1" + echo " freqa - frequency of adas increments, as in HHMMSS" echo " " echo " DESCRIPTION" echo " " echo " This procedures handles the LDAS coupling in the central DAS. " echo " " echo " Example of valid command line:" - echo " $MYNAME 1 030000 060000" + echo " $MYNAME 1 060000" echo " " echo " REQUIRED ENVIRONMENT VARIABLES" echo " " @@ -61,8 +53,8 @@ if ( $FAILED ) then endif set stage = $1 -set freql = $2 -set freqa = $3 +set freqa = $2 + cd $FVWORK set adas_strt = ( `rst_date ./d_rst` ) @@ -75,11 +67,14 @@ if (-e $FVWORK/.DONE_${MYNAME}.${yyyymmddhh} ) then exit(0) endif + @ adas_int = $freqa / 10000 + @ adas_int = $adas_int * 3600 + + if ( $stage == 0 ) then echo " ${MYNAME}: stage 0" - @ adas_int = $freqa / 10000 - @ adas_int = $adas_int * 3600 +# lfo forcing @ cent_int = 3600 @ tavg1_tick0 = -1800 @ inst1_tick0 = 0 @@ -103,13 +98,12 @@ if ( $stage == 0 ) then @ secs = $secs + $cent_int end + /bin/rm -f ${FVHOME}/recycle/holdforc/* #link $FVWORK for ldas met_forcing access /bin/rm -f $FVHOME/lana/forc /bin/ln -s $FVWORK $FVHOME/lana/forc - ls -l $FVHOME/lana/forc/*lfo_Nx+* - echo " ${MYNAME}: LDAS coupling: run ldas for central DAS coupling" # go to LDHOME to submit ldas run cd $LDHOME/run @@ -124,7 +118,7 @@ if ( $stage == 0 ) then set jobIDlong = `$PBS_BIN/sbatch $jobldas` set jobID = `echo $jobIDlong |awk -F'[ ]' '{print $4}'` setenv ldasJobIDs $jobID - echo $ldasJobIDs ": LDAS coupling lenkf jobID in LandAnalysisRun" + echo $ldasJobIDs ": LDAS coupling lenkf jobID for central das " ## back to fvwork cd $FVWORK @@ -150,48 +144,49 @@ if ( $stage == 0 ) then echo "LDAS coupling Lenkf job SUCCEEDED, stageLdasIncr" endif - /bin/rm -f ${FVHOME}/recycle/holdforc/* - # current all member incr outputs in cat/ens_avg - set LINC_DIR = ${LDHOME}/output/*/cat/ens_avg/ - - cd ${FVHOME}/lana - - @ ldas_int = $freql / 10000 - @ ldas_int = $ldas_int * 3600 - - @ adas_int = $freqa / 10000 - @ adas_int = $adas_int * 3600 - + set LINC_DIR = ${LDHOME}/output/*/cat/ens_avg/ + +# LANDASSIM_DT in sec (10800 ) + set ldas_int = 10800 + set ldasDT = `grep LANDASSIM_DT: ${LDHOME}/run/LDAS.rc | cut -d':' -f2` + if ( ${ldasDT} > 0 ) then + set ldas_int = ${ldasDT} + endif + +# LANDASSIM_T0 in hhmmss (centered update for ladas ) + set ldas_t0 = 013000 + set ldasT0 = `grep LANDASSIM_T0: ${LDHOME}/run/LDAS.rc | cut -d':' -f2` + if ( ${ldasT0} > 0 ) then + set ldas_t0 = ${ldasT0} + endif + set t0hh = `echo ${ldas_t0} | cut -c1-2` + set t0mm = `echo ${ldas_t0} | cut -c3-4` + @ cent_int = $t0hh * 3600 + $t0mm * 60 + set lincr_native_name = catch_progn_incr set lincr_default_name = ldas_inc - - @ cent_int = ($ldas_int / 2) - set secs = 0 while ( $secs < $adas_int ) # the begining time of the window secs=0 set ldas_strt = ( `tick $adas_strt $secs` ) - # for ldas_incr, use centered time - set ldas_cntr = ( `tick $ldas_strt $cent_int` ) - # ldas anal time - set ldas_anlt = ( `tick $ldas_strt $ldas_int` ) + # for ldas_incr, use LANDASSIM_T0 + set ldas_anlt = ( `tick $ldas_strt $cent_int` ) set yyyy_a=`echo $ldas_anlt[1] | cut -c1-4` set mm_a=`echo $ldas_anlt[1] | cut -c5-6` set dd_a=`echo $ldas_anlt[1] | cut -c7-8` set tttt_a=`echo $ldas_anlt[2] | cut -c1-4` - set tttt_c=`echo $ldas_cntr[2] | cut -c1-4` # default name for AGCM: ldas_inc.yyyymmdd_hhnn00 if ( -e ${LINC_DIR}/Y${yyyy_a}/M${mm_a}/*${lincr_native_name}.$ldas_anlt[1]_${tttt_a}z.nc4) then /bin/cp ${LINC_DIR}/Y${yyyy_a}/M${mm_a}/*.${lincr_native_name}.$ldas_anlt[1]_${tttt_a}z.nc4\ - ${FVWORK}/ldas_inc.$ldas_cntr[1]_${tttt_c}00 + ${FVWORK}/ldas_inc.$ldas_anlt[1]_${tttt_a}00 /bin/ln -s ${LINC_DIR}/Y${yyyy_a}/M${mm_a}/*${lincr_native_name}.$ldas_anlt[1]_${tttt_a}z.nc4\ - ${FVHOME}/lana/ldas_inc.$ldas_cntr[1]_${tttt_c}00 + ${FVHOME}/lana/ldas_inc.$ldas_anlt[1]_${tttt_a}00 else echo " ${MYNAME}: WARNING: ldas incr file not found, no ldasIncr for this cycle" exit 1 diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atm_ens.j b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atm_ens.j index 46763b7f..6340c4c1 100755 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atm_ens.j +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atm_ens.j @@ -141,10 +141,8 @@ setenv SPECRES 62 # should be able to revisit analyzer to avoid needing this setenv GAAS_ANA 1 -#sqz---merge--start setenv LDAS_ANA >>>LDAS_ANA<<< setenv LDHOME4ens >>>LDHOME4ens<<< -#---end # Run-time mpi-related options @@ -455,19 +453,17 @@ endif endif -# sqz---merge--start # LDAS ens analysis at ens gcm resolution # ----------------------------------- if ( $LDAS_ANA ) then zeit_ci.x eldas - atmos_eldas.csh $EXPID $anymd $anhms 030000 060000 |& tee -a atm_ens.log + atmos_eldas.csh $EXPID $anymd $anhms 060000 |& tee -a atm_ens.log if( $status) then echo "eldas failed" exit(1) endif zeit_co.x eldas endif -#---end # Run ensemble of atmospheric analyses # ------------------------------------ diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmos_eldas.csh b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmos_eldas.csh index c58ff53b..c1848dab 100755 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmos_eldas.csh +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmos_eldas.csh @@ -8,7 +8,7 @@ endif setenv MYNAME atmos_eldas.csh -if ( $#argv < 5 ) then +if ( $#argv < 4 ) then echo " " echo " \\begin{verbatim} " echo " " @@ -18,13 +18,12 @@ if ( $#argv < 5 ) then echo " " echo " SYNOPSIS " echo " " - echo " $MYNAME expid nymd nhms freql freqa " + echo " $MYNAME expid nymd nhms freqa " echo " " echo " where" echo " expid - usual experiment name, e.g., b541iau" echo " nymd - date of current anal as in YYYYMMDD" echo " nhms - time of current anal as in HHMMSS" - echo " freql - frequency of LDAS4en analysis, as in HHMMSS" echo " freqa - frequency of ADASen analysis, as in HHMMSS" echo " " echo " " @@ -33,7 +32,7 @@ if ( $#argv < 5 ) then echo " ensemble." echo " " echo " Example of valid command line:" - echo " $MYNAME b541iau 20091019 000000 030000 060000" + echo " $MYNAME b541iau 20091019 000000 060000" echo " " echo " REQUIRED ENVIRONMENT VARIABLES" echo " " @@ -64,8 +63,7 @@ endif set expid = $1 set nymd = $2 set nhms = $3 -set freql = $4 -set freqa = $5 +set freqa = $4 set hh = `echo $nhms | cut -c1-2` set yyyymmddhh = ${nymd}${hh} @@ -86,7 +84,7 @@ endif set jobIDlong = `$PBS_BIN/sbatch $jobldas` set jobID = `echo $jobIDlong |awk -F'[ ]' '{print $4}'` setenv ldasJobIDs $jobID - echo $ldasJobIDs ": LDAS4ens coupling lenkf jobID in LandAnalysisRun" + echo $ldasJobIDs ": LDAS4ens coupling lenkf jobID " ## back to fvwork cd $FVWORK @@ -125,18 +123,30 @@ endif end #foreach dir cd - - @ ldas_int = $freql / 10000 - @ ldas_int = $ldas_int * 3600 @ adas_int = $freqa / 10000 - @ adas_int = $adas_int * 3600 + @ adas_int = $adas_int * 3600 + + set ldas_int = 10800 + set ldasDT = `grep LANDASSIM_DT: ${LDHOME4ens}/run/LDAS.rc | cut -d':' -f2` + if ( ${ldasDT} > 0 ) then + set ldas_int = ${ldasDT} + endif + + set ldas_t0 = 013000 + set ldasT0 = `grep LANDASSIM_T0: ${LDHOME4ens}/run/LDAS.rc | cut -d':' -f2` + if ( ${ldasT0} > 0 ) then + set ldas_t0 = ${ldasT0} + endif + set t0hh = `echo ${ldas_t0} | cut -c1-2` + set t0mm = `echo ${ldas_t0} | cut -c3-4` + @ cent_int = $t0hh * 3600 + $t0mm * 60 + set lincr_native_name = catch_progn_incr set lincr_default_name = ldas_inc - - @ cent_int = ($ldas_int / 2) - /bin/cp $RSTSTAGE4AENS/$EXPID.rst.lcv.*.bin my_d_rst + /bin/cp $RSTSTAGE4AENS/*.rst.lcv.*.bin my_d_rst set adas_strt = ( `rst_date ./my_d_rst` ) set secs = 0 @@ -144,16 +154,13 @@ endif while ( $secs < $adas_int ) # the begining time of the window secs=0 set ldas_strt = ( `tick $adas_strt $secs` ) - # for ldas_incr, use centered time - set ldas_cntr = ( `tick $ldas_strt $cent_int` ) # ldas anal time - set ldas_anlt = ( `tick $ldas_strt $ldas_int` ) + set ldas_anlt = ( `tick $ldas_strt $cent_int` ) set yyyy_a=`echo $ldas_anlt[1] | cut -c1-4` set mm_a=`echo $ldas_anlt[1] | cut -c5-6` set dd_a=`echo $ldas_anlt[1] | cut -c7-8` set tttt_a=`echo $ldas_anlt[2] | cut -c1-4` - set tttt_c=`echo $ldas_cntr[2] | cut -c1-4` # default name for AGCM: ldas_inc.yyyymmdd_hhnn00 @ n = 0 while ($n < $nmem) @@ -163,7 +170,7 @@ echo $lentag set memtag = `echo $n | awk '{printf "%03d", $1}'` echo $memtag /bin/ln -s ${LINC_DIR}/Y${yyyy_a}/M${mm_a}/*.${lincr_native_name}${lentag}.$ldas_anlt[1]_${tttt_a}z.nc4\ - ${FVHOME}/atmens/enslana/mem$memtag/ldas_inc.$ldas_cntr[1]_${tttt_c}00 + ${FVHOME}/atmens/enslana/mem$memtag/ldas_inc.$ldas_anlt[1]_${tttt_a}00 end ## copy to FVWORK @@ -171,8 +178,8 @@ echo $memtag set dirs = (`/bin/ls -d mem0*`) foreach dir ($dirs) set nnn = `echo $dir | cut -c4-6` - /bin/cp ${FVHOME}/atmens/enslana/mem${nnn}/ldas_inc.$ldas_cntr[1]_${tttt_c}00\ - ${FVWORK}/mem${nnn}/ldas_inc.$ldas_cntr[1]_${tttt_c}00 + /bin/cp ${FVHOME}/atmens/enslana/mem${nnn}/ldas_inc.$ldas_anlt[1]_${tttt_a}00\ + ${FVWORK}/mem${nnn}/ldas_inc.$ldas_anlt[1]_${tttt_a}00 end #foreach dir #--- @ secs = $secs + $ldas_int From 4b9e3dacb99f6b4568deca34b829d95903f5d82a Mon Sep 17 00:00:00 2001 From: saraqzhang Date: Wed, 9 Jun 2021 10:56:38 -0400 Subject: [PATCH 039/205] add /GEOSdas_App/ldas_add2rc for LADAS experiment setup --- src/Applications/GEOSdas_App/ldas_add2rc | 74 ++++++++++++++++++++++++ 1 file changed, 74 insertions(+) create mode 100755 src/Applications/GEOSdas_App/ldas_add2rc diff --git a/src/Applications/GEOSdas_App/ldas_add2rc b/src/Applications/GEOSdas_App/ldas_add2rc new file mode 100755 index 00000000..a3b39a27 --- /dev/null +++ b/src/Applications/GEOSdas_App/ldas_add2rc @@ -0,0 +1,74 @@ +#!/bin/bash + +MYNAME="ldas_add2rc" +if [[ $# -ne 2 ]]; then + echo " " + echo " NAME " + echo " " + echo " $MYNAME - precedure to modify land premeters in AGCM.rc " + echo " " + echo " SYNOPSIS " + echo " " + echo " $MYNAME FVHOME LDHOME" + echo " " + echo " where" + echo " FVHOME - location of adas experiment " + echo " LDHOME - location of ldas experiment " + echo " " + echo " DESCRIPTION" + echo " " + echo " This procedure modifies the land parameters in AGCM.rc" + echo " " + echo " to be consistent with LDAS.rc in LADAS experiment " + echo " " + echo " It should be run after fvsetup and ldas_setup " + exit 0 +fi + +FVHOME="$1" +LDHOME="$2" + +cd $FVHOME/run +cp AGCM.rc.tmpl AGCM.rc.tmpl.original +cp AGCM.rc.tmpl input.txt + +SEARCH="Z0_FORMULATION:.*" +REPLACE="$(grep $SEARCH $LDHOME/run/LDAS.rc)" + +if [[ 1 -eq $(grep -c $SEARCH AGCM.rc.tmpl ) ]]; then +sed "s|$SEARCH|$REPLACE|g" AGCM.rc.tmpl > input.txt +else +sed -i "/LAND_PARAMS/ i\ $REPLACE" input.txt +fi + +list="LANDASSIM_DT LANDASSIM_T0 " + for var in $list +do + grep $var $LDHOME/run/LDAS.rc >> add.txt +done + +sed -i '/LDAS_INCR/r add.txt' input.txt + +mv input.txt AGCM.rc.tmpl + +echo "The land parameters modified in AGCM.rc: " +echo $REPLACE +for var in $list +do +echo "$(grep $var add.txt)" +done + +mv add.txt $FVHOME/run/atmens/. +cd $FVHOME/run/atmens/ +cp AGCM.rc.tmpl AGCM.rc.tmpl.original +cp AGCM.rc.tmpl input.txt + +if [[ 1 -eq $(grep -c $SEARCH AGCM.rc.tmpl ) ]]; then +sed "s|$SEARCH|$REPLACE|g" AGCM.rc.tmpl > input.txt +else +sed -i "/LAND_PARAMS/ i\ $REPLACE" input.txt +fi +sed -i '/LDAS_INCR/r add.txt' input.txt + +mv input.txt AGCM.rc.tmpl +rm -rf add.txt From 8e42a814aaac26bf319eb8cc2280f4cf3e84efae Mon Sep 17 00:00:00 2001 From: saraqzhang Date: Mon, 14 Jun 2021 17:28:08 -0400 Subject: [PATCH 040/205] ldas_add2rc checks the consistency of land parameters in LDAS.rc and AGCM.rc. --- src/Applications/GEOSdas_App/ldas_add2rc | 55 +++++++++++------------- 1 file changed, 26 insertions(+), 29 deletions(-) diff --git a/src/Applications/GEOSdas_App/ldas_add2rc b/src/Applications/GEOSdas_App/ldas_add2rc index a3b39a27..85ce14e3 100755 --- a/src/Applications/GEOSdas_App/ldas_add2rc +++ b/src/Applications/GEOSdas_App/ldas_add2rc @@ -5,7 +5,7 @@ if [[ $# -ne 2 ]]; then echo " " echo " NAME " echo " " - echo " $MYNAME - precedure to modify land premeters in AGCM.rc " + echo " $MYNAME - precedure to add/verify land premeters in AGCM.rc " echo " " echo " SYNOPSIS " echo " " @@ -17,9 +17,9 @@ if [[ $# -ne 2 ]]; then echo " " echo " DESCRIPTION" echo " " - echo " This procedure modifies the land parameters in AGCM.rc" - echo " " - echo " to be consistent with LDAS.rc in LADAS experiment " + echo " This procedure inserts additional land parameters in AGCM.rc" + echo " and verify if land parameters in AFCM.rc are consistent " + echo " with LDAS.rc in LADAS experiment " echo " " echo " It should be run after fvsetup and ldas_setup " exit 0 @@ -30,45 +30,42 @@ LDHOME="$2" cd $FVHOME/run cp AGCM.rc.tmpl AGCM.rc.tmpl.original -cp AGCM.rc.tmpl input.txt - -SEARCH="Z0_FORMULATION:.*" -REPLACE="$(grep $SEARCH $LDHOME/run/LDAS.rc)" - -if [[ 1 -eq $(grep -c $SEARCH AGCM.rc.tmpl ) ]]; then -sed "s|$SEARCH|$REPLACE|g" AGCM.rc.tmpl > input.txt -else -sed -i "/LAND_PARAMS/ i\ $REPLACE" input.txt -fi -list="LANDASSIM_DT LANDASSIM_T0 " - for var in $list +list="LANDASSIM_DT LANDASSIM_T0 " + for var in $list do grep $var $LDHOME/run/LDAS.rc >> add.txt done -sed -i '/LDAS_INCR/r add.txt' input.txt +sed -i '/LDAS_INCR/r add.txt' AGCM.rc.tmpl -mv input.txt AGCM.rc.tmpl - -echo "The land parameters modified in AGCM.rc: " -echo $REPLACE +echo " The following land parameters are added to AGCM.rc: " for var in $list do echo "$(grep $var add.txt)" done +clist=" Z0_FORMULATION:.* LAND_PARAMS:.* LSM_CHOICE:.* " + for var in $clist +do +Lset="$(grep $var $LDHOME/run/LDAS.rc)" +Aset="$(grep $var $FVHOME/run/AGCM.rc.tmpl)" +lv="$(echo $Lset | cut -d " " -f 2)" +av="$(echo $Aset | cut -d " " -f 2)" +if [ "$lv" != "$av" ]; then +echo " " +echo "Please make the following parameter value consistent in AGCM.rc and LDAS.rc:" +echo "in AGCM.rc: $Aset " +echo "in LDAS.rc: $Lset " +echo " " +fi +done + +###atmens mv add.txt $FVHOME/run/atmens/. cd $FVHOME/run/atmens/ cp AGCM.rc.tmpl AGCM.rc.tmpl.original -cp AGCM.rc.tmpl input.txt -if [[ 1 -eq $(grep -c $SEARCH AGCM.rc.tmpl ) ]]; then -sed "s|$SEARCH|$REPLACE|g" AGCM.rc.tmpl > input.txt -else -sed -i "/LAND_PARAMS/ i\ $REPLACE" input.txt -fi -sed -i '/LDAS_INCR/r add.txt' input.txt +sed -i '/LDAS_INCR/r add.txt' AGCM.rc.tmpl -mv input.txt AGCM.rc.tmpl rm -rf add.txt From b2ea34ef37ab51de9c27eb635738a8b3443406f8 Mon Sep 17 00:00:00 2001 From: saraqzhang Date: Mon, 14 Jun 2021 19:12:01 -0400 Subject: [PATCH 041/205] fix a typo in the description of ldas_add2rc --- src/Applications/GEOSdas_App/ldas_add2rc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Applications/GEOSdas_App/ldas_add2rc b/src/Applications/GEOSdas_App/ldas_add2rc index 85ce14e3..dc252657 100755 --- a/src/Applications/GEOSdas_App/ldas_add2rc +++ b/src/Applications/GEOSdas_App/ldas_add2rc @@ -18,7 +18,7 @@ if [[ $# -ne 2 ]]; then echo " DESCRIPTION" echo " " echo " This procedure inserts additional land parameters in AGCM.rc" - echo " and verify if land parameters in AFCM.rc are consistent " + echo " and verify if land parameters in AGCM.rc are consistent " echo " with LDAS.rc in LADAS experiment " echo " " echo " It should be run after fvsetup and ldas_setup " From 3dc91f2843912f5814e25c5ce3ed3675f75e45dc Mon Sep 17 00:00:00 2001 From: Rolf Reichle <54944691+gmao-rreichle@users.noreply.github.com> Date: Tue, 15 Jun 2021 18:02:12 -0400 Subject: [PATCH 042/205] minor cleanup of LADAS comments/help text --- src/Applications/GEOSdas_App/fvsetup | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index ad002893..f270eda3 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -538,12 +538,12 @@ $ENV{"PATH"} = $FindBin::Bin .":$ENV{PATH}"; $rc = system("$fvbin/fix_gocart_rc.csh $vres $fvhome/run/gocart"); die "Failed to fix GOCART levels-referencing $!" if ( $rc ); -# LDAS Setup is done seperately, follow instructions in GEOS ldas -#----------------------------------------------------------------- +# LDAS Setup is done separately, follow instructions in GEOSldas/README.md +# ------------------------------------------------------------------------ print "\n checkprintout ldas_ana == 1 ($ldas_ana)\n"; if ($ldas_ana == 1 ) { - print "\n please run ldas_setup in the GEOS ldas setup directory\n"; - print "\n requires prepared exp_exeinp.txt exp_batinp.txt\n" ; + print "\n Please run ldas_setup following instructions in GEOSldas/README.md\n"; + print "\n requires config input files: YOUR_exeinp.txt, YOUR_batinp.txt.\n" ; print "\n example LDROOT: /discover/nobackup/$user/GEOSldas\n" ; print "\n example LDHOME: /discover/nobackup/$user/ldascoup_C180\n" ; print "\n example cd $LDROOT/install/bin/ \n"; @@ -7561,8 +7561,8 @@ print SCRIPT <<"EOF"; setenv GAAS_ANA $gaas_ana # 1 = aerosol analysis, 0 = disables it setenv GAASFDBK $gaasfdbk # 1 = feedback aerosol analysis into GCM, 0 = don't setenv SKIP_PSAS 0 # sets do_you_want_to_skip_PSAS in ana.rc.tmpl; 0 = no, 1 = yes - setenv LDAS_ANA $ldas_ana # 1 = land analysis, 0 = disables it - setenv LDASFDBK $ldasfdbk # 1 = feedback land analysis into GCM, 0 = don't + setenv LDAS_ANA $ldas_ana # 1 = land analysis, 0 = disables it + setenv LDASFDBK $ldasfdbk # 1 = read land analysis incr into GCM (feedback), 0 = don't setenv LDHOME $ldashome # land analysis home dir (ldas_exp/) for central setenv LDHOME4ens $ldashome4ens # land analysis home dir for atm_ens setenv IGNORE_0 1 # 1 = ignore 0 length obs files in acquire From 2a0c47054eba8f7efa45002b42df3e6e9d669e93 Mon Sep 17 00:00:00 2001 From: Rolf Reichle <54944691+gmao-rreichle@users.noreply.github.com> Date: Tue, 15 Jun 2021 18:21:00 -0400 Subject: [PATCH 043/205] updated comments/help text in ldas_add2rc --- src/Applications/GEOSdas_App/ldas_add2rc | 38 ++++++++++++++---------- 1 file changed, 22 insertions(+), 16 deletions(-) diff --git a/src/Applications/GEOSdas_App/ldas_add2rc b/src/Applications/GEOSdas_App/ldas_add2rc index dc252657..59999a1e 100755 --- a/src/Applications/GEOSdas_App/ldas_add2rc +++ b/src/Applications/GEOSdas_App/ldas_add2rc @@ -5,29 +5,31 @@ if [[ $# -ne 2 ]]; then echo " " echo " NAME " echo " " - echo " $MYNAME - precedure to add/verify land premeters in AGCM.rc " + echo " $MYNAME - reconcile GEOSldas and AGCM configurations in weakly-coupled LADAS " echo " " echo " SYNOPSIS " echo " " echo " $MYNAME FVHOME LDHOME" echo " " echo " where" - echo " FVHOME - location of adas experiment " - echo " LDHOME - location of ldas experiment " + echo " FVHOME - location of ADAS experiment " + echo " LDHOME - location of LDAS experiment " echo " " echo " DESCRIPTION" echo " " - echo " This procedure inserts additional land parameters in AGCM.rc" - echo " and verify if land parameters in AGCM.rc are consistent " - echo " with LDAS.rc in LADAS experiment " + echo " This procedure inserts select GEOSldas resource parameters into AGCM.rc and " + echo " verifies consistency between LDAS.rc and AGCM.rc for other resource parameters " echo " " - echo " It should be run after fvsetup and ldas_setup " + echo " $MYNAME should be run after fvsetup and ldas_setup " exit 0 fi FVHOME="$1" LDHOME="$2" +# ---------------------------------------------------------------- +# extract the following parameters from LDAS.rc and add to AGCM.rc + cd $FVHOME/run cp AGCM.rc.tmpl AGCM.rc.tmpl.original @@ -45,6 +47,18 @@ do echo "$(grep $var add.txt)" done +# add same resource parameters into AGCM.rc for atm ens +mv add.txt $FVHOME/run/atmens/. +cd $FVHOME/run/atmens/ +cp AGCM.rc.tmpl AGCM.rc.tmpl.original + +sed -i '/LDAS_INCR/r add.txt' AGCM.rc.tmpl + +rm -rf add.txt + +# ------------------------------------------------------------------------ +# check consistency of the following parameter between LDAS.rc and AGCM.rc + clist=" Z0_FORMULATION:.* LAND_PARAMS:.* LSM_CHOICE:.* " for var in $clist do @@ -54,18 +68,10 @@ lv="$(echo $Lset | cut -d " " -f 2)" av="$(echo $Aset | cut -d " " -f 2)" if [ "$lv" != "$av" ]; then echo " " -echo "Please make the following parameter value consistent in AGCM.rc and LDAS.rc:" +echo "Please repeat setup such that the following parameter values are consistent in AGCM.rc and LDAS.rc:" echo "in AGCM.rc: $Aset " echo "in LDAS.rc: $Lset " echo " " fi done -###atmens -mv add.txt $FVHOME/run/atmens/. -cd $FVHOME/run/atmens/ -cp AGCM.rc.tmpl AGCM.rc.tmpl.original - -sed -i '/LDAS_INCR/r add.txt' AGCM.rc.tmpl - -rm -rf add.txt From 74298102c0d0627563195d206d163fdd9bc0c7a8 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Tue, 6 Jul 2021 16:03:24 -0400 Subject: [PATCH 044/205] Update components to be in line with GCM --- components.yaml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/components.yaml b/components.yaml index bd797392..7e80e7c4 100644 --- a/components.yaml +++ b/components.yaml @@ -5,13 +5,13 @@ GEOSadas: env: local: ./@env remote: ../ESMA_env.git - tag: v3.2.1 + tag: v3.3.0 develop: main cmake: local: ./@cmake remote: ../ESMA_cmake.git - tag: v3.4.2 + tag: v3.5.0 develop: develop ecbuild: @@ -34,7 +34,7 @@ GMAO_Shared: MAPL: local: ./src/Shared/@MAPL remote: ../MAPL.git - tag: v2.6.7 + tag: v2.7.0 develop: develop FMS: @@ -71,7 +71,7 @@ GEOSagcmPert_GridComp: FVdycoreCubed_GridComp: local: ./src/Components/@GEOSgcm_GridComp/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/@FVdycoreCubed_GridComp remote: ../FVdycoreCubed_GridComp.git - tag: v1.2.13 + tag: v1.2.15 develop: develop fvdycore: @@ -121,7 +121,7 @@ mom6: GEOSgcm_App: local: ./src/Applications/@GEOSgcm_App remote: ../GEOSgcm_App.git - tag: v1.4.1 + tag: v1.5.2 develop: develop UMD_Etc: From 8b9e56faa448a8f2dc55213c975bf8dad28ac278 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 7 Jul 2021 09:25:47 -0400 Subject: [PATCH 045/205] Update components.yaml --- components.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/components.yaml b/components.yaml index 7e80e7c4..f047256c 100644 --- a/components.yaml +++ b/components.yaml @@ -46,7 +46,7 @@ FMS: GEOSana_GridComp: local: ./src/Components/@GEOSana_GridComp remote: ../GEOSana_GridComp.git - tag: v1.4.1 + branch: bugfix/mathomp4/geos-state-compiler-error develop: develop GEOSgcm_GridComp: From 249393a26fbe304f22c48b9c407196402e149a82 Mon Sep 17 00:00:00 2001 From: saraqzhang Date: Mon, 19 Jul 2021 13:54:14 -0400 Subject: [PATCH 046/205] add ldas_run.csh to dasscripts in GEOSdas_App/CMakeLists.txt --- src/Applications/GEOSdas_App/CMakeLists.txt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Applications/GEOSdas_App/CMakeLists.txt b/src/Applications/GEOSdas_App/CMakeLists.txt index c3beac5f..53981631 100644 --- a/src/Applications/GEOSdas_App/CMakeLists.txt +++ b/src/Applications/GEOSdas_App/CMakeLists.txt @@ -11,7 +11,8 @@ set(dasscripts fvsens fvsvec g54dvar - fp_seamless + fp_seamless + ldas_run.csh read_HIST.csh ) set(extraperlscripts From af8d327da95cd40e0afbdf53a730fccf7c3a9e88 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 21 Jul 2021 08:28:45 -0400 Subject: [PATCH 047/205] Update to GEOSana_GridComp v1.4.2 --- components.yaml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/components.yaml b/components.yaml index f047256c..e7bc38b4 100644 --- a/components.yaml +++ b/components.yaml @@ -11,7 +11,7 @@ env: cmake: local: ./@cmake remote: ../ESMA_cmake.git - tag: v3.5.0 + tag: v3.5.2 develop: develop ecbuild: @@ -46,7 +46,7 @@ FMS: GEOSana_GridComp: local: ./src/Components/@GEOSana_GridComp remote: ../GEOSana_GridComp.git - branch: bugfix/mathomp4/geos-state-compiler-error + tag: v1.4.2 develop: develop GEOSgcm_GridComp: @@ -101,8 +101,8 @@ geos-chem: GOCART: local: ./src/Components/@GEOSgcm_GridComp/GEOSagcm_GridComp/GEOSphysics_GridComp/@GEOSchem_GridComp/@GOCART remote: ../GOCART.git - sparse: ./config/GOCART.sparse tag: v1.0.1 + sparse: ./config/GOCART.sparse develop: develop mom: @@ -116,7 +116,7 @@ mom6: remote: ../MOM6.git tag: geos/v2.0.1 develop: dev/gfdl - recurse_submodules: True + recurse_submodules: true GEOSgcm_App: local: ./src/Applications/@GEOSgcm_App From 193cad6db42d102fbcb38169887fafdd40bd8b93 Mon Sep 17 00:00:00 2001 From: Joe Stassi Date: Fri, 23 Jul 2021 09:32:16 -0400 Subject: [PATCH 048/205] Updates for integrating RADMON processing into the ADAS --- src/Applications/GEOSdas_App/GEOSdas.csm | 1 + src/Applications/GEOSdas_App/fvsetup | 62 +++++++++++--- src/Applications/GEOSdas_App/gen_silo_arc.pl | 2 +- .../GEOSdas_App/monthly.yyyymm.pl.tmpl | 81 ++++++++++++++++--- src/Applications/GEOSdas_App/monthly_setup.pl | 4 + .../GEOSdas_App/write_FVDAS_Run_Config.pl | 6 +- 6 files changed, 129 insertions(+), 27 deletions(-) diff --git a/src/Applications/GEOSdas_App/GEOSdas.csm b/src/Applications/GEOSdas_App/GEOSdas.csm index 54f71fbd..f2bdd02e 100755 --- a/src/Applications/GEOSdas_App/GEOSdas.csm +++ b/src/Applications/GEOSdas_App/GEOSdas.csm @@ -140,6 +140,7 @@ if ( !($?LOCAL_ACQUIRE) ) setenv LOCAL_ACQUIRE 0 if ( !($?MAP05RST) ) setenv MAP05RST 0 if ( !($?MKRESRST ) ) setenv MKRESRST 0 + if ( !($?MONTHLY_RADMON) ) setenv MONTHLY_RADMON 0 if ( !($?MPIRUN_IDF) ) setenv MPIRUN_IDF 0 if ( !($?MPIRUN_UPRST) ) setenv MPIRUN_UPRST /dev/null if ( !($?NEWRADBC) ) setenv NEWRADBC 0 diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index adaf5a68..f94f1131 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -514,6 +514,7 @@ $ENV{"PATH"} = $FindBin::Bin .":$ENV{PATH}"; if ($DAO == 0) { while3 ( \&get_mhost ) } while3 ( \&get_output ); while3 ( \&get_history ); + while3 ( \&get_pyradmon ); while3 ( \&get_rstype ); while3 ( \&get_GID ); @@ -4556,6 +4557,29 @@ sub get_GID { return 0; } +#======================================================================= +sub get_pyradmon { + + #=========================================================# + # FOR NOW, TAKE DEFAULT RATHER THAN QUERYING FOR LOCATION # + #=========================================================# + $pyradmon = "/discover/nobackup/jstassi/GEOSadas/pyradmon"; + return; + #=========================================================# + + print "\n------------------------\n" + . "Pyradmon Source Location\n" + . "------------------------\n"; + + $pyradmon_dflt = "/discover/nobackup/jstassi/GEOSadas/pyradmon"; + $pyradmon = query("\n Pyradmon code location?", $pyradmon_dflt); + if (-d $pyradmon) { + $ENV{"PYRADMON"} = $pyradmon; + return; + } + return 1; +} + #======================================================================= sub get_dimsg5gcm { @@ -5184,9 +5208,11 @@ sub secs2hhmmss { sub mkdir_fvhome { # create directories on FVHOME print "\nSetting up FVHOME directory for $expid experiment ...\n"; - foreach $dir (qw(ana diag daotovs etc obs prog rs run recycle fcst asens anasa)) { - mkpath("$fvhome/$dir") - or die ">>> ERROR <<< creating directory $fvhome/$dir;"; + foreach $dir (qw(ana diag daotovs etc obs prog radmon)) { + mkpath("$fvhome/$dir") or die ">>> ERROR <<< creating directory $fvhome/$dir;"; + } + foreach $dir (qw(rs run recycle fcst asens anasa)) { + mkpath("$fvhome/$dir") or die ">>> ERROR <<< creating directory $fvhome/$dir;"; } foreach $subdir (qw( gaas gocart )) { mkpath("$fvhome/run/$subdir") @@ -7313,9 +7339,10 @@ if ((\$arch_type == "ADAS") && (\$\?yyyymm) && (\$\?dd)) then # defaults #--------- - if (! \$\?MONTHLY_MEANS ) set MONTHLY_MEANS = 1 - if (! \$\?MONTHLY_TAR ) set MONTHLY_TAR = 1 - if (! \$\?MONTHLY_PLOTS ) set MONTHLY_PLOTS = 0 + if (! \$\?MONTHLY_MEANS ) set MONTHLY_MEANS = 1 + if (! \$\?MONTHLY_TAR ) set MONTHLY_TAR = 1 + if (! \$\?MONTHLY_PLOTS ) set MONTHLY_PLOTS = 0 + if (! \$\?MONTHLY_RADMON ) set MONTHLY_RADMON = 0 # create job script for monthly post processing #---------------------------------------------- @@ -7335,14 +7362,12 @@ if ((\$arch_type == "ADAS") && (\$\?yyyymm) && (\$\?dd)) then # execute job script for monthly means processing #------------------------------------------------ set flags = "" - if (\$MONTHLY_MEANS) set flags = "\$flags -means" - if (\$MONTHLY_TAR) set flags = "\$flags -tar" - if (\$MONTHLY_PLOTS) set flags = "\$flags -plots" - - if (\$MONTHLY_MEANS || \$MONTHLY_TAR || \$MONTHLY_PLOTS) then - \$monthlyPost \$flags - endif + if (\$MONTHLY_MEANS) set flags = "\$flags -means" + if (\$MONTHLY_TAR) set flags = "\$flags -tar" + if (\$MONTHLY_PLOTS) set flags = "\$flags -plots" + if (\$MONTHLY_RADMON) set flags = "\$flags -radmon \$MONTHLY_RADMON" + if (\$flags != "") \$monthlyPost \$flags endif endif endif @@ -7631,6 +7656,7 @@ print SCRIPT <<"EOF"; setenv MONTHLY_MEANS $monthly_means # 1 = submit monthly means at end of month; 0 = don't setenv MONTHLY_TAR $monthly_tar # 1 = submit monthly tar job at end of month; 0 = don't setenv MONTHLY_PLOTS $monthly_plots # 1 = submit monthly plots job at end of month; 0 = don't + setenv MONTHLY_RADMON 0 # 1 = submit monthly radmon job; 2 = 2 jobs/month; 3 = 3 jobs/month; 0 = don't setenv NCSUFFIX $ncsuffix setenv STAGE4FSENS /dev/null setenv GAAS_ANA $gaas_ana # 1 = aerosol analysis, 0 = disables it @@ -8412,6 +8438,10 @@ EOF set vars = "\$vars,MONTHLY_PLOTS=\$MONTHLY_PLOTS" endif + if (\$\?MONTHLY_RADMON) then + set vars = "\$vars,MONTHLY_RADMON=\$MONTHLY_RADMON" + endif + # submit archive job # ------------------ if ( \$BATCH_SUBCMD == "sbatch" ) then @@ -9965,6 +9995,12 @@ sub copy_resources { $fname = "fvsavecf"; # config saving script $rc = system("/bin/cp $fvbin/$fname $fvhome/run/$fname"); die "Cannot write file $fvhome/run/$fname: $!" if ( $rc ); + + # Copy radmon.defaults.rc file to FVHOME/radmon + #---------------------------------------------- + if (-e "$pyradmon/scripts/radmon.defaults.rc") { + cp("$pyradmon/scripts/radmon.defaults.rc", "$fvhome/radmon"); + } } #======================================================================= diff --git a/src/Applications/GEOSdas_App/gen_silo_arc.pl b/src/Applications/GEOSdas_App/gen_silo_arc.pl index 9607767f..63d87329 100755 --- a/src/Applications/GEOSdas_App/gen_silo_arc.pl +++ b/src/Applications/GEOSdas_App/gen_silo_arc.pl @@ -86,7 +86,7 @@ sub init { # check for needed executables and rc #------------------------------------ $edhist_pl = "$fvroot/bin/edhist.pl"; - $echorc_x = "$fvroot/bin/echorc.x"; + $echorc_x = "$fvroot/bin/echorc.pl"; $gsidiags_rc = "$fvroot/etc/gsidiags.rc"; die "Error. Cannot find $edhist_pl;" unless -x $edhist_pl; diff --git a/src/Applications/GEOSdas_App/monthly.yyyymm.pl.tmpl b/src/Applications/GEOSdas_App/monthly.yyyymm.pl.tmpl index 1792ac4d..c3dba664 100644 --- a/src/Applications/GEOSdas_App/monthly.yyyymm.pl.tmpl +++ b/src/Applications/GEOSdas_App/monthly.yyyymm.pl.tmpl @@ -6,6 +6,7 @@ # > compute monthly means # > tar and clean monthly means inputs # > create monthly plots +# > run monthly radmon plots # Notes: # 1. To use this script, # - copy to experiment run directory @@ -53,12 +54,12 @@ use WriteLog qw(chdir_ mkpath_ unlink_ system_); # global variables #----------------- -my ($meansFLG, $plotsFLG, $tarFLG, $finish, $nopush, %doMeans); -my ($EXPID, $FVHOME, $PBS_BIN, $account, $listdir, $mnthlyRC); +my ($meansFLG, $plotsFLG, $radmonFLG, $tarFLG, $finish, $nopush, %doMeans); +my ($EXPID, $FVHOME, $PBS_BIN, $PYRADMON, $account, $listdir, $mnthlyRC); my ($numnodes_mm, $numnodes_mp, $plotHISTrc, $qcmd, $rundir); my ($script, $siteID, $workdir, $yyyymm, %newrc, %JOBID); my ($walltime_cl, $walltime_mm, $walltime_mp, $walltime_pf); -my ($partition, $qos); +my ($partition, $qos, $runlocal); #$partition = "preops"; #$qos = "dastest"; @@ -88,6 +89,7 @@ my %valid = ( "fetch" => 1, archive_monthly_keep_files(); } monthly_plots() if $plotsFLG; + radmon() if $radmonFLG; } #======================================================================= @@ -111,10 +113,14 @@ sub init { #----------------------- GetOptions( "means" => \$meansFLG, "tar" => \$tarFLG, + "plots" => \$plotsFLG, "finish_plots" => \$finish, "nopush" => \$nopush, + "radmon:i" => \$radmonFLG, + "runlocal" => \$runlocal, + "partition=s" => \$partition, "qos=s" => \$qos, @@ -125,6 +131,10 @@ sub init { "h|help" => \$help ); usage() if $help; + if (defined($radmonFLG)) { + $radmonFLG = 1 if $radmonFLG < 1 or $radmonFLG > 3; + } + # flags indicating whether to create new resource files #------------------------------------------------------ if ($#newrc == 0 and $newrc[0] eq "") { $newrc[0] = "1,2" } @@ -134,7 +144,8 @@ sub init { next unless m/^1$/ or m/^2$/; $newrc{$_} = 1; } - usage() unless $meansFLG or $tarFLG or $plotsFLG or $finish or %newrc; + usage() unless $meansFLG or $tarFLG or $plotsFLG or $finish + or $radmonFLG or %newrc; # process options #---------------- @@ -153,10 +164,11 @@ sub init { $opts{"debug"} = $debug if $debug; perl_config(%opts); - $EXPID = $ENV{"EXPID"}; - $FVHOME = $ENV{"FVHOME"}; - $PBS_BIN = $ENV{"PBS_BIN"}; - $GID = $ENV{"GID"}; + $EXPID = $ENV{"EXPID"}; + $FVHOME = $ENV{"FVHOME"}; + $PBS_BIN = $ENV{"PBS_BIN"}; + $PYRADMON = $ENV{"PYRADMON"}; + $GID = $ENV{"GID"}; $ENV{"PATH"} = "$rundir:$fvroot/bin:$ENV{PATH}"; @@ -870,6 +882,43 @@ sub finish_monthly_plots { } } +#======================================================================= +# name - radmon +# purpose - run pyradmon code +#======================================================================= +sub radmon { + my ($qFLG, $flags, $pyflags, $radmonRC); + + $qFLG = ""; + $qFLG = "-qjobs" unless $runlocal; + $flags = "-expid $EXPID -fvhome $FVHOME -np $qFLG"; + + $radmonRC = "$FVHOME/radmon/radmon.defaults.rc"; + $radmonRC = "" unless -e $radmonRC; + + if ($radmonFLG == 1) { + $pyflags = $flags ." -startdate ${yyyymm}01"; + system("$PYRADMON/scripts/pyradmon_driver.pl $radmonRC $pyflags"); + } + elsif ($radmonFLG == 2) { + $pyflags = $flags ." -startdate ${yyyymm}01 -enddate ${yyyymm}15"; + system("$PYRADMON/scripts/pyradmon_driver.pl $radmonRC $pyflags"); + + $pyflags = $flags ." -startdate ${yyyymm}16"; + system("$PYRADMON/scripts/pyradmon_driver.pl $radmonRC $pyflags"); + } + elsif ($radmonFLG == 3) { + $pyflags = $flags ." -startdate ${yyyymm}01 -enddate ${yyyymm}10"; + system("$PYRADMON/scripts/pyradmon_driver.pl $radmonRC $pyflags"); + + $pyflags = $flags ." -startdate ${yyyymm}11 -enddate ${yyyymm}20"; + system("$PYRADMON/scripts/pyradmon_driver.pl $radmonRC $pyflags"); + + $pyflags = $flags ." -startdate ${yyyymm}21"; + system("$PYRADMON/scripts/pyradmon_driver.pl $radmonRC $pyflags"); + } +} + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # UTILITY subroutines #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1043,11 +1092,21 @@ usage: $script [process options] [plot option] [other options] process options (see Notes below) -means calculate monthly means -tar tar input files + -plots produce monthly plots from monthly means -finish_plots finish monthly plots job which stopped before completion - -plot option (only valid when used with -plots or -finish_plots) - -nopush do not transfer gif files to Web server after plotting + -nopush do not transfer gif files to Web server after plotting; + only valid when used with -plots or -finish_plots flag + + -radmon [val] produce radmon plots (see -qjobs option) + if val == 1 ... produce plots for entire month + if val == 2 ... split month into 2 sets + if val == 3 ... split month into 3 sets + if no val is given, then set val to 1 + -runlocal run radmon jobs locally if archive is visible; otherwise, + jobs will automatically be sent to slurm queue; they will + be sent there regardless if archive is not visible; + only valid when used with -radmon flag slurm directive options -partition partition send monthly means jobs to specified partition diff --git a/src/Applications/GEOSdas_App/monthly_setup.pl b/src/Applications/GEOSdas_App/monthly_setup.pl index 647546c7..b5b6eb10 100755 --- a/src/Applications/GEOSdas_App/monthly_setup.pl +++ b/src/Applications/GEOSdas_App/monthly_setup.pl @@ -180,6 +180,10 @@ sub write_plotfiles { $values{"\@GEOSBIN"} = "$FVROOT/bin"; $values{"\@GEOSSRC"} = $ENV{"GEOSUTIL"}; + $values{"\@BATCH_TIME"} = "SBATCH --time="; + $values{"\@BATCH_JOBNAME"} = "SBATCH --jobname="; + $values{"\@BATCH_OUTPUTNAMEOUTPUT"} = "SBATCH --output=OUTPUT"; + replaceLabels($infile, $outfil, \%values,\@setenvs); # write gcm_moveplot.j; copy gcm_quickplot.csh diff --git a/src/Applications/GEOSdas_App/write_FVDAS_Run_Config.pl b/src/Applications/GEOSdas_App/write_FVDAS_Run_Config.pl index 5951cc18..0ebb4315 100755 --- a/src/Applications/GEOSdas_App/write_FVDAS_Run_Config.pl +++ b/src/Applications/GEOSdas_App/write_FVDAS_Run_Config.pl @@ -15,8 +15,8 @@ my ($FVHOME, $FVROOT, $RUNDIR); my ($AOD_OBSCLASS, $BERROR, $DO_ECS_OUT, $DO_REM_SYNC, $EXPID, $FVARCH, $FVBCS, $GID, $MONTHLY_MEANS, $MP_SET_NUMTHREADS, $NCEPINPUT, $NOBACKUP, - $OBSCLASS, $OBSCLASS_NOAIRS, $OMP_NUM_THREADS, $RUN_QUADS, $VTRACK, - $VTXLEVS, $VTXRELOC); + $OBSCLASS, $OBSCLASS_NOAIRS, $OMP_NUM_THREADS, $RUN_QUADS, $PYRADMON, + $VTRACK, $VTXLEVS, $VTXRELOC); my ($BASEDIR, $FCSTID, $FVDMGET, $G5MODULES, $PLOTS_LOC, $GEOSUTIL, $GTAG); my ($qalter, $PBS_BIN, $DISCOVERSHARE); my ($FVSHARE, $SHARE, $REM_GRADS_CONFIG, $G5MGRAM, $LATS4DLOC, $FVBIN, @@ -97,6 +97,7 @@ sub init { $OBSCLASS = $ENV{"OBSCLASS"}; $OBSCLASS_NOAIRS = $ENV{"OBSCLASS_NOAIRS"}; $OMP_NUM_THREADS = $ENV{"OMP_NUM_THREADS"}; + $PYRADMON = $ENV{"PYRADMON"}; $RUN_QUADS = $ENV{"RUN_QUADS"}; $VTRACK = $ENV{"VTRACK"}; $VTXLEVS = $ENV{"VTXLEVS"}; @@ -278,6 +279,7 @@ sub writefile { print RUNCONF "setenv FVARCH $FVARCH\n" if $FVARCH; print RUNCONF "setenv FVSPOOL $FVSPOOL\n" if $FVSPOOL; print RUNCONF "setenv BASEDIR $BASEDIR\n" if $BASEDIR; + print RUNCONF "setenv PYRADMON $PYRADMON\n" if $PYRADMON; print RUNCONF "#------------------------------\n"; print RUNCONF "setenv G5MODULES \"$G5MODULES\"\n" if $G5MODULES; print RUNCONF "source \$FVROOT/bin/g5_modules\n"; From 61a011c510c5fda7c13735d704d95c50fa539b30 Mon Sep 17 00:00:00 2001 From: Joe Stassi Date: Mon, 26 Jul 2021 11:39:39 -0400 Subject: [PATCH 049/205] Correct prompts in input file --- src/Applications/GEOSdas_App/testsuites/C48f.input | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Applications/GEOSdas_App/testsuites/C48f.input b/src/Applications/GEOSdas_App/testsuites/C48f.input index 2cbc6376..fbc4a60a 100644 --- a/src/Applications/GEOSdas_App/testsuites/C48f.input +++ b/src/Applications/GEOSdas_App/testsuites/C48f.input @@ -221,6 +221,9 @@ Output Restart TYPE (bin or nc4) [nc4] Select group: [g0613] > +Continue without missing resource files? [y] +> + Edit COLLECTIONS list in run/HISTORY.rc.tmpl (y/n)? [n] > y From 0a0141e0a75ec91c48dc6e39f1d2ec6636c64283 Mon Sep 17 00:00:00 2001 From: Joe Stassi Date: Mon, 9 Aug 2021 12:13:21 -0400 Subject: [PATCH 050/205] Fixed bug in shortcut code to take default $pyradmon value rather than querying for it. --- src/Applications/GEOSdas_App/fvsetup | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index f94f1131..a4fc8258 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -4560,18 +4560,19 @@ sub get_GID { #======================================================================= sub get_pyradmon { + $pyradmon_dflt = "/discover/nobackup/jstassi/GEOSadas/pyradmon"; + #=========================================================# # FOR NOW, TAKE DEFAULT RATHER THAN QUERYING FOR LOCATION # #=========================================================# - $pyradmon = "/discover/nobackup/jstassi/GEOSadas/pyradmon"; + $pyradmon = $pyradmon_dflt; + $ENV{"PYRADMON"} = $pyradmon; return; #=========================================================# print "\n------------------------\n" . "Pyradmon Source Location\n" . "------------------------\n"; - - $pyradmon_dflt = "/discover/nobackup/jstassi/GEOSadas/pyradmon"; $pyradmon = query("\n Pyradmon code location?", $pyradmon_dflt); if (-d $pyradmon) { $ENV{"PYRADMON"} = $pyradmon; From 0ec343899cc23872a2edb59f1183b7edd41e8379 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Mon, 16 Aug 2021 11:02:10 -0400 Subject: [PATCH 051/205] - allow access to /css - fix replay mode (now can replay and reproduce 3dvar) - fix prep scripts for ensemble forecast and obsens - filename template neeeded update --- src/Applications/GEOSdas_App/GEOSdas.csm | 172 +++++++++--------- src/Applications/GEOSdas_App/fvpsas | 24 +-- src/Applications/GEOSdas_App/fvsens | 5 +- src/Applications/GEOSdas_App/fvsetup | 8 +- .../GEOSdas_App/monthly.yyyymm.pl.tmpl | 22 ++- .../GEOSdas_App/monthly_prefetch.j.tmpl | 1 + src/Applications/GEOSdas_App/monthly_setup.pl | 2 +- .../GEOSdas_App/monthly_tarandclean.j.tmpl | 1 + .../GEOSdas_App/testsuites/x0046.input | 2 +- .../GEOSdas_App/testsuites/x0046_replay.input | 2 +- src/Applications/GSI_App/fvssi | 2 + .../NCEP_Etc/NCEP_enkf/scripts/gmao/atm_ens.j | 1 + .../scripts/gmao/atmens_prepgeps.csh | 36 ++-- .../scripts/gmao/atmens_prepobsens.csh | 97 +++++----- .../NCEP_Etc/NCEP_enkf/scripts/gmao/jobgen.pl | 5 + 15 files changed, 205 insertions(+), 175 deletions(-) diff --git a/src/Applications/GEOSdas_App/GEOSdas.csm b/src/Applications/GEOSdas_App/GEOSdas.csm index f2bdd02e..da53def9 100755 --- a/src/Applications/GEOSdas_App/GEOSdas.csm +++ b/src/Applications/GEOSdas_App/GEOSdas.csm @@ -118,6 +118,7 @@ if ( !($?CONVPROG) ) setenv CONVPROG 0 if ( !($?CONVSFC) ) setenv CONVSFC 0 if ( !($?CONVUPA) ) setenv CONVUPA 0 + if ( !($?DATAMOVE_CONSTRAINT) ) setenv DATAMOVE_CONSTRAINT NULL if ( !($?DIAG2ODS) ) setenv DIAG2ODS 0 if ( !($?DIAGTAR) ) setenv DIAGTAR 0 if ( !($?DO_0HR_IMP) ) setenv DO_0HR_IMP 0 @@ -174,12 +175,6 @@ #_RT if ( !($?STAGE4FCST) ) setenv STAGE4FCST 0 # need to resolve redundancies -# Sanity setting -# -------------- - if ( $SKIPANA ) then - setenv ASYNBKG 360 - endif - if ( $?RUN_OPT_BEGIN ) then set run_opt_begin = ( $RUN_OPT_BEGIN ) else @@ -448,7 +443,7 @@ exit 1 # Cannot do GAASFDBK unless GAAS_ANA is on # ---------------------------------------- if ( ! $FORECAST ) then - if ( $GAASFDBK && ( ! $GAAS_ANA ) ) then + if ( $GAAS_ANA && ( ! $GAASFDBK ) ) then echo $myname": GAAS inconsistency, GAASFDBK=$GAASFDBK, GAAS_ANA=$GAAS_ANA" exit 1 endif @@ -498,7 +493,6 @@ exit 1 # ----------------------------------------------------- if ( !($?obsclass) && !($?req_obsclass) ) then setenv SKIPANA 1 # no ANALYSIS - setenv ASYNBKG 360 endif # For readability, introduce DOING_ANA @@ -564,7 +558,7 @@ exit 1 # Set HISTORY gaas products on or off # ----------------------------------- - if ( $GAAS_ANA ) then + if ( $GAAS_ANA || -e replay_aod.rc ) then foreach hist ( `ls HIST*.rc.tmpl` ) edhist.pl $hist -i -Ipm gaas_bkg end @@ -1583,6 +1577,7 @@ exit 1 fname2 "#SBATCH --ntasks=1" fname2 "#SBATCH --time=2:00:00" fname2 "#SBATCH --partition=$data_queue" + fname2 "#$DATAMOVE_CONSTRAINT" fname2 "#SBATCH --account=$GID" fname2 "#PBS -N acqfcst" fname2 "#PBS -o acqfcst.log.$acqdate.txt" @@ -1789,6 +1784,7 @@ exit 1 fname2 "#SBATCH --ntasks=1" fname2 "#SBATCH --time=2:00:00" fname2 "#SBATCH --partition=$data_queue" + fname2 "#$DATAMOVE_CONSTRAINT" fname2 "#SBATCH --account=$GID" fname2 "#PBS -N acqaod4fcst" fname2 "#PBS -o acqaod4fcst.log.$acqdate.txt" @@ -2325,11 +2321,17 @@ exit 1 Sub AcquireReplayAnalysis_() # --------------------------------- if ( $?ECHO___ ) set echo + + if ( (! $?rpl_nymdb) && (! $?rpl_nhmsb)) then + set rpl_nymdb = $bnymd + set rpl_nhmsb = $bnhms + endif + # Acquire anlysis data for replay locally # ---------------------------------------- if ( (`uname -n` !~ borg*) || ( $LOCAL_ACQUIRE ) ) then acquire -v -rc replay.acq -s $spool -d $FVWORK -la $nlook -ssh \ - $strict $bnymd $bnhms $inhms $nstep + $strict $rpl_nymdb $rpl_nhmsb $inhms $nstep else # Do something special when on NCCS linux cluster @@ -2342,77 +2344,52 @@ exit 1 set data_queue="" endif - if ( $nstep > 4 ) set nstep = 4 - set qsub_acquire = 1 set fname = "acqreplay1.pbs" set acqdate = ${bnymd}_`echo $bnhms | cut -c1-2`z set acqlog = $FVHOME/run/acqreplay1.log.$acqdate.txt - while ( ( $bnymd <= $enymd[1] ) && ( ! -e "${FVWORK}/acquire.FAILED" ) ) - fname1 "#\!/bin/csh -xvf" - fname2 "#$group_list" - fname2 "#SBATCH --job-name=acqreplay1" - fname2 "#SBATCH --output=acqreplay1.log.$acqdate.txt" - fname2 "#SBATCH --ntasks=1" - fname2 "#SBATCH --time=2:00:00" - fname2 "#SBATCH --partition=$data_queue" - fname2 "#SBATCH --account=$GID" - fname2 "#PBS -N acqreplay1" - fname2 "#PBS -o acqreplay1.log.$acqdate.txt" - fname2 "#PBS -l nodes=1:ppn=1" - fname2 "#PBS -l walltime=2:00:00" - fname2 "#PBS -q $data_queue" - fname2 "#PBS -S /bin/csh" - fname2 "#PBS -j eo" - fname2 "" - fname2 "setenv DO_DMGET $DO_DMGET" - fname2 "set path = ( $path )" - fname2 "cd $FVWORK" - fname2 "acquire -v -rc replay.acq -s $spool -d $FVWORK -ssh $strict $bnymd $bnhms 060000 4" - fname2 "exit" - - if ( $BATCH_SUBCMD == "sbatch" ) then - sbatch -W -o $acqlog $fname - else - qsub -W block=true -o $acqlog $fname - endif - sleep 2 - set bnymd=`tick $bnymd` - end - - # Now do an acquire for tomorrows data - #------------------------------------- - if ( ( $nlook ) && ( ! -e "${FVWORK}/acquire.FAILED" ) ) then - set la_dtg=`tick $enymd 86400` - - set fname = "acqreplay2.pbs" - set acqdate = ${la_dtg[1]}_`echo $la_dtg[2] | cut -c1-2`z - set acqlog = $FVHOME/run/acqreplay2.log.$acqdate.txt - fname1 "#\!/bin/csh -xvf" - fname2 "#$group_list" - fname2 "#SBATCH --job-name=acqreplay2" - fname2 "#SBATCH --output=acqreplay2.log.$acqdate.txt" - fname2 "#SBATCH --ntasks=1" - fname2 "#SBATCH --time=2:00:00" - fname2 "#SBATCH --partition=$data_queue" - fname2 "#SBATCH --account=$GID" - fname2 "#PBS -N acqreplay2" - fname2 "#PBS -o acqreplay2.log.$acqdate.txt" - fname2 "#PBS -l nodes=1:ppn=1" - fname2 "#PBS -l walltime=2:00:00" - fname2 "#PBS -q $data_queue" - fname2 "#PBS -S /bin/csh" - fname2 "#PBS -j eo" - fname2 "" - fname2 "setenv DO_DMGET $DO_DMGET" - fname2 "set path = ( $path )" - fname2 "cd $FVWORK" - fname2 "acquire -v -rc replay.acq -d $spool -s $spool -ssh $la_dtg[1] $la_dtg[2] 06000 4" - fname2 "exit" + @ hours = $ASYNBKG * 60 + set init_date = (`tick $rpl_nymdb $rpl_nhmsb -$hours` ) + fname1 "#\!/bin/csh -xvf" + fname2 "#$group_list" + fname2 "#SBATCH --job-name=acqreplay1" + fname2 "#SBATCH --output=acqreplay1.log.$acqdate.txt" + fname2 "#SBATCH --ntasks=1" + fname2 "#SBATCH --time=2:00:00" + fname2 "#SBATCH --partition=$data_queue" + fname2 "#$DATAMOVE_CONSTRAINT" + fname2 "#SBATCH --account=$GID" + fname2 "#PBS -N acqreplay1" + fname2 "#PBS -o acqreplay1.log.$acqdate.txt" + fname2 "#PBS -l nodes=1:ppn=1" + fname2 "#PBS -l walltime=2:00:00" + fname2 "#PBS -q $data_queue" + fname2 "#PBS -S /bin/csh" + fname2 "#PBS -j eo" + fname2 "" + fname2 "setenv DO_DMGET $DO_DMGET" + fname2 "set path = ( $path )" + fname2 "cd $FVWORK" + fname2 "acquire -v -rc replay.acq -s $spool -d $FVWORK -ssh $strict $rpl_nymdb $rpl_nhmsb 060000 1" + fname2 "if ( -e replay_aod.acq ) then" + fname2 " acquire -v -rc replay_aod.acq -s $spool -d $FVWORK -ssh $strict $rpl_nymdb $rpl_nhmsb 030000 2" + fname2 "endif" + fname2 "if ( -e replay_agcm.acq ) then" + fname2 " acquire -v -rc replay_agcm.acq -s $spool -d $FVWORK -ssh $strict $init_date[1] $init_date[2] 060000 1" + fname2 "endif" + fname2 "" + fname2 "exit" - $BATCH_SUBCMD -o $acqlog $fname - set acq_status = $status - endif # if nlook + if ( $BATCH_SUBCMD == "sbatch" ) then + sbatch -W -o $acqlog $fname + else + qsub -W block=true -o $acqlog $fname + endif + sleep 2 + @ cyc_sec = $TIMEINC * 60 + set next_cycle = (`tick $rpl_nymdb $rpl_nhmsb $cyc_sec`) + set rpl_nymdb = $next_cycle[1] + set rpl_nhmsb = $next_cycle[2] endif # test for borg* @@ -3484,16 +3461,34 @@ endif if ( -e mkiau.rc.tmpl ) then - /bin/rm -f sed_file - echo "s/>>>EXPID<< sed_file - echo "s/>>>BKGFNAME<<> sed_file - echo "s/>>>ANAFNAME<<> sed_file - echo "s/>>>NCSUFFIX<<> sed_file - echo "s/>>>ANADATE<<> sed_file - echo "s/>>>ANATIME<<> sed_file - /bin/rm -f ./mkiau.rc - sed -f sed_file ./mkiau.rc.tmpl > ./mkiau.rc - $makeiaux + if ( -e replay.acq && -e replay_agcm.acq ) then + touch IAU_EGRESS + set myiau_full = `echorc.x -template $EXPID $gcm_nymd0 $gcm_nhms0 iau_tendency_filename` + set myiau_shrt = `echorc.x -rc mkiau.rc.tmpl -template $EXPID $gcm_nymd0 $gcm_nhms0 AGCM_INTERNAL_CHECKPOINT_FILE` + if ( -e $myiau_full ) then + /bin/cp $myiau_full $myiau_shrt + else + echo "Cannot find: $myiau_full" + set status = 1 + if ( ${status} ) then + Call AbnormalExit_( 4 ) + endif + endif + else + + /bin/rm -f sed_file + + echo "s/>>>EXPID<< sed_file + echo "s/>>>BKGFNAME<<> sed_file + echo "s/>>>ANAFNAME<<> sed_file + echo "s/>>>NCSUFFIX<<> sed_file + echo "s/>>>ANADATE<<> sed_file + echo "s/>>>ANATIME<<> sed_file + /bin/rm -f ./mkiau.rc + sed -f sed_file ./mkiau.rc.tmpl > ./mkiau.rc + $makeiaux + + endif else @@ -5688,11 +5683,6 @@ endif if ( $FORECAST ) then /bin/rm d_rst mkdrstdate.x $fcst_end # create d_rst with current date and time - else if ( $SKIPANA ) then - set GcmEndDate = $GcmEndEpoch[1] - set GcmEndTime = $GcmEndEpoch[2] - /bin/rm d_rst - mkdrstdate.x $GcmEndDate $GcmEndTime endif set buf = `rst_date d_rst` diff --git a/src/Applications/GEOSdas_App/fvpsas b/src/Applications/GEOSdas_App/fvpsas index a6548a51..4f054673 100755 --- a/src/Applications/GEOSdas_App/fvpsas +++ b/src/Applications/GEOSdas_App/fvpsas @@ -302,31 +302,25 @@ exit 100 endif endif - zeit_ci.x acquire # Acquire "replay" analysis or observations # ----------------------------------------- if ( ! $FORECAST && $AnaFreqEpoch[2] > 0 ) then + zeit_ci.x acquire + # Determine relevant time/frequency information # --------------------------------------------- Call DetermineAcquireTimes_() -# Acquire replay analysis... -# ----------------------------------------- - if ( -e replay.acq ) then - - Call AcquireReplayAnalysis_() - -# .. or observational data -# ------------------------ - else if ( $DOING_ANA ) then +# If so, aquire observational data +# -------------------------------- + if ( $DOING_ANA ) then Call AcquireObservations_() endif - endif zeit_co.x acquire # Pre-analysis Quality Control @@ -371,6 +365,14 @@ @ seg = 0 while ( $seg < $nsegs ) +# Acquire replay analysis... +# -------------------------- + if ( -e replay.acq ) then + + Call AcquireReplayAnalysis_() + + endif + # Determines times/frequencies for this segment # --------------------------------------------- Call SplitExecSegmentTimes_() diff --git a/src/Applications/GEOSdas_App/fvsens b/src/Applications/GEOSdas_App/fvsens index 430481d0..9011e2d2 100755 --- a/src/Applications/GEOSdas_App/fvsens +++ b/src/Applications/GEOSdas_App/fvsens @@ -93,6 +93,7 @@ endif if ( !($?BATCH_SUBCMD) ) setenv BATCH_SUBCMD "sbatch" if ( !($?FCSTVERIFY) ) setenv FCSTVERIFY asm if ( !($?CORRECT4IAU) ) setenv CORRECT4IAU 0 +if ( !($?DATAMOVE_CONSTRAINT) ) setenv DATAMOVE_CONSTRAINT NULL if ( !($?VEXPID) ) setenv VEXPID $EXPID if ( !($?NCVRFANA) ) setenv NCVRFANA 0 if ( !($?LOCJGRADF) ) setenv LOCJGRADF 0 @@ -441,8 +442,8 @@ while ( $ic < $ntp1 ) fname2 "#SBATCH --ntasks=1" fname2 "#SBATCH --time=1:00:00" fname2 "#SBATCH --partition=$data_queue" + fname2 "#$DATAMOVE_CONSTRAINT" fname2 "#SBATCH --account=$GID" - fname2 "#SBATCH --partition=datamove" fname2 "#SBATCH --time=1:00:00" fname2 "#PBS -N acquire" fname2 "#PBS -o acquire.log.o%j" @@ -679,8 +680,8 @@ while ( $ic < $ntp1 ) fname2 "#SBATCH --ntasks=1" fname2 "#SBATCH --time=1:00:00" fname2 "#SBATCH --partition=$data_queue" + fname2 "#$DATAMOVE_CONSTRAINT" fname2 "#SBATCH --account=$GID" - fname2 "#SBATCH --partition=datamove" fname2 "#SBATCH --time=1:00:00" fname2 "#PBS -N acquire" fname2 "#PBS -o acquire.log.o%j" diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index f94f1131..ae9eacb0 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -7220,6 +7220,7 @@ print SCRIPT <<"EOF"; #$group_list ##$export_none #$jobqueue2 +##SBATCH --constraint=cssrw #SBATCH --time=${arcwallclk}:00 #SBATCH --job-name=arch_$expid #SBATCH --output=arch_$expid.log.o%j.txt @@ -8490,7 +8491,11 @@ EOF echo2 "#SBATCH --partition=datamove" echo2 "#SBATCH --time=1:00:00" echo2 "##SBATCH --export=NONE" - echo2 "#SBATCH --constraint=$nodeflg" + if ( \$?DATAMOVE_CONSTRAINT ) then + echo2 "#\$DATAMOVE_CONSTRAINT" + else + echo2 "#SBATCH --constraint=$nodeflg" + endif echo2 "" echo2 "setenv FVHOME \$FVHOME" echo2 "set Bin = \$Bin" @@ -9223,6 +9228,7 @@ print SCRIPT <<"EOF"; fname2 "#SBATCH --ntasks=1" fname2 "#SBATCH --time=1:00:00" fname2 "#SBATCH --partition=datamove" + fname2 "#\$DATAMOVE_CONSTRAINT" fname2 "#SBATCH --account=$gid" fname2 "#SBATCH --output=acq.log.o%j.txt" fname2 "#PBS -N acquire" diff --git a/src/Applications/GEOSdas_App/monthly.yyyymm.pl.tmpl b/src/Applications/GEOSdas_App/monthly.yyyymm.pl.tmpl index c3dba664..51bdc9be 100644 --- a/src/Applications/GEOSdas_App/monthly.yyyymm.pl.tmpl +++ b/src/Applications/GEOSdas_App/monthly.yyyymm.pl.tmpl @@ -397,6 +397,7 @@ sub fetch_inputs { my (%opts, $filestring, $ftype, $htype, $do_dmput, $do_tar); my ($tmpl, $prefetch_j, $jobname, $outfile); my ($job_name, $time, $output, $parFLG, $vFLG); + my ($constraint); my (%value, @deps, $dependFLG, $cmd); # input arguments @@ -421,6 +422,7 @@ sub fetch_inputs { $time = "SBATCH --time=$walltime_pf"; $output = "SBATCH --output=$outfile"; $parFLG = "SBATCH --partition=datamove"; + $constraint = "$DATAMOVE_CONSTRAINT": $vFLG = "--export=outfile=$outfile"; } else { @@ -428,6 +430,7 @@ sub fetch_inputs { $time = "PBS -l walltime=$walltime_pf"; $output = "PBS -o $outfile"; $parFLG = ""; + $constraint = ""; $vFLG = "-v outfile=$outfile"; } @@ -437,6 +440,7 @@ sub fetch_inputs { $value{"__ACCOUNT__"} = $account; $value{"__OUTPUT__"} = $output; $value{"__PARTITION__"} = $parFLG; + $value{"__CONSTRAINT__"} = $constraint; $value{"__FILESTRING__"} = $filestring; $value{"__HOURTYPE__"} = $htype; @@ -565,6 +569,7 @@ sub tar_and_clean_inputs { my (%opts, $filestring, $ftype, $do_tar, $lastFLG); my ($tmpl, $tarandclean_j, $jobname, $outfile); my ($job_name, $time, $output, $parFLG, $vFLG); + my ($constraint); my (%value, $walltime, @deps, $dependFLG, $cmd); # input arguments @@ -588,6 +593,7 @@ sub tar_and_clean_inputs { $time = "SBATCH --time=$walltime_cl"; $output = "SBATCH --output=$outfile"; $parFLG = "SBATCH --partition=datamove"; + $constraint = "$DATAMOVE_CONSTRAINT"; $vFLG = "--export=outfile=$outfile"; } else { @@ -595,6 +601,7 @@ sub tar_and_clean_inputs { $time = "PBS -l walltime=$walltime_cl"; $output = "PBS -o $outfile"; $parFLG = ""; + $constraint = ""; $vFLG = "-v outfile=$outfile"; } @@ -604,6 +611,7 @@ sub tar_and_clean_inputs { $value{"__ACCOUNT__"} = $account; $value{"__OUTPUT__"} = $output; $value{"__PARTITION__"} = $parFLG; + $value{"__CONSTRAINT__"} = $constraint; $value{"__FILESTRING__"} = $filestring; $value{"__YYYYMM__"} = $yyyymm; @@ -639,6 +647,7 @@ sub tar_and_clean_inputs { sub archive_monthly_keep_files { my ($outfile, $vars, $vFLG, $outFLG, $qFLGs, @deps, $dependFLG); my ($KEEParc_csh, $cmd, $cmd_save); + my ($constraint,$dummy); # command flags #-------------- @@ -648,10 +657,14 @@ sub archive_monthly_keep_files { . "outfile=$outfile"; if ($siteID eq "nccs") { + $constraint = ""; + if ($DATAMOVE_CONSTRAINT) { + ($dummy, $constraint) = (split / /, $DATAMOVE_CONSTRAINT)[0, 1]; + } $vFLG = "--export=$vars"; $outFLG = "--output=$outfile"; $qFLGs = "--job-name=KEEParc.$yyyymm --time=$walltime_cl" - . " --partition=datamove"; + . " --partition=datamove $constraint"; } else { $vFLG = "-v $vars"; @@ -695,6 +708,7 @@ sub archive_monthly_keep_files { sub archive_monthly_files { my ($outfile, $vars, $vFLG, $outFLG, $qFLGs, @deps, $dependFLG); my ($MPParc_csh, $cmd, $cmd_save); + my ($dummy, $constraint); # command flags #-------------- @@ -705,10 +719,14 @@ sub archive_monthly_files { . "mmid=$$"; if ($siteID eq "nccs") { + $constraint = ""; + if ($DATAMOVE_CONSTRAINT) { + ($dummy, $constraint) = (split / /, $DATAMOVE_CONSTRAINT)[0, 1]; + } $vFLG = "--export=$vars"; $outFLG = "--output=$outfile"; $qFLGs = "--job-name=MPParc.$yyyymm --nodes=1 --time=$walltime_cl" - . " --partition=datamove"; + . " --partition=datamove $constraint"; } else { $vFLG = "-v $vars"; diff --git a/src/Applications/GEOSdas_App/monthly_prefetch.j.tmpl b/src/Applications/GEOSdas_App/monthly_prefetch.j.tmpl index b6e4e31d..52f7fab7 100644 --- a/src/Applications/GEOSdas_App/monthly_prefetch.j.tmpl +++ b/src/Applications/GEOSdas_App/monthly_prefetch.j.tmpl @@ -5,6 +5,7 @@ #__ACCOUNT__ #__OUTPUT__ #__PARTITION__ +#__CONSTRAINT__ #SBATCH --no-requeue #SBATCH --export=NONE #PBS -S /bin/csh diff --git a/src/Applications/GEOSdas_App/monthly_setup.pl b/src/Applications/GEOSdas_App/monthly_setup.pl index b5b6eb10..0f570bad 100755 --- a/src/Applications/GEOSdas_App/monthly_setup.pl +++ b/src/Applications/GEOSdas_App/monthly_setup.pl @@ -181,7 +181,7 @@ sub write_plotfiles { $values{"\@GEOSSRC"} = $ENV{"GEOSUTIL"}; $values{"\@BATCH_TIME"} = "SBATCH --time="; - $values{"\@BATCH_JOBNAME"} = "SBATCH --jobname="; + $values{"\@BATCH_JOBNAME"} = "SBATCH --job-name="; $values{"\@BATCH_OUTPUTNAMEOUTPUT"} = "SBATCH --output=OUTPUT"; replaceLabels($infile, $outfil, \%values,\@setenvs); diff --git a/src/Applications/GEOSdas_App/monthly_tarandclean.j.tmpl b/src/Applications/GEOSdas_App/monthly_tarandclean.j.tmpl index 503b0fb7..f0ad1da2 100644 --- a/src/Applications/GEOSdas_App/monthly_tarandclean.j.tmpl +++ b/src/Applications/GEOSdas_App/monthly_tarandclean.j.tmpl @@ -5,6 +5,7 @@ #__ACCOUNT__ #__OUTPUT__ #__PARTITION__ +#__CONSTRAINT__ #SBATCH --no-requeue #SBATCH --export=NONE #PBS -S /bin/csh diff --git a/src/Applications/GEOSdas_App/testsuites/x0046.input b/src/Applications/GEOSdas_App/testsuites/x0046.input index 72252c71..28ef7ecb 100644 --- a/src/Applications/GEOSdas_App/testsuites/x0046.input +++ b/src/Applications/GEOSdas_App/testsuites/x0046.input @@ -143,7 +143,7 @@ Which main class of ObsSys (1: NRT; 2: MERRA; 3: MERRA-2)? [1] > OBSERVING SYSTEM CLASSES? -> disc_airs_bufr,disc_amsua_bufr,gmao_amsr2_bufr,gmao_gmi_bufr,mls_nrt_nc,ncep_1bamua_bufr,ncep_1bhrs4_bufr,ncep_acftpfl_bufr,ncep_atms_bufr,ncep_aura_omi_bufr,ncep_avcsam_bufr,ncep_avcspm_bufr,ncep_crisfsr_bufr,ncep_goesfv_bufr,ncep_gpsro_com_bufr,ncep_mhs_bufr,ncep_mtiasi_bufr,ncep_prep_bufr,ncep_satwnd_bufr,ncep_sevcsr_bufr,ncep_ssmis_bufr,ncep_tcvitals,npp_ompsnm_bufr +> disc_airs_bufr,disc_amsua_bufr,gmao_amsr2_bufr,gmao_gmi_bufr,mls_nrt_nc,ncep_1bamua_bufr,ncep_1bhrs4_bufr,ncep_acftpfl_bufr,ncep_atms_bufr,ncep_aura_omi_bufr,ncep_avcsam_bufr,ncep_avcspm_bufr,ncep_crisfsr_bufr,ncep_goesfv_bufr,ncep_gpsro_com_bufr,ncep_mhs_bufr,ncep_mtiasi_bufr,ncep_prep_bufr,ncep_satwnd_bufr,ncep_sevcsr_bufr,ncep_ssmis_bufr,ncep_tcvitals,npp_ompsnm_bufr,gmao_mlst_bufr CHECKING OBSYSTEM? [2] > 1 diff --git a/src/Applications/GEOSdas_App/testsuites/x0046_replay.input b/src/Applications/GEOSdas_App/testsuites/x0046_replay.input index 391cf6ab..d2437187 100644 --- a/src/Applications/GEOSdas_App/testsuites/x0046_replay.input +++ b/src/Applications/GEOSdas_App/testsuites/x0046_replay.input @@ -143,7 +143,7 @@ Which main class of ObsSys (1: NRT; 2: MERRA; 3: MERRA-2)? [1] > OBSERVING SYSTEM CLASSES? -> disc_airs_bufr,disc_amsua_bufr,gmao_amsr2_bufr,gmao_gmi_bufr,mls_nrt_nc,ncep_1bamua_bufr,ncep_1bhrs4_bufr,ncep_acftpfl_bufr,ncep_atms_bufr,ncep_aura_omi_bufr,ncep_avcsam_bufr,ncep_avcspm_bufr,ncep_crisfsr_bufr,ncep_goesfv_bufr,ncep_gpsro_com_bufr,ncep_mhs_bufr,ncep_mtiasi_bufr,ncep_prep_bufr,ncep_satwnd_bufr,ncep_sevcsr_bufr,ncep_ssmis_bufr,ncep_tcvitals,npp_ompsnm_bufr +> disc_airs_bufr,disc_amsua_bufr,gmao_amsr2_bufr,gmao_gmi_bufr,mls_nrt_nc,ncep_1bamua_bufr,ncep_1bhrs4_bufr,ncep_acftpfl_bufr,ncep_atms_bufr,ncep_aura_omi_bufr,ncep_avcsam_bufr,ncep_avcspm_bufr,ncep_crisfsr_bufr,ncep_goesfv_bufr,ncep_gpsro_com_bufr,ncep_mhs_bufr,ncep_mtiasi_bufr,ncep_prep_bufr,ncep_satwnd_bufr,ncep_sevcsr_bufr,ncep_ssmis_bufr,ncep_tcvitals,npp_ompsnm_bufr,gmao_mlst_bufr CHECKING OBSYSTEM? [2] > 1 diff --git a/src/Applications/GSI_App/fvssi b/src/Applications/GSI_App/fvssi index a8572c77..05793097 100755 --- a/src/Applications/GSI_App/fvssi +++ b/src/Applications/GSI_App/fvssi @@ -53,6 +53,7 @@ if ( !($?ANA4DUPD_IAU0_ONLY) ) setenv ANA4DUPD_IAU0_ONLY 0 # assume 4d increment if ( !($?ANGLEBC) ) setenv ANGLEBC 0 if ( !($?BATCH_SUBCMD) ) setenv BATCH_SUBCMD "sbatch" + if ( !($?DATAMOVE_CONSTRAINT) ) setenv DATAMOVE_CONSTRAINT NULL if ( !($?INCSENS) ) setenv INCSENS 0 if ( !($?GSI_NETCDF_DIAG) ) setenv GSI_NETCDF_DIAG 0 if ( !($?SPECRES) ) setenv FAILED 1 @@ -322,6 +323,7 @@ fname2 "#PBS -j eo" fname2 "#SBATCH -A $GID" fname2 "#SBATCH --partition=datamove" + fname2 "#$DATAMOVE_CONSTRAINT" fname2 "#SBATCH --time=1:00:00" fname2 "" fname2 "cd $FVWORK" diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atm_ens.j b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atm_ens.j index 9dfb7027..0c50a534 100755 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atm_ens.j +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atm_ens.j @@ -47,6 +47,7 @@ # ---------------------- # setenv JOBGEN_PARTITION preops # setenv JOBGEN_QOS dastest +# setenv JOBGEN_ARCH_CONSTRAINT cssrw setenv JOBGEN_CONSTRAINT >>>NODEFLG<<< setenv ATMENS_QNAME compute if ( $?JOBGEN_PARTITION ) then diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmens_prepgeps.csh b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmens_prepgeps.csh index 0a453a6e..ec16e422 100755 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmens_prepgeps.csh +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmens_prepgeps.csh @@ -420,7 +420,7 @@ foreach times ( 1 $xtratime ) endif else echo "${MYNAME}: unfolding non-inflated ensemble of analyses ... " - $DRYRUN tar xvf $expid.atmens_e${ttype}.${tnymd}_${thh}z.tar --wildcards --no-anchored "*${SRCEXPID}.${ttype}.eta.${gnymd}_${ghh}z.$NCSUFFIX" + $DRYRUN tar xvf $expid.atmens_e${ttype}.${tnymd}_${thh}z.tar --wildcards --no-anchored "*${SRCEXPID}.${ttype}.eta.${gnymd}_${ghh}00z.$NCSUFFIX" if ( $SRCEXPID != $expid && -d $SRCEXPID.atmens_e${ttype}.${tnymd}_${thh}z ) then $DRYRUN /bin/mv $SRCEXPID.atmens_e${ttype}.${tnymd}_${thh}z $expid.atmens_e${ttype}.${tnymd}_${thh}z endif @@ -502,19 +502,19 @@ endif if ($ATMENS_GEPS_RECENTER) then cd $ENSWORK if ( ! -d central ) mkdir -p central - if ( ! -e central/$expid.ana.eta.${anymd}_${ahh}z.$NCSUFFIX ) then + if ( ! -e central/$expid.ana.eta.${anymd}_${ahh}00z.$NCSUFFIX ) then if ( $action == "setrc" ) then if ( $SRCEXPID == $expid ) then - echo $DATADIR/$expid/ana/Y$ayyyy/M$amm/$expid.ana.eta.${anymd}_${ahh}z.$NCSUFFIX >> $ACQRC + echo $DATADIR/$expid/ana/Y$ayyyy/M$amm/$expid.ana.eta.${anymd}_${ahh}00z.$NCSUFFIX >> $ACQRC else - echo "$DATADIR/$SRCEXPID/ana/Y$ayyyy/M$amm/$SRCEXPID.ana.eta.${anymd}_${ahh}z.$NCSUFFIX => $expid.ana.eta.${anymd}_${ahh}z.$NCSUFFIX" >> $ACQRC + echo "$DATADIR/$SRCEXPID/ana/Y$ayyyy/M$amm/$SRCEXPID.ana.eta.${anymd}_${ahh}00z.$NCSUFFIX => $expid.ana.eta.${anymd}_${ahh}00z.$NCSUFFIX" >> $ACQRC endif else - if ( -e $expid.ana.eta.${anymd}_${ahh}z.$NCSUFFIX ) then - /bin/mv $expid.ana.eta.${anymd}_${ahh}z.$NCSUFFIX central/ + if ( -e $expid.ana.eta.${anymd}_${ahh}00z.$NCSUFFIX ) then + /bin/mv $expid.ana.eta.${anymd}_${ahh}00z.$NCSUFFIX central/ if ( $atype != "ana" ) then # link needed to ease connection w/ recentering script cd central - ln -sf $expid.ana.eta.${anymd}_${ahh}z.$NCSUFFIX $expid.$atype.eta.${anymd}_${ahh}z.$NCSUFFIX + ln -sf $expid.ana.eta.${anymd}_${ahh}00z.$NCSUFFIX $expid.$atype.eta.${anymd}_${ahh}00z.$NCSUFFIX cd - endif endif @@ -525,17 +525,17 @@ endif # verification options: central assimilation or central analysis if ( $aver == "casm" || $aver == "cana" ) then set Aver = `echo $aver | cut -c2-` - if ( ! -e $expid.$Aver.eta.${av0nymd}_${av0hh}z.$NCSUFFIX ) then + if ( ! -e $expid.$Aver.eta.${av0nymd}_${av0hh}00z.$NCSUFFIX ) then if ( $action == "setrc" ) then if ( $SRCEXPID == $expid ) then - echo $DATADIR/$expid/ana/Y$av0yyyy/M$av0mm/$expid.$Aver.eta.${av0nymd}_${av0hh}z.$NCSUFFIX >> $ACQRC + echo $DATADIR/$expid/ana/Y$av0yyyy/M$av0mm/$expid.$Aver.eta.${av0nymd}_${av0hh}00z.$NCSUFFIX >> $ACQRC else - echo "$DATADIR/$SRCEXPID/ana/Y$av0yyyy/M$av0mm/$SRCEXPID.$Aver.eta.${av0nymd}_${av0hh}z.$NCSUFFIX => $expid.$Aver.eta.${av0nymd}_${av0hh}z.$NCSUFFIX" >> $ACQRC + echo "$DATADIR/$SRCEXPID/ana/Y$av0yyyy/M$av0mm/$SRCEXPID.$Aver.eta.${av0nymd}_${av0hh}00z.$NCSUFFIX => $expid.$Aver.eta.${av0nymd}_${av0hh}00z.$NCSUFFIX" >> $ACQRC endif else foreach dir (`/bin/ls -d mem*`) cd $dir - ln -s ../$expid.$Aver.eta.${av0nymd}_${av0hh}z.$NCSUFFIX . + ln -s ../$expid.$Aver.eta.${av0nymd}_${av0hh}00z.$NCSUFFIX . cd - end endif @@ -552,7 +552,7 @@ if ( $aver == "niana" ) then endif else echo "${MYNAME}: unfolding non-inflated ensemble of analyses ... " - $DRYRUN tar xvf $expid.atmens_eniana.${xav0nymd}_${xav0hh}z.tar --wildcards --no-anchored "*${SRCEXPID}.niana.eta.${av0nymd}_${av0hh}z.$NCSUFFIX" + $DRYRUN tar xvf $expid.atmens_eniana.${xav0nymd}_${xav0hh}z.tar --wildcards --no-anchored "*${SRCEXPID}.niana.eta.${av0nymd}_${av0hh}00z.$NCSUFFIX" if ( $SRCEXPID != $expid && -d $SRCEXPID.atmens_eniana.${xav0nymd}_${xav0hh}z ) then $DRYRUN /bin/mv $SRCEXPID.atmens_eniana.${xav0nymd}_${xav0hh}z $expid.atmens_eniana.${xav0nymd}_${xav0hh}z endif @@ -582,15 +582,15 @@ if ( $aver == "emana" ) then endif else echo "${MYNAME}: unfolding non-inflated ensemble of analyses ... " - $DRYRUN tar xvf $expid.atmens_stat.${xav0nymd}_${xav0hh}z.tar --wildcards --no-anchored "ensmean/*${SRCEXPID}.ana.eta.${av0nymd}_${av0hh}z.$NCSUFFIX" + $DRYRUN tar xvf $expid.atmens_stat.${xav0nymd}_${xav0hh}z.tar --wildcards --no-anchored "ensmean/*${SRCEXPID}.ana.eta.${av0nymd}_${av0hh}00z.$NCSUFFIX" if ( $SRCEXPID != $expid && -d $SRCEXPID.atmens_stat.${xav0nymd}_${xav0hh}z ) then $DRYRUN /bin/mv $SRCEXPID.atmens_stat.${xav0nymd}_${xav0hh}z $expid.atmens_stat.${xav0nymd}_${xav0hh}z endif if (! -d ensmean ) mkdir ensmean - /bin/mv $expid.atmens_stat.${xav0nymd}_${xav0hh}z/ensmean/$SRCEXPID.ana.eta.${av0nymd}_${av0hh}z.$NCSUFFIX ensmean/$expid.ana.eta.${av0nymd}_${av0hh}z.$NCSUFFIX + /bin/mv $expid.atmens_stat.${xav0nymd}_${xav0hh}z/ensmean/$SRCEXPID.ana.eta.${av0nymd}_${av0hh}00z.$NCSUFFIX ensmean/$expid.ana.eta.${av0nymd}_${av0hh}00z.$NCSUFFIX foreach dir (`/bin/ls -d mem*`) cd $dir - ln -sf ../ensmean/$expid.ana.eta.${av0nymd}_${av0hh}z.$NCSUFFIX . + ln -sf ../ensmean/$expid.ana.eta.${av0nymd}_${av0hh}00z.$NCSUFFIX . cd - end # endif @@ -633,10 +633,10 @@ endif cd $ENSWORK if ( $ATMENS_GEPS_RECENTER ) then - if ( ! -e ensmean/$expid.${atype}.eta.${anymd}_${ahh}z.$NCSUFFIX ) then + if ( ! -e ensmean/$expid.${atype}.eta.${anymd}_${ahh}00z.$NCSUFFIX ) then if ( ! -d ensmean ) mkdir ensmean - $DRYRUN $AENSTAT_MPIRUN -rc $ATMENSETC/mp_stats.rc -o ensmean/$expid.${atype}.eta.${anymd}_${ahh}z.$NCSUFFIX \ - mem*/$expid.${atype}.eta.${anymd}_${ahh}z.$NCSUFFIX + $DRYRUN $AENSTAT_MPIRUN -rc $ATMENSETC/mp_stats.rc -o ensmean/$expid.${atype}.eta.${anymd}_${ahh}00z.$NCSUFFIX \ + mem*/$expid.${atype}.eta.${anymd}_${ahh}00z.$NCSUFFIX endif mkdir torecenter cd torecenter diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmens_prepobsens.csh b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmens_prepobsens.csh index 11b5a4a5..937b9105 100755 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmens_prepobsens.csh +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmens_prepobsens.csh @@ -180,6 +180,7 @@ set av0nhms = $av0date[2] set av0yyyy = `echo $av0nymd | cut -c1-4` set av0mm = `echo $av0nymd | cut -c5-6` set av0hh = `echo $av0nhms | cut -c1-2` +set av0hhmn = ${av0hh}00 set av0yyyymmddhh = ${av0nymd}${av0hh} set xv0date = ( `tick $av0date[1] $av0date[2] $sixhours` ) @@ -363,7 +364,7 @@ if ( ! -d $expid.atmens_e$aver.${nnymd}_${nhh}z ) then endif else echo "${MYNAME}: unfolding non-inflated ensemble of analyses ... " - $DRYRUN tar xvf $expid.atmens_e$aver.${nnymd}_${nhh}z.tar --wildcards --no-anchored "*${SRCEXPID}.$aver.eta.${anymd}_${ahh}z.$NCSUFFIX" + $DRYRUN tar xvf $expid.atmens_e$aver.${nnymd}_${nhh}z.tar --wildcards --no-anchored "*${SRCEXPID}.$aver.eta.${anymd}_${ahh}00z.$NCSUFFIX" if ( $SRCEXPID != $expid && -d $SRCEXPID.atmens_e$aver.${nnymd}_${nhh}z ) then $DRYRUN /bin/mv $SRCEXPID.atmens_e$aver.${nnymd}_${nhh}z $expid.atmens_e$aver.${nnymd}_${nhh}z endif @@ -399,7 +400,7 @@ if ( $ATMENS_FSO_MFCST <= 1 ) then endif else echo "${MYNAME}: unfolding ensemble of forecasts from analyses $expid.atmens_e${prog}.${xfanymd}_${xfahh}z.tar ... " - $DRYRUN tar xvf $expid.atmens_e${prog}.${xfanymd}_${xfahh}z.tar --wildcards --no-anchored "*${SRCEXPID}.prog.eta.${av0nymd}_${av0hh}z.$NCSUFFIX" + $DRYRUN tar xvf $expid.atmens_e${prog}.${xfanymd}_${xfahh}z.tar --wildcards --no-anchored "*${SRCEXPID}.prog.eta.${av0nymd}_${av0hhmn}z.$NCSUFFIX" if ( $ATMENS_FSO_FSENS == 1 ) then $DRYRUN tar xvf $expid.atmens_e${prog}.${xfanymd}_${xfahh}z.tar --wildcards --no-anchored "*${SRCEXPID}.fsens*.eta.*-${anymd}_${ahh}z.$NCSUFFIX" endif @@ -442,7 +443,7 @@ if ( $ATMENS_FSO_MFCST <= 1 ) then endif else echo "${MYNAME}: unfolding ensemble of forecasts from backgroud state $expid.atmens_e${prog}.${xfbnymd}_${xfbhh}z.tar ... " - $DRYRUN tar xvf $expid.atmens_e${prog}.${xfbnymd}_${xfbhh}z.tar --wildcards --no-anchored "*${SRCEXPID}.prog.eta.${av0nymd}_${av0hh}z.$NCSUFFIX" + $DRYRUN tar xvf $expid.atmens_e${prog}.${xfbnymd}_${xfbhh}z.tar --wildcards --no-anchored "*${SRCEXPID}.prog.eta.${av0nymd}_${av0hhmn}z.$NCSUFFIX" if ( $ATMENS_FSO_FSENS == 1 ) then $DRYRUN tar xvf $expid.atmens_e${prog}.${xfbnymd}_${xfbhh}z.tar --wildcards --no-anchored "*${SRCEXPID}.fsens*.eta.*-${anymd}_${ahh}z.$NCSUFFIX" endif @@ -472,38 +473,40 @@ if ( $ATMENS_FSO_MFCST == 0 || $ATMENS_FSO_FSENS == 2 ) then if ( $ATMENS_FSO_MFCST == 0 ) then set ftype = "prog" set xtag = "" + set mn = "00" endif if ( $ATMENS_FSO_FSENS == 2 ) then set ftype = "fsens_twe" set xtag = "-${anymd}_${ahh}z" + set mn = "" endif # forecasts issued from backgrounds - if ( ! -e prog/fcsterr/$expid.$ftype.eta.${fbnymd}_${fbhh}z+${av0nymd}_${av0hh}z${xtag}.$NCSUFFIX ) then + if ( ! -e prog/fcsterr/$expid.$ftype.eta.${fbnymd}_${fbhh}z+${av0nymd}_${av0hh}${mn}z${xtag}.$NCSUFFIX ) then if ( $DRYRUN == "check" ) then - if ( ! -e $DATADIR/$SRCEXPID/prog/Y$fbyyyy/M$fbmm/D$fbdd/H$fbhh/$SRCEXPID.$ftype.eta.${fbnymd}_${fbhh}z+${av0nymd}_${av0hh}z${xtag}.$NCSUFFIX ) then - echo "${MYNAME}: missing $SRCEXPID.$ftype.eta.${fbnymd}_${fbhh}z+${av0nymd}_${av0hh}z${xtag}.$NCSUFFIX " + if ( ! -e $DATADIR/$SRCEXPID/prog/Y$fbyyyy/M$fbmm/D$fbdd/H$fbhh/$SRCEXPID.$ftype.eta.${fbnymd}_${fbhh}z+${av0nymd}_${av0hh}${mn}z${xtag}.$NCSUFFIX ) then + echo "${MYNAME}: missing $SRCEXPID.$ftype.eta.${fbnymd}_${fbhh}z+${av0nymd}_${av0hh}${mn}z${xtag}.$NCSUFFIX " @ notavail = $notavail + 1 endif else if ( $action == "setrc" ) then - echo $DATADIR/$SRCEXPID/prog/Y$fbyyyy/M$fbmm/D$fbdd/H$fbhh/$SRCEXPID.$ftype.eta.${fbnymd}_${fbhh}z+${av0nymd}_${av0hh}z${xtag}.$NCSUFFIX >> $ACQRC + echo $DATADIR/$SRCEXPID/prog/Y$fbyyyy/M$fbmm/D$fbdd/H$fbhh/$SRCEXPID.$ftype.eta.${fbnymd}_${fbhh}z+${av0nymd}_${av0hh}${mn}z${xtag}.$NCSUFFIX >> $ACQRC else - $DRYRUN /bin/mv $SRCEXPID.$ftype.eta.${fbnymd}_${fbhh}z+${av0nymd}_${av0hh}z${xtag}.$NCSUFFIX prog/fcsterr/$expid.$ftype.eta.${fbnymd}_${fbhh}z+${av0nymd}_${av0hh}z${xtag}.$NCSUFFIX + $DRYRUN /bin/mv $SRCEXPID.$ftype.eta.${fbnymd}_${fbhh}z+${av0nymd}_${av0hh}${mn}z${xtag}.$NCSUFFIX prog/fcsterr/$expid.$ftype.eta.${fbnymd}_${fbhh}z+${av0nymd}_${av0hh}${mn}z${xtag}.$NCSUFFIX endif endif endif # forecasts issued from analysis - if ( ! -e prog/fcsterr/$expid.$ftype.eta.${fanymd}_${fahh}z+${av0nymd}_${av0hh}z${xtag}.$NCSUFFIX ) then + if ( ! -e prog/fcsterr/$expid.$ftype.eta.${fanymd}_${fahh}z+${av0nymd}_${av0hh}${mn}z${xtag}.$NCSUFFIX ) then if ( $DRYRUN == "check" ) then - if ( ! -e $DATADIR/$SRCEXPID/prog/Y$fayyyy/M$famm/D$fadd/H$fahh/$SRCEXPID.$ftype.eta.${fanymd}_${fahh}z+${av0nymd}_${av0hh}z${xtag}.$NCSUFFIX ) then - echo "${MYNAME}: missing $SRCEXPID.$ftype.eta.${fanymd}_${fahh}z+${av0nymd}_${av0hh}z${xtag}.$NCSUFFIX " + if ( ! -e $DATADIR/$SRCEXPID/prog/Y$fayyyy/M$famm/D$fadd/H$fahh/$SRCEXPID.$ftype.eta.${fanymd}_${fahh}z+${av0nymd}_${av0hh}${mn}z${xtag}.$NCSUFFIX ) then + echo "${MYNAME}: missing $SRCEXPID.$ftype.eta.${fanymd}_${fahh}z+${av0nymd}_${av0hh}${mn}z${xtag}.$NCSUFFIX " @ notavail = $notavail + 1 endif else if ( $action == "setrc" ) then - echo $DATADIR/$SRCEXPID/prog/Y$fayyyy/M$famm/D$fadd/H$fahh/$SRCEXPID.$ftype.eta.${fanymd}_${fahh}z+${av0nymd}_${av0hh}z${xtag}.$NCSUFFIX >> $ACQRC + echo $DATADIR/$SRCEXPID/prog/Y$fayyyy/M$famm/D$fadd/H$fahh/$SRCEXPID.$ftype.eta.${fanymd}_${fahh}z+${av0nymd}_${av0hh}${mn}z${xtag}.$NCSUFFIX >> $ACQRC else - $DRYRUN /bin/mv $SRCEXPID.$ftype.eta.${fanymd}_${fahh}z+${av0nymd}_${av0hh}z${xtag}.$NCSUFFIX prog/fcsterr/$expid.$ftype.eta.${fanymd}_${fahh}z+${av0nymd}_${av0hh}z${xtag}.$NCSUFFIX + $DRYRUN /bin/mv $SRCEXPID.$ftype.eta.${fanymd}_${fahh}z+${av0nymd}_${av0hh}${mn}z${xtag}.$NCSUFFIX prog/fcsterr/$expid.$ftype.eta.${fanymd}_${fahh}z+${av0nymd}_${av0hh}${mn}z${xtag}.$NCSUFFIX endif endif endif @@ -511,21 +514,21 @@ endif # central forecasts # verification from central if ( $ATMENS_FSO_AVRFY == 0 ) then - if ( ! -e prog/fcsterr/$expid.$aver.eta.${av0nymd}_${av0hh}z.$NCSUFFIX ) then + if ( ! -e prog/fcsterr/$expid.$aver.eta.${av0nymd}_${av0hhmn}z.$NCSUFFIX ) then if ( $DRYRUN == "check" ) then - if ( ! -e $DATADIR/$SRCEXPID/ana/Y$av0yyyy/M$av0mm/$SRCEXPID.$aver.eta.${av0nymd}_${av0hh}z.$NCSUFFIX ) then - echo "${MYNAME}: missing $SRCEXPID.$aver.eta.${av0nymd}_${av0hh}z.$NCSUFFIX " + if ( ! -e $DATADIR/$SRCEXPID/ana/Y$av0yyyy/M$av0mm/$SRCEXPID.$aver.eta.${av0nymd}_${av0hhmn}z.$NCSUFFIX ) then + echo "${MYNAME}: missing $SRCEXPID.$aver.eta.${av0nymd}_${av0hhmn}z.$NCSUFFIX " @ notavail = $notavail + 1 endif else if ( $action == "setrc" ) then if ( $SRCEXPID == $expid ) then - echo $DATADIR/$expid/ana/Y$av0yyyy/M$av0mm/$expid.$aver.eta.${av0nymd}_${av0hh}z.$NCSUFFIX >> $ACQRC + echo $DATADIR/$expid/ana/Y$av0yyyy/M$av0mm/$expid.$aver.eta.${av0nymd}_${av0hhmn}z.$NCSUFFIX >> $ACQRC else - echo "$DATADIR/$SRCEXPID/ana/Y$av0yyyy/M$av0mm/$SRCEXPID.$aver.eta.${av0nymd}_${av0hh}z.$NCSUFFIX => $expid.$aver.eta.${av0nymd}_${av0hh}z.$NCSUFFIX" >> $ACQRC + echo "$DATADIR/$SRCEXPID/ana/Y$av0yyyy/M$av0mm/$SRCEXPID.$aver.eta.${av0nymd}_${av0hhmn}z.$NCSUFFIX => $expid.$aver.eta.${av0nymd}_${av0hhmn}z.$NCSUFFIX" >> $ACQRC endif else - $DRYRUN /bin/mv $expid.$aver.eta.${av0nymd}_${av0hh}z.$NCSUFFIX prog/fcsterr + $DRYRUN /bin/mv $expid.$aver.eta.${av0nymd}_${av0hhmn}z.$NCSUFFIX prog/fcsterr endif endif endif @@ -547,7 +550,7 @@ if ( $ATMENS_FSO_AVRFY == 1 && $ATMENS_FSO_MFCST <= 1 ) then endif else echo "${MYNAME}: unfolding non-inflated ensemble of analyses ... " - $DRYRUN tar xvf $expid.atmens_e$aver.${vnnymd}_${vnhh}z.tar --wildcards --no-anchored "*${SRCEXPID}.$aver.eta.${av0nymd}_${av0hh}z.$NCSUFFIX" + $DRYRUN tar xvf $expid.atmens_e$aver.${vnnymd}_${vnhh}z.tar --wildcards --no-anchored "*${SRCEXPID}.$aver.eta.${av0nymd}_${av0hhmn}z.$NCSUFFIX" if ( $SRCEXPID != $expid && -d $SRCEXPID.atmens_e$aver.${vnnymd}_${vnhh}z ) then $DRYRUN /bin/mv $SRCEXPID.atmens_e$aver.${vnnymd}_${vnhh}z $expid.atmens_e$aver.${vnnymd}_${vnhh}z endif @@ -602,18 +605,18 @@ cd $ENSWORK # Calculate mean non-inflated analysis # ------------------------------------ -if ( ! -e ensmean/$expid.$aver.eta.${anymd}_${ahh}z.$NCSUFFIX ) then +if ( ! -e ensmean/$expid.$aver.eta.${anymd}_${ahh}00z.$NCSUFFIX ) then if ( ! -d ensmean ) mkdir ensmean if ( $?AENSTAT_FAST_MPIRUN ) then - $DRYRUN $AENSTAT_FAST_MPIRUN -o ensmean/$expid.$aver.eta.${anymd}_${ahh}z.$NCSUFFIX \ - mem*/$expid.$aver.eta.${anymd}_${ahh}z.$NCSUFFIX + $DRYRUN $AENSTAT_FAST_MPIRUN -o ensmean/$expid.$aver.eta.${anymd}_${ahh}00z.$NCSUFFIX \ + mem*/$expid.$aver.eta.${anymd}_${ahh}00z.$NCSUFFIX else - $DRYRUN $AENSTAT_MPIRUN -rc $ATMENSETC/mp_stats.rc -o ensmean/$expid.$aver.eta.${anymd}_${ahh}z.$NCSUFFIX \ - mem*/$expid.$aver.eta.${anymd}_${ahh}z.$NCSUFFIX + $DRYRUN $AENSTAT_MPIRUN -rc $ATMENSETC/mp_stats.rc -o ensmean/$expid.$aver.eta.${anymd}_${ahh}00z.$NCSUFFIX \ + mem*/$expid.$aver.eta.${anymd}_${ahh}00z.$NCSUFFIX endif endif -set ana_ens_mean = "ensmean/$expid.$aver.eta.${anymd}_${ahh}z.$NCSUFFIX" +set ana_ens_mean = "ensmean/$expid.$aver.eta.${anymd}_${ahh}00z.$NCSUFFIX" set ens_mres = `getgfiodim.x $ana_ens_mean` if ($status) then echo "${MYNAME}: error trying to determine ens resolution, aborting ..." @@ -647,27 +650,27 @@ if ( $ATMENS_FSO_MFCST == 1 ) then cd $ENSWORK/prog # calculate ensemble mean of forecasts from # analysis ... - if ( ! -e fcsterr/$expid.prog.eta.${fanymd}_${fahh}z+${av0nymd}_${av0hh}z.$NCSUFFIX ) then + if ( ! -e fcsterr/$expid.prog.eta.${fanymd}_${fahh}z+${av0nymd}_${av0hhmn}z.$NCSUFFIX ) then if ( $?AENSTAT_FAST_MPIRUN) then - echo $AENSTAT_FAST_MPIRUN -o fcsterr/$expid.prog.eta.${fanymd}_${fahh}z+${av0nymd}_${av0hh}z.$NCSUFFIX ... - $DRYRUN $AENSTAT_FAST_MPIRUN -o fcsterr/$expid.prog.eta.${fanymd}_${fahh}z+${av0nymd}_${av0hh}z.$NCSUFFIX \ - ${fanymd}_${fahh}z/mem*/$expid.prog.eta.${av0nymd}_${av0hh}z.$NCSUFFIX + echo $AENSTAT_FAST_MPIRUN -o fcsterr/$expid.prog.eta.${fanymd}_${fahh}z+${av0nymd}_${av0hhmn}z.$NCSUFFIX ... + $DRYRUN $AENSTAT_FAST_MPIRUN -o fcsterr/$expid.prog.eta.${fanymd}_${fahh}z+${av0nymd}_${av0hhmn}z.$NCSUFFIX \ + ${fanymd}_${fahh}z/mem*/$expid.prog.eta.${av0nymd}_${av0hhmn}z.$NCSUFFIX else - echo $AENSTAT_MPIRUN -rc $ATMENSETC/mp_stats.rc -o fcsterr/$expid.prog.eta.${fanymd}_${fahh}z+${av0nymd}_${av0hh}z.$NCSUFFIX ... - $DRYRUN $AENSTAT_MPIRUN -rc $ATMENSETC/mp_stats.rc -o fcsterr/$expid.prog.eta.${fanymd}_${fahh}z+${av0nymd}_${av0hh}z.$NCSUFFIX \ - ${fanymd}_${fahh}z/mem*/$expid.prog.eta.${av0nymd}_${av0hh}z.$NCSUFFIX + echo $AENSTAT_MPIRUN -rc $ATMENSETC/mp_stats.rc -o fcsterr/$expid.prog.eta.${fanymd}_${fahh}z+${av0nymd}_${av0hhmn}z.$NCSUFFIX ... + $DRYRUN $AENSTAT_MPIRUN -rc $ATMENSETC/mp_stats.rc -o fcsterr/$expid.prog.eta.${fanymd}_${fahh}z+${av0nymd}_${av0hhmn}z.$NCSUFFIX \ + ${fanymd}_${fahh}z/mem*/$expid.prog.eta.${av0nymd}_${av0hhmn}z.$NCSUFFIX endif endif # and background ... - if ( ! -e fcsterr/$expid.prog.eta.${fbnymd}_${fbhh}z+${av0nymd}_${av0hh}z.$NCSUFFIX ) then + if ( ! -e fcsterr/$expid.prog.eta.${fbnymd}_${fbhh}z+${av0nymd}_${av0hhmn}z.$NCSUFFIX ) then if ( $?AENSTAT_FAST_MPIRUN) then - echo $AENSTAT_FAST_MPIRUN -o fcsterr/$expid.prog.eta.${fbnymd}_${fbhh}z+${av0nymd}_${av0hh}z.$NCSUFFIX ... - $DRYRUN $AENSTAT_FAST_MPIRUN -o fcsterr/$expid.prog.eta.${fbnymd}_${fbhh}z+${av0nymd}_${av0hh}z.$NCSUFFIX \ - ${fbnymd}_${fbhh}z/mem*/$expid.prog.eta.${av0nymd}_${av0hh}z.$NCSUFFIX + echo $AENSTAT_FAST_MPIRUN -o fcsterr/$expid.prog.eta.${fbnymd}_${fbhh}z+${av0nymd}_${av0hhmn}z.$NCSUFFIX ... + $DRYRUN $AENSTAT_FAST_MPIRUN -o fcsterr/$expid.prog.eta.${fbnymd}_${fbhh}z+${av0nymd}_${av0hhmn}z.$NCSUFFIX \ + ${fbnymd}_${fbhh}z/mem*/$expid.prog.eta.${av0nymd}_${av0hhmn}z.$NCSUFFIX else - echo $AENSTAT_MPIRUN -rc $ATMENSETC/mp_stats.rc -o fcsterr/$expid.prog.eta.${fbnymd}_${fbhh}z+${av0nymd}_${av0hh}z.$NCSUFFIX ... - $DRYRUN $AENSTAT_MPIRUN -rc $ATMENSETC/mp_stats.rc -o fcsterr/$expid.prog.eta.${fbnymd}_${fbhh}z+${av0nymd}_${av0hh}z.$NCSUFFIX \ - ${fbnymd}_${fbhh}z/mem*/$expid.prog.eta.${av0nymd}_${av0hh}z.$NCSUFFIX + echo $AENSTAT_MPIRUN -rc $ATMENSETC/mp_stats.rc -o fcsterr/$expid.prog.eta.${fbnymd}_${fbhh}z+${av0nymd}_${av0hhmn}z.$NCSUFFIX ... + $DRYRUN $AENSTAT_MPIRUN -rc $ATMENSETC/mp_stats.rc -o fcsterr/$expid.prog.eta.${fbnymd}_${fbhh}z+${av0nymd}_${av0hhmn}z.$NCSUFFIX \ + ${fbnymd}_${fbhh}z/mem*/$expid.prog.eta.${av0nymd}_${av0hhmn}z.$NCSUFFIX endif endif endif @@ -682,15 +685,15 @@ if ( $ATMENS_FSO_AVRFY == 0 ) then endif if ( $ATMENS_FSO_AVRFY == 1 && $ATMENS_FSO_MFCST <= 1 ) then cd $ENSWORK - if ( ! -e prog/fcsterr/$expid.$aver.eta.${av0nymd}_${av0hh}z.$NCSUFFIX ) then + if ( ! -e prog/fcsterr/$expid.$aver.eta.${av0nymd}_${av0hhmn}z.$NCSUFFIX ) then if ( $?AENSTAT_FAST_MPIRUN) then - echo $AENSTAT_FAST_MPIRUN -o prog/fcsterr/$expid.$aver.eta.${av0nymd}_${av0hh}z.$NCSUFFIX ... - $DRYRUN $AENSTAT_FAST_MPIRUN -o prog/fcsterr/$expid.$aver.eta.${av0nymd}_${av0hh}z.$NCSUFFIX \ - $expid.atmens_e$aver.${vnnymd}_${vnhh}z/mem*/$expid.$aver.eta.${av0nymd}_${av0hh}z.$NCSUFFIX + echo $AENSTAT_FAST_MPIRUN -o prog/fcsterr/$expid.$aver.eta.${av0nymd}_${av0hhmn}z.$NCSUFFIX ... + $DRYRUN $AENSTAT_FAST_MPIRUN -o prog/fcsterr/$expid.$aver.eta.${av0nymd}_${av0hhmn}z.$NCSUFFIX \ + $expid.atmens_e$aver.${vnnymd}_${vnhh}z/mem*/$expid.$aver.eta.${av0nymd}_${av0hhmn}z.$NCSUFFIX else - echo $AENSTAT_MPIRUN -rc $ATMENSETC/mp_stats.rc -o prog/fcsterr/$expid.$aver.eta.${av0nymd}_${av0hh}z.$NCSUFFIX ... - $DRYRUN $AENSTAT_MPIRUN -rc $ATMENSETC/mp_stats.rc -o prog/fcsterr/$expid.$aver.eta.${av0nymd}_${av0hh}z.$NCSUFFIX \ - $expid.atmens_e$aver.${vnnymd}_${vnhh}z/mem*/$expid.$aver.eta.${av0nymd}_${av0hh}z.$NCSUFFIX + echo $AENSTAT_MPIRUN -rc $ATMENSETC/mp_stats.rc -o prog/fcsterr/$expid.$aver.eta.${av0nymd}_${av0hhmn}z.$NCSUFFIX ... + $DRYRUN $AENSTAT_MPIRUN -rc $ATMENSETC/mp_stats.rc -o prog/fcsterr/$expid.$aver.eta.${av0nymd}_${av0hhmn}z.$NCSUFFIX \ + $expid.atmens_e$aver.${vnnymd}_${vnhh}z/mem*/$expid.$aver.eta.${av0nymd}_${av0hhmn}z.$NCSUFFIX endif endif endif diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/jobgen.pl b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/jobgen.pl index 095ffa68..1cf0271f 100755 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/jobgen.pl +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/jobgen.pl @@ -222,6 +222,11 @@ sub gen { #PBS -q $opt_q #SBATCH --partition=datamove EOF + if ( $ENV{JOBGEN_ARCH_CONSTRAINT} ) { + print SCRIPT <<"EOF"; +#SBATCH --constraint=$ENV{JOBGEN_ARCH_CONSTRAINT} +EOF + } } } From c4722d0207364ca6a9d2a98e7f8aabfba074b3a3 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 16 Aug 2021 11:07:48 -0400 Subject: [PATCH 052/205] Update LICENSE.md This updates the license to match that found at: https://opensource.gsfc.nasa.gov/projects/GEOS-5/index.php --- LICENSE.md | 240 ++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 239 insertions(+), 1 deletion(-) diff --git a/LICENSE.md b/LICENSE.md index 80be6d7f..aefef584 100644 --- a/LICENSE.md +++ b/LICENSE.md @@ -19,5 +19,243 @@ Government Agency Original Software Designation: GSC-15354-1 Government Agency Original Software Title: GEOS-5 GCM Modeling Software User Registration Requested. Please Visit http://opensource.gsfc.nasa.gov Government Agency Point of Contact for Original Software: - Dale Hithon, SRA Assistant, (301) 286-2691 + Dale Hithon, SRA Assistant, (301) 286-2691 + +1. DEFINITIONS + +A. "Contributor" means Government Agency, as the developer of the +Original Software, and any entity that makes a Modification. + +B. "Covered Patents" mean patent claims licensable by a Contributor +that are necessarily infringed by the use or sale of its Modification +alone or when combined with the Subject Software. + +C. "Display" means the showing of a copy of the Subject Software, +either directly or by means of an image, or any other device. + +D. "Distribution" means conveyance or transfer of the Subject Software, +regardless of means, to another. + +E. "Larger Work" means computer software that combines Subject +Software, or portions thereof, with software separate from the Subject +Software that is not governed by the terms of this Agreement. + +F. "Modification" means any alteration of, including addition to +or deletion from, the substance or structure of either the Original +Software or Subject Software, and includes derivative works, as that +term is defined in the Copyright Statute, 17 USC 101. However, the act +of including Subject Software as part of a Larger Work does not in and +of itself constitute a Modification. + +G. "Original Software" means the computer software first released under +this Agreement by Government Agency with Government Agency designation +GSC-15354-1 and entitled GEOS-5 GCM Modeling Software, including source +code, object code and accompanying documentation, if any. + +H. "Recipient" means anyone who acquires the Subject Software under +this Agreement, including all Contributors. + +I. "Redistribution" means Distribution of the Subject Software after a +Modification has been made. + +J. "Reproduction" means the making of a counterpart, image or copy of +the Subject Software. + +K. "Sale" means the exchange of the Subject Software for money or +equivalent value. + +L. "Subject Software" means the Original Software, Modifications, or +any respective parts thereof. + +M. "Use" means the application or employment of the Subject Software +for any purpose. + + + +2. GRANT OF RIGHTS + +A. Under Non-Patent Rights: Subject to the terms and conditions of this +Agreement, each Contributor, with respect to its own contribution to +the Subject Software, hereby grants to each Recipient a non-exclusive, +world-wide, royalty-free license to engage in the following activities +pertaining to the Subject Software: + +1. Use +2. Distribution +3. Reproduction +4. Modification +5. Redistribution +6. Display + +B. Under Patent Rights: Subject to the terms and conditions of this +Agreement, each Contributor, with respect to its own contribution to +the Subject Software, hereby grants to each Recipient under Covered +Patents a non-exclusive, world-wide, royalty-free license to engage in +the following activities pertaining to the Subject Software: + +1. Use +2. Distribution +3. Reproduction +4. Sale +5. Offer for Sale + +C. The rights granted under Paragraph B. also apply to the combination +of a Contributor's Modification and the Subject Software if, at the +time the Modification is added by the Contributor, the addition of +such Modification causes the combination to be covered by the Covered +Patents. It does not apply to any other combinations that include a +Modification. + +D. The rights granted in Paragraphs A. and B. allow the Recipient to +sublicense those same rights. Such sublicense must be under the same +terms and conditions of this Agreement. + + +3. OBLIGATIONS OF RECIPIENT + +A. Distribution or Redistribution of the Subject Software must be made +under this Agreement except for additions covered under paragraph 3H. + +1. Whenever a Recipient distributes or redistributes the Subject +Software, a copy of this Agreement must be included with each copy of +the Subject Software; and + +2. If Recipient distributes or redistributes the Subject Software in +any form other than source code, Recipient must also make the source +code freely available, and must provide with each copy of the Subject +Software information on how to obtain the source code in a reasonable +manner on or through a medium customarily used for software exchange. + +B. Each Recipient must ensure that the following copyright notice +appears prominently in the Subject Software: + +Copyright © 2003-2007 United States Government as represented by the +Administrator of the National Aeronautics and Space Administration. All +Rights Reserved. + +C. Each Contributor must characterize its alteration of the Subject +Software as a Modification and must identify itself as the originator +of its Modification in a manner that reasonably allows subsequent +Recipients to identify the originator of the Modification. In +fulfillment of these requirements, Contributor must include a file +(e.g., a change log file) that describes the alterations made and +the date of the alterations, identifies Contributor as originator of +the alterations, and consents to characterization of the alterations +as a Modification, for example, by including a statement that the +Modification is derived, directly or indirectly, from Original Software +provided by Government Agency. Once consent is granted, it may not +thereafter be revoked. + +D. A Contributor may add its own copyright notice to the Subject +Software. Once a copyright notice has been added to the Subject +Software, a Recipient may not remove it without the express permission +of the Contributor who added the notice. + +E. A Recipient may not make any representation in the Subject Software +or in any promotional, advertising or other material that may be +construed as an endorsement by Government Agency or by any prior +Recipient of any product or service provided by Recipient, or that may +seek to obtain commercial advantage by the fact of Government Agency's +or a prior Recipient's participation in this Agreement. + +F. In an effort to track usage and maintain accurate records of +the Subject Software, each Recipient, upon receipt of the Subject +Software, is requested to register with Government Agency by visiting +the following website: http://opensource.gsfc.nasa.gov. Recipient's +name and personal information shall be used for statistical purposes +only. Once a Recipient makes a Modification available, it is requested +that the Recipient inform Government Agency at the web site provided +above how to access the Modification. + +G. Each Contributor represents that its Modification is believed to +be Contributor's original creation and does not violate any existing +agreements, regulations, statutes or rules, and further that Contributor +has sufficient rights to grant the rights conveyed by this Agreement. + +H. A Recipient may choose to offer, and to charge a fee for, warranty, +support, indemnity and/or liability obligations to one or more other +Recipients of the Subject Software. A Recipient may do so, however, +only on its own behalf and not on behalf of Government Agency or any +other Recipient. Such a Recipient must make it absolutely clear that +any such warranty, support, indemnity and/or liability obligation is +offered by that Recipient alone. Further, such Recipient agrees to +indemnify Government Agency and every other Recipient for any liability +incurred by them as a result of warranty, support, indemnity and/or +liability offered by such Recipient. + +I. A Recipient may create a Larger Work by combining Subject Software +with separate software not governed by the terms of this agreement +and distribute the Larger Work as a single product. In such case, the +Recipient must make sure Subject Software, or portions thereof, included +in the Larger Work is subject to this Agreement. + +J. Notwithstanding any provisions contained herein, Recipient is hereby +put on notice that export of any goods or technical data from the United +States may require some form of export license from the U.S. Government. +Failure to obtain necessary export licenses may result in criminal +liability under U.S. laws. Government Agency neither represents that a +license shall not be required nor that, if required, it shall be issued. +Nothing granted herein provides any such export license. + +4. DISCLAIMER OF WARRANTIES AND LIABILITIES; WAIVER AND INDEMNIFICATION + +A. No Warranty: THE SUBJECT SOFTWARE IS PROVIDED "AS IS" WITHOUT +ANY WARRANTY OF ANY KIND, EITHER EXPRESSED, IMPLIED, OR STATUTORY, +INCLUDING, BUT NOT LIMITED TO, ANY WARRANTY THAT THE SUBJECT +SOFTWARE WILL CONFORM TO SPECIFICATIONS, ANY IMPLIED WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR FREEDOM FROM +INFRINGEMENT, ANY WARRANTY THAT THE SUBJECT SOFTWARE WILL BE ERROR FREE, +OR ANY WARRANTY THAT DOCUMENTATION, IF PROVIDED, WILL CONFORM TO THE +SUBJECT SOFTWARE. THIS AGREEMENT DOES NOT, IN ANY MANNER, CONSTITUTE AN +ENDORSEMENT BY GOVERNMENT AGENCY OR ANY PRIOR RECIPIENT OF ANY RESULTS, +RESULTING DESIGNS, HARDWARE, SOFTWARE PRODUCTS OR ANY OTHER APPLICATIONS +RESULTING FROM USE OF THE SUBJECT SOFTWARE. FURTHER, GOVERNMENT AGENCY +DISCLAIMS ALL WARRANTIES AND LIABILITIES REGARDING THIRD-PARTY SOFTWARE, +IF PRESENT IN THE ORIGINAL SOFTWARE, AND DISTRIBUTES IT "AS IS." + +B. Waiver and Indemnity: RECIPIENT AGREES TO WAIVE ANY AND ALL +CLAIMS AGAINST THE UNITED STATES GOVERNMENT, ITS CONTRACTORS AND +SUBCONTRACTORS, AS WELL AS ANY PRIOR RECIPIENT. IF RECIPIENT'S USE +OF THE SUBJECT SOFTWARE RESULTS IN ANY LIABILITIES, DEMANDS, DAMAGES, +EXPENSES OR LOSSES ARISING FROM SUCH USE, INCLUDING ANY DAMAGES FROM +PRODUCTS BASED ON, OR RESULTING FROM, RECIPIENT'S USE OF THE SUBJECT +SOFTWARE, RECIPIENT SHALL INDEMNIFY AND HOLD HARMLESS THE UNITED STATES +GOVERNMENT, ITS CONTRACTORS AND SUBCONTRACTORS, AS WELL AS ANY PRIOR +RECIPIENT, TO THE EXTENT PERMITTED BY LAW. RECIPIENT'S SOLE REMEDY FOR +ANY SUCH MATTER SHALL BE THE IMMEDIATE, UNILATERAL TERMINATION OF THIS +AGREEMENT. + +5. GENERAL TERMS + +A. Termination: This Agreement and the rights granted hereunder will +terminate automatically if a Recipient fails to comply with these terms +and conditions, and fails to cure such noncompliance within thirty +(30) days of becoming aware of such noncompliance. Upon termination, +a Recipient agrees to immediately cease use and distribution of the +Subject Software. All sublicenses to the Subject Software properly +granted by the breaching Recipient shall survive any such termination of +this Agreement. + +B. Severability: If any provision of this Agreement is invalid or +unenforceable under applicable law, it shall not affect the validity or +enforceability of the remainder of the terms of this Agreement. + +C. Applicable Law: This Agreement shall be subject to United States +federal law only for all purposes, including, but not limited to, +determining the validity of this Agreement, the meaning of its +provisions and the rights, obligations and remedies of the parties. + +D. Entire Understanding: This Agreement constitutes the entire +understanding and agreement of the parties relating to release of the +Subject Software and may not be superseded, modified or amended except +by further written agreement duly executed by the parties. + +E. Binding Authority: By accepting and using the Subject Software under +this Agreement, a Recipient affirms its authority to bind the Recipient +to all terms and conditions of this Agreement and that that Recipient +hereby agrees to all terms and conditions herein. + +F. Point of Contact: Any Recipient contact with Government Agency is to +be directed to the designated representative as follows: Dale Hithon, +SRA Assistant, (301) 286-2691. ``` From 2d2240de21390e12909812c6791a1d967f79f9f9 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Wed, 18 Aug 2021 11:06:03 -0400 Subject: [PATCH 053/205] cssrw access; update branches for this tag --- components.yaml | 4 ++-- src/Applications/GEOSdas_App/monthly_means.j.tmpl | 2 +- src/Applications/GEOSdas_App/plots_transfer.csh.tmpl | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/components.yaml b/components.yaml index e7bc38b4..429cb2ec 100644 --- a/components.yaml +++ b/components.yaml @@ -28,7 +28,7 @@ NCEP_Shared: GMAO_Shared: local: ./src/Shared/@GMAO_Shared remote: ../GMAO_Shared.git - tag: v1.4.5 + branch: feature/rtodling/rt-cssrwNreplay develop: main MAPL: @@ -46,7 +46,7 @@ FMS: GEOSana_GridComp: local: ./src/Components/@GEOSana_GridComp remote: ../GEOSana_GridComp.git - tag: v1.4.2 + branch: feature/rtodling/ncdiag_append_fix develop: develop GEOSgcm_GridComp: diff --git a/src/Applications/GEOSdas_App/monthly_means.j.tmpl b/src/Applications/GEOSdas_App/monthly_means.j.tmpl index 80a02999..244200ca 100644 --- a/src/Applications/GEOSdas_App/monthly_means.j.tmpl +++ b/src/Applications/GEOSdas_App/monthly_means.j.tmpl @@ -58,7 +58,7 @@ chdir $workdir # set send_mail option #--------------------- set send_mail = 0 -set mail_users = ( "steven.pawson" "nicole.brubaker" "steven.bloom" "gary.partyka" "derek.vanpelt" ) +set mail_users = ( "gary.partyka" ) # set flag for monitoring location #--------------------------------- diff --git a/src/Applications/GEOSdas_App/plots_transfer.csh.tmpl b/src/Applications/GEOSdas_App/plots_transfer.csh.tmpl index 755dc130..550dab7c 100644 --- a/src/Applications/GEOSdas_App/plots_transfer.csh.tmpl +++ b/src/Applications/GEOSdas_App/plots_transfer.csh.tmpl @@ -26,7 +26,7 @@ umask 022 @ exit_status = 0 set do_cleanup = 0 set send_mail = 0 -set mail_users = ("Stephen.C.Bloom" "gary.partyka" "Lawrence.L.Takacs") +set mail_users = ("gary.partyka" "Lawrence.L.Takacs") # job parameters #--------------- From 72c6f88c2de7f71b165fe672d3498d20f63a4424 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Wed, 18 Aug 2021 11:48:24 -0400 Subject: [PATCH 054/205] latest for AtmosAna --- components.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/components.yaml b/components.yaml index 429cb2ec..94e49d44 100644 --- a/components.yaml +++ b/components.yaml @@ -46,7 +46,7 @@ FMS: GEOSana_GridComp: local: ./src/Components/@GEOSana_GridComp remote: ../GEOSana_GridComp.git - branch: feature/rtodling/ncdiag_append_fix + branch: feature/rtodling/reviseGPSRO_for_5_29 develop: develop GEOSgcm_GridComp: From e3d416a58fe19ee5897662324980f076965b730b Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Thu, 19 Aug 2021 08:10:40 -0400 Subject: [PATCH 055/205] Update LICENSE.md Again The conversion from Word Doc to Markdown messed up the top of the LICENSE file. This correct the issue. This updates the license to match that found at: https://opensource.gsfc.nasa.gov/projects/GEOS-5/index.php --- LICENSE.md | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/LICENSE.md b/LICENSE.md index aefef584..b0277a69 100644 --- a/LICENSE.md +++ b/LICENSE.md @@ -1,7 +1,9 @@ ``` -Copyright (c) 2003-2018 United States Government as represented by -the Admistrator of the National Aeronautics and Space Administration. -All Rights Reserved. + + NASA OPEN SOURCE SOFTWARE AGREEMENT + + +NASA OPEN SOURCE AGREEMENT VERSION 1.3 THIS OPEN SOURCE AGREEMENT ("AGREEMENT") DEFINES THE RIGHTS OF USE, REPRODUCTION, DISTRIBUTION, MODIFICATION AND REDISTRIBUTION OF CERTAIN @@ -129,7 +131,7 @@ manner on or through a medium customarily used for software exchange. B. Each Recipient must ensure that the following copyright notice appears prominently in the Subject Software: -Copyright © 2003-2007 United States Government as represented by the +Copyright © 2003-2018 United States Government as represented by the Administrator of the National Aeronautics and Space Administration. All Rights Reserved. From b3c251db2c467d3e2d35b1405125a66a623aa7bc Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Thu, 19 Aug 2021 08:39:03 -0400 Subject: [PATCH 056/205] include integration layers for RO --- src/Applications/GEOSdas_App/fvsetup | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index ae9eacb0..3ed0ce3f 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -1750,11 +1750,11 @@ sub ed_ncep_rc { } if ( $siglevs <= 72 ) { - if($rcd =~ /\@NLEV_EXT/) {$rcd=~ s/\@NLEV_EXT/13/g; } - } elsif ( $siglevs > 72 & $siglevs <= 132 ) { if($rcd =~ /\@NLEV_EXT/) {$rcd=~ s/\@NLEV_EXT/15/g; } + } elsif ( $siglevs > 72 & $siglevs <= 132 ) { + if($rcd =~ /\@NLEV_EXT/) {$rcd=~ s/\@NLEV_EXT/17/g; } } elsif ( $siglevs > 132 ) { - if($rcd =~ /\@NLEV_EXT/) {$rcd=~ s/\@NLEV_EXT/25/g; } + if($rcd =~ /\@NLEV_EXT/) {$rcd=~ s/\@NLEV_EXT/27/g; } } if ( $hyb_ens < 0 ) { if($rcd =~ /\@NITER1/) {$rcd=~ s/\@NITER1/100/g; } From 67e2310115ec9d7a36dabfdb97a83dc932d55711 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Tue, 24 Aug 2021 10:54:01 -0400 Subject: [PATCH 057/205] a few bug fixes --- src/Applications/GEOSdas_App/fvpsas | 11 +++++------ src/Applications/GEOSdas_App/fvsetup | 6 +++++- 2 files changed, 10 insertions(+), 7 deletions(-) diff --git a/src/Applications/GEOSdas_App/fvpsas b/src/Applications/GEOSdas_App/fvpsas index 4f054673..f4386038 100755 --- a/src/Applications/GEOSdas_App/fvpsas +++ b/src/Applications/GEOSdas_App/fvpsas @@ -307,21 +307,20 @@ # ----------------------------------------- if ( ! $FORECAST && $AnaFreqEpoch[2] > 0 ) then - zeit_ci.x acquire # Determine relevant time/frequency information # --------------------------------------------- Call DetermineAcquireTimes_() -# If so, aquire observational data -# -------------------------------- +# If so, acquire observational data +# --------------------------------- if ( $DOING_ANA ) then - + zeit_ci.x acquire Call AcquireObservations_() - + zeit_co.x acquire endif - zeit_co.x acquire + endif # Pre-analysis Quality Control # ---------------------------- diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index 3ed0ce3f..d29df8a6 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -2359,7 +2359,7 @@ sub ed_aens_das_replay_acq { my($replay_arcdir, $aens_replay_expid, $acq); $aens_replay_expid = "x0044"; - $replay_arcdir = query("Replay exp name?", $aens_replay_expid); + $aens_replay_expid = query("Replay exp name?", $aens_replay_expid); $replay_arcdir = "/discover/nobackup/projects/gmao/advda/rtodling/archive/x0044"; $replay_arcdir = query("Replay archive directory?", $replay_arcdir); @@ -7674,6 +7674,7 @@ print SCRIPT <<"EOF"; setenv NEWRADBC $newradbc setenv ANGLEBC $newradbc setenv GSI_NETCDF_DIAG 1 + setenv GSI_DIAG2TXT 1 # setenv DO_0HR_IMP 1 if ( -e \$FVHOME/run/replay.acq ) then @@ -8715,6 +8716,9 @@ print SCRIPT <<"EOF"; # Experiment environment # ---------------------- + if ( ! (\$?DATAMOVE_CONSTRAINT) ) then + setenv DATAMOVE_CONSTRAINT NULL + endif setenv BATCH_SUBCMD $qsub setenv GID $gid setenv group_list \"$group_list1\" From dd44687ff7d510796a584aacef0b84ba5ae0e1fe Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Thu, 26 Aug 2021 06:25:59 -0400 Subject: [PATCH 058/205] initial (working) write of netcdf berror file --- .../NCEP_Etc/NCEP_bkgecov/CMakeLists.txt | 2 +- .../NCEP_Etc/NCEP_bkgecov/m_nc_berror.f90 | 334 ++++++++++++++++++ .../NCEP_bkgecov/write_berror_global.f90 | 58 ++- 3 files changed, 380 insertions(+), 14 deletions(-) create mode 100644 src/Applications/NCEP_Etc/NCEP_bkgecov/m_nc_berror.f90 diff --git a/src/Applications/NCEP_Etc/NCEP_bkgecov/CMakeLists.txt b/src/Applications/NCEP_Etc/NCEP_bkgecov/CMakeLists.txt index ede37d1d..881d845b 100644 --- a/src/Applications/NCEP_Etc/NCEP_bkgecov/CMakeLists.txt +++ b/src/Applications/NCEP_Etc/NCEP_bkgecov/CMakeLists.txt @@ -8,7 +8,7 @@ set (SRCS m_stvp.f90 sstmod.f90 m_speclap.f90 m_calap.f90 compact_diffs.f90 comm_mod.f90 deter_subdomain.f90 init_commvars.f90 type_kinds.F90 variables.f90 variances.F90 - vertlength.F90 addoz.f90 + vertlength.F90 addoz.f90 m_nc_berror.f90 ) # This is equivalent to FOPT=$(FOPT3) in GNU Make diff --git a/src/Applications/NCEP_Etc/NCEP_bkgecov/m_nc_berror.f90 b/src/Applications/NCEP_Etc/NCEP_bkgecov/m_nc_berror.f90 new file mode 100644 index 00000000..55d61c3a --- /dev/null +++ b/src/Applications/NCEP_Etc/NCEP_bkgecov/m_nc_berror.f90 @@ -0,0 +1,334 @@ +module m_nc_berror +use netcdf +implicit none +private + +type berror_vars + integer :: nlon,nlat,nsig + real(4),allocatable,dimension(:,:,:):: tcon + real(4),allocatable,dimension(:,:) :: sfvar,vpvar,tvar,qvar,cvar,nrhvar,ozvar + real(4),allocatable,dimension(:,:) :: qivar,qlvar,qrvar,qsvar + real(4),allocatable,dimension(:,:) :: sfhln,vphln,thln,qhln,chln,ozhln + real(4),allocatable,dimension(:,:) :: qihln,qlhln,qrhln,qshln + real(4),allocatable,dimension(:,:) :: sfvln,vpvln,tvln,qvln,cvln,ozvln + real(4),allocatable,dimension(:,:) :: qivln,qlvln,qrvln,qsvln + real(4),allocatable,dimension(:,:) :: vpcon,pscon,varsst,corlsst + real(4),allocatable,dimension(:) :: psvar,pshln +end type berror_vars + + integer, parameter :: nv1d = 2 + character(len=4),parameter :: cvars1d(nv1d) = (/ 'ps ', 'hps ' /) + + integer, parameter :: nv2d = 33 + character(len=5),parameter :: cvars2d(nv2d) = (/ & + 'sf ', 'hsf ', 'vsf ', & + 'vp ', 'hvp ', 'vvp ', & + 't ', 'ht ', 'vt ', & + 'q ', 'hq ', 'vq ', & + 'qi ', 'hqi ', 'vqi ', & + 'ql ', 'hql ', 'vql ', & + 'qr ', 'hqr ', 'vqr ', & + 'qs ', 'hqs ', 'vqs ', & + 'oz ', 'hoz ', 'voz ', & + 'cw ', 'hcw ', 'vcw ', & + 'pscon', 'vpcon', 'nrh ' & + /) + + integer, parameter :: nvmll = 1 ! meriodional, level, level + character(len=4),parameter :: cvarsMLL(nvmll) = (/ 'tcon' /) + + integer, parameter :: nv2dx = 2 + character(len=6),parameter :: cvars2dx(nv2dx) = (/ 'sst ', 'sstcor' /) + +public :: berror_vars +public :: read_nc_berror +public :: write_nc_berror + +contains + +subroutine read_nc_berror (fname,bvars) + implicit none + character(len=*), intent(in) :: fname ! input filename + type(berror_vars),intent(inout) :: bvars ! background error variables + +! This will be the netCDF ID for the file and data variable. + integer :: ncid, varid + +! Local variables + integer ii,jj,nlat,nlon,nlev + real(4), allocatable :: data1d(:) + real(4), allocatable :: data2d(:,:) + +! Set dims + nlat=bvars%nlat + nlon=bvars%nlon + nlev=bvars%nsig + +! Open the file. NF90_NOWRITE tells netCDF we want read-only access to +! the file. + + call check( nf90_open(fname, NF90_NOWRITE, ncid) ) + +! Allocate dims + allocate(data2d(nlat,nlev)) + +! Get the varid of the data variable, based on its name. + call check( nf90_inq_varid(ncid, "d", varid) ) + +! Read data + call check( nf90_get_var(ncid, varid, data2d) ) + + deallocate(data2d) + + ! Close the file, freeing all resources. + call check( nf90_close(ncid) ) + + print *,"*** SUCCESS reading example file ", fname, "! " + + return + +contains + subroutine check(status) + integer, intent ( in) :: status + + if(status /= nf90_noerr) then + print *, trim(nf90_strerror(status)) + stop "Stopped" + end if + end subroutine check +end subroutine read_nc_berror + +subroutine write_nc_berror (fname,bvars,plevs) + implicit none + character(len=*), intent(in) :: fname ! input filename + type(berror_vars),intent(in) :: bvars ! background error variables + real(4), intent(in) :: plevs(:) + +! This is the name of the data file we will create. + character (len = *), parameter :: FILE_NAME = "simple_xy.nc" + + integer, parameter :: NDIMS = 3 + +! When we create netCDF files, variables and dimensions, we get back +! an ID for each one. + character(len=4) :: cindx + integer :: ncid, dimids(NDIMS) + integer :: x_dimid, y_dimid, z_dimid + integer :: lon_varid, lat_varid, lev_varid + integer :: ii,jj,nl,nv,nn,nlat,nlon,nlev + real(4) :: dlat,dlon + integer, allocatable :: varid1d(:), varid2d(:), varid2dx(:), varidMLL(:) + real(4),allocatable :: lats(:),lons(:) + +! This is the data array we will write. It will just be filled with +! a progression of integers for this example. + real(4), allocatable :: data_out(:,:,:) + +! Set dims + nlat=bvars%nlat + nlon=bvars%nlon + nlev=bvars%nsig + +! Create some pretend data. If this wasn't an example program, we + ! would have some real data to write, for example, model output. + dlat=180./(nlat-1.0) + allocate(lats(nlat)) + do jj = 1, nlat + lats(jj) = -90.0 + (jj-1.0)*dlat + enddo + dlon=360./nlon + allocate(lons(nlon)) + do ii = 1, nlon + lons(ii) = -180.0 + ii*dlon + enddo + +! Always check the return code of every netCDF function call. In +! this example program, wrapping netCDF calls with "call check()" +! makes sure that any return which is not equal to nf90_noerr (0) +! will print a netCDF error message and exit. + +! Create the netCDF file. The nf90_clobber parameter tells netCDF to +! overwrite this file, if it already exists. + call check( nf90_create(fname, NF90_CLOBBER, ncid) ) + +! Define the dimensions. NetCDF will hand back an ID for each. + call check( nf90_def_dim(ncid, "lon", nlon, x_dimid) ) + call check( nf90_def_dim(ncid, "lat", nlat, y_dimid) ) + call check( nf90_def_dim(ncid, "lev", nlev, z_dimid) ) + + call check( nf90_def_var(ncid, "lon", NF90_REAL, x_dimid, lon_varid) ) + call check( nf90_def_var(ncid, "lat", NF90_REAL, y_dimid, lat_varid) ) + call check( nf90_def_var(ncid, "lev", NF90_REAL, z_dimid, lev_varid) ) + + call check( nf90_put_att(ncid, lon_varid, "units", "degress") ) + call check( nf90_put_att(ncid, lat_varid, "units", "degress") ) + call check( nf90_put_att(ncid, lev_varid, "units", "hPa") ) + +! The dimids array is used to pass the IDs of the dimensions of +! the variables. Note that in fortran arrays are stored in +! column-major format. + dimids = (/ x_dimid, y_dimid, z_dimid /) + +! Define variables. + allocate(varid1d(nv1d)) + do nv = 1, nv1d + call check( nf90_def_var(ncid, trim(cvars1d(nv)), NF90_REAL, (/ y_dimid /), varid1d(nv)) ) + enddo + allocate(varid2d(nv2d)) + do nv = 1, nv2d + call check( nf90_def_var(ncid, trim(cvars2d(nv)), NF90_REAL, (/ y_dimid, z_dimid /), varid2d(nv)) ) + enddo + allocate(varidMLL(nlev*nvmll)) + nn=0 + do nv = 1, nvmll + do nl = 1, nlev + nn=nn+1 + write(cindx,'(i4.4)') nl + call check( nf90_def_var(ncid, trim(cvarsMLL(nv))//cindx, NF90_REAL, (/ y_dimid, z_dimid /), varidMLL(nn)) ) + enddo + enddo + allocate(varid2dx(nv2dx)) + do nv = 1, nv2dx + call check( nf90_def_var(ncid, trim(cvars2dx(nv)), NF90_REAL, (/ x_dimid, y_dimid /), varid2dx(nv)) ) + enddo + +! End define mode. This tells netCDF we are done defining metadata. + call check( nf90_enddef(ncid) ) + +! Write coordinate variables data + call check( nf90_put_var(ncid, lon_varid, lons ) ) + call check( nf90_put_var(ncid, lat_varid, lats ) ) + call check( nf90_put_var(ncid, lev_varid, plevs) ) + +! Write data to file + allocate(data_out(1,nlat,1)) + do nv = 1, nv1d + if(trim(cvars1d(nv))=="ps" ) data_out(1,:,1) = bvars%psvar + if(trim(cvars1d(nv))=="hps" ) data_out(1,:,1) = bvars%pshln + call check( nf90_put_var(ncid, varid1d(nv), data_out(1,:,1))) + enddo + deallocate(data_out) + allocate(data_out(1,nlat,nlev)) + do nv = 1, nv2d + if(trim(cvars2d(nv))=="sf" ) data_out(1,:,:) = bvars%sfvar + if(trim(cvars2d(nv))=="hsf") data_out(1,:,:) = bvars%sfhln + if(trim(cvars2d(nv))=="vsf") data_out(1,:,:) = bvars%sfvln +! + if(trim(cvars2d(nv))=="vp" ) data_out(1,:,:) = bvars%vpvar + if(trim(cvars2d(nv))=="hvp") data_out(1,:,:) = bvars%vphln + if(trim(cvars2d(nv))=="vvp") data_out(1,:,:) = bvars%vpvln +! + if(trim(cvars2d(nv))=="t" ) data_out(1,:,:) = bvars%tvar + if(trim(cvars2d(nv))=="ht" ) data_out(1,:,:) = bvars%thln + if(trim(cvars2d(nv))=="vt" ) data_out(1,:,:) = bvars%tvln +! + if(trim(cvars2d(nv))=="q" ) data_out(1,:,:) = bvars%qvar + if(trim(cvars2d(nv))=="hq" ) data_out(1,:,:) = bvars%qhln + if(trim(cvars2d(nv))=="vq" ) data_out(1,:,:) = bvars%qvln +! + if(trim(cvars2d(nv))=="qi" ) data_out(1,:,:) = bvars%qivar + if(trim(cvars2d(nv))=="hqi") data_out(1,:,:) = bvars%qihln + if(trim(cvars2d(nv))=="vqi") data_out(1,:,:) = bvars%qivln +! + if(trim(cvars2d(nv))=="ql" ) data_out(1,:,:) = bvars%qlvar + if(trim(cvars2d(nv))=="hql") data_out(1,:,:) = bvars%qlhln + if(trim(cvars2d(nv))=="vql") data_out(1,:,:) = bvars%qlvln +! + if(trim(cvars2d(nv))=="qr" ) data_out(1,:,:) = bvars%qrvar + if(trim(cvars2d(nv))=="hqr") data_out(1,:,:) = bvars%qrhln + if(trim(cvars2d(nv))=="vqr") data_out(1,:,:) = bvars%qrvln +! + if(trim(cvars2d(nv))=="nrh") data_out(1,:,:) = bvars%nrhvar + if(trim(cvars2d(nv))=="qs" ) data_out(1,:,:) = bvars%qsvar + if(trim(cvars2d(nv))=="hqs") data_out(1,:,:) = bvars%qshln + if(trim(cvars2d(nv))=="vqs") data_out(1,:,:) = bvars%qsvln +! + if(trim(cvars2d(nv))=="cw" ) data_out(1,:,:) = bvars%cvar + if(trim(cvars2d(nv))=="hcw") data_out(1,:,:) = bvars%chln + if(trim(cvars2d(nv))=="vcw") data_out(1,:,:) = bvars%cvln +! + if(trim(cvars2d(nv))=="oz" ) data_out(1,:,:) = bvars%ozvar + if(trim(cvars2d(nv))=="hoz") data_out(1,:,:) = bvars%ozhln + if(trim(cvars2d(nv))=="voz") data_out(1,:,:) = bvars%ozvln +! + if(trim(cvars2d(nv))=="pscon") data_out(1,:,:) = bvars%pscon + if(trim(cvars2d(nv))=="vpcon") data_out(1,:,:) = bvars%vpcon +! + call check( nf90_put_var(ncid, varid2d(nv), data_out(1,:,:)) ) + enddo + +! Choose to write out NLATxNLEVxNLEV vars as to facilitate visualization + nn=0 + do nv = 1, nvmll + do nl = 1, nlev + nn = nn + 1 + write(cindx,'(i4.4)') nl + if(trim(cvarsMLL(nv))=="tcon") data_out(1,:,:) = bvars%tcon(:,:,nl) + call check( nf90_put_var(ncid, varidMLL(nn), data_out(1,:,:)) ) + enddo + enddo + deallocate(data_out) + +! use of hflip should be for visualization only + allocate(data_out(nlon,nlat,1)) + do nv = 1, nv2dx + if(trim(cvars2dx(nv))=="sst" ) then + data_out(:,:,1) = transpose(bvars%varsst) + call hflip_(data_out(:,:,1)) + endif + if(trim(cvars2dx(nv))=="sstcor" ) then + data_out(:,:,1) = transpose(bvars%corlsst) + call hflip_(data_out(:,:,1)) + endif + call check( nf90_put_var(ncid, varid2dx(nv), data_out(:,:,1)) ) + enddo + deallocate(data_out) + +! Close file + call check( nf90_close(ncid) ) + + deallocate(varidMLL) + deallocate(varid2d) + deallocate(varid1d) + deallocate(lats) + deallocate(lons) + + print *, "*** SUCCESS writing example file ", fname + + return +contains + subroutine check(status) + integer, intent ( in) :: status + + if(status /= nf90_noerr) then + print *, trim(nf90_strerror(status)) + stop "Stopped" + end if + end subroutine check +end subroutine write_nc_berror + +subroutine hflip_ (q) +real(4),intent(inout) :: q(:,:) +real(4),allocatable :: dum(:) +integer :: i,j,k,im,jm +im=size(q,1);jm=size(q,2) +allocate(dum(im)) +do j=1,jm + do i=1,im/2 + dum(i) = q(i+im/2,j) + dum(i+im/2) = q(i,j) + enddo + q(:,j) = dum(:) +enddo +deallocate(dum) +allocate(dum(jm)) +do i=1,im + dum = q(i,:) + do j=1,jm + q(i,jm-j+1) = dum(j) + enddo +enddo +deallocate(dum) +end subroutine hflip_ + +end module m_nc_berror diff --git a/src/Applications/NCEP_Etc/NCEP_bkgecov/write_berror_global.f90 b/src/Applications/NCEP_Etc/NCEP_bkgecov/write_berror_global.f90 index cb0e274a..d3e6ccae 100644 --- a/src/Applications/NCEP_Etc/NCEP_bkgecov/write_berror_global.f90 +++ b/src/Applications/NCEP_Etc/NCEP_bkgecov/write_berror_global.f90 @@ -9,20 +9,24 @@ ! ! Declare local variables + program write_berror_global + + use m_nc_berror, only: berror_vars + use m_nc_berror, only: write_nc_berror implicit none - type berror_vars - integer :: nlon,nlat,nsig - real(4),allocatable,dimension(:,:,:):: tcon - real(4),allocatable,dimension(:,:) :: sfvar,vpvar,tvar,qvar,cvar,nrhvar,ozvar - real(4),allocatable,dimension(:,:) :: qivar,qlvar,qrvar,qsvar - real(4),allocatable,dimension(:,:) :: sfhln,vphln,thln,qhln,chln,ozhln - real(4),allocatable,dimension(:,:) :: qihln,qlhln,qrhln,qshln - real(4),allocatable,dimension(:,:) :: sfvln,vpvln,tvln,qvln,cvln,ozvln - real(4),allocatable,dimension(:,:) :: qivln,qlvln,qrvln,qsvln - real(4),allocatable,dimension(:,:) :: vpcon,pscon,varsst,corlsst - real(4),allocatable,dimension(:) :: psvar,pshln - end type berror_vars +! type berror_vars +! integer :: nlon,nlat,nsig +! real(4),allocatable,dimension(:,:,:):: tcon +! real(4),allocatable,dimension(:,:) :: sfvar,vpvar,tvar,qvar,cvar,nrhvar,ozvar +! real(4),allocatable,dimension(:,:) :: qivar,qlvar,qrvar,qsvar +! real(4),allocatable,dimension(:,:) :: sfhln,vphln,thln,qhln,chln,ozhln +! real(4),allocatable,dimension(:,:) :: qihln,qlhln,qrhln,qshln +! real(4),allocatable,dimension(:,:) :: sfvln,vpvln,tvln,qvln,cvln,ozvln +! real(4),allocatable,dimension(:,:) :: qivln,qlvln,qrvln,qsvln +! real(4),allocatable,dimension(:,:) :: vpcon,pscon,varsst,corlsst +! real(4),allocatable,dimension(:) :: psvar,pshln +! end type berror_vars real(4),allocatable,dimension(:):: corp_avn,hwllp_avn real(4),allocatable,dimension(:,:):: corsst_avn,hwllsst_avn @@ -80,6 +84,7 @@ write(6,'(a)') ' Finish interpolation.' endif call berror_write_(ivars,merra2current) + call be_write_nc_(ivars) call berror_write_grads_(ivars) call final_berror_vars_(ivars) @@ -667,4 +672,31 @@ subroutine vinterp_berror_vars_(ivars,ovars) end subroutine vinterp_berror_vars_ - end + subroutine be_write_nc_(ivars) + + use m_set_eta, only: set_eta + use m_set_eta, only: get_ref_plevs + implicit none + + type(berror_vars), intent(in) :: ivars + + real(4),allocatable,dimension(:,:) :: aux + real(4),allocatable,dimension(:) :: plevs + real(4),allocatable,dimension(:) :: ak,bk + real(4) ptop, pint + integer k,ks + + allocate(plevs(ivars%nsig)) + allocate(ak(ivars%nsig+1),bk(ivars%nsig+1)) + call set_eta ( ivars%nsig, ks, ptop, pint, ak, bk ) + call get_ref_plevs ( ak, bk, ptop, plevs ) + plevs = plevs(ivars%nsig:1:-1) ! reorient GEOS-5 levs to be consistent w/ GSI(Berror) + + call write_nc_berror('try.nc',ivars,plevs) + + deallocate(ak,bk) + deallocate(plevs) + + end subroutine be_write_nc_ + + end program write_berror_global From 840b62e3f02292bee9b5e4a961652ea9a8a5ffdd Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Thu, 26 Aug 2021 20:25:48 -0400 Subject: [PATCH 059/205] now nc-write works --- .../NCEP_Etc/NCEP_bkgecov/m_nc_berror.f90 | 18 ++++++---- .../NCEP_bkgecov/write_berror_global.f90 | 33 +++++++++++-------- 2 files changed, 31 insertions(+), 20 deletions(-) diff --git a/src/Applications/NCEP_Etc/NCEP_bkgecov/m_nc_berror.f90 b/src/Applications/NCEP_Etc/NCEP_bkgecov/m_nc_berror.f90 index 55d61c3a..d0a60b80 100644 --- a/src/Applications/NCEP_Etc/NCEP_bkgecov/m_nc_berror.f90 +++ b/src/Applications/NCEP_Etc/NCEP_bkgecov/m_nc_berror.f90 @@ -38,12 +38,18 @@ module m_nc_berror character(len=4),parameter :: cvarsMLL(nvmll) = (/ 'tcon' /) integer, parameter :: nv2dx = 2 - character(len=6),parameter :: cvars2dx(nv2dx) = (/ 'sst ', 'sstcor' /) + character(len=7),parameter :: cvars2dx(nv2dx) = (/ 'sst ', 'sstcorl' /) public :: berror_vars public :: read_nc_berror public :: write_nc_berror +public :: bkgerror_ncep2geos_flip + +interface bkgerror_ncep2geos_flip + module procedure hflip2d_ +end interface + contains subroutine read_nc_berror (fname,bvars) @@ -274,11 +280,11 @@ subroutine write_nc_berror (fname,bvars,plevs) do nv = 1, nv2dx if(trim(cvars2dx(nv))=="sst" ) then data_out(:,:,1) = transpose(bvars%varsst) - call hflip_(data_out(:,:,1)) +! call hflip2d_(data_out(:,:,1)) endif - if(trim(cvars2dx(nv))=="sstcor" ) then + if(trim(cvars2dx(nv))=="sstcorl" ) then data_out(:,:,1) = transpose(bvars%corlsst) - call hflip_(data_out(:,:,1)) +! call hflip2d_(data_out(:,:,1)) endif call check( nf90_put_var(ncid, varid2dx(nv), data_out(:,:,1)) ) enddo @@ -307,7 +313,7 @@ subroutine check(status) end subroutine check end subroutine write_nc_berror -subroutine hflip_ (q) +subroutine hflip2d_ (q) real(4),intent(inout) :: q(:,:) real(4),allocatable :: dum(:) integer :: i,j,k,im,jm @@ -329,6 +335,6 @@ subroutine hflip_ (q) enddo enddo deallocate(dum) -end subroutine hflip_ +end subroutine hflip2d_ end module m_nc_berror diff --git a/src/Applications/NCEP_Etc/NCEP_bkgecov/write_berror_global.f90 b/src/Applications/NCEP_Etc/NCEP_bkgecov/write_berror_global.f90 index d3e6ccae..d6a99d08 100644 --- a/src/Applications/NCEP_Etc/NCEP_bkgecov/write_berror_global.f90 +++ b/src/Applications/NCEP_Etc/NCEP_bkgecov/write_berror_global.f90 @@ -13,21 +13,9 @@ program write_berror_global use m_nc_berror, only: berror_vars use m_nc_berror, only: write_nc_berror + use m_nc_berror, only: bkgerror_ncep2geos_flip implicit none -! type berror_vars -! integer :: nlon,nlat,nsig -! real(4),allocatable,dimension(:,:,:):: tcon -! real(4),allocatable,dimension(:,:) :: sfvar,vpvar,tvar,qvar,cvar,nrhvar,ozvar -! real(4),allocatable,dimension(:,:) :: qivar,qlvar,qrvar,qsvar -! real(4),allocatable,dimension(:,:) :: sfhln,vphln,thln,qhln,chln,ozhln -! real(4),allocatable,dimension(:,:) :: qihln,qlhln,qrhln,qshln -! real(4),allocatable,dimension(:,:) :: sfvln,vpvln,tvln,qvln,cvln,ozvln -! real(4),allocatable,dimension(:,:) :: qivln,qlvln,qrvln,qsvln -! real(4),allocatable,dimension(:,:) :: vpcon,pscon,varsst,corlsst -! real(4),allocatable,dimension(:) :: psvar,pshln -! end type berror_vars - real(4),allocatable,dimension(:):: corp_avn,hwllp_avn real(4),allocatable,dimension(:,:):: corsst_avn,hwllsst_avn real(4),allocatable,dimension(:,:):: bv_avn,wgv_avn,corqq_avn,pput_avn @@ -433,9 +421,11 @@ end subroutine berror_write_ subroutine berror_write_grads_(vars) type(berror_vars) vars - integer j,nsig,nlat,iret + integer j,nsig,nlat,nlon,iret + real(4),allocatable,dimension(:,:) :: aux nlat=vars%nlat + nlon=vars%nlon nsig=vars%nsig call baopenwt(lugrd,'bgstats_sp.grd',iret) @@ -491,6 +481,21 @@ subroutine berror_write_grads_(vars) enddo close(luout) +! Put out SST info to on a separate grads file + allocate(aux(nlon,nlat)) + call baopenwt(lugrd,'sst.grd',iret) + + aux = transpose(vars%varsst) + call bkgerror_ncep2geos_flip(aux) + call wryte(lugrd,4*nlat*nlon,aux) + + aux = transpose(vars%corlsst) + call bkgerror_ncep2geos_flip(aux) + call wryte(lugrd,4*nlat*nlon,aux) + + call baclose(lugrd,iret) + deallocate(aux) + end subroutine berror_write_grads_ subroutine final_berror_vars_(vr) type(berror_vars) vr From 465394b1cdd7a38520f59815ecb78ab33ea13ba5 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Fri, 27 Aug 2021 16:02:20 -0400 Subject: [PATCH 060/205] Bug fix for SST variables orientation (this needs to be corrorated by looking at SST fields in GSI) - very likely a bug. Add opt for NC4 output --- .../NCEP_Etc/NCEP_bkgecov/CMakeLists.txt | 1 + .../NCEP_Etc/NCEP_bkgecov/m_nc_berror.f90 | 195 ++++++++++++------ .../NCEP_Etc/NCEP_bkgecov/postmod.f90 | 3 +- .../NCEP_Etc/NCEP_bkgecov/sstmod.f90 | 164 ++++++++++++--- .../NCEP_Etc/NCEP_bkgecov/ut_sst_berror.f90 | 21 ++ .../NCEP_bkgecov/write_berror_global.f90 | 44 +++- 6 files changed, 321 insertions(+), 107 deletions(-) create mode 100644 src/Applications/NCEP_Etc/NCEP_bkgecov/ut_sst_berror.f90 diff --git a/src/Applications/NCEP_Etc/NCEP_bkgecov/CMakeLists.txt b/src/Applications/NCEP_Etc/NCEP_bkgecov/CMakeLists.txt index 881d845b..d0dd33dd 100644 --- a/src/Applications/NCEP_Etc/NCEP_bkgecov/CMakeLists.txt +++ b/src/Applications/NCEP_Etc/NCEP_bkgecov/CMakeLists.txt @@ -29,6 +29,7 @@ target_compile_definitions(${this} PRIVATE _LAPACK_ gmao_intf) ecbuild_add_executable(TARGET calcstats.x SOURCES statsmain.F90 LIBS ${this} ${MKL_LIBRARIES}) ecbuild_add_executable(TARGET write_berror_global.x SOURCES write_berror_global.f90 LIBS ${this} ${MKL_LIBRARIES}) +ecbuild_add_executable(TARGET ut_sst_berror.x SOURCES ut_sst_berror.f90 LIBS ${this} ${MKL_LIBRARIES}) file (GLOB tmpl_files *.tmpl) install (FILES ${tmpl_files} DESTINATION etc) diff --git a/src/Applications/NCEP_Etc/NCEP_bkgecov/m_nc_berror.f90 b/src/Applications/NCEP_Etc/NCEP_bkgecov/m_nc_berror.f90 index d0a60b80..8e92fd3a 100644 --- a/src/Applications/NCEP_Etc/NCEP_bkgecov/m_nc_berror.f90 +++ b/src/Applications/NCEP_Etc/NCEP_bkgecov/m_nc_berror.f90 @@ -3,6 +3,11 @@ module m_nc_berror implicit none private +public :: berror_vars +public :: read_nc_berror +public :: write_nc_berror +public :: bkgerror_ncep2geos_flip + type berror_vars integer :: nlon,nlat,nsig real(4),allocatable,dimension(:,:,:):: tcon @@ -16,38 +21,33 @@ module m_nc_berror real(4),allocatable,dimension(:) :: psvar,pshln end type berror_vars - integer, parameter :: nv1d = 2 - character(len=4),parameter :: cvars1d(nv1d) = (/ 'ps ', 'hps ' /) - - integer, parameter :: nv2d = 33 - character(len=5),parameter :: cvars2d(nv2d) = (/ & - 'sf ', 'hsf ', 'vsf ', & - 'vp ', 'hvp ', 'vvp ', & - 't ', 'ht ', 'vt ', & - 'q ', 'hq ', 'vq ', & - 'qi ', 'hqi ', 'vqi ', & - 'ql ', 'hql ', 'vql ', & - 'qr ', 'hqr ', 'vqr ', & - 'qs ', 'hqs ', 'vqs ', & - 'oz ', 'hoz ', 'voz ', & - 'cw ', 'hcw ', 'vcw ', & - 'pscon', 'vpcon', 'nrh ' & - /) - - integer, parameter :: nvmll = 1 ! meriodional, level, level - character(len=4),parameter :: cvarsMLL(nvmll) = (/ 'tcon' /) - - integer, parameter :: nv2dx = 2 - character(len=7),parameter :: cvars2dx(nv2dx) = (/ 'sst ', 'sstcorl' /) - -public :: berror_vars -public :: read_nc_berror -public :: write_nc_berror - -public :: bkgerror_ncep2geos_flip +integer, parameter :: nv1d = 2 +character(len=4),parameter :: cvars1d(nv1d) = (/ 'ps ', 'hps ' /) + +integer, parameter :: nv2d = 33 +character(len=5),parameter :: cvars2d(nv2d) = (/ & + 'sf ', 'hsf ', 'vsf ', & + 'vp ', 'hvp ', 'vvp ', & + 't ', 'ht ', 'vt ', & + 'q ', 'hq ', 'vq ', & + 'qi ', 'hqi ', 'vqi ', & + 'ql ', 'hql ', 'vql ', & + 'qr ', 'hqr ', 'vqr ', & + 'qs ', 'hqs ', 'vqs ', & + 'oz ', 'hoz ', 'voz ', & + 'cw ', 'hcw ', 'vcw ', & + 'pscon', 'vpcon', 'nrh ' & + /) + +integer, parameter :: nvmll = 1 ! meriodional, level, level +character(len=4),parameter :: cvarsMLL(nvmll) = (/ 'tcon' /) + +integer, parameter :: nv2dx = 2 +character(len=7),parameter :: cvars2dx(nv2dx) = (/ 'sst ', 'sstcorl' /) interface bkgerror_ncep2geos_flip - module procedure hflip2d_ + module procedure yflip_ + module procedure xyflip_ end interface contains @@ -104,14 +104,15 @@ subroutine check(status) end subroutine check end subroutine read_nc_berror -subroutine write_nc_berror (fname,bvars,plevs) +subroutine write_nc_berror (fname,bvars,plevs,viewASgsi) implicit none character(len=*), intent(in) :: fname ! input filename type(berror_vars),intent(in) :: bvars ! background error variables real(4), intent(in) :: plevs(:) - -! This is the name of the data file we will create. - character (len = *), parameter :: FILE_NAME = "simple_xy.nc" + logical, intent(in) :: viewASgsi ! determines whether output is + ! to be GSI or GEOS compliant; + ! clearly only the former can + ! be used for GSI purposes. integer, parameter :: NDIMS = 3 @@ -136,17 +137,30 @@ subroutine write_nc_berror (fname,bvars,plevs) nlev=bvars%nsig ! Create some pretend data. If this wasn't an example program, we - ! would have some real data to write, for example, model output. - dlat=180./(nlat-1.0) - allocate(lats(nlat)) - do jj = 1, nlat - lats(jj) = -90.0 + (jj-1.0)*dlat - enddo - dlon=360./nlon - allocate(lons(nlon)) - do ii = 1, nlon - lons(ii) = -180.0 + ii*dlon - enddo +! would have some real data to write, for example, model output. + if (viewASgsi) then + dlat=180./(nlat-1.0) + allocate(lats(nlat)) + do jj = nlat,1,-1 + lats(jj) = -90.0 + (jj-1.0)*dlat + enddo + dlon=360./nlon + allocate(lons(nlon)) + do ii = 1, nlon + lons(ii) = 0.0 + ii*dlon + enddo + else + dlat=180./(nlat-1.0) + allocate(lats(nlat)) + do jj = 1, nlat + lats(jj) = -90.0 + (jj-1.0)*dlat + enddo + dlon=360./nlon + allocate(lons(nlon)) + do ii = 1, nlon + lons(ii) = -180.0 + ii*dlon + enddo + endif ! Always check the return code of every netCDF function call. In ! this example program, wrapping netCDF calls with "call check()" @@ -211,6 +225,7 @@ subroutine write_nc_berror (fname,bvars,plevs) do nv = 1, nv1d if(trim(cvars1d(nv))=="ps" ) data_out(1,:,1) = bvars%psvar if(trim(cvars1d(nv))=="hps" ) data_out(1,:,1) = bvars%pshln + if(.not.viewASgsi) call bkgerror_ncep2geos_flip(data_out(1,:,1)) call check( nf90_put_var(ncid, varid1d(nv), data_out(1,:,1))) enddo deallocate(data_out) @@ -260,6 +275,7 @@ subroutine write_nc_berror (fname,bvars,plevs) if(trim(cvars2d(nv))=="pscon") data_out(1,:,:) = bvars%pscon if(trim(cvars2d(nv))=="vpcon") data_out(1,:,:) = bvars%vpcon ! + if(.not.viewASgsi) call bkgerror_ncep2geos_flip(data_out(1,:,:),'yz') call check( nf90_put_var(ncid, varid2d(nv), data_out(1,:,:)) ) enddo @@ -270,6 +286,7 @@ subroutine write_nc_berror (fname,bvars,plevs) nn = nn + 1 write(cindx,'(i4.4)') nl if(trim(cvarsMLL(nv))=="tcon") data_out(1,:,:) = bvars%tcon(:,:,nl) + if(.not.viewASgsi) call bkgerror_ncep2geos_flip(data_out(1,:,:),'yz') call check( nf90_put_var(ncid, varidMLL(nn), data_out(1,:,:)) ) enddo enddo @@ -278,13 +295,13 @@ subroutine write_nc_berror (fname,bvars,plevs) ! use of hflip should be for visualization only allocate(data_out(nlon,nlat,1)) do nv = 1, nv2dx - if(trim(cvars2dx(nv))=="sst" ) then + if(trim(cvars2dx(nv))=="sst" ) then data_out(:,:,1) = transpose(bvars%varsst) -! call hflip2d_(data_out(:,:,1)) + if(.not.viewASgsi) call bkgerror_ncep2geos_flip(data_out(:,:,1),'xy') endif if(trim(cvars2dx(nv))=="sstcorl" ) then data_out(:,:,1) = transpose(bvars%corlsst) -! call hflip2d_(data_out(:,:,1)) + if(.not.viewASgsi) call bkgerror_ncep2geos_flip(data_out(:,:,1),'xy') endif call check( nf90_put_var(ncid, varid2dx(nv), data_out(:,:,1)) ) enddo @@ -313,28 +330,76 @@ subroutine check(status) end subroutine check end subroutine write_nc_berror -subroutine hflip2d_ (q) -real(4),intent(inout) :: q(:,:) +subroutine yflip_ (q) +real(4),intent(inout) :: q(:) real(4),allocatable :: dum(:) -integer :: i,j,k,im,jm -im=size(q,1);jm=size(q,2) -allocate(dum(im)) +integer :: j,jm +jm=size(q) +allocate(dum(jm)) +dum=q do j=1,jm - do i=1,im/2 - dum(i) = q(i+im/2,j) - dum(i+im/2) = q(i,j) - enddo - q(:,j) = dum(:) + q(jm-j+1) = dum(j) enddo deallocate(dum) -allocate(dum(jm)) -do i=1,im - dum = q(i,:) +end subroutine yflip_ + +subroutine xyflip_ (q,flag) +real(4),intent(inout) :: q(:,:) +real(4),allocatable :: dum(:) +character(len=2), intent(in) :: flag +integer :: i,j,k,im,jm,km +if (trim(flag)=='xy') then + im=size(q,1);jm=size(q,2) + allocate(dum(im)) do j=1,jm - q(i,jm-j+1) = dum(j) + do i=1,im/2 + dum(i) = q(i+im/2,j) + dum(i+im/2) = q(i,j) + enddo + q(:,j) = dum(:) enddo -enddo -deallocate(dum) -end subroutine hflip2d_ + deallocate(dum) + allocate(dum(jm)) + do i=1,im + dum = q(i,:) + do j=1,jm + q(i,jm-j+1) = dum(j) + enddo + enddo + deallocate(dum) +else if (trim(flag)=='yx') then + jm=size(q,1);im=size(q,2) + allocate(dum(im)) + do j=1,jm + do i=1,im/2 + dum(i) = q(j,i+im/2) + dum(i+im/2) = q(j,i) + enddo + q(j,:) = dum(:) + enddo + deallocate(dum) + allocate(dum(jm)) + do i=1,im + dum = q(:,i) + do j=1,jm + q(jm-j+1,i) = dum(j) + enddo + enddo + deallocate(dum) +else if (trim(flag)=='yz') then + jm=size(q,1);km=size(q,2) + allocate(dum(jm)) + do k=1,km + dum = q(:,k) + do j=1,jm + q(jm-j+1,k) = dum(j) + enddo + enddo + deallocate(dum) +else + print *,'flip: bad flag choice, aborting ...' + call exit(999) +endif +end subroutine xyflip_ end module m_nc_berror diff --git a/src/Applications/NCEP_Etc/NCEP_bkgecov/postmod.f90 b/src/Applications/NCEP_Etc/NCEP_bkgecov/postmod.f90 index b3467691..a33a6d0b 100644 --- a/src/Applications/NCEP_Etc/NCEP_bkgecov/postmod.f90 +++ b/src/Applications/NCEP_Etc/NCEP_bkgecov/postmod.f90 @@ -194,7 +194,8 @@ subroutine writefiles chln=100*1.e3 cvln=0.5 -! write out files; +! write out files; RT: The file below is useless: it's not a grads file as the +! extention implies! outf=45 open(outf,file='berror_stats.grd',form='unformatted') rewind outf diff --git a/src/Applications/NCEP_Etc/NCEP_bkgecov/sstmod.f90 b/src/Applications/NCEP_Etc/NCEP_bkgecov/sstmod.f90 index cf241524..1e590a78 100644 --- a/src/Applications/NCEP_Etc/NCEP_bkgecov/sstmod.f90 +++ b/src/Applications/NCEP_Etc/NCEP_bkgecov/sstmod.f90 @@ -4,10 +4,14 @@ module sstmod ! ! $$$ use type_kinds, only: fp_kind + use m_spline, only: spline + use m_nc_berror, only: bkgerror_ncep2geos_flip implicit none real(fp_kind),allocatable,dimension(:,:):: varsst,corlsst + logical :: do_spline=.false. + logical :: orient_sst_per_gsi_std=.true. ! implements a bug fix contains @@ -32,7 +36,7 @@ subroutine sst_stats use variables, only: nlat,nlon,rlats,rlons,deg2rad implicit none - integer i,j,k,errsst,mype,ilt,iln,idx + integer i,j,k,mype,ilt,iln,idx real*4,dimension(720,360):: sstintmp real*4,dimension(720,360,9):: sst2in @@ -40,18 +44,26 @@ subroutine sst_stats real(fp_kind),dimension(360,720):: sstvin,sstcin real(fp_kind) linlat(360) real(fp_kind) linlon(720) - real(fp_kind) rlatint(nlat),rlonint(nlon) - real(fp_kind),dimension(nlat*nlon):: rlatbig,rlonbig,sstv1,sstc1 + real(fp_kind),allocatable,dimension(:):: rlatint,rlonint + real(fp_kind),allocatable,dimension(:):: rlatbig,rlonbig,sstv1,sstc1 + real(4),allocatable,dimension(:,:):: var_out,cor_out - data errsst / 23 / + integer, parameter :: lui=23 + integer, parameter :: luo=24 + + allocate(rlatint(nlat),rlonint(nlon)) + allocate(rlatbig(nlat*nlon),rlonbig(nlat*nlon)) + allocate(sstv1(nlat*nlon),sstc1(nlat*nlon)) + + ! these fields are transposed by oriented as in GEOS: [-180,180] and [-90,90] ilt=360 iln=720 - open(errsst,file='berror_sst',access='direct',& + open(lui,file='berror_sst',access='direct',& recl=720*360*4,form='unformatted') - read (errsst,rec=1) sstintmp + read (lui,rec=1) sstintmp do k=2,9 - read (errsst,rec=k) ((sst2in(i,j,k-1),i=1,iln),j=1,ilt) + read (lui,rec=k) ((sst2in(i,j,k-1),i=1,iln),j=1,ilt) end do do j=1,iln do i=1,ilt @@ -60,13 +72,17 @@ subroutine sst_stats end do end do + call sst_grads_(luo,'origsst',real(sstvin,4),real(sstcin,4),.true.) + ! the sst variances has missing values in it, which need to be filled ! with more realistic values - do i=1,200 + do i=1,200 !RT: this is real bad hack call fillsstv(sstvin,ilt,iln) end do + call sst_grads_(luo,'nofillsst',real(sstvin,4),real(sstcin,4),.true.) + ! load the lats/lons of the 0.5 x 0.5 linear grid do j=1,ilt linlat(j)=deg2rad*(0.5**2.-90.+(j-1)*0.5) @@ -84,34 +100,116 @@ subroutine sst_stats rlonint(j)=rlons(j) end do -! get linear grid coordinate numbers of gaussian points - call gdcrdp(rlatint,nlat,linlat,ilt) - call gdcrdp(rlonint,nlon,linlon,iln) -! load nlat*nlon arrays for 2d interpolation - idx=0 - do j=1,nlon - do i=1,nlat - idx=idx+1 - rlatbig(idx)=rlatint(i) - rlonbig(idx)=rlonint(j) - end do - end do - -! perform interpolation of linear grid fields to Gaussian - call intrp2(sstvin,sstv1,rlatbig,rlonbig,ilt,iln,nlat*nlon) - call intrp2(sstcin,sstc1,rlatbig,rlonbig,ilt,iln,nlat*nlon) - - idx=0 - do j=1,nlon - do i=1,nlat - idx=idx+1 - varsst(i,j)=sstv1(idx) - corlsst(i,j)=sstc1(idx) - end do - end do + if (do_spline) then + allocate(var_out(nlat,iln),cor_out(nlat,iln)) + do i=1,iln + call spline( linlat, rlatint, sstvin(:,i), var_out(:,i) ) + call spline( linlat, rlatint, sstcin(:,i), cor_out(:,i) ) + enddo + do j=1,nlat + call spline( linlon, rlonint, var_out(j,:), varsst (j,:) ) + call spline( linlon, rlonint, cor_out(j,:), corlsst(j,:) ) + enddo + deallocate(var_out,cor_out) + else +! get linear grid coordinate numbers of gaussian points + call gdcrdp(rlatint,nlat,linlat,ilt) + call gdcrdp(rlonint,nlon,linlon,iln) + +! load nlat*nlon arrays for 2d interpolation + idx=0 + do j=1,nlon + do i=1,nlat + idx=idx+1 + rlatbig(idx)=rlatint(i) + rlonbig(idx)=rlonint(j) + end do + end do + +! perform interpolation of linear grid fields to Gaussian + call intrp2(sstvin,sstv1,rlatbig,rlonbig,ilt,iln,nlat*nlon) + call intrp2(sstcin,sstc1,rlatbig,rlonbig,ilt,iln,nlat*nlon) + + idx=0 + do j=1,nlon + do i=1,nlat + idx=idx+1 + varsst(i,j)=sstv1(idx) + corlsst(i,j)=sstc1(idx) + end do + end do + + endif + + if ( orient_sst_per_gsi_std ) then +! This reorients the field as expected by GSI: [0,360] and [90,-90] + call bkgerror_ncep2geos_flip(varsst,'yz') + call bkgerror_ncep2geos_flip(corlsst,'yz') + endif + + call sst_grads_(luo,'sst4gsi',real(varsst,4),real(corlsst,4),.true.) + + deallocate(sstv1,sstc1) + deallocate(rlatbig,rlonbig) + deallocate(rlatint,rlonint) return + contains + + subroutine sst_grads_(lu,prefix_fname,var,clen,trans) + integer, intent(in) :: lu + real(4), intent(in) :: var(:,:),clen(:,:) + character(len=*),intent(in) :: prefix_fname + logical,intent(in) :: trans + real(4),allocatable:: aux(:,:) + integer :: im,jm + im=size(var,1); jm=size(var,2) + allocate(aux(im,jm)) + open(lu,file=trim(prefix_fname)//'.grd',form='unformatted',convert='little_endian',access='sequential') + if(trans) then + aux=transpose(var) + else + aux=var + endif + write(lu) aux + if(trans) then + aux=transpose(clen) + else + aux=clen + endif + write(lu) aux + close(lu) + deallocate(aux) + if (trans) then + call write_grads_ctl(prefix_fname,lu,jm,im) + else + call write_grads_ctl(prefix_fname,lu,im,jm) + endif + end subroutine sst_grads_ + + subroutine write_grads_ctl (fname, lu,im,jm) + character(len=*), intent(in) :: fname + integer, intent(in) :: lu,im,jm + + open(lu,file=trim(fname)//'.ctl',form='formatted') + write(lu,'(2a)') 'dset ^', trim(fname)//'.grd' + write(lu,'(2a)') 'title ', 'sst berror variances/corlength' + write(lu,'(a)') 'options little_endian' + write(lu,'(a,2x,f6.1)') 'undef', -999.0 ! any other preference for this? + write(lu,'(a,2x,i4,2x,a,2x,f5.1,2x,f9.6)') 'xdef',im, 'linear', 0.0, 360./im + write(lu,'(a,2x,i4,2x,a,2x,f5.1,2x,f9.6)') 'ydef',jm, 'linear', -90.0, 180./(jm-1.) + write(lu,'(a)') 'zdef 1 linear 1 1' + write(lu,'(a,2x,i4,2x,a)') 'tdef', 1, 'LINEAR 12:00Z04JUL1776 6hr' ! any date suffices + write(lu,'(a,2x,i4)') 'vars', 2 + write(lu,'(a,1x,2(i4,1x),a)') 'sst', 1,0, 'sst' + write(lu,'(a,1x,2(i4,1x),a)') 'sstcorl', 1,0, 'sstcorl' + write(lu,'(a)') 'endvars' + close(lu) + + + end subroutine write_grads_ctl + end subroutine sst_stats diff --git a/src/Applications/NCEP_Etc/NCEP_bkgecov/ut_sst_berror.f90 b/src/Applications/NCEP_Etc/NCEP_bkgecov/ut_sst_berror.f90 new file mode 100644 index 00000000..b2288598 --- /dev/null +++ b/src/Applications/NCEP_Etc/NCEP_bkgecov/ut_sst_berror.f90 @@ -0,0 +1,21 @@ +program ut_sst_berror + +use sstmod, only: create_sstvars +use sstmod, only: destroy_sstvars +use sstmod, only: sst_stats +use variables, only: create_grids +use variables, only: nlat,nlon + +implicit none +integer, parameter :: im=1152 +integer, parameter :: jm=721 +integer, parameter :: jcap=254 + +nlat=jm;nlon=im ! quick initialization of variables in common block + +call create_grids (nlat,nlon,jcap,.false.) +call create_sstvars(nlat,nlon) +call sst_stats +call destroy_sstvars + +end program ut_sst_berror diff --git a/src/Applications/NCEP_Etc/NCEP_bkgecov/write_berror_global.f90 b/src/Applications/NCEP_Etc/NCEP_bkgecov/write_berror_global.f90 index d6a99d08..f70515aa 100644 --- a/src/Applications/NCEP_Etc/NCEP_bkgecov/write_berror_global.f90 +++ b/src/Applications/NCEP_Etc/NCEP_bkgecov/write_berror_global.f90 @@ -6,6 +6,8 @@ ! ????????? El Akkraoui - changes to make it look more like NMC-code itself ! 10May2018 Todling - a little more strealined in preparation for interp ! - add ability to vertically interpolate berror +! 27Aug2021 Todling - introduce NetCDF version +! - considerable bug fix in orientation of SST fields ! ! Declare local variables @@ -34,12 +36,18 @@ program write_berror_global character(len=256) argv, ifname, ofname character(255) grdfile - character*5 var(40) + character(len=5) var(40) + character(len=256) ncfile logical merra2current ! convert older format to current format logical hydromet + logical fix_sst_orientation + logical viewASgsi hydromet = .true. + fix_sst_orientation = .false. + viewASgsi = .true. merra2current =.false. + ncfile = 'NULL' call init_() @@ -71,8 +79,12 @@ program write_berror_global call vinterp_berror_vars_(xvars,ivars) write(6,'(a)') ' Finish interpolation.' endif + if (fix_sst_orientation) then + call bkgerror_ncep2geos_flip(ivars%varsst ,'yz') + call bkgerror_ncep2geos_flip(ivars%corlsst,'yz') + endif call berror_write_(ivars,merra2current) - call be_write_nc_(ivars) + if(trim(ncfile)/='NULL') call be_write_nc_(ncfile,ivars,viewASgsi) call berror_write_grads_(ivars) call final_berror_vars_(ivars) @@ -91,7 +103,14 @@ subroutine init_ print *, "Usage: write_berror_global.x [options] ifname ofname nlon nlat nlev" print * print *, " OPTIONS:" - print *, " -nohyro - handles case w/o hydrometeors" + print *, " -nohyro - handles case w/o hydrometeors" + print *, " -fixsst - reorients SST fields as expected by GSI (bug fix)" + print *, " -viewASgeos - allow for NetCDF output to be oriented using" + print *, " - conventions (default: GSI convention)" + print *, "" + print *, " Remarks: " + print *, " 1. choosing to get reoriented NC4 output does not affect the " + print *, " orientation of the binary output typically used in GSI. " print * stop end if @@ -103,8 +122,15 @@ subroutine init_ if ( iarg .gt. argc ) exit call GetArg ( iarg, argv ) select case (trim(argv)) + case('-fixsst') + fix_sst_orientation = .true. case('-nohydro') hydromet = .false. + case('-viewASgeos') + viewASgsi = .false. + case('-nc') + iarg = iarg + 1 + call GetArg ( iarg, ncfile ) case default ncount = ncount + 1 if (ncount > fixargs) exit @@ -486,11 +512,11 @@ subroutine berror_write_grads_(vars) call baopenwt(lugrd,'sst.grd',iret) aux = transpose(vars%varsst) - call bkgerror_ncep2geos_flip(aux) + if(.not. viewASgsi) call bkgerror_ncep2geos_flip(aux,'xy') call wryte(lugrd,4*nlat*nlon,aux) aux = transpose(vars%corlsst) - call bkgerror_ncep2geos_flip(aux) + if(.not. viewASgsi) call bkgerror_ncep2geos_flip(aux,'xy') call wryte(lugrd,4*nlat*nlon,aux) call baclose(lugrd,iret) @@ -626,7 +652,7 @@ subroutine vinterp_berror_vars_(ivars,ovars) ! interpolation. It shuld be done as in ! Bnew = T Bold T', ! where T is the interpolation matrix and T' its transpose. - ! No all interpolants will preserve covariance properties. + ! Not all interpolants will preserve covariance properties. aux=0.0 do k=1,ivars%nsig call spline( plevi, plevo, ivars%tcon(j,k,:), aux(k,:) ) @@ -677,13 +703,15 @@ subroutine vinterp_berror_vars_(ivars,ovars) end subroutine vinterp_berror_vars_ - subroutine be_write_nc_(ivars) + subroutine be_write_nc_(fname,ivars,viewASgsi) use m_set_eta, only: set_eta use m_set_eta, only: get_ref_plevs implicit none + character(len=*), intent(in) :: fname type(berror_vars), intent(in) :: ivars + logical, intent(in) :: viewASgsi real(4),allocatable,dimension(:,:) :: aux real(4),allocatable,dimension(:) :: plevs @@ -697,7 +725,7 @@ subroutine be_write_nc_(ivars) call get_ref_plevs ( ak, bk, ptop, plevs ) plevs = plevs(ivars%nsig:1:-1) ! reorient GEOS-5 levs to be consistent w/ GSI(Berror) - call write_nc_berror('try.nc',ivars,plevs) + call write_nc_berror(trim(fname),ivars,plevs,viewASgsi) deallocate(ak,bk) deallocate(plevs) From 1352a2133a934cffe04e8143155323d4ca2fd67b Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Sat, 28 Aug 2021 13:13:20 -0400 Subject: [PATCH 061/205] Gladly, after careful inspection, it was found for the sst part to be correct - all unnecessary changes have been removed in turn. --- .../NCEP_Etc/NCEP_bkgecov/m_nc_berror.f90 | 125 +----------------- .../NCEP_Etc/NCEP_bkgecov/sstmod.f90 | 18 +-- .../NCEP_bkgecov/write_berror_global.f90 | 51 ++++--- 3 files changed, 33 insertions(+), 161 deletions(-) diff --git a/src/Applications/NCEP_Etc/NCEP_bkgecov/m_nc_berror.f90 b/src/Applications/NCEP_Etc/NCEP_bkgecov/m_nc_berror.f90 index 8e92fd3a..58ca2ae3 100644 --- a/src/Applications/NCEP_Etc/NCEP_bkgecov/m_nc_berror.f90 +++ b/src/Applications/NCEP_Etc/NCEP_bkgecov/m_nc_berror.f90 @@ -6,7 +6,6 @@ module m_nc_berror public :: berror_vars public :: read_nc_berror public :: write_nc_berror -public :: bkgerror_ncep2geos_flip type berror_vars integer :: nlon,nlat,nsig @@ -45,11 +44,6 @@ module m_nc_berror integer, parameter :: nv2dx = 2 character(len=7),parameter :: cvars2dx(nv2dx) = (/ 'sst ', 'sstcorl' /) -interface bkgerror_ncep2geos_flip - module procedure yflip_ - module procedure xyflip_ -end interface - contains subroutine read_nc_berror (fname,bvars) @@ -89,7 +83,7 @@ subroutine read_nc_berror (fname,bvars) ! Close the file, freeing all resources. call check( nf90_close(ncid) ) - print *,"*** SUCCESS reading example file ", fname, "! " + print *,"*** Finish reading file ", fname, "! " return @@ -104,15 +98,13 @@ subroutine check(status) end subroutine check end subroutine read_nc_berror -subroutine write_nc_berror (fname,bvars,plevs,viewASgsi) +subroutine write_nc_berror (fname,bvars,plevs,lats,lons) implicit none character(len=*), intent(in) :: fname ! input filename type(berror_vars),intent(in) :: bvars ! background error variables + real(4), intent(in) :: lats(:) ! latitudes per GSI: increase index from South to North Pole + real(4), intent(in) :: lons(:) ! longitudea per GSI: increase index from East to West real(4), intent(in) :: plevs(:) - logical, intent(in) :: viewASgsi ! determines whether output is - ! to be GSI or GEOS compliant; - ! clearly only the former can - ! be used for GSI purposes. integer, parameter :: NDIMS = 3 @@ -123,9 +115,7 @@ subroutine write_nc_berror (fname,bvars,plevs,viewASgsi) integer :: x_dimid, y_dimid, z_dimid integer :: lon_varid, lat_varid, lev_varid integer :: ii,jj,nl,nv,nn,nlat,nlon,nlev - real(4) :: dlat,dlon integer, allocatable :: varid1d(:), varid2d(:), varid2dx(:), varidMLL(:) - real(4),allocatable :: lats(:),lons(:) ! This is the data array we will write. It will just be filled with ! a progression of integers for this example. @@ -136,32 +126,6 @@ subroutine write_nc_berror (fname,bvars,plevs,viewASgsi) nlon=bvars%nlon nlev=bvars%nsig -! Create some pretend data. If this wasn't an example program, we -! would have some real data to write, for example, model output. - if (viewASgsi) then - dlat=180./(nlat-1.0) - allocate(lats(nlat)) - do jj = nlat,1,-1 - lats(jj) = -90.0 + (jj-1.0)*dlat - enddo - dlon=360./nlon - allocate(lons(nlon)) - do ii = 1, nlon - lons(ii) = 0.0 + ii*dlon - enddo - else - dlat=180./(nlat-1.0) - allocate(lats(nlat)) - do jj = 1, nlat - lats(jj) = -90.0 + (jj-1.0)*dlat - enddo - dlon=360./nlon - allocate(lons(nlon)) - do ii = 1, nlon - lons(ii) = -180.0 + ii*dlon - enddo - endif - ! Always check the return code of every netCDF function call. In ! this example program, wrapping netCDF calls with "call check()" ! makes sure that any return which is not equal to nf90_noerr (0) @@ -225,7 +189,6 @@ subroutine write_nc_berror (fname,bvars,plevs,viewASgsi) do nv = 1, nv1d if(trim(cvars1d(nv))=="ps" ) data_out(1,:,1) = bvars%psvar if(trim(cvars1d(nv))=="hps" ) data_out(1,:,1) = bvars%pshln - if(.not.viewASgsi) call bkgerror_ncep2geos_flip(data_out(1,:,1)) call check( nf90_put_var(ncid, varid1d(nv), data_out(1,:,1))) enddo deallocate(data_out) @@ -275,7 +238,6 @@ subroutine write_nc_berror (fname,bvars,plevs,viewASgsi) if(trim(cvars2d(nv))=="pscon") data_out(1,:,:) = bvars%pscon if(trim(cvars2d(nv))=="vpcon") data_out(1,:,:) = bvars%vpcon ! - if(.not.viewASgsi) call bkgerror_ncep2geos_flip(data_out(1,:,:),'yz') call check( nf90_put_var(ncid, varid2d(nv), data_out(1,:,:)) ) enddo @@ -286,7 +248,6 @@ subroutine write_nc_berror (fname,bvars,plevs,viewASgsi) nn = nn + 1 write(cindx,'(i4.4)') nl if(trim(cvarsMLL(nv))=="tcon") data_out(1,:,:) = bvars%tcon(:,:,nl) - if(.not.viewASgsi) call bkgerror_ncep2geos_flip(data_out(1,:,:),'yz') call check( nf90_put_var(ncid, varidMLL(nn), data_out(1,:,:)) ) enddo enddo @@ -297,11 +258,9 @@ subroutine write_nc_berror (fname,bvars,plevs,viewASgsi) do nv = 1, nv2dx if(trim(cvars2dx(nv))=="sst" ) then data_out(:,:,1) = transpose(bvars%varsst) - if(.not.viewASgsi) call bkgerror_ncep2geos_flip(data_out(:,:,1),'xy') endif if(trim(cvars2dx(nv))=="sstcorl" ) then data_out(:,:,1) = transpose(bvars%corlsst) - if(.not.viewASgsi) call bkgerror_ncep2geos_flip(data_out(:,:,1),'xy') endif call check( nf90_put_var(ncid, varid2dx(nv), data_out(:,:,1)) ) enddo @@ -313,10 +272,8 @@ subroutine write_nc_berror (fname,bvars,plevs,viewASgsi) deallocate(varidMLL) deallocate(varid2d) deallocate(varid1d) - deallocate(lats) - deallocate(lons) - print *, "*** SUCCESS writing example file ", fname + print *, "*** Finish writing file ", fname return contains @@ -330,76 +287,4 @@ subroutine check(status) end subroutine check end subroutine write_nc_berror -subroutine yflip_ (q) -real(4),intent(inout) :: q(:) -real(4),allocatable :: dum(:) -integer :: j,jm -jm=size(q) -allocate(dum(jm)) -dum=q -do j=1,jm - q(jm-j+1) = dum(j) -enddo -deallocate(dum) -end subroutine yflip_ - -subroutine xyflip_ (q,flag) -real(4),intent(inout) :: q(:,:) -real(4),allocatable :: dum(:) -character(len=2), intent(in) :: flag -integer :: i,j,k,im,jm,km -if (trim(flag)=='xy') then - im=size(q,1);jm=size(q,2) - allocate(dum(im)) - do j=1,jm - do i=1,im/2 - dum(i) = q(i+im/2,j) - dum(i+im/2) = q(i,j) - enddo - q(:,j) = dum(:) - enddo - deallocate(dum) - allocate(dum(jm)) - do i=1,im - dum = q(i,:) - do j=1,jm - q(i,jm-j+1) = dum(j) - enddo - enddo - deallocate(dum) -else if (trim(flag)=='yx') then - jm=size(q,1);im=size(q,2) - allocate(dum(im)) - do j=1,jm - do i=1,im/2 - dum(i) = q(j,i+im/2) - dum(i+im/2) = q(j,i) - enddo - q(j,:) = dum(:) - enddo - deallocate(dum) - allocate(dum(jm)) - do i=1,im - dum = q(:,i) - do j=1,jm - q(jm-j+1,i) = dum(j) - enddo - enddo - deallocate(dum) -else if (trim(flag)=='yz') then - jm=size(q,1);km=size(q,2) - allocate(dum(jm)) - do k=1,km - dum = q(:,k) - do j=1,jm - q(jm-j+1,k) = dum(j) - enddo - enddo - deallocate(dum) -else - print *,'flip: bad flag choice, aborting ...' - call exit(999) -endif -end subroutine xyflip_ - end module m_nc_berror diff --git a/src/Applications/NCEP_Etc/NCEP_bkgecov/sstmod.f90 b/src/Applications/NCEP_Etc/NCEP_bkgecov/sstmod.f90 index 1e590a78..5adcb214 100644 --- a/src/Applications/NCEP_Etc/NCEP_bkgecov/sstmod.f90 +++ b/src/Applications/NCEP_Etc/NCEP_bkgecov/sstmod.f90 @@ -5,13 +5,11 @@ module sstmod ! $$$ use type_kinds, only: fp_kind use m_spline, only: spline - use m_nc_berror, only: bkgerror_ncep2geos_flip implicit none real(fp_kind),allocatable,dimension(:,:):: varsst,corlsst logical :: do_spline=.false. - logical :: orient_sst_per_gsi_std=.true. ! implements a bug fix contains @@ -142,12 +140,6 @@ subroutine sst_stats endif - if ( orient_sst_per_gsi_std ) then -! This reorients the field as expected by GSI: [0,360] and [90,-90] - call bkgerror_ncep2geos_flip(varsst,'yz') - call bkgerror_ncep2geos_flip(corlsst,'yz') - endif - call sst_grads_(luo,'sst4gsi',real(varsst,4),real(corlsst,4),.true.) deallocate(sstv1,sstc1) @@ -188,7 +180,10 @@ subroutine sst_grads_(lu,prefix_fname,var,clen,trans) endif end subroutine sst_grads_ - subroutine write_grads_ctl (fname, lu,im,jm) + end subroutine sst_stats + + subroutine write_grads_ctl (fname, lu,im,jm) + implicit none character(len=*), intent(in) :: fname integer, intent(in) :: lu,im,jm @@ -208,10 +203,7 @@ subroutine write_grads_ctl (fname, lu,im,jm) close(lu) - end subroutine write_grads_ctl - - end subroutine sst_stats - + end subroutine write_grads_ctl subroutine gdcrdp(d,nd,x,nx) use type_kinds, only: fp_kind diff --git a/src/Applications/NCEP_Etc/NCEP_bkgecov/write_berror_global.f90 b/src/Applications/NCEP_Etc/NCEP_bkgecov/write_berror_global.f90 index f70515aa..cc219828 100644 --- a/src/Applications/NCEP_Etc/NCEP_bkgecov/write_berror_global.f90 +++ b/src/Applications/NCEP_Etc/NCEP_bkgecov/write_berror_global.f90 @@ -7,7 +7,6 @@ ! 10May2018 Todling - a little more strealined in preparation for interp ! - add ability to vertically interpolate berror ! 27Aug2021 Todling - introduce NetCDF version -! - considerable bug fix in orientation of SST fields ! ! Declare local variables @@ -15,7 +14,6 @@ program write_berror_global use m_nc_berror, only: berror_vars use m_nc_berror, only: write_nc_berror - use m_nc_berror, only: bkgerror_ncep2geos_flip implicit none real(4),allocatable,dimension(:):: corp_avn,hwllp_avn @@ -40,12 +38,8 @@ program write_berror_global character(len=256) ncfile logical merra2current ! convert older format to current format logical hydromet - logical fix_sst_orientation - logical viewASgsi hydromet = .true. - fix_sst_orientation = .false. - viewASgsi = .true. merra2current =.false. ncfile = 'NULL' @@ -79,12 +73,8 @@ program write_berror_global call vinterp_berror_vars_(xvars,ivars) write(6,'(a)') ' Finish interpolation.' endif - if (fix_sst_orientation) then - call bkgerror_ncep2geos_flip(ivars%varsst ,'yz') - call bkgerror_ncep2geos_flip(ivars%corlsst,'yz') - endif call berror_write_(ivars,merra2current) - if(trim(ncfile)/='NULL') call be_write_nc_(ncfile,ivars,viewASgsi) + if(trim(ncfile)/='NULL') call be_write_nc_(ncfile,ivars) call berror_write_grads_(ivars) call final_berror_vars_(ivars) @@ -104,13 +94,8 @@ subroutine init_ print * print *, " OPTIONS:" print *, " -nohyro - handles case w/o hydrometeors" - print *, " -fixsst - reorients SST fields as expected by GSI (bug fix)" - print *, " -viewASgeos - allow for NetCDF output to be oriented using" - print *, " - conventions (default: GSI convention)" + print *, " -nc FNAME - output errors in NetCDF format to file FNAME" print *, "" - print *, " Remarks: " - print *, " 1. choosing to get reoriented NC4 output does not affect the " - print *, " orientation of the binary output typically used in GSI. " print * stop end if @@ -122,12 +107,8 @@ subroutine init_ if ( iarg .gt. argc ) exit call GetArg ( iarg, argv ) select case (trim(argv)) - case('-fixsst') - fix_sst_orientation = .true. case('-nohydro') hydromet = .false. - case('-viewASgeos') - viewASgsi = .false. case('-nc') iarg = iarg + 1 call GetArg ( iarg, ncfile ) @@ -446,6 +427,7 @@ subroutine berror_write_(vr,m2c) end subroutine berror_write_ subroutine berror_write_grads_(vars) + use sstmod, only: write_grads_ctl type(berror_vars) vars integer j,nsig,nlat,nlon,iret real(4),allocatable,dimension(:,:) :: aux @@ -512,15 +494,14 @@ subroutine berror_write_grads_(vars) call baopenwt(lugrd,'sst.grd',iret) aux = transpose(vars%varsst) - if(.not. viewASgsi) call bkgerror_ncep2geos_flip(aux,'xy') call wryte(lugrd,4*nlat*nlon,aux) aux = transpose(vars%corlsst) - if(.not. viewASgsi) call bkgerror_ncep2geos_flip(aux,'xy') call wryte(lugrd,4*nlat*nlon,aux) call baclose(lugrd,iret) deallocate(aux) + call write_grads_ctl('sst',lugrd,nlon,nlat) end subroutine berror_write_grads_ subroutine final_berror_vars_(vr) @@ -703,7 +684,7 @@ subroutine vinterp_berror_vars_(ivars,ovars) end subroutine vinterp_berror_vars_ - subroutine be_write_nc_(fname,ivars,viewASgsi) + subroutine be_write_nc_(fname,ivars) use m_set_eta, only: set_eta use m_set_eta, only: get_ref_plevs @@ -711,13 +692,14 @@ subroutine be_write_nc_(fname,ivars,viewASgsi) character(len=*), intent(in) :: fname type(berror_vars), intent(in) :: ivars - logical, intent(in) :: viewASgsi real(4),allocatable,dimension(:,:) :: aux + real(4),allocatable,dimension(:) :: lats,lons real(4),allocatable,dimension(:) :: plevs real(4),allocatable,dimension(:) :: ak,bk - real(4) ptop, pint - integer k,ks + real(4) ptop, pint, dlon, dlat + integer :: nlat,nlon + integer ii,jj,k,ks allocate(plevs(ivars%nsig)) allocate(ak(ivars%nsig+1),bk(ivars%nsig+1)) @@ -725,10 +707,23 @@ subroutine be_write_nc_(fname,ivars,viewASgsi) call get_ref_plevs ( ak, bk, ptop, plevs ) plevs = plevs(ivars%nsig:1:-1) ! reorient GEOS-5 levs to be consistent w/ GSI(Berror) - call write_nc_berror(trim(fname),ivars,plevs,viewASgsi) +! The following defines lat/lon per GSI orientation + nlon=ivars%nlon; nlat=ivars%nlat + allocate(lons(nlon),lats(nlat)) + dlat=180./(nlat-1.0) + do jj = nlat,1,-1 + lats(jj) = -90.0 + (jj-1.0)*dlat + enddo + dlon=360./nlon + do ii = 1, nlon + lons(ii) = (ii-1.0)*dlon + enddo + + call write_nc_berror(trim(fname),ivars,plevs,lats,lons) deallocate(ak,bk) deallocate(plevs) + deallocate(lons,lats) end subroutine be_write_nc_ From f8239939384001f443040fb21cb83189158b3a5e Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Sat, 28 Aug 2021 16:59:43 -0400 Subject: [PATCH 062/205] Now reader available and checked --- .../NCEP_Etc/NCEP_bkgecov/m_nc_berror.f90 | 102 +++++++++++++++--- .../NCEP_bkgecov/write_berror_global.f90 | 87 ++++++++++++++- 2 files changed, 175 insertions(+), 14 deletions(-) diff --git a/src/Applications/NCEP_Etc/NCEP_bkgecov/m_nc_berror.f90 b/src/Applications/NCEP_Etc/NCEP_bkgecov/m_nc_berror.f90 index 58ca2ae3..b66df1fd 100644 --- a/src/Applications/NCEP_Etc/NCEP_bkgecov/m_nc_berror.f90 +++ b/src/Applications/NCEP_Etc/NCEP_bkgecov/m_nc_berror.f90 @@ -55,9 +55,9 @@ subroutine read_nc_berror (fname,bvars) integer :: ncid, varid ! Local variables - integer ii,jj,nlat,nlon,nlev - real(4), allocatable :: data1d(:) - real(4), allocatable :: data2d(:,:) + character(len=4) :: cindx + integer nv,nl,nlat,nlon,nlev + real(4), allocatable :: data_in(:,:,:) ! Set dims nlat=bvars%nlat @@ -69,21 +69,97 @@ subroutine read_nc_berror (fname,bvars) call check( nf90_open(fname, NF90_NOWRITE, ncid) ) -! Allocate dims - allocate(data2d(nlat,nlev)) +! Read data to file + allocate(data_in(1,nlat,1)) + do nv = 1, nv1d + call check( nf90_inq_varid(ncid, trim(cvars1d(nv)), varid) ) + call check( nf90_get_var(ncid, varid, data_in(1,:,1))) + if(trim(cvars1d(nv))=="ps" ) bvars%psvar = data_in(1,:,1) + if(trim(cvars1d(nv))=="hps" ) bvars%pshln = data_in(1,:,1) + enddo + deallocate(data_in) + allocate(data_in(1,nlat,nlev)) + do nv = 1, nv2d + call check( nf90_inq_varid(ncid, trim(cvars2d(nv)), varid) ) + call check( nf90_get_var(ncid, varid, data_in(1,:,:)) ) -! Get the varid of the data variable, based on its name. - call check( nf90_inq_varid(ncid, "d", varid) ) + if(trim(cvars2d(nv))=="sf" ) bvars%sfvar = data_in(1,:,:) + if(trim(cvars2d(nv))=="hsf") bvars%sfhln = data_in(1,:,:) + if(trim(cvars2d(nv))=="vsf") bvars%sfvln = data_in(1,:,:) +! + if(trim(cvars2d(nv))=="vp" ) bvars%vpvar = data_in(1,:,:) + if(trim(cvars2d(nv))=="hvp") bvars%vphln = data_in(1,:,:) + if(trim(cvars2d(nv))=="vvp") bvars%vpvln = data_in(1,:,:) +! + if(trim(cvars2d(nv))=="t" ) bvars%tvar = data_in(1,:,:) + if(trim(cvars2d(nv))=="ht" ) bvars%thln = data_in(1,:,:) + if(trim(cvars2d(nv))=="vt" ) bvars%tvln = data_in(1,:,:) +! + if(trim(cvars2d(nv))=="q" ) bvars%qvar = data_in(1,:,:) + if(trim(cvars2d(nv))=="hq" ) bvars%qhln = data_in(1,:,:) + if(trim(cvars2d(nv))=="vq" ) bvars%qvln = data_in(1,:,:) +! + if(trim(cvars2d(nv))=="qi" ) bvars%qivar = data_in(1,:,:) + if(trim(cvars2d(nv))=="hqi") bvars%qihln = data_in(1,:,:) + if(trim(cvars2d(nv))=="vqi") bvars%qivln = data_in(1,:,:) +! + if(trim(cvars2d(nv))=="ql" ) bvars%qlvar = data_in(1,:,:) + if(trim(cvars2d(nv))=="hql") bvars%qlhln = data_in(1,:,:) + if(trim(cvars2d(nv))=="vql") bvars%qlvln = data_in(1,:,:) +! + if(trim(cvars2d(nv))=="qr" ) bvars%qrvar = data_in(1,:,:) + if(trim(cvars2d(nv))=="hqr") bvars%qrhln = data_in(1,:,:) + if(trim(cvars2d(nv))=="vqr") bvars%qrvln = data_in(1,:,:) +! + if(trim(cvars2d(nv))=="nrh") bvars%nrhvar = data_in(1,:,:) + if(trim(cvars2d(nv))=="qs" ) bvars%qsvar = data_in(1,:,:) + if(trim(cvars2d(nv))=="hqs") bvars%qshln = data_in(1,:,:) + if(trim(cvars2d(nv))=="vqs") bvars%qsvln = data_in(1,:,:) +! + if(trim(cvars2d(nv))=="cw" ) bvars%cvar = data_in(1,:,:) + if(trim(cvars2d(nv))=="hcw") bvars%chln = data_in(1,:,:) + if(trim(cvars2d(nv))=="vcw") bvars%cvln = data_in(1,:,:) +! + if(trim(cvars2d(nv))=="oz" ) bvars%ozvar = data_in(1,:,:) + if(trim(cvars2d(nv))=="hoz") bvars%ozhln = data_in(1,:,:) + if(trim(cvars2d(nv))=="voz") bvars%ozvln = data_in(1,:,:) +! + if(trim(cvars2d(nv))=="pscon") bvars%pscon = data_in(1,:,:) + if(trim(cvars2d(nv))=="vpcon") bvars%vpcon = data_in(1,:,:) +! + enddo -! Read data - call check( nf90_get_var(ncid, varid, data2d) ) +! Get matrix NLATxNLEVxNLEV that has been written as NLEV 2d-fields + do nv = 1, nvmll + do nl = 1, nlev + write(cindx,'(i4.4)') nl + if(trim(cvarsMLL(nv))=="tcon") then + call check( nf90_inq_varid(ncid, trim(cvarsMLL(nv))//cindx, varid) ) + call check( nf90_get_var(ncid, varid, data_in(1,:,:)) ) + bvars%tcon(:,:,nl) = data_in(1,:,:) + endif + enddo + enddo + deallocate(data_in) - deallocate(data2d) +! Write out lat/lon fields + allocate(data_in(nlon,nlat,1)) + do nv = 1, nv2dx + call check( nf90_inq_varid(ncid, trim(cvars2dx(nv)), varid) ) + call check( nf90_get_var(ncid, varid, data_in(:,:,1)) ) + if(trim(cvars2dx(nv))=="sst" ) then + bvars%varsst = transpose(data_in(:,:,1)) + endif + if(trim(cvars2dx(nv))=="sstcorl" ) then + bvars%corlsst = transpose(data_in(:,:,1)) + endif + enddo + deallocate(data_in) - ! Close the file, freeing all resources. +! Close the file, freeing all resources. call check( nf90_close(ncid) ) - print *,"*** Finish reading file ", fname, "! " + print *,"*** Finish reading file: ", trim(fname) return @@ -253,7 +329,7 @@ subroutine write_nc_berror (fname,bvars,plevs,lats,lons) enddo deallocate(data_out) -! use of hflip should be for visualization only +! Write out lat/lon fields allocate(data_out(nlon,nlat,1)) do nv = 1, nv2dx if(trim(cvars2dx(nv))=="sst" ) then diff --git a/src/Applications/NCEP_Etc/NCEP_bkgecov/write_berror_global.f90 b/src/Applications/NCEP_Etc/NCEP_bkgecov/write_berror_global.f90 index cc219828..0cabdd11 100644 --- a/src/Applications/NCEP_Etc/NCEP_bkgecov/write_berror_global.f90 +++ b/src/Applications/NCEP_Etc/NCEP_bkgecov/write_berror_global.f90 @@ -13,6 +13,7 @@ program write_berror_global use m_nc_berror, only: berror_vars + use m_nc_berror, only: read_nc_berror use m_nc_berror, only: write_nc_berror implicit none @@ -38,6 +39,7 @@ program write_berror_global character(len=256) ncfile logical merra2current ! convert older format to current format logical hydromet + logical :: nc_read_test = .true. hydromet = .true. merra2current =.false. @@ -72,9 +74,19 @@ program write_berror_global call copy_berror_vars_(xvars,ivars) call vinterp_berror_vars_(xvars,ivars) write(6,'(a)') ' Finish interpolation.' + call destroy_berror_vars_(xvars) endif call berror_write_(ivars,merra2current) - if(trim(ncfile)/='NULL') call be_write_nc_(ncfile,ivars) + if(trim(ncfile)/='NULL') then + call be_write_nc_(ncfile,ivars) + if ( nc_read_test ) then + call init_berror_vars_(xvars,ivars%nlon,ivars%nlat,ivars%nsig) + call read_nc_berror(ncfile,xvars) + call be_write_nc_('again.nc',xvars) + call comp_berror_vars_(ivars,xvars) + call destroy_berror_vars_(xvars) + endif + endif call berror_write_grads_(ivars) call final_berror_vars_(ivars) @@ -208,6 +220,79 @@ subroutine init_berror_vars_(vr,nlon,nlat,nsig) allocate(vr%psvar(nlat),vr%pshln(nlat)) end subroutine init_berror_vars_ + subroutine destroy_berror_vars_(vr) + type(berror_vars) vr +! deallocate arrays + deallocate(vr%sfvar,vr%vpvar,vr%tvar,vr%qvar, & + vr%qivar,vr%qlvar,vr%qrvar,vr%qsvar,& + vr%cvar,vr%nrhvar,vr%ozvar) + deallocate(vr%sfhln,vr%vphln,vr%thln,vr%qhln, & + vr%qihln,vr%qlhln,vr%qrhln,vr%qshln,& + vr%chln, vr%ozhln) + deallocate(vr%sfvln,vr%vpvln,vr%tvln,vr%qvln, & + vr%qivln,vr%qlvln,vr%qrvln,vr%qsvln,& + vr%cvln, vr%ozvln) + deallocate(vr%pscon,vr%vpcon) + deallocate(vr%varsst,vr%corlsst) + deallocate(vr%tcon) + deallocate(vr%psvar,vr%pshln) + end subroutine destroy_berror_vars_ + + subroutine comp_berror_vars_(va,vb) + type(berror_vars) va + type(berror_vars) vb + integer :: ii,jj,ier(50) + logical failed + real :: tolerance = 10.e-10 + ii=0;ier=0 + ii=ii+1; if(abs(sum(va%sfvar - vb%sfvar)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%vpvar - vb%vpvar)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%tvar - vb%tvar)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%qvar - vb%qvar )) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%qivar - vb%qivar)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%qlvar - vb%qlvar)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%qrvar - vb%qrvar)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%qsvar - vb%qsvar) )>tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%cvar - vb%cvar )) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%nrhvar- vb%nrhvar))>tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%ozvar - vb%ozvar)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%sfhln - vb%sfhln)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%vphln - vb%vphln ))>tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%thln - vb%thln)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%qhln - vb%qhln) ) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%qihln - vb%qihln)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%qlhln - vb%qlhln)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%qrhln - vb%qrhln) )>tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%qshln - vb%qshln ))>tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%chln - vb%chln )) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%ozhln - vb%ozhln)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%sfvln - vb%sfvln)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%vpvln - vb%vpvln)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%tvln - vb%tvln)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%qvln - vb%qvln )) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%qivln - vb%qivln)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%qlvln - vb%qlvln)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%qrvln - vb%qrvln)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%qsvln - vb%qsvln) )>tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%cvln - vb%cvln )) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%ozvln - vb%ozvln)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%pscon - vb%pscon)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%vpcon - vb%vpcon)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%varsst- vb%varsst))>tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%corlsst-vb%corlsst))>tolerance)ier(ii)=ii + ii=ii+1; if(abs(sum(va%tcon - vb%tcon)) >tolerance) ier(ii)=ii + failed=.false. + do jj=1,ii + if(ier(jj)/=0) then + print *, 'Found field ', jj, ' not to match' + failed=.true. + endif + enddo + if (.not.failed) then + print *, 'Comp finds all fields to match' + endif + end subroutine comp_berror_vars_ + subroutine berror_read_(vr) type(berror_vars) vr From e6754c1756762c97a615a69f731f8f05a01a0e29 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Mon, 30 Aug 2021 09:03:44 -0400 Subject: [PATCH 063/205] minor clean up --- .../NCEP_Etc/NCEP_bkgecov/m_nc_berror.f90 | 193 +++++++++++++++++- .../NCEP_bkgecov/write_berror_global.f90 | 137 ++----------- 2 files changed, 204 insertions(+), 126 deletions(-) diff --git a/src/Applications/NCEP_Etc/NCEP_bkgecov/m_nc_berror.f90 b/src/Applications/NCEP_Etc/NCEP_bkgecov/m_nc_berror.f90 index b66df1fd..26236396 100644 --- a/src/Applications/NCEP_Etc/NCEP_bkgecov/m_nc_berror.f90 +++ b/src/Applications/NCEP_Etc/NCEP_bkgecov/m_nc_berror.f90 @@ -3,6 +3,9 @@ module m_nc_berror implicit none private +public :: init_berror_vars +public :: final_berror_vars +public :: comp_berror_vars public :: berror_vars public :: read_nc_berror public :: write_nc_berror @@ -20,6 +23,8 @@ module m_nc_berror real(4),allocatable,dimension(:) :: psvar,pshln end type berror_vars +character(len=*), parameter :: myname = 'm_nc_berror' + integer, parameter :: nv1d = 2 character(len=4),parameter :: cvars1d(nv1d) = (/ 'ps ', 'hps ' /) @@ -44,21 +49,46 @@ module m_nc_berror integer, parameter :: nv2dx = 2 character(len=7),parameter :: cvars2dx(nv2dx) = (/ 'sst ', 'sstcorl' /) +interface read_nc_berror; module procedure & + read_berror_ ; end interface +interface write_nc_berror; module procedure & + write_berror_ ; end interface +interface init_berror_vars; module procedure & + init_berror_vars_ ; end interface +interface final_berror_vars; module procedure & + final_berror_vars_ ; end interface +interface comp_berror_vars; module procedure & + comp_berror_vars_ ; end interface + contains -subroutine read_nc_berror (fname,bvars) +subroutine read_berror_ (fname,bvars,rc, myid,root) implicit none character(len=*), intent(in) :: fname ! input filename type(berror_vars),intent(inout) :: bvars ! background error variables + integer, intent(out) :: rc + integer, intent(in), optional :: myid,root ! accommodate MPI calling programs ! This will be the netCDF ID for the file and data variable. integer :: ncid, varid ! Local variables + character(len=*), parameter :: myname_ = myname//"::read_" character(len=4) :: cindx - integer nv,nl,nlat,nlon,nlev + integer :: nv,nl,nlat,nlon,nlev + integer :: ndims_, nvars_, ngatts_, unlimdimid_ + integer :: nlat_,nlon_,nlev_ real(4), allocatable :: data_in(:,:,:) + logical :: verbose + +! Return code (status) + rc = 0 + verbose=.true. + if(present(myid).and.present(root) )then + if(myid/=root) verbose=.false. + endif + ! Set dims nlat=bvars%nlat nlon=bvars%nlon @@ -69,6 +99,27 @@ subroutine read_nc_berror (fname,bvars) call check( nf90_open(fname, NF90_NOWRITE, ncid) ) +! Read global attributes + call check( nf90_inquire(ncid, ndims_, nvars_, ngatts_, unlimdimid_) ) + call check( nf90_inq_dimid(ncid, "lon", varid) ) + call check( nf90_inquire_dimension(ncid, varid, len=nlon_) ) + call check( nf90_inq_dimid(ncid, "lat", varid) ) + call check( nf90_inquire_dimension(ncid, varid, len=nlat_) ) + call check( nf90_inq_dimid(ncid, "lev", varid) ) + call check( nf90_inquire_dimension(ncid, varid, len=nlev_) ) + +! Consistency check + if (nlon_ /= nlon .or. nlat_ /=nlat .or. nlev_/=nlev ) then + rc=1 + if(myid==root) then + print *, 'nlat(file) = ', nlat_, 'nlat(required) = ', nlat + print *, 'nlon(file) = ', nlon_, 'nlon(required) = ', nlon + print *, 'nlev(file) = ', nlev_, 'nlev(required) = ', nlev + print *, myname_, 'Inconsistent dimensions, aborting ... ' + endif + return + endif + ! Read data to file allocate(data_in(1,nlat,1)) do nv = 1, nv1d @@ -159,7 +210,7 @@ subroutine read_nc_berror (fname,bvars) ! Close the file, freeing all resources. call check( nf90_close(ncid) ) - print *,"*** Finish reading file: ", trim(fname) + if(verbose) print *,"*** Finish reading file: ", trim(fname) return @@ -172,16 +223,19 @@ subroutine check(status) stop "Stopped" end if end subroutine check -end subroutine read_nc_berror +end subroutine read_berror_ -subroutine write_nc_berror (fname,bvars,plevs,lats,lons) +subroutine write_berror_ (fname,bvars,plevs,lats,lons,rc, myid,root) implicit none character(len=*), intent(in) :: fname ! input filename type(berror_vars),intent(in) :: bvars ! background error variables real(4), intent(in) :: lats(:) ! latitudes per GSI: increase index from South to North Pole real(4), intent(in) :: lons(:) ! longitudea per GSI: increase index from East to West real(4), intent(in) :: plevs(:) + integer, intent(out) :: rc + integer, intent(in), optional :: myid,root ! accommodate MPI calling programs + character(len=*), parameter :: myname_ = myname//"::read_" integer, parameter :: NDIMS = 3 ! When we create netCDF files, variables and dimensions, we get back @@ -192,11 +246,19 @@ subroutine write_nc_berror (fname,bvars,plevs,lats,lons) integer :: lon_varid, lat_varid, lev_varid integer :: ii,jj,nl,nv,nn,nlat,nlon,nlev integer, allocatable :: varid1d(:), varid2d(:), varid2dx(:), varidMLL(:) + logical :: verbose ! This is the data array we will write. It will just be filled with ! a progression of integers for this example. real(4), allocatable :: data_out(:,:,:) +! Return code (status) + rc = 0 + verbose=.true. + if(present(myid).and.present(root) )then + if(myid/=root) verbose=.false. + endif + ! Set dims nlat=bvars%nlat nlon=bvars%nlon @@ -361,6 +423,125 @@ subroutine check(status) stop "Stopped" end if end subroutine check -end subroutine write_nc_berror +end subroutine write_berror_ + +subroutine init_berror_vars_(vr,nlon,nlat,nsig) + + integer,intent(in) :: nlon,nlat,nsig + type(berror_vars) vr + + vr%nlon=nlon + vr%nlat=nlat + vr%nsig=nsig + +! allocate single precision arrays + allocate(vr%sfvar(nlat,nsig),vr%vpvar(nlat,nsig),vr%tvar(nlat,nsig),vr%qvar(nlat,nsig), & + vr%qivar(nlat,nsig),vr%qlvar(nlat,nsig),vr%qrvar(nlat,nsig),vr%qsvar(nlat,nsig),& + vr%cvar(nlat,nsig),vr%nrhvar(nlat,nsig),vr%ozvar(nlat,nsig)) + allocate(vr%sfhln(nlat,nsig),vr%vphln(nlat,nsig),vr%thln(nlat,nsig),vr%qhln(nlat,nsig), & + vr%qihln(nlat,nsig),vr%qlhln(nlat,nsig),vr%qrhln(nlat,nsig),vr%qshln(nlat,nsig),& + vr%chln(nlat,nsig), vr%ozhln(nlat,nsig)) + allocate(vr%sfvln(nlat,nsig),vr%vpvln(nlat,nsig),vr%tvln(nlat,nsig),vr%qvln(nlat,nsig), & + vr%qivln(nlat,nsig),vr%qlvln(nlat,nsig),vr%qrvln(nlat,nsig),vr%qsvln(nlat,nsig),& + vr%cvln(nlat,nsig), vr%ozvln(nlat,nsig)) + allocate(vr%pscon(nlat,nsig),vr%vpcon(nlat,nsig)) + allocate(vr%varsst(nlat,nlon),vr%corlsst(nlat,nlon)) + allocate(vr%tcon(nlat,nsig,nsig)) + allocate(vr%psvar(nlat),vr%pshln(nlat)) + end subroutine init_berror_vars_ + + subroutine final_berror_vars_(vr) + type(berror_vars) vr +! deallocate arrays + deallocate(vr%sfvar,vr%vpvar,vr%tvar,vr%qvar, & + vr%qivar,vr%qlvar,vr%qrvar,vr%qsvar,& + vr%cvar,vr%nrhvar,vr%ozvar) + deallocate(vr%sfhln,vr%vphln,vr%thln,vr%qhln, & + vr%qihln,vr%qlhln,vr%qrhln,vr%qshln,& + vr%chln, vr%ozhln) + deallocate(vr%sfvln,vr%vpvln,vr%tvln,vr%qvln, & + vr%qivln,vr%qlvln,vr%qrvln,vr%qsvln,& + vr%cvln, vr%ozvln) + deallocate(vr%pscon,vr%vpcon) + deallocate(vr%varsst,vr%corlsst) + deallocate(vr%tcon) + deallocate(vr%psvar,vr%pshln) +end subroutine final_berror_vars_ + +subroutine comp_berror_vars_(va,vb,rc, myid,root) + type(berror_vars) va + type(berror_vars) vb + integer, intent(out) :: rc + integer, intent(in), optional :: myid,root ! accommodate MPI calling programs + character(len=*), parameter :: myname_ = myname//"::comp_berror_vars_" + integer :: ii,jj,ier(50) + logical :: verbose, failed + real :: tolerance = 10.e-10 +! + rc=0 + verbose=.true. + if(present(myid).and.present(root) )then + if(myid/=root) verbose=.false. + endif +! Consistency check + if (va%nlon/=vb%nlon .or. va%nlat/=vb%nlat .or. va%nsig/=vb%nsig ) then + rc=1 + if(myid==root) then + print *, 'nlat(va) = ', va%nlat, 'nlat(vb) = ', vb%nlat + print *, 'nlon(va) = ', va%nlon, 'nlon(vb) = ', vb%nlon + print *, 'nlev(va) = ', va%nsig, 'nlev(vb) = ', vb%nsig + print *, myname_, 'Inconsistent dimensions, aborting ... ' + endif + return + endif + + ii=0;ier=0 + ii=ii+1; if(abs(sum(va%sfvar - vb%sfvar)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%vpvar - vb%vpvar)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%tvar - vb%tvar)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%qvar - vb%qvar )) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%qivar - vb%qivar)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%qlvar - vb%qlvar)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%qrvar - vb%qrvar)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%qsvar - vb%qsvar) )>tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%cvar - vb%cvar )) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%nrhvar- vb%nrhvar))>tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%ozvar - vb%ozvar)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%sfhln - vb%sfhln)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%vphln - vb%vphln ))>tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%thln - vb%thln)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%qhln - vb%qhln) ) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%qihln - vb%qihln)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%qlhln - vb%qlhln)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%qrhln - vb%qrhln) )>tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%qshln - vb%qshln ))>tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%chln - vb%chln )) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%ozhln - vb%ozhln)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%sfvln - vb%sfvln)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%vpvln - vb%vpvln)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%tvln - vb%tvln)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%qvln - vb%qvln )) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%qivln - vb%qivln)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%qlvln - vb%qlvln)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%qrvln - vb%qrvln)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%qsvln - vb%qsvln) )>tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%cvln - vb%cvln )) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%ozvln - vb%ozvln)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%pscon - vb%pscon)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%vpcon - vb%vpcon)) >tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%varsst- vb%varsst))>tolerance) ier(ii)=ii + ii=ii+1; if(abs(sum(va%corlsst-vb%corlsst))>tolerance)ier(ii)=ii + ii=ii+1; if(abs(sum(va%tcon - vb%tcon)) >tolerance) ier(ii)=ii + failed=.false. + do jj=1,ii + if(ier(jj)/=0.and.verbose) then + print *, 'Found field ', jj, ' not to match' + failed=.true. + endif + enddo + if (.not.failed) then + if(verbose) print *, 'Comp finds all fields to match' + endif +end subroutine comp_berror_vars_ end module m_nc_berror diff --git a/src/Applications/NCEP_Etc/NCEP_bkgecov/write_berror_global.f90 b/src/Applications/NCEP_Etc/NCEP_bkgecov/write_berror_global.f90 index 0cabdd11..09655bb4 100644 --- a/src/Applications/NCEP_Etc/NCEP_bkgecov/write_berror_global.f90 +++ b/src/Applications/NCEP_Etc/NCEP_bkgecov/write_berror_global.f90 @@ -12,6 +12,9 @@ program write_berror_global + use m_nc_berror, only: init_berror_vars + use m_nc_berror, only: final_berror_vars + use m_nc_berror, only: comp_berror_vars use m_nc_berror, only: berror_vars use m_nc_berror, only: read_nc_berror use m_nc_berror, only: write_nc_berror @@ -32,6 +35,7 @@ program write_berror_global integer isig,ilat,ilon ! dims in file integer msig,mlat,mlon ! user dims integer i,j,k,m,ncfggg,iret,kindex + integer status character(len=256) argv, ifname, ofname character(255) grdfile @@ -49,7 +53,7 @@ program write_berror_global call get_berror_dims_(ilon,ilat,isig) - call init_berror_vars_(ivars,ilon,ilat,isig) + call init_berror_vars(ivars,ilon,ilat,isig) if (merra2current) then call berror_old_read_(mlon,mlat,msig) @@ -67,30 +71,29 @@ program write_berror_global endif if (msig/=ivars%nsig) then write(6,'(a)') ' Interpolating error covariance fields ...' - call init_berror_vars_(xvars,ilon,ilat,isig) + call init_berror_vars(xvars,ilon,ilat,isig) call copy_berror_vars_(ivars,xvars) - call final_berror_vars_(ivars) - call init_berror_vars_(ivars,ilon,ilat,msig) + call final_berror_vars(ivars) + call init_berror_vars(ivars,ilon,ilat,msig) call copy_berror_vars_(xvars,ivars) call vinterp_berror_vars_(xvars,ivars) write(6,'(a)') ' Finish interpolation.' - call destroy_berror_vars_(xvars) + call final_berror_vars(xvars) endif call berror_write_(ivars,merra2current) if(trim(ncfile)/='NULL') then call be_write_nc_(ncfile,ivars) if ( nc_read_test ) then - call init_berror_vars_(xvars,ivars%nlon,ivars%nlat,ivars%nsig) - call read_nc_berror(ncfile,xvars) + call init_berror_vars(xvars,ivars%nlon,ivars%nlat,ivars%nsig) + call read_nc_berror(ncfile,xvars,status) call be_write_nc_('again.nc',xvars) - call comp_berror_vars_(ivars,xvars) - call destroy_berror_vars_(xvars) + call comp_berror_vars(ivars,xvars,status) + call final_berror_vars(xvars) endif endif call berror_write_grads_(ivars) - call final_berror_vars_(ivars) - + call final_berror_vars(ivars) contains @@ -195,104 +198,6 @@ subroutine get_berror_dims_(nlon,nlat,nsig) close(luin) end subroutine get_berror_dims_ - subroutine init_berror_vars_(vr,nlon,nlat,nsig) - - integer,intent(in) :: nlon,nlat,nsig - type(berror_vars) vr - - vr%nlon=nlon - vr%nlat=nlat - vr%nsig=nsig - -! allocate single precision arrays - allocate(vr%sfvar(nlat,nsig),vr%vpvar(nlat,nsig),vr%tvar(nlat,nsig),vr%qvar(nlat,nsig), & - vr%qivar(nlat,nsig),vr%qlvar(nlat,nsig),vr%qrvar(nlat,nsig),vr%qsvar(nlat,nsig),& - vr%cvar(nlat,nsig),vr%nrhvar(nlat,nsig),vr%ozvar(nlat,nsig)) - allocate(vr%sfhln(nlat,nsig),vr%vphln(nlat,nsig),vr%thln(nlat,nsig),vr%qhln(nlat,nsig), & - vr%qihln(nlat,nsig),vr%qlhln(nlat,nsig),vr%qrhln(nlat,nsig),vr%qshln(nlat,nsig),& - vr%chln(nlat,nsig), vr%ozhln(nlat,nsig)) - allocate(vr%sfvln(nlat,nsig),vr%vpvln(nlat,nsig),vr%tvln(nlat,nsig),vr%qvln(nlat,nsig), & - vr%qivln(nlat,nsig),vr%qlvln(nlat,nsig),vr%qrvln(nlat,nsig),vr%qsvln(nlat,nsig),& - vr%cvln(nlat,nsig), vr%ozvln(nlat,nsig)) - allocate(vr%pscon(nlat,nsig),vr%vpcon(nlat,nsig)) - allocate(vr%varsst(nlat,nlon),vr%corlsst(nlat,nlon)) - allocate(vr%tcon(nlat,nsig,nsig)) - allocate(vr%psvar(nlat),vr%pshln(nlat)) - end subroutine init_berror_vars_ - - subroutine destroy_berror_vars_(vr) - type(berror_vars) vr -! deallocate arrays - deallocate(vr%sfvar,vr%vpvar,vr%tvar,vr%qvar, & - vr%qivar,vr%qlvar,vr%qrvar,vr%qsvar,& - vr%cvar,vr%nrhvar,vr%ozvar) - deallocate(vr%sfhln,vr%vphln,vr%thln,vr%qhln, & - vr%qihln,vr%qlhln,vr%qrhln,vr%qshln,& - vr%chln, vr%ozhln) - deallocate(vr%sfvln,vr%vpvln,vr%tvln,vr%qvln, & - vr%qivln,vr%qlvln,vr%qrvln,vr%qsvln,& - vr%cvln, vr%ozvln) - deallocate(vr%pscon,vr%vpcon) - deallocate(vr%varsst,vr%corlsst) - deallocate(vr%tcon) - deallocate(vr%psvar,vr%pshln) - end subroutine destroy_berror_vars_ - - subroutine comp_berror_vars_(va,vb) - type(berror_vars) va - type(berror_vars) vb - integer :: ii,jj,ier(50) - logical failed - real :: tolerance = 10.e-10 - ii=0;ier=0 - ii=ii+1; if(abs(sum(va%sfvar - vb%sfvar)) >tolerance) ier(ii)=ii - ii=ii+1; if(abs(sum(va%vpvar - vb%vpvar)) >tolerance) ier(ii)=ii - ii=ii+1; if(abs(sum(va%tvar - vb%tvar)) >tolerance) ier(ii)=ii - ii=ii+1; if(abs(sum(va%qvar - vb%qvar )) >tolerance) ier(ii)=ii - ii=ii+1; if(abs(sum(va%qivar - vb%qivar)) >tolerance) ier(ii)=ii - ii=ii+1; if(abs(sum(va%qlvar - vb%qlvar)) >tolerance) ier(ii)=ii - ii=ii+1; if(abs(sum(va%qrvar - vb%qrvar)) >tolerance) ier(ii)=ii - ii=ii+1; if(abs(sum(va%qsvar - vb%qsvar) )>tolerance) ier(ii)=ii - ii=ii+1; if(abs(sum(va%cvar - vb%cvar )) >tolerance) ier(ii)=ii - ii=ii+1; if(abs(sum(va%nrhvar- vb%nrhvar))>tolerance) ier(ii)=ii - ii=ii+1; if(abs(sum(va%ozvar - vb%ozvar)) >tolerance) ier(ii)=ii - ii=ii+1; if(abs(sum(va%sfhln - vb%sfhln)) >tolerance) ier(ii)=ii - ii=ii+1; if(abs(sum(va%vphln - vb%vphln ))>tolerance) ier(ii)=ii - ii=ii+1; if(abs(sum(va%thln - vb%thln)) >tolerance) ier(ii)=ii - ii=ii+1; if(abs(sum(va%qhln - vb%qhln) ) >tolerance) ier(ii)=ii - ii=ii+1; if(abs(sum(va%qihln - vb%qihln)) >tolerance) ier(ii)=ii - ii=ii+1; if(abs(sum(va%qlhln - vb%qlhln)) >tolerance) ier(ii)=ii - ii=ii+1; if(abs(sum(va%qrhln - vb%qrhln) )>tolerance) ier(ii)=ii - ii=ii+1; if(abs(sum(va%qshln - vb%qshln ))>tolerance) ier(ii)=ii - ii=ii+1; if(abs(sum(va%chln - vb%chln )) >tolerance) ier(ii)=ii - ii=ii+1; if(abs(sum(va%ozhln - vb%ozhln)) >tolerance) ier(ii)=ii - ii=ii+1; if(abs(sum(va%sfvln - vb%sfvln)) >tolerance) ier(ii)=ii - ii=ii+1; if(abs(sum(va%vpvln - vb%vpvln)) >tolerance) ier(ii)=ii - ii=ii+1; if(abs(sum(va%tvln - vb%tvln)) >tolerance) ier(ii)=ii - ii=ii+1; if(abs(sum(va%qvln - vb%qvln )) >tolerance) ier(ii)=ii - ii=ii+1; if(abs(sum(va%qivln - vb%qivln)) >tolerance) ier(ii)=ii - ii=ii+1; if(abs(sum(va%qlvln - vb%qlvln)) >tolerance) ier(ii)=ii - ii=ii+1; if(abs(sum(va%qrvln - vb%qrvln)) >tolerance) ier(ii)=ii - ii=ii+1; if(abs(sum(va%qsvln - vb%qsvln) )>tolerance) ier(ii)=ii - ii=ii+1; if(abs(sum(va%cvln - vb%cvln )) >tolerance) ier(ii)=ii - ii=ii+1; if(abs(sum(va%ozvln - vb%ozvln)) >tolerance) ier(ii)=ii - ii=ii+1; if(abs(sum(va%pscon - vb%pscon)) >tolerance) ier(ii)=ii - ii=ii+1; if(abs(sum(va%vpcon - vb%vpcon)) >tolerance) ier(ii)=ii - ii=ii+1; if(abs(sum(va%varsst- vb%varsst))>tolerance) ier(ii)=ii - ii=ii+1; if(abs(sum(va%corlsst-vb%corlsst))>tolerance)ier(ii)=ii - ii=ii+1; if(abs(sum(va%tcon - vb%tcon)) >tolerance) ier(ii)=ii - failed=.false. - do jj=1,ii - if(ier(jj)/=0) then - print *, 'Found field ', jj, ' not to match' - failed=.true. - endif - enddo - if (.not.failed) then - print *, 'Comp finds all fields to match' - endif - end subroutine comp_berror_vars_ - subroutine berror_read_(vr) type(berror_vars) vr @@ -589,15 +494,7 @@ subroutine berror_write_grads_(vars) call write_grads_ctl('sst',lugrd,nlon,nlat) end subroutine berror_write_grads_ - subroutine final_berror_vars_(vr) - type(berror_vars) vr - deallocate(vr%tcon) - deallocate(vr%sfvar,vr%vpvar,vr%tvar,vr%qvar,vr%qivar,vr%qlvar,vr%qsvar,vr%qrvar,vr%cvar,vr%nrhvar,vr%sfhln,& - vr%vphln,vr%thln,vr%qhln,vr%qihln,vr%qlhln,vr%qrhln,vr%qshln,vr%chln,vr%sfvln,vr%vpvln,vr%tvln,& - vr%qvln,vr%qivln,vr%qlvln,vr%qrvln,vr%qsvln,vr%cvln,vr%vpcon,vr%pscon,vr%varsst,vr%corlsst, & - vr%ozvar,vr%ozhln,vr%ozvln) - deallocate(vr%psvar,vr%pshln) - end subroutine final_berror_vars_ + subroutine copy_berror_vars_(ivars,ovars) type(berror_vars) ivars type(berror_vars) ovars @@ -784,7 +681,7 @@ subroutine be_write_nc_(fname,ivars) real(4),allocatable,dimension(:) :: ak,bk real(4) ptop, pint, dlon, dlat integer :: nlat,nlon - integer ii,jj,k,ks + integer ii,jj,k,ks,status allocate(plevs(ivars%nsig)) allocate(ak(ivars%nsig+1),bk(ivars%nsig+1)) @@ -804,7 +701,7 @@ subroutine be_write_nc_(fname,ivars) lons(ii) = (ii-1.0)*dlon enddo - call write_nc_berror(trim(fname),ivars,plevs,lats,lons) + call write_nc_berror(trim(fname),ivars,plevs,lats,lons,status) deallocate(ak,bk) deallocate(plevs) From e7d0305fc9d7d6e7f91b2d0fa76c8fbb5cef64aa Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Sat, 4 Sep 2021 05:37:01 -0400 Subject: [PATCH 064/205] rename all methods for consistency --- .../NCEP_Etc/NCEP_bkgecov/m_nc_berror.f90 | 580 ++++++++++++++---- .../NCEP_bkgecov/write_berror_global.f90 | 116 +--- 2 files changed, 499 insertions(+), 197 deletions(-) diff --git a/src/Applications/NCEP_Etc/NCEP_bkgecov/m_nc_berror.f90 b/src/Applications/NCEP_Etc/NCEP_bkgecov/m_nc_berror.f90 index 26236396..97e22060 100644 --- a/src/Applications/NCEP_Etc/NCEP_bkgecov/m_nc_berror.f90 +++ b/src/Applications/NCEP_Etc/NCEP_bkgecov/m_nc_berror.f90 @@ -3,25 +3,32 @@ module m_nc_berror implicit none private -public :: init_berror_vars -public :: final_berror_vars -public :: comp_berror_vars -public :: berror_vars -public :: read_nc_berror -public :: write_nc_berror - -type berror_vars +public :: nc_berror_vars_init +public :: nc_berror_vars_final +public :: nc_berror_vars_comp +public :: nc_berror_vars_copy +public :: nc_berror_vars +public :: nc_berror_dims +public :: nc_berror_read +public :: nc_berror_write +public :: nc_berror_getpointer + +type nc_berror_vars + logical :: initialized=.false. integer :: nlon,nlat,nsig - real(4),allocatable,dimension(:,:,:):: tcon - real(4),allocatable,dimension(:,:) :: sfvar,vpvar,tvar,qvar,cvar,nrhvar,ozvar - real(4),allocatable,dimension(:,:) :: qivar,qlvar,qrvar,qsvar - real(4),allocatable,dimension(:,:) :: sfhln,vphln,thln,qhln,chln,ozhln - real(4),allocatable,dimension(:,:) :: qihln,qlhln,qrhln,qshln - real(4),allocatable,dimension(:,:) :: sfvln,vpvln,tvln,qvln,cvln,ozvln - real(4),allocatable,dimension(:,:) :: qivln,qlvln,qrvln,qsvln - real(4),allocatable,dimension(:,:) :: vpcon,pscon,varsst,corlsst - real(4),allocatable,dimension(:) :: psvar,pshln -end type berror_vars + real(4),pointer,dimension(:,:,:):: tcon + real(4),pointer,dimension(:,:) :: sfvar,vpvar,tvar,qvar,cvar,nrhvar,ozvar + real(4),pointer,dimension(:,:) :: qivar,qlvar,qrvar,qsvar + real(4),pointer,dimension(:,:) :: sfhln,vphln,thln,qhln,chln,ozhln + real(4),pointer,dimension(:,:) :: qihln,qlhln,qrhln,qshln + real(4),pointer,dimension(:,:) :: sfvln,vpvln,tvln,qvln,cvln,ozvln + real(4),pointer,dimension(:,:) :: qivln,qlvln,qrvln,qsvln + real(4),pointer,dimension(:,:) :: vpcon,pscon,varsst,corlsst + real(4),pointer,dimension(:) :: psvar,pshln + real(4),pointer,dimension(:) :: v1d + real(4),pointer,dimension(:,:) :: v2d + real(4),pointer,dimension(:,:,:):: v3d +end type nc_berror_vars character(len=*), parameter :: myname = 'm_nc_berror' @@ -47,27 +54,78 @@ module m_nc_berror character(len=4),parameter :: cvarsMLL(nvmll) = (/ 'tcon' /) integer, parameter :: nv2dx = 2 -character(len=7),parameter :: cvars2dx(nv2dx) = (/ 'sst ', 'sstcorl' /) +character(len=4),parameter :: cvars2dx(nv2dx) = (/ 'sst ', 'hsst' /) -interface read_nc_berror; module procedure & +interface nc_berror_dims; module procedure & + read_dims_ ; end interface +interface nc_berror_read; module procedure & read_berror_ ; end interface -interface write_nc_berror; module procedure & +interface nc_berror_write; module procedure & write_berror_ ; end interface -interface init_berror_vars; module procedure & +interface nc_berror_vars_init; module procedure & init_berror_vars_ ; end interface -interface final_berror_vars; module procedure & +interface nc_berror_vars_final; module procedure & final_berror_vars_ ; end interface -interface comp_berror_vars; module procedure & +interface nc_berror_vars_comp; module procedure & comp_berror_vars_ ; end interface +interface nc_berror_vars_copy; module procedure & + copy_ ; end interface +interface nc_berror_getpointer + module procedure get_pointer_1d_ + module procedure get_pointer_2d_ +end interface contains +subroutine read_dims_ (fname,nlat,nlon,nlev,rc, myid,root) + implicit none + character(len=*), intent(in) :: fname ! input filename + integer, intent(out) :: rc + integer, intent(out) :: nlat,nlon,nlev + integer, intent(in), optional :: myid, root + +! This will be the netCDF ID for the file and data variable. + integer :: ncid, varid, ier + integer :: mype_,root_ + +! Local variables + character(len=*), parameter :: myname_ = myname//"::dims_" + logical :: verbose + +! Return code (status) + rc=0; mype_=0; root_=0 + if(present(myid) .and. present(root) ) then + mype_ = myid + root_ = root + endif + +! Open the file. NF90_NOWRITE tells netCDF we want read-only access to +! the file. + + call check_( nf90_open(fname, NF90_NOWRITE, ncid), rc, mype_, root_ ) + if(rc/=0) return + +! Read global attributes + call check_( nf90_inq_dimid(ncid, "lon", varid), rc, mype_, root_) + call check_( nf90_inquire_dimension(ncid, varid, len=nlon), rc, mype_, root_ ) + call check_( nf90_inq_dimid(ncid, "lat", varid), rc, mype_, root_ ) + call check_( nf90_inquire_dimension(ncid, varid, len=nlat), rc, mype_, root_ ) + call check_( nf90_inq_dimid(ncid, "lev", varid), rc, mype_, root_ ) + call check_( nf90_inquire_dimension(ncid, varid, len=nlev), rc, mype_, root_ ) + +! Close the file, freeing all resources. + call check_( nf90_close(ncid), rc, mype_, root_ ) + + return + +end subroutine read_dims_ + subroutine read_berror_ (fname,bvars,rc, myid,root) implicit none character(len=*), intent(in) :: fname ! input filename - type(berror_vars),intent(inout) :: bvars ! background error variables + type(nc_berror_vars),intent(inout) :: bvars ! background error variables integer, intent(out) :: rc - integer, intent(in), optional :: myid,root ! accommodate MPI calling programs + integer, intent(in), optional :: myid,root ! accommodate MPI calling programs ! This will be the netCDF ID for the file and data variable. integer :: ncid, varid @@ -78,61 +136,79 @@ subroutine read_berror_ (fname,bvars,rc, myid,root) integer :: nv,nl,nlat,nlon,nlev integer :: ndims_, nvars_, ngatts_, unlimdimid_ integer :: nlat_,nlon_,nlev_ + integer :: mype_,root_ real(4), allocatable :: data_in(:,:,:) logical :: verbose + logical :: init_ ! Return code (status) - rc = 0 + rc=0; mype_=0; root_=0 verbose=.true. + init_=.false. if(present(myid).and.present(root) )then if(myid/=root) verbose=.false. + mype_ = myid + root_ = root endif -! Set dims - nlat=bvars%nlat - nlon=bvars%nlon - nlev=bvars%nsig +! Get dimensions + call read_dims_ (fname,nlat_,nlon_,nlev_,rc, mype_,root_) + + init_ = bvars%initialized + if ( init_ ) then +! Set dims + nlat=bvars%nlat + nlon=bvars%nlon + nlev=bvars%nsig + +! Consistency check + if (nlon_ /= nlon .or. nlat_ /=nlat .or. nlev_/=nlev ) then + rc=1 + if(myid==root) then + print *, 'nlat(file) = ', nlat_, 'nlat(required) = ', nlat + print *, 'nlon(file) = ', nlon_, 'nlon(required) = ', nlon + print *, 'nlev(file) = ', nlev_, 'nlev(required) = ', nlev + print *, myname_, 'Inconsistent dimensions, aborting ... ' + endif + return + endif + else +! Set dims + nlat=nlat_ + nlon=nlon_ + nlev=nlev_ + call init_berror_vars_(bvars,nlon,nlat,nlev) + endif ! Open the file. NF90_NOWRITE tells netCDF we want read-only access to ! the file. - call check( nf90_open(fname, NF90_NOWRITE, ncid) ) + call check_( nf90_open(fname, NF90_NOWRITE, ncid), rc, mype_, root_ ) + if(rc/=0) return ! Read global attributes - call check( nf90_inquire(ncid, ndims_, nvars_, ngatts_, unlimdimid_) ) - call check( nf90_inq_dimid(ncid, "lon", varid) ) - call check( nf90_inquire_dimension(ncid, varid, len=nlon_) ) - call check( nf90_inq_dimid(ncid, "lat", varid) ) - call check( nf90_inquire_dimension(ncid, varid, len=nlat_) ) - call check( nf90_inq_dimid(ncid, "lev", varid) ) - call check( nf90_inquire_dimension(ncid, varid, len=nlev_) ) - -! Consistency check - if (nlon_ /= nlon .or. nlat_ /=nlat .or. nlev_/=nlev ) then - rc=1 - if(myid==root) then - print *, 'nlat(file) = ', nlat_, 'nlat(required) = ', nlat - print *, 'nlon(file) = ', nlon_, 'nlon(required) = ', nlon - print *, 'nlev(file) = ', nlev_, 'nlev(required) = ', nlev - print *, myname_, 'Inconsistent dimensions, aborting ... ' - endif - return - endif +! call check_( nf90_inquire(ncid, ndims_, nvars_, ngatts_, unlimdimid_), rc, mype_, root_ ) +! call check_( nf90_inq_dimid(ncid, "lon", varid), rc, mype_, root_ ) +! call check_( nf90_inquire_dimension(ncid, varid, len=nlon_), rc, mype_, root_ ) +! call check_( nf90_inq_dimid(ncid, "lat", varid), rc, mype_, root_ ) +! call check_( nf90_inquire_dimension(ncid, varid, len=nlat_), rc, mype_, root_ ) +! call check_( nf90_inq_dimid(ncid, "lev", varid), rc, mype_, root_ ) +! call check_( nf90_inquire_dimension(ncid, varid, len=nlev_), rc, mype_, root_ ) ! Read data to file allocate(data_in(1,nlat,1)) do nv = 1, nv1d - call check( nf90_inq_varid(ncid, trim(cvars1d(nv)), varid) ) - call check( nf90_get_var(ncid, varid, data_in(1,:,1))) + call check_( nf90_inq_varid(ncid, trim(cvars1d(nv)), varid), rc, mype_, root_ ) + call check_( nf90_get_var(ncid, varid, data_in(1,:,1)), rc, mype_, root_ ) if(trim(cvars1d(nv))=="ps" ) bvars%psvar = data_in(1,:,1) if(trim(cvars1d(nv))=="hps" ) bvars%pshln = data_in(1,:,1) enddo deallocate(data_in) allocate(data_in(1,nlat,nlev)) do nv = 1, nv2d - call check( nf90_inq_varid(ncid, trim(cvars2d(nv)), varid) ) - call check( nf90_get_var(ncid, varid, data_in(1,:,:)) ) + call check_( nf90_inq_varid(ncid, trim(cvars2d(nv)), varid), rc, mype_, root_ ) + call check_( nf90_get_var(ncid, varid, data_in(1,:,:)), rc, mype_, root_ ) if(trim(cvars2d(nv))=="sf" ) bvars%sfvar = data_in(1,:,:) if(trim(cvars2d(nv))=="hsf") bvars%sfhln = data_in(1,:,:) @@ -185,8 +261,8 @@ subroutine read_berror_ (fname,bvars,rc, myid,root) do nl = 1, nlev write(cindx,'(i4.4)') nl if(trim(cvarsMLL(nv))=="tcon") then - call check( nf90_inq_varid(ncid, trim(cvarsMLL(nv))//cindx, varid) ) - call check( nf90_get_var(ncid, varid, data_in(1,:,:)) ) + call check_( nf90_inq_varid(ncid, trim(cvarsMLL(nv))//cindx, varid), rc, mype_, root_ ) + call check_( nf90_get_var(ncid, varid, data_in(1,:,:)), rc, mype_, root_ ) bvars%tcon(:,:,nl) = data_in(1,:,:) endif enddo @@ -196,39 +272,30 @@ subroutine read_berror_ (fname,bvars,rc, myid,root) ! Write out lat/lon fields allocate(data_in(nlon,nlat,1)) do nv = 1, nv2dx - call check( nf90_inq_varid(ncid, trim(cvars2dx(nv)), varid) ) - call check( nf90_get_var(ncid, varid, data_in(:,:,1)) ) + call check_( nf90_inq_varid(ncid, trim(cvars2dx(nv)), varid), rc, mype_, root_ ) + call check_( nf90_get_var(ncid, varid, data_in(:,:,1)), rc, mype_, root_ ) if(trim(cvars2dx(nv))=="sst" ) then bvars%varsst = transpose(data_in(:,:,1)) endif - if(trim(cvars2dx(nv))=="sstcorl" ) then + if(trim(cvars2dx(nv))=="hsst" ) then bvars%corlsst = transpose(data_in(:,:,1)) endif enddo deallocate(data_in) ! Close the file, freeing all resources. - call check( nf90_close(ncid) ) + call check_( nf90_close(ncid), rc, mype_, root_ ) if(verbose) print *,"*** Finish reading file: ", trim(fname) return -contains - subroutine check(status) - integer, intent ( in) :: status - - if(status /= nf90_noerr) then - print *, trim(nf90_strerror(status)) - stop "Stopped" - end if - end subroutine check end subroutine read_berror_ subroutine write_berror_ (fname,bvars,plevs,lats,lons,rc, myid,root) implicit none character(len=*), intent(in) :: fname ! input filename - type(berror_vars),intent(in) :: bvars ! background error variables + type(nc_berror_vars),intent(in) :: bvars ! background error variables real(4), intent(in) :: lats(:) ! latitudes per GSI: increase index from South to North Pole real(4), intent(in) :: lons(:) ! longitudea per GSI: increase index from East to West real(4), intent(in) :: plevs(:) @@ -245,6 +312,7 @@ subroutine write_berror_ (fname,bvars,plevs,lats,lons,rc, myid,root) integer :: x_dimid, y_dimid, z_dimid integer :: lon_varid, lat_varid, lev_varid integer :: ii,jj,nl,nv,nn,nlat,nlon,nlev + integer :: mype_,root_ integer, allocatable :: varid1d(:), varid2d(:), varid2dx(:), varidMLL(:) logical :: verbose @@ -253,10 +321,12 @@ subroutine write_berror_ (fname,bvars,plevs,lats,lons,rc, myid,root) real(4), allocatable :: data_out(:,:,:) ! Return code (status) - rc = 0 + rc=0; mype_=0; root_=0 verbose=.true. if(present(myid).and.present(root) )then if(myid/=root) verbose=.false. + mype_ = myid + root_ = root endif ! Set dims @@ -271,20 +341,21 @@ subroutine write_berror_ (fname,bvars,plevs,lats,lons,rc, myid,root) ! Create the netCDF file. The nf90_clobber parameter tells netCDF to ! overwrite this file, if it already exists. - call check( nf90_create(fname, NF90_CLOBBER, ncid) ) + call check_( nf90_create(fname, NF90_CLOBBER, ncid), rc, mype_, root_ ) + if(rc/=0) return ! Define the dimensions. NetCDF will hand back an ID for each. - call check( nf90_def_dim(ncid, "lon", nlon, x_dimid) ) - call check( nf90_def_dim(ncid, "lat", nlat, y_dimid) ) - call check( nf90_def_dim(ncid, "lev", nlev, z_dimid) ) + call check_( nf90_def_dim(ncid, "lon", nlon, x_dimid), rc, mype_, root_ ) + call check_( nf90_def_dim(ncid, "lat", nlat, y_dimid), rc, mype_, root_ ) + call check_( nf90_def_dim(ncid, "lev", nlev, z_dimid), rc, mype_, root_ ) - call check( nf90_def_var(ncid, "lon", NF90_REAL, x_dimid, lon_varid) ) - call check( nf90_def_var(ncid, "lat", NF90_REAL, y_dimid, lat_varid) ) - call check( nf90_def_var(ncid, "lev", NF90_REAL, z_dimid, lev_varid) ) + call check_( nf90_def_var(ncid, "lon", NF90_REAL, x_dimid, lon_varid), rc, mype_, root_ ) + call check_( nf90_def_var(ncid, "lat", NF90_REAL, y_dimid, lat_varid), rc, mype_, root_ ) + call check_( nf90_def_var(ncid, "lev", NF90_REAL, z_dimid, lev_varid), rc, mype_, root_ ) - call check( nf90_put_att(ncid, lon_varid, "units", "degress") ) - call check( nf90_put_att(ncid, lat_varid, "units", "degress") ) - call check( nf90_put_att(ncid, lev_varid, "units", "hPa") ) + call check_( nf90_put_att(ncid, lon_varid, "units", "degress"), rc, mype_, root_ ) + call check_( nf90_put_att(ncid, lat_varid, "units", "degress"), rc, mype_, root_ ) + call check_( nf90_put_att(ncid, lev_varid, "units", "hPa"), rc, mype_, root_ ) ! The dimids array is used to pass the IDs of the dimensions of ! the variables. Note that in fortran arrays are stored in @@ -294,11 +365,11 @@ subroutine write_berror_ (fname,bvars,plevs,lats,lons,rc, myid,root) ! Define variables. allocate(varid1d(nv1d)) do nv = 1, nv1d - call check( nf90_def_var(ncid, trim(cvars1d(nv)), NF90_REAL, (/ y_dimid /), varid1d(nv)) ) + call check_( nf90_def_var(ncid, trim(cvars1d(nv)), NF90_REAL, (/ y_dimid /), varid1d(nv)), rc, mype_, root_ ) enddo allocate(varid2d(nv2d)) do nv = 1, nv2d - call check( nf90_def_var(ncid, trim(cvars2d(nv)), NF90_REAL, (/ y_dimid, z_dimid /), varid2d(nv)) ) + call check_( nf90_def_var(ncid, trim(cvars2d(nv)), NF90_REAL, (/ y_dimid, z_dimid /), varid2d(nv)), rc, mype_, root_ ) enddo allocate(varidMLL(nlev*nvmll)) nn=0 @@ -306,28 +377,28 @@ subroutine write_berror_ (fname,bvars,plevs,lats,lons,rc, myid,root) do nl = 1, nlev nn=nn+1 write(cindx,'(i4.4)') nl - call check( nf90_def_var(ncid, trim(cvarsMLL(nv))//cindx, NF90_REAL, (/ y_dimid, z_dimid /), varidMLL(nn)) ) + call check_( nf90_def_var(ncid, trim(cvarsMLL(nv))//cindx, NF90_REAL, (/ y_dimid, z_dimid /), varidMLL(nn)), rc, mype_, root_ ) enddo enddo allocate(varid2dx(nv2dx)) do nv = 1, nv2dx - call check( nf90_def_var(ncid, trim(cvars2dx(nv)), NF90_REAL, (/ x_dimid, y_dimid /), varid2dx(nv)) ) + call check_( nf90_def_var(ncid, trim(cvars2dx(nv)), NF90_REAL, (/ x_dimid, y_dimid /), varid2dx(nv)), rc, mype_, root_ ) enddo ! End define mode. This tells netCDF we are done defining metadata. - call check( nf90_enddef(ncid) ) + call check_( nf90_enddef(ncid), rc, mype_, root_ ) ! Write coordinate variables data - call check( nf90_put_var(ncid, lon_varid, lons ) ) - call check( nf90_put_var(ncid, lat_varid, lats ) ) - call check( nf90_put_var(ncid, lev_varid, plevs) ) + call check_( nf90_put_var(ncid, lon_varid, lons ), rc, mype_, root_ ) + call check_( nf90_put_var(ncid, lat_varid, lats ), rc, mype_, root_ ) + call check_( nf90_put_var(ncid, lev_varid, plevs), rc, mype_, root_ ) ! Write data to file allocate(data_out(1,nlat,1)) do nv = 1, nv1d if(trim(cvars1d(nv))=="ps" ) data_out(1,:,1) = bvars%psvar if(trim(cvars1d(nv))=="hps" ) data_out(1,:,1) = bvars%pshln - call check( nf90_put_var(ncid, varid1d(nv), data_out(1,:,1))) + call check_( nf90_put_var(ncid, varid1d(nv), data_out(1,:,1)), rc, mype_, root_) enddo deallocate(data_out) allocate(data_out(1,nlat,nlev)) @@ -376,7 +447,7 @@ subroutine write_berror_ (fname,bvars,plevs,lats,lons,rc, myid,root) if(trim(cvars2d(nv))=="pscon") data_out(1,:,:) = bvars%pscon if(trim(cvars2d(nv))=="vpcon") data_out(1,:,:) = bvars%vpcon ! - call check( nf90_put_var(ncid, varid2d(nv), data_out(1,:,:)) ) + call check_( nf90_put_var(ncid, varid2d(nv), data_out(1,:,:)), rc, mype_, root_ ) enddo ! Choose to write out NLATxNLEVxNLEV vars as to facilitate visualization @@ -386,7 +457,7 @@ subroutine write_berror_ (fname,bvars,plevs,lats,lons,rc, myid,root) nn = nn + 1 write(cindx,'(i4.4)') nl if(trim(cvarsMLL(nv))=="tcon") data_out(1,:,:) = bvars%tcon(:,:,nl) - call check( nf90_put_var(ncid, varidMLL(nn), data_out(1,:,:)) ) + call check_( nf90_put_var(ncid, varidMLL(nn), data_out(1,:,:)), rc, mype_, root_ ) enddo enddo deallocate(data_out) @@ -397,15 +468,15 @@ subroutine write_berror_ (fname,bvars,plevs,lats,lons,rc, myid,root) if(trim(cvars2dx(nv))=="sst" ) then data_out(:,:,1) = transpose(bvars%varsst) endif - if(trim(cvars2dx(nv))=="sstcorl" ) then + if(trim(cvars2dx(nv))=="hsst" ) then data_out(:,:,1) = transpose(bvars%corlsst) endif - call check( nf90_put_var(ncid, varid2dx(nv), data_out(:,:,1)) ) + call check_( nf90_put_var(ncid, varid2dx(nv), data_out(:,:,1)), rc, mype_, root_ ) enddo deallocate(data_out) ! Close file - call check( nf90_close(ncid) ) + call check_( nf90_close(ncid), rc, mype_, root_ ) deallocate(varidMLL) deallocate(varid2d) @@ -414,21 +485,15 @@ subroutine write_berror_ (fname,bvars,plevs,lats,lons,rc, myid,root) print *, "*** Finish writing file ", fname return -contains - subroutine check(status) - integer, intent ( in) :: status - - if(status /= nf90_noerr) then - print *, trim(nf90_strerror(status)) - stop "Stopped" - end if - end subroutine check + end subroutine write_berror_ subroutine init_berror_vars_(vr,nlon,nlat,nsig) integer,intent(in) :: nlon,nlat,nsig - type(berror_vars) vr + type(nc_berror_vars) vr + + if(vr%initialized) return vr%nlon=nlon vr%nlat=nlat @@ -448,11 +513,13 @@ subroutine init_berror_vars_(vr,nlon,nlat,nsig) allocate(vr%varsst(nlat,nlon),vr%corlsst(nlat,nlon)) allocate(vr%tcon(nlat,nsig,nsig)) allocate(vr%psvar(nlat),vr%pshln(nlat)) + vr%initialized=.true. end subroutine init_berror_vars_ subroutine final_berror_vars_(vr) - type(berror_vars) vr + type(nc_berror_vars) vr ! deallocate arrays + if(.not. vr%initialized) return deallocate(vr%sfvar,vr%vpvar,vr%tvar,vr%qvar, & vr%qivar,vr%qlvar,vr%qrvar,vr%qsvar,& vr%cvar,vr%nrhvar,vr%ozvar) @@ -466,11 +533,12 @@ subroutine final_berror_vars_(vr) deallocate(vr%varsst,vr%corlsst) deallocate(vr%tcon) deallocate(vr%psvar,vr%pshln) + vr%initialized=.false. end subroutine final_berror_vars_ subroutine comp_berror_vars_(va,vb,rc, myid,root) - type(berror_vars) va - type(berror_vars) vb + type(nc_berror_vars) va + type(nc_berror_vars) vb integer, intent(out) :: rc integer, intent(in), optional :: myid,root ! accommodate MPI calling programs character(len=*), parameter :: myname_ = myname//"::comp_berror_vars_" @@ -544,4 +612,298 @@ subroutine comp_berror_vars_(va,vb,rc, myid,root) endif end subroutine comp_berror_vars_ +subroutine copy_(ivars,ovars,hydro) + type(nc_berror_vars) ivars + type(nc_berror_vars) ovars + logical, intent(in), optional :: hydro + + logical wrtall,hydro_ + + hydro_=.true. + wrtall=.true. + if (ovars%nlon/=ivars%nlon .or. & + ovars%nlat/=ivars%nlat ) then + print*, 'copy_berror_vars_: Trying to copy inconsistent vectors, aborting ...' + call exit(1) + endif + if ( ovars%nsig/=ivars%nsig ) then + wrtall=.false. + endif + if(present(hydro)) then + hydro_ = hydro + endif + + if (wrtall) then + ovars%tcon = ivars%tcon + ovars%vpcon = ivars%vpcon + ovars%pscon = ivars%pscon + ovars%sfvar = ivars%sfvar + ovars%sfhln = ivars%sfhln + ovars%sfvln = ivars%sfvln + ovars%vpvar = ivars%vpvar + ovars%vphln = ivars%vphln + ovars%vpvln = ivars%vpvln + ovars%tvar = ivars%tvar + ovars%thln = ivars%thln + ovars%tvln = ivars%tvln + ovars%qvar = ivars%qvar + ovars%nrhvar = ivars%nrhvar + ovars%qhln = ivars%qhln + ovars%qvln = ivars%qvln + if(hydro_) then + ovars%qivar = ivars%qivar + ovars%qihln = ivars%qihln + ovars%qivln = ivars%qivln + ovars%qlvar = ivars%qlvar + ovars%qlhln = ivars%qlhln + ovars%qlvln = ivars%qlvln + ovars%qrvar = ivars%qrvar + ovars%qrhln = ivars%qrhln + ovars%qrvln = ivars%qrvln + ovars%qsvar = ivars%qsvar + ovars%qshln = ivars%qshln + ovars%qsvln = ivars%qsvln + endif + ovars%ozvar = ivars%ozvar + ovars%ozhln = ivars%ozhln + ovars%ozvln = ivars%ozvln + ovars%cvar = ivars%cvar + ovars%chln = ivars%chln + ovars%cvln = ivars%cvln + endif + + ovars%psvar = ivars%psvar + ovars%pshln = ivars%pshln + ovars%varsst = ivars%varsst + ovars%corlsst = ivars%corlsst + +end subroutine copy_ + +subroutine get_pointer_1d_ (vname, bvars, ptr, rc ) +implicit none +character(len=*), intent(in) :: vname +type(nc_berror_vars) bvars +real(4),pointer,intent(inout) :: ptr(:) +integer,intent(out) :: rc +rc=-1 +if(trim(vname)=='ps') then + ptr => bvars%psvar + rc=0 +endif +if(trim(vname)=='hps') then + ptr => bvars%pshln + rc=0 +endif +end subroutine get_pointer_1d_ + +subroutine get_pointer_2d_ (vname, bvars, ptr, rc ) +implicit none +character(len=*), intent(in) :: vname +type(nc_berror_vars) bvars +real(4),pointer,intent(inout) :: ptr(:,:) +integer,intent(out) :: rc +character(len=5) :: var +rc=-1 +! +var='sst' +if(trim(vname)==trim(var)) then + ptr => bvars%varsst + rc=0 + return +endif +if(trim(vname)=='h'//trim(var)) then + ptr => bvars%corlsst + rc=0 + return +endif +! +var='sf' +if(trim(vname)==trim(var)) then + ptr => bvars%sfvar + rc=0 + return +endif +if(trim(vname)=='h'//trim(var)) then + ptr => bvars%sfhln + rc=0 + return +endif +if(trim(vname)=='v'//trim(var)) then + ptr => bvars%sfvln + rc=0 + return +endif +! +var='vp' +if(trim(vname)==trim(var)) then + ptr => bvars%vpvar + rc=0 + return +endif +if(trim(vname)=='h'//trim(var)) then + ptr => bvars%vphln + rc=0 + return +endif +if(trim(vname)=='v'//trim(var)) then + ptr => bvars%vpvln + rc=0 + return +endif +! +var='t' +if(trim(vname)==trim(var)) then + ptr => bvars%tvar + rc=0 + return +endif +if(trim(vname)=='h'//trim(var)) then + ptr => bvars%thln + rc=0 + return +endif +if(trim(vname)=='v'//trim(var)) then + ptr => bvars%tvln + rc=0 + return +endif +! +var='q' +if(trim(vname)==trim(var)) then + ptr => bvars%qvar + rc=0 + return +endif +if(trim(vname)=='h'//trim(var)) then + ptr => bvars%qhln + rc=0 + return +endif +if(trim(vname)=='v'//trim(var)) then + ptr => bvars%qvln + rc=0 + return +endif +! +var='cw' +if(trim(vname)==trim(var)) then + ptr => bvars%cvar + rc=0 + return +endif +if(trim(vname)=='h'//trim(var)) then + ptr => bvars%chln + rc=0 + return +endif +if(trim(vname)=='v'//trim(var)) then + ptr => bvars%cvln + rc=0 + return +endif +! +var='qi' +if(trim(vname)==trim(var)) then + ptr => bvars%qivar + rc=0 + return +endif +if(trim(vname)=='h'//trim(var)) then + ptr => bvars%qihln + rc=0 + return +endif +if(trim(vname)=='v'//trim(var)) then + ptr => bvars%qivln + rc=0 + return +endif +! +var='ql' +if(trim(vname)==trim(var)) then + ptr => bvars%qlvar + rc=0 + return +endif +if(trim(vname)=='h'//trim(var)) then + ptr => bvars%qlhln + rc=0 + return +endif +if(trim(vname)=='v'//trim(var)) then + ptr => bvars%qlvln + rc=0 + return +endif +! +var='qr' +if(trim(vname)==trim(var)) then + ptr => bvars%qrvar + rc=0 + return +endif +if(trim(vname)=='h'//trim(var)) then + ptr => bvars%qrhln + rc=0 + return +endif +if(trim(vname)=='v'//trim(var)) then + ptr => bvars%qrvln + rc=0 + return +endif +! +var='qs' +if(trim(vname)==trim(var)) then + ptr => bvars%qsvar + rc=0 + return +endif +if(trim(vname)=='h'//trim(var)) then + ptr => bvars%qshln + rc=0 + return +endif +if(trim(vname)=='v'//trim(var)) then + ptr => bvars%qsvln + rc=0 + return +endif +! +var='oz' +if(trim(vname)==trim(var)) then + ptr => bvars%ozvar + rc=0 + return +endif +if(trim(vname)=='h'//trim(var)) then + ptr => bvars%ozhln + rc=0 + return +endif +if(trim(vname)=='v'//trim(var)) then + ptr => bvars%ozvln + rc=0 + return +endif +! +var='nrh' +if(trim(vname)==trim(var)) then + ptr => bvars%nrhvar + rc=0 + return +endif +end subroutine get_pointer_2d_ + +subroutine check_(status,rc, myid, root) + integer, intent ( in) :: status + integer, intent (out) :: rc + integer, intent ( in) :: myid, root + rc=0 + if(status /= nf90_noerr) then + if(myid==root) print *, trim(nf90_strerror(status)) + rc=999 + end if +end subroutine check_ + end module m_nc_berror diff --git a/src/Applications/NCEP_Etc/NCEP_bkgecov/write_berror_global.f90 b/src/Applications/NCEP_Etc/NCEP_bkgecov/write_berror_global.f90 index 09655bb4..ff06fb5a 100644 --- a/src/Applications/NCEP_Etc/NCEP_bkgecov/write_berror_global.f90 +++ b/src/Applications/NCEP_Etc/NCEP_bkgecov/write_berror_global.f90 @@ -12,12 +12,13 @@ program write_berror_global - use m_nc_berror, only: init_berror_vars - use m_nc_berror, only: final_berror_vars - use m_nc_berror, only: comp_berror_vars - use m_nc_berror, only: berror_vars - use m_nc_berror, only: read_nc_berror - use m_nc_berror, only: write_nc_berror + use m_nc_berror, only: nc_berror_vars_init + use m_nc_berror, only: nc_berror_vars_final + use m_nc_berror, only: nc_berror_vars_comp + use m_nc_berror, only: nc_berror_vars_copy + use m_nc_berror, only: nc_berror_vars + use m_nc_berror, only: nc_berror_read + use m_nc_berror, only: nc_berror_write implicit none real(4),allocatable,dimension(:):: corp_avn,hwllp_avn @@ -26,8 +27,8 @@ program write_berror_global real(4),allocatable,dimension(:,:,:):: corz_avn,hwll_avn,vztdq_avn,agv_avn real(4),allocatable,dimension(:,:):: corz,corzq,hwll,vztdq - type(berror_vars) ivars - type(berror_vars) xvars + type(nc_berror_vars) ivars + type(nc_berror_vars) xvars integer, parameter :: luin =22 integer, parameter :: luout=45 @@ -53,7 +54,7 @@ program write_berror_global call get_berror_dims_(ilon,ilat,isig) - call init_berror_vars(ivars,ilon,ilat,isig) + call nc_berror_vars_init(ivars,ilon,ilat,isig) if (merra2current) then call berror_old_read_(mlon,mlat,msig) @@ -71,29 +72,28 @@ program write_berror_global endif if (msig/=ivars%nsig) then write(6,'(a)') ' Interpolating error covariance fields ...' - call init_berror_vars(xvars,ilon,ilat,isig) - call copy_berror_vars_(ivars,xvars) - call final_berror_vars(ivars) - call init_berror_vars(ivars,ilon,ilat,msig) - call copy_berror_vars_(xvars,ivars) + call nc_berror_vars_init(xvars,ilon,ilat,isig) + call nc_berror_vars_copy(ivars,xvars) + call nc_berror_vars_final(ivars) + call nc_berror_vars_init(ivars,ilon,ilat,msig) + call nc_berror_vars_copy(xvars,ivars) call vinterp_berror_vars_(xvars,ivars) write(6,'(a)') ' Finish interpolation.' - call final_berror_vars(xvars) + call nc_berror_vars_final(xvars) endif call berror_write_(ivars,merra2current) if(trim(ncfile)/='NULL') then call be_write_nc_(ncfile,ivars) if ( nc_read_test ) then - call init_berror_vars(xvars,ivars%nlon,ivars%nlat,ivars%nsig) - call read_nc_berror(ncfile,xvars,status) + call nc_berror_read(ncfile,xvars,status) call be_write_nc_('again.nc',xvars) - call comp_berror_vars(ivars,xvars,status) - call final_berror_vars(xvars) + call nc_berror_vars_comp(ivars,xvars,status) + call nc_berror_vars_final(xvars) endif endif call berror_write_grads_(ivars) - call final_berror_vars(ivars) + call nc_berror_vars_final(ivars) contains @@ -200,7 +200,7 @@ end subroutine get_berror_dims_ subroutine berror_read_(vr) - type(berror_vars) vr + type(nc_berror_vars) vr integer nlat,nlon,nsig var=' ' @@ -262,7 +262,7 @@ end subroutine berror_read_ subroutine berror_write_(vr,m2c) - type(berror_vars) vr + type(nc_berror_vars) vr logical, intent(in) :: m2c integer nlon,nlat,nsig @@ -418,7 +418,7 @@ end subroutine berror_write_ subroutine berror_write_grads_(vars) use sstmod, only: write_grads_ctl - type(berror_vars) vars + type(nc_berror_vars) vars integer j,nsig,nlat,nlon,iret real(4),allocatable,dimension(:,:) :: aux @@ -495,66 +495,6 @@ subroutine berror_write_grads_(vars) end subroutine berror_write_grads_ - subroutine copy_berror_vars_(ivars,ovars) - type(berror_vars) ivars - type(berror_vars) ovars - - logical wrtall - - wrtall=.true. - if (ovars%nlon/=ivars%nlon .or. & - ovars%nlat/=ivars%nlat ) then - print*, 'copy_berror_vars_: Trying to copy inconsistent vectors, aborting ...' - call exit(1) - endif - if ( ovars%nsig/=ivars%nsig ) then - wrtall=.false. - endif - - if (wrtall) then - ovars%tcon = ivars%tcon - ovars%vpcon = ivars%vpcon - ovars%pscon = ivars%pscon - ovars%sfvar = ivars%sfvar - ovars%sfhln = ivars%sfhln - ovars%sfvln = ivars%sfvln - ovars%vpvar = ivars%vpvar - ovars%vphln = ivars%vphln - ovars%vpvln = ivars%vpvln - ovars%tvar = ivars%tvar - ovars%thln = ivars%thln - ovars%tvln = ivars%tvln - ovars%qvar = ivars%qvar - ovars%nrhvar = ivars%nrhvar - ovars%qhln = ivars%qhln - ovars%qvln = ivars%qvln - ovars%qivar = ivars%qivar - ovars%qihln = ivars%qihln - ovars%qivln = ivars%qivln - ovars%qlvar = ivars%qlvar - ovars%qlhln = ivars%qlhln - ovars%qlvln = ivars%qlvln - ovars%qrvar = ivars%qrvar - ovars%qrhln = ivars%qrhln - ovars%qrvln = ivars%qrvln - ovars%qsvar = ivars%qsvar - ovars%qshln = ivars%qshln - ovars%qsvln = ivars%qsvln - ovars%ozvar = ivars%ozvar - ovars%ozhln = ivars%ozhln - ovars%ozvln = ivars%ozvln - ovars%cvar = ivars%cvar - ovars%chln = ivars%chln - ovars%cvln = ivars%cvln - endif - - ovars%psvar = ivars%psvar - ovars%pshln = ivars%pshln - ovars%varsst = ivars%varsst - ovars%corlsst = ivars%corlsst - - end subroutine copy_berror_vars_ - subroutine vinterp_berror_vars_(ivars,ovars) use m_spline, only: spline @@ -563,8 +503,8 @@ subroutine vinterp_berror_vars_(ivars,ovars) use m_const, only: pstd implicit none - type(berror_vars) ivars - type(berror_vars) ovars + type(nc_berror_vars) ivars + type(nc_berror_vars) ovars real(4),allocatable,dimension(:,:) :: aux real(4),allocatable,dimension(:) :: plevi,plevo @@ -672,8 +612,8 @@ subroutine be_write_nc_(fname,ivars) use m_set_eta, only: get_ref_plevs implicit none - character(len=*), intent(in) :: fname - type(berror_vars), intent(in) :: ivars + character(len=*), intent(in) :: fname + type(nc_berror_vars), intent(in) :: ivars real(4),allocatable,dimension(:,:) :: aux real(4),allocatable,dimension(:) :: lats,lons @@ -701,7 +641,7 @@ subroutine be_write_nc_(fname,ivars) lons(ii) = (ii-1.0)*dlon enddo - call write_nc_berror(trim(fname),ivars,plevs,lats,lons,status) + call nc_berror_write(trim(fname),ivars,plevs,lats,lons,status) deallocate(ak,bk) deallocate(plevs) From 1df643adafc89e276e683bd88ef35dbe04209771 Mon Sep 17 00:00:00 2001 From: Joe Stassi Date: Fri, 17 Sep 2021 15:08:55 -0400 Subject: [PATCH 065/205] Logic was added to pass the ARCHIVE location from GEOSadas to the Pyradmon code so that it has the correct location when GEOSadas is not using the default location. This update also contains the $datamove_constraint variable and related logic from Ricardo which he was planning to add later. He said that including it now would have no impact. --- .../GEOSdas_App/monthly.yyyymm.pl.tmpl | 55 ++++++++++++++----- 1 file changed, 41 insertions(+), 14 deletions(-) diff --git a/src/Applications/GEOSdas_App/monthly.yyyymm.pl.tmpl b/src/Applications/GEOSdas_App/monthly.yyyymm.pl.tmpl index c3dba664..714bbc7d 100644 --- a/src/Applications/GEOSdas_App/monthly.yyyymm.pl.tmpl +++ b/src/Applications/GEOSdas_App/monthly.yyyymm.pl.tmpl @@ -55,14 +55,15 @@ use WriteLog qw(chdir_ mkpath_ unlink_ system_); # global variables #----------------- my ($meansFLG, $plotsFLG, $radmonFLG, $tarFLG, $finish, $nopush, %doMeans); -my ($EXPID, $FVHOME, $PBS_BIN, $PYRADMON, $account, $listdir, $mnthlyRC); -my ($numnodes_mm, $numnodes_mp, $plotHISTrc, $qcmd, $rundir); +my ($EXPID, $FVARCH, $FVHOME, $PBS_BIN, $PYRADMON, $account, $listdir); +my ($mnthlyRC, $numnodes_mm, $numnodes_mp, $plotHISTrc, $qcmd, $rundir); my ($script, $siteID, $workdir, $yyyymm, %newrc, %JOBID); my ($walltime_cl, $walltime_mm, $walltime_mp, $walltime_pf); my ($partition, $qos, $runlocal); +my ($datamove_constraint); -#$partition = "preops"; -#$qos = "dastest"; +$partition = "preops"; +$qos = "dastest"; my %valid = ( "fetch" => 1, "means" => 1, @@ -165,10 +166,17 @@ sub init { perl_config(%opts); $EXPID = $ENV{"EXPID"}; + $FVARCH = $ENV{"FVARCH"}; $FVHOME = $ENV{"FVHOME"}; $PBS_BIN = $ENV{"PBS_BIN"}; $PYRADMON = $ENV{"PYRADMON"}; $GID = $ENV{"GID"}; + $datamove_constraint = $ENV{"datamove_constraint"}; + $datamove_constraint = "#"; + if ($datamove_constraint) { + $datamove_constraint = $datamove_constraint; + } + $ENV{"PATH"} = "$rundir:$fvroot/bin:$ENV{PATH}"; @@ -397,6 +405,7 @@ sub fetch_inputs { my (%opts, $filestring, $ftype, $htype, $do_dmput, $do_tar); my ($tmpl, $prefetch_j, $jobname, $outfile); my ($job_name, $time, $output, $parFLG, $vFLG); + my ($constraint); my (%value, @deps, $dependFLG, $cmd); # input arguments @@ -421,6 +430,7 @@ sub fetch_inputs { $time = "SBATCH --time=$walltime_pf"; $output = "SBATCH --output=$outfile"; $parFLG = "SBATCH --partition=datamove"; + $constraint = "$datamove_constraint"; $vFLG = "--export=outfile=$outfile"; } else { @@ -428,6 +438,7 @@ sub fetch_inputs { $time = "PBS -l walltime=$walltime_pf"; $output = "PBS -o $outfile"; $parFLG = ""; + $constraint = ""; $vFLG = "-v outfile=$outfile"; } @@ -437,6 +448,7 @@ sub fetch_inputs { $value{"__ACCOUNT__"} = $account; $value{"__OUTPUT__"} = $output; $value{"__PARTITION__"} = $parFLG; + $value{"__CONSTRAINT__"} = $constraint; $value{"__FILESTRING__"} = $filestring; $value{"__HOURTYPE__"} = $htype; @@ -565,6 +577,7 @@ sub tar_and_clean_inputs { my (%opts, $filestring, $ftype, $do_tar, $lastFLG); my ($tmpl, $tarandclean_j, $jobname, $outfile); my ($job_name, $time, $output, $parFLG, $vFLG); + my ($constraint); my (%value, $walltime, @deps, $dependFLG, $cmd); # input arguments @@ -588,6 +601,7 @@ sub tar_and_clean_inputs { $time = "SBATCH --time=$walltime_cl"; $output = "SBATCH --output=$outfile"; $parFLG = "SBATCH --partition=datamove"; + $constraint = "$datamove_constraint"; $vFLG = "--export=outfile=$outfile"; } else { @@ -595,6 +609,7 @@ sub tar_and_clean_inputs { $time = "PBS -l walltime=$walltime_cl"; $output = "PBS -o $outfile"; $parFLG = ""; + $constraint = ""; $vFLG = "-v outfile=$outfile"; } @@ -604,6 +619,7 @@ sub tar_and_clean_inputs { $value{"__ACCOUNT__"} = $account; $value{"__OUTPUT__"} = $output; $value{"__PARTITION__"} = $parFLG; + $value{"__CONSTRAINT__"} = $constraint; $value{"__FILESTRING__"} = $filestring; $value{"__YYYYMM__"} = $yyyymm; @@ -639,6 +655,7 @@ sub tar_and_clean_inputs { sub archive_monthly_keep_files { my ($outfile, $vars, $vFLG, $outFLG, $qFLGs, @deps, $dependFLG); my ($KEEParc_csh, $cmd, $cmd_save); + my ($constraint,$dummy); # command flags #-------------- @@ -648,10 +665,14 @@ sub archive_monthly_keep_files { . "outfile=$outfile"; if ($siteID eq "nccs") { + $constraint = ""; + if ($datamove_constraint) { + ($dummy, $constraint) = (split / /, $datamove_constraint)[0, 1]; + } $vFLG = "--export=$vars"; $outFLG = "--output=$outfile"; $qFLGs = "--job-name=KEEParc.$yyyymm --time=$walltime_cl" - . " --partition=datamove"; + . " --partition=datamove $constraint"; } else { $vFLG = "-v $vars"; @@ -695,6 +716,7 @@ sub archive_monthly_keep_files { sub archive_monthly_files { my ($outfile, $vars, $vFLG, $outFLG, $qFLGs, @deps, $dependFLG); my ($MPParc_csh, $cmd, $cmd_save); + my ($dummy, $constraint); # command flags #-------------- @@ -705,10 +727,14 @@ sub archive_monthly_files { . "mmid=$$"; if ($siteID eq "nccs") { + $constraint = ""; + if ($datamove_constraint) { + ($dummy, $constraint) = (split / /, $datamove_constraint)[0, 1]; + } $vFLG = "--export=$vars"; $outFLG = "--output=$outfile"; $qFLGs = "--job-name=MPParc.$yyyymm --nodes=1 --time=$walltime_cl" - . " --partition=datamove"; + . " --partition=datamove $constraint"; } else { $vFLG = "-v $vars"; @@ -887,35 +913,36 @@ sub finish_monthly_plots { # purpose - run pyradmon code #======================================================================= sub radmon { - my ($qFLG, $flags, $pyflags, $radmonRC); + my ($qFLG, $flags, $pyflags, $radmonRC, $pyradmon_driver_pl); $qFLG = ""; $qFLG = "-qjobs" unless $runlocal; - $flags = "-expid $EXPID -fvhome $FVHOME -np $qFLG"; + $flags = "-expid $EXPID -fvhome $FVHOME -archive $FVARCH -np $qFLG"; + $pyradmon_driver_pl = "$PYRADMON/scripts/pyradmon_driver.pl"; $radmonRC = "$FVHOME/radmon/radmon.defaults.rc"; $radmonRC = "" unless -e $radmonRC; if ($radmonFLG == 1) { $pyflags = $flags ." -startdate ${yyyymm}01"; - system("$PYRADMON/scripts/pyradmon_driver.pl $radmonRC $pyflags"); + system("$pyradmon_driver_pl $radmonRC $pyflags"); } elsif ($radmonFLG == 2) { $pyflags = $flags ." -startdate ${yyyymm}01 -enddate ${yyyymm}15"; - system("$PYRADMON/scripts/pyradmon_driver.pl $radmonRC $pyflags"); + system("$pyradmon_driver_pl $radmonRC $pyflags"); $pyflags = $flags ." -startdate ${yyyymm}16"; - system("$PYRADMON/scripts/pyradmon_driver.pl $radmonRC $pyflags"); + system("$pyradmon_driver_pl $radmonRC $pyflags"); } elsif ($radmonFLG == 3) { $pyflags = $flags ." -startdate ${yyyymm}01 -enddate ${yyyymm}10"; - system("$PYRADMON/scripts/pyradmon_driver.pl $radmonRC $pyflags"); + system("$pyradmon_driver_pl $radmonRC $pyflags"); $pyflags = $flags ." -startdate ${yyyymm}11 -enddate ${yyyymm}20"; - system("$PYRADMON/scripts/pyradmon_driver.pl $radmonRC $pyflags"); + system("$pyradmon_driver_pl $radmonRC $pyflags"); $pyflags = $flags ." -startdate ${yyyymm}21"; - system("$PYRADMON/scripts/pyradmon_driver.pl $radmonRC $pyflags"); + system("$pyradmon_driver_pl $radmonRC $pyflags"); } } From a883d2ed77f283696f51b511ab81e0884f0e5752 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Tue, 21 Sep 2021 12:57:38 -0400 Subject: [PATCH 066/205] Update LICENSE to Apache, other license changes GEOS was recently moved to use the Apache 2.0 license. This update: * Changes the main `LICENSE` file in the repo to be the Apache 2.0 license * Adds a `COPYRIGHT` file * Moves the old NOSA license to a `LICENSE-NOSA` file * Adds text to the `README.md` about the new and old licenses --- COPYRIGHT | 15 +++ LICENSE | 200 +++++++++++++++++++++++++++++++++++++ LICENSE.md => LICENSE-NOSA | 2 - README.md | 10 ++ 4 files changed, 225 insertions(+), 2 deletions(-) create mode 100644 COPYRIGHT create mode 100644 LICENSE rename LICENSE.md => LICENSE-NOSA (99%) diff --git a/COPYRIGHT b/COPYRIGHT new file mode 100644 index 00000000..26a5bfb0 --- /dev/null +++ b/COPYRIGHT @@ -0,0 +1,15 @@ +NASA Docket No. GSC-15,354-1, and identified as "GEOS-5 GCM Modeling Software” + +“Copyright © 2008 United States Government as represented by the Administrator +of the National Aeronautics and Space Administration. All Rights Reserved.” + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use +this file except in compliance with the License. You may obtain a copy of the +License at + +http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software distributed +under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR +CONDITIONS OF ANY KIND, either express or implied. See the License for the +specific language governing permissions and limitations under the License. diff --git a/LICENSE b/LICENSE new file mode 100644 index 00000000..82ca4504 --- /dev/null +++ b/LICENSE @@ -0,0 +1,200 @@ + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + +TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + +1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, and + distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by the copyright + owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all other entities + that control, are controlled by, or are under common control with that entity. + For the purposes of this definition, "control" means (i) the power, direct or + indirect, to cause the direction or management of such entity, whether by + contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity exercising + permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, including + but not limited to software source code, documentation source, and configuration + files. + + "Object" form shall mean any form resulting from mechanical transformation or + translation of a Source form, including but not limited to compiled object code, + generated documentation, and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or Object form, made + available under the License, as indicated by a copyright notice that is included + in or attached to the work (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object form, that + is based on (or derived from) the Work and for which the editorial revisions, + annotations, elaborations, or other modifications represent, as a whole, an + original work of authorship. For the purposes of this License, Derivative Works + shall not include works that remain separable from, or merely link (or bind by + name) to the interfaces of, the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including the original version + of the Work and any modifications or additions to that Work or Derivative Works + thereof, that is intentionally submitted to Licensor for inclusion in the Work + by the copyright owner or by an individual or Legal Entity authorized to submit + on behalf of the copyright owner. For the purposes of this definition, + "submitted" means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, and + issue tracking systems that are managed by, or on behalf of, the Licensor for + the purpose of discussing and improving the Work, but excluding communication + that is conspicuously marked or otherwise designated in writing by the copyright + owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity on behalf + of whom a Contribution has been received by Licensor and subsequently + incorporated within the Work. + +2. Grant of Copyright License. + + Subject to the terms and conditions of this License, each Contributor hereby + grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, + irrevocable copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the Work and such + Derivative Works in Source or Object form. + +3. Grant of Patent License. + + Subject to the terms and conditions of this License, each Contributor hereby + grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, + irrevocable (except as stated in this section) patent license to make, have + made, use, offer to sell, sell, import, and otherwise transfer the Work, where + such license applies only to those patent claims licensable by such Contributor + that are necessarily infringed by their Contribution(s) alone or by combination + of their Contribution(s) with the Work to which such Contribution(s) was + submitted. If You institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work or a + Contribution incorporated within the Work constitutes direct or contributory + patent infringement, then any patent licenses granted to You under this License + for that Work shall terminate as of the date such litigation is filed. + +4. Redistribution. + + You may reproduce and distribute copies of the Work or Derivative Works + thereof in any medium, with or without modifications, and in Source or Object + form, provided that You meet the following conditions: + + (a) You must give any other recipients of the Work or Derivative Works a + copy of this License; and + + (b) You must cause any modified files to carry prominent notices stating that + You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works that You + distribute, all copyright, patent, trademark, and attribution notices from + the Source form of the Work, excluding those notices that do not pertain + to any part of the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its distribution, + then any Derivative Works that You distribute must include a readable copy + of the attribution notices contained within such NOTICE file, excluding + those notices that do not pertain to any part of the Derivative Works, in + at least one of the following places: within a NOTICE text file + distributed as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, within a + display generated by the Derivative Works, if and wherever such + third-party notices normally appear. The contents of the NOTICE file are + for informational purposes only and do not modify the License. You may add + Your own attribution notices within Derivative Works that You distribute, + alongside or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed as modifying + the License. + + You may add Your own copyright statement to Your modifications and may + provide additional or different license terms and conditions for use, + reproduction, or distribution of Your modifications, or for any such + Derivative Works as a whole, provided Your use, reproduction, and + distribution of the Work otherwise complies with the conditions stated in + this License. + +5. Submission of Contributions. + + Unless You explicitly state otherwise, any Contribution intentionally + submitted for inclusion in the Work by You to the Licensor shall be under the + terms and conditions of this License, without any additional terms or + conditions. Notwithstanding the above, nothing herein shall supersede or + modify the terms of any separate license agreement you may have executed with + Licensor regarding such Contributions. + +6. Trademarks. + + This License does not grant permission to use the trade names, trademarks, + service marks, or product names of the Licensor, except as required for + reasonable and customary use in describing the origin of the Work and + reproducing the content of the NOTICE file. + +7. Disclaimer of Warranty. + + Unless required by applicable law or agreed to in writing, Licensor provides + the Work (and each Contributor provides its Contributions) on an "AS IS" + BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions of + TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR + PURPOSE. You are solely responsible for determining the appropriateness of + using or redistributing the Work and assume any risks associated with Your + exercise of permissions under this License. + +8. Limitation of Liability. + + In no event and under no legal theory, whether in tort (including + negligence), contract, or otherwise, unless required by applicable law (such + as deliberate and grossly negligent acts) or agreed to in writing, shall any + Contributor be liable to You for damages, including any direct, indirect, + special, incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the Work + (including but not limited to damages for loss of goodwill, work stoppage, + computer failure or malfunction, or any and all other commercial damages or + losses), even if such Contributor has been advised of the possibility of such + damages. + +9. Accepting Warranty or Additional Liability. + + While redistributing the Work or Derivative Works thereof, You may choose to + offer, and charge a fee for, acceptance of support, warranty, indemnity, or + other liability obligations and/or rights consistent with this License. + However, in accepting such obligations, You may act only on Your own behalf + and on Your sole responsibility, not on behalf of any other Contributor, and + only if You agree to indemnify, defend, and hold each Contributor harmless + for any liability incurred by, or claims asserted against, such Contributor + by reason of your accepting any such warranty or additional liability. + +END OF TERMS AND CONDITIONS + +APPENDIX: How to apply the Apache License to your work + +To apply the Apache License to your work, attach the following boilerplate +notice with the fields enclosed by brackets "[]" replaced with your own +identifying information. (Don't include the brackets!) The text should be +enclosed in the appropriate comment syntax for the file format. We also +recommend that a file or class name and description of purpose be included on +the same "printed page" as the copyright notice for easier identification within +third-party archives. + + NASA Docket No. GSC-15,354-1, and identified as "GEOS-5 GCM Modeling Software” + + “Copyright © 2008 United States Government as represented by the Administrator + of the National Aeronautics and Space Administration. All Rights Reserved.” + + Licensed under the Apache License, Version 2.0 (the "License"); you may not use + this file except in compliance with the License. You may obtain a copy of the + License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software distributed + under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR + CONDITIONS OF ANY KIND, either express or implied. See the License for the + specific language governing permissions and limitations under the License. diff --git a/LICENSE.md b/LICENSE-NOSA similarity index 99% rename from LICENSE.md rename to LICENSE-NOSA index b0277a69..cf008bf9 100644 --- a/LICENSE.md +++ b/LICENSE-NOSA @@ -1,4 +1,3 @@ -``` NASA OPEN SOURCE SOFTWARE AGREEMENT @@ -260,4 +259,3 @@ hereby agrees to all terms and conditions herein. F. Point of Contact: Any Recipient contact with Government Agency is to be directed to the designated representative as follows: Dale Hithon, SRA Assistant, (301) 286-2691. -``` diff --git a/README.md b/README.md index 8f2a96ce..2501ffdd 100644 --- a/README.md +++ b/README.md @@ -181,3 +181,13 @@ cd install/bin Documentation for Running the ADAS can be found in the GEOS ADAS Wiki page https://github.com/GEOS-ESM/GEOSadas/wiki + +## Contributing + +Please check out our [contributing guidelines](CONTRIBUTING.md). + +## License + +All files are currently licensed under the Apache-2.0 license, see [`LICENSE`](LICENSE). + +Previously, the code was licensed under the [NASA Open Source Agreement, Version 1.3](LICENSE-NOSA). From 58b1e2321beb6ebfdda7f3963604eb6fab5c759a Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Tue, 21 Sep 2021 15:25:16 -0400 Subject: [PATCH 067/205] Fix license reference in CONTRIBUTING.md --- CONTRIBUTING.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index c9e6e594..58d5471d 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -13,4 +13,4 @@ are covered by other agreements and do not need to sign a CLA. ## License By contributing to GEOS-ESM projects, you agree your contributions will be -licensed under the [NASA Open Source Agreement (NOSA) License](LICENSE.md) +licensed under the [Apache 2.0 License](LICENSE) From 494ce0dac83f3390b0027a33cbdef444cd329aa7 Mon Sep 17 00:00:00 2001 From: Joe Stassi Date: Fri, 24 Sep 2021 09:35:49 -0400 Subject: [PATCH 068/205] Set $constraint = "" if it is not successfully extracted from $datamove_constraint --- src/Applications/GEOSdas_App/monthly.yyyymm.pl.tmpl | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Applications/GEOSdas_App/monthly.yyyymm.pl.tmpl b/src/Applications/GEOSdas_App/monthly.yyyymm.pl.tmpl index 714bbc7d..bb81c2c1 100644 --- a/src/Applications/GEOSdas_App/monthly.yyyymm.pl.tmpl +++ b/src/Applications/GEOSdas_App/monthly.yyyymm.pl.tmpl @@ -669,6 +669,7 @@ sub archive_monthly_keep_files { if ($datamove_constraint) { ($dummy, $constraint) = (split / /, $datamove_constraint)[0, 1]; } + $constraint = "" unless $constraint; $vFLG = "--export=$vars"; $outFLG = "--output=$outfile"; $qFLGs = "--job-name=KEEParc.$yyyymm --time=$walltime_cl" @@ -731,6 +732,7 @@ sub archive_monthly_files { if ($datamove_constraint) { ($dummy, $constraint) = (split / /, $datamove_constraint)[0, 1]; } + $constraint = "" unless $constraint; $vFLG = "--export=$vars"; $outFLG = "--output=$outfile"; $qFLGs = "--job-name=MPParc.$yyyymm --nodes=1 --time=$walltime_cl" From 5c4948dc747887df07afcd24b0dbe128688c2b34 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Mon, 4 Oct 2021 09:14:43 -0400 Subject: [PATCH 069/205] minor fixes to various scripts --- .../GEOSdas_App/Create_anasa_script.pm | 29 +++++++++---------- .../GEOSdas_App/Create_asens_script.pm | 6 ++-- .../GEOSdas_App/monthly.yyyymm.pl.tmpl | 18 ++++++++---- .../NCEP_enkf/scripts/gmao/gcm_ensset_rc.csh | 2 ++ .../NCEP_Etc/NCEP_enkf/scripts/gmao/jobgen.pl | 2 +- 5 files changed, 32 insertions(+), 25 deletions(-) diff --git a/src/Applications/GEOSdas_App/Create_anasa_script.pm b/src/Applications/GEOSdas_App/Create_anasa_script.pm index 8c7e3661..e1e78b6d 100644 --- a/src/Applications/GEOSdas_App/Create_anasa_script.pm +++ b/src/Applications/GEOSdas_App/Create_anasa_script.pm @@ -609,22 +609,21 @@ EOF endif else set lstcases = `/bin/ls -1 standalone.*` + if ( \$status ) then + echo \$myname": no more restart files, forecast job completed" + exit 0 + endif + if ( \$#lstcases > 0 ) then + set fcst_nxt = `echo \$lstcases[1] | cut -d. -f2 | cut -d+ -f1` + set jname = a\${fcst_nxt} + set lname = \$jname.log.o%j + if ( \$BATCH_SUBCMD == "sbatch" ) then + sbatch -d afterany:\${PBS_JOBID} -J \$jname -o \$lname $jobsa.j + else + qsub -W depend=afterany:\${PBS_JOBID} -N \$jname -o \$lname $jobsa.j + endif + endif endif - if ( \$status ) then - echo \$myname": no more restart files, forecast job completed" - exit 0 - endif - if ( \$#lstcases > 0 ) then - set fcst_nxt = `echo \$lstcases[1] | cut -d. -f2 | cut -d+ -f1` - set jname = a\${fcst_nxt} - set lname = \$jname.log.o%j - if ( \$BATCH_SUBCMD == "sbatch" ) then - sbatch -d afterany:\${PBS_JOBID} -J \$jname -o \$lname $jobsa.j - else - qsub -W depend=afterany:\${PBS_JOBID} -N \$jname -o \$lname $jobsa.j - endif - endif - # Because on Columbia this is not a legitimate TMPDIR, remove dir to avoid pile up # -------------------------------------------------------------------------------- diff --git a/src/Applications/GEOSdas_App/Create_asens_script.pm b/src/Applications/GEOSdas_App/Create_asens_script.pm index 3019203f..9c900d90 100644 --- a/src/Applications/GEOSdas_App/Create_asens_script.pm +++ b/src/Applications/GEOSdas_App/Create_asens_script.pm @@ -445,10 +445,10 @@ EOF # ----------------------------------------- if ( \$?this_nymdhh ) then set rslist = `/bin/ls -1 \$FVHOME/asens/\$EXPID.fsens_\${jgrdnrm}.eta.????????_??z+????????_??z-\${this_nymdhh}z.$ncsuffix \\ - \$FVHOME/asens/\$EXPID.Jgradf_\${jgrdnrm}.eta.????????_??z+????????_??z-\${this_nymdhh}z.$ncsuffix` + \$FVHOME/asens/\$EXPID.Jgradf_\${jgrdnrm}.eta.????????_??z+\${this_nymdhh}z.$ncsuffix` else set rslist = `/bin/ls -1 \$FVHOME/asens/\$EXPID.fsens_\${jgrdnrm}.eta.????????_??z+????????_??z-????????_??z.$ncsuffix \\ - \$FVHOME/asens/\$EXPID.Jgradf_\${jgrdnrm}.eta.????????_??z+????????_??z-????????_??z.$ncsuffix` + \$FVHOME/asens/\$EXPID.Jgradf_\${jgrdnrm}.eta.????????_??z+????????_??z.$ncsuffix` endif if ( \$status ) then echo \$myname": no gradient files found, nothing to do" @@ -603,7 +603,7 @@ EOF if (! \$?this_nymdhh ) then set rslist = `/bin/ls -1 \$FVHOME/asens/\$EXPID.fsens_???.eta.????????_??z+????????_??z-????????_??z.$ncsuffix \\ - \$FVHOME/asens/\$EXPID.Jgradf_???.eta.????????_??z+????????_??z-????????_??z.$ncsuffix` + \$FVHOME/asens/\$EXPID.Jgradf_???.eta.????????_??z+????????_??z.$ncsuffix` if ( \$status ) then echo \$myname": no more sensitivity files, forecast job completed" else diff --git a/src/Applications/GEOSdas_App/monthly.yyyymm.pl.tmpl b/src/Applications/GEOSdas_App/monthly.yyyymm.pl.tmpl index 51bdc9be..8609a2f1 100644 --- a/src/Applications/GEOSdas_App/monthly.yyyymm.pl.tmpl +++ b/src/Applications/GEOSdas_App/monthly.yyyymm.pl.tmpl @@ -60,6 +60,7 @@ my ($numnodes_mm, $numnodes_mp, $plotHISTrc, $qcmd, $rundir); my ($script, $siteID, $workdir, $yyyymm, %newrc, %JOBID); my ($walltime_cl, $walltime_mm, $walltime_mp, $walltime_pf); my ($partition, $qos, $runlocal); +my ($datamove_constraint); #$partition = "preops"; #$qos = "dastest"; @@ -169,6 +170,11 @@ sub init { $PBS_BIN = $ENV{"PBS_BIN"}; $PYRADMON = $ENV{"PYRADMON"}; $GID = $ENV{"GID"}; + $datamove_constraint = "#"; + if ($ENV{"DATAMOVE_CONSTRAINT"}) { + $datamove_constarint = $ENV{"DATAMOVE_CONSTRAINT"}; + } + $ENV{"PATH"} = "$rundir:$fvroot/bin:$ENV{PATH}"; @@ -422,7 +428,7 @@ sub fetch_inputs { $time = "SBATCH --time=$walltime_pf"; $output = "SBATCH --output=$outfile"; $parFLG = "SBATCH --partition=datamove"; - $constraint = "$DATAMOVE_CONSTRAINT": + $constraint = "$datamove_constraint": $vFLG = "--export=outfile=$outfile"; } else { @@ -593,7 +599,7 @@ sub tar_and_clean_inputs { $time = "SBATCH --time=$walltime_cl"; $output = "SBATCH --output=$outfile"; $parFLG = "SBATCH --partition=datamove"; - $constraint = "$DATAMOVE_CONSTRAINT"; + $constraint = "$datamove_constraint"; $vFLG = "--export=outfile=$outfile"; } else { @@ -658,8 +664,8 @@ sub archive_monthly_keep_files { if ($siteID eq "nccs") { $constraint = ""; - if ($DATAMOVE_CONSTRAINT) { - ($dummy, $constraint) = (split / /, $DATAMOVE_CONSTRAINT)[0, 1]; + if ($datamove_constraint) { + ($dummy, $constraint) = (split / /, $datamove_constraint)[0, 1]; } $vFLG = "--export=$vars"; $outFLG = "--output=$outfile"; @@ -720,8 +726,8 @@ sub archive_monthly_files { if ($siteID eq "nccs") { $constraint = ""; - if ($DATAMOVE_CONSTRAINT) { - ($dummy, $constraint) = (split / /, $DATAMOVE_CONSTRAINT)[0, 1]; + if ($datamove_constraint) { + ($dummy, $constraint) = (split / /, $datamove_constraint)[0, 1]; } $vFLG = "--export=$vars"; $outFLG = "--output=$outfile"; diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/gcm_ensset_rc.csh b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/gcm_ensset_rc.csh index e70b0eb2..c0537586 100644 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/gcm_ensset_rc.csh +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/gcm_ensset_rc.csh @@ -275,6 +275,8 @@ cd $ENSWORK/$member endif /bin/cp fvcore_layout.rc input.nml + /bin/cp $FVHOME/run/GEOS_SurfaceGridComp.rc . + # Prepare CAP # ----------- set this_cap = $ATMENSETC/CAP.rc.tmpl diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/jobgen.pl b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/jobgen.pl index 1cf0271f..092cf9e8 100755 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/jobgen.pl +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/jobgen.pl @@ -224,7 +224,7 @@ sub gen { EOF if ( $ENV{JOBGEN_ARCH_CONSTRAINT} ) { print SCRIPT <<"EOF"; -#SBATCH --constraint=$ENV{JOBGEN_ARCH_CONSTRAINT} +#$ENV{JOBGEN_ARCH_CONSTRAINT} EOF } } From 293b4bffcd6b7ccefb80a82a1881752e0acd87ad Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Mon, 4 Oct 2021 09:20:11 -0400 Subject: [PATCH 070/205] corrections to trajectory file needed for JEDI --- .../NCEP_enkf/scripts/gmao/etc/HISTAENS.rc.tmpl | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/HISTAENS.rc.tmpl b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/HISTAENS.rc.tmpl index 904e9779..241a901e 100644 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/HISTAENS.rc.tmpl +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/HISTAENS.rc.tmpl @@ -746,6 +746,7 @@ COLLECTIONS: 'bkg.eta' 'QSTOT' , 'MOIST' , 'qs' , 'QRTOT' , 'MOIST' , 'qr' , 'O3PPMV' , 'CHEMISTRY' , 'o3mr' , + 'GOCART::CO2' , 'GOCART' , 'co2' , 'QCLSX0' , 'MOIST' , 'qls' , 'QCCNX0' , 'MOIST' , 'qcn' , 'CLCNX0' , 'MOIST' , 'cfcn' , @@ -768,8 +769,15 @@ COLLECTIONS: 'bkg.eta' 'CT' , 'SURFACE' , 'ct' , 'CQ' , 'SURFACE' , 'cq' , 'U10N;V10N' , 'SURFACE' , 'u10m;v10m' , - 'TA' , 'DYN' , 'ts' , + 'TA' , 'DYN' , 'ta' , + 'TS' , 'SURFACE' , 'ts' , 'SNOMAS' , 'SURFACE' , 'sheleg' , 'TSOIL1' , 'SURFACE' , 'soilt' , 'WET1' , 'SURFACE' , 'soilm' , + 'DCOOL' , 'SURFACE' , 'dcool' , + 'DWARM' , 'SURFACE' , 'dwarm' , + 'TDROP' , 'SURFACE' , 'tdrop' , + 'TS_FOUND' , 'SURFACE' , 'ts_found' , + 'TDEL' , 'SURFACE' , 'tdel' , + 'Z0' , 'SURFACE' , 'z0m' , :: From 4e50312ce4ed503c8c2b63af28078c19e92ab1e3 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Mon, 4 Oct 2021 09:59:05 -0400 Subject: [PATCH 071/205] renamed base exp for this version --- .../testsuites/{x0046.input => x0046a.input} | 14 ++++++------- ...x0046_replay.input => x0046a_replay.input} | 20 +++++++++---------- 2 files changed, 17 insertions(+), 17 deletions(-) rename src/Applications/GEOSdas_App/testsuites/{x0046.input => x0046a.input} (94%) rename src/Applications/GEOSdas_App/testsuites/{x0046_replay.input => x0046a_replay.input} (91%) diff --git a/src/Applications/GEOSdas_App/testsuites/x0046.input b/src/Applications/GEOSdas_App/testsuites/x0046a.input similarity index 94% rename from src/Applications/GEOSdas_App/testsuites/x0046.input rename to src/Applications/GEOSdas_App/testsuites/x0046a.input index 28ef7ecb..4f04ef0b 100644 --- a/src/Applications/GEOSdas_App/testsuites/x0046.input +++ b/src/Applications/GEOSdas_App/testsuites/x0046a.input @@ -1,8 +1,8 @@ #------------ -# x0046.input +# x0046a.input #------------ -description: x0046__GEOSadas-5_29_0__agrid_C360__ogrid_C +description: x0046a__GEOSadas-5_29_0__agrid_C360__ogrid_C tag: GEOSadas-5_29_0 ---ENDHEADERS--- @@ -28,7 +28,7 @@ EXPID? [u000_C360] Check for previous use of expid (y/n)? [y] > n -EXPDSC? [x0046__GEOSadas-5_29_0__agrid_C360__ogrid_C] +EXPDSC? [x0046a__GEOSadas-5_29_0__agrid_C360__ogrid_C] > Land Boundary Conditions? [Icarus_Updated] @@ -37,10 +37,10 @@ Land Boundary Conditions? [Icarus_Updated] Catchment Model choice? [1] > -FVHOME? [/discover/nobackup/dao_it/x0046] +FVHOME? [/discover/nobackup/dao_it/x0046a] > /discover/nobackup/projects/gmao/dadev/dao_it/$expid -The directory /discover/nobackup/projects/gmao/obsdev/dao_it/x0046 already exists. Clean it? [y] +The directory /discover/nobackup/projects/gmao/obsdev/dao_it/x0046a already exists. Clean it? [y] > Which case of variational analysis? [1] @@ -91,7 +91,7 @@ Run singular vector experiments (0=n,1=yes)? [0] Run analysis-sensitivity applications (0=no,1=yes)? [0] > 1 -Verifying experiment id: [x0046] +Verifying experiment id: [x0046a] > Ending year-month-day? [20191121] @@ -226,7 +226,7 @@ Ensemble Resolution? [C90] Ensemble Vertical Levels? [72] > -Experiment archive directory for ensemble restarts or 'later': [/archive/u/rtodling/x0046] +Experiment archive directory for ensemble restarts or 'later': [/archive/u/rtodling/x0046a] > /discover/nobackup/projects/gmao/dadev/rtodling/archive/x0044 Edit COLLECTIONS list in run/HISTORY.rc.tmpl (y/n)? [n] diff --git a/src/Applications/GEOSdas_App/testsuites/x0046_replay.input b/src/Applications/GEOSdas_App/testsuites/x0046a_replay.input similarity index 91% rename from src/Applications/GEOSdas_App/testsuites/x0046_replay.input rename to src/Applications/GEOSdas_App/testsuites/x0046a_replay.input index d2437187..24a4a56b 100644 --- a/src/Applications/GEOSdas_App/testsuites/x0046_replay.input +++ b/src/Applications/GEOSdas_App/testsuites/x0046a_replay.input @@ -1,8 +1,8 @@ #------------ -# x0046_replay.input +# x0046a_replay.input #------------ -description: x0046_replay__GEOSadas-5_29_0__agrid_C360__ogrid_C +description: x0046a_replay__GEOSadas-5_29_0__agrid_C360__ogrid_C tag: GEOSadas-5_29_0 ---ENDHEADERS--- @@ -28,7 +28,7 @@ EXPID? [u000_C360] Check for previous use of expid (y/n)? [y] > n -EXPDSC? [x0046_replay__GEOSadas-5_29_0__agrid_C360__ogrid_C] +EXPDSC? [x0046a_replay__GEOSadas-5_29_0__agrid_C360__ogrid_C] > Land Boundary Conditions? [Icarus_Updated] @@ -37,10 +37,10 @@ Land Boundary Conditions? [Icarus_Updated] Catchment Model choice? [1] > -FVHOME? [/discover/nobackup/dao_it/x0046_replay] +FVHOME? [/discover/nobackup/dao_it/x0046a_replay] > /discover/nobackup/projects/gmao/dadev/dao_it/$expid -The directory /discover/nobackup/projects/gmao/obsdev/dao_it/x0046_replay already exists. Clean it? [y] +The directory /discover/nobackup/projects/gmao/obsdev/dao_it/x0046a_replay already exists. Clean it? [y] > Which case of variational analysis? [1] @@ -91,7 +91,7 @@ Run singular vector experiments (0=n,1=yes)? [0] Run analysis-sensitivity applications (0=no,1=yes)? [0] > 1 -Verifying experiment id: [x0046_replay] +Verifying experiment id: [x0046a_replay] > Ending year-month-day? [20191121] @@ -217,11 +217,11 @@ Select group: [s0818] Replayed Ensemble (from OPS)? [yes] > -Replay exp name? [x0044] -> x0044 +Replay exp name? [x0045a] +> x0045a -Replay archive directory? [/discover/nobackup/projects/gmao/dadev/rtodling/archive/x0044] -> /discover/nobackup/projects/gmao/dadev/rtodling/archive/x0044 +Replay archive directory? [/discover/nobackup/projects/gmao/dadev/dao_it/archive/x0045a] +> /discover/nobackup/projects/gmao/dadev/dao_it/archive/x0045a Edit COLLECTIONS list in run/HISTORY.rc.tmpl (y/n)? [n] > From 639e71f18479eeec41eed9c48ee618059440e9d7 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Mon, 4 Oct 2021 11:15:43 -0400 Subject: [PATCH 072/205] pseudo-versioning --- components.yaml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/components.yaml b/components.yaml index 94e49d44..2b87e448 100644 --- a/components.yaml +++ b/components.yaml @@ -1,6 +1,6 @@ GEOSadas: fixture: true - develop: develop + tag: rt5.29.0.2 env: local: ./@env @@ -46,7 +46,7 @@ FMS: GEOSana_GridComp: local: ./src/Components/@GEOSana_GridComp remote: ../GEOSana_GridComp.git - branch: feature/rtodling/reviseGPSRO_for_5_29 + tag: v1.4.3 develop: develop GEOSgcm_GridComp: @@ -83,7 +83,7 @@ fvdycore: GEOSchem_GridComp: local: ./src/Components/@GEOSgcm_GridComp/GEOSagcm_GridComp/GEOSphysics_GridComp/@GEOSchem_GridComp remote: ../GEOSchem_GridComp.git - tag: v1.6.0 + tag: rt1.6.1 develop: develop HEMCO: @@ -121,7 +121,7 @@ mom6: GEOSgcm_App: local: ./src/Applications/@GEOSgcm_App remote: ../GEOSgcm_App.git - tag: v1.5.2 + tag: rt1.5.3 develop: develop UMD_Etc: From 9a1efc47a094526615f45caa25db26c55362a5a2 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Mon, 4 Oct 2021 13:03:16 -0400 Subject: [PATCH 073/205] bug in defining fixture --- components.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/components.yaml b/components.yaml index 2b87e448..460014a6 100644 --- a/components.yaml +++ b/components.yaml @@ -1,6 +1,6 @@ GEOSadas: fixture: true - tag: rt5.29.0.2 + develop: develop env: local: ./@env From e6c3df68291beea71292fd42615abd78e83cf2ff Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Mon, 4 Oct 2021 13:39:56 -0400 Subject: [PATCH 074/205] add history output --- components.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/components.yaml b/components.yaml index 460014a6..c16a8bd5 100644 --- a/components.yaml +++ b/components.yaml @@ -121,7 +121,7 @@ mom6: GEOSgcm_App: local: ./src/Applications/@GEOSgcm_App remote: ../GEOSgcm_App.git - tag: rt1.5.3 + tag: rt1.5.3.1 develop: develop UMD_Etc: From 7c591036f1b073e826eb338d333cc46d39f83b74 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Mon, 4 Oct 2021 14:24:40 -0400 Subject: [PATCH 075/205] merge w/ Joe-s changes for radmon --- .../GEOSdas_App/monthly.yyyymm.pl.tmpl | 31 +++++++++++-------- 1 file changed, 18 insertions(+), 13 deletions(-) diff --git a/src/Applications/GEOSdas_App/monthly.yyyymm.pl.tmpl b/src/Applications/GEOSdas_App/monthly.yyyymm.pl.tmpl index 8609a2f1..141fcc52 100644 --- a/src/Applications/GEOSdas_App/monthly.yyyymm.pl.tmpl +++ b/src/Applications/GEOSdas_App/monthly.yyyymm.pl.tmpl @@ -55,8 +55,8 @@ use WriteLog qw(chdir_ mkpath_ unlink_ system_); # global variables #----------------- my ($meansFLG, $plotsFLG, $radmonFLG, $tarFLG, $finish, $nopush, %doMeans); -my ($EXPID, $FVHOME, $PBS_BIN, $PYRADMON, $account, $listdir, $mnthlyRC); -my ($numnodes_mm, $numnodes_mp, $plotHISTrc, $qcmd, $rundir); +my ($EXPID, $FVARCH, $FVHOME, $PBS_BIN, $PYRADMON, $account, $listdir); +my ($mnthlyRC, $numnodes_mm, $numnodes_mp, $plotHISTrc, $qcmd, $rundir); my ($script, $siteID, $workdir, $yyyymm, %newrc, %JOBID); my ($walltime_cl, $walltime_mm, $walltime_mp, $walltime_pf); my ($partition, $qos, $runlocal); @@ -166,13 +166,15 @@ sub init { perl_config(%opts); $EXPID = $ENV{"EXPID"}; + $FVARCH = $ENV{"FVARCH"}; $FVHOME = $ENV{"FVHOME"}; $PBS_BIN = $ENV{"PBS_BIN"}; $PYRADMON = $ENV{"PYRADMON"}; $GID = $ENV{"GID"}; + $datamove_constraint = $ENV{"datamove_constraint"}; $datamove_constraint = "#"; - if ($ENV{"DATAMOVE_CONSTRAINT"}) { - $datamove_constarint = $ENV{"DATAMOVE_CONSTRAINT"}; + if ($datamove_constraint) { + $datamove_constraint = $datamove_constraint; } @@ -428,7 +430,7 @@ sub fetch_inputs { $time = "SBATCH --time=$walltime_pf"; $output = "SBATCH --output=$outfile"; $parFLG = "SBATCH --partition=datamove"; - $constraint = "$datamove_constraint": + $constraint = "$datamove_constraint"; $vFLG = "--export=outfile=$outfile"; } else { @@ -667,6 +669,7 @@ sub archive_monthly_keep_files { if ($datamove_constraint) { ($dummy, $constraint) = (split / /, $datamove_constraint)[0, 1]; } + $constraint = "" unless $constraint; $vFLG = "--export=$vars"; $outFLG = "--output=$outfile"; $qFLGs = "--job-name=KEEParc.$yyyymm --time=$walltime_cl" @@ -729,6 +732,7 @@ sub archive_monthly_files { if ($datamove_constraint) { ($dummy, $constraint) = (split / /, $datamove_constraint)[0, 1]; } + $constraint = "" unless $constraint; $vFLG = "--export=$vars"; $outFLG = "--output=$outfile"; $qFLGs = "--job-name=MPParc.$yyyymm --nodes=1 --time=$walltime_cl" @@ -911,35 +915,36 @@ sub finish_monthly_plots { # purpose - run pyradmon code #======================================================================= sub radmon { - my ($qFLG, $flags, $pyflags, $radmonRC); + my ($qFLG, $flags, $pyflags, $radmonRC, $pyradmon_driver_pl); $qFLG = ""; $qFLG = "-qjobs" unless $runlocal; - $flags = "-expid $EXPID -fvhome $FVHOME -np $qFLG"; + $flags = "-expid $EXPID -fvhome $FVHOME -archive $FVARCH -np $qFLG"; + $pyradmon_driver_pl = "$PYRADMON/scripts/pyradmon_driver.pl"; $radmonRC = "$FVHOME/radmon/radmon.defaults.rc"; $radmonRC = "" unless -e $radmonRC; if ($radmonFLG == 1) { $pyflags = $flags ." -startdate ${yyyymm}01"; - system("$PYRADMON/scripts/pyradmon_driver.pl $radmonRC $pyflags"); + system("$pyradmon_driver_pl $radmonRC $pyflags"); } elsif ($radmonFLG == 2) { $pyflags = $flags ." -startdate ${yyyymm}01 -enddate ${yyyymm}15"; - system("$PYRADMON/scripts/pyradmon_driver.pl $radmonRC $pyflags"); + system("$pyradmon_driver_pl $radmonRC $pyflags"); $pyflags = $flags ." -startdate ${yyyymm}16"; - system("$PYRADMON/scripts/pyradmon_driver.pl $radmonRC $pyflags"); + system("$pyradmon_driver_pl $radmonRC $pyflags"); } elsif ($radmonFLG == 3) { $pyflags = $flags ." -startdate ${yyyymm}01 -enddate ${yyyymm}10"; - system("$PYRADMON/scripts/pyradmon_driver.pl $radmonRC $pyflags"); + system("$pyradmon_driver_pl $radmonRC $pyflags"); $pyflags = $flags ." -startdate ${yyyymm}11 -enddate ${yyyymm}20"; - system("$PYRADMON/scripts/pyradmon_driver.pl $radmonRC $pyflags"); + system("$pyradmon_driver_pl $radmonRC $pyflags"); $pyflags = $flags ." -startdate ${yyyymm}21"; - system("$PYRADMON/scripts/pyradmon_driver.pl $radmonRC $pyflags"); + system("$pyradmon_driver_pl $radmonRC $pyflags"); } } From 14abb414902b8f1b62449cdcc5236c7603167baa Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Tue, 5 Oct 2021 09:44:47 -0400 Subject: [PATCH 076/205] minor fix from coinfo to tgasinfo; off w/ diag bin files; replay test case for x46 correction --- src/Applications/GEOSdas_App/fvsetup | 2 +- src/Applications/GEOSdas_App/gen_silo_arc.pl | 4 ++-- .../{x0046a_replay.input => x0046aRPY.input} | 24 +++++-------------- 3 files changed, 9 insertions(+), 21 deletions(-) rename src/Applications/GEOSdas_App/testsuites/{x0046a_replay.input => x0046aRPY.input} (90%) diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index d29df8a6..8dcd3286 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -765,7 +765,7 @@ sub defaults { gmao_global_anavinfo_rcov.rc gmao_global_blacklist.rc gmao_global_cloudy_radiance_info.rc - gmao_global_coinfo.rc + gmao_global_tgasinfo.rc gmao_global_convinfo.rc gmao_global_hybens_info.x288y181l72.rc gmao_global_hybens_info.x576y361l72.rc diff --git a/src/Applications/GEOSdas_App/gen_silo_arc.pl b/src/Applications/GEOSdas_App/gen_silo_arc.pl index 63d87329..2cf97bed 100755 --- a/src/Applications/GEOSdas_App/gen_silo_arc.pl +++ b/src/Applications/GEOSdas_App/gen_silo_arc.pl @@ -255,8 +255,8 @@ sub gsiobs_info { ($dline3 = $line) =~ s/_ID_/diag_${conv}_ges/; ($dline4 = $line) =~ s/_ID_/imp0hr_diag_$conv/; printarc("$dline1.ods\n"); - printarc("$dline2.bin\n"); - printarc("$dline3.bin\n"); +# printarc("$dline2.bin\n"); +# printarc("$dline3.bin\n"); printarc("$dline2.nc4\n"); printarc("$dline3.nc4\n"); printarc("$dline4.ods\n\n"); diff --git a/src/Applications/GEOSdas_App/testsuites/x0046a_replay.input b/src/Applications/GEOSdas_App/testsuites/x0046aRPY.input similarity index 90% rename from src/Applications/GEOSdas_App/testsuites/x0046a_replay.input rename to src/Applications/GEOSdas_App/testsuites/x0046aRPY.input index 24a4a56b..8dcb383d 100644 --- a/src/Applications/GEOSdas_App/testsuites/x0046a_replay.input +++ b/src/Applications/GEOSdas_App/testsuites/x0046aRPY.input @@ -1,8 +1,8 @@ #------------ -# x0046a_replay.input +# x0046aRPY.input #------------ -description: x0046a_replay__GEOSadas-5_29_0__agrid_C360__ogrid_C +description: x0046aRPY__GEOSadas-5_29_0__agrid_C360__ogrid_C tag: GEOSadas-5_29_0 ---ENDHEADERS--- @@ -28,7 +28,7 @@ EXPID? [u000_C360] Check for previous use of expid (y/n)? [y] > n -EXPDSC? [x0046a_replay__GEOSadas-5_29_0__agrid_C360__ogrid_C] +EXPDSC? [x0046aRPY__GEOSadas-5_29_0__agrid_C360__ogrid_C] > Land Boundary Conditions? [Icarus_Updated] @@ -37,10 +37,10 @@ Land Boundary Conditions? [Icarus_Updated] Catchment Model choice? [1] > -FVHOME? [/discover/nobackup/dao_it/x0046a_replay] +FVHOME? [/discover/nobackup/dao_it/x0046aRPY] > /discover/nobackup/projects/gmao/dadev/dao_it/$expid -The directory /discover/nobackup/projects/gmao/obsdev/dao_it/x0046a_replay already exists. Clean it? [y] +The directory /discover/nobackup/projects/gmao/obsdev/dao_it/x0046aRPY already exists. Clean it? [y] > Which case of variational analysis? [1] @@ -77,21 +77,9 @@ FVICS? [/archive/u/jstassi/restarts/GEOSadas-5_24_0] > /discover/nobackup/projects/gmao/dadev/rtodling/archive/Restarts/x0045/rs/Y2020/M11/x0045.rst.20201129_21z.tar Run model-adjoint-related applications (0=no,1=yes)? [0] -> 1 - -Analysis/Forecast filename template for sensitivity? -> - -Stage the gradient vector files (y/n)? [y] -> - -Run singular vector experiments (0=n,1=yes)? [0] > Run analysis-sensitivity applications (0=no,1=yes)? [0] -> 1 - -Verifying experiment id: [x0046a_replay] > Ending year-month-day? [20191121] @@ -110,7 +98,7 @@ Number of PEs in the meridional direction (NY)? [48] > Job nickname? [g5das] -> x46 +> x46a Run in split executable mode (1=yes;0=no)? [1] > From 7b2b4fb380b085a978deb8271faa988418fc0375 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Tue, 5 Oct 2021 09:55:06 -0400 Subject: [PATCH 077/205] unfortunately Joe tells me the random wrappers will not work from the nc4 files directly! - he is working to fix that - until then the bin files are neded --- src/Applications/GEOSdas_App/gen_silo_arc.pl | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Applications/GEOSdas_App/gen_silo_arc.pl b/src/Applications/GEOSdas_App/gen_silo_arc.pl index 2cf97bed..63d87329 100755 --- a/src/Applications/GEOSdas_App/gen_silo_arc.pl +++ b/src/Applications/GEOSdas_App/gen_silo_arc.pl @@ -255,8 +255,8 @@ sub gsiobs_info { ($dline3 = $line) =~ s/_ID_/diag_${conv}_ges/; ($dline4 = $line) =~ s/_ID_/imp0hr_diag_$conv/; printarc("$dline1.ods\n"); -# printarc("$dline2.bin\n"); -# printarc("$dline3.bin\n"); + printarc("$dline2.bin\n"); + printarc("$dline3.bin\n"); printarc("$dline2.nc4\n"); printarc("$dline3.nc4\n"); printarc("$dline4.ods\n\n"); From 5f4a54ee8c7a9037bd4c17c470c17198cb5ba3f0 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Tue, 5 Oct 2021 11:58:26 -0400 Subject: [PATCH 078/205] need update to GSI --- components.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/components.yaml b/components.yaml index c16a8bd5..b5620e4d 100644 --- a/components.yaml +++ b/components.yaml @@ -46,7 +46,7 @@ FMS: GEOSana_GridComp: local: ./src/Components/@GEOSana_GridComp remote: ../GEOSana_GridComp.git - tag: v1.4.3 + tag: v1.4.4 develop: develop GEOSgcm_GridComp: From 228572905062d32d470d38ac9d79dc5586354e77 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Fri, 8 Oct 2021 13:10:06 -0400 Subject: [PATCH 079/205] These are mild modifications of the work of Sara and Rolf for LDAS. --- src/Applications/GEOSdas_App/GEOSdas.csm | 194 +++++++++--------- src/Applications/GEOSdas_App/fvpsas | 45 ++-- src/Applications/GEOSdas_App/fvsetup | 50 ++--- src/Applications/GEOSdas_App/ldas_run.csh | 192 ++++++++--------- .../testsuites/C360L181_replay.input | 9 +- .../testsuites/C360L91_replay.input | 9 +- .../GEOSdas_App/testsuites/C48f.input | 9 +- .../GEOSdas_App/testsuites/C90C.input | 9 +- .../GEOSdas_App/testsuites/C90C_ens.input | 9 +- .../GEOSdas_App/testsuites/C90C_replay.input | 3 + .../GEOSdas_App/testsuites/geos_it.input | 3 + .../GEOSdas_App/testsuites/prePP.input | 40 ++-- .../GEOSdas_App/testsuites/x0046a.input | 9 +- .../GEOSdas_App/testsuites/x0046aRPY.input | 9 +- .../NCEP_Etc/NCEP_enkf/scripts/gmao/atm_ens.j | 28 +-- .../NCEP_enkf/scripts/gmao/atmos_eldas.csh | 183 ++++++++--------- 16 files changed, 409 insertions(+), 392 deletions(-) diff --git a/src/Applications/GEOSdas_App/GEOSdas.csm b/src/Applications/GEOSdas_App/GEOSdas.csm index 99705a77..2e758c69 100755 --- a/src/Applications/GEOSdas_App/GEOSdas.csm +++ b/src/Applications/GEOSdas_App/GEOSdas.csm @@ -1897,7 +1897,6 @@ exit 1 /bin/cp $FVHOME/recycle/$EXPID.ana_radstat_rst.*.tar radstat endif - # GAAS restart files #------------------- if ( ! $DO4DVAR ) then @@ -5683,116 +5682,117 @@ endif /bin/cp $EXPID.ana_radstat_rst.$rtag.tar $RSTHOLD/ & endif - # hold lfo files for the next segment of ldas coupling - #---------------------------------------------------------- - if ( $LDAS_ANA ) then - mkdir -p $FVHOME/recycle/holdforc - /bin/cp *2d_lfo*nc4 $FVHOME/recycle/holdforc/. - endif - - # local copy to be moved by pesto, 2nd copy to be dealt w/ by recycle - #-------------------------------------------------------------------- - if ( -e biasinp.$RSTSUFFIX ) then - /bin/mv biasinp.$RSTSUFFIX $EXPID.biasinp.$rtag.$RSTSUFFIX - /bin/cp $EXPID.biasinp.$rtag.$RSTSUFFIX $EXPID.biasinp_rst.$rtag.$RSTSUFFIX - /bin/cp $EXPID.biasinp_rst.$rtag.$RSTSUFFIX $RSTHOLD/ & - endif - - # local copy to be moved by pesto, 2nd copy to be dealt w/ by recycle - #-------------------------------------------------------------------- - if ( -e biasinp.ctl ) then - /bin/mv biasinp.ctl $EXPID.biasinp.$rtag.ctl - /bin/cp $EXPID.biasinp.$rtag.ctl $EXPID.biasinp_rst.$rtag.ctl - /bin/cp $EXPID.biasinp_rst.$rtag.ctl $RSTHOLD/ & - endif + # hold lfo files for the next segment of ldas coupling + #---------------------------------------------------------- + if ( $LDAS_ANA ) then + mkdir -p $FVHOME/recycle/holdforc + /bin/cp *2d_lfo*nc4 $FVHOME/recycle/holdforc/ + endif - # local copy to be moved by pesto, 2nd copy to be dealt w/ by recycle - #-------------------------------------------------------------------- - if ( $DO4DVAR ) then # initial traj needed for 4dvar - if ( -e $EXPID.traj_lcv_rst.$rtag4.$NCSUFFIX ) then - /bin/cp $EXPID.traj_lcv_rst.$rtag4.$NCSUFFIX $RSTHOLD/$EXPID.traj_lcv_rst.$rtag4.$NCSUFFIX & - else - if ( -e $EXPID.traj.lcv.$rtag4.$NCSUFFIX ) then - /bin/cp $EXPID.traj.lcv.$rtag4.$NCSUFFIX $EXPID.traj_lcv_rst.$rtag4.$NCSUFFIX & - /bin/cp $EXPID.traj.lcv.$rtag4.$NCSUFFIX $RSTHOLD/$EXPID.traj_lcv_rst.$rtag4.$NCSUFFIX & - endif - endif -# if ( -e $EXPID.ptrj.prs.$rtag4.$NCSUFFIX ) then -# /bin/cp $EXPID.ptrj.prs.$rtag4.$NCSUFFIX $EXPID.ptrj_prs_rst.$rtag4.$NCSUFFIX & -# /bin/cp $EXPID.ptrj.prs.$rtag4.$NCSUFFIX $RSTHOLD/$EXPID.ptrj_prs_rst.$rtag4.$NCSUFFIX & -# endif - endif + # local copy to be moved by pesto, 2nd copy to be dealt w/ by recycle + #-------------------------------------------------------------------- + if ( -e biasinp.$RSTSUFFIX ) then + /bin/mv biasinp.$RSTSUFFIX $EXPID.biasinp.$rtag.$RSTSUFFIX + /bin/cp $EXPID.biasinp.$rtag.$RSTSUFFIX $EXPID.biasinp_rst.$rtag.$RSTSUFFIX + /bin/cp $EXPID.biasinp_rst.$rtag.$RSTSUFFIX $RSTHOLD/ & + endif + # local copy to be moved by pesto, 2nd copy to be dealt w/ by recycle + #-------------------------------------------------------------------- + if ( -e biasinp.ctl ) then + /bin/mv biasinp.ctl $EXPID.biasinp.$rtag.ctl + /bin/cp $EXPID.biasinp.$rtag.ctl $EXPID.biasinp_rst.$rtag.ctl + /bin/cp $EXPID.biasinp_rst.$rtag.ctl $RSTHOLD/ & + endif + + # local copy to be moved by pesto, 2nd copy to be dealt w/ by recycle + #-------------------------------------------------------------------- + if ( $DO4DVAR ) then # initial traj needed for 4dvar + if ( -e $EXPID.traj_lcv_rst.$rtag4.$NCSUFFIX ) then + /bin/cp $EXPID.traj_lcv_rst.$rtag4.$NCSUFFIX $RSTHOLD/$EXPID.traj_lcv_rst.$rtag4.$NCSUFFIX & + else + if ( -e $EXPID.traj.lcv.$rtag4.$NCSUFFIX ) then + /bin/cp $EXPID.traj.lcv.$rtag4.$NCSUFFIX $EXPID.traj_lcv_rst.$rtag4.$NCSUFFIX & + /bin/cp $EXPID.traj.lcv.$rtag4.$NCSUFFIX $RSTHOLD/$EXPID.traj_lcv_rst.$rtag4.$NCSUFFIX & + endif + endif +# if ( -e $EXPID.ptrj.prs.$rtag4.$NCSUFFIX ) then +# /bin/cp $EXPID.ptrj.prs.$rtag4.$NCSUFFIX $EXPID.ptrj_prs_rst.$rtag4.$NCSUFFIX & +# /bin/cp $EXPID.ptrj.prs.$rtag4.$NCSUFFIX $RSTHOLD/$EXPID.ptrj_prs_rst.$rtag4.$NCSUFFIX & +# endif + endif - set GDA_list = `ls *GDA.all.*` - if ( ! $status ) then - set GDA_rst = `echo $GDA_list[$#GDA_list] | sed -e 's/\.all\./.rst./'` - /bin/cp $GDA_list[$#GDA_list] ./${GDA_rst} - if ( $?trksufx ) then - set tstsufx = `echo $GDA_rst | cut -d. -f5,6` - if ( "$tstsufx" == "$trksufx" ) /bin/rm -f $GDA_rst - endif - if ( -e $GDA_rst ) /bin/cp $GDA_rst $RSTHOLD/${GDA_rst} - endif - if ( $DO4DVAR ) then + set GDA_list = `ls *GDA.all.*` + if ( ! $status ) then + set GDA_rst = `echo $GDA_list[$#GDA_list] | sed -e 's/\.all\./.rst./'` + /bin/cp $GDA_list[$#GDA_list] ./${GDA_rst} + if ( $?trksufx ) then + set tstsufx = `echo $GDA_rst | cut -d. -f5,6` + if ( "$tstsufx" == "$trksufx" ) /bin/rm -f $GDA_rst + endif + if ( -e $GDA_rst ) /bin/cp $GDA_rst $RSTHOLD/${GDA_rst} + endif - # local copy to be moved by pesto, 2nd copy to be dealt w/ by recycle - #-------------------------------------------------------------------- - /bin/cp $EXPID.bkg.eta.$rtag.$NCSUFFIX $EXPID.bkg_eta_rst.$rtag.$NCSUFFIX & - /bin/cp $EXPID.bkg.eta.$rtag.$NCSUFFIX $RSTHOLD/$EXPID.bkg_eta_rst.$rtag.$NCSUFFIX & + if ( $DO4DVAR ) then + + # local copy to be moved by pesto, 2nd copy to be dealt w/ by recycle + #-------------------------------------------------------------------- + /bin/cp $EXPID.bkg.eta.$rtag.$NCSUFFIX $EXPID.bkg_eta_rst.$rtag.$NCSUFFIX & + /bin/cp $EXPID.bkg.eta.$rtag.$NCSUFFIX $RSTHOLD/$EXPID.bkg_eta_rst.$rtag.$NCSUFFIX & + + /bin/cp $EXPID.cbkg.eta.$rtag.$NCSUFFIX $EXPID.cbkg_eta_rst.$rtag.$NCSUFFIX & + /bin/cp $EXPID.cbkg.eta.$rtag.$NCSUFFIX $RSTHOLD/$EXPID.cbkg_eta_rst.$rtag.$NCSUFFIX & - /bin/cp $EXPID.cbkg.eta.$rtag.$NCSUFFIX $EXPID.cbkg_eta_rst.$rtag.$NCSUFFIX & - /bin/cp $EXPID.cbkg.eta.$rtag.$NCSUFFIX $RSTHOLD/$EXPID.cbkg_eta_rst.$rtag.$NCSUFFIX & + /bin/cp $EXPID.abkg.eta.$rtag.$NCSUFFIX $EXPID.abkg_eta_rst.$rtag.$NCSUFFIX & + /bin/cp $EXPID.abkg.eta.$rtag.$NCSUFFIX $RSTHOLD/$EXPID.abkg_eta_rst.$rtag.$NCSUFFIX & - /bin/cp $EXPID.abkg.eta.$rtag.$NCSUFFIX $EXPID.abkg_eta_rst.$rtag.$NCSUFFIX & - /bin/cp $EXPID.abkg.eta.$rtag.$NCSUFFIX $RSTHOLD/$EXPID.abkg_eta_rst.$rtag.$NCSUFFIX & + /bin/cp $EXPID.bkg.sfc.$rtag.$NCSUFFIX $EXPID.bkg_sfc_rst.$rtag.$NCSUFFIX & + /bin/cp $EXPID.bkg.sfc.$rtag.$NCSUFFIX $RSTHOLD/$EXPID.bkg_sfc_rst.$rtag.$NCSUFFIX & - /bin/cp $EXPID.bkg.sfc.$rtag.$NCSUFFIX $EXPID.bkg_sfc_rst.$rtag.$NCSUFFIX & - /bin/cp $EXPID.bkg.sfc.$rtag.$NCSUFFIX $RSTHOLD/$EXPID.bkg_sfc_rst.$rtag.$NCSUFFIX & + else - else + # local copy to be moved by pesto, 2nd copy to be dealt w/ by recycle + #-------------------------------------------------------------------- + @ n = 1 + while ( $n <= $nbkg ) - # local copy to be moved by pesto, 2nd copy to be dealt w/ by recycle - #-------------------------------------------------------------------- - @ n = 1 - while ( $n <= $nbkg ) + if ( -e $bkgsfc_lst[$n] ) then + /bin/cp $bkgsfc_lst[$n] $bkgsfcrst_lst[$n] & + /bin/cp $bkgsfc_lst[$n] $RSTHOLD/$bkgsfcrst_lst[$n] & + else + /bin/cp $sfcbkg_lst[$n] $bkgsfcrst_lst[$n] & + /bin/cp $sfcbkg_lst[$n] $RSTHOLD/$bkgsfcrst_lst[$n] & + endif - if ( -e $bkgsfc_lst[$n] ) then - /bin/cp $bkgsfc_lst[$n] $bkgsfcrst_lst[$n] & - /bin/cp $bkgsfc_lst[$n] $RSTHOLD/$bkgsfcrst_lst[$n] & - else - /bin/cp $sfcbkg_lst[$n] $bkgsfcrst_lst[$n] & - /bin/cp $sfcbkg_lst[$n] $RSTHOLD/$bkgsfcrst_lst[$n] & - endif + if ( -e $bkgupa_lst[$n] ) then + /bin/cp $bkgupa_lst[$n] $bkguparst_lst[$n] & + /bin/cp $bkgupa_lst[$n] $RSTHOLD/$bkguparst_lst[$n] & + else + /bin/cp $upabkg_lst[$n] $bkguparst_lst[$n] & + /bin/cp $upabkg_lst[$n] $RSTHOLD/$bkguparst_lst[$n] & + endif - if ( -e $bkgupa_lst[$n] ) then - /bin/cp $bkgupa_lst[$n] $bkguparst_lst[$n] & - /bin/cp $bkgupa_lst[$n] $RSTHOLD/$bkguparst_lst[$n] & - else - /bin/cp $upabkg_lst[$n] $bkguparst_lst[$n] & - /bin/cp $upabkg_lst[$n] $RSTHOLD/$bkguparst_lst[$n] & - endif + if ( -e $cbkgetarst_lst[$n] ) then + /bin/cp $cbkgetarst_lst[$n] $cbkgetarst_lst[$n] & + /bin/cp $cbkgetarst_lst[$n] $RSTHOLD/$cbkgetarst_lst[$n] & + else + /bin/cp $cbkg_lst[$n] $cbkgetarst_lst[$n] & + /bin/cp $cbkg_lst[$n] $RSTHOLD/$cbkgetarst_lst[$n] & + endif - if ( -e $cbkgetarst_lst[$n] ) then - /bin/cp $cbkgetarst_lst[$n] $cbkgetarst_lst[$n] & - /bin/cp $cbkgetarst_lst[$n] $RSTHOLD/$cbkgetarst_lst[$n] & - else - /bin/cp $cbkg_lst[$n] $cbkgetarst_lst[$n] & - /bin/cp $cbkg_lst[$n] $RSTHOLD/$cbkgetarst_lst[$n] & - endif + if ( -e $abkgetarst_lst[$n] ) then + /bin/cp $abkgetarst_lst[$n] $abkgetarst_lst[$n] & + /bin/cp $abkgetarst_lst[$n] $RSTHOLD/$abkgetarst_lst[$n] & + else + /bin/cp $abkg_lst[$n] $abkgetarst_lst[$n] & + /bin/cp $abkg_lst[$n] $RSTHOLD/$abkgetarst_lst[$n] & + endif + @ n++ + end + wait - if ( -e $abkgetarst_lst[$n] ) then - /bin/cp $abkgetarst_lst[$n] $abkgetarst_lst[$n] & - /bin/cp $abkgetarst_lst[$n] $RSTHOLD/$abkgetarst_lst[$n] & - else - /bin/cp $abkg_lst[$n] $abkgetarst_lst[$n] & - /bin/cp $abkg_lst[$n] $RSTHOLD/$abkgetarst_lst[$n] & - endif - @ n++ - end - wait - endif # < DO4DVAR > + endif # < DO4DVAR > endif # < DOING_ANA > diff --git a/src/Applications/GEOSdas_App/fvpsas b/src/Applications/GEOSdas_App/fvpsas index 71037988..94037ffd 100755 --- a/src/Applications/GEOSdas_App/fvpsas +++ b/src/Applications/GEOSdas_App/fvpsas @@ -418,24 +418,20 @@ endif -#-------------------------------------- + # Run Land analysis # ----------------- - if ( $LDAS_ANA ) then - echo " LDAS coupling: fvpsas LDAS_ANA run lenkf " zeit_ci.x ldasRun - ldas_run.csh 0 060000 |& tee -a ldasrun.log - if( $status) then - echo "ldasRun failed" - exit(1) - endif + echo " LDAS coupling: fvpsas LDAS_ANA run lenkf " + ldas_run.csh 0 060000 |& tee -a ldasrun.log + if( $status) then + echo "ldasRun failed" + exit(1) + endif zeit_co.x ldasRun endif -##--------------------------------- - - # Run the analysis if not doing replay # ----------------------------------- if ( ! -e replay.acq ) then @@ -494,21 +490,18 @@ endif endif -#------------------------------------------------ -# check ldas job status and stage ldas increments -#-------------------------------------------------- - if ( ( $LDAS_ANA ) && ( $LDASFDBK ) ) then - echo " LDAS coupling: stage 1" - zeit_ci.x ldasStage - ldas_run.csh 1 060000 |& tee -a ldasrun.log - if( $status) then - echo "ldas_run stage 1 failed" - exit(1) - endif - zeit_co.x ldasStage - endif - -#----------------------- + # Check ldas job status and stage ldas increments + # ----------------------------------------------- + if ( ( $LDAS_ANA ) && ( $LDASFDBK ) ) then + zeit_ci.x ldasStage + echo " LDAS coupling: stage 1" + ldas_run.csh 1 060000 |& tee -a ldasrun.log + if( $status) then + echo "ldas_run stage 1 failed" + exit(1) + endif + zeit_co.x ldasStage + endif # Convert analysis eta file into GCM restart # ------------------------------------------ diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index ea2870d1..5e812017 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -509,7 +509,7 @@ $ENV{"PATH"} = $FindBin::Bin .":$ENV{PATH}"; while3 ( \&set_rcov ); while3 ( \&set_acftbias ); while3 ( \&set_newradbc ); - while3 ( \&set_ldasANA ); + while3 ( \&set_ldasANA ); while3 ( \&get_forecast ); if ($DAO == 0) { while3 ( \&get_mhost ) } while3 ( \&get_output ); @@ -520,7 +520,7 @@ $ENV{"PATH"} = $FindBin::Bin .":$ENV{PATH}"; # Create subdirectories in FVHOME # ------------------------------- - mkdir_fvhome(); + mkdir_fvhome(); # Create Namelists/tables for main DAS run # ---------------------------------------- @@ -3373,35 +3373,34 @@ sub set_ldasANA { $ldasfdbk = 0; $ldas_flag = 0; $dflt = "n"; + $ldashome = "NULL" ; + $ldashome4ens = "NULL" ; - print "\n-------------\n"; - print "LDAS Analysis\n"; - print "-------------\n\n"; + print "\n-------------\n"; + print "LDAS Analysis\n"; + print "-------------\n\n"; - $ans1 = query(" Land DAS Analysis (y/n)?", $dflt) ; - $ldas_ana = 1 if yes($ans1); - print " ldas_ana ($ldas_ana)\n " ; + $ans1 = query(" Land DAS Analysis (y/n)?", $dflt) ; + $ldas_ana = 1 if yes($ans1); - if ($ldas_ana == 1) { - $ans2 = query(" Enable LDAS feedback to model y/n ? ", $dflt); - $ldasfdbk = 1 if yes($ans2); - print " ldasfdbk ($ldasfdbk)\n" ; + if ($ldas_ana == 1) { + $ans2 = query(" Enable LDAS feedback to model y/n ? ", $dflt); + $ldasfdbk = 1 if yes($ans2); - if ($ldasfdbk ==1 ) { - $ldas_flag = 1 - } + if ($ldasfdbk ==1 ) { + $ldas_flag = 1; + } - $ans3 = query("LDAS HOME = /discover/nobackup/$user/$ldasexp, full path? "); - $ldashome = $ans3 ; + $ans3 = query("LDAS HOME = $fvhome, full path? "); + $ldashome = $ans3 ; - $ans4 = query("LDAS HOME for atm_ens = /discover/nobackup/$user/$ldasexp4ens, full path? "); - $ldashome4ens = $ans4 ; + $ans4 = query("LDAS HOME for land ensemble = $fvhome/run/atmens, full path? "); + $ldashome4ens = $ans4 ; - } - return 0; + } +return 0; } - #======================================================================= sub get_setgsi { @@ -3617,7 +3616,7 @@ EOF $replace{">>>JOBNJ<<<"} = "$jobn.j"; $replace{">>>FVHOME<<<"} = "$fvhome"; $replace{">>>LDAS_ANA<<<"} = $ldas_ana; - $replace{">>>LDHOME4ens<<<"} = "$ldashome4ens"; + $replace{">>>LDHOME4ENS<<<"} = "$ldashome4ens"; $atm_ens_j = "$fvhome/run/atm_ens.j"; $atm_ens_j_tilde = "${atm_ens_j}~"; @@ -4318,7 +4317,7 @@ sub get_history { #----------------------------------------------------------- if ( $ldas_ana == 1 ) { $verify = 0; - @ldasinputs = qw / tavg1_2d_lfo inst1_2d_lfo /; + @ldasinputs = qw / tavg1_2d_lfo inst1_2d_lfo /; foreach $prod ( @ldasinputs ) { open HIST, "< $fvroot/etc/$g5hist_rc"; unless ( grep /$prod/, ) { @@ -7699,7 +7698,7 @@ print SCRIPT <<"EOF"; setenv LDAS_ANA $ldas_ana # 1 = land analysis, 0 = disables it setenv LDASFDBK $ldasfdbk # 1 = read land analysis incr into GCM (feedback), 0 = don't setenv LDHOME $ldashome # land analysis home dir (ldas_exp/) for central - setenv LDHOME4ens $ldashome4ens # land analysis home dir for atm_ens + setenv LDHOME4ENS $ldashome4ens # land analysis home dir for atm_ens setenv IGNORE_0 1 # 1 = ignore 0 length obs files in acquire setenv ACFTBIAS $acftbias setenv USE_MODIS_STAGE 0 # 1 = use MODIS data from MODIS_STAGE_DIR; 0 = don't @@ -9828,6 +9827,7 @@ sub copy_resources { ed_g5cap_rc("fcst","CAP_15.rc.tmpl",$fhours15); } else { ed_g5cap_rc("fcst","CAP.rc.tmpl",$fhours21); + ed_g5cap_rc("fcst","CAP_21.rc.tmpl",$fhours21); } ed_g5cap_apert_rc("fcst"); ed_g5prog_rc_new("fcst","GCMPROG.rc.tmpl"); diff --git a/src/Applications/GEOSdas_App/ldas_run.csh b/src/Applications/GEOSdas_App/ldas_run.csh index a5a923fe..652be5e6 100755 --- a/src/Applications/GEOSdas_App/ldas_run.csh +++ b/src/Applications/GEOSdas_App/ldas_run.csh @@ -18,7 +18,7 @@ if ( $#argv < 2 ) then echo " " echo " where" echo " stage - run step 0 or stage step 1" - echo " freqa - frequency of adas increments, as in HHMMSS" + echo " freqa - frequency of adas increments, as in HHMMSS" echo " " echo " DESCRIPTION" echo " " @@ -56,10 +56,10 @@ set stage = $1 set freqa = $2 - cd $FVWORK - set adas_strt = ( `rst_date ./d_rst` ) -set nymd = `echo $adas_strt[1] | cut -c1-8` -set hh = `echo $adas_strt[2] | cut -c1-2` +cd $FVWORK +set adas_strt = ( `rst_date ./d_rst` ) +set nymd = `echo $adas_strt[1] | cut -c1-8` +set hh = `echo $adas_strt[2] | cut -c1-2` set yyyymmddhh = ${nymd}${hh} if (-e $FVWORK/.DONE_${MYNAME}.${yyyymmddhh} ) then @@ -67,29 +67,29 @@ if (-e $FVWORK/.DONE_${MYNAME}.${yyyymmddhh} ) then exit(0) endif - @ adas_int = $freqa / 10000 - @ adas_int = $adas_int * 3600 +@ adas_int = $freqa / 10000 +@ adas_int = $adas_int * 3600 if ( $stage == 0 ) then echo " ${MYNAME}: stage 0" # lfo forcing - @ cent_int = 3600 - @ tavg1_tick0 = -1800 - @ inst1_tick0 = 0 + @ cent_int = 3600 + @ tavg1_tick0 = -1800 + @ inst1_tick0 = 0 - set inst1_strt = ( `tick $adas_strt $inst1_tick0` ) - set tavg1_strt = ( `tick $adas_strt $tavg1_tick0` ) + set inst1_strt = ( `tick $adas_strt $inst1_tick0` ) + set tavg1_strt = ( `tick $adas_strt $tavg1_tick0` ) - set secs = 0 + set secs = 0 - while ( $secs < = $adas_int ) - set inst1_now = ( `tick $inst1_strt $secs` ) - set tavg1_now = ( `tick $tavg1_strt $secs` ) + while ( $secs < = $adas_int ) + set inst1_now = ( `tick $inst1_strt $secs` ) + set tavg1_now = ( `tick $tavg1_strt $secs` ) - set tttt_i=`echo $inst1_now[2] | cut -c1-4` - set tttt_a=`echo $tavg1_now[2] | cut -c1-4` + set tttt_i=`echo $inst1_now[2] | cut -c1-4` + set tttt_a=`echo $tavg1_now[2] | cut -c1-4` /bin/cp ${FVHOME}/recycle/holdforc/*.inst1_2d_lfo_Nx+-.$inst1_now[1]_${tttt_i}z.nc4\ ${FVWORK} @@ -98,109 +98,109 @@ if ( $stage == 0 ) then @ secs = $secs + $cent_int end - /bin/rm -f ${FVHOME}/recycle/holdforc/* + /bin/rm -f ${FVHOME}/recycle/holdforc/* #link $FVWORK for ldas met_forcing access - /bin/rm -f $FVHOME/lana/forc - /bin/ln -s $FVWORK $FVHOME/lana/forc - - echo " ${MYNAME}: LDAS coupling: run ldas for central DAS coupling" - # go to LDHOME to submit ldas run - cd $LDHOME/run - echo "ldas_home_dir: ", $LDHOME - set lcapdat = `cat cap_restart | cut -c1-8` - set lcaptim = `cat cap_restart | cut -c10-15` - echo "ldas_6h_window starting at: ", $lcapdat, $lcaptim - echo "adas_anal_window starting at: ", $adas_strt[1], $adas_strt[2] - - # submit job and capture job ID - set jobldas = "$LDHOME/run/lenkf.j" - set jobIDlong = `$PBS_BIN/sbatch $jobldas` - set jobID = `echo $jobIDlong |awk -F'[ ]' '{print $4}'` - setenv ldasJobIDs $jobID - echo $ldasJobIDs ": LDAS coupling lenkf jobID for central das " + /bin/rm -f $FVHOME/lana/forc + /bin/ln -s $FVWORK $FVHOME/lana/forc + + echo " ${MYNAME}: LDAS coupling: run ldas for central DAS coupling" + # go to LDHOME to submit ldas run + cd $LDHOME/run + echo "ldas_home_dir: ", $LDHOME + set lcapdat = `cat cap_restart | cut -c1-8` + set lcaptim = `cat cap_restart | cut -c10-15` + echo "ldas_6h_window starting at: ", $lcapdat, $lcaptim + echo "adas_anal_window starting at: ", $adas_strt[1], $adas_strt[2] + + # submit job and capture job ID + set jobldas = "$LDHOME/run/lenkf.j" + set jobIDlong = `$PBS_BIN/sbatch $jobldas` + set jobID = `echo $jobIDlong |awk -F'[ ]' '{print $4}'` + setenv ldasJobIDs $jobID + echo $ldasJobIDs ": LDAS coupling lenkf jobID for central das " ## back to fvwork - cd $FVWORK + cd $FVWORK ##stage incr - else - cd $FVWORK - echo " ${MYNAME}: LDAS coupling: stage/link LdasIncr for AGCM corrector " - if ($?ldasJobIDs) then - $FVROOT/bin/jobIDfilter -w $ldasJobIDs - unsetenv ldasJobIDs - endif - - set lenkf_status_file = ${FVWORK}/lenkf_job_completed.txt - rm -f $lenkf_status_file - - cp $LDHOME/run/lenkf_job_completed.txt $lenkf_status_file - - set lenkf_status = `cat $lenkf_status_file` - echo $lenkf_status - echo $lenkf_status ": lenkf_status" - if ($lenkf_status =~ SUCCEEDED ) then - echo "LDAS coupling Lenkf job SUCCEEDED, stageLdasIncr" - endif +else + cd $FVWORK + echo " ${MYNAME}: LDAS coupling: stage/link LdasIncr for AGCM corrector " + if ($?ldasJobIDs) then + $FVROOT/bin/jobIDfilter -w $ldasJobIDs + unsetenv ldasJobIDs + endif + + set lenkf_status_file = ${FVWORK}/lenkf_job_completed.txt + rm -f $lenkf_status_file + + /bin/cp $LDHOME/run/lenkf_job_completed.txt $lenkf_status_file + + set lenkf_status = `cat $lenkf_status_file` + echo $lenkf_status + echo $lenkf_status ": lenkf_status" + if ($lenkf_status =~ SUCCEEDED ) then + echo "LDAS coupling Lenkf job SUCCEEDED, stageLdasIncr" + endif # current all member incr outputs in cat/ens_avg - set LINC_DIR = ${LDHOME}/output/*/cat/ens_avg/ + set LINC_DIR = ${LDHOME}/output/*/cat/ens_avg/ # LANDASSIM_DT in sec (10800 ) - set ldas_int = 10800 - set ldasDT = `grep LANDASSIM_DT: ${LDHOME}/run/LDAS.rc | cut -d':' -f2` - if ( ${ldasDT} > 0 ) then + set ldas_int = 10800 + set ldasDT = `grep LANDASSIM_DT: ${LDHOME}/run/LDAS.rc | cut -d':' -f2` + if ( ${ldasDT} > 0 ) then set ldas_int = ${ldasDT} - endif + endif # LANDASSIM_T0 in hhmmss (centered update for ladas ) - set ldas_t0 = 013000 - set ldasT0 = `grep LANDASSIM_T0: ${LDHOME}/run/LDAS.rc | cut -d':' -f2` - if ( ${ldasT0} > 0 ) then + set ldas_t0 = 013000 + set ldasT0 = `grep LANDASSIM_T0: ${LDHOME}/run/LDAS.rc | cut -d':' -f2` + if ( ${ldasT0} > 0 ) then set ldas_t0 = ${ldasT0} - endif - set t0hh = `echo ${ldas_t0} | cut -c1-2` - set t0mm = `echo ${ldas_t0} | cut -c3-4` - @ cent_int = $t0hh * 3600 + $t0mm * 60 + endif + set t0hh = `echo ${ldas_t0} | cut -c1-2` + set t0mm = `echo ${ldas_t0} | cut -c3-4` + @ cent_int = $t0hh * 3600 + $t0mm * 60 - set lincr_native_name = catch_progn_incr - set lincr_default_name = ldas_inc + set lincr_native_name = catch_progn_incr + set lincr_default_name = ldas_inc - set secs = 0 + set secs = 0 - while ( $secs < $adas_int ) - # the begining time of the window secs=0 - set ldas_strt = ( `tick $adas_strt $secs` ) - # for ldas_incr, use LANDASSIM_T0 - set ldas_anlt = ( `tick $ldas_strt $cent_int` ) + while ( $secs < $adas_int ) + # the begining time of the window secs=0 + set ldas_strt = ( `tick $adas_strt $secs` ) + # for ldas_incr, use LANDASSIM_T0 + set ldas_anlt = ( `tick $ldas_strt $cent_int` ) - set yyyy_a=`echo $ldas_anlt[1] | cut -c1-4` - set mm_a=`echo $ldas_anlt[1] | cut -c5-6` - set dd_a=`echo $ldas_anlt[1] | cut -c7-8` - set tttt_a=`echo $ldas_anlt[2] | cut -c1-4` + set yyyy_a=`echo $ldas_anlt[1] | cut -c1-4` + set mm_a=`echo $ldas_anlt[1] | cut -c5-6` + set dd_a=`echo $ldas_anlt[1] | cut -c7-8` + set tttt_a=`echo $ldas_anlt[2] | cut -c1-4` # default name for AGCM: ldas_inc.yyyymmdd_hhnn00 - if ( -e ${LINC_DIR}/Y${yyyy_a}/M${mm_a}/*${lincr_native_name}.$ldas_anlt[1]_${tttt_a}z.nc4) then - - /bin/cp ${LINC_DIR}/Y${yyyy_a}/M${mm_a}/*.${lincr_native_name}.$ldas_anlt[1]_${tttt_a}z.nc4\ - ${FVWORK}/ldas_inc.$ldas_anlt[1]_${tttt_a}00 - - /bin/ln -s ${LINC_DIR}/Y${yyyy_a}/M${mm_a}/*${lincr_native_name}.$ldas_anlt[1]_${tttt_a}z.nc4\ - ${FVHOME}/lana/ldas_inc.$ldas_anlt[1]_${tttt_a}00 - else - echo " ${MYNAME}: WARNING: ldas incr file not found, no ldasIncr for this cycle" - exit 1 - endif - @ secs = $secs + $ldas_int + if ( -e ${LINC_DIR}/Y${yyyy_a}/M${mm_a}/*${lincr_native_name}.$ldas_anlt[1]_${tttt_a}z.nc4) then + + /bin/cp ${LINC_DIR}/Y${yyyy_a}/M${mm_a}/*.${lincr_native_name}.$ldas_anlt[1]_${tttt_a}z.nc4\ + ${FVWORK}/ldas_inc.$ldas_anlt[1]_${tttt_a}00 + + /bin/ln -s ${LINC_DIR}/Y${yyyy_a}/M${mm_a}/*${lincr_native_name}.$ldas_anlt[1]_${tttt_a}z.nc4\ + ${FVHOME}/lana/ldas_inc.$ldas_anlt[1]_${tttt_a}00 + else + echo " ${MYNAME}: WARNING: ldas incr file not found, no ldasIncr for this cycle" + exit 1 + endif + @ secs = $secs + $ldas_int end # normal return touch $FVWORK/.DONE_${MYNAME}.${yyyymmddhh} echo " ${MYNAME}: Complete " - exit 0 +exit 0 - endif #end stage=1 +endif #end stage=1 - cd ${FVWORK} +cd ${FVWORK} diff --git a/src/Applications/GEOSdas_App/testsuites/C360L181_replay.input b/src/Applications/GEOSdas_App/testsuites/C360L181_replay.input index 7f43dccc..6dc0aa52 100644 --- a/src/Applications/GEOSdas_App/testsuites/C360L181_replay.input +++ b/src/Applications/GEOSdas_App/testsuites/C360L181_replay.input @@ -2,8 +2,8 @@ # C360L181_replay.input #------------ -description: C360L181_replay__GEOSadas-5_29_0__agrid_C360__ogrid_C -tag: GEOSadas-5_29_0 +description: C360L181_replay__GEOSadas-5_29_3__agrid_C360__ogrid_C +tag: GEOSadas-5_29_3 ---ENDHEADERS--- @@ -28,7 +28,7 @@ EXPID? [u000_C360] Check for previous use of expid (y/n)? [y] > n -EXPDSC? [C360L181_replay__GEOSadas-5_29_0__agrid_C360__ogrid_C] +EXPDSC? [C360L181_replay__GEOSadas-5_29_3__agrid_C360__ogrid_C] > Land Boundary Conditions? [Icarus_Updated] @@ -160,6 +160,9 @@ Use aircraft bias correction (y/n)? [y] Use unified radiance bias correction (y/n)? [y] > +Land DAS Analysis (y/n)? [n] +> + Frequency (in days) for writing restarts? [0] > diff --git a/src/Applications/GEOSdas_App/testsuites/C360L91_replay.input b/src/Applications/GEOSdas_App/testsuites/C360L91_replay.input index 51f65a97..4521fe6a 100644 --- a/src/Applications/GEOSdas_App/testsuites/C360L91_replay.input +++ b/src/Applications/GEOSdas_App/testsuites/C360L91_replay.input @@ -2,8 +2,8 @@ # C360L91_replay.input #------------ -description: C360L91_replay__GEOSadas-5_29_0__agrid_C360__ogrid_C -tag: GEOSadas-5_29_0 +description: C360L91_replay__GEOSadas-5_29_3__agrid_C360__ogrid_C +tag: GEOSadas-5_29_3 ---ENDHEADERS--- @@ -28,7 +28,7 @@ EXPID? [u000_C360] Check for previous use of expid (y/n)? [y] > n -EXPDSC? [C360L91_replay__GEOSadas-5_29_0__agrid_C360__ogrid_C] +EXPDSC? [C360L91_replay__GEOSadas-5_29_3__agrid_C360__ogrid_C] > Land Boundary Conditions? [Icarus_Updated] @@ -160,6 +160,9 @@ Use aircraft bias correction (y/n)? [y] Use unified radiance bias correction (y/n)? [y] > +Land DAS Analysis (y/n)? [n] +> + Frequency (in days) for writing restarts? [0] > diff --git a/src/Applications/GEOSdas_App/testsuites/C48f.input b/src/Applications/GEOSdas_App/testsuites/C48f.input index fbc4a60a..9e779b2c 100644 --- a/src/Applications/GEOSdas_App/testsuites/C48f.input +++ b/src/Applications/GEOSdas_App/testsuites/C48f.input @@ -2,8 +2,8 @@ # C48f.input #----------- -description: C48f__GEOSadas-5_29_0__agrid_C48__ogrid_f34 -tag: GEOSadas-5_29_0 +description: C48f__GEOSadas-5_29_3__agrid_C48__ogrid_f34 +tag: GEOSadas-5_29_3 fvsetupflags: -sensdeg 1 ---ENDHEADERS--- @@ -29,7 +29,7 @@ EXPID? [u000_C48] Check for previous use of expid (y/n)? [y] > n -EXPDSC? [C48f__GEOSadas-5_29_0__agrid_C48__ogrid_f34] +EXPDSC? [C48f__GEOSadas-5_29_3__agrid_C48__ogrid_f34] > Land Boundary Conditions? [Icarus_Updated] @@ -167,6 +167,9 @@ Use aircraft bias correction (y/n)? [y] Use unified radiance bias correction (y/n)? [y] > +Land DAS Analysis (y/n)? [n] +> + Frequency (in days) for writing restarts? [0] > diff --git a/src/Applications/GEOSdas_App/testsuites/C90C.input b/src/Applications/GEOSdas_App/testsuites/C90C.input index 91fa7f99..8e3fe67d 100644 --- a/src/Applications/GEOSdas_App/testsuites/C90C.input +++ b/src/Applications/GEOSdas_App/testsuites/C90C.input @@ -2,8 +2,8 @@ # C90C.input #----------- -description: C90C__GEOSadas-5_29_0__agrid_C90__ogrid_CS -tag: GEOSadas-5_29_0 +description: C90C__GEOSadas-5_29_3__agrid_C90__ogrid_CS +tag: GEOSadas-5_29_3 ---ENDHEADERS--- @@ -28,7 +28,7 @@ EXPID? [u000_C90] Check for previous use of expid (y/n)? [y] > n -EXPDSC? [C90C__GEOSadas-5_29_0__agrid_C90__ogrid_CS] +EXPDSC? [C90C__GEOSadas-5_29_3__agrid_C90__ogrid_CS] > Land Boundary Conditions? [Icarus_Updated] @@ -145,6 +145,9 @@ Use aircraft bias correction (y/n)? [y] Use unified radiance bias correction (y/n)? [y] > +Land DAS Analysis (y/n)? [n] +> + Frequency (in days) for writing restarts? [0] > diff --git a/src/Applications/GEOSdas_App/testsuites/C90C_ens.input b/src/Applications/GEOSdas_App/testsuites/C90C_ens.input index 13fab6ab..536f0cd1 100644 --- a/src/Applications/GEOSdas_App/testsuites/C90C_ens.input +++ b/src/Applications/GEOSdas_App/testsuites/C90C_ens.input @@ -2,8 +2,8 @@ # C90C_ens.input #--------------- -description: C90C_ens__GEOSadas-5_29_0__agrid_C90__ogrid_C -tag: GEOSadas-5_29_0 +description: C90C_ens__GEOSadas-5_29_3__agrid_C90__ogrid_C +tag: GEOSadas-5_29_3 ---ENDHEADERS--- @@ -28,7 +28,7 @@ EXPID? [u000_C90] Check for previous use of expid (y/n)? [y] > n -EXPDSC? [C90C_ens__GEOSadas-5_29_0__agrid_C90__ogrid_C] +EXPDSC? [C90C_ens__GEOSadas-5_29_3__agrid_C90__ogrid_C] > Land Boundary Conditions? [Icarus_Updated] @@ -160,6 +160,9 @@ Use aircraft bias correction (y/n)? [y] Use unified radiance bias correction (y/n)? [y] > +Land DAS Analysis (y/n)? [n] +> + Frequency (in days) for writing restarts? [0] > diff --git a/src/Applications/GEOSdas_App/testsuites/C90C_replay.input b/src/Applications/GEOSdas_App/testsuites/C90C_replay.input index 2fe0444c..a95b339d 100644 --- a/src/Applications/GEOSdas_App/testsuites/C90C_replay.input +++ b/src/Applications/GEOSdas_App/testsuites/C90C_replay.input @@ -160,6 +160,9 @@ Use aircraft bias correction (y/n)? [y] Use unified radiance bias correction (y/n)? [y] > +Land DAS Analysis (y/n)? [n] +> + Frequency (in days) for writing restarts? [0] > diff --git a/src/Applications/GEOSdas_App/testsuites/geos_it.input b/src/Applications/GEOSdas_App/testsuites/geos_it.input index c955bbe7..e426e7d4 100644 --- a/src/Applications/GEOSdas_App/testsuites/geos_it.input +++ b/src/Applications/GEOSdas_App/testsuites/geos_it.input @@ -148,6 +148,9 @@ Use aircraft bias correction (y/n)? [y] Use unified radiance bias correction (y/n)? [y] > +Land DAS Analysis (y/n)? [n] +> + Frequency (in days) for writing restarts? [0] > diff --git a/src/Applications/GEOSdas_App/testsuites/prePP.input b/src/Applications/GEOSdas_App/testsuites/prePP.input index 87e6eed8..7c155d27 100644 --- a/src/Applications/GEOSdas_App/testsuites/prePP.input +++ b/src/Applications/GEOSdas_App/testsuites/prePP.input @@ -2,8 +2,8 @@ # prePP.input #------------ -description: prePP__GEOSadas-5_29_0__agrid_C720__ogrid_C -tag: GEOSadas-5_29_0 +description: prePP__GEOSadas-5_29_3__agrid_C720__ogrid_C +tag: GEOSadas-5_29_3 ---ENDHEADERS--- @@ -28,7 +28,7 @@ EXPID? [u000_C720] Check for previous use of expid (y/n)? [y] > n -EXPDSC? [prePP__GEOSadas-5_29_0__agrid_C720__ogrid_C] +EXPDSC? [prePP__GEOSadas-5_29_3__agrid_C720__ogrid_C] > Land Boundary Conditions? [Icarus_Updated] @@ -74,13 +74,7 @@ AeroCom? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/AeroCom] > FVICS? [/archive/u/jstassi/restarts/GEOSadas-5_24_0] -> later - -Starting year-month-day? [20190116] -> - -Starting hour-min-sec? [210000] -> +> /nfs3m/archive/sfa_cache01/projects/dao_ops/GEOS-5.27/GEOSadas-5_27/f5271_fp/rs/Y2021/M09/f5271_fp.rst.20210919_21z.tar Run model-adjoint-related applications (0=no,1=yes)? [0] > 1 @@ -100,8 +94,8 @@ Run analysis-sensitivity applications (0=no,1=yes)? [0] Verifying experiment id: [prePP] > -Ending year-month-day? [20190119] -> +Ending year-month-day? [20210921] +> 20211004 Length of FORECAST run segments (in hours)? [123] > @@ -116,7 +110,7 @@ Number of PEs in the meridional direction (NY)? [48] > 288 Job nickname? [g5das] -> prePP +> $expid Run in split executable mode (1=yes;0=no)? [1] > @@ -140,16 +134,19 @@ Ensemble Hybrid (<0;3=3dHyb;4=Hyb4d)? [-1] > 4 Number of procs in the zonal direction (NX)? [16] -> +> 27 Number of procs in the meridional direction (NY)? [42] > Which main class of ObsSys (1: NRT; 2: MERRA; 3: MERRA-2)? [1] -> +> 1 OBSERVING SYSTEM CLASSES? -> disc_airs_bufr,disc_amsua_bufr,gmao_amsr2_bufr,gmao_gmi_bufr,mls_nrt_nc,ncep_1bamua_bufr,ncep_1bhrs4_bufr,ncep_acftpfl_bufr,ncep_atms_bufr,ncep_aura_omi_bufr,ncep_avcsam_bufr,ncep_avcspm_bufr,ncep_crisfsr_bufr,ncep_goesfv_bufr,ncep_gpsro_bufr,ncep_mhs_bufr,ncep_mtiasi_bufr,ncep_prep_bufr,ncep_satwnd_bufr,ncep_sevcsr_bufr,ncep_ssmis_bufr,ncep_tcvitals,npp_ompsnm_bufr +> disc_airs_bufr,disc_amsua_bufr,gmao_amsr2_bufr,gmao_gmi_bufr,mls_nrt_nc,ncep_1bamua_bufr,ncep_1bhrs4_bufr,ncep_acftpfl_bufr,ncep_atms_bufr,ncep_aura_omi_bufr,ncep_avcsam_bufr,ncep_avcspm_bufr,ncep_crisfsr_bufr,ncep_goesfv_bufr,ncep_gpsro_bufr,ncep_mhs_bufr,ncep_mtiasi_bufr,ncep_prep_bufr,ncep_satwnd_bufr,ncep_sevcsr_bufr,ncep_ssmis_bufr,ncep_tcvitals,npp_ompsnm_bufr,gmao_mlst_bufr + +CHECKING OBSYSTEM? [2] +> 1 Which RADCOR option? [NONE] > @@ -163,6 +160,9 @@ Use aircraft bias correction (y/n)? [y] Use unified radiance bias correction (y/n)? [y] > +Land DAS Analysis (y/n)? [n] +> + Frequency (in days) for writing restarts? [0] > @@ -214,10 +214,10 @@ Which template? [GCMPROG.rc.tmpl] Output Restart TYPE (bin or nc4) [nc4] > -Select group: [s0818] -> g0613 +Select group: [g0613] +> -Replayed Ensemble (from OPS)? [yes] +Replayed Ensemble? [yes] > no Use SPPT-scheme for Ensemble? [yes] @@ -230,7 +230,7 @@ Ensemble Vertical Levels? [72] > Experiment archive directory for ensemble restarts or 'later': [/archive/u/rtodling/prePP] -> later +> /nfs3m/archive/sfa_cache01/projects/dao_ops/GEOS-5.27/GEOSadas-5_27/f5271_fp Edit COLLECTIONS list in run/HISTORY.rc.tmpl (y/n)? [n] > diff --git a/src/Applications/GEOSdas_App/testsuites/x0046a.input b/src/Applications/GEOSdas_App/testsuites/x0046a.input index 4f04ef0b..21dfbd2d 100644 --- a/src/Applications/GEOSdas_App/testsuites/x0046a.input +++ b/src/Applications/GEOSdas_App/testsuites/x0046a.input @@ -2,8 +2,8 @@ # x0046a.input #------------ -description: x0046a__GEOSadas-5_29_0__agrid_C360__ogrid_C -tag: GEOSadas-5_29_0 +description: x0046a__GEOSadas-5_29_3__agrid_C360__ogrid_C +tag: GEOSadas-5_29_3 ---ENDHEADERS--- @@ -28,7 +28,7 @@ EXPID? [u000_C360] Check for previous use of expid (y/n)? [y] > n -EXPDSC? [x0046a__GEOSadas-5_29_0__agrid_C360__ogrid_C] +EXPDSC? [x0046a__GEOSadas-5_29_3__agrid_C360__ogrid_C] > Land Boundary Conditions? [Icarus_Updated] @@ -160,6 +160,9 @@ Use aircraft bias correction (y/n)? [y] Use unified radiance bias correction (y/n)? [y] > +Land DAS Analysis (y/n)? [n] +> + Frequency (in days) for writing restarts? [0] > diff --git a/src/Applications/GEOSdas_App/testsuites/x0046aRPY.input b/src/Applications/GEOSdas_App/testsuites/x0046aRPY.input index 8dcb383d..03e8427f 100644 --- a/src/Applications/GEOSdas_App/testsuites/x0046aRPY.input +++ b/src/Applications/GEOSdas_App/testsuites/x0046aRPY.input @@ -2,8 +2,8 @@ # x0046aRPY.input #------------ -description: x0046aRPY__GEOSadas-5_29_0__agrid_C360__ogrid_C -tag: GEOSadas-5_29_0 +description: x0046aRPY__GEOSadas-5_29_3__agrid_C360__ogrid_C +tag: GEOSadas-5_29_3 ---ENDHEADERS--- @@ -28,7 +28,7 @@ EXPID? [u000_C360] Check for previous use of expid (y/n)? [y] > n -EXPDSC? [x0046aRPY__GEOSadas-5_29_0__agrid_C360__ogrid_C] +EXPDSC? [x0046aRPY__GEOSadas-5_29_3__agrid_C360__ogrid_C] > Land Boundary Conditions? [Icarus_Updated] @@ -148,6 +148,9 @@ Use aircraft bias correction (y/n)? [y] Use unified radiance bias correction (y/n)? [y] > +Land DAS Analysis (y/n)? [n] +> + Frequency (in days) for writing restarts? [0] > diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atm_ens.j b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atm_ens.j index 646e12e3..3cf20135 100755 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atm_ens.j +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atm_ens.j @@ -145,7 +145,7 @@ setenv GAAS_ANA 1 setenv LDAS_ANA >>>LDAS_ANA<<< - setenv LDHOME4ens >>>LDHOME4ens<<< + setenv LDHOME4ENS >>>LDHOME4ENS<<< # Run-time mpi-related options @@ -459,13 +459,13 @@ # LDAS ens analysis at ens gcm resolution # ----------------------------------- if ( $LDAS_ANA ) then - zeit_ci.x eldas - atmos_eldas.csh $EXPID $anymd $anhms 060000 |& tee -a atm_ens.log - if( $status) then - echo "eldas failed" - exit(1) - endif - zeit_co.x eldas + zeit_ci.x eldas + atmos_eldas.csh $EXPID $anymd $anhms 060000 |& tee -a atm_ens.log + if( $status) then + echo "eldas failed" + exit(1) + endif + zeit_co.x eldas endif # Run ensemble of atmospheric analyses @@ -487,9 +487,9 @@ set amm = `echo ${anymd} | cut -c5-6` set ahh = `echo ${anhms} | cut -c1-2` cd $FVWORK/updated_ens - if(! -e $HYBRIDGSI/${EXPID}.atmens_eana_brec.${nymdb}_${hhb}z.tar ) then - tar -cvf $HYBRIDGSI/${EXPID}.atmens_eana_brec.${nymdb}_${hhb}z.tar mem0*/*.ana.eta*nc4 - endif +# if(! -e $HYBRIDGSI/${EXPID}.atmens_eana_brec.${nymdb}_${hhb}z.tar ) then +# tar -cvf $HYBRIDGSI/${EXPID}.atmens_eana_brec.${nymdb}_${hhb}z.tar mem0*/*.ana.eta*nc4 +# endif cd - endif @@ -520,9 +520,9 @@ set amm = `echo ${anymd} | cut -c5-6` set ahh = `echo ${anhms} | cut -c1-2` cd $FVWORK/updated_ens - if(! -e $HYBRIDGSI/${EXPID}.atmens_eana_arec.${nymdb}_${hhb}z.tar ) then - tar -cvf $HYBRIDGSI/${EXPID}.atmens_eana_arec.${nymdb}_${hhb}z.tar mem0*/*.ana.eta*nc4 - endif +# if(! -e $HYBRIDGSI/${EXPID}.atmens_eana_arec.${nymdb}_${hhb}z.tar ) then +# tar -cvf $HYBRIDGSI/${EXPID}.atmens_eana_arec.${nymdb}_${hhb}z.tar mem0*/*.ana.eta*nc4 +# endif cd - endif diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmos_eldas.csh b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmos_eldas.csh index c1848dab..bb5de0fb 100755 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmos_eldas.csh +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmos_eldas.csh @@ -39,7 +39,7 @@ if ( $#argv < 4 ) then echo " FVHOME - location of experiment " echo " FVROOT - location of DAS build " echo " FVWORK - location of work directory " - echo " LDHOME4ens - location of LDAS4ens experiment " + echo " LDHOME4ENS - location of LDAS4ENS experiment " echo " \\end{verbatim} " echo " \\clearpage " exit(0) @@ -52,7 +52,7 @@ setenv FAILED 0 if ( !($?FVHOME) ) setenv FAILED 1 if ( !($?FVROOT) ) setenv FAILED 1 if ( !($?FVWORK) ) setenv FAILED 1 -if ( !($?LDHOME4ens) ) setenv FAILED 1 +if ( !($?LDHOME4ENS) ) setenv FAILED 1 if ( $FAILED ) then env @@ -74,104 +74,101 @@ if (-e $ENSWORK/.DONE_${MYNAME}.$yyyymmddhh ) then exit(0) endif - echo " ${MYNAME}: LDAS4ENS coupling: run ldas for atmens coupling" - # ens forc access: $FVHOME/ensdiag/mem*** - # go to LDHOME to run ldas - cd $LDHOME4ens/run - echo "ldas_home_dir: ", $LDHOME4ens - # submit job and capture job ID - set jobldas = "$LDHOME4ens/run/lenkf.j" - set jobIDlong = `$PBS_BIN/sbatch $jobldas` - set jobID = `echo $jobIDlong |awk -F'[ ]' '{print $4}'` - setenv ldasJobIDs $jobID - echo $ldasJobIDs ": LDAS4ens coupling lenkf jobID " +echo " ${MYNAME}: LDAS4ENS coupling: run ldas for atmens coupling" +# ens forc access: $FVHOME/ensdiag/mem*** +# go to LDHOME4ENS to run ldas +cd $LDHOME4ENS/run +echo "ldas_home_dir: ", $LDHOME4ENS +# submit job and capture job ID +set jobldas = "$LDHOME4ENS/run/lenkf.j" +set jobIDlong = `sbatch $jobldas` +set jobID = `echo $jobIDlong |awk -F'[ ]' '{print $4}'` +setenv ldasJobIDs $jobID +echo $ldasJobIDs ": LDAS4ens coupling lenkf jobID " ## back to fvwork - cd $FVWORK +cd $FVWORK - echo " ${MYNAME}: LDAS4ENS coupling: stage/link LdasIncr for eAGCM corrector " - setenv RSTSTAGE4AENS $FVHOME/atmens/RST +echo " ${MYNAME}: LDAS4ENS coupling: stage/link LdasIncr for eAGCM corrector " +setenv RSTSTAGE4AENS $FVHOME/atmens/RST - if ($?ldasJobIDs) then - $FVROOT/bin/jobIDfilter -w $ldasJobIDs - unsetenv ldasJobIDs - endif +if ($?ldasJobIDs) then + $FVROOT/bin/jobIDfilter -w $ldasJobIDs + unsetenv ldasJobIDs +endif - set lenkf_status_file = ${FVWORK}/lenkf_job_completed.txt - rm -f $lenkf_status_file +set lenkf_status_file = ${FVWORK}/lenkf_job_completed.txt +/bin/rm -f $lenkf_status_file - cp $LDHOME4ens/run/lenkf_job_completed.txt $lenkf_status_file +/bin/cp $LDHOME4ENS/run/lenkf_job_completed.txt $lenkf_status_file - set lenkf_status = `cat $lenkf_status_file` - echo $lenkf_status - echo $lenkf_status ": lenkf_status" - if ($lenkf_status =~ SUCCEEDED ) then - echo "LDAS4ens coupling Lenkf job SUCCEEDED, stageLdasIncr4ens" +set lenkf_status = `cat $lenkf_status_file` +echo $lenkf_status +echo $lenkf_status ": lenkf_status" +if ($lenkf_status =~ SUCCEEDED ) then + echo "LDAS4ens coupling Lenkf job SUCCEEDED, stageLdasIncr4ens" # current all member incr outputs in cat/ens_avg - set LINC_DIR = ${LDHOME4ens}/output/*/cat/ens_avg/ + set LINC_DIR = ${LDHOME4ENS}/output/*/cat/ens_avg/ #make atmens/lana/mem* - cd ${FVHOME}/atmens - mkdir enslana - @ nmem = 0 - set dirs = (`/bin/ls -d mem0*`) - foreach dir ($dirs) - set nnn = `echo $dir | cut -c4-6` - mkdir ${FVHOME}/atmens/enslana/mem${nnn} - @ nmem ++ - end #foreach dir - cd - - - @ adas_int = $freqa / 10000 - @ adas_int = $adas_int * 3600 - - set ldas_int = 10800 - set ldasDT = `grep LANDASSIM_DT: ${LDHOME4ens}/run/LDAS.rc | cut -d':' -f2` - if ( ${ldasDT} > 0 ) then + cd ${FVHOME}/atmens + mkdir enslana + @ nmem = 0 + set dirs = (`/bin/ls -d mem0*`) + foreach dir ($dirs) + set nnn = `echo $dir | cut -c4-6` + mkdir ${FVHOME}/atmens/enslana/mem${nnn} + @ nmem ++ + end #foreach dir + cd - + + @ adas_int = $freqa / 10000 + @ adas_int = $adas_int * 3600 + + set ldas_int = 10800 + set ldasDT = `grep LANDASSIM_DT: ${LDHOME4ENS}/run/LDAS.rc | cut -d':' -f2` + if ( ${ldasDT} > 0 ) then set ldas_int = ${ldasDT} - endif + endif - set ldas_t0 = 013000 - set ldasT0 = `grep LANDASSIM_T0: ${LDHOME4ens}/run/LDAS.rc | cut -d':' -f2` - if ( ${ldasT0} > 0 ) then + set ldas_t0 = 013000 + set ldasT0 = `grep LANDASSIM_T0: ${LDHOME4ENS}/run/LDAS.rc | cut -d':' -f2` + if ( ${ldasT0} > 0 ) then set ldas_t0 = ${ldasT0} - endif - set t0hh = `echo ${ldas_t0} | cut -c1-2` - set t0mm = `echo ${ldas_t0} | cut -c3-4` - @ cent_int = $t0hh * 3600 + $t0mm * 60 - - - set lincr_native_name = catch_progn_incr - set lincr_default_name = ldas_inc - - - /bin/cp $RSTSTAGE4AENS/*.rst.lcv.*.bin my_d_rst - set adas_strt = ( `rst_date ./my_d_rst` ) - - set secs = 0 - - while ( $secs < $adas_int ) - # the begining time of the window secs=0 - set ldas_strt = ( `tick $adas_strt $secs` ) - # ldas anal time - set ldas_anlt = ( `tick $ldas_strt $cent_int` ) - - set yyyy_a=`echo $ldas_anlt[1] | cut -c1-4` - set mm_a=`echo $ldas_anlt[1] | cut -c5-6` - set dd_a=`echo $ldas_anlt[1] | cut -c7-8` - set tttt_a=`echo $ldas_anlt[2] | cut -c1-4` -# default name for AGCM: ldas_inc.yyyymmdd_hhnn00 - @ n = 0 -while ($n < $nmem) -set lentag = `echo $n | awk '{printf "%04d", $1}'` -echo $lentag -@ n++ -set memtag = `echo $n | awk '{printf "%03d", $1}'` -echo $memtag - /bin/ln -s ${LINC_DIR}/Y${yyyy_a}/M${mm_a}/*.${lincr_native_name}${lentag}.$ldas_anlt[1]_${tttt_a}z.nc4\ + endif + set t0hh = `echo ${ldas_t0} | cut -c1-2` + set t0mm = `echo ${ldas_t0} | cut -c3-4` + @ cent_int = $t0hh * 3600 + $t0mm * 60 + + set lincr_native_name = catch_progn_incr + set lincr_default_name = ldas_inc + + /bin/cp $RSTSTAGE4AENS/*.rst.lcv.*.bin my_d_rst + set adas_strt = ( `rst_date ./my_d_rst` ) + + set secs = 0 + while ( $secs < $adas_int ) + # the begining time of the window secs=0 + set ldas_strt = ( `tick $adas_strt $secs` ) + # ldas anal time + set ldas_anlt = ( `tick $ldas_strt $cent_int` ) + + set yyyy_a=`echo $ldas_anlt[1] | cut -c1-4` + set mm_a=`echo $ldas_anlt[1] | cut -c5-6` + set dd_a=`echo $ldas_anlt[1] | cut -c7-8` + set tttt_a=`echo $ldas_anlt[2] | cut -c1-4` + # default name for AGCM: ldas_inc.yyyymmdd_hhnn00 + @ n = 0 + while ($n < $nmem) + set lentag = `echo $n | awk '{printf "%04d", $1}'` + echo $lentag + @ n++ + set memtag = `echo $n | awk '{printf "%03d", $1}'` + echo $memtag + /bin/ln -s ${LINC_DIR}/Y${yyyy_a}/M${mm_a}/*.${lincr_native_name}${lentag}.$ldas_anlt[1]_${tttt_a}z.nc4\ ${FVHOME}/atmens/enslana/mem$memtag/ldas_inc.$ldas_anlt[1]_${tttt_a}00 - end + end ## copy to FVWORK cd ${FVWORK} @@ -180,19 +177,19 @@ echo $memtag set nnn = `echo $dir | cut -c4-6` /bin/cp ${FVHOME}/atmens/enslana/mem${nnn}/ldas_inc.$ldas_anlt[1]_${tttt_a}00\ ${FVWORK}/mem${nnn}/ldas_inc.$ldas_anlt[1]_${tttt_a}00 - end #foreach dir + end #foreach dir #--- - @ secs = $secs + $ldas_int - end #sec while loop + @ secs = $secs + $ldas_int + end #sec while loop - else - echo " ${MYNAME}: WARNING: ldas4ens failed, no ldasIncr for this cycle to enAGCM " - exit 1 - endif #end ldas enkf succeeded +else + echo " ${MYNAME}: WARNING: ldas4ens failed, no ldasIncr for this cycle to enAGCM " + exit 1 +endif #end ldas enkf succeeded # normal return touch $FVWORK/.DONE_${MYNAME}.$yyyymmddhh echo " ${MYNAME}: Complete " - exit 0 +exit 0 From f0e40f811930fef4a354524e71e912eb39811ad7 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Fri, 8 Oct 2021 13:16:06 -0400 Subject: [PATCH 080/205] now using parallel tar to get ensemble --- .../NCEP_enkf/scripts/gmao/acquire_atmens.csh | 15 +++++++++++---- .../NCEP_enkf/scripts/gmao/atmens_prepgeps.csh | 16 +++++++++++++--- .../NCEP_enkf/scripts/gmao/atmens_prepobsens.csh | 10 ++++++++-- .../NCEP_enkf/scripts/gmao/get_atmens_rst.pl | 6 +++++- 4 files changed, 37 insertions(+), 10 deletions(-) diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/acquire_atmens.csh b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/acquire_atmens.csh index 037746fa..15acbdc1 100644 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/acquire_atmens.csh +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/acquire_atmens.csh @@ -10,6 +10,7 @@ # 06Apr2016 Todling Allow to acquire stats tar ball # 24Feb2020 Todling Adjust to allow replay from older ebkg tar balls # 23Jun2020 Todling Redef meaning of ATMENSLOC +# 06Oct2021 Todling Use parallel untar ######################################################################## if ( !($?ATMENS_VERBOSE) ) then @@ -66,14 +67,15 @@ if ( $#argv < 4 ) then echo " " echo " OPTIONAL EVIRONMENT VARIABLES" echo " " - echo " ATMENSLOC - place where to put acquired ensemble " - echo " (default: FVWORK) " + echo " ATMENS_NCPUSTAR - number of CPUS used for untar (default: 32) " + echo " ATMENSLOC - place where to put acquired ensemble " + echo " (default: FVWORK) " echo " SEE ALSO" echo " analyzer - driver for central ADAS analysis" echo " " echo " AUTHOR" echo " Ricardo Todling (Ricardo.Todling@nasa.gov), NASA/GMAO " - echo " Last modified: 08Apr2013 by: R. Todling" + echo " Last modified: 06Oct2021 by: R. Todling" echo " " echo " \\end{verbatim} " echo " \\clearpage " @@ -97,6 +99,7 @@ if ( !($?VAROFFSET) ) setenv FAILED 1 if ( !($?ENSACQ_WALLCLOCK)) setenv ENSACQ_WALLCLOCK 2:00:00 if ( !($?ATMENSLOC) ) setenv ATMENSLOC $FVWORK/atmens +if ( !($?ATMENS_NCPUSTAR) ) setenv ATMENS_NCPUSTAR 32 if ( $FAILED ) then env @@ -200,7 +203,11 @@ foreach ball ( $tarballtyps ) # do not reorder the first two gunzip $expid.atmens_${ball}.${nymdb}_${hhb}z.tar.gz endif if ( -e $expid.atmens_${ball}.${nymdb}_${hhb}z.tar ) then - tar -xvf $expid.atmens_${ball}.${nymdb}_${hhb}z.tar + if ( $ATMENS_NCPUSTAR > 1 ) then + parallel-untar.py $expid.atmens_${ball}.${nymdb}_${hhb}z.tar $ATMENS_NCPUSTAR + else + tar -xvf $expid.atmens_${ball}.${nymdb}_${hhb}z.tar + endif set dummy = (`/bin/ls -1d *.atmens_${ball}.${nymdb}_${hhb}z`) set oldexpid = `echo $dummy[1] | cut -d. -f1` if ( "$oldexpid" != "$expid" ) then diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmens_prepgeps.csh b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmens_prepgeps.csh index ec16e422..fb35cebf 100755 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmens_prepgeps.csh +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmens_prepgeps.csh @@ -64,6 +64,7 @@ if ( $#argv < 7 ) then echo " " echo " ATMENS_GEPS_RECENTER 1: use to recenter ensemble analysis" echo " (default: 0)" + echo " ATMENS_NCPUSTAR - number of CPUS used for untar (default: 32) " echo " NCSUFFIX - suffix of hdf/netcdf files (default: nc4)" echo " DATADIR - location where original data resides" echo " (default: /archive/u/user)" @@ -76,7 +77,7 @@ if ( $#argv < 7 ) then echo " AUTHOR" echo " Ricardo Todling (Ricardo.Todling@nasa.gov), NASA/GMAO " echo " Created modified: 01Apr2017 by: R. Todling" - echo " Last modified: 16Apr2017 by: R. Todling" + echo " Last modified: 06Oct2021 by: R. Todling" echo " \\end{verbatim} " echo " \\clearpage " exit(0) @@ -92,6 +93,7 @@ if ( !($?GID) ) setenv FAILED 1 if ( !($?ATMENS_GEPS_RECENTER) ) setenv ATMENS_GEPS_RECENTER 0 # 1= will recenter analysis if ( !($?ATMENS_GEPS_FROM_CENTRAL) ) setenv ATMENS_GEPS_FROM_CENTRAL 0 # 1= forecast from central rst/bkg +if ( !($?ATMENS_NCPUSTAR) ) setenv ATMENS_NCPUSTAR 32 if ( !($?SRCEXPID) ) setenv SRCEXPID NULL if ( !($?DATADIR) ) setenv DATADIR $ARCHIVE @@ -277,7 +279,11 @@ if ( $ATMENS_GEPS_FROM_CENTRAL ) then mkdir -p centralRST/Ori mkdir -p centralRST/New cd centralRST/Ori - tar xvf ../../$SRCEXPID.rst.${nymd}_${hh}z.tar + if ( $ATMENS_NCPUSTAR > 1 ) then + parallel-untar.py ../../$SRCEXPID.rst.${nymd}_${hh}z.tar $ATMENS_NCPUSTAR + else + tar xvf ../../$SRCEXPID.rst.${nymd}_${hh}z.tar + endif cd ../ set inpdir = `echo $cwd` set outdir = $inpdir/New @@ -346,7 +352,11 @@ else # ATMENS_GEPS_FROM_CENTRAL=0 - forecast from ens member RSTs echo "${MYNAME}: cannot find file type $ftype , aborting ... " exit (1) endif - $DRYRUN tar xvf $expid.atmens_${ftype}.${nymd}_${hh}z.tar + if ( $ATMENS_NCPUSTAR > 1 ) then + $DRYRUN parallel-untar.py $expid.atmens_${ftype}.${nymd}_${hh}z.tar $ATMENS_NCPUSTAR + else + $DRYRUN tar xvf $expid.atmens_${ftype}.${nymd}_${hh}z.tar + endif if ( $SRCEXPID != $expid && -d $SRCEXPID.atmens_${ftype}.${nymd}_${hh}z ) then /bin/mv $SRCEXPID.atmens_${ftype}.${nymd}_${hh}z $expid.atmens_${ftype}.${nymd}_${hh}z endif diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmens_prepobsens.csh b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmens_prepobsens.csh index 937b9105..1fad6596 100755 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmens_prepobsens.csh +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmens_prepobsens.csh @@ -72,6 +72,7 @@ if ( $#argv < 7 ) then echo " ATMENS_FSO_MFCST - 0: use central forecast for error definition" echo " 1: use ensemble mean forecast for error definition" echo " (default: 0)" + echo " ATMENS_NCPUSTAR - number of CPUS used for untar (default: 32) " echo " NCSUFFIX - suffix of hdf/netcdf files (default: nc4)" echo " DATADIR - location where original data resides" echo " (default: /archive/u/user)" @@ -84,7 +85,7 @@ if ( $#argv < 7 ) then echo " AUTHOR" echo " Ricardo Todling (Ricardo.Todling@nasa.gov), NASA/GMAO " echo " Created modified: 01Apr2017 by: R. Todling" - echo " Last modified: 16Apr2017 by: R. Todling" + echo " Last modified: 06Oct2021 by: R. Todling" echo " \\end{verbatim} " echo " \\clearpage " exit(0) @@ -106,6 +107,7 @@ if ( !($?ATMENS_FSO_AVRFY) ) setenv ATMENS_FSO_AVRFY 0 # 0= use central analys # 1= use ensemble mean analysis if ( !($?ATMENS_FSO_MFCST) ) setenv ATMENS_FSO_MFCST 0 # 0= use central fcsts # 1= use mean of ens forecast +if ( !($?ATMENS_NCPUSTAR) ) setenv ATMENS_NCPUSTAR 32 if ( !($?SRCEXPID) ) setenv SRCEXPID NULL if ( !($?DATADIR) ) setenv DATADIR $ARCHIVE if ( !($?NCSUFFIX) ) setenv NCSUFFIX nc4 @@ -342,7 +344,11 @@ foreach ftype ( ) else if ( -e $expid.atmens_${ftype}.${nymd}_${hh}z.tar ) then echo "${MYNAME}: unfolding ensemble of backgrounds ($ftype) ... " - $DRYRUN tar xvf $expid.atmens_${ftype}.${nymd}_${hh}z.tar + if ( $ATMENS_NCPUSTAR > 1 ) then + $DRYRUN parallel-untar.py $expid.atmens_${ftype}.${nymd}_${hh}z.tar $ATMENS_NCPUSTAR + else + $DRYRUN tar xvf $expid.atmens_${ftype}.${nymd}_${hh}z.tar + endif endif endif endif diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/get_atmens_rst.pl b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/get_atmens_rst.pl index 81996f29..0d52486a 100755 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/get_atmens_rst.pl +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/get_atmens_rst.pl @@ -17,6 +17,7 @@ #----------------- my ($atmens_dir); my ($arcdir, $expid, $newid, $yyyymmdd, $yyyy, $mm, $hh); +my ($fvroot); my %vopts = ( "verbose" => 1 ); @@ -31,6 +32,9 @@ my ($tarfile, $tarpath, $label, $pid); my ($ens, $mem, $mfile, $mfile_new); my (@tarList); + + my $fvbin = $FindBin::Bin; + $fvroot = dirname($fvbin); init(); chdir($atmens_dir); @@ -60,7 +64,7 @@ system "dmget @tarList"; exit; } - foreach $tarpath (@tarList) { system_("tar xvf $tarpath") } + foreach $tarpath (@tarList) { system_("$fvroot/bin/parallel-untar.py $tarpath 16") } $atmens_stat_dir = "$expid.atmens_stat.${yyyymmdd}_${hh}z"; foreach $ens (<$atmens_stat_dir/ens*>) { mv_($ens, $pwd) } From 2c73fd0adcc09c6033a97e9e0929e7b5c4c4a735 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Fri, 8 Oct 2021 13:21:24 -0400 Subject: [PATCH 081/205] Update to recommended version of MAPL and model. --- components.yaml | 10 +++++----- src/Applications/GEOSdas_App/AGCMrc.pm | 6 +++++- 2 files changed, 10 insertions(+), 6 deletions(-) diff --git a/components.yaml b/components.yaml index b5620e4d..c498caeb 100644 --- a/components.yaml +++ b/components.yaml @@ -28,13 +28,13 @@ NCEP_Shared: GMAO_Shared: local: ./src/Shared/@GMAO_Shared remote: ../GMAO_Shared.git - branch: feature/rtodling/rt-cssrwNreplay + tag: v1.4.10 develop: main MAPL: local: ./src/Shared/@MAPL remote: ../MAPL.git - tag: v2.7.0 + tag: v2.8.0 develop: develop FMS: @@ -52,7 +52,7 @@ GEOSana_GridComp: GEOSgcm_GridComp: local: ./src/Components/@GEOSgcm_GridComp remote: ../GEOSgcm_GridComp.git - tag: v1.12.3 + tag: v1.12.4 sparse: ./config/GEOSgcm_GridComp.sparse develop: develop @@ -77,7 +77,7 @@ FVdycoreCubed_GridComp: fvdycore: local: ./src/Components/@GEOSgcm_GridComp/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/@FVdycoreCubed_GridComp/@fvdycore remote: ../GFDL_atmos_cubed_sphere.git - tag: geos/v1.1.6 + tag: geos/v1.1.7 develop: geos/develop GEOSchem_GridComp: @@ -121,7 +121,7 @@ mom6: GEOSgcm_App: local: ./src/Applications/@GEOSgcm_App remote: ../GEOSgcm_App.git - tag: rt1.5.3.1 + tag: rt1.5.4.1 develop: develop UMD_Etc: diff --git a/src/Applications/GEOSdas_App/AGCMrc.pm b/src/Applications/GEOSdas_App/AGCMrc.pm index 1cf249bc..edbb34da 100644 --- a/src/Applications/GEOSdas_App/AGCMrc.pm +++ b/src/Applications/GEOSdas_App/AGCMrc.pm @@ -266,7 +266,11 @@ sub ed_g5agcm_rc { # comment unused catch or catchCN restart #---------------------------------------- - if ($lsmodel_flag == 1) { $comment{"CATCHCN_INTERNAL"} = 1 } + if ($lsmodel_flag == 1) { + $comment{"CATCHCN_INTERNAL"} = 1; + $comment{"CATCHCNCLM40_INTERNAL"} = 1; + $comment{"CATCHCNCLM45_INTERNAL"} = 1; + } if ($lsmodel_flag == 2) { $comment{"CATCH_INTERNAL"} = 1 } # comment these line when GOCART tracers turned on From 31a5452a2f88992cc89239668088433e3124b7fd Mon Sep 17 00:00:00 2001 From: Rolf Reichle <54944691+gmao-rreichle@users.noreply.github.com> Date: Fri, 8 Oct 2021 18:50:21 -0400 Subject: [PATCH 082/205] bug fix for ADAS checking on LDAS job constructed from Sara's recent commit 5fac454 https://github.com/GEOS-ESM/GEOSadas/pull/80/commits/5fac4547a982a5e8c032521774fd76c2c2de76c0?w=1 --- src/Applications/GEOSdas_App/ldas_run.csh | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/src/Applications/GEOSdas_App/ldas_run.csh b/src/Applications/GEOSdas_App/ldas_run.csh index 652be5e6..cca1ea8d 100755 --- a/src/Applications/GEOSdas_App/ldas_run.csh +++ b/src/Applications/GEOSdas_App/ldas_run.csh @@ -117,8 +117,9 @@ if ( $stage == 0 ) then set jobldas = "$LDHOME/run/lenkf.j" set jobIDlong = `$PBS_BIN/sbatch $jobldas` set jobID = `echo $jobIDlong |awk -F'[ ]' '{print $4}'` - setenv ldasJobIDs $jobID - echo $ldasJobIDs ": LDAS coupling lenkf jobID for central das " + echo $jobID > $FVWORK/ldasJobIDs.txt + ls -l $FVWORK/ldasJobIDs.txt + echo $jobID ": LDAS jobID for central das in ldasJobIDs.txt" ## back to fvwork cd $FVWORK @@ -127,10 +128,11 @@ if ( $stage == 0 ) then else cd $FVWORK echo " ${MYNAME}: LDAS coupling: stage/link LdasIncr for AGCM corrector " - if ($?ldasJobIDs) then - $FVROOT/bin/jobIDfilter -w $ldasJobIDs - unsetenv ldasJobIDs - endif + set ldasJobIDs = `cat ldasJobIDs.txt` + echo " ldasJobIDs : ${ldasJobIDs} " + $FVROOT/bin/jobIDfilter -w $ldasJobIDs + /bin/mv $FVWORK/ldasJobIDs.txt $FVWORK/ldasJobIDs.txt.${yyyymmddhh} + echo " ${MYNAME}: job monitoring is done" set lenkf_status_file = ${FVWORK}/lenkf_job_completed.txt rm -f $lenkf_status_file From 1576490ba2c5054b2e640c54fb05616f503e4e82 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Tue, 12 Oct 2021 11:48:48 -0400 Subject: [PATCH 083/205] compiler update; this is failing in netcdf ncdiag --- components.yaml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/components.yaml b/components.yaml index c498caeb..9eb5d47c 100644 --- a/components.yaml +++ b/components.yaml @@ -5,13 +5,13 @@ GEOSadas: env: local: ./@env remote: ../ESMA_env.git - tag: v3.3.0 + tag: v3.4.0 develop: main cmake: local: ./@cmake remote: ../ESMA_cmake.git - tag: v3.5.2 + tag: v3.5.8 develop: develop ecbuild: @@ -46,7 +46,7 @@ FMS: GEOSana_GridComp: local: ./src/Components/@GEOSana_GridComp remote: ../GEOSana_GridComp.git - tag: v1.4.4 + branch: feature/rtodling/bkerror_check develop: develop GEOSgcm_GridComp: From 1f52fa9110b1edcd47cb3abb06910026a0b1b894 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Tue, 12 Oct 2021 13:46:57 -0400 Subject: [PATCH 084/205] error in module definition --- components.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/components.yaml b/components.yaml index 9eb5d47c..092a5939 100644 --- a/components.yaml +++ b/components.yaml @@ -121,7 +121,7 @@ mom6: GEOSgcm_App: local: ./src/Applications/@GEOSgcm_App remote: ../GEOSgcm_App.git - tag: rt1.5.4.1 + tag: v1.5.4 develop: develop UMD_Etc: From f38f623f598edfe1dc41fe71b6bd76edfe5dfb1d Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Wed, 13 Oct 2021 14:58:21 -0400 Subject: [PATCH 085/205] changes in support of cascade --- .../GEOSdas_App/Create_anasa_script.pm | 9 +++++-- .../GEOSdas_App/Create_asens_script.pm | 9 +++++-- .../GEOSdas_App/Create_fsens_script.pm | 9 +++++-- src/Applications/GEOSdas_App/GEOSdas.csm | 2 ++ src/Applications/GEOSdas_App/fvsetup | 26 +++++++------------ .../testsuites/C360L181_replay.input | 3 +++ .../testsuites/C360L91_replay.input | 3 +++ .../GEOSdas_App/testsuites/C48f.input | 3 +++ .../GEOSdas_App/testsuites/C90C.input | 2 ++ .../GEOSdas_App/testsuites/C90C_ens.input | 3 +++ .../GEOSdas_App/testsuites/C90C_replay.input | 3 +++ .../GEOSdas_App/testsuites/geos_it.input | 3 +++ .../GEOSdas_App/testsuites/prePP.input | 3 +++ .../GEOSdas_App/testsuites/x0046a.input | 3 +++ .../GEOSdas_App/testsuites/x0046aRPY.input | 3 +++ 15 files changed, 62 insertions(+), 22 deletions(-) diff --git a/src/Applications/GEOSdas_App/Create_anasa_script.pm b/src/Applications/GEOSdas_App/Create_anasa_script.pm index e1e78b6d..0e2b6583 100644 --- a/src/Applications/GEOSdas_App/Create_anasa_script.pm +++ b/src/Applications/GEOSdas_App/Create_anasa_script.pm @@ -75,8 +75,13 @@ sub anasa_script { $siteID = get_siteID(); $nodeflg = "hasw"; my $npn = `facter processorcount`; chomp($npn); - if ( $npn == 40 ) { $nodeflg = "sky" } - elsif ( $npn == 28 ) { $nodeflg = "hasw" } + if ( $npn == 40 ) { + $nodeflg = "sky"; + } elsif ( $npn == 48 ) { + $nodeflg = "cas"; + } elsif ( $npn == 28 ) { + $nodeflg = "hasw"; + } open(SCRIPT,">$fvhome/anasa/$jobsa.j") or die ">>> ERROR <<< cannot write $fvhome/anasa/$jobsa.j"; diff --git a/src/Applications/GEOSdas_App/Create_asens_script.pm b/src/Applications/GEOSdas_App/Create_asens_script.pm index 9c900d90..accc813a 100644 --- a/src/Applications/GEOSdas_App/Create_asens_script.pm +++ b/src/Applications/GEOSdas_App/Create_asens_script.pm @@ -77,8 +77,13 @@ sub asens_script { $siteID = get_siteID(); my $npn = `facter processorcount`; chomp($npn); - if ( $npn == 40 ) { $nodeflg = "sky" } - elsif ( $npn == 28 ) { $nodeflg = "hasw" } + if ( $npn == 40 ) { + $nodeflg = "sky"; + } elsif ( $npn == 48 ) { + $nodeflg = "cas"; + } elsif ( $npn == 28 ) { + $nodeflg = "hasw"; + } open(SCRIPT,">$fvhome/asens/$joba.j") or die ">>> ERROR <<< cannot write $fvhome/asens/$joba.j"; diff --git a/src/Applications/GEOSdas_App/Create_fsens_script.pm b/src/Applications/GEOSdas_App/Create_fsens_script.pm index db7dea8b..12f8baca 100644 --- a/src/Applications/GEOSdas_App/Create_fsens_script.pm +++ b/src/Applications/GEOSdas_App/Create_fsens_script.pm @@ -56,8 +56,13 @@ sub fsens_script { $siteID = get_siteID(); $nodeflg = "hasw"; my $npn = `facter processorcount`; chomp($npn); - if ( $npn == 40 ) { $nodeflg = "sky" } - elsif ( $npn == 28 ) { $nodeflg = "hasw" } + if ( $npn == 40 ) { + $nodeflg = "sky"; + } elsif ( $npn == 48 ) { + $nodeflg = "cas"; + } elsif ( $npn == 28 ) { + $nodeflg = "hasw"; + } open(SCRIPT,">$fvhome/run/$jobfs.j") or die ">>> ERROR <<< cannot write $fvhome/run/$jobfs.j"; diff --git a/src/Applications/GEOSdas_App/GEOSdas.csm b/src/Applications/GEOSdas_App/GEOSdas.csm index 2e758c69..b4ed53e2 100755 --- a/src/Applications/GEOSdas_App/GEOSdas.csm +++ b/src/Applications/GEOSdas_App/GEOSdas.csm @@ -4283,6 +4283,8 @@ endif set npn = `facter processorcount` if ( $npn == 40 ) then set mynodes = "sky" + else if ( $npn == 48 ) then + set mynodes = "cas" else set mynodes = "hasw" endif diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index 5e812017..30b1858f 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -3016,15 +3016,17 @@ EOF #======================================================================= sub get_nodeflg { - $ncpus_per_node = 24; - $nodeflg = "hasw"; $proc = ""; # reset default if applicable - my $npn = `facter processorcount`; chomp($npn); - if ( $npn == 40 ) { - $ncpus_per_node = 36; - $nodeflg = "sky"; - } + + $ans = query(" Processing nodes (1:Westmere, 2:SandyBridge, 3:Ivy Bridge, 4:Haswell, 5:Skylake, 6:Cascase)?", "4"); + + if ($ans == 1) { $nodeflg = "wes"; $ncpus_per_node = 12 } + elsif ($ans == 2) { $nodeflg = "san"; $ncpus_per_node = 16 } + elsif ($ans == 3) { $nodeflg = "ivy"; $ncpus_per_node = 20 } + elsif ($ans == 4) { $nodeflg = "hasw"; $ncpus_per_node = 24 } + elsif ($ans == 5) { $nodeflg = "sky"; $ncpus_per_node = 36 } + elsif ($ans == 6) { $nodeflg = "cas"; $ncpus_per_node = 42 } # currently not applicable at nccs #--------------------------------- @@ -3033,14 +3035,6 @@ sub get_nodeflg { # request specific nodes on pfe? #------------------------------- if ($siteName eq "pfe") { - $ans = query(" Processing nodes (1:Westmere, 2:SandyBridge, 3:Ivy Bridge, 4:Haswell, 5:Sky)?", "1"); - $ans = 1 unless $ans == 2 or $ans == 3 or $ans == 4 or $ans == 5; - - if ($ans == 1) { $nodeflg = "wes"; $ncpus_per_node = 12 } - elsif ($ans == 2) { $nodeflg = "san"; $ncpus_per_node = 16 } - elsif ($ans == 3) { $nodeflg = "ivy"; $ncpus_per_node = 20 } - elsif ($ans == 4) { $nodeflg = "has"; $ncpus_per_node = 24 } - elsif ($ans == 5) { $nodeflg = "sky"; $ncpus_per_node = 36 } $procflg = ":mpiprocs=$ncpus_per_node$proc"; } @@ -8874,7 +8868,7 @@ print SCRIPT <<"EOF"; # MPT env variables # ----------------- if (\$?I_MPI_ROOT) then -# setenv I_MPI_USE_DYNAMIC_CONNECTIONS 0 + setenv I_MPI_USE_DYNAMIC_CONNECTIONS 0 # setenv I_MPI_FABRICS shm:dapl # setenv I_MPI_FABRICS_LIST "dapl,ofa" # setenv I_MPI_FALLBACK "enable" diff --git a/src/Applications/GEOSdas_App/testsuites/C360L181_replay.input b/src/Applications/GEOSdas_App/testsuites/C360L181_replay.input index 6dc0aa52..ffaa41f9 100644 --- a/src/Applications/GEOSdas_App/testsuites/C360L181_replay.input +++ b/src/Applications/GEOSdas_App/testsuites/C360L181_replay.input @@ -43,6 +43,9 @@ FVHOME? [/discover/nobackup/dao_it/C360L181_replay] The directory /discover/nobackup/projects/gmao/obsdev/dao_it/C360L181_replay already exists. Clean it? [y] > +Processing nodes (1:Westmere, 2:SandyBridge, 3:Ivy Bridge, 4:Haswell, 5:Skylake, 6:Cascase)? [4] +> + Which case of variational analysis? [1] > diff --git a/src/Applications/GEOSdas_App/testsuites/C360L91_replay.input b/src/Applications/GEOSdas_App/testsuites/C360L91_replay.input index 4521fe6a..545120d8 100644 --- a/src/Applications/GEOSdas_App/testsuites/C360L91_replay.input +++ b/src/Applications/GEOSdas_App/testsuites/C360L91_replay.input @@ -43,6 +43,9 @@ FVHOME? [/discover/nobackup/dao_it/C360L91_replay] The directory /discover/nobackup/projects/gmao/obsdev/dao_it/C360L91_replay already exists. Clean it? [y] > +Processing nodes (1:Westmere, 2:SandyBridge, 3:Ivy Bridge, 4:Haswell, 5:Skylake, 6:Cascase)? [4] +> + Which case of variational analysis? [1] > diff --git a/src/Applications/GEOSdas_App/testsuites/C48f.input b/src/Applications/GEOSdas_App/testsuites/C48f.input index 9e779b2c..59c397ff 100644 --- a/src/Applications/GEOSdas_App/testsuites/C48f.input +++ b/src/Applications/GEOSdas_App/testsuites/C48f.input @@ -41,6 +41,9 @@ FVHOME? [/discover/nobackup/jstassi/C48f] The directory /discover/nobackup/jstassi/C48f does not exist. Create it now? [y] > +Processing nodes (1:Westmere, 2:SandyBridge, 3:Ivy Bridge, 4:Haswell, 5:Skylake, 6:Cascase)? [4] +> + Which case of variational analysis? [1] > diff --git a/src/Applications/GEOSdas_App/testsuites/C90C.input b/src/Applications/GEOSdas_App/testsuites/C90C.input index 8e3fe67d..99caccb4 100644 --- a/src/Applications/GEOSdas_App/testsuites/C90C.input +++ b/src/Applications/GEOSdas_App/testsuites/C90C.input @@ -40,6 +40,8 @@ FVHOME? [/discover/nobackup/jstassi/C90C] The directory /discover/nobackup/jstassi/C90C does not exist. Create it now? [y] > +Processing nodes (1:Westmere, 2:SandyBridge, 3:Ivy Bridge, 4:Haswell, 5:Skylake, 6:Cascase)? [4] +> Which case of variational analysis? [1] > diff --git a/src/Applications/GEOSdas_App/testsuites/C90C_ens.input b/src/Applications/GEOSdas_App/testsuites/C90C_ens.input index 536f0cd1..feed5438 100644 --- a/src/Applications/GEOSdas_App/testsuites/C90C_ens.input +++ b/src/Applications/GEOSdas_App/testsuites/C90C_ens.input @@ -43,6 +43,9 @@ FVHOME? [/discover/nobackup/jstassi/C90C_ens] The directory /discover/nobackup/jstassi/C90C_ens does not exist. Create it now? [y] > +Processing nodes (1:Westmere, 2:SandyBridge, 3:Ivy Bridge, 4:Haswell, 5:Skylake, 6:Cascase)? [4] +> + Which case of variational analysis? [1] > diff --git a/src/Applications/GEOSdas_App/testsuites/C90C_replay.input b/src/Applications/GEOSdas_App/testsuites/C90C_replay.input index a95b339d..936dcc84 100644 --- a/src/Applications/GEOSdas_App/testsuites/C90C_replay.input +++ b/src/Applications/GEOSdas_App/testsuites/C90C_replay.input @@ -43,6 +43,9 @@ FVHOME? [/discover/nobackup/jstassi/C90C_replay] The directory /discover/nobackup/jstassi/C90C_replay does not exist. Create it now? [y] > +Processing nodes (1:Westmere, 2:SandyBridge, 3:Ivy Bridge, 4:Haswell, 5:Skylake, 6:Cascase)? [4] +> + Which case of variational analysis? [1] > diff --git a/src/Applications/GEOSdas_App/testsuites/geos_it.input b/src/Applications/GEOSdas_App/testsuites/geos_it.input index e426e7d4..ffc2c001 100644 --- a/src/Applications/GEOSdas_App/testsuites/geos_it.input +++ b/src/Applications/GEOSdas_App/testsuites/geos_it.input @@ -43,6 +43,9 @@ FVHOME? [/discover/nobackup/rtodling/geos_it] The directory /discover/nobackup/projects/gmao/dadev/rtodling/geos_it does not exist. Create it now? [y] > +Processing nodes (1:Westmere, 2:SandyBridge, 3:Ivy Bridge, 4:Haswell, 5:Skylake, 6:Cascase)? [4] +> + Which case of variational analysis? [1] > diff --git a/src/Applications/GEOSdas_App/testsuites/prePP.input b/src/Applications/GEOSdas_App/testsuites/prePP.input index 7c155d27..90f0f342 100644 --- a/src/Applications/GEOSdas_App/testsuites/prePP.input +++ b/src/Applications/GEOSdas_App/testsuites/prePP.input @@ -43,6 +43,9 @@ FVHOME? [/discover/nobackup/rtodling/prePP] The directory /discover/nobackup/projects/gmao/dadev/rtodling/prePP does not exist. Create it now? [y] > +Processing nodes (1:Westmere, 2:SandyBridge, 3:Ivy Bridge, 4:Haswell, 5:Skylake, 6:Cascase)? [4] +> + Which case of variational analysis? [1] > diff --git a/src/Applications/GEOSdas_App/testsuites/x0046a.input b/src/Applications/GEOSdas_App/testsuites/x0046a.input index 21dfbd2d..e3b45d5e 100644 --- a/src/Applications/GEOSdas_App/testsuites/x0046a.input +++ b/src/Applications/GEOSdas_App/testsuites/x0046a.input @@ -43,6 +43,9 @@ FVHOME? [/discover/nobackup/dao_it/x0046a] The directory /discover/nobackup/projects/gmao/obsdev/dao_it/x0046a already exists. Clean it? [y] > +Processing nodes (1:Westmere, 2:SandyBridge, 3:Ivy Bridge, 4:Haswell, 5:Skylake, 6:Cascase)? [4] +> + Which case of variational analysis? [1] > diff --git a/src/Applications/GEOSdas_App/testsuites/x0046aRPY.input b/src/Applications/GEOSdas_App/testsuites/x0046aRPY.input index 03e8427f..2172e382 100644 --- a/src/Applications/GEOSdas_App/testsuites/x0046aRPY.input +++ b/src/Applications/GEOSdas_App/testsuites/x0046aRPY.input @@ -43,6 +43,9 @@ FVHOME? [/discover/nobackup/dao_it/x0046aRPY] The directory /discover/nobackup/projects/gmao/obsdev/dao_it/x0046aRPY already exists. Clean it? [y] > +Processing nodes (1:Westmere, 2:SandyBridge, 3:Ivy Bridge, 4:Haswell, 5:Skylake, 6:Cascase)? [4] +> + Which case of variational analysis? [1] > From d5118b1625cd45f3f9b052a4affeb82e357985d3 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Thu, 21 Oct 2021 11:14:18 -0400 Subject: [PATCH 086/205] support for splitting diag files into subdirs --- .../NCEP_Etc/NCEP_enkf/scripts/gmao/etc/obs1gsi_mean.rc | 1 + .../NCEP_Etc/NCEP_enkf/scripts/gmao/etc/obs1gsi_member.rc | 1 + 2 files changed, 2 insertions(+) diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/obs1gsi_mean.rc b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/obs1gsi_mean.rc index 38aa95d0..8afcbf95 100644 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/obs1gsi_mean.rc +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/obs1gsi_mean.rc @@ -29,6 +29,7 @@ @RADBC newpc4pred=.true.,adp_anglebc=.true.,angord=4, @RADBC passive_bc=.true.,use_edges=.false., @RADBC diag_precon=.true.,step_start=1.e-3,emiss_bc=.true., + lrun_subdirs=.false., / &GRIDOPTS JCAP=@GSI_JCAP,NLAT=@GSI_JM,NLON=@GSI_IM,nsig=@GSI_LM, diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/obs1gsi_member.rc b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/obs1gsi_member.rc index 7cfc66d7..3df6806c 100644 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/obs1gsi_member.rc +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/obs1gsi_member.rc @@ -29,6 +29,7 @@ @RADBC newpc4pred=.true.,adp_anglebc=.true.,angord=4, @RADBC passive_bc=.true.,use_edges=.false., @RADBC diag_precon=.true.,step_start=1.e-3,emiss_bc=.true., + lrun_subdirs=.false., / &GRIDOPTS JCAP=@GSI_JCAP,NLAT=@GSI_JM,NLON=@GSI_IM,nsig=@GSI_LM, From 99a1c48b8732e7a74469ee71fcc4a261946c2634 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Thu, 21 Oct 2021 11:16:51 -0400 Subject: [PATCH 087/205] no shortening of exp name --- src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atm_ens.j | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atm_ens.j b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atm_ens.j index 3cf20135..e68a8be2 100755 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atm_ens.j +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atm_ens.j @@ -60,7 +60,7 @@ setenv CASE $EXPID # experiment ID (for LSM's sake) setenv FVROOT `cat $FVHOME/.FVROOT` setenv FVRUN $FVHOME/run - setenv BIGNAME `echo "$EXPID" | tr -s '[:lower:]' '[:upper:]'` + setenv BIGNAME `echo "$EXPID" | tr '[:lower:]' '[:upper:]'` if( (`uname -s` == "Linux") ) then if( `uname -m` != "ia64" ) then setenv FORT90L -Wl,-T From c3ae60be6ce1472f6bb0292d0b3f743151e9dd4c Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Thu, 21 Oct 2021 11:17:40 -0400 Subject: [PATCH 088/205] GSI only works now w/ perhost specified --- src/Applications/GEOSdas_App/Create_anasa_script.pm | 2 +- src/Applications/GEOSdas_App/Create_asens_script.pm | 2 +- src/Applications/GEOSdas_App/fvsetup | 4 ++-- .../NCEP_Etc/NCEP_enkf/scripts/gmao/etc/AtmEnsConfig.csh | 2 +- 4 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Applications/GEOSdas_App/Create_anasa_script.pm b/src/Applications/GEOSdas_App/Create_anasa_script.pm index 0e2b6583..2cab04db 100644 --- a/src/Applications/GEOSdas_App/Create_anasa_script.pm +++ b/src/Applications/GEOSdas_App/Create_anasa_script.pm @@ -388,7 +388,7 @@ EOF # --------------------------------- set ANAX = `which GSIsa.x` set SACX = `which sac.x` - setenv MPIRUN_ANA "esma_mpirun -np \$NCPUS \$ANAX" + setenv MPIRUN_ANA "esma_mpirun -perhost 8 -np \$NCPUS \$ANAX" # setenv MPIRUN_SAC "esma_mpirun -np \$NCPUS \$SACX" setenv MPIRUN_SAC "esma_mpirun -np 1 \$SACX" diff --git a/src/Applications/GEOSdas_App/Create_asens_script.pm b/src/Applications/GEOSdas_App/Create_asens_script.pm index accc813a..5ed24117 100644 --- a/src/Applications/GEOSdas_App/Create_asens_script.pm +++ b/src/Applications/GEOSdas_App/Create_asens_script.pm @@ -387,7 +387,7 @@ EOF # --------------------------------- set ANAX = `which GSIsa.x` set SACX = `which sac.x` - setenv MPIRUN_ANA "esma_mpirun -np \$NCPUS \$ANAX" + setenv MPIRUN_ANA "esma_mpirun -perhost 8 -np \$NCPUS \$ANAX" # setenv MPIRUN_SAC "esma_mpirun -np \$NCPUS \$SACX" setenv MPIRUN_SAC "esma_mpirun -np 1 \$SACX" diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index 30b1858f..40978f2f 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -7964,7 +7964,7 @@ print SCRIPT <<"EOF"; #-setenv MPIRUN_IAU "PBS_NODEFILE=\$FVWORK/IAU_list; esma_mpirun -np \$NCPUS_IAU \$IAUX" setenv MPIRUN_IAU "esma_mpirun -np \$NCPUS_IAU \$IAUX" #-setenv MPIRUN_UPRST "esma_mpirun -np \$NCPUS_IAU \$RSTUPDX" - setenv MPIRUN_ANA "PBS_NODEFILE=\$FVWORK/ANA_list; esma_mpirun -np \$NCPUS_GSI \$ANAX" + setenv MPIRUN_ANA "PBS_NODEFILE=\$FVWORK/ANA_list; esma_mpirun -perhost 8 -np \$NCPUS_GSI \$ANAX" setenv MPIRUN_OBSVR "esma_mpirun -np \$NCPUS_GSI \$ANAX" setenv MPIRUN_SAC "esma_mpirun -np 1 \$SACX" setenv MPIRUN_OIQC "PBS_NODEFILE=\$FVWORK/OIQC_list; esma_mpirun -np 4" @@ -9147,7 +9147,7 @@ print SCRIPT <<"EOF"; setenv OMP_NUM_THREADS $omp_num_threads setenv MPIRUN_IDF "esma_mpirun -np \$NCPUS_IDF \$IDFX" setenv MPIRUN_IAU "esma_mpirun -np \$NCPUS_IAU \$IAUX" - setenv MPIRUN_ANA "PBS_NODEFILE=\$FVWORK/ANA_list; esma_mpirun -np \$NCPUS_GSI \$ANAX" + setenv MPIRUN_ANA "PBS_NODEFILE=\$FVWORK/ANA_list; esma_mpirun -perhost 8 -np \$NCPUS_GSI \$ANAX" setenv MPIRUN_OBSVR "PBS_NODEFILE=\$FVWORK/ANA_list; esma_mpirun -np \$NCPUS_GSI \$ANAX" setenv MPIRUN_SAC "esma_mpirun -np 1 \$SACX" setenv MPIRUN_OIQC "PBS_NODEFILE=\$FVWORK/OIQC_list; esma_mpirun -np 4" diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/AtmEnsConfig.csh b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/AtmEnsConfig.csh index c45cca29..50680a00 100644 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/AtmEnsConfig.csh +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/AtmEnsConfig.csh @@ -137,7 +137,7 @@ setenv AENS_PERTS_DSTJOB 8 setenv PERTS_QNAME $ATMENS_QNAME setenv PERTS_WALLCLOCK 1:00:00 setenv PERTS_NCPUS 24 -setenv PERTS_ENSTAT_MPIRUN "$ATMENS_MPIRUN -np $PERTS_NCPUS mp_stats.x" +setenv PERTS_ENSTAT_MPIRUN "$ATMENS_MPIRUN -perhost 2 -np $PERTS_NCPUS mp_stats.x" # pert-energy calculation #------------------------ From 2d4d9db4ef602bf5ced4faaa5ca52452fe47f924 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Thu, 21 Oct 2021 11:18:27 -0400 Subject: [PATCH 089/205] ENKF a little more memory hungry w/ compiler/mpi upgrade --- .../NCEP_Etc/NCEP_enkf/scripts/gmao/setup_atmens.pl | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/setup_atmens.pl b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/setup_atmens.pl index cecd2d69..8751004f 100755 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/setup_atmens.pl +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/setup_atmens.pl @@ -221,7 +221,7 @@ sub init { $obsv_im = 288; $obsv_jm = 181; $obsv_lm = $nlevs; $obsv_jcap = 126; } if ( $agcm_im == 180 ){ - $enkf_cpus = 224; + $enkf_cpus = 368; $agcm_nx = 7; $agcm_ny = 12; $miau_nx = 2; $miau_ny = 12; $obsv_nx = 4; $obsv_ny = 14; @@ -233,7 +233,7 @@ sub init { $obsv_im = 576; $obsv_jm = 361; $obsv_lm = $nlevs; $obsv_jcap = 254; } if ( $agcm_im == 360 ){ - $enkf_cpus = 224; + $enkf_cpus = 736; $agcm_nx = 3; $agcm_ny = 72; $miau_nx = 4; $miau_ny = 24; $obsv_nx = 4; $obsv_ny = 14; From ef599e7d5f50c54ccc3d7e70ec31a40fb62f5c93 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Wed, 27 Oct 2021 15:04:30 -0400 Subject: [PATCH 090/205] properly finalize GEOSgcmPert.x --- src/Applications/GEOSgcmPert_App/GEOSgcmPert.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Applications/GEOSgcmPert_App/GEOSgcmPert.F90 b/src/Applications/GEOSgcmPert_App/GEOSgcmPert.F90 index c281e0e5..e4bd0c55 100644 --- a/src/Applications/GEOSgcmPert_App/GEOSgcmPert.F90 +++ b/src/Applications/GEOSgcmPert_App/GEOSgcmPert.F90 @@ -826,7 +826,8 @@ subroutine PERT_CAP(ROOT_SetServices, Name, AmIRoot, RC) call ESMF_FieldBundleDestroy (LLPertBundle, __RC__) call t_p%stop('geosgcmpert.x') call MAPL_Finalize() -! call ESMF_Finalize (__RC__) + call pert_server%finalize() + call ESMF_Finalize (__RC__) end subroutine PERT_CAP From c025be76feb738ca9ddccaef3469153ad271b54c Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Thu, 28 Oct 2021 13:36:47 -0400 Subject: [PATCH 091/205] Support for Skylake and Cascade --- src/Applications/GEOSdas_App/AGCMrc.pm | 24 +- src/Applications/GEOSdas_App/fvsetup | 240 +++++++++--------- src/Applications/GEOSdas_App/gen_lnbcs.pl | 66 ++++- .../GEOSdas_App/testsuites/prePP.input | 6 +- .../GEOSdas_App/testsuites/x0046a.input | 4 +- .../NCEP_Etc/NCEP_enkf/scripts/gmao/atm_ens.j | 3 +- .../NCEP_enkf/scripts/gmao/etc/AGCM.rc.tmpl | 30 +-- .../scripts/gmao/etc/AtmEnsConfig.csh | 3 + .../scripts/gmao/etc/AtmOSEConfig.csh | 2 + .../NCEP_enkf/scripts/gmao/gcm_ensemble.csh | 4 + .../scripts/gmao/job_distributor.csh | 21 +- .../NCEP_Etc/NCEP_enkf/scripts/gmao/jobgen.pl | 11 +- .../NCEP_enkf/scripts/gmao/setup_atmens.pl | 104 ++++++-- 13 files changed, 322 insertions(+), 196 deletions(-) diff --git a/src/Applications/GEOSdas_App/AGCMrc.pm b/src/Applications/GEOSdas_App/AGCMrc.pm index edbb34da..41969310 100644 --- a/src/Applications/GEOSdas_App/AGCMrc.pm +++ b/src/Applications/GEOSdas_App/AGCMrc.pm @@ -33,14 +33,16 @@ our @EXPORT_OK = qw ( set_AGCM_envvars #----------------- my ($gocart_tracers, $carma_tracers, $iau, $pcp_forced, $lsmodel_flag); my ($fvhome, $fvroot); +my ($coupled); my ($envvars_set, $flags_set, %subst); #---------------------------------- # GCM Restart files #---------------------------------- -my (@rs5_core, @rs5_boot, @rs5_others, @rs5_notused, @rs5_files); +my (@rs5_core, @rs5_boot, @rs5_coupled, @rs5_others, @rs5_notused, @rs5_files); my %list = (rs5_core => \@rs5_core, rs5_boot => \@rs5_boot, + rs5_coupled => \@rs5_coupled, rs5_others => \@rs5_others, rs5_obsolete => \@rs5_notused, # maintain obsolete interface rs5_notused => \@rs5_notused, @@ -87,6 +89,11 @@ my %list = (rs5_core => \@rs5_core, traj_lcv_rst ptrj_prs_rst ); +# needed for coupled model +@rs5_coupled = qw ( ocean_internal_rst + seaice_import_rst + seaice_internal_rst ); + # these restarts are currently not in use @rs5_notused = qw ( aiau_import_rst aiau_import_checkout @@ -98,15 +105,10 @@ my %list = (rs5_core => \@rs5_core, hemco_internal_rst hemco_import_rst mam_internal_rst - ocean_internal_rst orad_import_rst - seaice_import_rst - seaice_internal_rst stratchem_internal_rst stratchem_import_rst ); -# this array includes all but the notused restarts -@rs5_files = (@rs5_core, @rs5_boot, @rs5_others); #======================================================================= # name - set_AGCM_envvars @@ -118,7 +120,17 @@ sub set_AGCM_envvars { $envvars_set = 0; $fvhome = hashextract("fvhome",%envvars); $fvroot = hashextract("fvroot",%envvars); + $coupled = hashextract("coupled",%envvars); $envvars_set = 1; + + # this array includes all but the notused restarts + if ( $coupled ) { + @rs5_files = (@rs5_core, @rs5_boot, @rs5_coupled, @rs5_others); + } else { + @rs5_notused = (@rs5_notused, @rs5_coupled); + @rs5_files = (@rs5_core, @rs5_boot, @rs5_others); + } + } #======================================================================= diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index 40978f2f..9c01672e 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -385,6 +385,7 @@ my ($qsub); my ($acqloc); my ($fcstimes,$fcswait_hrs,$asnwait_hrs); my ($landbcs); +my ($coupled, $ores); my ($sysfile, $nodeflg); my (@rmTilde); @@ -2277,7 +2278,7 @@ sub ed_g5cap_rc { if($rcd =~ /\@DT/) {$rcd=~ s/\@DT/$dt/g; } if($rcd =~ /\@OCEAN_IM/) {$rcd=~ s/\@OCEAN_IM/$ogcm_im/g; } if($rcd =~ /\@OCEAN_JM/) {$rcd=~ s/\@OCEAN_JM/$ogcm_jm/g; } - if($rcd =~ /\@OCEAN_LM/) {$rcd=~ s/\@OCEAN_LM/$ogcm_km/g; } + if($rcd =~ /\@OCEAN_LM/) {$rcd=~ s/\@OCEAN_LM/$ogcm_lm/g; } if($rcd =~ /\@BEG_DATE/) {$rcd=~ s/\@BEG_DATE/$beg_date/g; } if($rcd =~ /\@END_DATE/) {$rcd=~ s/\@END_DATE/$myedate/g; } if($rcd =~ /\@NUM_SGMT/) {$rcd=~ s/\@NUM_SGMT/9999/g; } # this is a dummy varible for L.Takacs script only @@ -2668,16 +2669,22 @@ sub get_fvbcs { $sstfile = "dataoceanfile_MERRA_sst_1971-current.$ogrid.LE"; $icefile = "dataoceanfile_MERRA_fraci_1971-current.$ogrid.LE"; } - if ($ogcm eq "e") { + elsif ($ogcm eq "e") { $fvrtbcs = "$fvbcs/g5gcm/bcs/SST/$ogrid"; $sstfile = "dataoceanfile_MERRA2_SST.$ogrid.\$year.data"; $icefile = "dataoceanfile_MERRA2_ICE.$ogrid.\$year.data"; + } + elsif ($ogcm eq "f" || $ogcm eq "C") { + $fvrtbcs = "$fvbcs/g5gcm/bcs/realtime/OSTIA_REYNOLDS"; + $sstfile = "dataoceanfile_OSTIA_REYNOLDS_SST.$ogrid.\$year.data"; + $icefile = "dataoceanfile_OSTIA_REYNOLDS_ICE.$ogrid.\$year.data"; } - if ($ogcm eq "f" || $ogcm eq "C") { + elsif ($ogcm eq "T") { # this will need revision (RT) $fvrtbcs = "$fvbcs/g5gcm/bcs/realtime/OSTIA_REYNOLDS"; $sstfile = "dataoceanfile_OSTIA_REYNOLDS_SST.$ogrid.\$year.data"; $icefile = "dataoceanfile_OSTIA_REYNOLDS_ICE.$ogrid.\$year.data"; } + else { die "Abort: Not yet ready for this ocean-model resolution $ogcm_id\n"; } print <<"EOF"; @@ -3026,7 +3033,7 @@ sub get_nodeflg { elsif ($ans == 3) { $nodeflg = "ivy"; $ncpus_per_node = 20 } elsif ($ans == 4) { $nodeflg = "hasw"; $ncpus_per_node = 24 } elsif ($ans == 5) { $nodeflg = "sky"; $ncpus_per_node = 36 } - elsif ($ans == 6) { $nodeflg = "cas"; $ncpus_per_node = 42 } + elsif ($ans == 6) { $nodeflg = "cas"; $ncpus_per_node = 46 } # currently not applicable at nccs #--------------------------------- @@ -3598,7 +3605,7 @@ EOF $flags .= " -fvhome $fvhome" if $checkFLG; $params = " $aens_ana $expid $aens_im $aens_jm $aens_ocn $landbcs"; - $cmd = "$fvbin/setup_atmens.pl $flags $params"; + $cmd = "$fvbin/setup_atmens.pl -nodename $nodeflg $flags $params"; print "$cmd\n"; system($cmd); @@ -3611,6 +3618,7 @@ EOF $replace{">>>FVHOME<<<"} = "$fvhome"; $replace{">>>LDAS_ANA<<<"} = $ldas_ana; $replace{">>>LDHOME4ENS<<<"} = "$ldashome4ens"; + $replace{">>>NCPUS_PER_NODE<<<"} = "$ncpus_per_node"; $atm_ens_j = "$fvhome/run/atm_ens.j"; $atm_ens_j_tilde = "${atm_ens_j}~"; @@ -4645,19 +4653,23 @@ G5GCM SETTINGS e : 1/4-deg (1440x720); e.g. MERRA-2 f : 1/8-deg (2880x1440); e.g. OSTIA C : OSTIA cubed BCs consistent w/ Atmos res + T11 : Coupled (Tripolar-1-degree) + T12 : Coupled (Tripolar-1/2-degrees) + T14 : Coupled (Tripolar-1/4-degrees) + T18 : Coupled (Tripolar-1/8-degrees) EOF - $res = query(" AGCM Horizontal Resolution?", $res); - $vres = query(" AGCM Vertical Resolution?", $vres); - $ores = query(" OGCM Resolution?", $ores); + $res = query(" AGCM Horizontal Resolution?", $res); + $vres = query(" AGCM Vertical Resolution?", $vres); + $ores = query(" OGCM Resolution?", $ores); - $coupled = 0; $cubed = 0; $nx_pert = 1; $ny_pert = 6 * $nx_pert; $use_shmem = 0; $ios_nds = 1; + $cldmicro = "1MOMENT"; if ( "$res" eq "c" && "$vres" eq "55" ) { $anahgrd = substr($res,0,1); $nx = 4; @@ -4672,11 +4684,7 @@ EOF $chemdt = $dt; $solardt = 3600; $irraddt = 3600; - if ( $coupled == 1 ) { - $ogcmrdt = $dt; - } else { - $ogcmrdt = $irraddt; - } + $ogcmrdt = $irraddt; $ana_im = $agcm_im; $ana_jm = $agcm_jm; $hist_im = $agcm_im; @@ -4705,11 +4713,7 @@ EOF $chemdt = $dt; $solardt = 3600; $irraddt = 3600; - if ( $coupled == 1 ) { - $ogcmrdt = $dt; - } else { - $ogcmrdt = $irraddt; - } + $ogcmrdt = $irraddt; $ana_im = $agcm_im; $ana_jm = $agcm_jm; $hist_im = $agcm_im; @@ -4738,11 +4742,7 @@ EOF $chemdt = $dt; $solardt = 3600; $irraddt = 3600; - if ( $coupled == 1 ) { - $ogcmrdt = $dt; - } else { - $ogcmrdt = $irraddt; - } + $ogcmrdt = $irraddt; $ana_im = $agcm_im; $ana_jm = $agcm_jm; $hist_im = $agcm_im; @@ -4771,11 +4771,7 @@ EOF $chemdt = $dt; $solardt = 3600; $irraddt = 3600; - if ( $coupled == 1 ) { - $ogcmrdt = $dt; - } else { - $ogcmrdt = $irraddt; - } + $ogcmrdt = $irraddt; $ana_im = $agcm_im; $ana_jm = $agcm_jm; $hist_im = $agcm_im; @@ -4802,11 +4798,7 @@ EOF $chemdt = $dt; $solardt = 3600; $irraddt = 3600; - if ( $coupled == 1 ) { - $ogcmrdt = $dt; - } else { - $ogcmrdt = $irraddt; - } + $ogcmrdt = $irraddt; $ana_im = $agcm_im; $ana_jm = $agcm_jm; $hist_im = $agcm_im; @@ -4837,11 +4829,7 @@ EOF $chemdt = $dt; $solardt = 3600; $irraddt = 3600; - if ( $coupled == 1 ) { - $ogcmrdt = $dt; - } else { - $ogcmrdt = $irraddt; - } + $ogcmrdt = $irraddt; $ana_im = 576; $ana_jm = 361; $hist_im = $agcm_im; @@ -4872,11 +4860,7 @@ EOF $chemdt = $dt; $solardt = 3600; $irraddt = 3600; - if ( $coupled == 1 ) { - $ogcmrdt = $dt; - } else { - $ogcmrdt = $irraddt; - } + $ogcmrdt = $irraddt; $ana_im = $agcm_im; $ana_jm = $agcm_jm; $hist_im = $agcm_im; @@ -4906,11 +4890,7 @@ EOF $chemdt = $dt; $solardt = 3600; $irraddt = 3600; - if ( $coupled == 1 ) { - $ogcmrdt = $dt; - } else { - $ogcmrdt = $irraddt; - } + $ogcmrdt = $irraddt; $ana_im = 144; #$agcm_im * 4; $ana_jm = 91; #$agcm_im * 2 + 1; $hist_im = $ana_im; @@ -4942,11 +4922,7 @@ EOF $chemdt = $dt; $solardt = 3600; $irraddt = 3600; - if ( $coupled == 1 ) { - $ogcmrdt = $dt; - } else { - $ogcmrdt = $irraddt; - } + $ogcmrdt = $irraddt; $ana_im = 288; #$agcm_im * 4; $ana_jm = 181; #$agcm_im * 2 + 1; $hist_im = $ana_im; @@ -4979,11 +4955,7 @@ EOF $chemdt = $dt; $solardt = 3600; $irraddt = 3600; - if ( $coupled == 1 ) { - $ogcmrdt = $dt; - } else { - $ogcmrdt = $irraddt; - } + $ogcmrdt = $irraddt; $ana_im = 576; #$agcm_im * 4; $ana_jm = 361; #$agcm_im * 2 + 1; $hist_im = $ana_im; @@ -5016,11 +4988,7 @@ EOF $chemdt = $dt; $solardt = 3600; $irraddt = 3600; - if ( $coupled == 1 ) { - $ogcmrdt = $dt; - } else { - $ogcmrdt = $irraddt; - } + $ogcmrdt = $irraddt; $ana_im = 576; $ana_jm = 361; $hist_im = 1152; @@ -5054,11 +5022,7 @@ EOF $chemdt = $dt; $solardt = 3600; $irraddt = 3600; - if ( $coupled == 1 ) { - $ogcmrdt = $dt; - } else { - $ogcmrdt = $irraddt; - } + $ogcmrdt = $irraddt; $ana_im = 1152; #$agcm_im * 4; $ana_jm = 721; #$agcm_im * 2 + 1; $hist_im = $ana_im; @@ -5092,11 +5056,7 @@ EOF $chemdt = $dt; $solardt = 3600; $irraddt = 3600; - if ( $coupled == 1 ) { - $ogcmrdt = $dt; - } else { - $ogcmrdt = $irraddt; - } + $ogcmrdt = $irraddt; $ana_im = 1152; #$agcm_im * 4; $ana_jm = 721; #$agcm_im * 2 + 1; $hist_im = $ana_im; @@ -5137,47 +5097,75 @@ EOF $hres = substr ( $res, 0, 1 ); - # Resolution dependent settings - $mem = "4gb"; - $mem = "8gb" if ( $agcm_im == 288 && $agcm_jm == 181 ); - $mem = "16gb" if ( $agcm_im == 576 && $agcm_jm == 361 ); - - $ogcm = substr($ores, 0, 1); - $ogcm_km = substr($ores, 1, 2); - - if ($ogcm eq "c") { - $ogcm_grid_type = "LatLon"; - $ogcm_im = 360; - $ogcm_jm = 180; - $ogcm_nf = 1; - $cube_ogcm = "#"; - $latlon_ogcm = ""; - } - elsif ($ogcm eq "e") { - $ogcm_grid_type = "LatLon"; - $ogcm_im = 1440; - $ogcm_jm = 720; - $ogcm_nf = 1; - $cube_ogcm = "#"; - $latlon_ogcm = ""; - } - elsif ($ogcm eq "f") { - $ogcm_grid_type = "LatLon"; - $ogcm_im = 2880; - $ogcm_jm = 1440; - $ogcm_nf = 1; - $cube_ogcm = "#"; - $latlon_ogcm = ""; - } - elsif ($ogcm eq "C") { - $ogcm_grid_type = "Cubed-Sphere"; - $ogcm_im = $agcm_im; - $ogcm_jm = $agcm_jm; - $ogcm_nf = 6; - $cube_ogcm = ""; - $latlon_ogcm = "#"; + # Resolution dependent settings + $mem = "4gb"; + $mem = "8gb" if ( $agcm_im == 288 && $agcm_jm == 181 ); + $mem = "16gb" if ( $agcm_im == 576 && $agcm_jm == 361 ); + + $ogcm = substr($ores, 0, 1); + $ogcm_id = substr($ores, 1, 2); + + $coupled = 0; + if ($ogcm eq "c") { + $ogcm_grid_type = "LatLon"; + $ogcm_im = 360; + $ogcm_jm = 180; + $ogcm_lm = 34; + $ogcm_nf = 1; + $cube_ogcm = "#"; + $latlon_ogcm = ""; + } + elsif ($ogcm eq "e") { + $ogcm_grid_type = "LatLon"; + $ogcm_im = 1440; + $ogcm_jm = 720; + $ogcm_lm = 34; + $ogcm_nf = 1; + $cube_ogcm = "#"; + $latlon_ogcm = ""; + } + elsif ($ogcm eq "f") { + $ogcm_grid_type = "LatLon"; + $ogcm_im = 2880; + $ogcm_jm = 1440; + $ogcm_lm = 34; + $ogcm_nf = 1; + $cube_ogcm = "#"; + $latlon_ogcm = ""; + } + elsif ($ogcm eq "C") { + $ogcm_grid_type = "Cubed-Sphere"; + $ogcm_im = $agcm_im; + $ogcm_jm = $agcm_jm; + $ogcm_lm = 34; + $ogcm_nf = 6; + $cube_ogcm = ""; + $latlon_ogcm = "#"; + } + elsif ($ogcm eq "T") { + $coupled = 1; + $ocean_name = "MOM6"; + $ogcmrdt = $dt; + $ogcm_grid_type = "Tripolar"; + if ( $ogcm_id eq "11" ) { + die "Abort: Not yet ready for this ocean-model resolution $ogcm_id\n"; + } + elsif ( $ogcm_id eq "12" ) { + die "Abort: Not yet ready for this ocean-model resolution $ogcm_id\n"; + } + elsif ( $ogcm_id eq "14" ) { + $ogcm_im = 1440; + $ogcm_jm = 1080; + $ogcm_lm = 75; + $ogcm_nx = 40; + $ogcm_ny = 30; + } + elsif ( $ogcm_id eq "18" ) { + die "Abort: Not yet ready for this ocean-model resolution $ogcm_id\n"; + } + else { die "Error: Unsupported ocean-model resolution $ogcm_id\n"; } } - else { die "Error: Cannot recognize Ocean Horizontal Resolution Code $ogcm;" } + else { die "Error: Cannot recognize Ocean Horizontal Resolution Code $ogcm \n;" } $ogrid = "${ogcm_im}x${ogcm_jm}"; $agcm_im4 = sprintf "%04i", $agcm_im; @@ -5186,10 +5174,7 @@ EOF $ogcm_jm4 = sprintf "%04i", $ogcm_jm; - if ($ogcm_km ne "34") { - $ogcm_km = 34; - print " Hard-wiring Ocean Vertical Resolution to $ogcm_km\n" - } + print " Ocean Vertical Resolution to $ogcm_lm\n"; $is_fcst = 0; # eventually SST will be persisted after initial read, # but for now leave things as they are since results are @@ -5213,7 +5198,11 @@ EOF $hist_jm = $agcm_jm; $iauexec = "makeiau.x"; $AGCM_GRIDNAME = "PC${agcm_im}x${agcm_jm}-DC"; - $OGCM_GRIDNAME = "PE${ogcm_im}x${ogcm_jm}-DE"; + if ( $coupled ) { + $OGCM_GRIDNAME = "PE${ogcm_im}x${ogcm_jm}-TM"; + } else { + $OGCM_GRIDNAME = "PE${ogcm_im}x${ogcm_jm}-DE"; + } } return 0 ; @@ -7414,9 +7403,9 @@ sub build_lnbcs { $mymerra2 = ""; if ( $merra2 ) { $mymerra2 = "-merra2" }; if ( $cubed ) { - $cmd = "$fvbin/gen_lnbcs.pl -fvhome $fvhome -o lnbcs $mymerra2 -cubed $agcm_im $agcm_jm $ogcm $landbcs"; + $cmd = "$fvbin/gen_lnbcs.pl -fvhome $fvhome -o lnbcs $mymerra2 -cubed $agcm_im $agcm_jm $ores $landbcs"; } else { - $cmd = "$fvbin/gen_lnbcs.pl -fvhome $fvhome -o lnbcs $mymerra2 $agcm_im $agcm_jm $ogcm $landbcs"; + $cmd = "$fvbin/gen_lnbcs.pl -fvhome $fvhome -o lnbcs $mymerra2 $agcm_im $agcm_jm $ores $landbcs"; } print "$cmd\n"; system($cmd); @@ -9489,6 +9478,7 @@ sub init_agcm_rc { $envvars{"fvhome"} = $fvhome; $envvars{"fvroot"} = $fvroot; + $envvars{"coupled"} = $coupled; set_AGCM_envvars(%envvars); $flags{"gocart_tracers"} = $gocart_tracers; @@ -9558,19 +9548,25 @@ sub init_agcm_rc { AGCM_label_subst("\@NUM_READERS", $num_readers); AGCM_label_subst("\@NUM_WRITERS", 1); #_RT: for now, it seems not good to have it larger than 1 + AGCM_label_subst("\@OCEAN_NAME", $ocean_name); AGCM_label_subst("\@OGCM_IM", $ogcm_im); AGCM_label_subst("\@OGCM_JM", $ogcm_jm); - AGCM_label_subst("\@OGCM_LM", $ogcm_km); + AGCM_label_subst("\@OGCM_LM", $ogcm_lm); AGCM_label_subst("\@OGCM_NF", $ogcm_nf); AGCM_label_subst("\@OGCM_GRID_TYPE", $ogcm_grid_type); AGCM_label_subst("\@CUBE_OGCM", $cube_ogcm); AGCM_label_subst("\@LATLON_OGCM", $latlon_ogcm); + AGCM_label_subst("\@CLDMICRO", $cldmicro); + AGCM_label_subst("\@DT", $dt); AGCM_label_subst("\@CHEM_DT", $chemdt); AGCM_label_subst("\@SOLAR_DT", $solardt); AGCM_label_subst("\@IRRAD_DT", $irraddt); + AGCM_label_subst("\@OCEAN_DT", $ogcmrdt); + AGCM_label_subst("\@OGCM_NX", $ogcm_nx); + AGCM_label_subst("\@OGCM_NY", $ogcm_ny); AGCM_label_subst("\@DASTUNING", $dastuning); diff --git a/src/Applications/GEOSdas_App/gen_lnbcs.pl b/src/Applications/GEOSdas_App/gen_lnbcs.pl index 4116599f..af65b03d 100755 --- a/src/Applications/GEOSdas_App/gen_lnbcs.pl +++ b/src/Applications/GEOSdas_App/gen_lnbcs.pl @@ -65,7 +65,7 @@ sub init { } else { # required command line args $agcm_im = $ARGV[0]; $agcm_jm = $ARGV[1]; - $ogcm = $ARGV[2]; + $ogcmres = $ARGV[2]; $lndbcs = $ARGV[3]; } @@ -92,6 +92,10 @@ sub init { $outfile = "$opt_fvhome/run/$outfile"; } +$ogcm = substr($ogcmres, 0, 1); +$ogcm_id = substr($ogcmres, 1, 2); + +$coupled = 0; if ($ogcm eq "c") { $ogcm_im = 360; $ogcm_jm = 180; @@ -136,10 +140,27 @@ sub init { $sstfile = "dataoceanfile_OSTIA_REYNOLDS_SST.$ogrid.\$year.data"; $icefile = "dataoceanfile_OSTIA_REYNOLDS_ICE.$ogrid.\$year.data"; } +elsif ($ogcm eq "T") { # Coupled-Tripolar-Ocean + $coupled = 1; + if ($ogcm_id eq "14" ) { + $ogcm_im = 1440; + $ogcm_jm = 1080; + $ogcm_lm = 75; + } else { + die "ERROR: Ocean resolution not supported, $ogcmres"; + } + $ogrid = "${ogcm_im}x${ogcm_jm}"; + if ( $lndbcs eq "Icarus-NLv3" ) { + $BCSTAG = "$lndbcs/Icarus-NLv3_Ostia"; + } else { + $BCSTAG = "$lndbcs/Icarus_Ostia"; + } + $fvrtbcs = "g5gcm/bcs/realtime/OSTIA_REYNOLDS"; + $sstfile = "dataoceanfile_OSTIA_REYNOLDS_SST.$ogrid.\$year.data"; + $icefile = "dataoceanfile_OSTIA_REYNOLDS_ICE.$ogrid.\$year.data"; +} -$coupled = 0; - } #...................................................................... sub create_g5bcs_script { @@ -219,25 +240,44 @@ sub create_g5bcs_script { setenv CUBED $cubed setenv G5GCMBCS \$FVHOME/fvInput/g5gcm/bcs setenv G5GRTBCS \$FVHOME/fvInput/$fvrtbcs +# wired ocean bcs location for now + setenv OGCMBCS /discover/nobackup/projects/gmao/ssd/aogcm/ocean_bcs # Possibly real-time boundary conditions # -------------------------------------- if ( \$COUPLED ) then - if ( ! -e \$G5GRTBCS/$ogrid/SEAWIFS_KPAR_mon_clim.$ogrid ) exit 1 - /bin/ln -sf \$G5GRTBCS/$ogrid/SEAWIFS_KPAR_mon_clim.$ogrid SEAWIFS_KPAR_mon_clim.data + if ( ! -e \$OGCMBCS/MOM6/$ogrid/SEAWIFS_KPAR_mon_clim.$ogrid ) exit 1 + /bin/ln -sf \$OGCMBCS/MOM6/$ogrid/SEAWIFS_KPAR_mon_clim.$ogrid SEAWIFS_KPAR_mon_clim.data + + if ( ! -e \$OGCMBCS/MOM6/${OGCM_GRIDNAME}_TM${ogcm_im}xTM${ogcm_jm}/${OGCM_GRIDNAME}_TM${ogcm_im}xTM${ogcm_jm}-Pfafstetter.til ) exit 1 + /bin/ln -sf \$OGCMBCS/MOM6/${OGCM_GRIDNAME}_TM${ogcm_im}xTM${ogcm_jm}/${OGCM_GRIDNAME}_TM${ogcm_im}xTM${ogcm_jm}-Pfafstetter.til tile.data + + if ( ! -e \$OGCMBCS/MOM6/${OGCM_GRIDNAME}_TM${ogcm_im}xTM${ogcm_jm}/${OGCM_GRIDNAME}_TM${ogcm_im}xTM${ogcm_jm}-Pfafstetter.TRN ) exit 1 + /bin/ln -sf \$OGCMBCS/MOM6/${OGCM_GRIDNAME}_TM${ogcm_im}xTM${ogcm_jm}/${OGCM_GRIDNAME}_TM${ogcm_im}xTM${ogcm_jm}-Pfafstetter.TRN runoff.bin + + if ( ! -e \$OGCMBCS/MOM6/${ogcm_im}x${ogcm_jm}/MAPL_Tripolar.nc ) exit 1 + /bin/ln -sf \$OGCMBCS/MOM6/${ogcm_im}x${ogcm_jm}/MAPL_Tripolar.nc . + + if ( ! -e \$OGCMBCS/MOM6/${ogcm_im}x${ogcm_jm}/vgrid${ogcm_lm}.ascii ) exit 1 + /bin/ln -sf \$OGCMBCS/MOM6/${ogcm_im}x${ogcm_jm}/vgrid${ogcm_lm}.ascii vgrid.ascii + + if ( ! -e \$OGCMBCS/MOM6/$ogrid/tripolar_$ogrid.ascii ) exit 1 + /bin/ln -sf \$OGCMBCS/MOM6/$ogrid/tripolar_$ogrid.ascii . - if ( ! -e \$G5GRTBCS/DC${agcm_im}xPC${agcm_jm}_TM${ogcm_im}xTM${ogcm_jm}-Pfafstetter.til ) exit 1 - /bin/ln -sf \$G5GRTBCS/DC${agcm_im}xPC${agcm_jm}_TM${ogcm_im}${ogcm_jm}-Pfafstetter.til tile.data + if ( ! -e \$OGCMBCS/MOM6/$ogrid/vgrid50.ascii ) exit 1 + /bin/ln -sf \$OGCMBCS/MOM6/$ogrid/vgrid50.ascii vgrid.ascii - if ( ! -e \$G5GRTBCS/DC${agcm_im}xPC${agcm_jm}_TM${ogcm_im}${ogcm_jm}-Pfafstetter.TRN ) exit 1 - /bin/ln -sf \$G5GRTBCS/DC${agcm_im}xPC${agcm_jm}_TM${ogcm_im}${ogcm_jm}-Pfafstetter.TRN runoff.bin + if ( ! -e \$OGCMBCS/MOM6/${ogcm_im}x${ogcm_jm}/cice/kmt_cice.bin ) exit 1 + /bin/ln -sf \$OGCMBCS/MOM6/${ogcm_im}x${ogcm_jm}/cice/kmt_cice.bin . - if ( ! -e \$G5GRTBCS/$ogrid/tripolar_$ogrid.ascii ) exit 1 - /bin/ln -sf \$G5GRTBCS/$ogrid/tripolar_$ogrid.ascii . + if ( ! -e \$OGCMBCS/MOM6/${ogcm_im}x${ogcm_jm}/cice/grid_cice.bin ) exit 1 + /bin/ln -sf \$OGCMBCS/MOM6/${ogcm_im}x${ogcm_jm}/cice/grid_cice.bin . - if ( ! -e \$G5GRTBCS/$ogrid/vgrid50.ascii ) exit 1 - /bin/ln -sf \$G5GRTBCS/$ogrid/vgrid50.ascii vgrid.ascii + # now comes the mess: + if ( -d INPUT ) /bin/rm -r INPUT + mkdir INPUT + /bin/cp \$OGCMBCS/MOM6/${ogcm_im}x${ogcm_jm}/INPUT/* INPUT else diff --git a/src/Applications/GEOSdas_App/testsuites/prePP.input b/src/Applications/GEOSdas_App/testsuites/prePP.input index 90f0f342..efda015a 100644 --- a/src/Applications/GEOSdas_App/testsuites/prePP.input +++ b/src/Applications/GEOSdas_App/testsuites/prePP.input @@ -44,7 +44,7 @@ The directory /discover/nobackup/projects/gmao/dadev/rtodling/prePP does not exi > Processing nodes (1:Westmere, 2:SandyBridge, 3:Ivy Bridge, 4:Haswell, 5:Skylake, 6:Cascase)? [4] -> +> 5 Which case of variational analysis? [1] > @@ -107,10 +107,10 @@ Number of one-day DAS segments per PBS job? [1] > Number of PEs in the zonal direction (NX)? [28] -> 12 +> 24 Number of PEs in the meridional direction (NY)? [48] -> 288 +> 144 Job nickname? [g5das] > $expid diff --git a/src/Applications/GEOSdas_App/testsuites/x0046a.input b/src/Applications/GEOSdas_App/testsuites/x0046a.input index e3b45d5e..1009ac7b 100644 --- a/src/Applications/GEOSdas_App/testsuites/x0046a.input +++ b/src/Applications/GEOSdas_App/testsuites/x0046a.input @@ -107,10 +107,10 @@ Number of one-day DAS segments per PBS job? [1] > Number of PEs in the zonal direction (NX)? [8] -> 16 +> 12 Number of PEs in the meridional direction (NY)? [48] -> +> 72 Job nickname? [g5das] > x46 diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atm_ens.j b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atm_ens.j index e68a8be2..dde126e5 100755 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atm_ens.j +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atm_ens.j @@ -3,7 +3,7 @@ #SBATCH --account=>>>GID<<< #SBATCH --constraint=>>>NODEFLG<<< #SBATCH --ntasks=96 -#SBATCH --ntasks-per-node=24 +#SBATCH --ntasks-per-node=>>>NCPUS_PER_NODE<<< #SBATCH --time=6:00:00 # #SBATCH --job-name=atm_ens @@ -49,6 +49,7 @@ # setenv JOBGEN_QOS dastest # setenv JOBGEN_ARCH_CONSTRAINT cssrw setenv JOBGEN_CONSTRAINT >>>NODEFLG<<< +# setenv JOBGEN_NCPUS_PER_NODE >>>NCPUS_PER_NODE<<< setenv ATMENS_QNAME compute if ( $?JOBGEN_PARTITION ) then setenv ATMENS_QNAME $JOBGEN_PARTITION diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/AGCM.rc.tmpl b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/AGCM.rc.tmpl index 39718512..8aae31e9 100644 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/AGCM.rc.tmpl +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/AGCM.rc.tmpl @@ -15,7 +15,7 @@ AGCM_GRIDNAME: PE@AGCM_IMx@AGCM_JM-CF AGCM.NF: @AGCM_NF AGCM.LM: @AGCM_LM AGCM.IM_WORLD: @AGCM_IM - AGCM.JM_WORLD: @AGCM_JM + # AGCM.JM_WORLD: @AGCM_JM DYCORE: FV3 @@ -89,7 +89,7 @@ BERES_FILE_NAME: ExtData/g5gcm/gwd/newmfspectra40_dc25.nc >>>DATAOCEAN<<<>>>LATLON_OGCM<<>>DATAOCEAN<<<>>>LATLON_OGCM<<>>DATAOCEAN<<<>>>CUBE_OGCM<<>>DATAOCEAN<<>>EXPID<<<.ana.eta.%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.nc4 - NUDGE_STATE: YES - AGCM_IMPORT_RESTART_FILE: agcm_import_rst - AGCM_IMPORT_RESTART_TYPE: binary - 4DIAU_FREQUENCY: 21600 - FILTER_TYPE: IDF +# AINC_FILE: >>>EXPID<<<.ana.eta.%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.nc4 +# NUDGE_STATE: YES +# AGCM_IMPORT_RESTART_FILE: agcm_import_rst +# AGCM_IMPORT_RESTART_TYPE: binary +# 4DIAU_FREQUENCY: 21600 +# FILTER_TYPE: IDF # Exact REPLAY Mode for 4D-IAU (Note: DateStamp on agcm_import_rst should be the SYNPOTIC time of the Analysis) # ------------------------------------------------------------------------------------------------------------- @@ -516,7 +516,7 @@ LDAS_INCR: 0 # AGCM_INTERNAL = BIAS Correction Increment: BIAS(n+1) = ALPHA*IAU(n) + BETA*BIAS(n) # ---------------------------------------------------------------------------------- -#>>>FORCEDAS<<>>FORCEDAS<<>>FORCEGCM<<>>FORCEGCM<<>>COUPLED<<>>COUPLED<< 0 ) then + setenv JOBGEN_NCPUS_PER_NODE $ENSGCM_NCPUS_PER_NODE + endif endif if ( $FAILED ) then diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/job_distributor.csh b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/job_distributor.csh index a8630d9e..b1e11ee5 100755 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/job_distributor.csh +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/job_distributor.csh @@ -16,8 +16,7 @@ setenv dryrun echo # use this when debugging setenv dryrun setenv FAILED 0 -if ( !($?FVHOME) ) setenv FAILED 1 -if ( !($?FVROOT) ) setenv FAILED 1 +if ( !($?FVROOT) ) setenv FAILED 1 if ( $FAILED ) then env @@ -25,7 +24,11 @@ if ( $FAILED ) then exit 1 endif -set path = ( . $FVHOME/run $FVROOT/bin $path ) +if ( ($?FVHOME) ) then + set path = ( . $FVHOME/run $FVROOT/bin $path ) +else + set path = ( . $FVROOT/bin $path ) +endif set usage="\ Usage: $0 -machfile machinefile -usrcmd usrcmd -usrntask ntask " @@ -61,7 +64,16 @@ echo "njobs = $njobs" if ( $?SLURM_JOBID ) then # Number of available nodes - set num_nodes = `sinfo -N -n "$SLURM_NODELIST" | grep -v NODELIST | cut -c1-8 | uniq | wc -l` + if ( $?SLURM_JOB_NUM_NODES ) then + set num_nodes = $SLURM_JOB_NUM_NODES + else + set num_nodes = `sinfo -all -N -n "$SLURM_NODELIST" | grep -v NODELIST | cut -c1-8 | uniq | wc -l` + endif + if ( $?SLURM_NTASKS_PER_NODE ) then + set ntasks_per_node = $SLURM_NTASKS_PER_NODE + else + set ntasks_per_node = $num_nodes + endif # Mimic old PBS_NODEFILE setenv PBS_NODEFILE PBS_NODEFILE_${SLURM_JOBID} @@ -69,6 +81,7 @@ if ( $?SLURM_JOBID ) then echo " usrntask $usrntask" echo " njobs $njobs" echo " num_nodes $num_nodes" + echo " ntasks_per_node $ntasks_per_node" @ tasks_per_nodes = ($usrntask * $njobs) / $num_nodes set tasklist = () @ nd = 0 diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/jobgen.pl b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/jobgen.pl index 092cf9e8..fa408d7b 100755 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/jobgen.pl +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/jobgen.pl @@ -160,7 +160,7 @@ sub gen { print SCRIPT <<"EOF"; #\!/bin/csh -xvf #SBATCH --job-name=$jobname -#SBATCH --output=$jobname.log +#SBATCH --output=batch_${jobname}.log #SBATCH --time=$pbs_wallclk #PBS -N $jobname #PBS -o $jobname.log @@ -199,13 +199,12 @@ sub gen { if ( $ENV{JOBGEN_CONSTRAINT} ) { print SCRIPT <<"EOF"; #SBATCH --constraint=$ENV{JOBGEN_CONSTRAINT} -#SBATCH --ntasks=${ncpus} -EOF - } else { - print SCRIPT <<"EOF"; -#PBS -l select=${nodes}:ncpus=${ncpus_per_node} EOF } + print SCRIPT <<"EOF"; +#SBATCH --ntasks=${ncpus} +#_SBATCH --ntasks-per-node=${ncpus_per_node} +EOF } if ( $opt_q ne "datamove" ) { diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/setup_atmens.pl b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/setup_atmens.pl index 8751004f..13998f88 100755 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/setup_atmens.pl +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/setup_atmens.pl @@ -42,6 +42,7 @@ "expdir=s", "fvhome=s", "nlevs=s", + "nodename=s", "lsmcm", "radbc", "vtxrlc", @@ -129,6 +130,11 @@ sub init { $nlevs = $opt_nlevs; } + $nodename = "hasw"; + if ( $opt_nodename ) { + $nodename = $opt_nodename; + } + $dosppt = 1; if ( $opt_nosppt ) { $dosppt = 0; @@ -206,14 +212,33 @@ sub init { $latlon_ogcm = "#"; } + if ( $nodename eq "hasw" ) { $ncpus_per_node = 24; } + if ( $nodename eq "sky" ) { $ncpus_per_node = 36; } + if ( $nodename eq "cas" ) { $ncpus_per_node = 46; } + $agcm_ncpus_per_node = -1; + # define layout depending on resolution $agcm_nx = 4; $agcm_ny = 12; if ( $agcm_im == 90 ){ - $enkf_cpus = 192; - $agcm_nx = 4; $agcm_ny = 12; - $miau_nx = 2; $miau_ny = 12; - $obsv_nx = 4; $obsv_ny = 8; - $stat_nx = 2; $stat_ny = 2; + if ($nodename eq "hasw") { + $enkf_cpus = 192; + $agcm_nx = 4; $agcm_ny = 12; + $miau_nx = 2; $miau_ny = 12; + $obsv_nx = 4; $obsv_ny = 8; + $stat_nx = 2; $stat_ny = 2; + } elsif ($nodename eq "sky") { +# $agcm_ncpus_per_node = 36; + $enkf_cpus = 244; + $agcm_nx = 5; $agcm_ny = 24; + $miau_nx = 2; $miau_ny = 12; + $obsv_nx = 4; $obsv_ny = 8; + $stat_nx = 2; $stat_ny = 2; + } elsif ($nodename eq "cas") { + die "Sorry this node/resolution not set yet, aborting \n"; +# $agcm_ncpus_per_node = 46; + } else { + die "Unknown node name, aborting \n"; + } $chis_im = 90; $chis_jm = 540; # cubed-resolution $dhis_im = 288; $dhis_jm = 181; # diag-resolution output $hhis_im = 288; $hhis_jm = 181; # high-resolution output @@ -221,11 +246,30 @@ sub init { $obsv_im = 288; $obsv_jm = 181; $obsv_lm = $nlevs; $obsv_jcap = 126; } if ( $agcm_im == 180 ){ - $enkf_cpus = 368; - $agcm_nx = 7; $agcm_ny = 12; - $miau_nx = 2; $miau_ny = 12; - $obsv_nx = 4; $obsv_ny = 14; - $stat_nx = 2; $stat_ny = 14; + if ($nodename eq "hasw") { + $enkf_cpus = 224; + $agcm_nx = 6; $agcm_ny = 12; + $miau_nx = 2; $miau_ny = 12; + $obsv_nx = 4; $obsv_ny = 14; + $stat_nx = 2; $stat_ny = 14; + } elsif ($nodename eq "sky") { +# $agcm_ncpus_per_node = 36; + $enkf_cpus = 368; + $agcm_nx = 5; $agcm_ny = 24; + $miau_nx = 2; $miau_ny = 12; + $obsv_nx = 4; $obsv_ny = 20; + $stat_nx = 2; $stat_ny = 20; + } elsif ($nodename eq "cas") { +# $agcm_ncpus_per_node = 46; + $enkf_cpus = 442; + $agcm_nx = 6; $agcm_ny = 24; + $miau_nx = 2; $miau_ny = 12; + $obsv_nx = 4; $obsv_ny = 24; + $stat_nx = 2; $stat_ny = 24; + die "Sorry this node/resolution not set yet, aborting \n"; + } else { + die "Unknown node name, aborting \n"; + } $chis_im = 180; $chis_jm = 1080; # cubed-resolution $dhis_im = 288; $dhis_jm = 181; $hhis_im = 576; $hhis_jm = 361; @@ -233,11 +277,21 @@ sub init { $obsv_im = 576; $obsv_jm = 361; $obsv_lm = $nlevs; $obsv_jcap = 254; } if ( $agcm_im == 360 ){ - $enkf_cpus = 736; - $agcm_nx = 3; $agcm_ny = 72; - $miau_nx = 4; $miau_ny = 24; - $obsv_nx = 4; $obsv_ny = 14; - $stat_nx = 3; $stat_ny = 12; + if ($nodename eq "hasw") { + $enkf_cpus = 672; + $agcm_nx = 3; $agcm_ny = 72; + $miau_nx = 4; $miau_ny = 24; + $obsv_nx = 4; $obsv_ny = 14; + $stat_nx = 3; $stat_ny = 12; + } elsif ($nodename eq "sky") { + die "Sorry this node/resolution not set yet, aborting \n"; +# $agcm_ncpus_per_node = 36; + } elsif ($nodename eq "cas") { + die "Sorry this node/resolution not set yet, aborting \n"; +# $agcm_ncpus_per_node = 46; + } else { + die "Unknown node name, aborting \n"; + } $chis_im = 360; $chis_jm = 2160; # cubed-resolution $dhis_im = 288; $dhis_jm = 181; $hhis_im = 1152; $hhis_jm = 721; @@ -542,9 +596,9 @@ sub ed_obsv_rc { GSI_GridComp_ensfinal.rc.tmpl obs1gsi_mean.rc obs1gsi_member.rc ); - $nsig_ext = 13; + $nsig_ext = 15; if ( $obsv_lm > 72 & $obsv_lm <= 132 ) { - $nsig_ext = 15; + $nsig_ext = 17; } elsif ( $obsv_lm > 132 ) { $nsig_ext = 25; } @@ -679,13 +733,15 @@ sub ed_conf_rc { #--------------------------------------- while( defined($rcd = ) ) { chomp($rcd); - if($rcd =~ /\@ACFTBIAS/) {$rcd=~ s/\@ACFTBIAS/$setacftbc/g; } - if($rcd =~ /\@AGCM_CPUS/) {$rcd=~ s/\@AGCM_CPUS/$agcm_cpus/g; } - if($rcd =~ /\@DORCORR/) {$rcd=~ s/\@DORCORR/$dorcorr/g; } - if($rcd =~ /\@MIAU_CPUS/) {$rcd=~ s/\@MIAU_CPUS/$miau_cpus/g; } - if($rcd =~ /\@OBSV_CPUS/) {$rcd=~ s/\@OBSV_CPUS/$obsv_cpus/g; } - if($rcd =~ /\@STAT_CPUS/) {$rcd=~ s/\@STAT_CPUS/$stat_cpus/g; } - if($rcd =~ /\@ENKF_CPUS/) {$rcd=~ s/\@ENKF_CPUS/$enkf_cpus/g; } + if($rcd =~ /\@ACFTBIAS/) {$rcd=~ s/\@ACFTBIAS/$setacftbc/g; } + if($rcd =~ /\@AGCM_CPUS/) {$rcd=~ s/\@AGCM_CPUS/$agcm_cpus/g; } + if($rcd =~ /\@AGCM_NCPUS_PER_NODE/) {$rcd=~ s/\@AGCM_NCPUS_PER_NODE/$agcm_ncpus_per_node/g; } + if($rcd =~ /\@DORCORR/) {$rcd=~ s/\@DORCORR/$dorcorr/g; } + if($rcd =~ /\@MIAU_CPUS/) {$rcd=~ s/\@MIAU_CPUS/$miau_cpus/g; } + if($rcd =~ /\@OBSV_CPUS/) {$rcd=~ s/\@OBSV_CPUS/$obsv_cpus/g; } + if($rcd =~ /\@STAT_CPUS/) {$rcd=~ s/\@STAT_CPUS/$stat_cpus/g; } + if($rcd =~ /\@ENKF_CPUS/) {$rcd=~ s/\@ENKF_CPUS/$enkf_cpus/g; } + if($rcd =~ /\@NODENAME/) {$rcd=~ s/\@NODENAME/$nodename/g; } print(LUN2 "$rcd\n"); } From 3dd653e46714504f879abe82f2511c10a2843abb Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Thu, 28 Oct 2021 19:00:51 -0400 Subject: [PATCH 092/205] append input.nml from MOM6 when coupled --- src/Applications/GEOSdas_App/fvsetup | 49 ++++++++++++++++++++++++---- 1 file changed, 43 insertions(+), 6 deletions(-) diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index 9c01672e..e2d9772d 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -884,11 +884,11 @@ sub defaults { saverst.rc GEOS_SurfaceGridComp.rc ); - @coupled_files = qw( BC_GridComp_ExtData-clim.rc - CO_GridComp_ExtData-clim.rc - NI_GridComp_ExtData-clim.rc - OC_GridComp_ExtData-clim.rc - SU_GridComp_ExtData-clim.rc ); +# @coupled_files = qw( BC_GridComp_ExtData-clim.rc +# CO_GridComp_ExtData-clim.rc +# NI_GridComp_ExtData-clim.rc +# OC_GridComp_ExtData-clim.rc +# SU_GridComp_ExtData-clim.rc ); @chem_files = qw ( Aod-550nm_Registry.rc Aod3d_1064nm.rc @@ -1105,7 +1105,7 @@ sub defaults { if ( $anassi ) { @arc_files = @as_files }; if ( $anagsi ) { @arc_files = ( @ag_files, @lcv2prsrcs )}; if ( $fvchem ) { @crc_files = @chem_files }; - if ( $coupled ) { @crc_files = ( @chem_files, @coupled_files ) }; +# if ( $coupled ) { @crc_files = ( @chem_files, @coupled_files ) }; $monthly_plots = 0; if ( $siteID eq "nccs" ) { $monthly_means = 1; $monthly_tar = 1 } @@ -2241,9 +2241,18 @@ sub ed_g5fvlay_rc { close(LUN); close(LUN2); + cp($ft, $frun); unlink $ft; + if ( $coupled ) { + my @these = ("$fvroot/etc/MOM6/mom6_app/${ogcm_im}x${ogcm_jm}/input.nml","$frun"); + my $target = "/tmp/${user}_$$.txt"; + merge_txt(\@these,$target); + mv($target, $frun); + } + + } #======================================================================= @@ -9614,6 +9623,13 @@ sub init_agcm_rc { AGCM_label_subst("\@LSM_PARMS" , "#"); } + # Choice of Coupling + if ( $coupled ) { + AGCM_label_subst("\@COUPLED" , " "); + } else { + AGCM_label_subst("\@COUPLED" , "#"); + } + # directory-specific values #-------------------------- if (($varcase >= 4) and ($mydir eq "run")) { @@ -10681,6 +10697,27 @@ sub save_inputs { write_saved_inputs($save_file); } + +#======================================================================= +sub merge_txt { + my ($sources,$target) = @_; + + open my $out, '>>', $target or die "Could not open '$target' for appending\n"; + foreach my $file (@$sources) { + if (open my $in, '<', $file) { + while (my $line = <$in>) { + print $out $line; + } + close $in; + } else { + warn "Could not open '$file' for reading\n"; + } + } + close $out; + print "created $file $out \n"; + + return $out; +} #======================================================================= sub write_saved_inputs { my ($save_file, $dashes, $len, $prompt, $ans); From 4e5c3841223b7da61bd76cb2a0fa17890c1d0c0b Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Fri, 29 Oct 2021 14:06:22 -0400 Subject: [PATCH 093/205] a few minor changes for coupled --- src/Applications/GEOSdas_App/GEOSdas.csm | 54 +++++++- src/Applications/GEOSdas_App/fvsetup | 31 ++++- src/Applications/GEOSdas_App/gen_lnbcs.pl | 143 ++++++++++++++-------- 3 files changed, 168 insertions(+), 60 deletions(-) diff --git a/src/Applications/GEOSdas_App/GEOSdas.csm b/src/Applications/GEOSdas_App/GEOSdas.csm index b4ed53e2..9b183b36 100755 --- a/src/Applications/GEOSdas_App/GEOSdas.csm +++ b/src/Applications/GEOSdas_App/GEOSdas.csm @@ -173,6 +173,8 @@ endif endif + setenv COUPLED 0 # default setting; is reset w/ present of mom dir in FVHOME/run/fcst + #_RT if ( !($?STAGE4FCST) ) setenv STAGE4FCST 0 # need to resolve redundancies if ( $?RUN_OPT_BEGIN ) then @@ -530,6 +532,11 @@ exit 1 /bin/cp $FVHOME/run/fsens/*.tmpl . /bin/cp $FVHOME/run/fsens/*.rc . endif + if ( -d $FVHOME/run/mom ) then + setenv COUPLED 1 + /bin/cp $FVHOME/run/mom/*.table . + /bin/cp $FVHOME/run/mom/MOM_* . + endif if ( $FORECAST ) then foreach file ( `ls ${fchome}/*` ) if ( $file =~ *.log.* ) continue @@ -538,6 +545,11 @@ exit 1 /bin/cp $file . # skip restarts endif end + if ( -d $FVHOME/fcst/mom ) then + setenv COUPLED 1 + /bin/cp $FVHOME/fcst/mom/*.table . + /bin/cp $FVHOME/run/mom/MOM_* . + endif endif cat fvcore_layout.rc >> input.nml @@ -639,6 +651,24 @@ exit 1 endif ln -s $rsfile ./${rsf}_rst end + if ( $COUPLED ) then + set momrst_failed = 0 + if ( -e mom_rst ) then + /bin/mv mom_rst MOM.res.nc + else + @ momrst_failed = $momrst_failed + 1 + endif + foreach momrst ( 1 2 3 ) + if ( -e mom${momrst}_rst ) then + /bin/mv mom${momrst}_rst MOM.res_${momrst}.nc + else + @ momrst_failed = $momrst_failed + 1 + endif + end + if ( $momrst_failed ) then + Call AbnormalExit_( 3 ) + endif + endif set itime_hhmm = $itime:s/z/00z/ if ( -e $fcstage/stage/$EXPID.traj_lcv_rst.$itime_hhmm.$NCSUFFIX ) then @@ -682,6 +712,24 @@ exit 1 /bin/cp $rsfile ./${rs}_rst & endif end + if ( $COUPLED ) then + set momrst_failed = 0 + if ( -e mom_rst ) then + /bin/mv mom_rst MOM.res.nc + else + @ momrst_failed = $momrst_failed + 1 + endif + foreach momrst ( 1 2 3 ) + if ( -e mom${momrst}_rst ) then + /bin/mv mom${momrst}_rst MOM.res_${momrst}.nc + else + @ momrst_failed = $momrst_failed + 1 + endif + end + if ( $momrst_failed ) then + Call AbnormalExit_( 3 ) + endif + endif set GcmBegDate = $mydate[1] # Last line of CopyGcmRestarts4Forecast_ @@ -3855,8 +3903,6 @@ endif endif endif # echo "s/>>>NCSUFFIX<<> sed_file - echo "s/>>>COUPLED<<> sed_file - echo "s/>>>DATAOCEAN<<> sed_file echo "s/>>>FORCEGCM<<> sed_file echo "s/>>>REGULAR_REPLAY_ECMWF<<> sed_file echo "s/>>>REGULAR_REPLAY_NCEP<<> sed_file @@ -4477,8 +4523,6 @@ endif echo "s/>>>ANADATE<<> sed_file echo "s/>>>ANATIME<<> sed_file endif - echo "s/>>>COUPLED<<> sed_file - echo "s/>>>DATAOCEAN<<> sed_file echo "s/>>>FORCEGCM<<> sed_file if ( $blendrs || $blendec ) then @@ -4555,8 +4599,6 @@ endif echo "s/>>>4DIAUDAS<<> sed_file # no 4d-tendency for now echo "s/>>>FORCEDAS<<> sed_file endif - echo "s/>>>COUPLED<<> sed_file - echo "s/>>>DATAOCEAN<<> sed_file echo "s/>>>FORCEGCM<<> sed_file echo "s/>>>REGULAR_REPLAY_ECMWF<<> sed_file echo "s/>>>REGULAR_REPLAY_NCEP<<> sed_file diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index e2d9772d..ad2a7263 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -385,7 +385,7 @@ my ($qsub); my ($acqloc); my ($fcstimes,$fcswait_hrs,$asnwait_hrs); my ($landbcs); -my ($coupled, $ores); +my ($coupled, $ores, $mometc); my ($sysfile, $nodeflg); my (@rmTilde); @@ -884,6 +884,10 @@ sub defaults { saverst.rc GEOS_SurfaceGridComp.rc ); + @coupled_files = qw( data_table + g5aodas_diag_table + MOM_input + MOM_override ); # @coupled_files = qw( BC_GridComp_ExtData-clim.rc # CO_GridComp_ExtData-clim.rc # NI_GridComp_ExtData-clim.rc @@ -2246,7 +2250,7 @@ sub ed_g5fvlay_rc { unlink $ft; if ( $coupled ) { - my @these = ("$fvroot/etc/MOM6/mom6_app/${ogcm_im}x${ogcm_jm}/input.nml","$frun"); + my @these = ("$mometc/g5aodas_input.nml","$frun"); my $target = "/tmp/${user}_$$.txt"; merge_txt(\@these,$target); mv($target, $frun); @@ -5173,6 +5177,7 @@ EOF die "Abort: Not yet ready for this ocean-model resolution $ogcm_id\n"; } else { die "Error: Unsupported ocean-model resolution $ogcm_id\n"; } + $mometc = "$fvroot/etc/MOM6/mom6_app/${ogcm_im}x${ogcm_jm}"; } else { die "Error: Cannot recognize Ocean Horizontal Resolution Code $ogcm \n;" } $ogrid = "${ogcm_im}x${ogcm_jm}"; @@ -5196,6 +5201,8 @@ EOF $AGCM_GRIDNAME = "PE${agcm_im}x${agcm_jm}-CF"; if ( $ogcm eq "C" ) { $OGCM_GRIDNAME = "OC${ogcm_im}x${ogcm_jm}-CF"; + } elsif ( $ogcm eq "T" ) { + $OGCM_GRIDNAME = "PE${ogcm_im}x${ogcm_jm}-TM"; } else { $OGCM_GRIDNAME = "PE${ogcm_im}x${ogcm_jm}-DE"; } @@ -9625,9 +9632,11 @@ sub init_agcm_rc { # Choice of Coupling if ( $coupled ) { - AGCM_label_subst("\@COUPLED" , " "); + AGCM_label_subst("\@COUPLED" , " "); + AGCM_label_subst("\@DATAOCEAN" , "#"); } else { - AGCM_label_subst("\@COUPLED" , "#"); + AGCM_label_subst("\@COUPLED" , "#"); + AGCM_label_subst("\@DATAOCEAN" , " "); } # directory-specific values @@ -9859,6 +9868,20 @@ sub copy_resources { writeSaverst($fcsthrs, "$fvhome/run"); ed_blendacq("fcst"); + if ($coupled) { + foreach $dir ( "run","fcst" ) { + $rc = system("/bin/mkdir -p $fvhome/$dir/mom" ); + foreach $fname ( @coupled_files ) { + $aname = $fname; + if ( substr($aname,0,8) eq "g5aodas_" ) { + ($pfx,$aname) = split(/g5aodas_/,$fname); + } + cp("$mometc/$fname","$fvhome/$dir/mom/$aname") + || die "Cannot write file $fvhome/$dir/$aname: $!"; + } + } + } + # Edit GEOS-5 GCM-related resource files # -------------------------------------- foreach $fname ( @crc_files ) { diff --git a/src/Applications/GEOSdas_App/gen_lnbcs.pl b/src/Applications/GEOSdas_App/gen_lnbcs.pl index af65b03d..21123906 100755 --- a/src/Applications/GEOSdas_App/gen_lnbcs.pl +++ b/src/Applications/GEOSdas_App/gen_lnbcs.pl @@ -179,6 +179,7 @@ sub create_g5bcs_script { $bcsresa = "CF${agcm_im4}x6C"; if ( $ogcm eq "C" ) { $bcsreso = "CF${ogcm_im4}x6C"; + $bcsresa = "CF${agcm_im4}x6C"; } else { $bcsreso = "DE${ogcm_im4}xPE${ogcm_jm4}"; } @@ -240,21 +241,23 @@ sub create_g5bcs_script { setenv CUBED $cubed setenv G5GCMBCS \$FVHOME/fvInput/g5gcm/bcs setenv G5GRTBCS \$FVHOME/fvInput/$fvrtbcs -# wired ocean bcs location for now - setenv OGCMBCS /discover/nobackup/projects/gmao/ssd/aogcm/ocean_bcs # Possibly real-time boundary conditions # -------------------------------------- if ( \$COUPLED ) then - if ( ! -e \$OGCMBCS/MOM6/$ogrid/SEAWIFS_KPAR_mon_clim.$ogrid ) exit 1 - /bin/ln -sf \$OGCMBCS/MOM6/$ogrid/SEAWIFS_KPAR_mon_clim.$ogrid SEAWIFS_KPAR_mon_clim.data +# wired ocean bcs location for now + setenv OGCMBCS /discover/nobackup/projects/gmao/ssd/aogcm/ocean_bcs + setenv OAGCMBCS /discover/nobackup/projects/gmao/ssd/aogcm/atmosphere_bcs - if ( ! -e \$OGCMBCS/MOM6/${OGCM_GRIDNAME}_TM${ogcm_im}xTM${ogcm_jm}/${OGCM_GRIDNAME}_TM${ogcm_im}xTM${ogcm_jm}-Pfafstetter.til ) exit 1 - /bin/ln -sf \$OGCMBCS/MOM6/${OGCM_GRIDNAME}_TM${ogcm_im}xTM${ogcm_jm}/${OGCM_GRIDNAME}_TM${ogcm_im}xTM${ogcm_jm}-Pfafstetter.til tile.data + if ( ! -e \$OGCMBCS/MOM6/${ogcm_im}x${ogcm_jm}/SEAWIFS_KPAR_mon_clim.$ogrid ) exit 1 + /bin/ln -sf \$OGCMBCS/MOM6/${ogcm_im}x${ogcm_jm}/SEAWIFS_KPAR_mon_clim.$ogrid SEAWIFS_KPAR_mon_clim.data - if ( ! -e \$OGCMBCS/MOM6/${OGCM_GRIDNAME}_TM${ogcm_im}xTM${ogcm_jm}/${OGCM_GRIDNAME}_TM${ogcm_im}xTM${ogcm_jm}-Pfafstetter.TRN ) exit 1 - /bin/ln -sf \$OGCMBCS/MOM6/${OGCM_GRIDNAME}_TM${ogcm_im}xTM${ogcm_jm}/${OGCM_GRIDNAME}_TM${ogcm_im}xTM${ogcm_jm}-Pfafstetter.TRN runoff.bin + if ( ! -e \$OAGCMBCS/Icarus-NLv3/MOM6/${bcsresa}_TM${ogcm_im}xTM${ogcm_jm}/${bcsresa}_TM${ogcm_im}xTM${ogcm_jm}-Pfafstetter.til ) exit 1 + /bin/ln -sf \$OAGCMBCS/Icarus-NLv3/MOM6/${bcsresa}_TM${ogcm_im}xTM${ogcm_jm}/${bcsresa}_TM${ogcm_im}xTM${ogcm_jm}-Pfafstetter.til tile.data + + if ( ! -e \$OAGCMBCS/Icarus-NLv3/MOM6/${bcsresa}_TM${ogcm_im}xTM${ogcm_jm}/${bcsresa}_TM${ogcm_im}xTM${ogcm_jm}-Pfafstetter.TRN ) exit 1 + /bin/ln -sf \$OAGCMBCS/Icarus-NLv3/MOM6/${bcsresa}_TM${ogcm_im}xTM${ogcm_jm}/${bcsresa}_TM${ogcm_im}xTM${ogcm_jm}-Pfafstetter.TRN runoff.bin if ( ! -e \$OGCMBCS/MOM6/${ogcm_im}x${ogcm_jm}/MAPL_Tripolar.nc ) exit 1 /bin/ln -sf \$OGCMBCS/MOM6/${ogcm_im}x${ogcm_jm}/MAPL_Tripolar.nc . @@ -262,11 +265,8 @@ sub create_g5bcs_script { if ( ! -e \$OGCMBCS/MOM6/${ogcm_im}x${ogcm_jm}/vgrid${ogcm_lm}.ascii ) exit 1 /bin/ln -sf \$OGCMBCS/MOM6/${ogcm_im}x${ogcm_jm}/vgrid${ogcm_lm}.ascii vgrid.ascii - if ( ! -e \$OGCMBCS/MOM6/$ogrid/tripolar_$ogrid.ascii ) exit 1 - /bin/ln -sf \$OGCMBCS/MOM6/$ogrid/tripolar_$ogrid.ascii . - - if ( ! -e \$OGCMBCS/MOM6/$ogrid/vgrid50.ascii ) exit 1 - /bin/ln -sf \$OGCMBCS/MOM6/$ogrid/vgrid50.ascii vgrid.ascii + if ( ! -e \$OGCMBCS/MOM6/$ogrid/vgrid${ogcm_lm}.ascii ) exit 1 + /bin/ln -sf \$OGCMBCS/MOM6/$ogrid/vgrid${ogcm_lm}.ascii vgrid.ascii if ( ! -e \$OGCMBCS/MOM6/${ogcm_im}x${ogcm_jm}/cice/kmt_cice.bin ) exit 1 /bin/ln -sf \$OGCMBCS/MOM6/${ogcm_im}x${ogcm_jm}/cice/kmt_cice.bin . @@ -277,10 +277,55 @@ sub create_g5bcs_script { # now comes the mess: if ( -d INPUT ) /bin/rm -r INPUT mkdir INPUT - /bin/cp \$OGCMBCS/MOM6/${ogcm_im}x${ogcm_jm}/INPUT/* INPUT + /bin/cp \$OGCMBCS/MOM6/${ogcm_im}x${ogcm_jm}/INPUT/* INPUT/ + +# if ( ! -e \$OGCMBCS/../atmosphere_bcs/Icarus-NLv3/MOM6/${OGCM_GRIDNAME}_TM${ogcm_im}xTM${ogcm_jm}/visdf_${RES_DATELINE}.dat ) exit 1 +# /bin/ln -sf \$OGCMBCS/../atmosphere_bcs/Icarus-NLv3/MOM6/${OGCM_GRIDNAME}_TM${ogcm_im}xTM${ogcm_jm}/visdf_${RES_DATELINE}.dat visdf.dat + +# if ( ! -e \$OGCMBCS/../atmosphere_bcs/Icarus-NLv3/MOM6/${OGCM_GRIDNAME}_TM${ogcm_im}xTM${ogcm_jm}/nirdf_${RES_DATELINE}.dat ) exit 1 +# /bin/ln -sf \$OGCMBCS/../atmosphere_bcs/Icarus-NLv3/MOM6/${OGCM_GRIDNAME}_TM${ogcm_im}xTM${ogcm_jm}/nirdf_${RES_DATELINE}.dat nirdf.dat + +# ALL WIRED FOR NOW + if ( ! -e \$G5GCMBCS/$BCSTAG/Shared/pchem.species.Clim_Prod_Loss.z_721x72.nc4 ) exit 1 + /bin/ln -sf \$G5GCMBCS/$BCSTAG/Shared/pchem.species.Clim_Prod_Loss.z_721x72.nc4 species.data + + if ( ! -e \$OAGCMBCS/Icarus-NLv3/MOM6/CF0180x6C_TM1440xTM1080/visdf_180x1080.dat ) exit 1 + /bin/ln -sf \$OAGCMBCS/Icarus-NLv3/MOM6/CF0180x6C_TM1440xTM1080/visdf_180x1080.dat visdf.dat + + if ( ! -e \$OAGCMBCS/Icarus-NLv3/MOM6/CF0180x6C_TM1440xTM1080/nirdf_180x1080.dat ) exit 1 + /bin/ln -sf \$OAGCMBCS/Icarus-NLv3/MOM6/CF0180x6C_TM1440xTM1080/nirdf_180x1080.dat nirdf.dat + + if ( ! -e \$OAGCMBCS/Icarus-NLv3/MOM6/CF0180x6C_TM1440xTM1080/vegdyn_180x1080.dat ) exit 1 + /bin/ln -sf \$OAGCMBCS/Icarus-NLv3/MOM6/CF0180x6C_TM1440xTM1080/vegdyn_180x1080.dat vegdyn.data + + if ( ! -e \$OAGCMBCS/Icarus-NLv3/MOM6/CF0180x6C_TM1440xTM1080/lai_clim_180x1080.data ) exit 1 + /bin/ln -sf \$OAGCMBCS/Icarus-NLv3/MOM6/CF0180x6C_TM1440xTM1080/lai_clim_180x1080.data lai.data + + if ( ! -e \$OAGCMBCS/Icarus-NLv3/MOM6/CF0180x6C_TM1440xTM1080/green_clim_180x1080.data ) exit 1 + /bin/ln -sf \$OAGCMBCS/Icarus-NLv3/MOM6/CF0180x6C_TM1440xTM1080/green_clim_180x1080.data green.data + + if ( ! -e \$OAGCMBCS/Icarus-NLv3/MOM6/CF0180x6C_TM1440xTM1080/ndvi_clim_180x1080.data ) exit 1 + /bin/ln -sf \$OAGCMBCS/Icarus-NLv3/MOM6/CF0180x6C_TM1440xTM1080/ndvi_clim_180x1080.data ndvi.data + if ( ! -e /discover/nobackup/ltakacs/bcs/Icarus-NLv3/Icarus-NLv3_Reynolds/CF0180x6C_DE0360xPE0180/topo_DYN_ave_180x1080.data ) exit 1 + /bin/ln -sf /discover/nobackup/ltakacs/bcs/Icarus-NLv3/Icarus-NLv3_Reynolds/CF0180x6C_DE0360xPE0180/topo_DYN_ave_180x1080.data topo_dynave.data + + if ( ! -e /discover/nobackup/ltakacs/bcs/Icarus-NLv3/Icarus-NLv3_Reynolds/CF0180x6C_DE0360xPE0180/topo_GWD_var_180x1080.data ) exit 1 + /bin/ln -sf /discover/nobackup/ltakacs/bcs/Icarus-NLv3/Icarus-NLv3_Reynolds/CF0180x6C_DE0360xPE0180/topo_GWD_var_180x1080.data topo_gwdvar.data + + if ( ! -e /discover/nobackup/ltakacs/bcs/Icarus-NLv3/Icarus-NLv3_Reynolds/CF0180x6C_DE0360xPE0180/topo_TRB_var_180x1080.data ) exit 1 + /bin/ln -sf /discover/nobackup/ltakacs/bcs/Icarus-NLv3/Icarus-NLv3_Reynolds/CF0180x6C_DE0360xPE0180/topo_TRB_var_180x1080.data topo_trbvar.data + + if( -e /discover/nobackup/ltakacs/bcs/Icarus-NLv3/Icarus-NLv3_Reynolds/CF0180x6C_DE0360xPE0180/Gnomonic_CF0180x6C_DE0360xPE0180.dat ) exit 1 + /bin/ln -sf /discover/nobackup/ltakacs/bcs/Icarus-NLv3/Icarus-NLv3_Reynolds/CF0180x6C_DE0360xPE0180/Gnomonic_CF0180x6C_DE0360xPE0180.dat . + + /bin/ln -sf /discover/nobackup/ltakacs/bcs/Icarus-NLv3/Icarus-NLv3_Reynolds/Shared/*bin . + /bin/ln -sf /discover/nobackup/ltakacs/bcs/Icarus-NLv3/Icarus-NLv3_Reynolds/Shared/*c2l*.nc4 . + else +# Climatological boundary conditions +# ---------------------------------- if ( ! -e \$G5GRTBCS/$ogrid/$sstfile ) exit 1 /bin/ln -sf \$G5GRTBCS/$ogrid/$sstfile sst.data @@ -293,56 +338,54 @@ sub create_g5bcs_script { if ( ! -e \$G5GCMBCS/$BCSTAG/$bcsres/$TILEDATA ) exit 1 /bin/ln -sf \$G5GCMBCS/$BCSTAG/$bcsres/$TILEDATA tile.data - endif + if ( ! -e \$G5GCMBCS/$BCSTAG/$bcsres/vegdyn_${RES_DATELINE}_24Aug2017.dat ) exit 1 + /bin/ln -sf \$G5GCMBCS/$BCSTAG/$bcsres/vegdyn_${RES_DATELINE}_24Aug2017.dat vegdyn.data -# Climatological boundary conditions -# ---------------------------------- - if ( ! -e \$G5GCMBCS/$BCSTAG/$bcsres/vegdyn_${RES_DATELINE}_24Aug2017.dat ) exit 1 - /bin/ln -sf \$G5GCMBCS/$BCSTAG/$bcsres/vegdyn_${RES_DATELINE}_24Aug2017.dat vegdyn.data + if ( ! -e \$G5GCMBCS/$BCSTAG/Shared/pchem.species.Clim_Prod_Loss.z_721x72.nc4 ) exit 1 + /bin/ln -sf \$G5GCMBCS/$BCSTAG/Shared/pchem.species.Clim_Prod_Loss.z_721x72.nc4 species.data - if ( ! -e \$G5GCMBCS/$BCSTAG/Shared/pchem.species.Clim_Prod_Loss.z_721x72.nc4 ) exit 1 - /bin/ln -sf \$G5GCMBCS/$BCSTAG/Shared/pchem.species.Clim_Prod_Loss.z_721x72.nc4 species.data + if ( ! -e \$G5GCMBCS/$BCSTAG/$bcsres/lai_clim_${RES_DATELINE}.data ) exit 1 + /bin/ln -sf \$G5GCMBCS/$BCSTAG/$bcsres/lai_clim_${RES_DATELINE}.data lai.data - if ( ! -e \$G5GCMBCS/$BCSTAG/$bcsres/lai_clim_${RES_DATELINE}.data ) exit 1 - /bin/ln -sf \$G5GCMBCS/$BCSTAG/$bcsres/lai_clim_${RES_DATELINE}.data lai.data + if ( ! -e \$G5GCMBCS/$BCSTAG/$bcsres/green_clim_${RES_DATELINE}.data ) exit 1 + /bin/ln -sf \$G5GCMBCS/$BCSTAG/$bcsres/green_clim_${RES_DATELINE}.data green.data - if ( ! -e \$G5GCMBCS/$BCSTAG/$bcsres/green_clim_${RES_DATELINE}.data ) exit 1 - /bin/ln -sf \$G5GCMBCS/$BCSTAG/$bcsres/green_clim_${RES_DATELINE}.data green.data + if ( ! -e \$G5GCMBCS/$BCSTAG/$bcsres/ndvi_clim_${RES_DATELINE}.data ) exit 1 + /bin/ln -sf \$G5GCMBCS/$BCSTAG/$bcsres/ndvi_clim_${RES_DATELINE}.data ndvi.data - if ( ! -e \$G5GCMBCS/$BCSTAG/$bcsres/ndvi_clim_${RES_DATELINE}.data ) exit 1 - /bin/ln -sf \$G5GCMBCS/$BCSTAG/$bcsres/ndvi_clim_${RES_DATELINE}.data ndvi.data + if ( ! -e \$G5GCMBCS/$BCSTAG/$bcsres/visdf_${RES_DATELINE}.dat ) exit 1 + /bin/ln -sf \$G5GCMBCS/$BCSTAG/$bcsres/visdf_${RES_DATELINE}.dat visdf.dat - if ( ! -e \$G5GCMBCS/$BCSTAG/$bcsres/visdf_${RES_DATELINE}.dat ) exit 1 - /bin/ln -sf \$G5GCMBCS/$BCSTAG/$bcsres/visdf_${RES_DATELINE}.dat visdf.dat + if ( ! -e \$G5GCMBCS/$BCSTAG/$bcsres/nirdf_${RES_DATELINE}.dat ) exit 1 + /bin/ln -sf \$G5GCMBCS/$BCSTAG/$bcsres/nirdf_${RES_DATELINE}.dat nirdf.dat - if ( ! -e \$G5GCMBCS/$BCSTAG/$bcsres/nirdf_${RES_DATELINE}.dat ) exit 1 - /bin/ln -sf \$G5GCMBCS/$BCSTAG/$bcsres/nirdf_${RES_DATELINE}.dat nirdf.dat + if( ! -e \$G5GCMBCS/$BCSTAG/$bcsres/topo_DYN_ave_${RES_DATELINE}.data ) exit 1 + /bin/ln -sf \$G5GCMBCS/$BCSTAG/$bcsres/topo_DYN_ave_${RES_DATELINE}.data topo_dynave.data - if( ! -e \$G5GCMBCS/$BCSTAG/$bcsres/topo_DYN_ave_${RES_DATELINE}.data ) exit 1 - /bin/ln -sf \$G5GCMBCS/$BCSTAG/$bcsres/topo_DYN_ave_${RES_DATELINE}.data topo_dynave.data + if( ! -e \$G5GCMBCS/$BCSTAG/$bcsres/topo_GWD_var_${RES_DATELINE}.data ) exit 1 + /bin/ln -sf \$G5GCMBCS/$BCSTAG/$bcsres/topo_GWD_var_${RES_DATELINE}.data topo_gwdvar.data - if( ! -e \$G5GCMBCS/$BCSTAG/$bcsres/topo_GWD_var_${RES_DATELINE}.data ) exit 1 - /bin/ln -sf \$G5GCMBCS/$BCSTAG/$bcsres/topo_GWD_var_${RES_DATELINE}.data topo_gwdvar.data + if( ! -e \$G5GCMBCS/$BCSTAG/$bcsres/topo_TRB_var_${RES_DATELINE}.data ) exit 1 + /bin/ln -sf \$G5GCMBCS/$BCSTAG/$bcsres/topo_TRB_var_${RES_DATELINE}.data topo_trbvar.data - if( ! -e \$G5GCMBCS/$BCSTAG/$bcsres/topo_TRB_var_${RES_DATELINE}.data ) exit 1 - /bin/ln -sf \$G5GCMBCS/$BCSTAG/$bcsres/topo_TRB_var_${RES_DATELINE}.data topo_trbvar.data +# Convert tile file to binary +# --------------------------- + if ( \$CUBED ) then + if( -e \$G5GCMBCS/$BCSTAG/$bcsres/Gnomonic_$bcsres.dat ) then + /bin/ln -sf \$G5GCMBCS/$BCSTAG/$bcsres/Gnomonic_$bcsres.dat . + endif + /bin/ln -sf \$G5GCMBCS/$BCSTAG/Shared/*bin . + /bin/ln -sf \$G5GCMBCS/$BCSTAG/Shared/*_c2l_*.nc4 . + endif -# Convert tile file to binary -# --------------------------- - if ( \$CUBED ) then - if( -e \$G5GCMBCS/$BCSTAG/$bcsres/Gnomonic_$bcsres.dat ) then - /bin/ln -sf \$G5GCMBCS/$BCSTAG/$bcsres/Gnomonic_$bcsres.dat . - endif - /bin/ln -sf \$G5GCMBCS/$BCSTAG/Shared/*bin . - /bin/ln -sf \$G5GCMBCS/$BCSTAG/Shared/*_c2l_*.nc4 . - endif + if( -e \$G5GCMBCS/$BCSTAG/$bcsres/$TILEBIN ) then + /bin/ln -sf \$G5GCMBCS/$BCSTAG/$bcsres/$TILEBIN tile.bin + endif - if( -e \$G5GCMBCS/$BCSTAG/$bcsres/$TILEBIN ) then - /bin/ln -sf \$G5GCMBCS/$BCSTAG/$bcsres/$TILEBIN tile.bin - else - \$FVROOT/bin/binarytile.x tile.data tile.bin endif + \$FVROOT/bin/binarytile.x tile.data tile.bin + # Link to precipitation forcing data # ---------------------------------- if( ! -e ExtData/PCP ) then From b61bb03d856b2f0b95ead04158844321d96e6dd9 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Sat, 30 Oct 2021 07:05:56 -0400 Subject: [PATCH 094/205] GEOSadas.csm - a litte less intrusive MOM restart handling fvpsas and g54dvar - same as above fvsetup - minor gen_lnbcs.pl - species can be set equal in both AMIP and Coupled --- src/Applications/GEOSdas_App/GEOSdas.csm | 61 ++++++++++------------- src/Applications/GEOSdas_App/fvpsas | 2 + src/Applications/GEOSdas_App/fvsetup | 4 +- src/Applications/GEOSdas_App/g54dvar | 2 + src/Applications/GEOSdas_App/gen_lnbcs.pl | 10 ++-- 5 files changed, 37 insertions(+), 42 deletions(-) diff --git a/src/Applications/GEOSdas_App/GEOSdas.csm b/src/Applications/GEOSdas_App/GEOSdas.csm index 9b183b36..5b36e968 100755 --- a/src/Applications/GEOSdas_App/GEOSdas.csm +++ b/src/Applications/GEOSdas_App/GEOSdas.csm @@ -651,24 +651,6 @@ exit 1 endif ln -s $rsfile ./${rsf}_rst end - if ( $COUPLED ) then - set momrst_failed = 0 - if ( -e mom_rst ) then - /bin/mv mom_rst MOM.res.nc - else - @ momrst_failed = $momrst_failed + 1 - endif - foreach momrst ( 1 2 3 ) - if ( -e mom${momrst}_rst ) then - /bin/mv mom${momrst}_rst MOM.res_${momrst}.nc - else - @ momrst_failed = $momrst_failed + 1 - endif - end - if ( $momrst_failed ) then - Call AbnormalExit_( 3 ) - endif - endif set itime_hhmm = $itime:s/z/00z/ if ( -e $fcstage/stage/$EXPID.traj_lcv_rst.$itime_hhmm.$NCSUFFIX ) then @@ -712,27 +694,38 @@ exit 1 /bin/cp $rsfile ./${rs}_rst & endif end - if ( $COUPLED ) then - set momrst_failed = 0 - if ( -e mom_rst ) then - /bin/mv mom_rst MOM.res.nc + + set GcmBegDate = $mydate[1] + # Last line of CopyGcmRestarts4Forecast_ +\end + +#............................................................................. + +# ------------------------------------ + Sub CopyMOMRestarts_() +# ------------------------------------ + if ( $?ECHO___ ) set echo + + if ( ! $COUPLED ) exit 0 + + set momrst_failed = 0 + mkdir MOM_RESTART + if ( -e mom_rst ) then + /bin/mv mom_rst MOM_RESTART/MOM.res.nc + else + @ momrst_failed = $momrst_failed + 1 + endif + foreach momrst ( 1 2 3 ) + if ( -e mom${momrst}_rst ) then + /bin/mv mom${momrst}_rst MOM_RESTART/MOM.res_${momrst}.nc else @ momrst_failed = $momrst_failed + 1 endif - foreach momrst ( 1 2 3 ) - if ( -e mom${momrst}_rst ) then - /bin/mv mom${momrst}_rst MOM.res_${momrst}.nc - else - @ momrst_failed = $momrst_failed + 1 - endif - end - if ( $momrst_failed ) then - Call AbnormalExit_( 3 ) - endif + end + if ( $momrst_failed ) then + Call AbnormalExit_( 3 ) endif - set GcmBegDate = $mydate[1] - # Last line of CopyGcmRestarts4Forecast_ \end #............................................................................. diff --git a/src/Applications/GEOSdas_App/fvpsas b/src/Applications/GEOSdas_App/fvpsas index 94037ffd..ecd08268 100755 --- a/src/Applications/GEOSdas_App/fvpsas +++ b/src/Applications/GEOSdas_App/fvpsas @@ -190,6 +190,7 @@ # GEOS-5 forecast restarts # ------------------------ Call CopyGcmRestarts4Forecast_() + Call CopyMOMRestarts_() # Determine time of trajectory output in forecast mode # ---------------------------------------------------- @@ -246,6 +247,7 @@ zeit_ci.x CopyGCMRS Call CopyGcmRestarts4DAS_() wait # while copies are being done in the background + Call CopyMOMRestarts_() zeit_co.x CopyGCMRS # Link to GEOS-5 GCM boundary condition files diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index ad2a7263..3aa86eea 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -5042,7 +5042,7 @@ EOF $hist_jm = $ana_jm; $histc_im = 576; $histc_jm = 361; - $nx_pert = 6; + $nx_pert = 10; $ny_pert = 6 * $nx_pert; $hist_pert_im = 576; $hist_pert_jm = 361; @@ -5076,7 +5076,7 @@ EOF $hist_jm = $ana_jm; $histc_im = 576; $histc_jm = 361; - $nx_pert = 6; + $nx_pert = 10; $ny_pert = 6 * $nx_pert; $hist_pert_im = 576; $hist_pert_jm = 361; diff --git a/src/Applications/GEOSdas_App/g54dvar b/src/Applications/GEOSdas_App/g54dvar index 52cb72e0..17aa4c74 100755 --- a/src/Applications/GEOSdas_App/g54dvar +++ b/src/Applications/GEOSdas_App/g54dvar @@ -106,6 +106,7 @@ # GEOS-5 forecast restarts # ------------------------ Call CopyGcmRestarts4Forecast_() + Call CopyMOMRestarts_() # Determine time of trajectory output in forecast mode # ---------------------------------------------------- @@ -145,6 +146,7 @@ # ------------------------------------------------ zeit_ci.x CopyGCMRS Call CopyGcmRestarts4DAS_() + Call CopyMOMRestarts_() zeit_co.x CopyGCMRS # If we are running an analysis, we must stage the analysis restarts diff --git a/src/Applications/GEOSdas_App/gen_lnbcs.pl b/src/Applications/GEOSdas_App/gen_lnbcs.pl index 21123906..fd935809 100755 --- a/src/Applications/GEOSdas_App/gen_lnbcs.pl +++ b/src/Applications/GEOSdas_App/gen_lnbcs.pl @@ -286,9 +286,6 @@ sub create_g5bcs_script { # /bin/ln -sf \$OGCMBCS/../atmosphere_bcs/Icarus-NLv3/MOM6/${OGCM_GRIDNAME}_TM${ogcm_im}xTM${ogcm_jm}/nirdf_${RES_DATELINE}.dat nirdf.dat # ALL WIRED FOR NOW - if ( ! -e \$G5GCMBCS/$BCSTAG/Shared/pchem.species.Clim_Prod_Loss.z_721x72.nc4 ) exit 1 - /bin/ln -sf \$G5GCMBCS/$BCSTAG/Shared/pchem.species.Clim_Prod_Loss.z_721x72.nc4 species.data - if ( ! -e \$OAGCMBCS/Icarus-NLv3/MOM6/CF0180x6C_TM1440xTM1080/visdf_180x1080.dat ) exit 1 /bin/ln -sf \$OAGCMBCS/Icarus-NLv3/MOM6/CF0180x6C_TM1440xTM1080/visdf_180x1080.dat visdf.dat @@ -341,9 +338,6 @@ sub create_g5bcs_script { if ( ! -e \$G5GCMBCS/$BCSTAG/$bcsres/vegdyn_${RES_DATELINE}_24Aug2017.dat ) exit 1 /bin/ln -sf \$G5GCMBCS/$BCSTAG/$bcsres/vegdyn_${RES_DATELINE}_24Aug2017.dat vegdyn.data - if ( ! -e \$G5GCMBCS/$BCSTAG/Shared/pchem.species.Clim_Prod_Loss.z_721x72.nc4 ) exit 1 - /bin/ln -sf \$G5GCMBCS/$BCSTAG/Shared/pchem.species.Clim_Prod_Loss.z_721x72.nc4 species.data - if ( ! -e \$G5GCMBCS/$BCSTAG/$bcsres/lai_clim_${RES_DATELINE}.data ) exit 1 /bin/ln -sf \$G5GCMBCS/$BCSTAG/$bcsres/lai_clim_${RES_DATELINE}.data lai.data @@ -384,6 +378,10 @@ sub create_g5bcs_script { endif + if ( ! -e \$G5GCMBCS/$BCSTAG/Shared/pchem.species.Clim_Prod_Loss.z_721x72.nc4 ) exit 1 + /bin/ln -sf \$G5GCMBCS/$BCSTAG/Shared/pchem.species.Clim_Prod_Loss.z_721x72.nc4 species.data + + \$FVROOT/bin/binarytile.x tile.data tile.bin # Link to precipitation forcing data From 196e79b5b94ee8753f1ebe3fbdcd957fdacea381 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Sat, 30 Oct 2021 07:11:58 -0400 Subject: [PATCH 095/205] var no-longer do anything under intel 2021 --- src/Applications/GEOSdas_App/Create_anasa_script.pm | 2 +- src/Applications/GEOSdas_App/Create_asens_script.pm | 2 +- src/Applications/GEOSdas_App/fvsetup | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Applications/GEOSdas_App/Create_anasa_script.pm b/src/Applications/GEOSdas_App/Create_anasa_script.pm index 2cab04db..6b2b1da9 100644 --- a/src/Applications/GEOSdas_App/Create_anasa_script.pm +++ b/src/Applications/GEOSdas_App/Create_anasa_script.pm @@ -341,7 +341,7 @@ EOF source \$SHARE/dao_ops/opengrads/setup.csh 1.9-rc1-gmao if (\$?I_MPI_ROOT) then - setenv I_MPI_USE_DYNAMIC_CONNECTIONS 0 +# setenv I_MPI_USE_DYNAMIC_CONNECTIONS 0 setenv I_MPI_FABRICS shm:ofa endif setenv MPI_BUFS_PER_PROC 1024 diff --git a/src/Applications/GEOSdas_App/Create_asens_script.pm b/src/Applications/GEOSdas_App/Create_asens_script.pm index 5ed24117..060690c8 100644 --- a/src/Applications/GEOSdas_App/Create_asens_script.pm +++ b/src/Applications/GEOSdas_App/Create_asens_script.pm @@ -339,7 +339,7 @@ EOF source \$SHARE/dao_ops/opengrads/setup.csh 1.9-rc1-gmao if (\$?I_MPI_ROOT) then - setenv I_MPI_USE_DYNAMIC_CONNECTIONS 0 +# setenv I_MPI_USE_DYNAMIC_CONNECTIONS 0 setenv I_MPI_FABRICS shm:ofa endif setenv MPI_BUFS_PER_PROC 1024 diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index 3aa86eea..87201418 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -8873,7 +8873,7 @@ print SCRIPT <<"EOF"; # MPT env variables # ----------------- if (\$?I_MPI_ROOT) then - setenv I_MPI_USE_DYNAMIC_CONNECTIONS 0 +# setenv I_MPI_USE_DYNAMIC_CONNECTIONS 0 # setenv I_MPI_FABRICS shm:dapl # setenv I_MPI_FABRICS_LIST "dapl,ofa" # setenv I_MPI_FALLBACK "enable" From 172044699fb026300fbee429491cd496b174d16f Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Sun, 31 Oct 2021 10:54:04 -0400 Subject: [PATCH 096/205] all minor revisions to allow running coupled model in ADAS context; all tested and working --- src/Applications/GEOSdas_App/CMakeLists.txt | 1 + .../GEOSdas_App/Create_anasa_script.pm | 2 +- .../GEOSdas_App/Create_asens_script.pm | 2 +- .../GEOSdas_App/Create_fsens_script.pm | 2 +- src/Applications/GEOSdas_App/GEOSdas.csm | 74 ++++-- src/Applications/GEOSdas_App/fvpsas | 4 +- src/Applications/GEOSdas_App/fvsetup | 4 +- src/Applications/GEOSdas_App/g54dvar | 4 +- src/Applications/GEOSdas_App/gen_lnbcs.pl | 5 +- src/Applications/GEOSdas_App/gen_silo_arc.pl | 9 + src/Applications/GEOSdas_App/mom6diag.csh | 24 ++ .../GEOSdas_App/testsuites/C180RPY.input | 230 ++++++++++++++++++ .../GEOSdas_App/testsuites/C180T14RPY.input | 230 ++++++++++++++++++ .../NCEP_Etc/NCEP_enkf/scripts/gmao/atm_ens.j | 2 +- 14 files changed, 566 insertions(+), 27 deletions(-) create mode 100755 src/Applications/GEOSdas_App/mom6diag.csh create mode 100644 src/Applications/GEOSdas_App/testsuites/C180RPY.input create mode 100644 src/Applications/GEOSdas_App/testsuites/C180T14RPY.input diff --git a/src/Applications/GEOSdas_App/CMakeLists.txt b/src/Applications/GEOSdas_App/CMakeLists.txt index 53981631..8aefbd10 100644 --- a/src/Applications/GEOSdas_App/CMakeLists.txt +++ b/src/Applications/GEOSdas_App/CMakeLists.txt @@ -13,6 +13,7 @@ set(dasscripts g54dvar fp_seamless ldas_run.csh + mom6diag.csh read_HIST.csh ) set(extraperlscripts diff --git a/src/Applications/GEOSdas_App/Create_anasa_script.pm b/src/Applications/GEOSdas_App/Create_anasa_script.pm index 6b2b1da9..1a76ede1 100644 --- a/src/Applications/GEOSdas_App/Create_anasa_script.pm +++ b/src/Applications/GEOSdas_App/Create_anasa_script.pm @@ -154,7 +154,7 @@ sub anasa_script { # ------------------------ unsetenv LD_LIBRARY_PATH source \$FVROOT/bin/g5_modules - setenv LD_LIBRARY_PATH \${LD_LIBRARY_PATH}:\${BASEDIR}/\${ARCH}/lib:\${FVROOT}/lib + setenv LD_LIBRARY_PATH \${BASEDIR}/\${ARCH}/lib:\${FVROOT}/lib:\${LD_LIBRARY_PATH} setenv BATCH_SUBCMD $qsub diff --git a/src/Applications/GEOSdas_App/Create_asens_script.pm b/src/Applications/GEOSdas_App/Create_asens_script.pm index 060690c8..e2007d73 100644 --- a/src/Applications/GEOSdas_App/Create_asens_script.pm +++ b/src/Applications/GEOSdas_App/Create_asens_script.pm @@ -156,7 +156,7 @@ sub asens_script { # ------------------------ unsetenv LD_LIBRARY_PATH source \$FVROOT/bin/g5_modules - setenv LD_LIBRARY_PATH \${LD_LIBRARY_PATH}:\${BASEDIR}/\${ARCH}/lib:\${FVROOT}/lib + setenv LD_LIBRARY_PATH \${BASEDIR}/\${ARCH}/lib:\${FVROOT}/lib:\${LD_LIBRARY_PATH} # Internal parameters controling system behavior # ---------------------------------------------- diff --git a/src/Applications/GEOSdas_App/Create_fsens_script.pm b/src/Applications/GEOSdas_App/Create_fsens_script.pm index 12f8baca..5b0e4b2a 100644 --- a/src/Applications/GEOSdas_App/Create_fsens_script.pm +++ b/src/Applications/GEOSdas_App/Create_fsens_script.pm @@ -130,7 +130,7 @@ sub fsens_script { # ------------------------ unsetenv LD_LIBRARY_PATH source \$FVROOT/bin/g5_modules - setenv LD_LIBRARY_PATH \${LD_LIBRARY_PATH}:\${BASEDIR}/\${ARCH}/lib:\${FVROOT}/lib + setenv LD_LIBRARY_PATH \${BASEDIR}/\${ARCH}/lib:\${FVROOT}/lib:\${LD_LIBRARY_PATH} # Until a better handle of GEOS_Util is agreed upon (should not refer to things in src) # ------------------------------------------------------------------------------------- diff --git a/src/Applications/GEOSdas_App/GEOSdas.csm b/src/Applications/GEOSdas_App/GEOSdas.csm index 5b36e968..b4d99163 100755 --- a/src/Applications/GEOSdas_App/GEOSdas.csm +++ b/src/Applications/GEOSdas_App/GEOSdas.csm @@ -173,8 +173,6 @@ endif endif - setenv COUPLED 0 # default setting; is reset w/ present of mom dir in FVHOME/run/fcst - #_RT if ( !($?STAGE4FCST) ) setenv STAGE4FCST 0 # need to resolve redundancies if ( $?RUN_OPT_BEGIN ) then @@ -533,8 +531,7 @@ exit 1 /bin/cp $FVHOME/run/fsens/*.rc . endif if ( -d $FVHOME/run/mom ) then - setenv COUPLED 1 - /bin/cp $FVHOME/run/mom/*.table . + /bin/cp $FVHOME/run/mom/*_table . /bin/cp $FVHOME/run/mom/MOM_* . endif if ( $FORECAST ) then @@ -546,9 +543,8 @@ exit 1 endif end if ( -d $FVHOME/fcst/mom ) then - setenv COUPLED 1 - /bin/cp $FVHOME/fcst/mom/*.table . - /bin/cp $FVHOME/run/mom/MOM_* . + /bin/cp $FVHOME/fcst/mom/*_table . + /bin/cp $FVHOME/run/mom/MOM_* . endif endif cat fvcore_layout.rc >> input.nml @@ -695,37 +691,74 @@ exit 1 endif end + set GcmBegDate = $mydate[1] - # Last line of CopyGcmRestarts4Forecast_ + # Last line of CopyGcmRestarts4DAS_ \end #............................................................................. # ------------------------------------ - Sub CopyMOMRestarts_() + Sub CopyMOMRestarts_( FcstCase_ ) # ------------------------------------ if ( $?ECHO___ ) set echo - if ( ! $COUPLED ) exit 0 + if ( ! -d $FVHOME/run/mom ) exit 0 +# Bring restarts from recycle into work dir +# ----------------------------------------- set momrst_failed = 0 - mkdir MOM_RESTART + if ( $FcstCase_ ) then + echo "Not ready to hand Coupled forecasts, aborting ..." + Call AbnormalExit_( 1 ) + else # DASCase + foreach this ( mom_rst mom1_rst mom2_rst mom3_rst ) + set momrs = $FVHOME/recycle/$EXPID.$this.$itime.nc4 + if ( -e $momrs ) then + /bin/cp $momrs $this + else + @ momrst_failed = $momrst_failed + 1 + endif + end + endif + if ( $momrst_failed ) then + echo "Trouble setting up MOM restarts, aborting ..." + Call AbnormalExit_( 2 ) + endif + +# Find out where MOM expects restarts to be +# ----------------------------------------- + if ( ! -e fvcore_layout.rc ) then + echo "Trouble finding layout RC, aborting ..." + Call AbnormalExit_( 1 ) + endif + set mominpdir = `nmlread.py fvcore_layout.rc MOM_input_nml restart_input_dir` + if ( ! -d $mominpdir ) mkdir $mominpdir + + set momoutdir = `nmlread.py fvcore_layout.rc MOM_input_nml restart_output_dir` + if ( ! -d $momoutdir ) mkdir $momoutdir + +# Move MOM to location MOM expects them +# ------------------------------------- + @ momrst_failed = 0 if ( -e mom_rst ) then - /bin/mv mom_rst MOM_RESTART/MOM.res.nc + /bin/mv mom_rst $mominpdir/MOM.res.nc else @ momrst_failed = $momrst_failed + 1 endif foreach momrst ( 1 2 3 ) if ( -e mom${momrst}_rst ) then - /bin/mv mom${momrst}_rst MOM_RESTART/MOM.res_${momrst}.nc + /bin/mv mom${momrst}_rst $mominpdir/MOM.res_${momrst}.nc else @ momrst_failed = $momrst_failed + 1 endif end if ( $momrst_failed ) then - Call AbnormalExit_( 3 ) + echo "Trouble setting up MOM restarts, aborting ..." + Call AbnormalExit_( 2 ) endif + # Last line of CopyMOMRestarts_ \end #............................................................................. @@ -5111,6 +5144,10 @@ endif cnv2prs.pl -prog endif + if ( -d $FVHOME/run/mom ) then # this needs revision + mom6diag.csh $EXPID $GcmBegDate $GcmBegTime $GcmEndDate $GcmEndTime + endif + exit 0 # Last line of SplitExecPostProcessing_() @@ -5892,6 +5929,15 @@ endif if ( $DO4DVAR ) then /bin/mv $EXPID.*rst*iter*.$RSTSUFFIX $FVHOME/recycle/hold endif + if ( ! -d $FVHOME/run/mom ) exit 0 + set momoutdir = `nmlread.py fvcore_layout.rc MOM_input_nml restart_output_dir` + set mylcvs = (`ls -1 $EXPID.rst.lcv*`) + set momtag = `echo $mylcvs[1] | cut -d. -f4` + /bin/mv $momoutdir/MOM.res.nc $FVHOME/recycle/hold/$EXPID.mom_rst.${momtag}.nc4 + foreach fn ( 1 2 3 ) + /bin/mv $momoutdir/MOM.res_${fn}.nc $FVHOME/recycle/hold/$EXPID.mom${fn}_rst.${momtag}.nc4 + end + endif cd $FVHOME/recycle/hold tar cvf $FVWORK/$EXPID.rst.${rtag}.tar $EXPID.* /bin/mv $FVWORK/$EXPID.xinc*$NCSUFFIX . diff --git a/src/Applications/GEOSdas_App/fvpsas b/src/Applications/GEOSdas_App/fvpsas index ecd08268..56f8ba91 100755 --- a/src/Applications/GEOSdas_App/fvpsas +++ b/src/Applications/GEOSdas_App/fvpsas @@ -190,7 +190,7 @@ # GEOS-5 forecast restarts # ------------------------ Call CopyGcmRestarts4Forecast_() - Call CopyMOMRestarts_() + Call CopyMOMRestarts_( 1 ) # Determine time of trajectory output in forecast mode # ---------------------------------------------------- @@ -247,7 +247,7 @@ zeit_ci.x CopyGCMRS Call CopyGcmRestarts4DAS_() wait # while copies are being done in the background - Call CopyMOMRestarts_() + Call CopyMOMRestarts_( 0 ) zeit_co.x CopyGCMRS # Link to GEOS-5 GCM boundary condition files diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index 87201418..a8227085 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -7651,7 +7651,7 @@ print SCRIPT <<"EOF"; # ------------------------ unsetenv LD_LIBRARY_PATH source \$FVROOT/bin/g5_modules - setenv LD_LIBRARY_PATH \${LD_LIBRARY_PATH}:\${BASEDIR}/\${ARCH}/lib:\${FVROOT}/lib + setenv LD_LIBRARY_PATH \${BASEDIR}/\${ARCH}/lib:\${FVROOT}/lib:\${LD_LIBRARY_PATH} # Internal parameters controlling system behavior # ---------------------------------------------- @@ -8806,7 +8806,7 @@ print SCRIPT <<"EOF"; # ------------------------ unsetenv LD_LIBRARY_PATH source \$FVROOT/bin/g5_modules - setenv LD_LIBRARY_PATH \${LD_LIBRARY_PATH}:\${BASEDIR}/\${ARCH}/lib:\${FVROOT}/lib + setenv LD_LIBRARY_PATH \${BASEDIR}/\${ARCH}/lib:\${FVROOT}/lib:\${LD_LIBRARY_PATH} # Until a better handle of GEOS_Util is agreed upon (should not refer to things in src) # ------------------------------------------------------------------------------------- diff --git a/src/Applications/GEOSdas_App/g54dvar b/src/Applications/GEOSdas_App/g54dvar index 17aa4c74..7067995f 100755 --- a/src/Applications/GEOSdas_App/g54dvar +++ b/src/Applications/GEOSdas_App/g54dvar @@ -106,7 +106,7 @@ # GEOS-5 forecast restarts # ------------------------ Call CopyGcmRestarts4Forecast_() - Call CopyMOMRestarts_() + Call CopyMOMRestarts_( 1 ) # Determine time of trajectory output in forecast mode # ---------------------------------------------------- @@ -146,7 +146,7 @@ # ------------------------------------------------ zeit_ci.x CopyGCMRS Call CopyGcmRestarts4DAS_() - Call CopyMOMRestarts_() + Call CopyMOMRestarts_( 0 ) zeit_co.x CopyGCMRS # If we are running an analysis, we must stage the analysis restarts diff --git a/src/Applications/GEOSdas_App/gen_lnbcs.pl b/src/Applications/GEOSdas_App/gen_lnbcs.pl index fd935809..dbefbc6e 100755 --- a/src/Applications/GEOSdas_App/gen_lnbcs.pl +++ b/src/Applications/GEOSdas_App/gen_lnbcs.pl @@ -274,9 +274,8 @@ sub create_g5bcs_script { if ( ! -e \$OGCMBCS/MOM6/${ogcm_im}x${ogcm_jm}/cice/grid_cice.bin ) exit 1 /bin/ln -sf \$OGCMBCS/MOM6/${ogcm_im}x${ogcm_jm}/cice/grid_cice.bin . - # now comes the mess: - if ( -d INPUT ) /bin/rm -r INPUT - mkdir INPUT + # now comes the mess (this must loot at input.nml (or layout) instead of wired INPUT namedir: + if ( -d INPUT ) mkdir INPUT /bin/cp \$OGCMBCS/MOM6/${ogcm_im}x${ogcm_jm}/INPUT/* INPUT/ # if ( ! -e \$OGCMBCS/../atmosphere_bcs/Icarus-NLv3/MOM6/${OGCM_GRIDNAME}_TM${ogcm_im}xTM${ogcm_jm}/visdf_${RES_DATELINE}.dat ) exit 1 diff --git a/src/Applications/GEOSdas_App/gen_silo_arc.pl b/src/Applications/GEOSdas_App/gen_silo_arc.pl index 63d87329..53bcfbf7 100755 --- a/src/Applications/GEOSdas_App/gen_silo_arc.pl +++ b/src/Applications/GEOSdas_App/gen_silo_arc.pl @@ -743,6 +743,15 @@ sub append_other_info { \${PESTOROOT}%s/obs/Y%y4/M%m2/%s.diag_conv_%y4%m2%d2_%h20000z.tar +# +# ------------------------------- +# MOM6 OUTPUT: Wired for now +# ------------------------------- +# +\${PESTOROOT}%s/mom/Y%y4/M%m2/%s.forcing.y4%m2%d2_%h2z+%y4%m2%d2_%h2z.nc4 +\${PESTOROOT}%s/mom/Y%y4/M%m2/%s.prog_z.y4%m2%d2_%h2z+%y4%m2%d2_%h2z.nc4 +\${PESTOROOT}%s/mom/Y%y4/M%m2/%s.sfc_ave.y4%m2%d2_%h2z+%y4%m2%d2_%h2z.nc4 + EOF } diff --git a/src/Applications/GEOSdas_App/mom6diag.csh b/src/Applications/GEOSdas_App/mom6diag.csh new file mode 100755 index 00000000..6dd2b0f0 --- /dev/null +++ b/src/Applications/GEOSdas_App/mom6diag.csh @@ -0,0 +1,24 @@ +#!/bin/csh + +# THIS IS TEMPORARY: should be replaced w/ better script + +if ( $#argv < 5 ) then + echo " Usage: mom6diag.csh EXPID YYYYMMDD HHMMSS YYYYMMDD HHMMSS" + exit 1 +endif + +set expid = $1 +set begdate = $2 +set begtime = $3 +set enddate = $4 +set endtime = $5 + +set bhh = `echo $begtime | cut -c1-2`` +set ehh = `echo $endtime | cut -c1-2`` + +set begtag = ${begdate}_${bhh}z +set endtag = ${enddate}_${bhh}z + +foreach ftype ( prog_z forcing sfc_ave ) + /bin/mv $ftype.nc $expid.${begtag}+${endtag}.nc4 +end diff --git a/src/Applications/GEOSdas_App/testsuites/C180RPY.input b/src/Applications/GEOSdas_App/testsuites/C180RPY.input new file mode 100644 index 00000000..291e418d --- /dev/null +++ b/src/Applications/GEOSdas_App/testsuites/C180RPY.input @@ -0,0 +1,230 @@ +#------------ +# C180RPY.input +#------------ + +description: C180RPY__GEOSadas-5_29_3__agrid_C360__ogrid_C +tag: GEOSadas-5_29_3 + +---ENDHEADERS--- + +Remote account for Intranet plots? [rtodling@train] +> + +Is this a MERRA2 experiment (y/n)? [n] +> + +AGCM Horizontal Resolution? [C48] +> C180 + +AGCM Vertical Resolution? [72] +> + +OGCM Resolution? [f] +> C + +EXPID? [u000_C180] +> $expid + +Check for previous use of expid (y/n)? [y] +> n + +EXPDSC? [C180RPY__GEOSadas-5_29_3__agrid_C360__ogrid_C] +> + +Land Boundary Conditions? [Icarus_Updated] +> Icarus-NLv3 + +Catchment Model choice? [1] +> + +FVHOME? [/discover/nobackup/rtodling/C180RPY] +> /discover/nobackup/projects/gmao/dadev/rtodling/$expid + +The directory /discover/nobackup/projects/gmao/obsdev/rtodling/C180RPY already exists. Clean it? [y] +> + +Processing nodes (1:Westmere, 2:SandyBridge, 3:Ivy Bridge, 4:Haswell, 5:Skylake, 6:Cascase)? [4] +> 5 + +Which case of variational analysis? [1] +> + +Window of the variational analysis (min)? [360] +> + +FVINPUT? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar] +> + +REAL TIME BCS? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/g5gcm/bcs/realtime/OSTIA_REYNOLDS] +> + +agcmpert? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/agcmpert] +> + +g5chem? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/g5chem] +> + +g5gcm? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/g5gcm] +> + +PIESA? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/PIESA] +> + +MERRA2? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/MERRA2] +> + +AeroCom? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/AeroCom] +> + +FVICS? [/archive/u/jstassi/restarts/GEOSadas-5_24_0] +> /discover/nobackup/projects/gmao/dadev/rtodling/archive/Restarts/x0045_C180/rs_coupled/Y2020/M11/x0045.rst.20201129_21z.tar + +Run model-adjoint-related applications (0=no,1=yes)? [0] +> + +Run analysis-sensitivity applications (0=no,1=yes)? [0] +> + +Ending year-month-day? [20191121] +> 20210206 + +Length of FORECAST run segments (in hours)? [123] +> + +Number of one-day DAS segments per PBS job? [1] +> + +Number of PEs in the zonal direction (NX)? [8] +> 20 + +Number of PEs in the meridional direction (NY)? [48] +> 60 + +Job nickname? [g5das] +> c01 + +Run in split executable mode (1=yes;0=no)? [1] +> + +Frequency of background fields (min)? [180] +> 60 + +Triangular spectral truncation? [254] +> + +Analysis vertical levels (sig))? [72] +> + +GSI grid resolution? [NA] +> + +GEOS grid resolution instead? [d] +> + +Ensemble Hybrid (<0;3=3dHyb;4=Hyb4d)? [-1] +> 4 + +Number of procs in the zonal direction (NX)? [12] +> 16 + +Number of procs in the meridional direction (NY)? [20] +> 42 + +Which main class of ObsSys (1: NRT; 2: MERRA; 3: MERRA-2)? [1] +> + +OBSERVING SYSTEM CLASSES? +> disc_airs_bufr,disc_amsua_bufr,gmao_amsr2_bufr,gmao_gmi_bufr,mls_nrt_nc,ncep_1bamua_bufr,ncep_1bhrs4_bufr,ncep_acftpfl_bufr,ncep_atms_bufr,ncep_aura_omi_bufr,ncep_avcsam_bufr,ncep_avcspm_bufr,ncep_crisfsr_bufr,ncep_goesfv_bufr,ncep_gpsro_com_bufr,ncep_mhs_bufr,ncep_mtiasi_bufr,ncep_prep_bufr,ncep_satwnd_bufr,ncep_sevcsr_bufr,ncep_ssmis_bufr,ncep_tcvitals,npp_ompsnm_bufr,gmao_mlst_bufr + +CHECKING OBSYSTEM? [2] +> 1 + +Which RADCOR option? [NONE] +> + +Use sat channel-correlated observation errors (y/n)? [y] +> + +Use aircraft bias correction (y/n)? [y] +> + +Use unified radiance bias correction (y/n)? [y] +> + +Land DAS Analysis (y/n)? [n] +> + +Frequency (in days) for writing restarts? [0] +> + +Frequency for PROGNOSTIC fields? [010000] +> + +Frequency for surface (2D) DIAGNOSTIC fields? [010000] +> + +Frequency for upper air (3D) DIAGNOSTIC fields? [030000] +> + +Dimension of output in zonal direction? [576] +> + +Dimension of output in meridional direction? [361] +> + +Would you like 2D diagnostics? [y] +> + +Would you like 3D diagnostics? [y] +> + +Would you like to compress diagnostics output files? [n] +> + +Include GOCART tracers (CO,CO2,aerosols,etc) (y/n)? [y] +> + +Select GOCART Emission Files to use: [OPS] +> + +Do Aerosol Analysis (y/n)? [y] +> + +AOD OBSERVING CLASSES [or type 'none']? +> + +Enable GAAS feedback to model (y/n)? [y] +> + +Which template? [HISTORY.rc.tmpl] +> + +Which template? [GCMPROG.rc.tmpl] +> + +Output Restart TYPE (bin or nc4) [nc4] +> + +Select group: [s0818] +> g0613 + +Replayed Ensemble (from OPS)? [yes] +> + +Replay exp name? [x0045a] +> x0045a + +Replay archive directory? [/discover/nobackup/projects/gmao/dadev/dao_it/archive/x0045a] +> /discover/nobackup/projects/gmao/dadev/dao_it/archive/x0045a + +Edit COLLECTIONS list in run/HISTORY.rc.tmpl (y/n)? [n] +> + +Edit COLLECTIONS list in fcst/HISTORY.rc.tmpl (y/n)? [n] +> + +Edit files in run directory for CERES configuration (y/n)? [n] +> + +Which? [Q] +> diff --git a/src/Applications/GEOSdas_App/testsuites/C180T14RPY.input b/src/Applications/GEOSdas_App/testsuites/C180T14RPY.input new file mode 100644 index 00000000..eab985b3 --- /dev/null +++ b/src/Applications/GEOSdas_App/testsuites/C180T14RPY.input @@ -0,0 +1,230 @@ +#------------ +# C180T14RPY.input +#------------ + +description: C180T14RPY__GEOSadas-5_29_3__agrid_C360__ogrid_C +tag: GEOSadas-5_29_3 + +---ENDHEADERS--- + +Remote account for Intranet plots? [rtodling@train] +> + +Is this a MERRA2 experiment (y/n)? [n] +> + +AGCM Horizontal Resolution? [C48] +> C180 + +AGCM Vertical Resolution? [72] +> + +OGCM Resolution? [f] +> T14 + +EXPID? [u000_C180] +> $expid + +Check for previous use of expid (y/n)? [y] +> n + +EXPDSC? [C180T14RPY__GEOSadas-5_29_3__agrid_C360__ogrid_C] +> + +Land Boundary Conditions? [Icarus_Updated] +> Icarus-NLv3 + +Catchment Model choice? [1] +> + +FVHOME? [/discover/nobackup/rtodling/C180T14RPY] +> /discover/nobackup/projects/gmao/dadev/rtodling/$expid + +The directory /discover/nobackup/projects/gmao/obsdev/rtodling/C180T14RPY already exists. Clean it? [y] +> + +Processing nodes (1:Westmere, 2:SandyBridge, 3:Ivy Bridge, 4:Haswell, 5:Skylake, 6:Cascase)? [4] +> 5 + +Which case of variational analysis? [1] +> + +Window of the variational analysis (min)? [360] +> + +FVINPUT? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar] +> + +REAL TIME BCS? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/g5gcm/bcs/realtime/OSTIA_REYNOLDS] +> + +agcmpert? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/agcmpert] +> + +g5chem? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/g5chem] +> + +g5gcm? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/g5gcm] +> + +PIESA? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/PIESA] +> + +MERRA2? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/MERRA2] +> + +AeroCom? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/AeroCom] +> + +FVICS? [/archive/u/jstassi/restarts/GEOSadas-5_24_0] +> /discover/nobackup/projects/gmao/dadev/rtodling/archive/Restarts/x0045_C180/rs_coupled/Y2020/M11/x0045.rst.20201129_21z.tar + +Run model-adjoint-related applications (0=no,1=yes)? [0] +> + +Run analysis-sensitivity applications (0=no,1=yes)? [0] +> + +Ending year-month-day? [20191121] +> 20210206 + +Length of FORECAST run segments (in hours)? [123] +> + +Number of one-day DAS segments per PBS job? [1] +> + +Number of PEs in the zonal direction (NX)? [8] +> 20 + +Number of PEs in the meridional direction (NY)? [48] +> 60 + +Job nickname? [g5das] +> c01 + +Run in split executable mode (1=yes;0=no)? [1] +> + +Frequency of background fields (min)? [180] +> 60 + +Triangular spectral truncation? [254] +> + +Analysis vertical levels (sig))? [72] +> + +GSI grid resolution? [NA] +> + +GEOS grid resolution instead? [d] +> + +Ensemble Hybrid (<0;3=3dHyb;4=Hyb4d)? [-1] +> 4 + +Number of procs in the zonal direction (NX)? [12] +> 16 + +Number of procs in the meridional direction (NY)? [20] +> 42 + +Which main class of ObsSys (1: NRT; 2: MERRA; 3: MERRA-2)? [1] +> + +OBSERVING SYSTEM CLASSES? +> disc_airs_bufr,disc_amsua_bufr,gmao_amsr2_bufr,gmao_gmi_bufr,mls_nrt_nc,ncep_1bamua_bufr,ncep_1bhrs4_bufr,ncep_acftpfl_bufr,ncep_atms_bufr,ncep_aura_omi_bufr,ncep_avcsam_bufr,ncep_avcspm_bufr,ncep_crisfsr_bufr,ncep_goesfv_bufr,ncep_gpsro_com_bufr,ncep_mhs_bufr,ncep_mtiasi_bufr,ncep_prep_bufr,ncep_satwnd_bufr,ncep_sevcsr_bufr,ncep_ssmis_bufr,ncep_tcvitals,npp_ompsnm_bufr,gmao_mlst_bufr + +CHECKING OBSYSTEM? [2] +> 1 + +Which RADCOR option? [NONE] +> + +Use sat channel-correlated observation errors (y/n)? [y] +> + +Use aircraft bias correction (y/n)? [y] +> + +Use unified radiance bias correction (y/n)? [y] +> + +Land DAS Analysis (y/n)? [n] +> + +Frequency (in days) for writing restarts? [0] +> + +Frequency for PROGNOSTIC fields? [010000] +> + +Frequency for surface (2D) DIAGNOSTIC fields? [010000] +> + +Frequency for upper air (3D) DIAGNOSTIC fields? [030000] +> + +Dimension of output in zonal direction? [576] +> + +Dimension of output in meridional direction? [361] +> + +Would you like 2D diagnostics? [y] +> + +Would you like 3D diagnostics? [y] +> + +Would you like to compress diagnostics output files? [n] +> + +Include GOCART tracers (CO,CO2,aerosols,etc) (y/n)? [y] +> + +Select GOCART Emission Files to use: [OPS] +> + +Do Aerosol Analysis (y/n)? [y] +> + +AOD OBSERVING CLASSES [or type 'none']? +> + +Enable GAAS feedback to model (y/n)? [y] +> + +Which template? [HISTORY.rc.tmpl] +> + +Which template? [GCMPROG.rc.tmpl] +> + +Output Restart TYPE (bin or nc4) [nc4] +> + +Select group: [s0818] +> g0613 + +Replayed Ensemble (from OPS)? [yes] +> + +Replay exp name? [x0045a] +> x0045a + +Replay archive directory? [/discover/nobackup/projects/gmao/dadev/dao_it/archive/x0045a] +> /discover/nobackup/projects/gmao/dadev/dao_it/archive/x0045a + +Edit COLLECTIONS list in run/HISTORY.rc.tmpl (y/n)? [n] +> + +Edit COLLECTIONS list in fcst/HISTORY.rc.tmpl (y/n)? [n] +> + +Edit files in run directory for CERES configuration (y/n)? [n] +> + +Which? [Q] +> diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atm_ens.j b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atm_ens.j index dde126e5..b668a4f7 100755 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atm_ens.j +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atm_ens.j @@ -95,7 +95,7 @@ # ------------------------ # unsetenv LD_LIBRARY_PATH source $FVROOT/bin/g5_modules -# setenv LD_LIBRARY_PATH \${LD_LIBRARY_PATH}:\${BASEDIR}/\${ARCH}/lib:\${FVROOT}/lib +# setenv LD_LIBRARY_PATH \${BASEDIR}/\${ARCH}/lib:\${FVROOT}/lib:\${LD_LIBRARY_PATH} # Add FVROOT/bin to front of path so fvDAS binaries are found first # ----------------------------------------------------------------- From 2fb0e6b139d358cf0243477a7cbd0152c618169c Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Sun, 31 Oct 2021 11:08:00 -0400 Subject: [PATCH 097/205] minor --- src/Applications/GEOSdas_App/GEOSdas.csm | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Applications/GEOSdas_App/GEOSdas.csm b/src/Applications/GEOSdas_App/GEOSdas.csm index b4d99163..4e495706 100755 --- a/src/Applications/GEOSdas_App/GEOSdas.csm +++ b/src/Applications/GEOSdas_App/GEOSdas.csm @@ -5145,6 +5145,10 @@ endif endif if ( -d $FVHOME/run/mom ) then # this needs revision + set GcmBegDate = $GcmBegEpoch[1] + set GcmBegTime = $GcmBegEpoch[2] + set GcmEndDate = $GcmEndEpoch[1] + set GcmEndTime = $GcmEndEpoch[2] mom6diag.csh $EXPID $GcmBegDate $GcmBegTime $GcmEndDate $GcmEndTime endif From c61d589859a137aa49eaf3af944034794bd4ca82 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Sun, 31 Oct 2021 13:10:42 -0400 Subject: [PATCH 098/205] pertinent to the latest changes --- components.yaml | 8 ++++---- src/Applications/GEOSdas_App/mom6diag.csh | 4 ++-- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/components.yaml b/components.yaml index 092a5939..c12091d5 100644 --- a/components.yaml +++ b/components.yaml @@ -11,7 +11,7 @@ env: cmake: local: ./@cmake remote: ../ESMA_cmake.git - tag: v3.5.8 + tag: v3.5.2 develop: develop ecbuild: @@ -46,13 +46,13 @@ FMS: GEOSana_GridComp: local: ./src/Components/@GEOSana_GridComp remote: ../GEOSana_GridComp.git - branch: feature/rtodling/bkerror_check + branch: feature/rtodling/nc_diag_rev1 develop: develop GEOSgcm_GridComp: local: ./src/Components/@GEOSgcm_GridComp remote: ../GEOSgcm_GridComp.git - tag: v1.12.4 + branch: feature/rtodling/gcm_1_12_4_mom6_quarter_res sparse: ./config/GEOSgcm_GridComp.sparse develop: develop @@ -121,7 +121,7 @@ mom6: GEOSgcm_App: local: ./src/Applications/@GEOSgcm_App remote: ../GEOSgcm_App.git - tag: v1.5.4 + branch: feature/rtodling/v1_5_4_onlXoffl_flags develop: develop UMD_Etc: diff --git a/src/Applications/GEOSdas_App/mom6diag.csh b/src/Applications/GEOSdas_App/mom6diag.csh index 6dd2b0f0..e2fa656c 100755 --- a/src/Applications/GEOSdas_App/mom6diag.csh +++ b/src/Applications/GEOSdas_App/mom6diag.csh @@ -13,8 +13,8 @@ set begtime = $3 set enddate = $4 set endtime = $5 -set bhh = `echo $begtime | cut -c1-2`` -set ehh = `echo $endtime | cut -c1-2`` +set bhh = `echo $begtime | cut -c1-2` +set ehh = `echo $endtime | cut -c1-2` set begtag = ${begdate}_${bhh}z set endtag = ${enddate}_${bhh}z From 0ca1a0fa237eead2792deba3ac23500f582296a7 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Mon, 1 Nov 2021 05:52:10 -0400 Subject: [PATCH 099/205] make sure right branch is used; other changes fix template for mom output --- components.yaml | 2 +- src/Applications/GEOSdas_App/GEOSdas.csm | 4 +++ src/Applications/GEOSdas_App/gen_silo_arc.pl | 6 ++--- src/Applications/GEOSdas_App/mom6diag.csh | 28 +++++++++++++++++--- 4 files changed, 33 insertions(+), 7 deletions(-) diff --git a/components.yaml b/components.yaml index c12091d5..c15b62e7 100644 --- a/components.yaml +++ b/components.yaml @@ -65,7 +65,7 @@ g5pert: GEOSagcmPert_GridComp: local: ./src/Components/@GEOSagcmPert_GridComp remote: ../GEOSagcmPert_GridComp.git - tag: v1.2.0 + branch: feature/rtodling/bug_fixNno_evecs develop: main FVdycoreCubed_GridComp: diff --git a/src/Applications/GEOSdas_App/GEOSdas.csm b/src/Applications/GEOSdas_App/GEOSdas.csm index 4e495706..32775d0a 100755 --- a/src/Applications/GEOSdas_App/GEOSdas.csm +++ b/src/Applications/GEOSdas_App/GEOSdas.csm @@ -5150,6 +5150,10 @@ endif set GcmEndDate = $GcmEndEpoch[1] set GcmEndTime = $GcmEndEpoch[2] mom6diag.csh $EXPID $GcmBegDate $GcmBegTime $GcmEndDate $GcmEndTime + if ( $status ) then + echo " Trouble in SplitExecPostProcessing_(mom6diag) aborting ..." + exit 1 + endif endif exit 0 diff --git a/src/Applications/GEOSdas_App/gen_silo_arc.pl b/src/Applications/GEOSdas_App/gen_silo_arc.pl index 53bcfbf7..032951a9 100755 --- a/src/Applications/GEOSdas_App/gen_silo_arc.pl +++ b/src/Applications/GEOSdas_App/gen_silo_arc.pl @@ -748,9 +748,9 @@ sub append_other_info { # MOM6 OUTPUT: Wired for now # ------------------------------- # -\${PESTOROOT}%s/mom/Y%y4/M%m2/%s.forcing.y4%m2%d2_%h2z+%y4%m2%d2_%h2z.nc4 -\${PESTOROOT}%s/mom/Y%y4/M%m2/%s.prog_z.y4%m2%d2_%h2z+%y4%m2%d2_%h2z.nc4 -\${PESTOROOT}%s/mom/Y%y4/M%m2/%s.sfc_ave.y4%m2%d2_%h2z+%y4%m2%d2_%h2z.nc4 +\${PESTOROOT}%s/mom/Y%y4/M%m2/%s.forcing.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z.nc4 +\${PESTOROOT}%s/mom/Y%y4/M%m2/%s.prog_z.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z.nc4 +\${PESTOROOT}%s/mom/Y%y4/M%m2/%s.sfc_ave.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z.nc4 EOF } diff --git a/src/Applications/GEOSdas_App/mom6diag.csh b/src/Applications/GEOSdas_App/mom6diag.csh index e2fa656c..c2211c93 100755 --- a/src/Applications/GEOSdas_App/mom6diag.csh +++ b/src/Applications/GEOSdas_App/mom6diag.csh @@ -1,12 +1,26 @@ -#!/bin/csh +#!/bin/csh -x # THIS IS TEMPORARY: should be replaced w/ better script +setenv MYNAME "mom6diag.csh" if ( $#argv < 5 ) then echo " Usage: mom6diag.csh EXPID YYYYMMDD HHMMSS YYYYMMDD HHMMSS" exit 1 endif +setenv FAILED 0 +if ( !($?FVHOME) ) setenv FAILED 1 +if ( !($?FVROOT) ) setenv FAILED 1 +if ( !($?FVWORK) ) setenv FAILED 1 + +if ( $FAILED ) then + env + echo " ${MYNAME}: not all required env vars defined" + exit 1 +endif + +set path = ( . $FVHOME/run $FVROOT/bin $path ) + set expid = $1 set begdate = $2 set begtime = $3 @@ -17,8 +31,16 @@ set bhh = `echo $begtime | cut -c1-2` set ehh = `echo $endtime | cut -c1-2` set begtag = ${begdate}_${bhh}z -set endtag = ${enddate}_${bhh}z +set endtag = ${enddate}_${ehh}z +cd $FVWORK foreach ftype ( prog_z forcing sfc_ave ) - /bin/mv $ftype.nc $expid.${begtag}+${endtag}.nc4 + if ( -e $ftype.nc ) then + /bin/mv $ftype.nc $expid.$ftype.${begtag}+${endtag}.nc4 + else + echo "${MYNAME}: trouble finding expected output $ftype.nc" + exit 2 + endif end +cd - +exit 0 From f3444424ca5351f334ad12dd76bce33ca8f77c0a Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Mon, 1 Nov 2021 07:59:04 -0400 Subject: [PATCH 100/205] add FPP to help OPS; let new x-exp run on skylake --- .../GEOSdas_App/testsuites/fpp.input | 248 ++++++++++++++++++ .../GEOSdas_App/testsuites/x0046a.input | 2 +- 2 files changed, 249 insertions(+), 1 deletion(-) create mode 100644 src/Applications/GEOSdas_App/testsuites/fpp.input diff --git a/src/Applications/GEOSdas_App/testsuites/fpp.input b/src/Applications/GEOSdas_App/testsuites/fpp.input new file mode 100644 index 00000000..b448b2d5 --- /dev/null +++ b/src/Applications/GEOSdas_App/testsuites/fpp.input @@ -0,0 +1,248 @@ +#------------ +# fpp.input +#------------ + +description: fpp__GEOSadas-5_29_3__agrid_C720__ogrid_C +tag: GEOSadas-5_29_3 + +---ENDHEADERS--- + +Remote account for Intranet plots? [dao_ops@train] +> + +Is this a MERRA2 experiment (y/n)? [n] +> + +AGCM Horizontal Resolution? [C48] +> C720 + +AGCM Vertical Resolution? [72] +> + +OGCM Resolution? [f] +> C + +EXPID? [u000_C720] +> $expid + +Check for previous use of expid (y/n)? [y] +> n + +EXPDSC? [fpp__GEOSadas-5_29_3__agrid_C720__ogrid_C] +> + +Land Boundary Conditions? [Icarus_Updated] +> Icarus-NLv3 + +Catchment Model choice? [1] +> + +FVHOME? [/discover/nobackup/dao_ops/fpp] +> /gpfsm/dnb04/projects/p14/intermediate/$expid + +The directory /gpfsm/dnb04/projects/p14/intermediate/fpp does not exist. Create it now? [y] +> + +Processing nodes (1:Westmere, 2:SandyBridge, 3:Ivy Bridge, 4:Haswell, 5:Skylake, 6:Cascase)? [4] +> 5 + +Which case of variational analysis? [1] +> + +Window of the variational analysis (min)? [360] +> + +FVINPUT? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar] +> + +REAL TIME BCS? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/g5gcm/bcs/realtime/OSTIA_REYNOLDS] +> + +agcmpert? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/agcmpert] +> + +g5chem? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/g5chem] +> + +g5gcm? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/g5gcm] +> + +PIESA? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/PIESA] +> + +MERRA2? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/MERRA2] +> + +AeroCom? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/AeroCom] +> + +FVICS? [/archive/u/jstassi/restarts/GEOSadas-5_24_0] +> /nfs3m/archive/sfa_cache01/projects/dao_ops/GEOS-5.27/GEOSadas-5_27/f5271_fp/rs/Y2021/M09/f5271_fp.rst.20210919_21z.tar + +Run model-adjoint-related applications (0=no,1=yes)? [0] +> 1 + +Analysis/Forecast filename template for sensitivity? +> + +Stage the gradient vector files (y/n)? [y] +> + +Run singular vector experiments (0=n,1=yes)? [0] +> + +Run analysis-sensitivity applications (0=no,1=yes)? [0] +> 1 + +Verifying experiment id: [fpp] +> + +Ending year-month-day? [20210921] +> 20211004 + +Length of FORECAST run segments (in hours)? [123] +> + +Number of one-day DAS segments per PBS job? [1] +> + +Number of PEs in the zonal direction (NX)? [28] +> 15 + +Number of PEs in the meridional direction (NY)? [48] +> 360 + +Job nickname? [g5das] +> $expid + +Run in split executable mode (1=yes;0=no)? [1] +> + +Frequency of background fields (min)? [180] +> 60 + +Triangular spectral truncation? [254] +> + +Analysis vertical levels (sig))? [72] +> + +GSI grid resolution? [NA] +> + +GEOS grid resolution instead? [e] +> + +Ensemble Hybrid (<0;3=3dHyb;4=Hyb4d)? [-1] +> 4 + +Number of procs in the zonal direction (NX)? [16] +> 27 + +Number of procs in the meridional direction (NY)? [42] +> + +Which main class of ObsSys (1: NRT; 2: MERRA; 3: MERRA-2)? [1] +> 1 + +OBSERVING SYSTEM CLASSES? +> disc_airs_bufr,disc_amsua_bufr,gmao_amsr2_bufr,gmao_gmi_bufr,mls_nrt_nc,ncep_1bamua_bufr,ncep_1bhrs4_bufr,ncep_acftpfl_bufr,ncep_atms_bufr,ncep_aura_omi_bufr,ncep_avcsam_bufr,ncep_avcspm_bufr,ncep_crisfsr_bufr,ncep_goesfv_bufr,ncep_gpsro_bufr,ncep_mhs_bufr,ncep_mtiasi_bufr,ncep_prep_bufr,ncep_satwnd_bufr,ncep_sevcsr_bufr,ncep_ssmis_bufr,ncep_tcvitals,npp_ompsnm_bufr,gmao_mlst_bufr + +CHECKING OBSYSTEM? [2] +> 1 + +Which RADCOR option? [NONE] +> + +Use sat channel-correlated observation errors (y/n)? [y] +> + +Use aircraft bias correction (y/n)? [y] +> + +Use unified radiance bias correction (y/n)? [y] +> + +Land DAS Analysis (y/n)? [n] +> + +Frequency (in days) for writing restarts? [0] +> + +Frequency for PROGNOSTIC fields? [010000] +> + +Frequency for surface (2D) DIAGNOSTIC fields? [010000] +> + +Frequency for upper air (3D) DIAGNOSTIC fields? [030000] +> + +Dimension of output in zonal direction? [1152] +> + +Dimension of output in meridional direction? [721] +> + +Would you like 2D diagnostics? [y] +> + +Would you like 3D diagnostics? [y] +> + +Would you like to compress diagnostics output files? [n] +> + +Include GOCART tracers (CO,CO2,aerosols,etc) (y/n)? [y] +> + +Select GOCART Emission Files to use: [OPS] +> + +Do Aerosol Analysis (y/n)? [y] +> + +AOD OBSERVING CLASSES [or type 'none']? +> + +Enable GAAS feedback to model (y/n)? [y] +> + +Which template? [HISTORY.rc.tmpl] +> + +Which template? [GCMPROG.rc.tmpl] +> + +Output Restart TYPE (bin or nc4) [nc4] +> + +Select group: [g0613] +> + +Replayed Ensemble? [yes] +> no + +Use SPPT-scheme for Ensemble? [yes] +> + +Ensemble Resolution? [C90] +> C180 + +Ensemble Vertical Levels? [72] +> + +Experiment archive directory for ensemble restarts or 'later': [/archive/u/dao_ops/fpp] +> /nfs3m/archive/sfa_cache01/projects/dao_ops/GEOS-5.27/GEOSadas-5_27/f5271_fp + +Edit COLLECTIONS list in run/HISTORY.rc.tmpl (y/n)? [n] +> + +Edit COLLECTIONS list in fcst/HISTORY.rc.tmpl (y/n)? [n] +> + +Edit files in run directory for CERES configuration (y/n)? [n] +> + +Which? [Q] +> diff --git a/src/Applications/GEOSdas_App/testsuites/x0046a.input b/src/Applications/GEOSdas_App/testsuites/x0046a.input index 1009ac7b..ea64afdb 100644 --- a/src/Applications/GEOSdas_App/testsuites/x0046a.input +++ b/src/Applications/GEOSdas_App/testsuites/x0046a.input @@ -44,7 +44,7 @@ The directory /discover/nobackup/projects/gmao/obsdev/dao_it/x0046a already exis > Processing nodes (1:Westmere, 2:SandyBridge, 3:Ivy Bridge, 4:Haswell, 5:Skylake, 6:Cascase)? [4] -> +> 5 Which case of variational analysis? [1] > From 10c2a19888aedab1a54e89d461e35271239b678d Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Mon, 1 Nov 2021 13:53:49 -0400 Subject: [PATCH 101/205] cascade updade in shared --- components.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/components.yaml b/components.yaml index c15b62e7..29f18190 100644 --- a/components.yaml +++ b/components.yaml @@ -28,7 +28,7 @@ NCEP_Shared: GMAO_Shared: local: ./src/Shared/@GMAO_Shared remote: ../GMAO_Shared.git - tag: v1.4.10 + branch: feature/rtodling/cascase develop: main MAPL: From cd23c704179b162c513d9debe0a5a367ec71c61e Mon Sep 17 00:00:00 2001 From: Rolf Reichle <54944691+gmao-rreichle@users.noreply.github.com> Date: Mon, 1 Nov 2021 14:15:32 -0400 Subject: [PATCH 102/205] fixing suggestion of $fvhome as top-level LDAS dir --- src/Applications/GEOSdas_App/fvsetup | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index a4c70ab0..502d4f4e 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -3405,10 +3405,10 @@ sub set_ldasANA { $ldas_flag = 1; } - $ans3 = query("LDAS HOME = $fvhome, full path? "); + $ans3 = query("LDAS HOME = "$fvhome"_LDAS , full path? "); $ldashome = $ans3 ; - $ans4 = query("LDAS HOME for land ensemble = $fvhome/run/atmens, full path? "); + $ans4 = query("LDAS HOME for land ensemble = "$fvhome"_LDAS/run/atmens, full path? "); $ldashome4ens = $ans4 ; } From 003c0d12de3a8d897d374381a15fbf1d84004948 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Tue, 2 Nov 2021 08:53:32 -0400 Subject: [PATCH 103/205] incorrect perl statement from LDAS update --- src/Applications/GEOSdas_App/fvsetup | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index 502d4f4e..19a24e11 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -3401,17 +3401,17 @@ sub set_ldasANA { $ans2 = query(" Enable LDAS feedback to model y/n ? ", $dflt); $ldasfdbk = 1 if yes($ans2); - if ($ldasfdbk ==1 ) { + if ($ldasfdbk == 1 ) { $ldas_flag = 1; } - $ans3 = query("LDAS HOME = "$fvhome"_LDAS , full path? "); + $ans3 = query("LDAS HOME = ${fvhome}_LDAS , full path? ", $ldashome); $ldashome = $ans3 ; - $ans4 = query("LDAS HOME for land ensemble = "$fvhome"_LDAS/run/atmens, full path? "); + $ans4 = query("LDAS HOME for land ensemble = ${fvhome}_LDAS/run/atmens, full path? ", $ldashome4ens); $ldashome4ens = $ans4 ; - } + } return 0; } From c732326078cd04e9807eed1c2dbe4f4db7761f16 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Wed, 3 Nov 2021 05:26:22 -0400 Subject: [PATCH 104/205] knob to adjust version of QFEB on the fly (not tested); near final config for 5.29.3 --- components.yaml | 8 ++++---- src/Applications/GEOSdas_App/GEOSdas.csm | 18 +++++++++++++++++- .../GEOSdas_App/testsuites/fpp.input | 2 +- .../NCEP_enkf/scripts/gmao/gcm_ensset_rc.csh | 5 +++++ 4 files changed, 27 insertions(+), 6 deletions(-) diff --git a/components.yaml b/components.yaml index 29f18190..f268e69a 100644 --- a/components.yaml +++ b/components.yaml @@ -46,13 +46,13 @@ FMS: GEOSana_GridComp: local: ./src/Components/@GEOSana_GridComp remote: ../GEOSana_GridComp.git - branch: feature/rtodling/nc_diag_rev1 + tag: v1.4.5 develop: develop GEOSgcm_GridComp: local: ./src/Components/@GEOSgcm_GridComp remote: ../GEOSgcm_GridComp.git - branch: feature/rtodling/gcm_1_12_4_mom6_quarter_res + tag: rt1_12_4_mom6 sparse: ./config/GEOSgcm_GridComp.sparse develop: develop @@ -65,7 +65,7 @@ g5pert: GEOSagcmPert_GridComp: local: ./src/Components/@GEOSagcmPert_GridComp remote: ../GEOSagcmPert_GridComp.git - branch: feature/rtodling/bug_fixNno_evecs + tag: v5.29.1 develop: main FVdycoreCubed_GridComp: @@ -121,7 +121,7 @@ mom6: GEOSgcm_App: local: ./src/Applications/@GEOSgcm_App remote: ../GEOSgcm_App.git - branch: feature/rtodling/v1_5_4_onlXoffl_flags + tag: rt1_5_4_mom6 develop: develop UMD_Etc: diff --git a/src/Applications/GEOSdas_App/GEOSdas.csm b/src/Applications/GEOSdas_App/GEOSdas.csm index 32775d0a..21767056 100755 --- a/src/Applications/GEOSdas_App/GEOSdas.csm +++ b/src/Applications/GEOSdas_App/GEOSdas.csm @@ -824,6 +824,12 @@ exit 1 cd $FVHOME/run/gocart set extdata_files = `/bin/ls -1 *_ExtData.rc` cat $extdata_files > $FVWORK/ExtData.rc + set hh = `echo $gcm_nhms0 | cut -c1-2` + if ( ${gcm_nymd0}${hh} >= 2021103021 ) then + foreach line (`grep -ni qfed $FVWORK/ExtData.rc | gawk '{print $1}' FS=":"`) + sed -i "${line}s/.006./.061./" $FVWORK/ExtData.rc + end + endif cd - # /bin/cp ExtData.rc $EXPID.ExtData.$itime.rc @@ -3955,8 +3961,8 @@ endif # Which CAP to use? # ----------------- + set hh = `echo $gcm_nhms0 | cut -c1-2` if ( $Final_ ) then - set hh = `echo $gcm_nhms0 | cut -c1-2` set mycap = CAP.rc.tmpl if ( -e CAP_${hh}.rc.tmpl ) set mycap = CAP_${hh}.rc.tmpl else @@ -3988,6 +3994,11 @@ endif set extdata_files = `/bin/ls -1 *_ExtData.rc` cat $extdata_files > $FVWORK/ExtData.rc cd - + if ( ${gcm_nymd0}${hh} >= 2021103021 ) then + foreach line (`grep -ni qfed ExtData.rc | gawk '{print $1}' FS=":"`) + sed -i "${line}s/.006./.061./" ExtData.rc + end + endif /bin/cp ExtData.rc $EXPID.ExtData.$itime.rc # Last line of CoupleAnaToGcm_() @@ -4652,6 +4663,11 @@ endif cd $FVHOME/run/gocart set extdata_files = `/bin/ls -1 *_ExtData.rc` cat $extdata_files > $FVWORK/ExtData.rc + if ( ${gcm_nymd0}${hh} >= 2021103021 ) then + foreach line (`grep -ni qfed $FVWORK/ExtData.rc | gawk '{print $1}' FS=":"`) + sed -i "${line}s/.006./.061./" $FVWORK/ExtData.rc + end + endif cd - # /bin/cp ExtData.rc $EXPID.ExtData.$itime.rc diff --git a/src/Applications/GEOSdas_App/testsuites/fpp.input b/src/Applications/GEOSdas_App/testsuites/fpp.input index b448b2d5..aeb95411 100644 --- a/src/Applications/GEOSdas_App/testsuites/fpp.input +++ b/src/Applications/GEOSdas_App/testsuites/fpp.input @@ -77,7 +77,7 @@ AeroCom? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/AeroCom] > FVICS? [/archive/u/jstassi/restarts/GEOSadas-5_24_0] -> /nfs3m/archive/sfa_cache01/projects/dao_ops/GEOS-5.27/GEOSadas-5_27/f5271_fp/rs/Y2021/M09/f5271_fp.rst.20210919_21z.tar +> /discover/nobackup/projects/gmao/dadev/rtodling/archive/f5293_fpp/Y2021/M09/f5293_fpp.rst.20210919_21z.tar Run model-adjoint-related applications (0=no,1=yes)? [0] > 1 diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/gcm_ensset_rc.csh b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/gcm_ensset_rc.csh index c0537586..9072952d 100644 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/gcm_ensset_rc.csh +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/gcm_ensset_rc.csh @@ -232,6 +232,11 @@ cd $ENSWORK/$member if(-e ExtData.rc) /bin/rm -f ExtData.rc set extdata_files = `/bin/ls -1 *_ExtData.rc` cat $extdata_files > $ENSWORK/${member}/ExtData.rc + if ( ${nymdb}${hhb} >= 2021103021 ) then + foreach line (`grep -ni qfed $ENSWORK/${member}/ExtData.rc | gawk '{print $1}' FS=":"`) + sed -i "${line}s/.006./.061./" $ENSWORK/${member}/ExtData.rc + end + endif if(-e $ATMENSETC/aens_stoch.rc ) /bin/ln -sf $ATMENSETC/aens_stoch.rc $ENSWORK/${member}/stoch.rc From 0aa48dde372f203e49f344f6ee533534d3333479 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Wed, 3 Nov 2021 06:06:45 -0400 Subject: [PATCH 105/205] correct group for OPS --- src/Applications/GEOSdas_App/testsuites/fpp.input | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Applications/GEOSdas_App/testsuites/fpp.input b/src/Applications/GEOSdas_App/testsuites/fpp.input index aeb95411..189640d9 100644 --- a/src/Applications/GEOSdas_App/testsuites/fpp.input +++ b/src/Applications/GEOSdas_App/testsuites/fpp.input @@ -218,7 +218,7 @@ Output Restart TYPE (bin or nc4) [nc4] > Select group: [g0613] -> +> g2538 Replayed Ensemble? [yes] > no From dec93771604595df474b8cfcfcead9eaa5b8b7c7 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Wed, 3 Nov 2021 16:32:33 -0400 Subject: [PATCH 106/205] conf for x0046a; 5.29.3 --- components.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/components.yaml b/components.yaml index f268e69a..ddbb1a75 100644 --- a/components.yaml +++ b/components.yaml @@ -28,7 +28,7 @@ NCEP_Shared: GMAO_Shared: local: ./src/Shared/@GMAO_Shared remote: ../GMAO_Shared.git - branch: feature/rtodling/cascase + tag: rt1_4_10_cas develop: main MAPL: From 281f4ed38b2c41d9b0c49089edd03e232cd245b1 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Fri, 5 Nov 2021 09:38:04 -0400 Subject: [PATCH 107/205] small bug; fixed --- src/Applications/GEOSdas_App/GEOSdas.csm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Applications/GEOSdas_App/GEOSdas.csm b/src/Applications/GEOSdas_App/GEOSdas.csm index 21767056..6c0f5be2 100755 --- a/src/Applications/GEOSdas_App/GEOSdas.csm +++ b/src/Applications/GEOSdas_App/GEOSdas.csm @@ -5953,7 +5953,7 @@ endif if ( $DO4DVAR ) then /bin/mv $EXPID.*rst*iter*.$RSTSUFFIX $FVHOME/recycle/hold endif - if ( ! -d $FVHOME/run/mom ) exit 0 + if ( -d $FVHOME/run/mom ) then set momoutdir = `nmlread.py fvcore_layout.rc MOM_input_nml restart_output_dir` set mylcvs = (`ls -1 $EXPID.rst.lcv*`) set momtag = `echo $mylcvs[1] | cut -d. -f4` From 416231dcc2435981b038af720ca01ba29c8d5c00 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Sat, 6 Nov 2021 08:05:15 -0400 Subject: [PATCH 108/205] bug added when adding feature to address QFED change --- src/Applications/GEOSdas_App/GEOSdas.csm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Applications/GEOSdas_App/GEOSdas.csm b/src/Applications/GEOSdas_App/GEOSdas.csm index 6c0f5be2..a908d734 100755 --- a/src/Applications/GEOSdas_App/GEOSdas.csm +++ b/src/Applications/GEOSdas_App/GEOSdas.csm @@ -4598,6 +4598,7 @@ endif # Which CAP to use? # ----------------- + set nymdt = $GcmBegEpoch[1] set hh = `echo $GcmBegTime | cut -c1-2` set myhist = HISTORY.rc.tmpl if ( -e HISTORY_${hh}.rc.tmpl ) set myhist = HISTORY_${hh}.rc.tmpl @@ -4663,7 +4664,7 @@ endif cd $FVHOME/run/gocart set extdata_files = `/bin/ls -1 *_ExtData.rc` cat $extdata_files > $FVWORK/ExtData.rc - if ( ${gcm_nymd0}${hh} >= 2021103021 ) then + if ( ${nymdt}${hh} >= 2021103021 ) then foreach line (`grep -ni qfed $FVWORK/ExtData.rc | gawk '{print $1}' FS=":"`) sed -i "${line}s/.006./.061./" $FVWORK/ExtData.rc end From 22d04de2433a15dc223a0d639ac43ed52490753f Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Wed, 10 Nov 2021 07:34:14 -0500 Subject: [PATCH 109/205] fcst and das (run) should use the same land setup; somehow this is not a problem in most cases! --- src/Applications/GEOSdas_App/fvsetup | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index 19a24e11..1c5e0bc2 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -9866,6 +9866,7 @@ sub copy_resources { #--ed_g5prog_rc_new("run","GCMPROG.rc.tmpl"); ed_g5hist_rc_new("run","HISTORY.rc.tmpl"); ed_g5surfGC_rc("run","GEOS_SurfaceGridComp.rc"); + ed_g5surfGC_rc("fcst","GEOS_SurfaceGridComp.rc"); writeSaverst($fcsthrs, "$fvhome/run"); ed_blendacq("fcst"); From 08660f18e983561b1a12d63e16bb6d4ae341e619 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Fri, 12 Nov 2021 11:27:41 -0500 Subject: [PATCH 110/205] update ana_gridcomp; trivial but needed fix --- components.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/components.yaml b/components.yaml index ddbb1a75..7e8f1d3f 100644 --- a/components.yaml +++ b/components.yaml @@ -46,7 +46,7 @@ FMS: GEOSana_GridComp: local: ./src/Components/@GEOSana_GridComp remote: ../GEOSana_GridComp.git - tag: v1.4.5 + tag: v1.4.5.1 develop: develop GEOSgcm_GridComp: From 8fa93f56d3964ea14dbf6a686ec2f737cd321b28 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Fri, 12 Nov 2021 12:03:21 -0500 Subject: [PATCH 111/205] changed analysis tag following rules of the game --- components.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/components.yaml b/components.yaml index 7e8f1d3f..e4b0ca4a 100644 --- a/components.yaml +++ b/components.yaml @@ -46,7 +46,7 @@ FMS: GEOSana_GridComp: local: ./src/Components/@GEOSana_GridComp remote: ../GEOSana_GridComp.git - tag: v1.4.5.1 + tag: v1.5.0 develop: develop GEOSgcm_GridComp: From b40b40fd5566b7b4e532b1f602d1ea827baf6b03 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Tue, 16 Nov 2021 10:12:30 -0500 Subject: [PATCH 112/205] adjustment for C720 and higher case - enable o-server --- src/Applications/GEOSdas_App/fvsetup | 87 +++++++++++++++++++++++----- 1 file changed, 73 insertions(+), 14 deletions(-) diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index 1c5e0bc2..9eca6011 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -386,11 +386,13 @@ my ($acqloc); my ($fcstimes,$fcswait_hrs,$asnwait_hrs); my ($landbcs); my ($coupled, $ores, $mometc); +my ($o_servers); my ($sysfile, $nodeflg); my (@rmTilde); my ($merra2, $acftbias, $doRcorr, $nrt, $rstype); my ($hyb_ens, $do4diau, $newradbc, $siglevs, $vres, $aensupa); +my ($geosit, $r21c); system clear; get_runtime_values(); @@ -478,7 +480,7 @@ $ENV{"PATH"} = $FindBin::Bin .":$ENV{PATH}"; # -------------------------------- welcome(); while3 ( \&get_rem_acct_info ); - while3 ( \&get_reanalysis_info ); + while3 ( \&get_specific_info ); get_dimsg5gcm(); # User defined options @@ -1209,13 +1211,19 @@ sub defaults { } #======================================================================= -sub get_reanalysis_info { +sub get_specific_info { + $geosit = 0; $merra2 = 0; - $ans = query("\n Is this a MERRA2 experiment (y/n)?", "n"); - $merra2 = 1 if yes($ans); + $r21c = 0; + + $ans = query(" Is this a MERRA2 (1), GEOSIT (2), R21C (3) experiment?", "0"); + return 0 unless ( $ans ); + + if ($ans == 1) {$merra2 = 1}; + if ($ans == 2) {$geosit = 1}; + if ($ans == 3) {$r21c = 1}; - return 0; } #======================================================================= @@ -3498,6 +3506,11 @@ EOF $berror_file = "\$FVHOME/fvInput/gsi/etc/berror_gmao/gmao24Jun2011_fp+oz_fix/MERRA2/Final"; $berror_env = "setenv BERROR $berror_file"; } + if ( $geosit ) { + # $berror_file = "\$FVHOME/fvInput/gsi/etc/berror_gmao/gmao24Jun2011_fp+oz_fix/MERRA2/Final"; + # $berror_env = "setenv BERROR $berror_file"; + $berror_env = "# Likely need to point to new BERROR for GEOSIT (adjust fvsetup)"; + } } if ( $siglevs == 72 || $siglevs == 91 || $siglevs == 132 || $siglevs == 137 || $siglevs == 181 ) { $hybrid = ".true." }; @@ -4305,10 +4318,15 @@ sub get_history { # query for HISTORY.rc.tmpl file #------------------------------- @HISTORY = ( <$fvetc/HISTORY*.rc.tmpl*> ); + $g5hist_rc = "HISTORY.rc.tmpl"; if ( $merra2 ) { $g5hist_rc = "HISTORY_MERRA2.rc.tmpl"; - } else { - $g5hist_rc = "HISTORY.rc.tmpl"; + } + if ( $geosit ) { + $g5hist_rc = "HISTORY_GEOSIT.rc.tmpl"; + } + if ( $r21c ) { + $g5hist_rc = "HISTORY_R21C.rc.tmpl"; } $g5hist_rc = basename $HISTORY[0] unless -e "$fvetc/$g5hist_rc"; @@ -4682,6 +4700,7 @@ EOF $nx_pert = 1; $ny_pert = 6 * $nx_pert; $use_shmem = 0; + $o_servers = 0; $ios_nds = 1; $cldmicro = "1MOMENT"; if ( "$res" eq "c" && "$vres" eq "55" ) { @@ -5022,6 +5041,7 @@ EOF $ana_jm_ens = 181; } elsif ( "$res" eq "C720" ) { # Cubed-sphere $cubed = 1; + $o_servers = 8; # $ios_nds = 3; $specres = "254"; $jcap = "254"; @@ -5056,6 +5076,7 @@ EOF $ana_jm_ens = 361; } elsif ( "$res" eq "C1440" ) { # Cubed-sphere $cubed = 1; + $o_servers = 8; # $ios_nds = 4; $specres = "254"; $jcap = "254"; @@ -7478,6 +7499,8 @@ if ( $fvchem && $lm > 2 ) { } $pi = $i; # p for PSAS + my $xncpus = $ncpus + $o_servers * $ncpus_per_node; + # Turn off some parallelization on discover #------------------------------------------ if ( ($siteID eq "nccs") || ($siteID eq "nas") ) { @@ -7516,7 +7539,7 @@ if ( $siteID eq "nccs" ) { print SCRIPT <<"EOF"; #SBATCH --job-name=$jobn #SBATCH --output=$jobn.log.o%j.txt -#SBATCH --ntasks=$ncpus +#SBATCH --ntasks=$xncpus #SBATCH --ntasks-per-node=$ncpus_per_node #SBATCH --constraint=$nodeflg #SBATCH --time=${daswallclk}:00 @@ -7591,11 +7614,13 @@ print SCRIPT <<"EOF"; setenv ARCH `uname -s` setenv HOST `uname -n` setenv NCPUS $ncpus # Number of CPUs to run GCM + setenv NCPUSX $xncpus # Number of CPUs plus IO-server requirement setenv NCPUS_IDF $ncpus_idf # Number of CPUs to run IDF setenv NCPUS_IAU $ncpus_iau # Number of CPUs to run IAU setenv NCPUS_GSI $ncpus_gsi # Number of CPUs to run GSI setenv NCPUS_GPERT $ncpus_gpert # Number of CPUs to run gcmPERT setenv NCPUS_AOD $ncpus_aod # Number of CPUs to run PSAS-AOD + setenv O_SERVERS $o_servers # Number of IO servers setenv GAAS_RUN_SLURM 1 # launch AOD analysis as separate batch job setenv AODBLOCKJOB 1 EOF @@ -7821,9 +7846,10 @@ print SCRIPT <<"EOF"; setenv PSM2_MEMORY large setenv I_MPI_ADJUST_GATHERV 3 setenv I_MPI_ADJUST_ALLREDUCE 12 -# setenv I_MPI_EXTRA_FILESYSTEM 1 -# setenv I_MPI_EXTRA_FILESYSTEM_LIST gpfs -# setenv ROMIO_FSTYPE_FORCE "gpfs:" + setenv I_MPI_EXTRA_FILESYSTEM 1 + setenv I_MPI_EXTRA_FILESYSTEM_LIST gpfs + setenv ROMIO_FSTYPE_FORCE "gpfs:" + setenv I_MPI_FABRICS shm:ofi # setenv I_MPI_FABRICS shm:dapl # setenv I_MPI_FABRICS_LIST "dapl,ofa" # setenv I_MPI_FALLBACK "enable" @@ -7985,7 +8011,11 @@ print SCRIPT <<"EOF"; endif setenv RUN_OPT_BLEND "esma_mpirun -np \$NCPUS \$HDF2RSX" if (\$G5GCM ) then - setenv RUN_OPT_BEGIN "esma_mpirun -np \$NCPUS \$GCMX" + if ( \$O_SERVERS > 0 ) then + setenv RUN_OPT_BEGIN "mpirun -np \$NCPUSX \$GCMX --npes_model \$NCUPS --nodes_output_server \$O_SERVERS --oserver_type multigroup --npes_backend_pernode \$O_SERVERS" + else + setenv RUN_OPT_BEGIN "esma_mpirun -np \$NCPUS \$GCMX" + endif setenv ADMRUN_OPT_BEGIN "esma_mpirun -np \$NCPUS_GPERT \$GCMPTX" else setenv RUN_OPT_BEGIN "esma_mpirun -np \$AGCM_NUM_MPI \$GCMX" @@ -8672,6 +8702,8 @@ sub create_fscript { open(SCRIPT,">$fvhome/fcst/$jobf.j") or die ">>> ERROR <<< cannot write $fvhome/fcst/$jobf.j"; + my $xncpus = $ncpus + $o_servers * $ncpus_per_node; + print SCRIPT <<"EOF"; #!/bin/csh -fx # ------------------------------------------ @@ -8690,7 +8722,7 @@ if ( $siteID eq "nccs" ) { print SCRIPT <<"EOF"; #SBATCH --job-name=fcst #SBATCH --output=fcst.log.o%j.txt -#SBATCH --ntasks=$ncpus +#SBATCH --ntasks=$xncpus #SBATCH --ntasks-per-node=$ncpus_per_node #SBATCH --constraint=$nodeflg #SBATCH --time=${fcswallclk}:00 @@ -8760,10 +8792,12 @@ print SCRIPT <<"EOF"; setenv ARCH `uname -s` setenv HOST `uname -n` setenv NCPUS $ncpus # number of CPUS + setenv NCPUSX $xncpus # NCPUS plus IO-server requirements setenv NCPUS_IDF $ncpus_idf # Numbers of CPUs to run IDF setenv NCPUS_IAU $ncpus_iau # Numbers of CPUs to run IAU setenv NCPUS_GSI $ncpus_gsi # Numbers of CPUs to run GSI setenv NCPUS_GPERT $ncpus_gpert # Numbers of CPUs to run GSI + setenv O_SERVERS $o_servers # Number of IO servers setenv N_CPU \$NCPUS setenv EXPID $expid # experiment ID setenv CASE \$EXPID # experiment ID (for LSM's sake) @@ -8875,6 +8909,7 @@ print SCRIPT <<"EOF"; # ----------------- if (\$?I_MPI_ROOT) then # setenv I_MPI_USE_DYNAMIC_CONNECTIONS 0 + setenv I_MPI_FABRICS shm:ofi # setenv I_MPI_FABRICS shm:dapl # setenv I_MPI_FABRICS_LIST "dapl,ofa" # setenv I_MPI_FALLBACK "enable" @@ -9160,7 +9195,11 @@ print SCRIPT <<"EOF"; setenv MPIRUN "esma_mpirun -np \$PSAS_NUM_MPI " setenv RUN_OPT_BLEND "esma_mpirun -np \$NCPUS \$HDF2RSX" if (\$G5GCM ) then - setenv RUN_OPT_BEGIN "esma_mpirun -np \$NCPUS \$GCMX" + if ( \$O_SERVERS > 0 ) then + setenv RUN_OPT_BEGIN "mpirun -np \$NCPUSX \$GCMX --npes_model \$NCUPS --nodes_output_server \$O_SERVERS --oserver_type multigroup --npes_backend_pernode \$O_SERVERS" + else + setenv RUN_OPT_BEGIN "esma_mpirun -np \$NCPUS \$GCMX" + endif setenv ADMRUN_OPT_BEGIN "esma_mpirun -np \$NCPUS_GPERT \$GCMPTX" else setenv RUN_OPT_BEGIN "esma_mpirun -np \$AGCM_NUM_MPI \$GCMX" @@ -10080,6 +10119,26 @@ sub copy_resources { if (-e "$pyradmon/scripts/radmon.defaults.rc") { cp("$pyradmon/scripts/radmon.defaults.rc", "$fvhome/radmon"); } + +# When applicable, overwrite w/ pre-set RC files for GSI +# ------------------------------------------------------ + if ( $geosit ) { + if ( -d "$fvetc/gsi/GEOSIT" ) { + my @files = glob("$fvetc/gsi/GEOSIT" . "/*"); + foreach my $fn ( @files ) { + cp("$fn", "$fvhome/run"); + } + } + } + if ( $r21c ) { + if ( -d "$fvetc/gsi/R21C" ) { + my @files = glob("$fvetc/gsi/R21C" . "/*"); + foreach my $fn ( @files ) { + cp("$fn", "$fvhome/run"); + } + } + } + } #======================================================================= From aa78bc3ebb65574ef502b5b085d7787e154d8545 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Tue, 16 Nov 2021 10:14:16 -0500 Subject: [PATCH 113/205] adjust batch time to more reasonable value --- src/Applications/GEOSdas_App/Create_anasa_script.pm | 2 +- src/Applications/GEOSdas_App/Create_asens_script.pm | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Applications/GEOSdas_App/Create_anasa_script.pm b/src/Applications/GEOSdas_App/Create_anasa_script.pm index 1a76ede1..f5bdae0a 100644 --- a/src/Applications/GEOSdas_App/Create_anasa_script.pm +++ b/src/Applications/GEOSdas_App/Create_anasa_script.pm @@ -96,7 +96,7 @@ sub anasa_script { #SBATCH --ntasks=$ncpus_gsi #SBATCH --ntasks-per-node=24 #SBATCH --constraint=$nodeflg -#SBATCH --time=${fcswallclk}:00 +#SBATCH --time=1:30:00 #PBS -N anasa #PBS -o anasa.log.o%j #PBS -l ncpus=$ncpus_gsi diff --git a/src/Applications/GEOSdas_App/Create_asens_script.pm b/src/Applications/GEOSdas_App/Create_asens_script.pm index e2007d73..b45798fe 100644 --- a/src/Applications/GEOSdas_App/Create_asens_script.pm +++ b/src/Applications/GEOSdas_App/Create_asens_script.pm @@ -97,7 +97,7 @@ sub asens_script { #SBATCH --ntasks=$ncpus_gsi #SBATCH --ntasks-per-node=24 #SBATCH --constraint=$nodeflg -#SBATCH --time=${fcswallclk}:00 +#SBATCH --time=2:00:00 #PBS -N asens #PBS -o asens.log.o%j.txt #PBS -l ncpus=$ncpus_gsi From fa30fd696801aaa5724e4d58708997a5c3185f30 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Tue, 16 Nov 2021 10:15:16 -0500 Subject: [PATCH 114/205] support for GEOS-IT --- src/Applications/GEOSdas_App/edhist.pl | 8 ++++++-- .../GEOSdas_App/testsuites/C180RPY.input | 2 +- .../GEOSdas_App/testsuites/C180T14RPY.input | 2 +- .../GEOSdas_App/testsuites/C360L181_replay.input | 2 +- .../GEOSdas_App/testsuites/C360L91_replay.input | 2 +- .../GEOSdas_App/testsuites/C48f.input | 2 +- .../GEOSdas_App/testsuites/C90C.input | 2 +- .../GEOSdas_App/testsuites/C90C_ens.input | 2 +- .../GEOSdas_App/testsuites/C90C_replay.input | 2 +- .../GEOSdas_App/testsuites/fpp.input | 2 +- .../GEOSdas_App/testsuites/geos_it.input | 16 ++++++++-------- .../GEOSdas_App/testsuites/prePP.input | 2 +- .../GEOSdas_App/testsuites/x0046a.input | 2 +- .../GEOSdas_App/testsuites/x0046aRPY.input | 2 +- 14 files changed, 26 insertions(+), 22 deletions(-) diff --git a/src/Applications/GEOSdas_App/edhist.pl b/src/Applications/GEOSdas_App/edhist.pl index c54c8a73..934dc36f 100755 --- a/src/Applications/GEOSdas_App/edhist.pl +++ b/src/Applications/GEOSdas_App/edhist.pl @@ -1359,10 +1359,14 @@ sub add_silo_mstorage_traits { my (@anaID, @chemID, @diagID, @progID, $name, $storage); @anaID = qw( vtx .eta .sfc .prs ); - @chemID = qw( _adg_ _aer_ _chm_ _gas_ _nav_ _tag_ ); + @chemID = qw( _adg_ _aer_ _chm_ _gas_ _nav_ _tag_ + adg_ aer_ chm_ gas_ nav_ tag_ ); @diagID = qw( _asm_ _chm_ _cld_ _csp_ _dyn_ _ext_ _flx_ _glc_ _hwl_ _int_ _lfo_ _lnd_ _lsf_ _met_ _mst_ _ocn_ - _odt_ _qdt_ _rad_ _slv_ _tdt_ _tmp_ _trb_ _udt_ _wnd_ ); + _odt_ _qdt_ _rad_ _slv_ _tdt_ _tmp_ _trb_ _udt_ _wnd_ + asm_ cld_ csp_ dyn_ ext_ flx_ glc_ + hwl_ int_ lfo_ lnd_ lsf_ met_ mst_ ocn_ + odt_ qdt_ rad_ slv_ tdt_ tmp_ trb_ udt_ wnd_ ); @progID = qw( prog traj ptrj ); # add silo trait if not present diff --git a/src/Applications/GEOSdas_App/testsuites/C180RPY.input b/src/Applications/GEOSdas_App/testsuites/C180RPY.input index 291e418d..f23b3938 100644 --- a/src/Applications/GEOSdas_App/testsuites/C180RPY.input +++ b/src/Applications/GEOSdas_App/testsuites/C180RPY.input @@ -10,7 +10,7 @@ tag: GEOSadas-5_29_3 Remote account for Intranet plots? [rtodling@train] > -Is this a MERRA2 experiment (y/n)? [n] +Is this a MERRA2 (1), GEOSIT (2), R21C (3) experiment? [0] > AGCM Horizontal Resolution? [C48] diff --git a/src/Applications/GEOSdas_App/testsuites/C180T14RPY.input b/src/Applications/GEOSdas_App/testsuites/C180T14RPY.input index eab985b3..3d137dfd 100644 --- a/src/Applications/GEOSdas_App/testsuites/C180T14RPY.input +++ b/src/Applications/GEOSdas_App/testsuites/C180T14RPY.input @@ -10,7 +10,7 @@ tag: GEOSadas-5_29_3 Remote account for Intranet plots? [rtodling@train] > -Is this a MERRA2 experiment (y/n)? [n] +Is this a MERRA2 (1), GEOSIT (2), R21C (3) experiment? [0] > AGCM Horizontal Resolution? [C48] diff --git a/src/Applications/GEOSdas_App/testsuites/C360L181_replay.input b/src/Applications/GEOSdas_App/testsuites/C360L181_replay.input index ffaa41f9..7544d0df 100644 --- a/src/Applications/GEOSdas_App/testsuites/C360L181_replay.input +++ b/src/Applications/GEOSdas_App/testsuites/C360L181_replay.input @@ -10,7 +10,7 @@ tag: GEOSadas-5_29_3 Remote account for Intranet plots? [dao_it@train] > -Is this a MERRA2 experiment (y/n)? [n] +Is this a MERRA2 (1), GEOSIT (2), R21C (3) experiment? [0] > AGCM Horizontal Resolution? [C48] diff --git a/src/Applications/GEOSdas_App/testsuites/C360L91_replay.input b/src/Applications/GEOSdas_App/testsuites/C360L91_replay.input index 545120d8..00f14ef4 100644 --- a/src/Applications/GEOSdas_App/testsuites/C360L91_replay.input +++ b/src/Applications/GEOSdas_App/testsuites/C360L91_replay.input @@ -10,7 +10,7 @@ tag: GEOSadas-5_29_3 Remote account for Intranet plots? [dao_it@train] > -Is this a MERRA2 experiment (y/n)? [n] +Is this a MERRA2 (1), GEOSIT (2), R21C (3) experiment? [0] > AGCM Horizontal Resolution? [C48] diff --git a/src/Applications/GEOSdas_App/testsuites/C48f.input b/src/Applications/GEOSdas_App/testsuites/C48f.input index 59c397ff..7babc6cd 100644 --- a/src/Applications/GEOSdas_App/testsuites/C48f.input +++ b/src/Applications/GEOSdas_App/testsuites/C48f.input @@ -11,7 +11,7 @@ fvsetupflags: -sensdeg 1 Remote account for Intranet plots? [jstassi@train] > -Is this a MERRA2 experiment (y/n)? [n] +Is this a MERRA2 (1), GEOSIT (2), R21C (3) experiment? [0] > AGCM Horizontal Resolution? [C48] diff --git a/src/Applications/GEOSdas_App/testsuites/C90C.input b/src/Applications/GEOSdas_App/testsuites/C90C.input index 99caccb4..4e67007e 100644 --- a/src/Applications/GEOSdas_App/testsuites/C90C.input +++ b/src/Applications/GEOSdas_App/testsuites/C90C.input @@ -10,7 +10,7 @@ tag: GEOSadas-5_29_3 Remote account for Intranet plots? [jstassi@train] > -Is this a MERRA2 experiment (y/n)? [n] +Is this a MERRA2 (1), GEOSIT (2), R21C (3) experiment? [0] > AGCM Horizontal Resolution? [C48] diff --git a/src/Applications/GEOSdas_App/testsuites/C90C_ens.input b/src/Applications/GEOSdas_App/testsuites/C90C_ens.input index feed5438..57cf8247 100644 --- a/src/Applications/GEOSdas_App/testsuites/C90C_ens.input +++ b/src/Applications/GEOSdas_App/testsuites/C90C_ens.input @@ -10,7 +10,7 @@ tag: GEOSadas-5_29_3 Remote account for Intranet plots? [jstassi@train] > -Is this a MERRA2 experiment (y/n)? [n] +Is this a MERRA2 (1), GEOSIT (2), R21C (3) experiment? [0] > AGCM Horizontal Resolution? [C48] diff --git a/src/Applications/GEOSdas_App/testsuites/C90C_replay.input b/src/Applications/GEOSdas_App/testsuites/C90C_replay.input index 936dcc84..7f24c573 100644 --- a/src/Applications/GEOSdas_App/testsuites/C90C_replay.input +++ b/src/Applications/GEOSdas_App/testsuites/C90C_replay.input @@ -10,7 +10,7 @@ tag: 86f27c6 Remote account for Intranet plots? [rtodling@train] > -Is this a MERRA2 experiment (y/n)? [n] +Is this a MERRA2 (1), GEOSIT (2), R21C (3) experiment? [0] > AGCM Horizontal Resolution? [C48] diff --git a/src/Applications/GEOSdas_App/testsuites/fpp.input b/src/Applications/GEOSdas_App/testsuites/fpp.input index 189640d9..5ffad57a 100644 --- a/src/Applications/GEOSdas_App/testsuites/fpp.input +++ b/src/Applications/GEOSdas_App/testsuites/fpp.input @@ -10,7 +10,7 @@ tag: GEOSadas-5_29_3 Remote account for Intranet plots? [dao_ops@train] > -Is this a MERRA2 experiment (y/n)? [n] +Is this a MERRA2 (1), GEOSIT (2), R21C (3) experiment? [0] > AGCM Horizontal Resolution? [C48] diff --git a/src/Applications/GEOSdas_App/testsuites/geos_it.input b/src/Applications/GEOSdas_App/testsuites/geos_it.input index ffc2c001..f3ae0d64 100644 --- a/src/Applications/GEOSdas_App/testsuites/geos_it.input +++ b/src/Applications/GEOSdas_App/testsuites/geos_it.input @@ -2,16 +2,16 @@ # geos_it.input #-------------- -description: geos_it__b95f691__agrid_C360__ogrid_C -tag: b95f691 +description: geos_it__GEOSadas-5_29_3__agrid_C360__ogrid_C +tag: GEOSadas-5_29_3 ---ENDHEADERS--- Remote account for Intranet plots? [dao_ops@train] > -Is this a MERRA2 experiment (y/n)? [n] -> +Is this a MERRA2 (1), GEOSIT (2), R21C (3) experiment? [0] +> 2 AGCM Horizontal Resolution? [C48] > C180 @@ -28,7 +28,7 @@ EXPID? [u000_C360] Check for previous use of expid (y/n)? [y] > n -EXPDSC? [geos_it__b95f691__agrid_C360__ogrid_C] +EXPDSC? [geos_it__GEOSadas-5_27_1_p4__agrid_C360__ogrid_C] > Land Boundary Conditions? [Icarus_Updated] @@ -44,7 +44,7 @@ The directory /discover/nobackup/projects/gmao/dadev/rtodling/geos_it does not e > Processing nodes (1:Westmere, 2:SandyBridge, 3:Ivy Bridge, 4:Haswell, 5:Skylake, 6:Cascase)? [4] -> +> 5 Which case of variational analysis? [1] > @@ -77,7 +77,7 @@ AeroCom? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/AeroCom] > FVICS? [/archive/u/jstassi/restarts/GEOSadas-5_24_0] -> /discover/nobackup/projects/gmao/dadev/rtodling/archive/Restarts/5_29/geosit_test/rs/Y2017/M12/geosit_test.rst.20171219_21z.tar +> /discover/nobackup/projects/gmao/dadev/rtodling/archive/Restarts/5_29/geosit_test/Y2020/M01/geosit_test.rst.20200125_21z.tar Run model-adjoint-related applications (0=no,1=yes)? [0] > @@ -134,7 +134,7 @@ Which main class of ObsSys (1: NRT; 2: MERRA; 3: MERRA-2)? [1] > OBSERVING SYSTEM CLASSES? -> ncep_ssmis_bufr,ncep_1bamua_bufr,ncep_prep_bufr,ncep_tcvitals,ncep_mhs_bufr,ncep_1bhrs4_bufr,ncep_goesfv_bufr,ncep_gpsro_bufr,ncep_mtiasi_bufr,ncep_atms_bufr,ncep_cris_bufr,ncep_crisfsr_bufr,ncep_satwnd_bufr,ncep_sevcsr_bufr,ncep_avcsam_bufr,ncep_avcspm_bufr,disc_airs_bufr,disc_amsua_bufr,ncep_acftpfl_bufr,aura_omieff_nc,npp_ompsnp_nc,npp_ompsnmeff_nc,ncep_osbuv_bufr +> ncep_ssmis_bufr,ncep_1bamua_bufr,ncep_prep_bufr,ncep_tcvitals,ncep_mhs_bufr,ncep_1bhrs4_bufr,ncep_goesfv_bufr,ncep_gpsro_bufr,ncep_mtiasi_bufr,ncep_atms_bufr,ncep_cris_bufr,ncep_crisfsr_bufr,ncep_satwnd_bufr,ncep_sevcsr_bufr,ncep_avcsam_bufr,ncep_avcspm_bufr,disc_airs_bufr,disc_amsua_bufr,ncep_acftpfl_bufr,aura_omieff_nc,npp_ompsnp_nc,npp_ompsnmeff_nc,gmao_gmi_bufr,gmao_amsr2_bufr CHECKING OBSYSTEM? [2] > 1 diff --git a/src/Applications/GEOSdas_App/testsuites/prePP.input b/src/Applications/GEOSdas_App/testsuites/prePP.input index efda015a..642b1679 100644 --- a/src/Applications/GEOSdas_App/testsuites/prePP.input +++ b/src/Applications/GEOSdas_App/testsuites/prePP.input @@ -10,7 +10,7 @@ tag: GEOSadas-5_29_3 Remote account for Intranet plots? [rtodling@train] > -Is this a MERRA2 experiment (y/n)? [n] +Is this a MERRA2 (1), GEOSIT (2), R21C (3) experiment? [0] > AGCM Horizontal Resolution? [C48] diff --git a/src/Applications/GEOSdas_App/testsuites/x0046a.input b/src/Applications/GEOSdas_App/testsuites/x0046a.input index ea64afdb..1a227b31 100644 --- a/src/Applications/GEOSdas_App/testsuites/x0046a.input +++ b/src/Applications/GEOSdas_App/testsuites/x0046a.input @@ -10,7 +10,7 @@ tag: GEOSadas-5_29_3 Remote account for Intranet plots? [dao_it@train] > -Is this a MERRA2 experiment (y/n)? [n] +Is this a MERRA2 (1), GEOSIT (2), R21C (3) experiment? [0] > AGCM Horizontal Resolution? [C48] diff --git a/src/Applications/GEOSdas_App/testsuites/x0046aRPY.input b/src/Applications/GEOSdas_App/testsuites/x0046aRPY.input index 2172e382..c5b9a4c2 100644 --- a/src/Applications/GEOSdas_App/testsuites/x0046aRPY.input +++ b/src/Applications/GEOSdas_App/testsuites/x0046aRPY.input @@ -10,7 +10,7 @@ tag: GEOSadas-5_29_3 Remote account for Intranet plots? [dao_it@train] > -Is this a MERRA2 experiment (y/n)? [n] +Is this a MERRA2 (1), GEOSIT (2), R21C (3) experiment? [0] > AGCM Horizontal Resolution? [C48] From 041ff80287be5bfb5085441942633a80e2c1b612 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Tue, 16 Nov 2021 10:19:14 -0500 Subject: [PATCH 115/205] agreement to leave these data out of GEOS-IT --- src/Applications/GEOSdas_App/testsuites/geos_it.input | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Applications/GEOSdas_App/testsuites/geos_it.input b/src/Applications/GEOSdas_App/testsuites/geos_it.input index f3ae0d64..98238143 100644 --- a/src/Applications/GEOSdas_App/testsuites/geos_it.input +++ b/src/Applications/GEOSdas_App/testsuites/geos_it.input @@ -134,7 +134,7 @@ Which main class of ObsSys (1: NRT; 2: MERRA; 3: MERRA-2)? [1] > OBSERVING SYSTEM CLASSES? -> ncep_ssmis_bufr,ncep_1bamua_bufr,ncep_prep_bufr,ncep_tcvitals,ncep_mhs_bufr,ncep_1bhrs4_bufr,ncep_goesfv_bufr,ncep_gpsro_bufr,ncep_mtiasi_bufr,ncep_atms_bufr,ncep_cris_bufr,ncep_crisfsr_bufr,ncep_satwnd_bufr,ncep_sevcsr_bufr,ncep_avcsam_bufr,ncep_avcspm_bufr,disc_airs_bufr,disc_amsua_bufr,ncep_acftpfl_bufr,aura_omieff_nc,npp_ompsnp_nc,npp_ompsnmeff_nc,gmao_gmi_bufr,gmao_amsr2_bufr +> ncep_ssmis_bufr,ncep_1bamua_bufr,ncep_prep_bufr,ncep_tcvitals,ncep_mhs_bufr,ncep_1bhrs4_bufr,ncep_goesfv_bufr,ncep_gpsro_bufr,ncep_mtiasi_bufr,ncep_atms_bufr,ncep_cris_bufr,ncep_crisfsr_bufr,ncep_satwnd_bufr,ncep_sevcsr_bufr,ncep_avcsam_bufr,ncep_avcspm_bufr,disc_airs_bufr,disc_amsua_bufr,ncep_acftpfl_bufr,aura_omieff_nc,npp_ompsnp_nc,npp_ompsnmeff_nc CHECKING OBSYSTEM? [2] > 1 From 0c68715ebb2459d833836bce7a92271ba776bbeb Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Tue, 16 Nov 2021 12:22:33 -0500 Subject: [PATCH 116/205] fix for CrIS-NPP on/off/on 2021; support for GEOS-IT(zero-diff) --- components.yaml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/components.yaml b/components.yaml index e4b0ca4a..7b2a6598 100644 --- a/components.yaml +++ b/components.yaml @@ -46,7 +46,7 @@ FMS: GEOSana_GridComp: local: ./src/Components/@GEOSana_GridComp remote: ../GEOSana_GridComp.git - tag: v1.5.0 + tag: v1.5.1 develop: develop GEOSgcm_GridComp: @@ -121,7 +121,7 @@ mom6: GEOSgcm_App: local: ./src/Applications/@GEOSgcm_App remote: ../GEOSgcm_App.git - tag: rt1_5_4_mom6 + tag: rt_v1_5_6_geosit_0 develop: develop UMD_Etc: From 820204851ae699fcd9eda3d9003635712769adfe Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz Date: Tue, 16 Nov 2021 15:04:30 -0500 Subject: [PATCH 117/205] Adding routine to check if SFCSHP in input prepbufr files already has VIRTMP correction applied, and if so, to skip applying it in the GMAOprev step. --- .../NCEP_Paqc/GMAOprev/CMakeLists.txt | 5 ++ .../NCEP_Paqc/GMAOprev/check_virtmp.f | 52 +++++++++++++++++++ src/Applications/NCEP_Paqc/oiqc/gmao_prepqc | 18 +++++++ 3 files changed, 75 insertions(+) create mode 100644 src/Applications/NCEP_Paqc/GMAOprev/check_virtmp.f diff --git a/src/Applications/NCEP_Paqc/GMAOprev/CMakeLists.txt b/src/Applications/NCEP_Paqc/GMAOprev/CMakeLists.txt index 6becdc41..783b39b4 100644 --- a/src/Applications/NCEP_Paqc/GMAOprev/CMakeLists.txt +++ b/src/Applications/NCEP_Paqc/GMAOprev/CMakeLists.txt @@ -3,6 +3,11 @@ ecbuild_add_executable ( SOURCES gblevents_gmao.f prevents.f LIBS NCEP_bufr_r8i4 NCEP_w3_r8i4 GMAO_hermes) +ecbuild_add_executable ( + TARGET check_virtmp.x + SOURCES check_virtmp.f + LIBS NCEP_bufr_r4i4) + string(REPLACE " " ";" tmp ${FREAL8}) foreach (flag ${tmp}) target_compile_options (gmao_prevents.x PRIVATE $<$:${flag}>) diff --git a/src/Applications/NCEP_Paqc/GMAOprev/check_virtmp.f b/src/Applications/NCEP_Paqc/GMAOprev/check_virtmp.f new file mode 100644 index 00000000..ca572013 --- /dev/null +++ b/src/Applications/NCEP_Paqc/GMAOprev/check_virtmp.f @@ -0,0 +1,52 @@ + implicit none + real*8 hdr(1), tpc(1,20) + real*8 bmiss, getbmiss + CHARACTER(len=180) filn + CHARACTER(len=8) SUBSET + integer iret, idate, ilev, j, tvflg, lubfi + real vtcd + + data lubfi /10/ + + call getarg(1,filn) + open(unit=lubfi,file=filn,form='unformatted') + + CALL OPENBF(LUBFI,'IN',LUBFI) + call ufbqcd(lubfi,'VIRTMP',vtcd) + tvflg = 1 + subset = '' + iret = 0 + do while (iret == 0 .and. subset /= 'SFCSHP') + CALL READMG(LUBFI,SUBSET,IDATE,IRET) + end do + + +C LOOP THROUGH THE INPUT MESSAGES - READ THE NEXT SUBSET +C ------------------------------------------------------ + + do while(iret .eq. 0) + CALL READSB(LUBFI,IRET) + IF(IRET .eq. 0) then + call ufbint(lubfi,hdr,1,1,ilev,'TYP') + call ufbevn(lubfi,tpc,1,1,20,ilev,'TPC') + do j = 1,20 + if(tpc(1,j) == vtcd) tvflg = 0 + if(tpc(1,j) >= bmiss) exit + end do + if (tvflg == 0) exit + else + subset = '' + iret = 0 + do while (iret == 0 .and. subset /= 'SFCSHP') + CALL READMG(LUBFI,SUBSET,IDATE,IRET) + end do + endif + end do + if (tvflg == 0) then + print *,'VIRTUAL' + else + print *,'DRY' + end if + + stop + end diff --git a/src/Applications/NCEP_Paqc/oiqc/gmao_prepqc b/src/Applications/NCEP_Paqc/oiqc/gmao_prepqc index 050e27b1..4447afc2 100755 --- a/src/Applications/NCEP_Paqc/oiqc/gmao_prepqc +++ b/src/Applications/NCEP_Paqc/oiqc/gmao_prepqc @@ -300,10 +300,28 @@ sub gmaoprevents { Assign("prepdv.$nymd.$hh", 51); Assign("prevents.out.$nymd.$hh", 52); + $VTEMP = `check_virtmp.x $pref` + + open(PRVPARM, '>prepobs_prevents.parm'); + + if ( $VTEMP eq "DRY") { # input has sensible temperature + print "$0: PREVENTS calculate VIRTMP\n"; + print PRVPARM " &PREVDATA DOVTMP= TRUE, DOFCST= TRUE DOBERR= TRUE / \n"; + } else { # already has virtual temperature + print "$0: PREVENTS without VIRTMP\n"; + print PRVPARM " &PREVDATA DOVTMP= FALSE ,DOFCST= TRUE DOBERR= TRUE / \n"; + } + + close(PRVPARM); + $FORT_CONVERT12 = "BIG_ENDIAN"; $FORT_CONVERT13 = "BIG_ENDIAN"; +# Run check for virtual temperature +# --------------------------------- + + # Run prevents # ------------- $cmd = "gmao_prevents.x $dynf < $rcdir/prepobs_prevents.merra.parm"; From 35793a8d3a6129daf3449c87a6b2ffe8a7eaa6af Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz Date: Tue, 16 Nov 2021 15:10:45 -0500 Subject: [PATCH 118/205] modify name of parameter file used in prevents step - now written dynamically. --- src/Applications/NCEP_Paqc/oiqc/gmao_prepqc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Applications/NCEP_Paqc/oiqc/gmao_prepqc b/src/Applications/NCEP_Paqc/oiqc/gmao_prepqc index 4447afc2..8819069a 100755 --- a/src/Applications/NCEP_Paqc/oiqc/gmao_prepqc +++ b/src/Applications/NCEP_Paqc/oiqc/gmao_prepqc @@ -324,7 +324,7 @@ sub gmaoprevents { # Run prevents # ------------- - $cmd = "gmao_prevents.x $dynf < $rcdir/prepobs_prevents.merra.parm"; + $cmd = "gmao_prevents.x $dynf < $rcdir/prepobs_prevents.parm"; print "$0: $cmd\n" unless ( $opt_q ); # $rc = System ( $cmd, "/dev/null" ) unless ( $opt_n ) ; $rc = system ( $cmd ) unless ( $opt_n ) ; From ba214534c7aad472523cd5b3757167ace9c4a51b Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz Date: Tue, 16 Nov 2021 16:42:23 -0500 Subject: [PATCH 119/205] Corrected typo, changed location of input parameter file Modified 'if' test to be more general --- src/Applications/NCEP_Paqc/oiqc/gmao_prepqc | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/Applications/NCEP_Paqc/oiqc/gmao_prepqc b/src/Applications/NCEP_Paqc/oiqc/gmao_prepqc index 8819069a..c432c382 100755 --- a/src/Applications/NCEP_Paqc/oiqc/gmao_prepqc +++ b/src/Applications/NCEP_Paqc/oiqc/gmao_prepqc @@ -300,11 +300,10 @@ sub gmaoprevents { Assign("prepdv.$nymd.$hh", 51); Assign("prevents.out.$nymd.$hh", 52); - $VTEMP = `check_virtmp.x $pref` - + $VTEMP = `check_virtmp.x $pref`; open(PRVPARM, '>prepobs_prevents.parm'); - if ( $VTEMP eq "DRY") { # input has sensible temperature + if ( $VTEMP =~ /DRY/) { # input has sensible temperature print "$0: PREVENTS calculate VIRTMP\n"; print PRVPARM " &PREVDATA DOVTMP= TRUE, DOFCST= TRUE DOBERR= TRUE / \n"; } else { # already has virtual temperature @@ -324,7 +323,7 @@ sub gmaoprevents { # Run prevents # ------------- - $cmd = "gmao_prevents.x $dynf < $rcdir/prepobs_prevents.parm"; + $cmd = "gmao_prevents.x $dynf < prepobs_prevents.parm"; print "$0: $cmd\n" unless ( $opt_q ); # $rc = System ( $cmd, "/dev/null" ) unless ( $opt_n ) ; $rc = system ( $cmd ) unless ( $opt_n ) ; From f9d3eb53285a43d2963d244f923f6c9ffe933aa1 Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz Date: Tue, 16 Nov 2021 17:01:36 -0500 Subject: [PATCH 120/205] Add comment on latest changes to prologue of run script --- src/Applications/NCEP_Paqc/oiqc/gmao_prepqc | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Applications/NCEP_Paqc/oiqc/gmao_prepqc b/src/Applications/NCEP_Paqc/oiqc/gmao_prepqc index c432c382..bcf2cce3 100755 --- a/src/Applications/NCEP_Paqc/oiqc/gmao_prepqc +++ b/src/Applications/NCEP_Paqc/oiqc/gmao_prepqc @@ -21,6 +21,9 @@ # 'gmao_prepqc' without fv2ss step. # 20Mar2009 Todling Remove DASPERL (per da Silva) # 17Nov2015 Meta Clean up some unused (old) fort.XX assignments +# 16Nov2021 Meta Add routine to check for previous virtual temperature +# calculation for SFCSHP in input prepbufr and skip +# recalculation of VIRTMP if found #------------------------------------------------------------------ # make env vars readily available From 24c83ca69c1a45e3ec4408e99f359ca41e697879 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Tue, 16 Nov 2021 18:25:11 -0500 Subject: [PATCH 121/205] add ability to interpolate horizontally --- .../NCEP_bkgecov/write_berror_global.f90 | 141 +++++++++++++++++- 1 file changed, 135 insertions(+), 6 deletions(-) diff --git a/src/Applications/NCEP_Etc/NCEP_bkgecov/write_berror_global.f90 b/src/Applications/NCEP_Etc/NCEP_bkgecov/write_berror_global.f90 index ff06fb5a..053e87b2 100644 --- a/src/Applications/NCEP_Etc/NCEP_bkgecov/write_berror_global.f90 +++ b/src/Applications/NCEP_Etc/NCEP_bkgecov/write_berror_global.f90 @@ -66,19 +66,29 @@ program write_berror_global call berror_read_(ivars) endif - if (mlat/=ivars%nlat.or.mlon/=ivars%nlon) then - print *, 'cannot interpolate yet ...' + if (mlat/=ivars%nlat.and.mlon/=ivars%nlon.and.msig/=ivars%nsig) then + print *, 'cannot interpolate all three dims at one, try horz than vert ...' call exit(1) endif + if (mlat/=ivars%nlat.or.mlon/=ivars%nlon) then + write(6,'(a)') ' Horizontally interpolating error covariance fields ...' + call nc_berror_vars_init(xvars,ilon,ilat,isig) + call nc_berror_vars_copy(ivars,xvars) + call nc_berror_vars_final(ivars) + call nc_berror_vars_init(ivars,mlon,mlat,isig) + call hinterp_berror_vars_(xvars,ivars) + write(6,'(a)') ' Finish horizontal interpolation.' + call nc_berror_vars_final(xvars) + endif if (msig/=ivars%nsig) then - write(6,'(a)') ' Interpolating error covariance fields ...' + write(6,'(a)') ' Vertically interpolating error covariance fields ...' call nc_berror_vars_init(xvars,ilon,ilat,isig) call nc_berror_vars_copy(ivars,xvars) call nc_berror_vars_final(ivars) call nc_berror_vars_init(ivars,ilon,ilat,msig) - call nc_berror_vars_copy(xvars,ivars) + call nc_berror_vars_copy(xvars,ivars) ! copy lat/lon fields call vinterp_berror_vars_(xvars,ivars) - write(6,'(a)') ' Finish interpolation.' + write(6,'(a)') ' Finish vertical interpolation.' call nc_berror_vars_final(xvars) endif call berror_write_(ivars,merra2current) @@ -602,10 +612,129 @@ subroutine vinterp_berror_vars_(ivars,ovars) call spline( plevi, plevo, ivars%cvln (j,:), ovars%cvln (j,:) ) enddo deallocate(aux) - + deallocate(plevi) + deallocate(plevo) end subroutine vinterp_berror_vars_ + subroutine hinterp_berror_vars_(ivars,ovars) + + use m_spline, only: spline + use m_set_eta, only: set_eta + use m_set_eta, only: get_ref_plevs + use m_const, only: pstd + implicit none + + type(nc_berror_vars) ivars + type(nc_berror_vars) ovars + + real(4),allocatable,dimension(:,:) :: aux + real(4),allocatable,dimension(:) :: lati,lato + real(4),allocatable,dimension(:) :: loni,lono + integer i,j,k,k2 + real dlon,dlat + + if( ivars%nsig/=ovars%nsig ) then + print *, 'hinterp_berror_vars_: error, nsig must equal' + call exit(1) + endif + +! Input levels +! ------------ + allocate(lati(ivars%nlat)) + allocate(loni(ivars%nlon)) + dlat = 180./(ivars%nlat-1) + do j=1,ivars%nlat + lati(j) = -90.0 + (j-1.0)*dlat + enddo + dlon = 360./ivars%nlon + do i=1,ivars%nlon + loni(i) = i*dlon ! GSI def + enddo + +! Output levels +! ------------- + allocate(lato(ovars%nlat)) + allocate(lono(ovars%nlon)) + dlat = 180./(ovars%nlat-1) + do j=1,ovars%nlat + lato(j) = -90.0 + (j-1.0)*dlat + enddo + dlon = 360./ovars%nlon + do i=1,ovars%nlon + lono(i) = i*dlon ! GSI def + enddo + + + do k=1,ivars%nsig ! very, very parallelizable + + do k2=1,ivars%nsig + call spline( lati, lato, ivars%tcon(:,k2,k), ovars%tcon(:,k2,k) ) + enddo + + call spline( lati, lato, ivars%vpcon (:,k), ovars%vpcon (:,k) ) + call spline( lati, lato, ivars%pscon (:,k), ovars%pscon (:,k) ) + call spline( lati, lato, ivars%sfvar (:,k), ovars%sfvar (:,k) ) + call spline( lati, lato, ivars%sfhln (:,k), ovars%sfhln (:,k) ) + call spline( lati, lato, ivars%sfvln (:,k), ovars%sfvln (:,k) ) + call spline( lati, lato, ivars%vpvar (:,k), ovars%vpvar (:,k) ) + call spline( lati, lato, ivars%vphln (:,k), ovars%vphln (:,k) ) + call spline( lati, lato, ivars%vpvln (:,k), ovars%vpvln (:,k) ) + call spline( lati, lato, ivars%tvar (:,k), ovars%tvar (:,k) ) + call spline( lati, lato, ivars%thln (:,k), ovars%thln (:,k) ) + call spline( lati, lato, ivars%tvln (:,k), ovars%tvln (:,k) ) + call spline( lati, lato, ivars%qvar (:,k), ovars%qvar (:,k) ) + call spline( lati, lato, ivars%nrhvar(:,k), ovars%nrhvar(:,k) ) + call spline( lati, lato, ivars%qhln (:,k), ovars%qhln (:,k) ) + call spline( lati, lato, ivars%qvln (:,k), ovars%qvln (:,k) ) + call spline( lati, lato, ivars%qivar (:,k), ovars%qivar (:,k) ) + call spline( lati, lato, ivars%qihln (:,k), ovars%qihln (:,k) ) + call spline( lati, lato, ivars%qivln (:,k), ovars%qivln (:,k) ) + call spline( lati, lato, ivars%qlvar (:,k), ovars%qlvar (:,k) ) + call spline( lati, lato, ivars%qlhln (:,k), ovars%qlhln (:,k) ) + call spline( lati, lato, ivars%qlvln (:,k), ovars%qlvln (:,k) ) + call spline( lati, lato, ivars%qrvar (:,k), ovars%qrvar (:,k) ) + call spline( lati, lato, ivars%qrhln (:,k), ovars%qrhln (:,k) ) + call spline( lati, lato, ivars%qrvln (:,k), ovars%qrvln (:,k) ) + call spline( lati, lato, ivars%qsvar (:,k), ovars%qsvar (:,k) ) + call spline( lati, lato, ivars%qshln (:,k), ovars%qshln (:,k) ) + call spline( lati, lato, ivars%qsvln (:,k), ovars%qsvln (:,k) ) + call spline( lati, lato, ivars%ozvar (:,k), ovars%ozvar (:,k) ) + call spline( lati, lato, ivars%ozhln (:,k), ovars%ozhln (:,k) ) + call spline( lati, lato, ivars%ozvln (:,k), ovars%ozvln (:,k) ) + call spline( lati, lato, ivars%cvar (:,k), ovars%cvar (:,k) ) + call spline( lati, lato, ivars%chln (:,k), ovars%chln (:,k) ) + call spline( lati, lato, ivars%cvln (:,k), ovars%cvln (:,k) ) + enddo + call spline( lati, lato, ivars%psvar, ovars%psvar ) + call spline( lati, lato, ivars%pshln, ovars%pshln ) + +! Now handle horizontal 2d fields + allocate(aux(ovars%nlat,ivars%nlon)) + + ! varsst ... + do i=1,ivars%nlon + call spline( lati, lato, ivars%varsst(:,i), aux(:,i) ) + enddo + do j=1,ovars%nlat + call spline( loni, lono, aux(j,:), ovars%varsst(j,:) ) + enddo + ! corlsst + do i=1,ivars%nlon + call spline( lati, lato, ivars%corlsst(:,i), aux(:,i) ) + enddo + do j=1,ovars%nlat + call spline( loni, lono, aux(j,:), ovars%corlsst(j,:) ) + enddo + + deallocate(aux) + + deallocate(lati,loni) + deallocate(lato,lono) + + + end subroutine hinterp_berror_vars_ + subroutine be_write_nc_(fname,ivars) use m_set_eta, only: set_eta From 4985b6b83c291b2dff87a55c82dff0af72dcdc04 Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz Date: Wed, 17 Nov 2021 10:42:27 -0500 Subject: [PATCH 122/205] replace some files that were modified in merge of 'develop' --- src/Applications/GEOSdas_App/fvsetup | 15 ++++++----- .../GEOSdas_App/testsuites/C90C_ens.input | 8 +++--- .../GEOSdas_App/testsuites/C90C_replay.input | 5 +++- .../NCEP_enkf/scripts/gmao/get_atmens_rst.pl | 26 ++++--------------- 4 files changed, 21 insertions(+), 33 deletions(-) diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index 240695ac..a4fc8258 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -2356,28 +2356,29 @@ EOF #======================================================================= sub ed_aens_das_replay_acq { my($mydir) = @_; - my($replay_arcdir, $replay_expid, $acq); + my($replay_arcdir, $aens_replay_expid, $acq); - $replay_arcdir = "/discover/nobackup/projects/gmao/dadev/rtodling/archive/x0044"; + $aens_replay_expid = "x0044"; + $replay_arcdir = query("Replay exp name?", $aens_replay_expid); + $replay_arcdir = "/discover/nobackup/projects/gmao/advda/rtodling/archive/x0044"; $replay_arcdir = query("Replay archive directory?", $replay_arcdir); - $replay_expid = basename(abs_path($replay_arcdir)); $acq = "$fvhome/$mydir/atmens_replay.acq"; - open(SCRIPT,">$acq") or die ">>> ERROR <<< cannot write $acq"; + open(SCRIPT,">$acq") or die ">>> ERROR <<< cannot write $acq"; print SCRIPT <<"EOF"; -$replay_arcdir/atmens/Y%y4/M%m2/$replay_expid.atmens_ebkg.%y4%m2%d2_%h2z.tar => $expid.atmens_ebkg.%y4%m2%d2_%h2z.tar +$replay_arcdir/atmens/Y%y4/M%m2/$aens_replay_expid.atmens_ebkg.%y4%m2%d2_%h2z.tar => $expid.atmens_ebkg.%y4%m2%d2_%h2z.tar EOF if ( $mydir eq "run") { $acq = "$fvhome/anasa/atmens_replay.acq"; open(SCRIPT,">$acq") or die ">>> ERROR <<< cannot write $acq"; print SCRIPT <<"EOF"; -$replay_arcdir/atmens/Y%y4/M%m2/$replay_expid.atmens_ebkg.%y4%m2%d2_%h2z.tar => $expid.atmens_ebkg.%y4%m2%d2_%h2z.tar +$replay_arcdir/atmens/Y%y4/M%m2/$aens_replay_expid.atmens_ebkg.%y4%m2%d2_%h2z.tar => $expid.atmens_ebkg.%y4%m2%d2_%h2z.tar EOF $acq = "$fvhome/asens/atmens_asens.acq"; open(SCRIPT,">$acq") or die ">>> ERROR <<< cannot write $acq"; print SCRIPT <<"EOF"; -$replay_arcdir/atmens/Y%y4/M%m2/$replay_expid.atmens_ebkg.%y4%m2%d2_%h2z.tar => $expid.atmens_ebkg.%y4%m2%d2_%h2z.tar +$replay_arcdir/atmens/Y%y4/M%m2/$aens_replay_expid.atmens_ebkg.%y4%m2%d2_%h2z.tar => $expid.atmens_ebkg.%y4%m2%d2_%h2z.tar EOF } diff --git a/src/Applications/GEOSdas_App/testsuites/C90C_ens.input b/src/Applications/GEOSdas_App/testsuites/C90C_ens.input index 7adc18c8..13fab6ab 100644 --- a/src/Applications/GEOSdas_App/testsuites/C90C_ens.input +++ b/src/Applications/GEOSdas_App/testsuites/C90C_ens.input @@ -74,7 +74,7 @@ AeroCom? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/AeroCom] > FVICS? [/archive/u/jstassi/restarts/GEOSadas-5_24_0] -> /archive/u/jstassi/restarts/GEOSadas-5_27_0/C90CS_x0044.rst.20201215_21z.tar +> /archive/u/jstassi/restarts/GEOSadas-5_25_0/C90CS_x0039_p6.rst.20190729_21z.tar Run model-adjoint-related applications (0=no,1=yes)? [0] > 1 @@ -95,7 +95,7 @@ Verifying experiment id: [C90C_ens] > Ending year-month-day? [20190731] -> 20201220 +> 20190801 Length of FORECAST run segments (in hours)? [123] > @@ -143,7 +143,7 @@ Which main class of ObsSys (1: NRT; 2: MERRA; 3: MERRA-2)? [1] > OBSERVING SYSTEM CLASSES? -> ncep_ssmis_bufr,ncep_1bamua_bufr,ncep_prep_bufr,ncep_tcvitals,ncep_mhs_bufr,ncep_1bhrs4_bufr,ncep_gpsro_bufr,ncep_mtiasi_bufr,ncep_atms_bufr,ncep_crisfsr_bufr,ncep_satwnd_bufr,ncep_sevcsr_bufr,ncep_avcsam_bufr,ncep_avcspm_bufr,ncep_aura_omi_bufr,disc_airs_bufr,disc_amsua_bufr,gmao_gmi_bufr,mls_nrt_nc,gmao_amsr2_bufr,npp_ompsnm_bufr,ncep_acftpfl_bufr +> ncep_prep_bufr,ncep_1bamua_bufr,disc_airs_bufr,disc_amsua_bufr,ncep_mhs_bufr,ncep_1bhrs4_bufr,ncep_goesfv_bufr,ncep_mtiasi_bufr,ncep_gpsro_bufr,ncep_aura_omi_bufr,ncep_satwnd_bufr,ncep_atms_bufr,ncep_sevcsr_bufr,ncep_ssmis_bufr,mls_nrt_nc,ncep_avcsam_bufr,ncep_avcspm_bufr,ncep_tcvitals,gmao_gmi_bufr,ncep_crisfsr_bufr,npp_ompsnm_bufr,ncep_acftpfl_bufr CHECKING OBSYSTEM? [2] > @@ -227,7 +227,7 @@ Ensemble Vertical Levels? [72] > Experiment archive directory for ensemble restarts or 'later': [/archive/u/jstassi/C90C_ens] -> /discover/nobackup/projects/gmao/dadev/rtodling/archive/x0044 +> /archive/u/dao_it/x0039_p6 Edit COLLECTIONS list in run/HISTORY.rc.tmpl (y/n)? [n] > diff --git a/src/Applications/GEOSdas_App/testsuites/C90C_replay.input b/src/Applications/GEOSdas_App/testsuites/C90C_replay.input index 051bceb7..2fe0444c 100644 --- a/src/Applications/GEOSdas_App/testsuites/C90C_replay.input +++ b/src/Applications/GEOSdas_App/testsuites/C90C_replay.input @@ -217,8 +217,11 @@ Select group: [g0613] Replayed Ensemble (from OPS)? [yes] > +Replay exp name? [x0044] +> + Replay archive directory? [/discover/nobackup/projects/gmao/advda/rtodling/archive/x0044] -> /discover/nobackup/projects/gmao/dadev/rtodling/archive/x0044 +> Edit COLLECTIONS list in run/HISTORY.rc.tmpl (y/n)? [n] > diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/get_atmens_rst.pl b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/get_atmens_rst.pl index 7967a844..81996f29 100755 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/get_atmens_rst.pl +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/get_atmens_rst.pl @@ -1,12 +1,10 @@ #!/usr/bin/env perl use strict; use warnings; -use Cwd qw(abs_path cwd); +use Cwd qw(cwd); use File::Basename qw(basename dirname); use File::Copy qw(cp mv); use File::Path qw(mkpath rmtree); -use Getopt::Long qw(GetOptions); - use FindBin qw($Bin); use lib "$Bin"; use Manipulate_time qw(tick); @@ -32,7 +30,7 @@ my ($atmens_stat_dir, $atmens_ebkg_dir, $atmens_erst_dir, $atmens_ecbkg_dir); my ($tarfile, $tarpath, $label, $pid); my ($ens, $mem, $mfile, $mfile_new); - my (@archList, @tarList); + my (@tarList); init(); chdir($atmens_dir); @@ -54,12 +52,12 @@ foreach $label ("stat", "ebkg", "ecbkg", "erst") { $tarfile = "$expid.atmens_$label.${yyyymmdd}_${hh}z.tar"; $tarpath = "$atmens_date_dir/$tarfile"; - push @archList, $tarpath if archFile($tarpath); push @tarList, $tarpath; } + defined($pid = fork) or die "Error while attempting to fork;"; unless ($pid) { - system "dmget @archList"; + system "dmget @tarList"; exit; } foreach $tarpath (@tarList) { system_("tar xvf $tarpath") } @@ -90,6 +88,7 @@ # purpose - get runtime parameters and flags #======================================================================= sub init { + use Getopt::Long qw(GetOptions); my ($fvhome, $help, $exparcdir); GetOptions("fvhome=s" => \$fvhome, @@ -103,7 +102,6 @@ sub init { ($exparcdir, $newid, $yyyymmdd, $hh) = @ARGV; $exparcdir =~ s/[\s\/]*$//; - $exparcdir = abs_path($exparcdir); $arcdir = dirname($exparcdir); $expid = basename($exparcdir); @@ -125,20 +123,6 @@ sub init { } -#======================================================================= -# name - archFile -# purpose - Return true (1) if $file is an archive file; -# Return false (0) if not -#======================================================================= -sub archFile { - my ($file, $dmLine, $dmFLG); - $file = shift @_; - $dmLine = `dmls -l $file`; - $dmFLG = 1; - $dmFLG = 0 if $dmLine =~ m|(N/A)|; - return $dmFLG; -} - #======================================================================= # name - rename_new #======================================================================= From 95eb9c8279cd98f804519a0068cb1d126d538c5d Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Wed, 17 Nov 2021 16:32:33 -0500 Subject: [PATCH 123/205] fix for error in passing compiler directives in CMakefile.txt; other inconsequential --- .../NCEP_Etc/NCEP_bkgecov/CMakeLists.txt | 2 +- .../NCEP_bkgecov/berror_stats.nml.tmpl | 2 +- .../NCEP_Etc/NCEP_bkgecov/ut_gen_berrcov.j | 65 +++++++++++-------- 3 files changed, 40 insertions(+), 29 deletions(-) diff --git a/src/Applications/NCEP_Etc/NCEP_bkgecov/CMakeLists.txt b/src/Applications/NCEP_Etc/NCEP_bkgecov/CMakeLists.txt index d0dd33dd..22406486 100644 --- a/src/Applications/NCEP_Etc/NCEP_bkgecov/CMakeLists.txt +++ b/src/Applications/NCEP_Etc/NCEP_bkgecov/CMakeLists.txt @@ -25,7 +25,7 @@ esma_add_library (${this} DEPENDENCIES NCEP_bacio_r4i4 NCEP_w3_r4i4 NCEP_sp_r4i4 GMAO_gfio_r8 GMAO_hermes GMAO_transf ${MKL_LIBRARIES} ) -target_compile_definitions(${this} PRIVATE _LAPACK_ gmao_intf) +add_definitions (-D_LAPACK_ -Dgmao_intf) ecbuild_add_executable(TARGET calcstats.x SOURCES statsmain.F90 LIBS ${this} ${MKL_LIBRARIES}) ecbuild_add_executable(TARGET write_berror_global.x SOURCES write_berror_global.f90 LIBS ${this} ${MKL_LIBRARIES}) diff --git a/src/Applications/NCEP_Etc/NCEP_bkgecov/berror_stats.nml.tmpl b/src/Applications/NCEP_Etc/NCEP_bkgecov/berror_stats.nml.tmpl index 2a8c03b1..10b6bbde 100644 --- a/src/Applications/NCEP_Etc/NCEP_bkgecov/berror_stats.nml.tmpl +++ b/src/Applications/NCEP_Etc/NCEP_bkgecov/berror_stats.nml.tmpl @@ -9,7 +9,7 @@ ! note: biasrm=.false. means do bias correction - go figure! fnm0=>>>NMODES<<<,vectype=5,biasrm=.false.,laddoz=.false., LBAL=.true., - nreaders=8, + nreaders=16, readperts=.true., ! Debug only: ! calchrzscl=.false., diff --git a/src/Applications/NCEP_Etc/NCEP_bkgecov/ut_gen_berrcov.j b/src/Applications/NCEP_Etc/NCEP_bkgecov/ut_gen_berrcov.j index 1d46d4dc..e0ea7cc4 100755 --- a/src/Applications/NCEP_Etc/NCEP_bkgecov/ut_gen_berrcov.j +++ b/src/Applications/NCEP_Etc/NCEP_bkgecov/ut_gen_berrcov.j @@ -1,10 +1,10 @@ #!/bin/csh -x #SBATCH --account=g0613 -#SBATCH --constraint=hasw -#SBATCH --ntasks=1 +#SBATCH --constraint=sky +#_SBATCH --ntasks=8 #_SBATCH --ntasks=24 #_SBATCH --ntasks=96 -#_SBATCH --ntasks=384 +#SBATCH --ntasks=672 #_SBATCH --ntasks-per-node=24 #SBATCH --time=12:00:00 #SBATCH --qos=dastest @@ -22,7 +22,7 @@ setenv DRYRUN #echo setenv SKIPSETTING 0 - setenv MYNCPUS 4 + setenv MYNCPUS 8 # Set initial time and number of samples required setenv EXPID x0039_p5_REPLAY_L132 setenv EXPID x41Lrt @@ -32,33 +32,38 @@ setenv EXPID f525_p7_fp setenv EXPID f522_fp setenv EXPID f525_fp + setenv EXPID f5271_fp #setenv FVHOME /home/dao_ops/$EXPID #setenv ARCROOT /home/dao_ops/$EXPID/run/.../archive/prog #setenv FVHOME /discover/nobackup/projects/gmao/obsdev/rtodling/$EXPID #setenv FVHOME /discover/nobackup/projects/gmao/obsdev/rtodling/x0041 -setenv FVHOME /discover/nobackup/projects/gmao/dadev/rtodling/x0043rt +setenv FVHOME /discover/nobackup/projects/gmao/dadev/rtodling/prePP setenv FVROOT `cat $FVHOME/.FVROOT` setenv PLAINDIR 0 setenv ARCROOT /archive/u/$user/$EXPID/prog if ( $EXPID == "x0041" ) then setenv ARCROOT /archive/u/dao_it/$EXPID/prog endif -if ( $EXPID == "f521_fp" || $EXPID == "f522_fp" || $EXPID == "f525_fp" || $EXPID == "f525_p5_fp" || $EXPID == "f525_p7_fp" ) then +if ( $EXPID == "f521_fp" || $EXPID == "f522_fp" || $EXPID == "f525_fp" || $EXPID == "f525_p5_fp" || $EXPID == "f525_p7_fp" || $EXPID == "f5271_fp" ) then setenv ARCROOT /home/dao_ops/$EXPID/run/.../archive/prog endif if ($EXPID == "x0039_p5_REPLAY_L132") then setenv ARCROOT /gpfsm/dnb78s1/projects/p18/ltakacs/REPLAY_Experiments/x0039_p5_REPLAY_L132/forecasts/Regular_RPLFRQ:7200_ANA:x0039_p5 setenv PLAINDIR 1 endif -setenv DMGET 0 -setenv GET_SET 1 +setenv DMGET 0 +setenv GET_SET 0 -setenv DO_ACQUIRE 1 -setenv GEN_NMCDIFFS 1 +setenv DO_ACQUIRE 0 +setenv GEN_NMCDIFFS 0 -setenv GET_BERROR 0 +setenv GET_BERROR 1 setenv BERROR_NMODES 25 +set JCAP = 512 +set NLON = 576 +set NLAT = 361 + # Basic settings (weak dependency on version of DAS) # -------------------------------------------------- set path = ( . $FVROOT/bin $path ) @@ -72,9 +77,9 @@ setenv FCSTWORK /discover/nobackup/projects/gmao/obsdev/$user/fcst4berrcov.$EXPI setenv FCSTWORK /discover/nobackup/projects/gmao/dadev/$user/fcst4berrcov.$EXPID if ($?I_MPI_ROOT ) then - setenv MPIRUN_CALCSTATS "mpirun -np 32 calcstats.x" + setenv MPIRUN_CALCSTATS "mpirun -np 96 calcstats.x" else - setenv MPIRUN_CALCSTATS "mpirun_exec -np 32 calcstats.x" + setenv MPIRUN_CALCSTATS "mpirun_exec -np 96 calcstats.x" endif # # initial verification date and number of samples (will get samples ahead of initial date) @@ -85,6 +90,8 @@ set vnymd0 = 20181101 set vnymd0 = 20200203 set vnymd0 = 20200401 set vnymd0 = 20200301 +set vnymd0 = 20210203 # start +set vnymd0 = 20210305 #if ( $EXPID == "f522_fp") then # set vnymd0 = 20190304 # @ nsamples = 350 @@ -94,8 +101,8 @@ set vnymd0 = 20200301 #endif set vnhms0 = 000000 @ nsamples = 31 -setenv FCSTWRK $FCSTWORK.$vnymd0.$vnhms0 -mkdir -p $FCSTWRK/BERROR.WORK +#setenv FCSTWRK $FCSTWORK.$vnymd0.$vnhms0 +setenv FCSTWRK $FCSTWORK.all set diren = `dirname $FCSTWRK` set spool = "-s $diren/spool " @@ -106,8 +113,8 @@ if ( $GET_SET ) then set foffset_hr = 3 # offset in initial time from synoptic hour set nmc_hrv = 24 # begin time of NMC method / verification time set nmc_hrf = 48 # end time of NMC method / fcst time - set vmn = 00 # either black or 00 set vmn = # either black or 00 + set vmn = 00 # either black or 00 # ---------------------------------- # No user change from this part down @@ -181,8 +188,13 @@ if ( $GET_SET ) then set inidate = ( `tick $inidate $gap_sc` ) end + set lst = `cat $acqfile` + if (-e missing.txt ) /bin/rm missing.txt + touch missing.txt + foreach fn ($lst) + if (! -e $fn ) echo $fn >> missing.txt + end if ( $DMGET ) then - set lst = `cat $acqfile` echo $lst dmget $lst exit @@ -295,32 +307,31 @@ endif # GEN_NMCDIFFS if ( $GET_BERROR ) then if ( ! -d $FCSTWRK/BERROR.WORK ) mkdir -p $FCSTWRK/BERROR.WORK -cd $FCSTWRK/BERROR.WORK # Get positioned and set namelist parameters # ------------------------------------------ cd $FCSTWRK/BERROR.WORK/ + mkdir samples + cd samples + ln -sf $FCSTWRK/NMC48m24/*f48m24*nc4 . + cd - + # Get set to run berror stats code # -------------------------------- if (-e infiles ) /bin/rm infiles - cat $FCSTWRK/shrt_fcst.txt >> infiles - cat $FCSTWRK/long_fcst.txt >> infiles +# cat $FCSTWRK/shrt_fcst.txt >> infiles +# cat $FCSTWRK/long_fcst.txt >> infiles + ls samples/*f48m24*nc4 > infiles ln -sf infiles fort.10 - # just for the record ... - ls -lrt samples - # Figure out dimensions of forecast files (assumes that checking one suffices) # ---------------------------------------------------------------------------- - set fcst_files = (`cat samples`) + set fcst_files = (`cat infiles`) set fcst_res = (`getgfiodim.x $fcst_files[1]`) # wire for now - set JCAP = 512 set NSIG = $fcst_res[3] - set NLON = 576 - set NLAT = 361 # Prepare resource files set this_param = $FVROOT/etc/berror_stats.nml.tmpl From 232a390765c3d62366e3179b04d1f147110bd152 Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz Date: Fri, 19 Nov 2021 19:45:09 -0500 Subject: [PATCH 124/205] Add a 'usage' statment to be printed out if the file name on the command line is missing. --- src/Applications/NCEP_Paqc/GMAOprev/check_virtmp.f | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Applications/NCEP_Paqc/GMAOprev/check_virtmp.f b/src/Applications/NCEP_Paqc/GMAOprev/check_virtmp.f index ca572013..af8146f9 100644 --- a/src/Applications/NCEP_Paqc/GMAOprev/check_virtmp.f +++ b/src/Applications/NCEP_Paqc/GMAOprev/check_virtmp.f @@ -4,10 +4,16 @@ CHARACTER(len=180) filn CHARACTER(len=8) SUBSET integer iret, idate, ilev, j, tvflg, lubfi + integer nargs, iargc real vtcd data lubfi /10/ + nargs = iargc() + if (nargs .lt. 1) then + print *, 'Usage: check_virtmp.x prepbufr-file' + stop + end if call getarg(1,filn) open(unit=lubfi,file=filn,form='unformatted') From bc56c13058b2589e079429530061d2a60ea2798d Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Wed, 24 Nov 2021 12:24:36 -0500 Subject: [PATCH 125/205] fix for missing lon flip before calc of sf/vp; alllow for bypass of calc sf/vp and those are in file --- .../NCEP_bkgecov/berror_stats.nml.tmpl | 3 + .../NCEP_Etc/NCEP_bkgecov/m_GsiGrided.f90 | 39 ++++++++--- .../NCEP_Etc/NCEP_bkgecov/statsmain.F90 | 6 +- .../NCEP_Etc/NCEP_bkgecov/ut_gen_berrcov.j | 65 ++++++++++++++----- 4 files changed, 88 insertions(+), 25 deletions(-) diff --git a/src/Applications/NCEP_Etc/NCEP_bkgecov/berror_stats.nml.tmpl b/src/Applications/NCEP_Etc/NCEP_bkgecov/berror_stats.nml.tmpl index 10b6bbde..79d8e15c 100644 --- a/src/Applications/NCEP_Etc/NCEP_bkgecov/berror_stats.nml.tmpl +++ b/src/Applications/NCEP_Etc/NCEP_bkgecov/berror_stats.nml.tmpl @@ -5,6 +5,7 @@ ! jcap=382,lgaus=.false.,lsmver=.true.,nsig=72,nlat=361,nlon=576, ! jcap=512,lgaus=.false.,lsmver=.true.,nsig=72,nlat=721,nlon=1152,hrzsfactor=0.6, jcap=>>>JCAP<<<,lgaus=.false.,lsmver=.true.,nsig=>>>NSIG<<<,nlat=>>>NLAT<<<,nlon=>>>NLON<<<, + hrzsfactor=>>>HFAC<<<, maxcases=500,hybrid=.true.,smoothdeg=0.5, ! note: biasrm=.false. means do bias correction - go figure! fnm0=>>>NMODES<<<,vectype=5,biasrm=.false.,laddoz=.false., @@ -13,7 +14,9 @@ readperts=.true., ! Debug only: ! calchrzscl=.false., +! input_vpsf=.true., / &SMOOTHVARS +! this namelist is incorrectly implemented in the code - do not use / diff --git a/src/Applications/NCEP_Etc/NCEP_bkgecov/m_GsiGrided.f90 b/src/Applications/NCEP_Etc/NCEP_bkgecov/m_GsiGrided.f90 index 04b7fa39..7ee64707 100644 --- a/src/Applications/NCEP_Etc/NCEP_bkgecov/m_GsiGrided.f90 +++ b/src/Applications/NCEP_Etc/NCEP_bkgecov/m_GsiGrided.f90 @@ -7,10 +7,12 @@ module m_GsiGrided private ! except public :: GsiGrided + public :: GsiGrided_set public :: GsiGrided_init public :: GsiGrided_read public :: GsiGrided_clean public :: vectype + public :: input_vpsf type GsiGrided ! private @@ -32,6 +34,8 @@ module m_GsiGrided interface GsiGrided_init ; module procedure & init_ ; end interface + interface GsiGrided_set ; module procedure & + set_ ; end interface interface GsiGrided_read ; module procedure & read_ ; end interface interface GsiGrided_clean; module procedure & @@ -43,7 +47,9 @@ module m_GsiGrided real(fp_kind),parameter :: CPD = 1004.64 real(fp_kind),parameter :: RGAS = 287.04 real(fp_kind),parameter :: KAPPA = RGAS/CPD + integer :: vectype + logical :: input_vpsf contains @@ -87,10 +93,16 @@ subroutine init_(ob) ob%rh = 0 ob%mrh = 0 - vectype = 5 - end subroutine init_ + subroutine set_ + implicit none + + vectype = 5 + input_vpsf = .false. + + end subroutine set_ + subroutine read_(fid, nymd, nhms, ob, mype) use variables, only : nlat, nlon, nsig, filename @@ -101,6 +113,7 @@ subroutine read_(fid, nymd, nhms, ob, mype) use m_dyn,only : dyn_vect use m_dyn,only : dyn_get use m_dyn,only : dyn_clean + use m_dyn,only : dyn_flip use m_llInterp, only : llInterp use m_llInterp, only : llInterp_init @@ -133,6 +146,7 @@ subroutine read_(fid, nymd, nhms, ob, mype) type(llInterp) :: obll,obl character(len=3),pointer::xtrnames(:) logical dointerp + logical dovecwnds if (readperts) then @@ -145,6 +159,9 @@ subroutine read_(fid, nymd, nhms, ob, mype) call dyn_get(filename(fid),nymd,nhms,w_fv, & ier,timidx=1,vectype=vectype) endif + call dyn_flip(w_fv,dover=.false.) ! This is required since the calc + ! of div/vor; sf/vp before assume + ! the lon [0,360]; see inisph (RT) ! Atmospheric model dimensions nAlon = w_fv%grid%im @@ -227,29 +244,35 @@ subroutine read_(fid, nymd, nhms, ob, mype) w_fv%v = var3dv deallocate ( var3du, var3dv ) endif + dovecwnds=.not.input_vpsf if(dointerp)then allocate( var3su(nlat,nlon,nsig) ) allocate( var3sv(nlat,nlon,nsig) ) allocate( var3du(nlon,nlat,nsig) ) - call llInterp_atog(obll,w_fv%u, var3du, vector=.true.) + call llInterp_atog(obll,w_fv%u, var3du, vector=dovecwnds) call swapij3d_(var3du,var3su,nlat,nlon,nsig) - call llInterp_atog(obll,w_fv%v, var3du, vector=.true.) + call llInterp_atog(obll,w_fv%v, var3du, vector=dovecwnds) call swapij3d_(var3du,var3sv,nlat,nlon,nsig) else call llInterp_init(obl,nAlon,nAlat,nGlon,nGlat) allocate( var3su(nGlat,nGlon,nsig) ) allocate( var3sv(nGlat,nGlon,nsig) ) allocate( var3du(nGlon,nGlat,nsig) ) - call llInterp_atog(obl,w_fv%u, var3du, vector=.true.) + call llInterp_atog(obl,w_fv%u, var3du, vector=dovecwnds) call swapij3d_(var3du,var3su,nGlat,nGlon,nsig) - call llInterp_atog(obl,w_fv%v, var3du, vector=.true.) + call llInterp_atog(obl,w_fv%v, var3du, vector=dovecwnds) call swapij3d_(var3du,var3sv,nGlat,nGlon,nsig) call llInterp_clean(obl) endif deallocate( var3du ) - call m_vordiv(var3su,var3sv) - call m_stvp(ob%sf,ob%vp,var3su,var3sv) + if (input_vpsf) then + ob%vp=var3su + ob%sf=var3sv + else + call m_vordiv(var3su,var3sv) + call m_stvp(ob%sf,ob%vp,var3su,var3sv) + endif deallocate( var3su ) deallocate( var3sv ) diff --git a/src/Applications/NCEP_Etc/NCEP_bkgecov/statsmain.F90 b/src/Applications/NCEP_Etc/NCEP_bkgecov/statsmain.F90 index 4b7b5bff..a33dee90 100644 --- a/src/Applications/NCEP_Etc/NCEP_bkgecov/statsmain.F90 +++ b/src/Applications/NCEP_Etc/NCEP_bkgecov/statsmain.F90 @@ -76,6 +76,8 @@ program statsmain use specgrid, only: init_spec use postmod, only: writefiles use m_GsiGrided, only: vectype + use m_GsiGrided, only: input_vpsf + use m_GsiGrided, only: GsiGrided_set use comm_mod, only: nxpe,nype,init_mpi_vars,destroy_mpi_vars use m_zeit, only: zeit_ci,zeit_co,zeit_flush ! use MAPL_Mod @@ -110,11 +112,12 @@ program statsmain ! rhbounds(2)-specify lower and uppper bounds on rh diff ! nxpe,nype -allow testings w/ ESMF-like distribution ! hrzsfactor -parameter allowing for extra adjustment to horizontal scales +! input_vpsf -.true. when input has vp/sf in u/v slots namelist/namstat/jcap,lgaus,lsmver,nsig,nlat,nlon,& maxcases,hybrid,smoothdeg,fnm0,vectype,biasrm,laddoz,lbal,& hydromet,smooth_vert_variances,nreaders,readperts,calchrzscl,& - calcvrtscl,rhbounds,nxpe,nype,hrzsfactor + calcvrtscl,rhbounds,nxpe,nype,hrzsfactor,input_vpsf namelist/smoothvars/hcoeffs,vcoeffs ! MPI initial setup @@ -125,6 +128,7 @@ program statsmain ! Initialize defaults for namelist variables call init_vars call init_spec + call GsiGrided_set ! Read in namelist #ifdef ibm_sp diff --git a/src/Applications/NCEP_Etc/NCEP_bkgecov/ut_gen_berrcov.j b/src/Applications/NCEP_Etc/NCEP_bkgecov/ut_gen_berrcov.j index e0ea7cc4..91c6a81a 100755 --- a/src/Applications/NCEP_Etc/NCEP_bkgecov/ut_gen_berrcov.j +++ b/src/Applications/NCEP_Etc/NCEP_bkgecov/ut_gen_berrcov.j @@ -2,9 +2,9 @@ #SBATCH --account=g0613 #SBATCH --constraint=sky #_SBATCH --ntasks=8 -#_SBATCH --ntasks=24 +#_SBATCH --ntasks=36 #_SBATCH --ntasks=96 -#SBATCH --ntasks=672 +#SBATCH --ntasks=1000 #_SBATCH --ntasks-per-node=24 #SBATCH --time=12:00:00 #SBATCH --qos=dastest @@ -29,9 +29,9 @@ setenv EXPID x0041 setenv EXPID f521_fp setenv EXPID f525_p5_fp - setenv EXPID f525_p7_fp setenv EXPID f522_fp setenv EXPID f525_fp + setenv EXPID f525_p7_fp setenv EXPID f5271_fp #setenv FVHOME /home/dao_ops/$EXPID #setenv ARCROOT /home/dao_ops/$EXPID/run/.../archive/prog @@ -57,12 +57,11 @@ setenv GET_SET 0 setenv DO_ACQUIRE 0 setenv GEN_NMCDIFFS 0 -setenv GET_BERROR 1 +setenv GET_BERROR 1 setenv BERROR_NMODES 25 -set JCAP = 512 -set NLON = 576 -set NLAT = 361 +#set these_lats = ( 25 46 91 ) +set these_lats = ( 721 ) # Basic settings (weak dependency on version of DAS) # -------------------------------------------------- @@ -77,7 +76,8 @@ setenv FCSTWORK /discover/nobackup/projects/gmao/obsdev/$user/fcst4berrcov.$EXPI setenv FCSTWORK /discover/nobackup/projects/gmao/dadev/$user/fcst4berrcov.$EXPID if ($?I_MPI_ROOT ) then - setenv MPIRUN_CALCSTATS "mpirun -np 96 calcstats.x" + setenv MPIRUN_CALCSTATS "mpirun -np 864 calcstats.x" +# setenv MPIRUN_CALCSTATS "mpirun -np 64 calcstats.x" else setenv MPIRUN_CALCSTATS "mpirun_exec -np 96 calcstats.x" endif @@ -91,7 +91,7 @@ set vnymd0 = 20200203 set vnymd0 = 20200401 set vnymd0 = 20200301 set vnymd0 = 20210203 # start -set vnymd0 = 20210305 +set vnymd0 = 20200804 #if ( $EXPID == "f522_fp") then # set vnymd0 = 20190304 # @ nsamples = 350 @@ -100,9 +100,10 @@ set vnymd0 = 20210305 # #endif set vnhms0 = 000000 -@ nsamples = 31 +@ nsamples = 58 #setenv FCSTWRK $FCSTWORK.$vnymd0.$vnhms0 setenv FCSTWRK $FCSTWORK.all +mkdir $FCSTWRK set diren = `dirname $FCSTWRK` set spool = "-s $diren/spool " @@ -113,8 +114,8 @@ if ( $GET_SET ) then set foffset_hr = 3 # offset in initial time from synoptic hour set nmc_hrv = 24 # begin time of NMC method / verification time set nmc_hrf = 48 # end time of NMC method / fcst time - set vmn = # either black or 00 set vmn = 00 # either black or 00 + set vmn = # either black or 00 # ---------------------------------- # No user change from this part down @@ -305,8 +306,36 @@ if ( $GEN_NMCDIFFS ) then endif # GEN_NMCDIFFS if ( $GET_BERROR ) then - -if ( ! -d $FCSTWRK/BERROR.WORK ) mkdir -p $FCSTWRK/BERROR.WORK + foreach NLAT ( $these_lats ) + + setenv HFAC -1.0 + if ( $NLAT == 25 ) then + setenv JCAP 12 + setenv NLON 48 + endif + if ( $NLAT == 46 ) then + setenv JCAP 42 + setenv NLON 72 + endif + if ( $NLAT == 91 ) then + setenv JCAP 84 + setenv NLON 144 + endif + if ( $NLAT == 181 ) then + setenv JCAP 142 + setenv NLON 288 + endif + if ( $NLAT == 361 ) then + setenv JCAP 382 + setenv NLON 576 + endif + if ( $NLAT == 721 ) then + setenv JCAP 512 + setenv NLON 1152 + setenv HFAC 0.6 + endif + + if ( ! -d $FCSTWRK/BERROR.WORK ) mkdir -p $FCSTWRK/BERROR.WORK # Get positioned and set namelist parameters # ------------------------------------------ @@ -339,6 +368,7 @@ if ( ! -d $FCSTWRK/BERROR.WORK ) mkdir -p $FCSTWRK/BERROR.WORK if ( -e stats.param ) /bin/rm stats.parm if ( -e sed_file ) /bin/rm sed_file echo "s/>>>JCAP<< sed_file + echo "s/>>>HFAC<<> sed_file echo "s/>>>NSIG<<> sed_file echo "s/>>>NLAT<<> sed_file echo "s/>>>NLON<<> sed_file @@ -368,9 +398,9 @@ if ( ! -d $FCSTWRK/BERROR.WORK ) mkdir -p $FCSTWRK/BERROR.WORK /bin/mv $fn.grd $EXPID.gsi.$fn.clim.grd endif end - if ( -e $FCSTWRK/$EXPID.gsi.berror_stats.clim.tar ) /bin/rm $FCSTWRK/$EXPID.gsi.berror_stats.clim.tar - tar cvf $FCSTWRK/$EXPID.gsi.berror_stats.clim.tar $EXPID.gsi.berror_stats.clim.bin \ - $EXPID.gsi.*clim.grd + if ( -e $FCSTWRK/$EXPID.gsi.berror_stats.clim.y$NLAT.tar ) /bin/rm $FCSTWRK/$EXPID.gsi.berror_stats.clim.y$NLAT.tar + tar cvf $FCSTWRK/$EXPID.gsi.berror_stats.clim.y$NLAT.tar $EXPID.gsi.berror_stats.clim.bin \ + $EXPID.gsi.*clim.grd echo " ${MYNAME}: done creating B-error file" @@ -382,5 +412,8 @@ if ( ! -d $FCSTWRK/BERROR.WORK ) mkdir -p $FCSTWRK/BERROR.WORK /bin/rm -r fort.*00* /bin/rm -r fort.*01* /bin/rm -r fort.*02* + /bin/rm stats.parm + /bin/rm $EXPID.gsi.berror_stats.clim.bin $EXPID.gsi.*clim.grd + end # these_lats endif # GET_BERROR From f6f7f37c17a993fe3b581f166548cc9d8c5eb252 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Wed, 24 Nov 2021 12:25:49 -0500 Subject: [PATCH 126/205] needed in revised driving berror script --- .../NCEP_Etc/NCEP_enkf/scripts/gmao/atmens_berror.csh | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmens_berror.csh b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmens_berror.csh index e243aa2e..51fadf77 100755 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmens_berror.csh +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmens_berror.csh @@ -151,6 +151,7 @@ if ( $FROMENS ) then setenv NSIG $ens_nlevs setenv NLAT $ens_nlats setenv NLON $ens_nlons + setenv HFAC -1.0 # if desired resolution differs form ensemble resolution ... if ( -e $idir/atmens_berror.rc ) then @@ -304,6 +305,7 @@ if ( -e $this_param ) then if ( -e stats.param ) /bin/rm stats.parm if ( -e sed_file ) /bin/rm sed_file echo "s/>>>JCAP<< sed_file + echo "s/>>>HFAC<<> sed_file echo "s/>>>NSIG<<> sed_file echo "s/>>>NLAT<<> sed_file echo "s/>>>NLON<<> sed_file From 427efa5917abe946cd8a208acb520c3cf00ca18f Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz Date: Mon, 29 Nov 2021 16:41:53 -0500 Subject: [PATCH 127/205] Adding 'cleanup_tails=.true.' to aircraft bias correction substitution string for VarBC type aircraft temperature bias correction. The GSI will delete coefficients for tails that have not been updated for more than one year. --- src/Applications/GEOSdas_App/GEOSdas.csm | 4 ++-- src/Applications/GSI_App/fvssi | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Applications/GEOSdas_App/GEOSdas.csm b/src/Applications/GEOSdas_App/GEOSdas.csm index a908d734..21a32d27 100755 --- a/src/Applications/GEOSdas_App/GEOSdas.csm +++ b/src/Applications/GEOSdas_App/GEOSdas.csm @@ -913,11 +913,11 @@ exit 1 echo 'Setting aircraft_t_bc_ext to true, using external bias correction' breaksw case 2: - echo "s/>>>AIRCFT_BIAS<<> sed_file + echo "s/>>>AIRCFT_BIAS<<> sed_file echo 'Setting aircraft_t_bc to true, using VV.VV^2 bias correction' breaksw case 3: - echo "s/>>>AIRCFT_BIAS<<> sed_file + echo "s/>>>AIRCFT_BIAS<<> sed_file echo 'Setting aircraft_t_bc_pof to true, using POF bias correction' breaksw default: diff --git a/src/Applications/GSI_App/fvssi b/src/Applications/GSI_App/fvssi index 05793097..91fedd4b 100755 --- a/src/Applications/GSI_App/fvssi +++ b/src/Applications/GSI_App/fvssi @@ -742,11 +742,11 @@ echo 'Setting aircraft_t_bc_ext to true, using external bias correction' breaksw case 2: - echo "s/>>>AIRCFT_BIAS<<> sed_file + echo "s/>>>AIRCFT_BIAS<<> sed_file echo 'Setting aircraft_t_bc to true, using VV.VV^2 bias correction' breaksw case 3: - echo "s/>>>AIRCFT_BIAS<<> sed_file + echo "s/>>>AIRCFT_BIAS<<> sed_file echo 'Setting aircraft_t_bc_pof to true, using POF bias correction' breaksw default: From caa9f102bbba7e20059cfd5bbc5a01b4c3933062 Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz Date: Mon, 29 Nov 2021 17:10:32 -0500 Subject: [PATCH 128/205] Added forgotten comma at the end of the modified substitution string --- src/Applications/GEOSdas_App/GEOSdas.csm | 4 ++-- src/Applications/GSI_App/fvssi | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Applications/GEOSdas_App/GEOSdas.csm b/src/Applications/GEOSdas_App/GEOSdas.csm index 21a32d27..21da8ec0 100755 --- a/src/Applications/GEOSdas_App/GEOSdas.csm +++ b/src/Applications/GEOSdas_App/GEOSdas.csm @@ -913,11 +913,11 @@ exit 1 echo 'Setting aircraft_t_bc_ext to true, using external bias correction' breaksw case 2: - echo "s/>>>AIRCFT_BIAS<<> sed_file + echo "s/>>>AIRCFT_BIAS<<> sed_file echo 'Setting aircraft_t_bc to true, using VV.VV^2 bias correction' breaksw case 3: - echo "s/>>>AIRCFT_BIAS<<> sed_file + echo "s/>>>AIRCFT_BIAS<<> sed_file echo 'Setting aircraft_t_bc_pof to true, using POF bias correction' breaksw default: diff --git a/src/Applications/GSI_App/fvssi b/src/Applications/GSI_App/fvssi index 91fedd4b..65ed9bc7 100755 --- a/src/Applications/GSI_App/fvssi +++ b/src/Applications/GSI_App/fvssi @@ -742,11 +742,11 @@ echo 'Setting aircraft_t_bc_ext to true, using external bias correction' breaksw case 2: - echo "s/>>>AIRCFT_BIAS<<> sed_file + echo "s/>>>AIRCFT_BIAS<<> sed_file echo 'Setting aircraft_t_bc to true, using VV.VV^2 bias correction' breaksw case 3: - echo "s/>>>AIRCFT_BIAS<<> sed_file + echo "s/>>>AIRCFT_BIAS<<> sed_file echo 'Setting aircraft_t_bc_pof to true, using POF bias correction' breaksw default: From c7b89e96a8ca2244894790702c1198e76abb21b4 Mon Sep 17 00:00:00 2001 From: saraqzhang Date: Tue, 30 Nov 2021 11:28:34 -0500 Subject: [PATCH 129/205] add member information to file name template of land forcing collection modified: src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/HISTAENS.rc.tmpl --- .../NCEP_Etc/NCEP_enkf/scripts/gmao/etc/HISTAENS.rc.tmpl | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/HISTAENS.rc.tmpl b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/HISTAENS.rc.tmpl index eb36c72c..345ed08f 100644 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/HISTAENS.rc.tmpl +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/HISTAENS.rc.tmpl @@ -630,7 +630,7 @@ COLLECTIONS: 'bkg.eta' tavg1_2d_lfo_Nx+-.format: 'CFIO', tavg1_2d_lfo_Nx+-.descr: '2d,1-Hourly,Time-Averaged,Single-Level,Forecast,Land forcing' , - tavg1_2d_lfo_Nx+-.template: '%y4%m2%d2_%h2%n2z.nc4', + tavg1_2d_lfo_Nx+-.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<', tavg1_2d_lfo_Nx+-.mode: 'time-averaged', tavg1_2d_lfo_Nx+-.ref_date: >>>IOBBKGD<<< , tavg1_2d_lfo_Nx+-.ref_time: >>>IOBBKGT<<< , @@ -650,7 +650,7 @@ COLLECTIONS: 'bkg.eta' inst1_2d_lfo_Nx+-.format: 'CFIO', inst1_2d_lfo_Nx+-.descr: '2d,1-Hourly,Instantaneous,Single-Level,Forecast,land forcing' - inst1_2d_lfo_Nx+-.template: '%y4%m2%d2_%h2%n2z.nc4', + inst1_2d_lfo_Nx+-.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<', inst1_2d_lfo_Nx+-.mode: 'instantaneous' , inst1_2d_lfo_Nx+-.ref_date: >>>IOBBKGD<<< , inst1_2d_lfo_Nx+-.ref_time: >>>IOBBKGT<<< , From 4cb361cfb844067f013fe9f11883e68f3cdf4ada Mon Sep 17 00:00:00 2001 From: Joe Stassi Date: Tue, 30 Nov 2021 16:15:40 -0500 Subject: [PATCH 130/205] Modified so that script will not attempt to demigrate files that are not offline. --- .../NCEP_enkf/scripts/gmao/get_atmens_rst.pl | 26 ++++++++++--------- 1 file changed, 14 insertions(+), 12 deletions(-) diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/get_atmens_rst.pl b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/get_atmens_rst.pl index 0d52486a..4d9a9398 100755 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/get_atmens_rst.pl +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/get_atmens_rst.pl @@ -24,14 +24,11 @@ # main program #------------- { - my ($pwd); - my ($three_hr_sec, $ymd3, $hms3, $yyyy3, $mm3, $hh3); - my ($atmens_date_dir, $atmens_date3_dir); - my ($rdnperts_dates3_txt); - my ($atmens_stat_dir, $atmens_ebkg_dir, $atmens_erst_dir, $atmens_ecbkg_dir); - my ($tarfile, $tarpath, $label, $pid); - my ($ens, $mem, $mfile, $mfile_new); - my (@tarList); + my ($atmens_date3_dir, $atmens_date_dir, $atmens_ebkg_dir); + my ($atmens_ecbkg_dir, $atmens_erst_dir, $atmens_stat_dir); + my ($dmlist, $ens, $hh3, $hms3, $label, $mem, $mfile, $mfile_new, $mm3); + my ($pid, $pwd, $rdnperts_dates3_txt, $tarfile, $tarpath); + my ($three_hr_sec, $ymd3, $yyyy3, @tarList, @tarListA); my $fvbin = $FindBin::Bin; $fvroot = dirname($fvbin); @@ -56,13 +53,18 @@ foreach $label ("stat", "ebkg", "ecbkg", "erst") { $tarfile = "$expid.atmens_$label.${yyyymmdd}_${hh}z.tar"; $tarpath = "$atmens_date_dir/$tarfile"; + + $dmlist = `dmls -l $tarpath`; + push @tarListA, $tarpath if $dmlist =~ m/(OFL)/; push @tarList, $tarpath; } - defined($pid = fork) or die "Error while attempting to fork;"; - unless ($pid) { - system "dmget @tarList"; - exit; + if (@tarListA) { + defined($pid = fork) or die "Error while attempting to fork;"; + unless ($pid) { + system_("dmget @tarListA"); + exit; + } } foreach $tarpath (@tarList) { system_("$fvroot/bin/parallel-untar.py $tarpath 16") } From b55a9feb47e9366731bea8d460c3109fb94a4176 Mon Sep 17 00:00:00 2001 From: Joe Stassi Date: Tue, 30 Nov 2021 16:18:14 -0500 Subject: [PATCH 131/205] Issue #83: Run AOD in parallel and wait rather than running as separate job (and rather than running in parallel and not waiting) --- src/Applications/GEOSdas_App/GEOSdas.csm | 2 +- src/Applications/GEOSdas_App/fvsetup | 38 +++++++++++++----------- 2 files changed, 22 insertions(+), 18 deletions(-) diff --git a/src/Applications/GEOSdas_App/GEOSdas.csm b/src/Applications/GEOSdas_App/GEOSdas.csm index a908d734..e2fdfd5f 100755 --- a/src/Applications/GEOSdas_App/GEOSdas.csm +++ b/src/Applications/GEOSdas_App/GEOSdas.csm @@ -4403,7 +4403,7 @@ endif # run at command line #-------------------- chmod 744 $jobf - $jobf $aod_parallel_flag >&! $gaasLOG & + $jobf $aod_parallel_flag >&! $gaasLOG else diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index 9eca6011..f7d8d041 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -2538,7 +2538,7 @@ sub get_expid { my (%already_asked); $expid = "u000_"."$res"; - if ( $g5gcm ) { $expdsc = "${expid}__${cvstag}__agrid_${res}__ogrid_${ores}" } + if ( $g5gcm ) { $expdsc = "${expid}__agrid_${res}__ogrid_${ores}" } else { $expdsc = "FVGCM-based_run" } print <<"EOF"; @@ -2596,7 +2596,7 @@ EOF } } } - $expdsc = "${expid}__${cvstag}__agrid_${res}__ogrid_${ores}" if $g5gcm; + $expdsc = "${expid}__agrid_${res}__ogrid_${ores}" if $g5gcm; $expdsc = query(" EXPDSC?", $expdsc); return 0; } @@ -2739,10 +2739,10 @@ EOF last if -d $fvbcs; if ($loop++ < 3) { - warn ">> ERROR << cannot find directory $fvbcs"; + warn ">> WARNING << Cannot find directory $fvbcs; Try again;"; redo; } else { - die ">> ERROR << cannot find directory $fvbcs"; + die ">> ERROR << Cannot find directory $fvbcs;"; } } @@ -2759,10 +2759,10 @@ EOF last if -d $fvrtbcs; if ($loop++ < 3) { - warn ">> ERROR << cannot find directory $fvrtbcs"; + warn ">> WARNING << Cannot find directory $fvrtbcs; Try again;"; redo; } else { - die ">> ERROR << cannot find directory $fvrtbcs"; + die ">> ERROR << Cannot find directory $fvrtbcs;"; } } @@ -2793,10 +2793,10 @@ sub get_extdata { unless (-d $extdata{$set}) { if ($loop++ < 3) { - warn ">> ERROR << cannot find directory: $extdata{$set}"; + warn ">> WARNING << Cannot find directory: $extdata{$set}; Try again;"; redo; } else { - die ">> ERROR << cannot find directory: $extdata{$set}"; + die ">> ERROR << Cannot find directory: $extdata{$set};"; } } $loop = 0; @@ -3182,10 +3182,10 @@ EOF $nymde = query(" Ending year-month-day?", $nymde); unless ($nymde =~ /^\s*\d{8}\s*$/) { if ($loop++ < 3) { - warn ">> ERROR << Date must be in yyyymmdd format. Try again.\n\n"; + warn ">> WARNING << Date must be in yyyymmdd format; Try again;"; redo; } else { - die "Date must be in yyyymmdd format. Try again.\n\n"; + die ">> ERROR << Date must be in yyyymmdd format;"; } } } @@ -3202,11 +3202,11 @@ EOF { $fhours21 = query(" Length of FORECAST run segments (in hours)?", $fhours21); if ($fhours21 % 3 != 0) { - if ($loop < 3) { - warn ">> Error << Number of hours should be a multiple of 3. Try again.\n"; + if ($loop++ < 3) { + warn ">> WARNING << Number of hours should be a multiple of 3; Try again;"; redo; } else { - die " Number of hours should be a multiple of 3. Try again.\n"; + die ">> ERROR << Number of hours should be a multiple of 3;"; } } } @@ -7621,7 +7621,7 @@ print SCRIPT <<"EOF"; setenv NCPUS_GPERT $ncpus_gpert # Number of CPUs to run gcmPERT setenv NCPUS_AOD $ncpus_aod # Number of CPUs to run PSAS-AOD setenv O_SERVERS $o_servers # Number of IO servers - setenv GAAS_RUN_SLURM 1 # launch AOD analysis as separate batch job + #setenv GAAS_RUN_SLURM 1 # launch AOD analysis as separate batch job setenv AODBLOCKJOB 1 EOF if ($ncpus_per_node) { @@ -10804,8 +10804,9 @@ sub merge_txt { } #======================================================================= sub write_saved_inputs { - my ($save_file, $dashes, $len, $prompt, $ans); - my (%varDef, @fvANS, $var, %alreadyWarned); + my ($save_file); + my ($ans, $dashes, $fvID, $len, $prompt, $var); + my (%alreadyWarned, %varDef, @fvANS); $save_file = shift @_; @@ -10818,12 +10819,15 @@ sub write_saved_inputs { $len = length("$expid.input")+1; $dashes = "-"x$len; + chomp($fvID = `git hash-object $0 | cut -c1-10`); + print SAVE "#$dashes\n"; print SAVE "# $expid.input\n"; print SAVE "#$dashes\n\n"; + print SAVE "codeID: $cvstag\n"; print SAVE "description: $expdsc\n"; - print SAVE "tag: $cvstag\n"; + print SAVE "fvsetupID: $fvID\n"; print SAVE "fvsetupflags:".$fvsetupflags."\n" if $fvsetupflags; %varDef = (); From 1f3f933c8dc152a678be4eb3ff2d23dd429beffa Mon Sep 17 00:00:00 2001 From: Joe Stassi Date: Tue, 30 Nov 2021 16:22:40 -0500 Subject: [PATCH 132/205] Issue #119: Updates so that runjob script can check for consistency between input file and fvsetup. --- .../GEOSdas_App/testsuites/C180RPY.input | 15 +- .../GEOSdas_App/testsuites/C180T14RPY.input | 15 +- .../testsuites/C360L181_replay.input | 3 +- .../testsuites/C360L91_replay.input | 3 +- .../GEOSdas_App/testsuites/C48f.input | 3 +- .../GEOSdas_App/testsuites/C90C.input | 3 +- .../GEOSdas_App/testsuites/C90C_ens.input | 3 +- .../GEOSdas_App/testsuites/C90C_replay.input | 3 +- .../GEOSdas_App/testsuites/CMakeLists.txt | 21 ++- .../GEOSdas_App/testsuites/checkinput.pl | 75 ++------- .../GEOSdas_App/testsuites/fpp.input | 3 +- .../GEOSdas_App/testsuites/geos_it.input | 3 +- .../GEOSdas_App/testsuites/prePP.input | 3 +- .../GEOSdas_App/testsuites/runjob.pl | 158 ++++++------------ .../GEOSdas_App/testsuites/x0046a.input | 3 +- .../GEOSdas_App/testsuites/x0046aRPY.input | 3 +- 16 files changed, 127 insertions(+), 190 deletions(-) diff --git a/src/Applications/GEOSdas_App/testsuites/C180RPY.input b/src/Applications/GEOSdas_App/testsuites/C180RPY.input index f23b3938..42b8db59 100644 --- a/src/Applications/GEOSdas_App/testsuites/C180RPY.input +++ b/src/Applications/GEOSdas_App/testsuites/C180RPY.input @@ -2,8 +2,9 @@ # C180RPY.input #------------ -description: C180RPY__GEOSadas-5_29_3__agrid_C360__ogrid_C -tag: GEOSadas-5_29_3 +codeID: b3a880f +description: C180RPY__GEOSadas-5_29_3__agrid_C180__ogrid_C +fvsetupID: f7d8d041c9 ---ENDHEADERS--- @@ -28,7 +29,7 @@ EXPID? [u000_C180] Check for previous use of expid (y/n)? [y] > n -EXPDSC? [C180RPY__GEOSadas-5_29_3__agrid_C360__ogrid_C] +EXPDSC? [C180RPY__GEOSadas-5_29_3__agrid_C180__ogrid_C] > Land Boundary Conditions? [Icarus_Updated] @@ -85,7 +86,7 @@ Run model-adjoint-related applications (0=no,1=yes)? [0] Run analysis-sensitivity applications (0=no,1=yes)? [0] > -Ending year-month-day? [20191121] +Ending year-month-day? [20201201] > 20210206 Length of FORECAST run segments (in hours)? [123] @@ -97,7 +98,7 @@ Number of one-day DAS segments per PBS job? [1] Number of PEs in the zonal direction (NX)? [8] > 20 -Number of PEs in the meridional direction (NY)? [48] +Number of PEs in the meridional direction (NY)? [30] > 60 Job nickname? [g5das] @@ -124,10 +125,10 @@ GEOS grid resolution instead? [d] Ensemble Hybrid (<0;3=3dHyb;4=Hyb4d)? [-1] > 4 -Number of procs in the zonal direction (NX)? [12] +Number of procs in the zonal direction (NX)? [6] > 16 -Number of procs in the meridional direction (NY)? [20] +Number of procs in the meridional direction (NY)? [32] > 42 Which main class of ObsSys (1: NRT; 2: MERRA; 3: MERRA-2)? [1] diff --git a/src/Applications/GEOSdas_App/testsuites/C180T14RPY.input b/src/Applications/GEOSdas_App/testsuites/C180T14RPY.input index 3d137dfd..aa49b8d3 100644 --- a/src/Applications/GEOSdas_App/testsuites/C180T14RPY.input +++ b/src/Applications/GEOSdas_App/testsuites/C180T14RPY.input @@ -2,8 +2,9 @@ # C180T14RPY.input #------------ -description: C180T14RPY__GEOSadas-5_29_3__agrid_C360__ogrid_C -tag: GEOSadas-5_29_3 +codeID: b3a880f +description: C180T14RPY__GEOSadas-5_29_3__agrid_C180__ogrid_T14 +fvsetupID: f7d8d041c9 ---ENDHEADERS--- @@ -28,7 +29,7 @@ EXPID? [u000_C180] Check for previous use of expid (y/n)? [y] > n -EXPDSC? [C180T14RPY__GEOSadas-5_29_3__agrid_C360__ogrid_C] +EXPDSC? [C180T14RPY__GEOSadas-5_29_3__agrid_C180__ogrid_T14] > Land Boundary Conditions? [Icarus_Updated] @@ -85,7 +86,7 @@ Run model-adjoint-related applications (0=no,1=yes)? [0] Run analysis-sensitivity applications (0=no,1=yes)? [0] > -Ending year-month-day? [20191121] +Ending year-month-day? [20201201] > 20210206 Length of FORECAST run segments (in hours)? [123] @@ -97,7 +98,7 @@ Number of one-day DAS segments per PBS job? [1] Number of PEs in the zonal direction (NX)? [8] > 20 -Number of PEs in the meridional direction (NY)? [48] +Number of PEs in the meridional direction (NY)? [30] > 60 Job nickname? [g5das] @@ -124,10 +125,10 @@ GEOS grid resolution instead? [d] Ensemble Hybrid (<0;3=3dHyb;4=Hyb4d)? [-1] > 4 -Number of procs in the zonal direction (NX)? [12] +Number of procs in the zonal direction (NX)? [6] > 16 -Number of procs in the meridional direction (NY)? [20] +Number of procs in the meridional direction (NY)? [32] > 42 Which main class of ObsSys (1: NRT; 2: MERRA; 3: MERRA-2)? [1] diff --git a/src/Applications/GEOSdas_App/testsuites/C360L181_replay.input b/src/Applications/GEOSdas_App/testsuites/C360L181_replay.input index 7544d0df..2b4fb443 100644 --- a/src/Applications/GEOSdas_App/testsuites/C360L181_replay.input +++ b/src/Applications/GEOSdas_App/testsuites/C360L181_replay.input @@ -2,8 +2,9 @@ # C360L181_replay.input #------------ +codeID: b3a880f description: C360L181_replay__GEOSadas-5_29_3__agrid_C360__ogrid_C -tag: GEOSadas-5_29_3 +fvsetupID: f7d8d041c9 ---ENDHEADERS--- diff --git a/src/Applications/GEOSdas_App/testsuites/C360L91_replay.input b/src/Applications/GEOSdas_App/testsuites/C360L91_replay.input index 00f14ef4..4761a88e 100644 --- a/src/Applications/GEOSdas_App/testsuites/C360L91_replay.input +++ b/src/Applications/GEOSdas_App/testsuites/C360L91_replay.input @@ -2,8 +2,9 @@ # C360L91_replay.input #------------ +codeID: b3a880f description: C360L91_replay__GEOSadas-5_29_3__agrid_C360__ogrid_C -tag: GEOSadas-5_29_3 +fvsetupID: f7d8d041c9 ---ENDHEADERS--- diff --git a/src/Applications/GEOSdas_App/testsuites/C48f.input b/src/Applications/GEOSdas_App/testsuites/C48f.input index 7babc6cd..ceca39af 100644 --- a/src/Applications/GEOSdas_App/testsuites/C48f.input +++ b/src/Applications/GEOSdas_App/testsuites/C48f.input @@ -2,8 +2,9 @@ # C48f.input #----------- +codeID: b3a880f description: C48f__GEOSadas-5_29_3__agrid_C48__ogrid_f34 -tag: GEOSadas-5_29_3 +fvsetupID: f7d8d041c9 fvsetupflags: -sensdeg 1 ---ENDHEADERS--- diff --git a/src/Applications/GEOSdas_App/testsuites/C90C.input b/src/Applications/GEOSdas_App/testsuites/C90C.input index 4e67007e..32b7e293 100644 --- a/src/Applications/GEOSdas_App/testsuites/C90C.input +++ b/src/Applications/GEOSdas_App/testsuites/C90C.input @@ -2,8 +2,9 @@ # C90C.input #----------- +codeID: b3a880f description: C90C__GEOSadas-5_29_3__agrid_C90__ogrid_CS -tag: GEOSadas-5_29_3 +fvsetupID: f7d8d041c9 ---ENDHEADERS--- diff --git a/src/Applications/GEOSdas_App/testsuites/C90C_ens.input b/src/Applications/GEOSdas_App/testsuites/C90C_ens.input index 57cf8247..9031a002 100644 --- a/src/Applications/GEOSdas_App/testsuites/C90C_ens.input +++ b/src/Applications/GEOSdas_App/testsuites/C90C_ens.input @@ -2,8 +2,9 @@ # C90C_ens.input #--------------- +codeID: b3a880f description: C90C_ens__GEOSadas-5_29_3__agrid_C90__ogrid_C -tag: GEOSadas-5_29_3 +fvsetupID: f7d8d041c9 ---ENDHEADERS--- diff --git a/src/Applications/GEOSdas_App/testsuites/C90C_replay.input b/src/Applications/GEOSdas_App/testsuites/C90C_replay.input index 7f24c573..03774975 100644 --- a/src/Applications/GEOSdas_App/testsuites/C90C_replay.input +++ b/src/Applications/GEOSdas_App/testsuites/C90C_replay.input @@ -2,8 +2,9 @@ # C90C_replay.input #--------------- +codeID: b3a880f description: C90C_replay__86f27c6__agrid_C90__ogrid_C -tag: 86f27c6 +fvsetupID: f7d8d041c9 ---ENDHEADERS--- diff --git a/src/Applications/GEOSdas_App/testsuites/CMakeLists.txt b/src/Applications/GEOSdas_App/testsuites/CMakeLists.txt index 7cbe79d1..b2194e3a 100644 --- a/src/Applications/GEOSdas_App/testsuites/CMakeLists.txt +++ b/src/Applications/GEOSdas_App/testsuites/CMakeLists.txt @@ -34,15 +34,30 @@ if(GIT_FOUND) message(FATAL_ERROR "This should not be reached") endif () endif () + + message("Setting fvID to fvsetup SHA1 (1st 10 digits)") + execute_process( + COMMAND ${GIT_EXECUTABLE} hash-object src/Applications/GEOSdas_App/fvsetup + COMMAND cut -c1-10 + WORKING_DIRECTORY ${CMAKE_SOURCE_DIR} + OUTPUT_VARIABLE fvID + OUTPUT_STRIP_TRAILING_WHITESPACE + ) + message("fvID=${fvID}") endif() configure_file(CVSTAG.in CVSTAG @ONLY) -install(FILES ${CMAKE_CURRENT_BINARY_DIR}/CVSTAG DESTINATION etc) +install ( + FILES ${CMAKE_CURRENT_BINARY_DIR}/CVSTAG + DESTINATION etc +) set (ESMABIN ${CMAKE_INSTALL_PREFIX}/bin) set (ESMATST ${CMAKE_INSTALL_PREFIX}/etc/testsuites) foreach (perl_script checkinput runjob) configure_file ( ${perl_script}.pl ${perl_script} @ONLY) - install (PROGRAMS ${CMAKE_CURRENT_BINARY_DIR}/${perl_script} DESTINATION bin) + install ( + PROGRAMS ${CMAKE_CURRENT_BINARY_DIR}/${perl_script} + DESTINATION bin + ) endforeach () - diff --git a/src/Applications/GEOSdas_App/testsuites/checkinput.pl b/src/Applications/GEOSdas_App/testsuites/checkinput.pl index 142e6324..f2ec38c9 100644 --- a/src/Applications/GEOSdas_App/testsuites/checkinput.pl +++ b/src/Applications/GEOSdas_App/testsuites/checkinput.pl @@ -12,13 +12,12 @@ # global variables #----------------- -my ($auto, $inputDir, $full, $ignoreOSdiff, $debug, $stage, $rmlabel); -my ($verbose, $VERBOSE, $replaceALL); -my ($inFile, $inFileChk, @goodFiles, @badFiles, @errFiles); -my (@inputFiles, %head, $expid, %def0, %def1, @rawVALUE); -my ($fvsetupScript, $fvroot, $newinput); -my ($noloop, $sel, $sel_dflt); -my ($CVSTAG, $ESMATST, $siteID); +my ($auto, $codeID, $debug, $ESMATST, $expid, $full, $fvroot); +my ($fvsetupID, $fvsetupScript, $ignoreOSdiff); +my ($inFile, $inFileChk, $inputDir, $newinput, $noloop, $replaceALL); +my ($sel, $sel_dflt, $siteID, $stage, $VERBOSE, $verbose); +my (@badFiles, @errFiles, @goodFiles, @inputFiles, @rawVALUE); +my (%def0, %def1, %head); # main program #------------- @@ -62,7 +61,8 @@ sub init { # these values are set during build #---------------------------------- - $CVSTAG = "@GIT_TAG_OR_REV@"; + $codeID = "@GIT_TAG_OR_REV@"; + $fvsetupID = "@fvID@"; $ESMABIN = "@ESMABIN@"; $ESMATST = "@ESMATST@"; die ">> Error << $ESMABIN is not a directory;" unless -d $ESMABIN; @@ -70,14 +70,13 @@ sub init { # get runtime options #-------------------- Getopt::Long::Configure("no_ignore_case"); - GetOptions( "auto" => \$auto, + GetOptions( "a|auto" => \$auto, "d=s" => \$inputDir, "full" => \$full, "l|local" => \$localdir, "OSx" => \$ignoreOSdiff, "db|debug" => \$debug, "h|help" => \$help, - "RL!" => \$rmlabel, "stage" => \$stage, "v" => \$verbose, "V" => \$VERBOSE ); @@ -85,7 +84,6 @@ sub init { $verbose = 0 unless $verbose; $VERBOSE = 0 unless $VERBOSE; $verbose = 1 if $VERBOSE; - $rmlabel = 1 unless defined($rmlabel); @inputFiles = @ARGV; if ($localdir) { $inputDir = cwd() unless $inputDir } @@ -95,7 +93,6 @@ sub init { $fvroot = dirname($ESMABIN); $fvsetupScript = "$ESMABIN/fvsetup"; die ">> Error << cannot find $fvsetupScript;\n" unless -e $fvsetupScript; - } #======================================================================= @@ -109,8 +106,8 @@ sub intro { print "\n====================\n" . "\nCheck Fvsetup Inputs\n" . "\n====================\n"; - print "\nCVSTAG: $CVSTAG\n"; - print "fvsetup: " . dirname($fvsetupScript) ."\n"; + print "fvsetupID: $fvsetupID\n"; + print "fvsetup: " . dirname($fvsetupScript) ."\n"; } #======================================================================= @@ -191,10 +188,6 @@ sub getInputDir { } } - # chdir to $inputDir, just to be safe - #------------------------------------ - chdir $inputDir; - # stage inputs from testsuites directory, if requested #----------------------------------------------------- stageInputs() if $stage; @@ -268,7 +261,7 @@ sub getInputFiles { # get list of setup input files, if not specified by user #-------------------------------------------------------- - @inputFiles = (<$inputDir/*input>) unless @inputFiles; + @inputFiles = (<*.input>) unless @inputFiles; } #======================================================================= @@ -644,40 +637,6 @@ sub runSetup { foreach $line () { chomp $line; - # remove UNSTABLE, OPS, rejected, and retired labels from CVSTAG - #--------------------------------------------------------------- - if ($rmlabel) { - if ($line =~ /$CVSTAG/ and $line =~ /_UNSTABLE/) { - ($modline = $line) =~ s/_UNSTABLE//g; - print " mod: [$line] => [$modline]\n"; - $line = $modline; - } - - if ($line =~ /$CVSTAG/ and $line =~ /_INTERIM/) { - ($modline = $line) =~ s/_INTERIM//g; - print " mod: [$line] => [$modline]\n"; - $line = $modline; - } - - if ($line =~ /$CVSTAG/ and $line =~ /_OPS/) { - ($modline = $line) =~ s/_OPS//g; - print " mod: [$line] => [$modline]\n"; - $line = $modline; - } - - if ($line =~ /$CVSTAG/ and $line =~ /_rejected/) { - ($modline = $line) =~ s/_rejected//g; - print " mod: [$line] => [$modline]\n"; - $line = $modline; - } - - if ($line =~ /$CVSTAG/ and $line =~ /_retired/) { - ($modline = $line) =~ s/_retired//g; - print " mod: [$line] => [$modline]\n"; - $line = $modline; - } - } - # transfer previous description if one existed #--------------------------------------------- if ($line =~ /^description:\s*$/ and $head{"description"}) { @@ -1276,13 +1235,13 @@ sub usage { usage: $script [options] options - -auto use defaults rather than prompting for responses + -auto/-a use defaults rather than prompting for responses -d inputDir directory location of saved *.input files -full write full responses in *.input files - -l use local directory to look for saved *.input files + -local/-l use local directory to look for saved *.input files -OSx proceed even if OS difference found - -debug (or -db) do not remove .rawInFile and error logfile - -help (or -h) print usage information + -debug/-db do not remove .rawInFile and error logfile + -help/-h print usage information -noRL do not remove the following labels from tag name: "_UNSTABLE" "_INTERIM", "_OPS", "_rejected", "_retired" by default these labels are removed @@ -1295,7 +1254,7 @@ sub usage { 2. However, input files may be specified by name only in the command line, without including the ".input" extension. 3. If no file is specified as an input parameter, then the script will look - in the input directory for input files which match the CVSTAG of this script + at all input files in the local directory. 4. The precedence for determining the input directory (location of *.input files) is as follows: i) location specified with the -d flag diff --git a/src/Applications/GEOSdas_App/testsuites/fpp.input b/src/Applications/GEOSdas_App/testsuites/fpp.input index 5ffad57a..4cb36102 100644 --- a/src/Applications/GEOSdas_App/testsuites/fpp.input +++ b/src/Applications/GEOSdas_App/testsuites/fpp.input @@ -2,8 +2,9 @@ # fpp.input #------------ +codeID: b3a880f description: fpp__GEOSadas-5_29_3__agrid_C720__ogrid_C -tag: GEOSadas-5_29_3 +fvsetupID: f7d8d041c9 ---ENDHEADERS--- diff --git a/src/Applications/GEOSdas_App/testsuites/geos_it.input b/src/Applications/GEOSdas_App/testsuites/geos_it.input index 98238143..70e5fe24 100644 --- a/src/Applications/GEOSdas_App/testsuites/geos_it.input +++ b/src/Applications/GEOSdas_App/testsuites/geos_it.input @@ -2,8 +2,9 @@ # geos_it.input #-------------- +codeID: b3a880f description: geos_it__GEOSadas-5_29_3__agrid_C360__ogrid_C -tag: GEOSadas-5_29_3 +fvsetupID: f7d8d041c9 ---ENDHEADERS--- diff --git a/src/Applications/GEOSdas_App/testsuites/prePP.input b/src/Applications/GEOSdas_App/testsuites/prePP.input index 642b1679..3819faab 100644 --- a/src/Applications/GEOSdas_App/testsuites/prePP.input +++ b/src/Applications/GEOSdas_App/testsuites/prePP.input @@ -2,8 +2,9 @@ # prePP.input #------------ +codeID: b3a880f description: prePP__GEOSadas-5_29_3__agrid_C720__ogrid_C -tag: GEOSadas-5_29_3 +fvsetupID: f7d8d041c9 ---ENDHEADERS--- diff --git a/src/Applications/GEOSdas_App/testsuites/runjob.pl b/src/Applications/GEOSdas_App/testsuites/runjob.pl index 9c699c4f..d0c1198c 100644 --- a/src/Applications/GEOSdas_App/testsuites/runjob.pl +++ b/src/Applications/GEOSdas_App/testsuites/runjob.pl @@ -19,7 +19,7 @@ # # Input file header information # => description: [experiment description] -# => tag: [DAS tag ID] +# => fvid: [fvsetup ID] # => def: [variable];nas = [value at NAS] # => def: [variable];nccs = [value at NCCS] # => fvsetupflags: [fvsetup option] @@ -37,12 +37,14 @@ # global variables #----------------- -my ($auto, $autox, $nocheck, $nofilter, @inputFiles, $specified, $noloop); -my ($inputDir, $ignoreOSdiff, $debug, $dbqueue, $stage, $verbose, $sel); -my (%inFile, %rawInFile, %fvhome, $siteID, $CVSTAG, $ESMATST, $TRYAGAIN); -my (%descript, %edits, %expid, %flags, %fvics, %tag, %rem_acct); -my ($ESMABIN, $fvsetupScript, $fvroot, $jobn, @default, @nondefault); - +my ($ESMABIN, $ESMATST, $TRYAGAIN); +my ($auto, $autox, $codeID, $dbqueue, $debug); +my ($fvroot, $fvsetupID, $fvsetupScript); +my ($ignoreOSdiff, $inputDir, $jobn, $nocheck, $nofilter, $noloop); +my ($sel, $siteID, $specified, $stage, $verbose); +my (%descript, %edits, %expid, %flags, %fvhome, %fvics, %fvid); +my (%inFile, %rawInFile, %rem_acct); +my (@default, @inputFiles, @nondefault); # main program #------------- @@ -62,8 +64,8 @@ # Notes on where to find fvsetup - # 1. The variable, $ESMABIN, contains the directory location for the # fvsetup script. This value is hard-coded during the build. -# 2. This script is tag-dependent; it may not work properly for different -# versions of fvsetup which have a different collection and order of prompts. +# 2. This script is fvsetupID-dependent; it may not work properly for different +# versions of fvsetup which have differences in the prompts. # 3. $ESMABIN can be overwritten by using the -D flag to supply an alternate # location for fvsetup. This should be done with great care. #======================================================================= @@ -78,10 +80,12 @@ sub init { $TRYAGAIN = 9999; $siteID = get_siteID(); + #--$fvsetupID = `git hash-object $fvsetupScript | cut -c1-10`; # these values are set with sed substitution during build #-------------------------------------------------------- - $CVSTAG = "@GIT_TAG_OR_REV@"; + $codeID = "@GIT_TAG_OR_REV@"; + $fvsetupID = "@fvID@"; $ESMABIN = "@ESMABIN@"; $ESMATST = "@ESMATST@"; die ">> Error << $ESMABIN is not a directory;" unless -d $ESMABIN; @@ -89,10 +93,10 @@ sub init { # get runtime options #-------------------- Getopt::Long::Configure("no_ignore_case"); - GetOptions( "auto" => \$auto, - "autox" => \$autox, - "nocheck" => \$nocheck, - "nofilter" => \$nofilter, + GetOptions( "a|auto" => \$auto, + "ax|autox" => \$autox, + "nc|nocheck" => \$nocheck, + "nf|nofilter" => \$nofilter, "d=s" => \$inputDir, "l|local" => \$localdir, "OSx" => \$ignoreOSdiff, @@ -271,9 +275,8 @@ sub queryInputDir { # purpose - get list of *.input files in $inputDir #======================================================================= sub getInputs { - my ($key, $label, $index, $input, $tag, $expid, $ext); + my ($key, $label, $index, $input, $fvID, $expid, $ext); my ($file, $file1, $size); - my ($tag1, $tag2); # check that user-specified input files exist #-------------------------------------------- @@ -303,40 +306,21 @@ sub getInputs { elsif ($nofilter) { $label .= "\n" } else { - $label .= " for tag, $CVSTAG\n" } + $label .= " for fvsetupID: $fvsetupID\n" } underline($label); $key = 0; foreach $index (0..$#inputFiles) { $input = $inputFiles[$index]; - $tag = extract($input, "tag", 1); + $fvID = extract($input, "fvsetupID", 1); ($expid, $ext) = split/[\.]/, basename $input; - - # ignore the following label differences: - # "_UNSTABLE", "_OPS", "INTERIM", "_rejected", "_retired" - #-------------------------------------------------------- - ($tag1 = $CVSTAG) =~ s/_UNSTABLE$//; - ($tag2 = $tag) =~ s/_UNSTABLE$//; - - $tag1 =~ s/_OPS$//; - $tag2 =~ s/_OPS$//; - - $tag1 =~ s/_INTERIM$//; - $tag2 =~ s/_INTERIM$//; - - $tag1 =~ s/_rejected$//; - $tag2 =~ s/_rejected$//; - - $tag1 =~ s/_retired$//; - $tag2 =~ s/_retired$//; - - next unless $nofilter or ($tag1 eq $tag2); + next unless $nofilter or ($fvsetupID eq $fvID); # continue with input file #------------------------- $inFile{++$key} = $input; - $tag{$key} = $tag; + $fvid{$key} = $fvID; $expid{$key} = $expid; getRawInputs($key); extractAdditionalInfo($key); @@ -561,7 +545,7 @@ sub runjobs { my ($key, @keyArr); unless (%inFile) { - print "\nNo infiles were found for tag, $CVSTAG\n\n"; + print "\nNo infiles were found for fvsetupID: $fvsetupID\n\n"; return; } @@ -610,7 +594,7 @@ sub choose_job { $max1 = maxlen(values %expid); $max2 = maxlen(values %inFile); - $max3 = maxlen(values %tag); + $max3 = maxlen(values %fvid); $fmt0 = "%3s. %s\n"; $fmt1 = " %-${max1}s %-${max2}s %-${max3}s %s\n"; $fmt2 = "%3s. %-${max1}s %-${max2}s %-${max3}s : %s\n"; @@ -622,12 +606,12 @@ sub choose_job { print "\n--------------\n" . "Available Jobs\n" . "--------------\n"; - print "CVSTAG: $CVSTAG\n" unless $nofilter; + print "fvsetupID: $fvsetupID\n" unless $nofilter; print "directory: $inputDir\n\n"; if (%expid) { if ($nofilter) { - printf $fmt1, "expid", "file", "tag", "description"; - printf $fmt1, "-----", "----", "---", "-----------"; + printf $fmt1, "expid", "file", "fvID", "description"; + printf $fmt1, "-----", "----", "----", "-----------"; } else { printf $fmt3, "expid", "file", "description"; @@ -638,7 +622,7 @@ sub choose_job { foreach (sort numeric keys %inFile) { if ($nofilter) { printf $fmt2, $_, $expid{$_}, basename($inFile{$_}), - $tag{$_}, $descript{$_}; + $fvid{$_}, $descript{$_}; } else { printf $fmt4, $_, $expid{$_}, basename($inFile{$_}), @@ -749,9 +733,8 @@ sub run_fvsetup { use File::Path; my $key; my ($rawinput, $fvsuLOG, $fvsuLOG1, $fvsuERR, $fvsuERR1, $output, $logdir); - my ($fvsetup, $expid_arc, $clean, $label, $verify, $ans); + my ($fvsetup, $expid_arc, $clean, $verify, $ans); my ($FVHOME, $dflt, $cmd, @bootstrap, $status, $continueflag); - my ($tag1, $tag2, $tag3, $tag4, $tag5, $tag6, $tag7, $tag8); # input parameter #---------------- @@ -774,69 +757,36 @@ sub run_fvsetup { print " expid: $expid{$key}\n"; print " description: $descript{$key}\n"; print " input file: $inFile{$key}\n"; - print " CVS tag $tag{$key}\n" if $tag{$key};; + print " fvsetup ID: $fvid{$key}\n" if $fvid{$key};; print " fvsetup flags: $flags{$key}\n" if $flags{$key}; print " other edits: $edits{$key}\n" if $edits{$key}; print " FVHOME: $fvhome{$key}\n"; print " fvsetup: $fvsetupScript\n"; - # check CVS tag consistency - #-------------------------- + # check fvsetupid consistency + #---------------------------- $verify = 0; - if ( $tag{$key} ) { - if ( $CVSTAG ne $tag{$key} ) { + if ( $fvid{$key} ) { + if ( $fvsetupID ne $fvid{$key} ) { $verify = 1; - - # is the difference from a known associated label? - #------------------------------------------------- - ($tag1 = $CVSTAG) =~ s/_UNSTABLE$//; - ($tag2 = $tag{$key}) =~ s/_UNSTABLE$//; - if ($tag1 eq $tag2) { $verify = 0; $label = "Unstable tag found" } - - ($tag1 = $CVSTAG) =~ s/_INTERIM$//; - ($tag2 = $tag{$key}) =~ s/_INTERIM$//; - if ($tag1 eq $tag2) { $verify = 0; $label = "Interim tag found" } - - ($tag1 = $CVSTAG) =~ s/_rejected$//; - ($tag2 = $tag{$key}) =~ s/_rejected$//; - if ($tag1 eq $tag2) { $verify = 0; $label = "Rejected tag found" } - - ($tag1 = $CVSTAG) =~ s/_retired$//; - ($tag2 = $tag{$key}) =~ s/_retired$//; - if ($tag1 eq $tag2) { $verify = 0; $label = "Retired tag found" } - - ($tag1 = $CVSTAG) =~ s/_OPS$//; - ($tag2 = $tag{$key}) =~ s/_OPS$//; - if ($tag1 eq $tag2) { $verify = 0; $label = "OPS tag found" } - - # or is it a more serious difference? - #------------------------------------ - if ($verify) { - print "\n !!!---------!!!\n" - . " !!! WARNING !!!\n" - . " !!!---------!!!\n" - . " CVS tag inconsistency found.\n" - . " input file: $inFile{$key}\n\n" - . " CVS Tag (input file): $tag{$key}\n" - . " CVS Tag (runjob script): $CVSTAG\n"; - } - else { - print "\n $label"; - print "\n "."-"x length($label) ."\n" - . " CVS Tag (runjob script): $CVSTAG\n" - . " CVS Tag (input file): $tag{$key}\n"; - } + print "\n !!!---------!!!\n" + . " !!! WARNING !!!\n" + . " !!!---------!!!\n" + . " fvsetupID inconsistency found.\n" + . " input file: $inFile{$key}\n\n" + . " fvsetupID (input file): $fvid{$key}\n" + . " fvsetupID (runjob script): $fvsetupID\n"; } } else { + $verify = 1; print "\n !!!!!!!!!!!!!!!\n" . " !!! WARNING !!!\n" . " !!!!!!!!!!!!!!!\n" - . " No tag information available in input file.\n" + . " fvsetupID not found in input file.\n" . " input file: $inFile{$key}\n\n" - . " CVS Tag (input file): not found\n" - . " CVS Tag (runjob script): $CVSTAG\n"; - $verify = 1; + . " fvsetupID (input file): not found\n" + . " fvsetupID (runjob script): $fvsetupID\n"; } if ($verify) { print "\nUnless you are sure the input file is okay, you should quit" @@ -1405,15 +1355,15 @@ sub usage { usage: $script [options] [file1 [file2 [..]]] options - -auto use dflt responses for queries; automatically submit job(s) - -autox use dflt responses for queries; do not submit job(s) - -nocheck do not check for previous use of expid - -nofilter do not exclude *.input files if CVSTAG does not match + -auto/-a use dflt responses for queries; automatically submit job(s) + -autox/-ax use dflt responses for queries; do not submit job(s) + -nocheck/-nc do not check for previous use of expid + -nofilter/-nf do not exclude *.input files if fvsetupID does not match -d inputDir directory location of saved *.input files - -debug (or -db) runjob debug mode; do not remove .rawInFile and ERR files - -dbqueue (or -dbq) send job to debug queue for faster processing + -debug/-db runjob debug mode; do not remove .rawInFile and ERR files + -dbqueue/-dbq send job to debug queue for faster processing -f fvsetup fvsetup script to use; defaults to \$ESMABIN version - -help (or -h) print usage information + -help/-h print usage information -l get *.input files from local directory -OSx proceed even if OS difference found -stage copy testsuites *.input files to input directory @@ -1426,7 +1376,7 @@ sub usage { 2. However, input files may be specified by name only in the command line, without including the ".input" extension. 3. If no file is specified as an input parameter, then the script will look - in the input directory for input files which match the CVSTAG of this script + in the input directory for input files which match the fvsetupID of this script (if -nofilter flag is set, then all inputs will be available). 4. The precedence for determining the input directory (location of *.input files) is as follows: diff --git a/src/Applications/GEOSdas_App/testsuites/x0046a.input b/src/Applications/GEOSdas_App/testsuites/x0046a.input index 1a227b31..bfed5c62 100644 --- a/src/Applications/GEOSdas_App/testsuites/x0046a.input +++ b/src/Applications/GEOSdas_App/testsuites/x0046a.input @@ -2,8 +2,9 @@ # x0046a.input #------------ +codeID: b3a880f description: x0046a__GEOSadas-5_29_3__agrid_C360__ogrid_C -tag: GEOSadas-5_29_3 +fvsetupID: f7d8d041c9 ---ENDHEADERS--- diff --git a/src/Applications/GEOSdas_App/testsuites/x0046aRPY.input b/src/Applications/GEOSdas_App/testsuites/x0046aRPY.input index c5b9a4c2..9b6ac926 100644 --- a/src/Applications/GEOSdas_App/testsuites/x0046aRPY.input +++ b/src/Applications/GEOSdas_App/testsuites/x0046aRPY.input @@ -2,8 +2,9 @@ # x0046aRPY.input #------------ +codeID: b3a880f description: x0046aRPY__GEOSadas-5_29_3__agrid_C360__ogrid_C -tag: GEOSadas-5_29_3 +fvsetupID: f7d8d041c9 ---ENDHEADERS--- From 85c05540d8b104a94af23fffceaa1068912f1d26 Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz Date: Fri, 3 Dec 2021 15:32:51 -0500 Subject: [PATCH 133/205] Corrected spelling - the variable is cleanup_tail (without an 's') Added to the second instance of this substitution code in GEOSdas.csm --- src/Applications/GEOSdas_App/GEOSdas.csm | 8 ++++---- src/Applications/GSI_App/fvssi | 4 ++-- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Applications/GEOSdas_App/GEOSdas.csm b/src/Applications/GEOSdas_App/GEOSdas.csm index 21da8ec0..62d49748 100755 --- a/src/Applications/GEOSdas_App/GEOSdas.csm +++ b/src/Applications/GEOSdas_App/GEOSdas.csm @@ -913,11 +913,11 @@ exit 1 echo 'Setting aircraft_t_bc_ext to true, using external bias correction' breaksw case 2: - echo "s/>>>AIRCFT_BIAS<<> sed_file + echo "s/>>>AIRCFT_BIAS<<> sed_file echo 'Setting aircraft_t_bc to true, using VV.VV^2 bias correction' breaksw case 3: - echo "s/>>>AIRCFT_BIAS<<> sed_file + echo "s/>>>AIRCFT_BIAS<<> sed_file echo 'Setting aircraft_t_bc_pof to true, using POF bias correction' breaksw default: @@ -1128,11 +1128,11 @@ exit 1 echo 'Setting aircraft_t_bc_ext to true, using external bias correction' breaksw case 2: - echo "s/>>>AIRCFT_BIAS<<> sed_file + echo "s/>>>AIRCFT_BIAS<<> sed_file echo 'Setting aircraft_t_bc to true, using VV.VV^2 bias correction' breaksw case 3: - echo "s/>>>AIRCFT_BIAS<<> sed_file + echo "s/>>>AIRCFT_BIAS<<> sed_file echo 'Setting aircraft_t_bc_pof to true, using POF bias correction' breaksw default: diff --git a/src/Applications/GSI_App/fvssi b/src/Applications/GSI_App/fvssi index 65ed9bc7..d7638d06 100755 --- a/src/Applications/GSI_App/fvssi +++ b/src/Applications/GSI_App/fvssi @@ -742,11 +742,11 @@ echo 'Setting aircraft_t_bc_ext to true, using external bias correction' breaksw case 2: - echo "s/>>>AIRCFT_BIAS<<> sed_file + echo "s/>>>AIRCFT_BIAS<<> sed_file echo 'Setting aircraft_t_bc to true, using VV.VV^2 bias correction' breaksw case 3: - echo "s/>>>AIRCFT_BIAS<<> sed_file + echo "s/>>>AIRCFT_BIAS<<> sed_file echo 'Setting aircraft_t_bc_pof to true, using POF bias correction' breaksw default: From d61fc589d1a810651d223239da303516c9d5296b Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz Date: Fri, 3 Dec 2021 18:34:47 -0500 Subject: [PATCH 134/205] Oops, I did it again - forgot to modify BOTH places where the aircraft bias substitution is done. --- src/Applications/GSI_App/fvssi | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Applications/GSI_App/fvssi b/src/Applications/GSI_App/fvssi index d7638d06..8f78299b 100755 --- a/src/Applications/GSI_App/fvssi +++ b/src/Applications/GSI_App/fvssi @@ -842,11 +842,11 @@ echo 'Setting aircraft_t_bc_ext to true, using external bias correction' breaksw case 2: - echo "s/>>>AIRCFT_BIAS<<> sed_file + echo "s/>>>AIRCFT_BIAS<<> sed_file echo 'Setting aircraft_t_bc to true, using VV.VV^2 bias correction' breaksw case 3: - echo "s/>>>AIRCFT_BIAS<<> sed_file + echo "s/>>>AIRCFT_BIAS<<> sed_file echo 'Setting aircraft_t_bc_pof to true, using POF bias correction' breaksw default: From a9e715b53a868e31ac162f9760bc48e7514ef357 Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz Date: Wed, 8 Dec 2021 17:02:22 -0500 Subject: [PATCH 135/205] Modify to allow selecting cleanup_tail option via environment variable --- src/Applications/GEOSdas_App/GEOSdas.csm | 18 ++++++++++++++---- src/Applications/GSI_App/fvssi | 18 ++++++++++++++---- 2 files changed, 28 insertions(+), 8 deletions(-) diff --git a/src/Applications/GEOSdas_App/GEOSdas.csm b/src/Applications/GEOSdas_App/GEOSdas.csm index 62d49748..145e9373 100755 --- a/src/Applications/GEOSdas_App/GEOSdas.csm +++ b/src/Applications/GEOSdas_App/GEOSdas.csm @@ -78,6 +78,7 @@ # - Revise multi-incremental approach for 4d-analysis # (cost goes down with successive updates) # - Temporarily leaving test lines commented out +# 8Dec2021 Sienkiewicz - add option for 'cleanup_tail' for aircraft bias correction #----------------------------------------------------------------------------- # @@ -115,6 +116,7 @@ if ( !($?BOOTSTRAP) ) setenv BOOTSTRAP 0 if ( !($?CENTRAL_AGCM_PARALLEL) ) setenv CENTRAL_AGCM_PARALLEL 0 if ( !($?CHECK_DMF) ) setenv CHECK_DMF 1 + if ( !($?CLEANUP_TAIL) ) setenv CLEANUP_TAIL 0 if ( !($?CONVPROG) ) setenv CONVPROG 0 if ( !($?CONVSFC) ) setenv CONVSFC 0 if ( !($?CONVUPA) ) setenv CONVUPA 0 @@ -913,11 +915,15 @@ exit 1 echo 'Setting aircraft_t_bc_ext to true, using external bias correction' breaksw case 2: - echo "s/>>>AIRCFT_BIAS<<> sed_file + set cftstring = "aircraft_t_bc=.true.," + if ( $CLEANUP_TAIL ) set cftstring = "$cftstring cleanup_tail=.true.," + echo "s/>>>AIRCFT_BIAS<<> sed_file echo 'Setting aircraft_t_bc to true, using VV.VV^2 bias correction' breaksw case 3: - echo "s/>>>AIRCFT_BIAS<<> sed_file + set cftstring = "aircraft_t_bc_pof=.true.," + if ( $CLEANUP_TAIL ) set cftstring = "$cftstring cleanup_tail=.true.," + echo "s/>>>AIRCFT_BIAS<<> sed_file echo 'Setting aircraft_t_bc_pof to true, using POF bias correction' breaksw default: @@ -1128,11 +1134,15 @@ exit 1 echo 'Setting aircraft_t_bc_ext to true, using external bias correction' breaksw case 2: - echo "s/>>>AIRCFT_BIAS<<> sed_file + set cftstring = "aircraft_t_bc=.true.," + if ( $CLEANUP_TAIL ) set cftstring = "$cftstring cleanup_tail=.true.," + echo "s/>>>AIRCFT_BIAS<<> sed_file echo 'Setting aircraft_t_bc to true, using VV.VV^2 bias correction' breaksw case 3: - echo "s/>>>AIRCFT_BIAS<<> sed_file + set cftstring = "aircraft_t_bc_pof.true.," + if ( $CLEANUP_TAIL ) set cftstring = "$cftstring cleanup_tail=.true.," + echo "s/>>>AIRCFT_BIAS<<> sed_file echo 'Setting aircraft_t_bc_pof to true, using POF bias correction' breaksw default: diff --git a/src/Applications/GSI_App/fvssi b/src/Applications/GSI_App/fvssi index 8f78299b..7afdbc05 100755 --- a/src/Applications/GSI_App/fvssi +++ b/src/Applications/GSI_App/fvssi @@ -53,6 +53,7 @@ if ( !($?ANA4DUPD_IAU0_ONLY) ) setenv ANA4DUPD_IAU0_ONLY 0 # assume 4d increment if ( !($?ANGLEBC) ) setenv ANGLEBC 0 if ( !($?BATCH_SUBCMD) ) setenv BATCH_SUBCMD "sbatch" + if ( !($?CLEANUP_TAIL) ) setenv CLEANUP_TAIL 0 if ( !($?DATAMOVE_CONSTRAINT) ) setenv DATAMOVE_CONSTRAINT NULL if ( !($?INCSENS) ) setenv INCSENS 0 if ( !($?GSI_NETCDF_DIAG) ) setenv GSI_NETCDF_DIAG 0 @@ -742,11 +743,15 @@ echo 'Setting aircraft_t_bc_ext to true, using external bias correction' breaksw case 2: - echo "s/>>>AIRCFT_BIAS<<> sed_file + set cftstring = "aircraft_t_bc=.true.," + if ( $CLEANUP_TAIL ) set cftstring = "$cftstring cleanup_tail=.true.," + echo "s/>>>AIRCFT_BIAS<<> sed_file echo 'Setting aircraft_t_bc to true, using VV.VV^2 bias correction' breaksw case 3: - echo "s/>>>AIRCFT_BIAS<<> sed_file + set cftstring = "aircraft_t_bc_pof=.true.," + if ( $CLEANUP_TAIL ) set cftstring = "$cftstring cleanup_tail=.true.," + echo "s/>>>AIRCFT_BIAS<<> sed_file echo 'Setting aircraft_t_bc_pof to true, using POF bias correction' breaksw default: @@ -842,11 +847,15 @@ echo 'Setting aircraft_t_bc_ext to true, using external bias correction' breaksw case 2: - echo "s/>>>AIRCFT_BIAS<<> sed_file + set cftstring = "aircraft_t_bc=.true.," + if ( $CLEANUP_TAIL ) set cftstring = "$cftstring cleanup_tail=.true.," + echo "s/>>>AIRCFT_BIAS<<> sed_file echo 'Setting aircraft_t_bc to true, using VV.VV^2 bias correction' breaksw case 3: - echo "s/>>>AIRCFT_BIAS<<> sed_file + set cftstring = "aircraft_t_bc_pof=.true.," + if ( $CLEANUP_TAIL ) set cftstring = "$cftstring cleanup_tail=.true.," + echo "s/>>>AIRCFT_BIAS<<> sed_file echo 'Setting aircraft_t_bc_pof to true, using POF bias correction' breaksw default: @@ -984,6 +993,7 @@ ENVIRONMENT VARIABLES ENVIRONMENT VARIABLES (optional) ACFTBIAS sets aircraft bias correction + CLEANUP_TAIL triggers cleanup of aircraft coefficient file ANASENS trigger for analysis sensitivity (obs impact) INCSENS allows running adjoint GSI with analysis increment for input DO4DVAR trigger for 4DVAR-related features From 08dc4cdcf22c08ed80ed377b8e52e075423fa987 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Mon, 13 Dec 2021 11:41:15 -0500 Subject: [PATCH 136/205] minor fixes in various scripts; add summer case for x0046a --- components.yaml | 2 +- .../GEOSdas_App/Create_anasa_script.pm | 11 +- .../GEOSdas_App/Create_asens_script.pm | 10 +- .../GEOSdas_App/Create_fsens_script.pm | 11 +- src/Applications/GEOSdas_App/GEOSdas.csm | 2 +- src/Applications/GEOSdas_App/fvsetup | 4 +- .../GEOSdas_App/testsuites/x0046a.input | 2 +- .../testsuites/x0046a_Summer.input | 248 ++++++++++++++++++ .../NCEP_Etc/NCEP_bkgecov/ut_gen_berrcov.j | 9 +- .../NCEP_enkf/scripts/gmao/etc/nmcperts.rc | 15 +- 10 files changed, 274 insertions(+), 40 deletions(-) create mode 100644 src/Applications/GEOSdas_App/testsuites/x0046a_Summer.input diff --git a/components.yaml b/components.yaml index 7b2a6598..486ede3c 100644 --- a/components.yaml +++ b/components.yaml @@ -28,7 +28,7 @@ NCEP_Shared: GMAO_Shared: local: ./src/Shared/@GMAO_Shared remote: ../GMAO_Shared.git - tag: rt1_4_10_cas + tag: rt1_4_10_transf_fix develop: main MAPL: diff --git a/src/Applications/GEOSdas_App/Create_anasa_script.pm b/src/Applications/GEOSdas_App/Create_anasa_script.pm index f5bdae0a..d66d3975 100644 --- a/src/Applications/GEOSdas_App/Create_anasa_script.pm +++ b/src/Applications/GEOSdas_App/Create_anasa_script.pm @@ -41,8 +41,8 @@ sub anasa_script { my $hyb_ens = $inputparams{"hyb_ens"}; my $jobqueue1 = $inputparams{"jobqueue1"}; my $mem = $inputparams{"mem"}; - my $nodes = $inputparams{"nodes"}; my $ncpus_gsi = $inputparams{"ncpus_gsi"}; + my $nodeflg = $inputparams{"nodeflg"}; my $fcswallclk = $inputparams{"fcswallclk"}; my $nametag = $inputparams{"nametag"}; my $gid = $inputparams{"gid"}; @@ -73,15 +73,6 @@ sub anasa_script { my( $os, $siteID, $nodeflg ); $siteID = get_siteID(); - $nodeflg = "hasw"; - my $npn = `facter processorcount`; chomp($npn); - if ( $npn == 40 ) { - $nodeflg = "sky"; - } elsif ( $npn == 48 ) { - $nodeflg = "cas"; - } elsif ( $npn == 28 ) { - $nodeflg = "hasw"; - } open(SCRIPT,">$fvhome/anasa/$jobsa.j") or die ">>> ERROR <<< cannot write $fvhome/anasa/$jobsa.j"; diff --git a/src/Applications/GEOSdas_App/Create_asens_script.pm b/src/Applications/GEOSdas_App/Create_asens_script.pm index b45798fe..eb1f44b5 100644 --- a/src/Applications/GEOSdas_App/Create_asens_script.pm +++ b/src/Applications/GEOSdas_App/Create_asens_script.pm @@ -45,8 +45,8 @@ sub asens_script { my $hyb_ens = $inputparams{"hyb_ens"}; my $jobqueue1 = $inputparams{"jobqueue1"}; my $mem = $inputparams{"mem"}; - my $nodes = $inputparams{"nodes"}; my $ncpus_gsi = $inputparams{"ncpus_gsi"}; + my $nodeflg = $inputparams{"nodeflg"}; my $fcswallclk = $inputparams{"fcswallclk"}; my $nametag = $inputparams{"nametag"}; my $gid = $inputparams{"gid"}; @@ -76,14 +76,6 @@ sub asens_script { my( $os, $siteID, $nodeflg ); $siteID = get_siteID(); - my $npn = `facter processorcount`; chomp($npn); - if ( $npn == 40 ) { - $nodeflg = "sky"; - } elsif ( $npn == 48 ) { - $nodeflg = "cas"; - } elsif ( $npn == 28 ) { - $nodeflg = "hasw"; - } open(SCRIPT,">$fvhome/asens/$joba.j") or die ">>> ERROR <<< cannot write $fvhome/asens/$joba.j"; diff --git a/src/Applications/GEOSdas_App/Create_fsens_script.pm b/src/Applications/GEOSdas_App/Create_fsens_script.pm index 5b0e4b2a..cd2d4aab 100644 --- a/src/Applications/GEOSdas_App/Create_fsens_script.pm +++ b/src/Applications/GEOSdas_App/Create_fsens_script.pm @@ -41,8 +41,8 @@ sub fsens_script { my $export_none = $inputparams{"export_none"}; my $jobqueue1 = $inputparams{"jobqueue1"}; my $mem = $inputparams{"mem"}; - my $nodes = $inputparams{"nodes"}; my $ncpus_gsi = $inputparams{"ncpus_gsi"}; + my $nodeflg = $inputparams{"nodeflg"}; my $fcswallclk = $inputparams{"fcswallclk"}; my $nametag = $inputparams{"nametag"}; my $gid = $inputparams{"gid"}; @@ -54,15 +54,6 @@ sub fsens_script { my( $siteID, $nodeflg ); $siteID = get_siteID(); - $nodeflg = "hasw"; - my $npn = `facter processorcount`; chomp($npn); - if ( $npn == 40 ) { - $nodeflg = "sky"; - } elsif ( $npn == 48 ) { - $nodeflg = "cas"; - } elsif ( $npn == 28 ) { - $nodeflg = "hasw"; - } open(SCRIPT,">$fvhome/run/$jobfs.j") or die ">>> ERROR <<< cannot write $fvhome/run/$jobfs.j"; diff --git a/src/Applications/GEOSdas_App/GEOSdas.csm b/src/Applications/GEOSdas_App/GEOSdas.csm index a908d734..c9f48a31 100755 --- a/src/Applications/GEOSdas_App/GEOSdas.csm +++ b/src/Applications/GEOSdas_App/GEOSdas.csm @@ -4523,12 +4523,12 @@ endif # Which CAP to use? # ----------------- - set hh = `echo $gcm_nhms0 | cut -c1-2` set fcst_beg = ( `rst_date d_rst` ) set nymdt = $fcst_beg[1] set nhmst = $fcst_beg[2] set hhmnt = `echo $nhmst | cut -c1-4` + set hh = `echo $hhmnt | cut -c1-2` set nd_nh = ( `grep -i JOB_SGMT $mycap|awk '{printf "%d %d",$2, $3}'` ) set nsecs = `(expr $nd_nh[1] \* 86400 \+ $nd_nh[2] \/ 10000 \* 3600)` set fcst_end = ( `tick $fcst_beg $nsecs` ) diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index 9eca6011..add4f858 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -643,9 +643,9 @@ sub set_inputparams { "nametag" => $nametag, "ncpus" => $ncpus, "ncpus_gsi" => $ncpus_gsi, + "nodeflg" => $nodeflg, "ncsuffix" => $ncsuffix, "newradbc" => $newradbc, - "nodes" => $nodes, "nvarouter" => $nvarouter, "obClass" => $obClass, "oiqc" => $oiqc, @@ -7421,7 +7421,7 @@ if ((\$arch_type == "ADAS") && (\$\?yyyymm) && (\$\?dd)) then if (\$MONTHLY_PLOTS) set flags = "\$flags -plots" if (\$MONTHLY_RADMON) set flags = "\$flags -radmon \$MONTHLY_RADMON" - if (\$flags != "") \$monthlyPost \$flags + if ("\$flags" != "") \$monthlyPost \$flags endif endif endif diff --git a/src/Applications/GEOSdas_App/testsuites/x0046a.input b/src/Applications/GEOSdas_App/testsuites/x0046a.input index 1a227b31..75e6fd94 100644 --- a/src/Applications/GEOSdas_App/testsuites/x0046a.input +++ b/src/Applications/GEOSdas_App/testsuites/x0046a.input @@ -38,7 +38,7 @@ Catchment Model choice? [1] > FVHOME? [/discover/nobackup/dao_it/x0046a] -> /discover/nobackup/projects/gmao/dadev/dao_it/$expid +> /discover/nobackup/projects/gmao/dadev/dao_it/Winter_Runs/$expid The directory /discover/nobackup/projects/gmao/obsdev/dao_it/x0046a already exists. Clean it? [y] > diff --git a/src/Applications/GEOSdas_App/testsuites/x0046a_Summer.input b/src/Applications/GEOSdas_App/testsuites/x0046a_Summer.input new file mode 100644 index 00000000..9d92f245 --- /dev/null +++ b/src/Applications/GEOSdas_App/testsuites/x0046a_Summer.input @@ -0,0 +1,248 @@ +#------------ +# x0046a.input +#------------ + +description: x0046a__GEOSadas-5_29_3__agrid_C360__ogrid_C +tag: GEOSadas-5_29_3 + +---ENDHEADERS--- + +Remote account for Intranet plots? [dao_it@train] +> + +Is this a MERRA2 (1), GEOSIT (2), R21C (3) experiment? [0] +> + +AGCM Horizontal Resolution? [C48] +> C360 + +AGCM Vertical Resolution? [72] +> + +OGCM Resolution? [f] +> C + +EXPID? [u000_C360] +> $expid + +Check for previous use of expid (y/n)? [y] +> n + +EXPDSC? [x0046a__GEOSadas-5_29_3__agrid_C360__ogrid_C] +> + +Land Boundary Conditions? [Icarus_Updated] +> Icarus-NLv3 + +Catchment Model choice? [1] +> + +FVHOME? [/discover/nobackup/dao_it/x0046a] +> /discover/nobackup/projects/gmao/dadev/dao_it/Summer_Runs/$expid + +The directory /discover/nobackup/projects/gmao/obsdev/dao_it/x0046a already exists. Clean it? [y] +> + +Processing nodes (1:Westmere, 2:SandyBridge, 3:Ivy Bridge, 4:Haswell, 5:Skylake, 6:Cascase)? [4] +> 5 + +Which case of variational analysis? [1] +> + +Window of the variational analysis (min)? [360] +> + +FVINPUT? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar] +> + +REAL TIME BCS? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/g5gcm/bcs/realtime/OSTIA_REYNOLDS] +> + +agcmpert? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/agcmpert] +> + +g5chem? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/g5chem] +> + +g5gcm? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/g5gcm] +> + +PIESA? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/PIESA] +> + +MERRA2? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/MERRA2] +> + +AeroCom? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/AeroCom] +> + +FVICS? [/archive/u/jstassi/restarts/GEOSadas-5_24_0] +> /discover/nobackup/projects/gmao/dadev/rtodling/archive/Restarts/x0046a/rs/Y2019/M06/x0046a.rst.20190621_21z.tar + +Run model-adjoint-related applications (0=no,1=yes)? [0] +> 1 + +Analysis/Forecast filename template for sensitivity? +> + +Stage the gradient vector files (y/n)? [y] +> + +Run singular vector experiments (0=n,1=yes)? [0] +> + +Run analysis-sensitivity applications (0=no,1=yes)? [0] +> 1 + +Verifying experiment id: [x0046a] +> + +Ending year-month-day? [20191121] +> 20191006 + +Length of FORECAST run segments (in hours)? [123] +> + +Number of one-day DAS segments per PBS job? [1] +> + +Number of PEs in the zonal direction (NX)? [8] +> 12 + +Number of PEs in the meridional direction (NY)? [48] +> 72 + +Job nickname? [g5das] +> x46 + +Run in split executable mode (1=yes;0=no)? [1] +> + +Frequency of background fields (min)? [180] +> 60 + +Triangular spectral truncation? [254] +> + +Analysis vertical levels (sig))? [72] +> + +GSI grid resolution? [NA] +> + +GEOS grid resolution instead? [d] +> + +Ensemble Hybrid (<0;3=3dHyb;4=Hyb4d)? [-1] +> 4 + +Number of procs in the zonal direction (NX)? [12] +> 16 + +Number of procs in the meridional direction (NY)? [20] +> 42 + +Which main class of ObsSys (1: NRT; 2: MERRA; 3: MERRA-2)? [1] +> + +OBSERVING SYSTEM CLASSES? +> disc_airs_bufr,disc_amsua_bufr,gmao_amsr2_bufr,gmao_gmi_bufr,mls_nrt_nc,ncep_1bamua_bufr,ncep_1bhrs4_bufr,ncep_acftpfl_bufr,ncep_atms_bufr,ncep_aura_omi_bufr,ncep_avcsam_bufr,ncep_avcspm_bufr,ncep_crisfsr_bufr,ncep_goesfv_bufr,ncep_gpsro_com_bufr,ncep_mhs_bufr,ncep_mtiasi_bufr,ncep_prep_bufr,ncep_satwnd_bufr,ncep_sevcsr_bufr,ncep_ssmis_bufr,ncep_tcvitals,npp_ompsnm_bufr,gmao_mlst_bufr + +CHECKING OBSYSTEM? [2] +> 1 + +Which RADCOR option? [NONE] +> + +Use sat channel-correlated observation errors (y/n)? [y] +> + +Use aircraft bias correction (y/n)? [y] +> + +Use unified radiance bias correction (y/n)? [y] +> + +Land DAS Analysis (y/n)? [n] +> + +Frequency (in days) for writing restarts? [0] +> + +Frequency for PROGNOSTIC fields? [010000] +> + +Frequency for surface (2D) DIAGNOSTIC fields? [010000] +> + +Frequency for upper air (3D) DIAGNOSTIC fields? [030000] +> + +Dimension of output in zonal direction? [1152] +> + +Dimension of output in meridional direction? [721] +> + +Would you like 2D diagnostics? [y] +> + +Would you like 3D diagnostics? [y] +> + +Would you like to compress diagnostics output files? [n] +> + +Include GOCART tracers (CO,CO2,aerosols,etc) (y/n)? [y] +> + +Select GOCART Emission Files to use: [OPS] +> + +Do Aerosol Analysis (y/n)? [y] +> + +AOD OBSERVING CLASSES [or type 'none']? +> + +Enable GAAS feedback to model (y/n)? [y] +> + +Which template? [HISTORY.rc.tmpl] +> + +Which template? [GCMPROG.rc.tmpl] +> + +Output Restart TYPE (bin or nc4) [nc4] +> + +Select group: [s0818] +> g0613 + +Replayed Ensemble (from OPS)? [yes] +> no + +Use SPPT-scheme for Ensemble? [yes] +> + +Ensemble Resolution? [C90] +> + +Ensemble Vertical Levels? [72] +> + +Experiment archive directory for ensemble restarts or 'later': [/archive/u/rtodling/x0046a] +> /discover/nobackup/projects/gmao/dadev/dao_it/archive/x0043 + +Edit COLLECTIONS list in run/HISTORY.rc.tmpl (y/n)? [n] +> + +Edit COLLECTIONS list in fcst/HISTORY.rc.tmpl (y/n)? [n] +> + +Edit files in run directory for CERES configuration (y/n)? [n] +> + +Which? [Q] +> diff --git a/src/Applications/NCEP_Etc/NCEP_bkgecov/ut_gen_berrcov.j b/src/Applications/NCEP_Etc/NCEP_bkgecov/ut_gen_berrcov.j index 91c6a81a..f227fd0e 100755 --- a/src/Applications/NCEP_Etc/NCEP_bkgecov/ut_gen_berrcov.j +++ b/src/Applications/NCEP_Etc/NCEP_bkgecov/ut_gen_berrcov.j @@ -60,8 +60,8 @@ setenv GEN_NMCDIFFS 0 setenv GET_BERROR 1 setenv BERROR_NMODES 25 -#set these_lats = ( 25 46 91 ) -set these_lats = ( 721 ) +set these_lats = ( 25 46 91 181 361 721 ) +#set these_lats = ( 721 ) # Basic settings (weak dependency on version of DAS) # -------------------------------------------------- @@ -334,6 +334,11 @@ if ( $GET_BERROR ) then setenv NLON 1152 setenv HFAC 0.6 endif +# Hack: use same JCAP for all resolution as done in previous version of BERROR generation +# Hack: also redefine NMODES as used in previous version +# see: fvInput/gsi/etc/berror_gmao/gmao24Jun2016_fp+oz_fix/README + setenv JCAP 268 + setenv BERROR_NMODES 20 if ( ! -d $FCSTWRK/BERROR.WORK ) mkdir -p $FCSTWRK/BERROR.WORK diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/nmcperts.rc b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/nmcperts.rc index 3287e660..fca16ca7 100644 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/nmcperts.rc +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/nmcperts.rc @@ -1,12 +1,19 @@ -nmc_perts_date_beg: 2011040300 -nmc_perts_date_end: 2012051800 - nmc_perts_date_window: 45 nmc_perts_spool: null -#nmc_perts_location: dirac:/archive/u/aelakkra/dx573/Fcst48m24 +nmc_perts_date_beg: 2011040300 +nmc_perts_date_end: 2012051800 nmc_perts_location: ExtData/enAdas/perts/dyn/572 nmc_perts_fnametmpl: e572_fp.f48m24.eta.%y4%m2%d2_%h2z.nc4 +#nmc_perts_date_beg: 2018110100 +#nmc_perts_date_end: 2019081700 +#nmc_perts_location: ExtData/enAdas/perts/dyn/f522 +#nmc_perts_fnametmpl: f522_fp.f48m24.eta.%y4%m2%d2_%h2z.nc4 + +#nmc_perts_date_beg: 2020100100 +#nmc_perts_date_end: 2021111600 +#nmc_perts_location: ExtData/enAdas/perts/dyn/f5271 +#nmc_perts_fnametmpl: f5271_fp.f48m24.eta.%y4%m2%d2_%h200z.nc4 From aa4d7c12fcba26d01787576c4a3bc14997f95031 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 13 Dec 2021 13:16:52 -0500 Subject: [PATCH 137/205] Fix uncovered CMake path --- src/Applications/GEOSdas_App/testsuites/CMakeLists.txt | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Applications/GEOSdas_App/testsuites/CMakeLists.txt b/src/Applications/GEOSdas_App/testsuites/CMakeLists.txt index 7cbe79d1..c25f4c2c 100644 --- a/src/Applications/GEOSdas_App/testsuites/CMakeLists.txt +++ b/src/Applications/GEOSdas_App/testsuites/CMakeLists.txt @@ -33,6 +33,8 @@ if(GIT_FOUND) else () message(FATAL_ERROR "This should not be reached") endif () + else () + set (GIT_TAG_OR_REV GEOSadas-${CMAKE_PROJECT_VERSION}) endif () endif() From 5fa556663900dc32151819bd5bc4769ee2402578 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Mon, 13 Dec 2021 13:25:09 -0500 Subject: [PATCH 138/205] consistent w/ Joe Ss changes --- src/Applications/GEOSdas_App/testsuites/x0046a_Summer.input | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Applications/GEOSdas_App/testsuites/x0046a_Summer.input b/src/Applications/GEOSdas_App/testsuites/x0046a_Summer.input index 9d92f245..6cfeacd2 100644 --- a/src/Applications/GEOSdas_App/testsuites/x0046a_Summer.input +++ b/src/Applications/GEOSdas_App/testsuites/x0046a_Summer.input @@ -2,8 +2,9 @@ # x0046a.input #------------ +codeID: b3a880f description: x0046a__GEOSadas-5_29_3__agrid_C360__ogrid_C -tag: GEOSadas-5_29_3 +fvsetupID: f7d8d041c9 ---ENDHEADERS--- From e1e97202d479051ec1a85648eceac94d2ffa2fcb Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Mon, 13 Dec 2021 13:54:32 -0500 Subject: [PATCH 139/205] change default --- src/Applications/GEOSdas_App/GEOSdas.csm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Applications/GEOSdas_App/GEOSdas.csm b/src/Applications/GEOSdas_App/GEOSdas.csm index 84fab22c..5246ab9a 100755 --- a/src/Applications/GEOSdas_App/GEOSdas.csm +++ b/src/Applications/GEOSdas_App/GEOSdas.csm @@ -116,7 +116,7 @@ if ( !($?BOOTSTRAP) ) setenv BOOTSTRAP 0 if ( !($?CENTRAL_AGCM_PARALLEL) ) setenv CENTRAL_AGCM_PARALLEL 0 if ( !($?CHECK_DMF) ) setenv CHECK_DMF 1 - if ( !($?CLEANUP_TAIL) ) setenv CLEANUP_TAIL 0 + if ( !($?CLEANUP_TAIL) ) setenv CLEANUP_TAIL 1 if ( !($?CONVPROG) ) setenv CONVPROG 0 if ( !($?CONVSFC) ) setenv CONVSFC 0 if ( !($?CONVUPA) ) setenv CONVUPA 0 From ed7058e7fb0b883c70481b32f1c1a914a7c50715 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 13 Dec 2021 14:13:18 -0500 Subject: [PATCH 140/205] ADAS Gatekeepers should be notified of all changes --- .github/CODEOWNERS | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index a508429a..5ff52b81 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -8,11 +8,11 @@ # The GCM gatekeepers and CMake should know/approve these /.github/ @GEOS-ESM/cmake-team @GEOS-ESM/adas-gatekeepers -/.circleci/ @GEOS-ESM/cmake-team @GEOS-ESM/adas-gatekeepers -/.codebuild/ @GEOS-ESM/cmake-team @GEOS-ESM/adas-gatekeepers +/.circleci/ @GEOS-ESM/cmake-team @GEOS-ESM/adas-gatekeepers +/.codebuild/ @GEOS-ESM/cmake-team @GEOS-ESM/adas-gatekeepers -# The GEOS CMake Team is the CODEOWNER for the CMakeLists.txt files in this repository -CMakeLists.txt @GEOS-ESM/cmake-team +# The GEOS CMake Team should be notified for changes to CMakeLists.txt files in this repository +CMakeLists.txt @GEOS-ESM/cmake-team @GEOS-ESM/adas-gatekeepers # The GEOS CMake Team should be notified about and approve config changes -/config/ @GEOS-ESM/cmake-team +/config/ @GEOS-ESM/cmake-team @GEOS-ESM/adas-gatekeepers From fc48bcfcb0b4dc9ba780c529aa6df4657521cddd Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 13 Dec 2021 14:15:16 -0500 Subject: [PATCH 141/205] Update CODEOWNERS --- .github/CODEOWNERS | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index 5ff52b81..24426826 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -6,7 +6,7 @@ # GEOS ADAS Gatekeepers own all the files * @GEOS-ESM/adas-gatekeepers -# The GCM gatekeepers and CMake should know/approve these +# The ADAS gatekeepers and CMake should know/approve these /.github/ @GEOS-ESM/cmake-team @GEOS-ESM/adas-gatekeepers /.circleci/ @GEOS-ESM/cmake-team @GEOS-ESM/adas-gatekeepers /.codebuild/ @GEOS-ESM/cmake-team @GEOS-ESM/adas-gatekeepers From d4aa88146b88d81b23541fc17d3e09deb58f5722 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Mon, 13 Dec 2021 15:13:42 -0500 Subject: [PATCH 142/205] fix in gsi CMakefile - from Matt --- components.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/components.yaml b/components.yaml index 486ede3c..0b98243a 100644 --- a/components.yaml +++ b/components.yaml @@ -46,7 +46,7 @@ FMS: GEOSana_GridComp: local: ./src/Components/@GEOSana_GridComp remote: ../GEOSana_GridComp.git - tag: v1.5.1 + tag: v1.5.2 develop: develop GEOSgcm_GridComp: From 037d49dfea45f24cf33d0c682b4e4e2f5c7406b4 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Tue, 14 Dec 2021 07:24:37 -0500 Subject: [PATCH 143/205] minor fix; var now an arg, not local --- src/Applications/GEOSdas_App/Create_anasa_script.pm | 2 +- src/Applications/GEOSdas_App/Create_asens_script.pm | 2 +- src/Applications/GEOSdas_App/Create_fsens_script.pm | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Applications/GEOSdas_App/Create_anasa_script.pm b/src/Applications/GEOSdas_App/Create_anasa_script.pm index d66d3975..bf228ccd 100644 --- a/src/Applications/GEOSdas_App/Create_anasa_script.pm +++ b/src/Applications/GEOSdas_App/Create_anasa_script.pm @@ -70,7 +70,7 @@ sub anasa_script { my $qsub = $inputparams{"qsub"}; # local variables - my( $os, $siteID, $nodeflg ); + my( $os, $siteID ); $siteID = get_siteID(); diff --git a/src/Applications/GEOSdas_App/Create_asens_script.pm b/src/Applications/GEOSdas_App/Create_asens_script.pm index eb1f44b5..35312417 100644 --- a/src/Applications/GEOSdas_App/Create_asens_script.pm +++ b/src/Applications/GEOSdas_App/Create_asens_script.pm @@ -73,7 +73,7 @@ sub asens_script { my $qsub = $inputparams{"qsub"}; # local variables - my( $os, $siteID, $nodeflg ); + my( $os, $siteID ); $siteID = get_siteID(); diff --git a/src/Applications/GEOSdas_App/Create_fsens_script.pm b/src/Applications/GEOSdas_App/Create_fsens_script.pm index cd2d4aab..9b93e381 100644 --- a/src/Applications/GEOSdas_App/Create_fsens_script.pm +++ b/src/Applications/GEOSdas_App/Create_fsens_script.pm @@ -51,7 +51,7 @@ sub fsens_script { my $qsub = $inputparams{"qsub"}; # local variables - my( $siteID, $nodeflg ); + my( $siteID ); $siteID = get_siteID(); From 7a3cb2c60f988f82f45c09b56e384e45d32959df Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Tue, 14 Dec 2021 15:14:58 -0500 Subject: [PATCH 144/205] minor --- src/Applications/GEOSdas_App/fvsetup | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index 36895730..e5967f08 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -3774,8 +3774,8 @@ sub get_obsys { } else { $dflt = 1; } - $ans = query("Which main class of ObsSys (1: NRT; 2: MERRA; 3: MERRA-2)?", $dflt); - return 1 unless $ans == 1 or $ans == 2 or $ans == 3; + $ans = query("Which main class of ObsSys (1: NRT; 2: MERRA; 3: MERRA-2; 4: GEOS-IT; 5: R21C)?", $dflt); + return 1 unless $ans == 1 or $ans == 2 or $ans == 3 or $ans == 4 or $ans == 5; if ($GFLAG == 1) { $loc = "nccs" } else { $loc = "nas" } @@ -3796,6 +3796,12 @@ sub get_obsys { elsif ($ans == 3) { # MERRA-2 $obsysrc = "$fvetc/obsys-${loc}-merra2.rc"; $rflags .= " -stem merra2"; + elsif ($ans == 4) { # GEOS-IT + $obsysrc = "$fvetc/obsys-${loc}-geosit.rc"; +# $rflags .= " -stem geosit"; + elsif ($ans == 5) { # R21C + $obsysrc = "$fvetc/obsys-${loc}-r21c.rc"; +# $rflags .= " -stem r21c"; } $reqobs = $fvbin . "/require_obsys.pl"; From acef19ae9f900390f9ef620c51941836c194da5b Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz <53273921+gmao-msienkie@users.noreply.github.com> Date: Tue, 14 Dec 2021 16:38:11 -0500 Subject: [PATCH 145/205] Update gmao_prepqc Add additional flag to parm file - set to not recalculate specific humidity --- src/Applications/NCEP_Paqc/oiqc/gmao_prepqc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Applications/NCEP_Paqc/oiqc/gmao_prepqc b/src/Applications/NCEP_Paqc/oiqc/gmao_prepqc index ab79a059..16917dd3 100755 --- a/src/Applications/NCEP_Paqc/oiqc/gmao_prepqc +++ b/src/Applications/NCEP_Paqc/oiqc/gmao_prepqc @@ -313,7 +313,7 @@ sub gmaoprevents { print PRVPARM " &PREVDATA DOVTMP= TRUE, DOFCST= TRUE DOBERR= TRUE / \n"; } else { # already has virtual temperature print "$0: PREVENTS without VIRTMP\n"; - print PRVPARM " &PREVDATA DOVTMP= FALSE ,DOFCST= TRUE DOBERR= TRUE / \n"; + print PRVPARM " &PREVDATA DOVTMP= FALSE, RECALC_Q= FALSE, DOFCST= TRUE DOBERR= TRUE / \n"; } close(PRVPARM); From 86e4dfcf918621a0b39d4c49b211b4676f43b610 Mon Sep 17 00:00:00 2001 From: saraqzhang Date: Wed, 15 Dec 2021 22:00:04 -0500 Subject: [PATCH 146/205] (1) add ldas anal increments to fcst script (2) fix syntax errors in fvsetup modified: src/Applications/GEOSdas_App/fvsetup --- src/Applications/GEOSdas_App/fvsetup | 25 +++++++++++++++++++++++-- 1 file changed, 23 insertions(+), 2 deletions(-) diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index e5967f08..8bd1fa5d 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -3796,9 +3796,11 @@ sub get_obsys { elsif ($ans == 3) { # MERRA-2 $obsysrc = "$fvetc/obsys-${loc}-merra2.rc"; $rflags .= " -stem merra2"; + } elsif ($ans == 4) { # GEOS-IT $obsysrc = "$fvetc/obsys-${loc}-geosit.rc"; -# $rflags .= " -stem geosit"; +# $rflags .= " -stem geosit"; + } elsif ($ans == 5) { # R21C $obsysrc = "$fvetc/obsys-${loc}-r21c.rc"; # $rflags .= " -stem r21c"; @@ -8864,6 +8866,7 @@ print SCRIPT <<"EOF"; setenv DAOTOVS 0 # 1 = enables DAOTOVS, 0 = disables DAOTOVS setenv TIMEINC $varwindow setenv GAASFDBK $gaasfdbk + setenv LDASFDBK $ldasfdbk setenv SSMI_UV 0 # 1 = enables SSMI WIND SPEED, 0 = disables it setenv SPLITEXE 0 # 1 = enables SPLIT EXECUTABLE run, 0 = disables it (N/A) setenv VTRACK 0 # 0 = disable vortex tracker; 1 = enable @@ -9364,7 +9367,25 @@ print SCRIPT <<"EOF"; /bin/rm -r \$FVWORK exit 1 endif - endif + endif + +# obtain ldas incr for the first 6h integration +#---------------------------------------------- + if ( \$LDASFDBK == 1 ) then + /bin/cp \$EXPID.rst.lcv.\${nymd}_\${hh}z.bin ldasd_rst + set adas_strt = ( `rst_date ./ldasd_rst` ) + @ ldastick1 = 5400 + @ ldastick2 = 16200 + set linctt1 = ( `tick \$adas_strt \$ldastick1` ) + set linctt2 = ( `tick \$adas_strt \$ldastick2` ) + set yyyymmdd1 = `echo \$linctt1[1] | cut -c1-8` + set yyyymmdd2 = `echo \$linctt2[1] | cut -c1-8` + set hhnn1 = `echo \$linctt1[2] | cut -c1-4` + set hhnn2 = `echo \$linctt2[2] | cut -c1-4` + /bin/cp \$FVHOME/lana/ldas_inc.\${yyyymmdd1}_\${hhnn1}00 \$FVWORK/. + /bin/cp \$FVHOME/lana/ldas_inc.\${yyyymmdd2}_\${hhnn2}00 \$FVWORK/. + rm ldasd_rst + endif # Stage the initial condition # --------------------------- From 7ba110fc5104f6fb93cc6beca6b2a0a80defb9e8 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Fri, 17 Dec 2021 08:51:24 -0500 Subject: [PATCH 147/205] all in support of GEOS-IT; update to Henry-s Law will cause non-zero diff to x0046a-like settings --- components.yaml | 2 +- src/Applications/GEOSdas_App/fvsetup | 42 ++++++++++++--- .../GEOSdas_App/testsuites/C180RPY.input | 3 ++ .../GEOSdas_App/testsuites/C180T14RPY.input | 3 ++ .../testsuites/C360L181_replay.input | 3 ++ .../testsuites/C360L91_replay.input | 3 ++ .../GEOSdas_App/testsuites/C48f.input | 3 ++ .../GEOSdas_App/testsuites/C90C.input | 3 ++ .../GEOSdas_App/testsuites/C90C_ens.input | 3 ++ .../GEOSdas_App/testsuites/C90C_replay.input | 3 ++ .../GEOSdas_App/testsuites/fpp.input | 3 ++ .../GEOSdas_App/testsuites/geos_it.input | 7 ++- .../GEOSdas_App/testsuites/prePP.input | 3 ++ .../GEOSdas_App/testsuites/x0046a.input | 3 ++ .../GEOSdas_App/testsuites/x0046aRPY.input | 3 ++ .../testsuites/x0046a_Summer.input | 3 ++ .../GEOSdas_App/write_FVDAS_Run_Config.pl | 4 +- .../NCEP_enkf/scripts/gmao/setup_atmens.pl | 51 +++++++++++++++++++ 18 files changed, 135 insertions(+), 10 deletions(-) diff --git a/components.yaml b/components.yaml index 0b98243a..663dba34 100644 --- a/components.yaml +++ b/components.yaml @@ -83,7 +83,7 @@ fvdycore: GEOSchem_GridComp: local: ./src/Components/@GEOSgcm_GridComp/GEOSagcm_GridComp/GEOSphysics_GridComp/@GEOSchem_GridComp remote: ../GEOSchem_GridComp.git - tag: rt1.6.1 + tag: rt1.6.2 develop: develop HEMCO: diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index e5967f08..27630ba8 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -2245,6 +2245,11 @@ sub ed_g5fvlay_rc { if($rcd =~ /\@FV_SATADJ/) {$rcd=~ s/\@FV_SATADJ/do_sat_adj = .F./g; } if($rcd =~ /\@FV_ZTRACER/){$rcd=~ s/\@FV_ZTRACER/z_tracer = .T./g; } if($rcd =~ /\@FV_NWAT/) {$rcd=~ s/\@FV_NWAT/ /g; } + if ( "$res" eq "C720" ) { + if($rcd =~ /\@FV_N_SPLIT/) {$rcd=~ s/\@FV_N_SPLIT/n_split = 12/g; } + } else { + if($rcd =~ /\@FV_N_SPLIT/) {$rcd=~ s/\@FV_N_SPLIT/ /g; } + } print(LUN2 "$rcd\n"); } @@ -2775,7 +2780,7 @@ EOF #======================================================================= sub get_extdata { - @extdatasets = qw ( agcmpert g5chem g5gcm PIESA MERRA2 AeroCom ); + @extdatasets = qw ( agcmpert chemistry g5chem g5gcm PIESA MERRA2 AeroCom ); foreach $set ( @extdatasets ) { $extdata{$set} = "$fvbcs/$set" }; print "\n-------------\n" @@ -3769,11 +3774,11 @@ sub get_obsys { print("OBSERVING SYSTEM CLASSES\n"); print("------------------------\n"); - if ( $merra2 ) { - $dflt = 3; - } else { - $dflt = 1; - } + $dflt = 1; + if ( $merra2 ) { $dflt = 3; } + if ( $geosit ) { $dflt = 4; } + if ( $r21c ) { $dflt = 5; } + $ans = query("Which main class of ObsSys (1: NRT; 2: MERRA; 3: MERRA-2; 4: GEOS-IT; 5: R21C)?", $dflt); return 1 unless $ans == 1 or $ans == 2 or $ans == 3 or $ans == 4 or $ans == 5; @@ -3796,9 +3801,11 @@ sub get_obsys { elsif ($ans == 3) { # MERRA-2 $obsysrc = "$fvetc/obsys-${loc}-merra2.rc"; $rflags .= " -stem merra2"; + } elsif ($ans == 4) { # GEOS-IT $obsysrc = "$fvetc/obsys-${loc}-geosit.rc"; # $rflags .= " -stem geosit"; + } elsif ($ans == 5) { # R21C $obsysrc = "$fvetc/obsys-${loc}-r21c.rc"; # $rflags .= " -stem r21c"; @@ -4254,10 +4261,12 @@ EOF $emission{"3"} = "NR"; $emission{"4"} = "OPS"; $emission{"5"} = "PIESA"; + $emission{"6"} = "GEOSIT"; %remission = reverse %emission; if ($nrt) { $dflt = "OPS" } elsif ($merra2) { $dflt = "MERRA2" } + elsif ($geosit) { $dflt = "GEOSIT" } else { $dflt = "PIESA" } if ($gocart_tracers) { @@ -8674,6 +8683,9 @@ sub write_FVDAS_Run_Config { $ENV{"VTXLEVS"} = $vtxlevs; $ENV{"VTXRELOC"} = $vtxreloc; + if ($geosit | $r21c) { + $ENV{"MKSI_SIDB"} = "\$FVHOME/run/gmao_satinfo.db"; + } unless ( $ENV{"ARCHIVE"} ) { $ENV{"ARCHIVE"} = "lou:." if $siteName eq "cfe"; @@ -10132,6 +10144,15 @@ sub copy_resources { cp("$fn", "$fvhome/run"); } } + mkdir ("$fvhome/run/gmao_satinfo.db"); + if ( -d "$fvetc/gmao_satinfo.db/GEOSIT" ) { + my @files = glob("$fvetc/gmao_satinfo.db/GEOSIT" . "/*"); + foreach my $fn ( @files ) { + cp("$fn", "$fvhome/run/gmao_satinfo.db"); + } + } else { + die "Cannot find GEOSIT sat.db under $fvetc, aborting ..."; + } } if ( $r21c ) { if ( -d "$fvetc/gsi/R21C" ) { @@ -10140,6 +10161,15 @@ sub copy_resources { cp("$fn", "$fvhome/run"); } } + mkdir ("$fvhome/run/gmao_satinfo.db"); + if ( -d "$fvetc/gmao_satinfo.db/R21C" ) { + my @files = glob("$fvetc/gmao_satinfo.db/R21C" . "/*"); + foreach my $fn ( @files ) { + cp("$fn", "$fvhome/run/gmao_satinfo.db"); + } + } else { + die "Cannot find R21C sat.db under $fvetc, aborting ..."; + } } } diff --git a/src/Applications/GEOSdas_App/testsuites/C180RPY.input b/src/Applications/GEOSdas_App/testsuites/C180RPY.input index 42b8db59..34f8f108 100644 --- a/src/Applications/GEOSdas_App/testsuites/C180RPY.input +++ b/src/Applications/GEOSdas_App/testsuites/C180RPY.input @@ -62,6 +62,9 @@ REAL TIME BCS? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/g5 agcmpert? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/agcmpert] > +chemistry? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/chemistry] +> + g5chem? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/g5chem] > diff --git a/src/Applications/GEOSdas_App/testsuites/C180T14RPY.input b/src/Applications/GEOSdas_App/testsuites/C180T14RPY.input index aa49b8d3..725a4117 100644 --- a/src/Applications/GEOSdas_App/testsuites/C180T14RPY.input +++ b/src/Applications/GEOSdas_App/testsuites/C180T14RPY.input @@ -62,6 +62,9 @@ REAL TIME BCS? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/g5 agcmpert? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/agcmpert] > +chemistry? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/chemistry] +> + g5chem? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/g5chem] > diff --git a/src/Applications/GEOSdas_App/testsuites/C360L181_replay.input b/src/Applications/GEOSdas_App/testsuites/C360L181_replay.input index 2b4fb443..8fb60c32 100644 --- a/src/Applications/GEOSdas_App/testsuites/C360L181_replay.input +++ b/src/Applications/GEOSdas_App/testsuites/C360L181_replay.input @@ -62,6 +62,9 @@ REAL TIME BCS? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/g5 agcmpert? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/agcmpert] > +chemistry? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/chemistry] +> + g5chem? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/g5chem] > diff --git a/src/Applications/GEOSdas_App/testsuites/C360L91_replay.input b/src/Applications/GEOSdas_App/testsuites/C360L91_replay.input index 4761a88e..8171c146 100644 --- a/src/Applications/GEOSdas_App/testsuites/C360L91_replay.input +++ b/src/Applications/GEOSdas_App/testsuites/C360L91_replay.input @@ -62,6 +62,9 @@ REAL TIME BCS? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/g5 agcmpert? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/agcmpert] > +chemistry? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/chemistry] +> + g5chem? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/g5chem] > diff --git a/src/Applications/GEOSdas_App/testsuites/C48f.input b/src/Applications/GEOSdas_App/testsuites/C48f.input index ceca39af..2fec9da4 100644 --- a/src/Applications/GEOSdas_App/testsuites/C48f.input +++ b/src/Applications/GEOSdas_App/testsuites/C48f.input @@ -60,6 +60,9 @@ REAL TIME BCS? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/g5 agcmpert? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/agcmpert] > +chemistry? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/chemistry] +> + g5chem? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/g5chem] > diff --git a/src/Applications/GEOSdas_App/testsuites/C90C.input b/src/Applications/GEOSdas_App/testsuites/C90C.input index 32b7e293..6dfc95ad 100644 --- a/src/Applications/GEOSdas_App/testsuites/C90C.input +++ b/src/Applications/GEOSdas_App/testsuites/C90C.input @@ -58,6 +58,9 @@ REAL TIME BCS? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/g5 agcmpert? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/agcmpert] > +chemistry? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/chemistry] +> + g5chem? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/g5chem] > diff --git a/src/Applications/GEOSdas_App/testsuites/C90C_ens.input b/src/Applications/GEOSdas_App/testsuites/C90C_ens.input index 9031a002..0d1195e0 100644 --- a/src/Applications/GEOSdas_App/testsuites/C90C_ens.input +++ b/src/Applications/GEOSdas_App/testsuites/C90C_ens.input @@ -62,6 +62,9 @@ REAL TIME BCS? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/g5 agcmpert? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/agcmpert] > +chemistry? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/chemistry] +> + g5chem? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/g5chem] > diff --git a/src/Applications/GEOSdas_App/testsuites/C90C_replay.input b/src/Applications/GEOSdas_App/testsuites/C90C_replay.input index 03774975..b06f63fb 100644 --- a/src/Applications/GEOSdas_App/testsuites/C90C_replay.input +++ b/src/Applications/GEOSdas_App/testsuites/C90C_replay.input @@ -62,6 +62,9 @@ REAL TIME BCS? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/g5 agcmpert? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/agcmpert] > +chemistry? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/chemistry] +> + g5chem? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/g5chem] > diff --git a/src/Applications/GEOSdas_App/testsuites/fpp.input b/src/Applications/GEOSdas_App/testsuites/fpp.input index 4cb36102..574527d3 100644 --- a/src/Applications/GEOSdas_App/testsuites/fpp.input +++ b/src/Applications/GEOSdas_App/testsuites/fpp.input @@ -62,6 +62,9 @@ REAL TIME BCS? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/g5 agcmpert? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/agcmpert] > +chemistry? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/chemistry] +> + g5chem? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/g5chem] > diff --git a/src/Applications/GEOSdas_App/testsuites/geos_it.input b/src/Applications/GEOSdas_App/testsuites/geos_it.input index 70e5fe24..4786c300 100644 --- a/src/Applications/GEOSdas_App/testsuites/geos_it.input +++ b/src/Applications/GEOSdas_App/testsuites/geos_it.input @@ -62,6 +62,9 @@ REAL TIME BCS? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/g5 agcmpert? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/agcmpert] > +chemistry? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/chemistry] +> + g5chem? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/g5chem] > @@ -78,7 +81,7 @@ AeroCom? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/AeroCom] > FVICS? [/archive/u/jstassi/restarts/GEOSadas-5_24_0] -> /discover/nobackup/projects/gmao/dadev/rtodling/archive/Restarts/5_29/geosit_test/Y2020/M01/geosit_test.rst.20200125_21z.tar +> /home/dao_ops/d5271_it_sample/run/.../archive/rs/Y2019/M06/d5271_it_sample.rst.20190625_21z.tar Run model-adjoint-related applications (0=no,1=yes)? [0] > @@ -135,7 +138,7 @@ Which main class of ObsSys (1: NRT; 2: MERRA; 3: MERRA-2)? [1] > OBSERVING SYSTEM CLASSES? -> ncep_ssmis_bufr,ncep_1bamua_bufr,ncep_prep_bufr,ncep_tcvitals,ncep_mhs_bufr,ncep_1bhrs4_bufr,ncep_goesfv_bufr,ncep_gpsro_bufr,ncep_mtiasi_bufr,ncep_atms_bufr,ncep_cris_bufr,ncep_crisfsr_bufr,ncep_satwnd_bufr,ncep_sevcsr_bufr,ncep_avcsam_bufr,ncep_avcspm_bufr,disc_airs_bufr,disc_amsua_bufr,ncep_acftpfl_bufr,aura_omieff_nc,npp_ompsnp_nc,npp_ompsnmeff_nc +> ncep_ssmis_bufr,ncep_1bamua_bufr,ncep_prep_bufr,ncep_tcvitals,ncep_mhs_bufr,ncep_1bhrs4_bufr,ncep_goesfv_bufr,ncep_gpsro_bufr,ncep_mtiasi_bufr,ncep_atms_bufr,ncep_cris_bufr,ncep_crisfsr_bufr,ncep_satwnd_bufr,ncep_sevcsr_bufr,ncep_avcsam_bufr,ncep_avcspm_bufr,disc_airs_bufr,disc_amsua_bufr,ncep_acftpfl_bufr,aura_omieff_nc,npp_ompsnp_nc,npp_ompsnmeff_nc,gmao_gmi_bufr,gmao_amsr2_bufr CHECKING OBSYSTEM? [2] > 1 diff --git a/src/Applications/GEOSdas_App/testsuites/prePP.input b/src/Applications/GEOSdas_App/testsuites/prePP.input index 3819faab..a2886f86 100644 --- a/src/Applications/GEOSdas_App/testsuites/prePP.input +++ b/src/Applications/GEOSdas_App/testsuites/prePP.input @@ -62,6 +62,9 @@ REAL TIME BCS? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/g5 agcmpert? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/agcmpert] > +chemistry? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/chemistry] +> + g5chem? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/g5chem] > diff --git a/src/Applications/GEOSdas_App/testsuites/x0046a.input b/src/Applications/GEOSdas_App/testsuites/x0046a.input index 999ff665..b42d5623 100644 --- a/src/Applications/GEOSdas_App/testsuites/x0046a.input +++ b/src/Applications/GEOSdas_App/testsuites/x0046a.input @@ -62,6 +62,9 @@ REAL TIME BCS? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/g5 agcmpert? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/agcmpert] > +chemistry? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/chemistry] +> + g5chem? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/g5chem] > diff --git a/src/Applications/GEOSdas_App/testsuites/x0046aRPY.input b/src/Applications/GEOSdas_App/testsuites/x0046aRPY.input index 9b6ac926..ea49cfa0 100644 --- a/src/Applications/GEOSdas_App/testsuites/x0046aRPY.input +++ b/src/Applications/GEOSdas_App/testsuites/x0046aRPY.input @@ -62,6 +62,9 @@ REAL TIME BCS? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/g5 agcmpert? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/agcmpert] > +chemistry? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/chemistry] +> + g5chem? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/g5chem] > diff --git a/src/Applications/GEOSdas_App/testsuites/x0046a_Summer.input b/src/Applications/GEOSdas_App/testsuites/x0046a_Summer.input index 6cfeacd2..3f3c85e3 100644 --- a/src/Applications/GEOSdas_App/testsuites/x0046a_Summer.input +++ b/src/Applications/GEOSdas_App/testsuites/x0046a_Summer.input @@ -62,6 +62,9 @@ REAL TIME BCS? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/g5 agcmpert? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/agcmpert] > +chemistry? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/chemistry] +> + g5chem? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/g5chem] > diff --git a/src/Applications/GEOSdas_App/write_FVDAS_Run_Config.pl b/src/Applications/GEOSdas_App/write_FVDAS_Run_Config.pl index 0ebb4315..12598afd 100755 --- a/src/Applications/GEOSdas_App/write_FVDAS_Run_Config.pl +++ b/src/Applications/GEOSdas_App/write_FVDAS_Run_Config.pl @@ -14,7 +14,7 @@ my ($ARCH, $HOST); my ($FVHOME, $FVROOT, $RUNDIR); my ($AOD_OBSCLASS, $BERROR, $DO_ECS_OUT, $DO_REM_SYNC, $EXPID, $FVARCH, - $FVBCS, $GID, $MONTHLY_MEANS, $MP_SET_NUMTHREADS, $NCEPINPUT, $NOBACKUP, + $FVBCS, $GID, $MONTHLY_MEANS, $MKSI_SIDB, $MP_SET_NUMTHREADS, $NCEPINPUT, $NOBACKUP, $OBSCLASS, $OBSCLASS_NOAIRS, $OMP_NUM_THREADS, $RUN_QUADS, $PYRADMON, $VTRACK, $VTXLEVS, $VTXRELOC); my ($BASEDIR, $FCSTID, $FVDMGET, $G5MODULES, $PLOTS_LOC, $GEOSUTIL, $GTAG); @@ -92,6 +92,7 @@ sub init { $FVBCS = $ENV{"FVBCS"}; $GID = $ENV{"GID"}; $MONTHLY_MEANS = $ENV{"MONTHLY_MEANS"}; + $MKSI_SIDB = $ENV{"MKSI_SIDB"}; $MP_SET_NUMTHREADS = $ENV{"MP_SET_NUMTHREADS"}; $NCEPINPUT = $ENV{"NCEPINPUT"}; $OBSCLASS = $ENV{"OBSCLASS"}; @@ -321,6 +322,7 @@ sub writefile { print RUNCONF "setenv MONTHLY_X \"$MONTHLY_X\"\n" if $MONTHLY_X; print RUNCONF "setenv FVDOLMS $FVDOLMS\n" if $FVDOLMS; print RUNCONF "setenv CASE $CASE\n" if $CASE; + print RUNCONF "setenv MKSI_SIDB $MKSI_SIDB\n" if $MKSI_SIDB; print RUNCONF "setenv MP_SET_NUMTHREADS $MP_SET_NUMTHREADS\n" if $MP_SET_NUMTHREADS; print RUNCONF "setenv OMP_NUM_THREADS $OMP_NUM_THREADS\n" if $OMP_NUM_THREADS; print RUNCONF "setenv ARCH_QUEUE \"$ARCH_QUEUE\"\n" if $ARCH_QUEUE; diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/setup_atmens.pl b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/setup_atmens.pl index 13998f88..432a2466 100755 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/setup_atmens.pl +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/setup_atmens.pl @@ -441,6 +441,7 @@ sub install { if ( $doose ) { ed_conf_rc("$AOSEHOME","AtmOSEConfig.csh"); } +ed_g5fvlay_rc ("$AENSHOME"); # take care of satbias acq ed_satbias_acq ("$AENSHOME"); @@ -801,6 +802,56 @@ sub ed_aod4aens_acq { $ATMENS/central/$expid.aod_f.sfc.%y4%m2%d2_%h200z.nc4 $ATMENS/central/$expid.aod_k.sfc.%y4%m2%d2_%h200z.nc4 EOF +} +#...................................................................... +sub ed_g5fvlay_rc { + + return 0 unless ( $cubed ); + + my($mydir) = @_; + + my($frun, $ft, $rcd); + my($g5fvlayrc); + + $g5fvlayrc = "fvcore_layout.rc"; + + $ft = "$mydir/tmp.rc"; + $frun = "$mydir/$g5fvlayrc"; + + open(LUN,"$frun") || die "Fail to open $g5fvlayrc: $!\n"; + open(LUN2,">$ft") || die "Fail to open tmp.rc: $!\n"; + + # Change variables to the correct inputs + # RT: Only hydrostatic option supported for now - will revise for non-hydro case later + #--------------------------------------- + while( defined($rcd = ) ) { + chomp($rcd); + if($rcd =~ /\@FV_HYDRO/) {$rcd=~ s/\@FV_HYDRO/hydrostatic = .T./g; } + if($rcd =~ /\@FV_MAKENH/) {$rcd=~ s/\@FV_MAKENH/Make_NH = .F./g; } + if($rcd =~ /\@FV_SATADJ/) {$rcd=~ s/\@FV_SATADJ/do_sat_adj = .F./g; } + if($rcd =~ /\@FV_ZTRACER/){$rcd=~ s/\@FV_ZTRACER/z_tracer = .T./g; } + if($rcd =~ /\@FV_NWAT/) {$rcd=~ s/\@FV_NWAT/ /g; } + if ( $agcm_im == 720 ) { + if($rcd =~ /\@FV_N_SPLIT/) {$rcd=~ s/\@FV_N_SPLIT/n_split = 12/g; } + } else { + if($rcd =~ /\@FV_N_SPLIT/) {$rcd=~ s/\@FV_N_SPLIT/ /g; } + } + print(LUN2 "$rcd\n"); + } + + close(LUN); + close(LUN2); + + cp($ft, $frun); + unlink $ft; + +# if ( $coupled ) { +# my @these = ("$mometc/g5aodas_input.nml","$frun"); +# my $target = "/tmp/${user}_$$.txt"; +# merge_txt(\@these,$target); +# mv($target, $frun); +# } + } #...................................................................... From f5a9f8b133f799f161c7e2206a1756778b09567d Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Fri, 17 Dec 2021 14:35:44 -0500 Subject: [PATCH 148/205] revise obs sys for GEOS-IT and proper GOCART/emissions --- components.yaml | 6 +-- src/Applications/GEOSdas_App/fvsetup | 2 +- .../GEOSdas_App/testsuites/geos_it.input | 37 ++++++++++--------- 3 files changed, 24 insertions(+), 21 deletions(-) diff --git a/components.yaml b/components.yaml index 663dba34..52f9ea62 100644 --- a/components.yaml +++ b/components.yaml @@ -28,7 +28,7 @@ NCEP_Shared: GMAO_Shared: local: ./src/Shared/@GMAO_Shared remote: ../GMAO_Shared.git - tag: rt1_4_10_transf_fix + tag: rt1_4_10_geosit_1 develop: main MAPL: @@ -101,7 +101,7 @@ geos-chem: GOCART: local: ./src/Components/@GEOSgcm_GridComp/GEOSagcm_GridComp/GEOSphysics_GridComp/@GEOSchem_GridComp/@GOCART remote: ../GOCART.git - tag: v1.0.1 + tag: rt1.0.1_CEDS sparse: ./config/GOCART.sparse develop: develop @@ -121,7 +121,7 @@ mom6: GEOSgcm_App: local: ./src/Applications/@GEOSgcm_App remote: ../GEOSgcm_App.git - tag: rt_v1_5_6_geosit_0 + tag: rt1.5.6nsplit develop: develop UMD_Etc: diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index 51342de7..17342508 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -10097,7 +10097,7 @@ sub copy_resources { ed_ncep_rc("gsi_sens.rc.tmpl"); # overwrite some of the RC files when setting up for MERRA2 - if( $obsclass =~ "merra2" ) { + if( $merra2 ) { $cmd = "$fvbin/setup_4merra2.pl $fvhome $nymdb $hhb $ana_im $ana_jm $siglevs"; print "$cmd\n"; system($cmd); diff --git a/src/Applications/GEOSdas_App/testsuites/geos_it.input b/src/Applications/GEOSdas_App/testsuites/geos_it.input index 4786c300..699ccad9 100644 --- a/src/Applications/GEOSdas_App/testsuites/geos_it.input +++ b/src/Applications/GEOSdas_App/testsuites/geos_it.input @@ -2,9 +2,9 @@ # geos_it.input #-------------- -codeID: b3a880f -description: geos_it__GEOSadas-5_29_3__agrid_C360__ogrid_C -fvsetupID: f7d8d041c9 +codeID: 7f742b1 +description: geos_it__agrid_C180__ogrid_C +fvsetupID: bbf4f10063 ---ENDHEADERS--- @@ -23,13 +23,13 @@ AGCM Vertical Resolution? [72] OGCM Resolution? [f] > C -EXPID? [u000_C360] +EXPID? [u000_C180] > $expid Check for previous use of expid (y/n)? [y] > n -EXPDSC? [geos_it__GEOSadas-5_27_1_p4__agrid_C360__ogrid_C] +EXPDSC? [geos_it__agrid_C180__ogrid_C] > Land Boundary Conditions? [Icarus_Updated] @@ -63,7 +63,7 @@ agcmpert? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/agcmper > chemistry? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/chemistry] -> +> g5chem? [/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/g5chem] > @@ -89,7 +89,7 @@ Run model-adjoint-related applications (0=no,1=yes)? [0] Run analysis-sensitivity applications (0=no,1=yes)? [0] > -Ending year-month-day? [20210117] +Ending year-month-day? [20190627] > Length of FORECAST run segments (in hours)? [123] @@ -128,22 +128,22 @@ GEOS grid resolution instead? [d] Ensemble Hybrid (<0;3=3dHyb;4=Hyb4d)? [-1] > -Number of procs in the zonal direction (NX)? [12] +Number of procs in the zonal direction (NX)? [6] > 16 -Number of procs in the meridional direction (NY)? [20] +Number of procs in the meridional direction (NY)? [32] > 24 -Which main class of ObsSys (1: NRT; 2: MERRA; 3: MERRA-2)? [1] -> +Which main class of ObsSys (1: NRT; 2: MERRA; 3: MERRA-2; 4: GEOS-IT; 5: R21C)? [4] +> 4 OBSERVING SYSTEM CLASSES? -> ncep_ssmis_bufr,ncep_1bamua_bufr,ncep_prep_bufr,ncep_tcvitals,ncep_mhs_bufr,ncep_1bhrs4_bufr,ncep_goesfv_bufr,ncep_gpsro_bufr,ncep_mtiasi_bufr,ncep_atms_bufr,ncep_cris_bufr,ncep_crisfsr_bufr,ncep_satwnd_bufr,ncep_sevcsr_bufr,ncep_avcsam_bufr,ncep_avcspm_bufr,disc_airs_bufr,disc_amsua_bufr,ncep_acftpfl_bufr,aura_omieff_nc,npp_ompsnp_nc,npp_ompsnmeff_nc,gmao_gmi_bufr,gmao_amsr2_bufr +> merra2_cdas0_pre-qc_bufr,merra2_cdas_pre-qc_bufr,merra2_avhrrwnd_pre-qc_bufr,merra2_ascat_pre-qc_bufr,merra2_ers1_pre-qc_bufr,merra2_repro_ers2_pre-qc_bufr,merra2_qscat_jpl_pre-qc_bufr,merra2_wspd_pre-qc_bufr,merra2_nmodis_pre-qc_bufr,merra2_prof_pre-qc_bufr,merra2_cdas0_pre-qc_bufr,merra2_cdas_pre-qc_bufr,merra2_avhrrwnd_pre-qc_bufr,merra2_ascat_pre-qc_bufr,merra2_ers1_pre-qc_bufr,merra2_repro_ers2_pre-qc_bufr,merra2_qscat_jpl_pre-qc_bufr,merra2_wspd_pre-qc_bufr,merra2_nmodis_pre-qc_bufr,merra2_prof_pre-qc_bufr,merra2_ncep_tcvitals,ncep_ssmis_bufr,ncep_1bamua_bufr,ncep_mhs_bufr,ncep_1bhrs4_bufr,ncep_goesfv_bufr,ncep_gpsro_bufr,ncep_mtiasi_bufr,ncep_atms_bufr,ncep_cris_bufr,ncep_crisfsr_bufr,ncep_satwnd_bufr,ncep_sevcsr_bufr,ncep_avcsam_bufr,ncep_avcspm_bufr,disc_airs_bufr,disc_amsua_bufr,ncep_acftpfl_bufr,aura_omieff_nc,npp_ompsnp_nc,npp_ompsnmeff_nc,gmao_gmi_bufr,gmao_amsr2_bufr CHECKING OBSYSTEM? [2] > 1 -Which RADCOR option? [NONE] +Which RADCOR option? [HAIMB_HRAD] > Use sat channel-correlated observation errors (y/n)? [y] @@ -170,10 +170,10 @@ Frequency for surface (2D) DIAGNOSTIC fields? [010000] Frequency for upper air (3D) DIAGNOSTIC fields? [030000] > -Dimension of output in zonal direction? [1152] +Dimension of output in zonal direction? [576] > -Dimension of output in meridional direction? [721] +Dimension of output in meridional direction? [361] > Would you like 2D diagnostics? [y] @@ -188,7 +188,7 @@ Would you like to compress diagnostics output files? [n] Include GOCART tracers (CO,CO2,aerosols,etc) (y/n)? [y] > -Select GOCART Emission Files to use: [OPS] +Select GOCART Emission Files to use: [GEOSIT] > Do Aerosol Analysis (y/n)? [y] @@ -200,7 +200,7 @@ AOD OBSERVING CLASSES [or type 'none']? Enable GAAS feedback to model (y/n)? [y] > -Which template? [HISTORY.rc.tmpl] +Which template? [HISTORY_GEOSIT.rc.tmpl] > Which template? [GCMPROG.rc.tmpl] @@ -212,6 +212,9 @@ Output Restart TYPE (bin or nc4) [nc4] Select group: [g0613] > +Continue without missing resource files? [y] +> + Edit COLLECTIONS list in run/HISTORY.rc.tmpl (y/n)? [n] > From 3723d1a49771ca1b8ba2202356a87ff0fe57912a Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Thu, 23 Dec 2021 08:00:51 -0500 Subject: [PATCH 149/205] update GSI for GEOS-IT config; minor script adjustments merging 5.27.1-IT with current --- components.yaml | 2 +- src/Applications/GEOSdas_App/GEOSdas.csm | 21 +++++++++- src/Applications/GEOSdas_App/fvsetup | 1 + src/Applications/GEOSdas_App/gen_silo_arc.pl | 1 + .../GEOSdas_App/monthly.yyyymm.pl.tmpl | 42 +++++++++++-------- src/Applications/GEOSdas_App/monthly_setup.pl | 23 ++++++---- 6 files changed, 61 insertions(+), 29 deletions(-) diff --git a/components.yaml b/components.yaml index 52f9ea62..79ae1948 100644 --- a/components.yaml +++ b/components.yaml @@ -46,7 +46,7 @@ FMS: GEOSana_GridComp: local: ./src/Components/@GEOSana_GridComp remote: ../GEOSana_GridComp.git - tag: v1.5.2 + tag: v1.5.3 develop: develop GEOSgcm_GridComp: diff --git a/src/Applications/GEOSdas_App/GEOSdas.csm b/src/Applications/GEOSdas_App/GEOSdas.csm index 5246ab9a..bb71b721 100755 --- a/src/Applications/GEOSdas_App/GEOSdas.csm +++ b/src/Applications/GEOSdas_App/GEOSdas.csm @@ -177,6 +177,12 @@ #_RT if ( !($?STAGE4FCST) ) setenv STAGE4FCST 0 # need to resolve redundancies +# Sanity setting +# -------------- + if ( $SKIPANA ) then + setenv ASYNBKG 360 + endif + if ( $?RUN_OPT_BEGIN ) then set run_opt_begin = ( $RUN_OPT_BEGIN ) else @@ -445,7 +451,7 @@ exit 1 # Cannot do GAASFDBK unless GAAS_ANA is on # ---------------------------------------- if ( ! $FORECAST ) then - if ( $GAAS_ANA && ( ! $GAASFDBK ) ) then + if ( $GAASFDBK && ( ! $GAAS_ANA ) ) then echo $myname": GAAS inconsistency, GAASFDBK=$GAASFDBK, GAAS_ANA=$GAAS_ANA" exit 1 endif @@ -495,6 +501,7 @@ exit 1 # ----------------------------------------------------- if ( !($?obsclass) && !($?req_obsclass) ) then setenv SKIPANA 1 # no ANALYSIS + setenv ASYNBKG 360 endif # For readability, introduce DOING_ANA @@ -4187,7 +4194,12 @@ endif setenv NCPUS_AOD 1 endif - @ xtra = $NCPUS - $NCPUS_GSI + if ( $?SLURM_CPUS_ON_NODE && $?SLURM_JOB_NUM_NODES ) then + @ total_cpus_slurm = $SLURM_CPUS_ON_NODE * $SLURM_JOB_NUM_NODES + @ xtra = $total_cpus_slurm - $NCPUS_GSI + else + @ xtra = $NCPUS - $NCPUS_GSI + endif if ($xtra < $NCPUS_AOD) then setenv aod_parallel_flag 0 @@ -5742,6 +5754,11 @@ endif if ( $FORECAST ) then /bin/rm d_rst mkdrstdate.x $fcst_end # create d_rst with current date and time + else if ( $SKIPANA ) then + set GcmEndDate = $GcmEndEpoch[1] + set GcmEndTime = $GcmEndEpoch[2] + /bin/rm d_rst + mkdrstdate.x $GcmEndDate $GcmEndTime endif set buf = `rst_date d_rst` diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index 17342508..e06dd36b 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -595,6 +595,7 @@ $ENV{"PATH"} = $FindBin::Bin .":$ENV{PATH}"; . " -expid $expid" . " -fvhome $fvhome" . " -fvroot $fvroot" + . " -nodeflg $nodeflg" . " -res $res"; $cmd .= " -gid $gid" if $gid; print "$cmd\n"; diff --git a/src/Applications/GEOSdas_App/gen_silo_arc.pl b/src/Applications/GEOSdas_App/gen_silo_arc.pl index 032951a9..6d6cd137 100755 --- a/src/Applications/GEOSdas_App/gen_silo_arc.pl +++ b/src/Applications/GEOSdas_App/gen_silo_arc.pl @@ -341,6 +341,7 @@ sub append_other_info { \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.ana.obs.%y4%m2%d2.ods \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.ana.obs.%y4%m2%d2_%h2z.ods \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.prepbufr.%y4%m2%d2.t%h2z.blk +\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.acft_profl.%y4%m2%d2.t%h2z.bfr \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.gmao_global_satinfo.%y4%m2%d2_%h2z.txt \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.gmao_global_ozinfo.%y4%m2%d2_%h2z.txt \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.sac.nl.%y4%m2%d2_%h2z.txt diff --git a/src/Applications/GEOSdas_App/monthly.yyyymm.pl.tmpl b/src/Applications/GEOSdas_App/monthly.yyyymm.pl.tmpl index bb81c2c1..d33dce9b 100644 --- a/src/Applications/GEOSdas_App/monthly.yyyymm.pl.tmpl +++ b/src/Applications/GEOSdas_App/monthly.yyyymm.pl.tmpl @@ -49,6 +49,7 @@ BEGIN { } use lib "$fvroot/bin"; use GMAO_utils qw(get_siteID); +use Manipulate_time qw(get_htype token_resolve); use Perl_Config qw(perl_config); use WriteLog qw(chdir_ mkpath_ unlink_ system_); @@ -239,6 +240,7 @@ sub init { $walltime_pf = "2:00:00"; $numnodes_mm = 6; } + $walltime_mm = "1:00:00" if $qos eq "debug"; $walltime_mp = "1:00:00"; $numnodes_mp = 1; @@ -287,7 +289,7 @@ sub fetch_calc_tar_and_clean { my (%opts, $MMWORK, $filestring, $lastFLG); my (@fetchArr, $processflags); my ($max, $label, $num, $job_tarfile, @list); - my ($fileToken, @parts, %ftype, %htype, $ftype, $htype); + my ($fileToken, $fileTemplate, @parts, %ftype, %htype, $ftype, $htype); my (%doFetch, %doTar); # check for existence of work directory @@ -325,10 +327,7 @@ sub fetch_calc_tar_and_clean { # get $htype from $ftype, unless alternate htype value given #----------------------------------------------------------- - unless ($htype) { - if ($ftype =~ /\./) { $htype = $ftype } - else { $htype = (split(/_/, $ftype))[0] } - } + $htype = get_htype($ftype) unless $htype; $ftype{$filestring} = $ftype; $htype{$filestring} = $htype; @@ -351,11 +350,14 @@ sub fetch_calc_tar_and_clean { #------------------------------------- $lastFLG = 0; foreach $filestring (@fetchArr) { + $fileToken = basename($filestring); + $fileTemplate = token_resolve($fileToken, $yyyymm); %opts = (); $opts{"filestring"} = $filestring; $opts{"ftype"} = $ftype{$filestring}; $opts{"htype"} = $htype{$filestring}; + $opts{"fileTemplate"} = $fileTemplate; $opts{"do_dmput"} = 1; $opts{"do_dmput"} = 0 if $doTar{$filestring}; @@ -456,6 +458,7 @@ sub fetch_inputs { $value{"__RUNDIR__"} = $rundir; $value{"__WORKDIR__"} = $workdir; $value{"__DO_DMPUT__"} = $do_dmput; + $value{"__DO_SKIP_CHK__"} = 0; $value{"__DO_TAR__"} = $do_tar; replaceLabels($tmpl, $prefetch_j, %value); @@ -546,6 +549,7 @@ sub calc_monthly_means { $value{"__RUNDIR__"} = $rundir; $value{"__WORKDIR__"} = $workdir; $value{"__DO_DMPUT__"} = $do_dmput; + $value{"__DO_SKIP_CHK__"} = 1; replaceLabels($tmpl, $means_j, %value); @@ -574,7 +578,7 @@ sub calc_monthly_means { # => $lastFLG: flag indicating whether this is last data collection #======================================================================= sub tar_and_clean_inputs { - my (%opts, $filestring, $ftype, $do_tar, $lastFLG); + my (%opts, $filestring, $fileTemplate, $ftype, $do_tar, $lastFLG); my ($tmpl, $tarandclean_j, $jobname, $outfile); my ($job_name, $time, $output, $parFLG, $vFLG); my ($constraint); @@ -583,10 +587,11 @@ sub tar_and_clean_inputs { # input arguments #---------------- %opts = @_; - $filestring = $opts{"filestring"}; - $ftype = $opts{"ftype"}; - $do_tar = $opts{"do_tar"}; - $lastFLG = $opts{"lastFLG"}; + $filestring = $opts{"filestring"}; + $fileTemplate = $opts{"fileTemplate"}; + $ftype = $opts{"ftype"}; + $do_tar = $opts{"do_tar"}; + $lastFLG = $opts{"lastFLG"}; # create tarandclean job script #------------------------------- @@ -621,12 +626,13 @@ sub tar_and_clean_inputs { $value{"__PARTITION__"} = $parFLG; $value{"__CONSTRAINT__"} = $constraint; - $value{"__FILESTRING__"} = $filestring; - $value{"__YYYYMM__"} = $yyyymm; - $value{"__RUNDIR__"} = $rundir; - $value{"__WORKDIR__"} = $workdir; - $value{"__DO_TAR__"} = $do_tar; - $value{"__LASTFLG__"} = $lastFLG; + $value{"__FILESTRING__"} = $filestring; + $value{"__FILETEMPLATE__"} = $fileTemplate; + $value{"__YYYYMM__"} = $yyyymm; + $value{"__RUNDIR__"} = $rundir; + $value{"__WORKDIR__"} = $workdir; + $value{"__DO_TAR__"} = $do_tar; + $value{"__LASTFLG__"} = $lastFLG; replaceLabels($tmpl, $tarandclean_j, %value); @@ -659,7 +665,7 @@ sub archive_monthly_keep_files { # command flags #-------------- - $outfile = "$listdir/$EXPID.KEEParc.$yyyymm.log.$$.txt.FAILED"; + $outfile = "$listdir/$EXPID.KEEParc.$yyyymm.log.$$.txt"; $vars = "arch_type=MKEEP," . "arch_date=$yyyymm," . "outfile=$outfile"; @@ -721,7 +727,7 @@ sub archive_monthly_files { # command flags #-------------- - $outfile = "$listdir/$EXPID.MPParc.$yyyymm.log.$$.txt.FAILED"; + $outfile = "$listdir/$EXPID.MPParc.$yyyymm.log.$$.txt"; $vars = "arch_type=MNTHLY," . "arch_date=$yyyymm," . "outfile=$outfile," diff --git a/src/Applications/GEOSdas_App/monthly_setup.pl b/src/Applications/GEOSdas_App/monthly_setup.pl index 0f570bad..bf91e10a 100755 --- a/src/Applications/GEOSdas_App/monthly_setup.pl +++ b/src/Applications/GEOSdas_App/monthly_setup.pl @@ -54,6 +54,7 @@ #----------------- my ($EXPID, $FVETC, $GID, $numnodes, $scriptname, $siteID, $walltime); my ($rundir, $run_mp_dir, $FVHOME, $FVROOT); +my ($thisnode); # main program #------------- @@ -69,17 +70,18 @@ # purpose - get runtime options; check environment variables #======================================================================= sub init { - my ($res, $hres, $help, %opts); + my ($res, $hres, $help, $nodeflg, %opts); $scriptname = basename($0); $siteID = get_siteID(); - GetOptions( "expid=s" => \$EXPID, - "fvhome=s" => \$FVHOME, - "fvroot=s" => \$FVROOT, - "gid=s" => \$GID, - "res=s" => \$res, - "h" => \$help ); + GetOptions( "expid=s" => \$EXPID, + "fvhome=s" => \$FVHOME, + "fvroot=s" => \$FVROOT, + "gid=s" => \$GID, + "nodeflg=s" => \$nodeflg, + "res=s" => \$res, + "h" => \$help ); usage() if $help; $EXPID = $ENV{"EXPID"} unless $EXPID; @@ -115,6 +117,10 @@ sub init { if ($siteID eq "nccs") { $walltime = "8:00:00" } elsif ($siteID eq "nas") { $walltime = "12:00:00" } + $thisnode = "hasw"; + if ($nodeflg) { + $thisnode = $nodeflg; + } if ($res) { $hres = substr($res, 0, 1) if $res; @@ -174,7 +180,7 @@ sub write_plotfiles { %values = (); $values{"\@PLOT_T"} = "12:00:00"; $values{"\@PLOT_P"} = "SBATCH --nodes=4"; - $values{"\@PLOT_Q"} = "SBATCH --constraint=hasw"; + $values{"\@PLOT_Q"} = "SBATCH --constraint=$thisnode"; $values{"\@BATCH_GROUP"} = "SBATCH --account=$GID"; $values{"\@SITE"} = uc($siteID); $values{"\@GEOSBIN"} = "$FVROOT/bin"; @@ -286,6 +292,7 @@ sub usage { -fvhome fvhomedir FVHOME directory location; defaults to \$ENV{"FVHOME"} -fvroot fvrootdir FVROOT directory location; defaults to \$ENV{"FVROOT"} -gid groupid Group ID; defaults to getsponsor.pl default + -nodeflg Node flag: hasw, sky, cas (default: hasw) -res Horizontal resolution of atmosphere grid EOF exit; From 98e3bbf2f91e70a0175ea56fb8cf3874f63813f9 Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz Date: Mon, 27 Dec 2021 12:24:43 -0500 Subject: [PATCH 150/205] cleanup code, fix print statement --- src/Applications/GSI_App/gsidiag_bin2txt.f90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Applications/GSI_App/gsidiag_bin2txt.f90 b/src/Applications/GSI_App/gsidiag_bin2txt.f90 index d50682ba..d88efd15 100644 --- a/src/Applications/GSI_App/gsidiag_bin2txt.f90 +++ b/src/Applications/GSI_App/gsidiag_bin2txt.f90 @@ -158,9 +158,7 @@ program gsidiag_bin2txt call abort end if -! write(*,*)'File ', trim(infn), ' opened on lun=',inlun write(*,'(''File '', a, '' opened on lun='',i5 )') trim(infn), inlun -! open(inlun,file=infn,form='unformatted',convert='big_endian') call read_radiag_header( inlun, npred_read, sst_ret, headfix, headchan, headname, iflag, debug ) From d3d2fcfd0ccd4f6265032e08f391e2c152ac3380 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Thu, 3 Feb 2022 15:07:14 -0500 Subject: [PATCH 151/205] minor changes to satdb and MAPL fix for FPP - this also includes change to NH3 --- components.yaml | 4 ++-- src/Applications/GEOSdas_App/edhist.pl | 10 +++++++--- src/Applications/GEOSdas_App/fvsetup | 14 ++++++++------ 3 files changed, 17 insertions(+), 11 deletions(-) diff --git a/components.yaml b/components.yaml index 79ae1948..38ec45d7 100644 --- a/components.yaml +++ b/components.yaml @@ -34,7 +34,7 @@ GMAO_Shared: MAPL: local: ./src/Shared/@MAPL remote: ../MAPL.git - tag: v2.8.0 + tag: v2.8.0.2 develop: develop FMS: @@ -46,7 +46,7 @@ FMS: GEOSana_GridComp: local: ./src/Components/@GEOSana_GridComp remote: ../GEOSana_GridComp.git - tag: v1.5.3 + tag: v1.5.4 develop: develop GEOSgcm_GridComp: diff --git a/src/Applications/GEOSdas_App/edhist.pl b/src/Applications/GEOSdas_App/edhist.pl index 934dc36f..6cf4e22f 100755 --- a/src/Applications/GEOSdas_App/edhist.pl +++ b/src/Applications/GEOSdas_App/edhist.pl @@ -1125,7 +1125,9 @@ sub plot_edit { #---------------------------------------- @new = (); foreach $name (@topList) { - next unless $name =~ m/Cp$/ or $name =~ m/Np$/ or $name =~ m/Nx$/; + $name =~ s/_NCKS$//; + next unless $name =~ m/Cp$/ or $name =~ m/Np$/ or $name =~ m/Nx$/ + or $name =~ m/slv$/ or $name =~ m/p42$/; push @new, $name; } @topList = @new; @@ -1244,6 +1246,7 @@ sub delete_trait { $name = shift @_; $trait = shift @_; + return unless $traitHash{$name}; @traits = split/[:|,]/, $traitHash{$name}; foreach $trt (@traits) { push @new, $trt unless $trt =~ /$trait.N\d+/ } $traitHash{$name} = join ":", @new; @@ -1259,6 +1262,7 @@ sub add_grads_ddf { # add to %traitHash #------------------ + return unless $traitHash{$name}; @traits = split/[:|,]/, $traitHash{$name}; foreach $trt (@traits) { push @new, $trt; @@ -1452,7 +1456,7 @@ sub write_collection_def { $name = shift @_; $name1 = rm_dash_plus($name); - @traits = split /[:|,]/, $traitHash{$name}; + @traits = split /[:|,]/, $traitHash{$name} if $traitHash{$name}; remove_array_duplicates(\@traits); $tmax = 0; @@ -1519,7 +1523,7 @@ sub write_collection_def { } } } - print $comments{"$name.end"}; + print $comments{"$name.end"} if $comments{"$name.end"}; print " "x$tmax ." ::\n"; } diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index e06dd36b..9ad7eb59 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -7861,8 +7861,9 @@ print SCRIPT <<"EOF"; setenv I_MPI_ADJUST_ALLREDUCE 12 setenv I_MPI_EXTRA_FILESYSTEM 1 setenv I_MPI_EXTRA_FILESYSTEM_LIST gpfs - setenv ROMIO_FSTYPE_FORCE "gpfs:" - setenv I_MPI_FABRICS shm:ofi + setenv I_MPI_DEBUG 6 +# setenv ROMIO_FSTYPE_FORCE "gpfs:" +# setenv I_MPI_FABRICS shm:ofi # setenv I_MPI_FABRICS shm:dapl # setenv I_MPI_FABRICS_LIST "dapl,ofa" # setenv I_MPI_FALLBACK "enable" @@ -8948,7 +8949,8 @@ print SCRIPT <<"EOF"; setenv I_MPI_ADJUST_ALLREDUCE 12 setenv I_MPI_EXTRA_FILESYSTEM 1 setenv I_MPI_EXTRA_FILESYSTEM_LIST gpfs - setenv ROMIO_FSTYPE_FORCE "gpfs:" + setenv I_MPI_DEBUG 6 +# setenv ROMIO_FSTYPE_FORCE "gpfs:" endif if (\$?MPT_VERSION) then setenv MPI_COLL_REPRODUCIBLE @@ -9582,9 +9584,9 @@ sub init_agcm_rc { # $num_readers must divide evenly into $ny #----------------------------------------- - if ($ny % 4 == 0) { $num_readers = 4 } - elsif ($ny % 2 == 0) { $num_readers = 2 } - else { $num_readers = 1 } + if ($agcm_im == 180) { $num_readers = 4 } + elsif ($agcm_im > 180) { $num_readers = 6 } + else { $num_readers = 1 } # gcm satellite simulator #------------------------ From 1272b53f025027dcab860b3cfdcc87c93524df61 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Sat, 5 Feb 2022 19:18:39 -0500 Subject: [PATCH 152/205] minor fix to mapl; increase arrays size handling acft bias correction --- components.yaml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/components.yaml b/components.yaml index 38ec45d7..f09bd7da 100644 --- a/components.yaml +++ b/components.yaml @@ -34,7 +34,7 @@ GMAO_Shared: MAPL: local: ./src/Shared/@MAPL remote: ../MAPL.git - tag: v2.8.0.2 + tag: v2.8.0.3 develop: develop FMS: @@ -46,7 +46,7 @@ FMS: GEOSana_GridComp: local: ./src/Components/@GEOSana_GridComp remote: ../GEOSana_GridComp.git - tag: v1.5.4 + tag: v1.5.4.1 develop: develop GEOSgcm_GridComp: @@ -121,7 +121,7 @@ mom6: GEOSgcm_App: local: ./src/Applications/@GEOSgcm_App remote: ../GEOSgcm_App.git - tag: rt1.5.6nsplit + tag: rt1.5.6FPhist develop: develop UMD_Etc: From 1c3464c64dba9cf610aa98c8d1e1f354eb89f103 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Tue, 8 Feb 2022 09:37:47 -0500 Subject: [PATCH 153/205] GitHub Actions for MAPLv3 development --- .../PULL_REQUEST_TEMPLATE/auto_pr_to_mapl3.md | 10 +++++++ .github/workflows/push-to-develop.yml | 30 +++++++++++++++++++ 2 files changed, 40 insertions(+) create mode 100644 .github/PULL_REQUEST_TEMPLATE/auto_pr_to_mapl3.md create mode 100644 .github/workflows/push-to-develop.yml diff --git a/.github/PULL_REQUEST_TEMPLATE/auto_pr_to_mapl3.md b/.github/PULL_REQUEST_TEMPLATE/auto_pr_to_mapl3.md new file mode 100644 index 00000000..55020d73 --- /dev/null +++ b/.github/PULL_REQUEST_TEMPLATE/auto_pr_to_mapl3.md @@ -0,0 +1,10 @@ +## :memo: Automatic PR: `develop` → `release/MAPL-v3` + +### Description + + + +## :file_folder: Modified files + + + diff --git a/.github/workflows/push-to-develop.yml b/.github/workflows/push-to-develop.yml new file mode 100644 index 00000000..59424134 --- /dev/null +++ b/.github/workflows/push-to-develop.yml @@ -0,0 +1,30 @@ +name: Push to Develop + +on: + push: + branches: + - develop + +jobs: + pull_request: + name: Create Pull Request + runs-on: ubuntu-latest + steps: + - name: Checkout repo + uses: actions/checkout@v2 + with: + fetch-depth: 0 + - name: Run the action + uses: devops-infra/action-pull-request@v0.4 + with: + github_token: ${{ secrets.GITHUB_TOKEN }} + source_branch: develop + target_branch: release/MAPL-v3 + label: automatic,MAPL3,Skip Changelog + template: .github/PULL_REQUEST_TEMPLATE/auto_pr_to_mapl3.md + get_diff: true + assignee: ${{ github.actor }} + old_string: "" + new_string: ${{ github.event.commits[0].message }} + title: Auto PR - develop → MAPL-v3 - ${{ github.event.commits[0].message }} + From 9e9ef0912c2aa7734f0c7fb065e5c5bc7954fd3a Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Thu, 10 Feb 2022 13:12:26 -0500 Subject: [PATCH 154/205] bug fix in ens setup; sync of HISTORY w/ what FP uses --- components.yaml | 2 +- .../NCEP_Etc/NCEP_enkf/scripts/gmao/setup_atmens.pl | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/components.yaml b/components.yaml index f09bd7da..9f341351 100644 --- a/components.yaml +++ b/components.yaml @@ -121,7 +121,7 @@ mom6: GEOSgcm_App: local: ./src/Applications/@GEOSgcm_App remote: ../GEOSgcm_App.git - tag: rt1.5.6FPhist + tag: rt1.5.6FPhist_specs develop: develop UMD_Etc: diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/setup_atmens.pl b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/setup_atmens.pl index 432a2466..1f094977 100755 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/setup_atmens.pl +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/setup_atmens.pl @@ -816,9 +816,10 @@ sub ed_g5fvlay_rc { $g5fvlayrc = "fvcore_layout.rc"; $ft = "$mydir/tmp.rc"; + $fetc = "$FVROOT/etc/$g5fvlayrc"; $frun = "$mydir/$g5fvlayrc"; - open(LUN,"$frun") || die "Fail to open $g5fvlayrc: $!\n"; + open(LUN,"$fetc") || die "Fail to open $g5fvlayrc: $!\n"; open(LUN2,">$ft") || die "Fail to open tmp.rc: $!\n"; # Change variables to the correct inputs From 20ea050e5d64892409248588a513058418074fdc Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Wed, 16 Feb 2022 20:51:34 -0500 Subject: [PATCH 155/205] fix for TSKINI (surf export) and MAPL file specs --- components.yaml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/components.yaml b/components.yaml index 9f341351..c5ebd245 100644 --- a/components.yaml +++ b/components.yaml @@ -34,7 +34,7 @@ GMAO_Shared: MAPL: local: ./src/Shared/@MAPL remote: ../MAPL.git - tag: v2.8.0.3 + tag: v2.8.0.4 develop: develop FMS: @@ -52,7 +52,7 @@ GEOSana_GridComp: GEOSgcm_GridComp: local: ./src/Components/@GEOSgcm_GridComp remote: ../GEOSgcm_GridComp.git - tag: rt1_12_4_mom6 + tag: rt1_12_4_tskini sparse: ./config/GEOSgcm_GridComp.sparse develop: develop From a36cbe20484ef2b619ace5528516c30a16caaf23 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Fri, 25 Feb 2022 10:42:28 -0500 Subject: [PATCH 156/205] TKSINICE, GEOSIT history, ManipulateTime fixes --- components.yaml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/components.yaml b/components.yaml index c5ebd245..5e02a70b 100644 --- a/components.yaml +++ b/components.yaml @@ -28,7 +28,7 @@ NCEP_Shared: GMAO_Shared: local: ./src/Shared/@GMAO_Shared remote: ../GMAO_Shared.git - tag: rt1_4_10_geosit_1 + tag: rt1_4_10_geosit_2 develop: main MAPL: @@ -52,7 +52,7 @@ GEOSana_GridComp: GEOSgcm_GridComp: local: ./src/Components/@GEOSgcm_GridComp remote: ../GEOSgcm_GridComp.git - tag: rt1_12_4_tskini + tag: rt1_12_4_tskinice sparse: ./config/GEOSgcm_GridComp.sparse develop: develop @@ -121,7 +121,7 @@ mom6: GEOSgcm_App: local: ./src/Applications/@GEOSgcm_App remote: ../GEOSgcm_App.git - tag: rt1.5.6FPhist_specs + tag: rt1.5.6_geosit_hist1 develop: develop UMD_Etc: From f79ada220d04fb86a1a122fca84fb928927ae96d Mon Sep 17 00:00:00 2001 From: Joe Stassi Date: Tue, 1 Mar 2022 11:23:45 -0500 Subject: [PATCH 157/205] Modified in GEOSdas_App: monthly_means.pl and monthly_tarandclean.j.tmpl New file in GEOSdas_App/testsuites: update_input_IDs.pl See issue #161 --- src/Applications/GEOSdas_App/monthly_means.pl | 7 +- .../GEOSdas_App/monthly_tarandclean.j.tmpl | 18 +- .../testsuites/update_input_IDs.pl | 415 ++++++++++++++++++ 3 files changed, 426 insertions(+), 14 deletions(-) create mode 100755 src/Applications/GEOSdas_App/testsuites/update_input_IDs.pl diff --git a/src/Applications/GEOSdas_App/monthly_means.pl b/src/Applications/GEOSdas_App/monthly_means.pl index ed3bf449..1db175dd 100755 --- a/src/Applications/GEOSdas_App/monthly_means.pl +++ b/src/Applications/GEOSdas_App/monthly_means.pl @@ -103,7 +103,7 @@ sub init { use File::Basename qw(basename dirname); use File::Path qw(mkpath); use Getopt::Long (":config", "no_ignore_case"); - use Manipulate_time qw(get_hours num_days_in_month token_resolve); + use Manipulate_time qw(get_htype get_hours num_days_in_month token_resolve); use Remote_utils qw(splitrfile); use Perl_Config qw(perl_config); my ($filestring, $help, $null, $SILO_DIR); @@ -179,10 +179,7 @@ sub init { # get $htype from $ftype, unless alternate htype value given #----------------------------------------------------------- - unless ($htype) { - if ($ftype =~ /\./) { $htype = $ftype } - else { $htype = (split(/_/, $ftype))[0] } - } + $htype = get_htype($ftype) unless $htype; $archive = "$fvarch/$expid/$fpathToken"; $silo_dir = "$fvhome/$fpathToken"; diff --git a/src/Applications/GEOSdas_App/monthly_tarandclean.j.tmpl b/src/Applications/GEOSdas_App/monthly_tarandclean.j.tmpl index f0ad1da2..2feba3c4 100644 --- a/src/Applications/GEOSdas_App/monthly_tarandclean.j.tmpl +++ b/src/Applications/GEOSdas_App/monthly_tarandclean.j.tmpl @@ -27,12 +27,13 @@ else echo "-----" endif set echo -set filestring = __FILESTRING__ -set yyyymm = __YYYYMM__ -set rundir = __RUNDIR__ -set workdir = __WORKDIR__ -set do_tar = __DO_TAR__ -set lastFLG = __LASTFLG__ +set filestring = __FILESTRING__ +set fileTemplate = "__FILETEMPLATE__" +set yyyymm = __YYYYMM__ +set rundir = __RUNDIR__ +set workdir = __WORKDIR__ +set do_tar = __DO_TAR__ +set lastFLG = __LASTFLG__ unset echo echo @@ -112,9 +113,8 @@ endif # get list of workdir inputs #--------------------------- chdir $workdir -set suffix = $filestring:e -set workdir_inputs = ( `ls $EXPID.$ftype.$yyyymm*.$suffix` ) +set workdir_inputs = ( $fileTemplate ) set workdir_status = $status if ($workdir_status) then @@ -128,7 +128,7 @@ if ($do_tar) then # get list of archived inputs #---------------------------- - set archive_inputs = ( $remote_dir/$EXPID.$ftype.$yyyymm*.$suffix ) + set archive_inputs = ( $remote_dir/$fileTemplate ) set no_inputs_found = $status if ($no_inputs_found) then diff --git a/src/Applications/GEOSdas_App/testsuites/update_input_IDs.pl b/src/Applications/GEOSdas_App/testsuites/update_input_IDs.pl new file mode 100755 index 00000000..45f9c5d4 --- /dev/null +++ b/src/Applications/GEOSdas_App/testsuites/update_input_IDs.pl @@ -0,0 +1,415 @@ +#!/usr/bin/env perl +#======================================================================= +# name - update_input_IDs.pl +# purpose - update codeID and fvsetupID in testsuites *.input files +# +# revision history +# 06Dec2021 Stassi Initial version +# 26Jan2022 Stassi Modified to update codeID +#======================================================================= +use strict; +use warnings; +use File::Basename qw(basename dirname); +use File::Copy qw(move); +use Getopt::Long qw(GetOptions); + +# global variables +#----------------- +my ($codeID, $debug, $fvsetup, $fvsetupID, $gitcmd, $noprompt, $quiet); +my (%inputList); + +# main program +#------------- +{ + my ($cmd, $inputfile, $is_latest_tag_an_ancestor); + my ($Project_WC_REVISION_HASH, $Project_WC_LATEST_TAG); + + init(); + unless (defined($fvsetupID)) { + $cmd = "$gitcmd hash-object $fvsetup | cut -c1-10"; + chomp($fvsetupID = `$cmd`); + if ($debug) { + print "$cmd\n"; + print "fvsetupID = $fvsetupID\n"; + } + } + unless (defined($codeID)) { + $Project_WC_REVISION_HASH = revision_hash(); + $Project_WC_LATEST_TAG = latest_tag(); + $is_latest_tag_an_ancestor = + ancestor_check($Project_WC_LATEST_TAG, $Project_WC_REVISION_HASH); + + if ($is_latest_tag_an_ancestor == 0) { + $codeID = $Project_WC_REVISION_HASH; + } + elsif ($is_latest_tag_an_ancestor == 1) { + $codeID = $Project_WC_LATEST_TAG; + } + print "codeID = $codeID\n" if $debug; + } + foreach $inputfile (sort keys %inputList) { + update_ID_values($inputfile) + } +} + +#======================================================================= +# name - init +# purpose - get runtime options and fvsetup command +#======================================================================= +sub init { + my ($file, $fvsrc, $help, $inputfile, $pwd, @values); + + # get runtime options + #-------------------- + GetOptions( "d=s" => \$fvsrc, + "cid=s" => \$codeID, + "fid=s" => \$fvsetupID, + "np|noprompt" => \$noprompt, + "db|debug" => \$debug, + "q" => \$quiet, + "h|help" => \$help ); + usage() if $help; + + unless (defined($fvsetupID)) { + + # user specifies fvsetup or where to find it + #------------------------------------------- + if ($fvsrc) { + if (-f $fvsrc) { + $fvsetup = $fvsrc; + } + else { + die "Error. Cannot find directory, $fvsrc;" unless -d $fvsrc; + $fvsetup = "$fvsrc/Applications/GEOSdas_App/fvsetup"; + $fvsetup = "$fvsrc/fvsetup" unless -e $fvsetup; + unless (-e $fvsetup) { + die "Error. Cannot find fvsetup under directory, $fvsrc;"; + } + } + } + + # look for default fvsetup + #------------------------- + else { + $pwd = `pwd -L`; + $fvsetup = dirname($pwd) ."/fvsetup"; + die "Error. Cannot find, $fvsetup;" unless -e $fvsetup; + } + } + + # user supplies *.input file list + #-------------------------------- + if (@ARGV) { + %inputList = (); + foreach $inputfile (@ARGV) { + @values = split /,/, $inputfile; + foreach $file (@values) { + $file .= ".input" unless $file =~ m/.input$/; + unless (-e $file) { + warn "WARNING: Cannot find file, $file;"; + pause(); + next; + } + $inputList{$file} = 1 if $file; + } + } + } + + # or default to all *.input files in local directory + #--------------------------------------------------- + else { foreach $file (<*.input>) { $inputList{$file} = 1 } } + + # warn if no *.input files are found + #----------------------------------- + unless (%inputList) { + print "WARNING: No *.input files found.\n"; + usage(); + } + + # check git command + #------------------ + chomp($gitcmd = `which git`); + die "Error. Cannot find git command;" unless $gitcmd and -x $gitcmd; + + debug() if $debug; +} + +#======================================================================= +# name - revision_hash +# purpose - return value of Project_WC_REVISION_HASH +#======================================================================= +sub revision_hash { + my ($revision_hash, $cmd); + $cmd = "$gitcmd rev-parse --verify -q --short=7 HEAD"; + chomp($revision_hash = `$cmd`); + if ($debug) { + print "$cmd\n"; + print "revision_hash = $revision_hash\n"; + } + return $revision_hash; +} + +#======================================================================= +# name - latest_tag +# purpose - return value of Project_WC_LATEST_TAG +#======================================================================= +sub latest_tag { + my ($latest_tag, $cmd); + $cmd = "$gitcmd describe --tags --abbrev=0"; + chomp($latest_tag = `$cmd`); + if ($debug) { + print "$cmd\n"; + print "latest_tag = $latest_tag\n"; + } + return $latest_tag; +} + +#======================================================================= +# name - ancestor_check +# purpose - return value for $is_latest_tag_an_ancestor +# +# input parameters +# => $latest_tag: +# => $revision_hash: +#======================================================================= +sub ancestor_check { + my ($latest_tag, $revision_hash, $ancestor_check, $cmd); + $latest_tag = shift @_; + $revision_hash = shift @_; + $cmd = "$gitcmd merge-base --is-ancestor $latest_tag $revision_hash"; + chomp($ancestor_check = `$cmd`); + if ($debug) { + print "$cmd\n"; + print "ancestor_check = $ancestor_check\n"; + } + $ancestor_check = 0 unless $ancestor_check; + return $ancestor_check; +} + +#======================================================================= +# name - update_ID_values +# purpose - update the codeID and fvsetupID values in the given input file +# +# input parameters +# => $inputfile: the *.input file to update +#======================================================================= +sub update_ID_values { + my ($inputfile, $ans, $line, $updated); + my ($old_fvID, $old_cdID, $tilde_file, $tmpfile); + + $inputfile = shift @_; + $tmpfile = $inputfile .".tmp"; + unlink $tmpfile if -e $tmpfile; + $updated = 0; + + # check to see that fvsetupID is set in file + #------------------------------------------- + open (NPUT, "< $inputfile") or die "Error(1) opening file, $inputfile"; + if ($fvsetupID) { + unless (grep { /^\s*fvsetupID:/ } ) { + if ($noprompt) { + $ans = "y"; + } + else { + print "\nWARNING: fvsetupID value is not set in $inputfile.\n"; + print "$inputfile: (ADD LINE?) fvsetupID: $fvsetupID"; + print " (y/n) [y]: "; + chomp($ans = ); + if (lc($ans) eq "a") { $ans = "y"; $noprompt = 1 } + } + if ($ans eq "" or lc($ans) eq "y") { + system("sed -i 5i'fvsetupID: $fvsetupID' $inputfile > $tmpfile"); + print "$inputfile: UPDATED\n" unless $quiet; + $updated = 1; + } + } + } + close NPUT; + + # check to see that codeID is set in file + #---------------------------------------- + open (NPUT, "< $inputfile") or die "Error(2) opening file, $inputfile"; + if ($codeID) { + unless (grep { /^\s*codeID:/ } ) { + if ($noprompt) { + $ans = "y"; + } + else { + print "\nWARNING: codeID value is not set in $inputfile.\n"; + print "$inputfile: (ADD LINE?) codeID: $codeID"; + print " (y/n) [y]: "; + chomp($ans = ); + if (lc($ans) eq "a") { $ans = "y"; $noprompt = 1 } + } + if ($ans eq "" or lc($ans) eq "y") { + system("sed -i 5i'codeID: $codeID' $inputfile > $tmpfile"); + print "$inputfile: UPDATED\n" unless $quiet; + $updated = 1; + } + } + } + close NPUT; + + # transfer lines from inputfile to tmpfile + #----------------------------------------- + open (NPUT, "< $inputfile") or die "Error opening file, $inputfile"; + open (TMP, "> $tmpfile") or die "Error opening tmpfile, $tmpfile"; + + while () { + $line = $_; + + # replace old codeID with new ... + #----------------------------------- + if ($codeID and m/^\s*codeID:/) { + if (m/^\s*codeID:\s*(\w+)/) { + $old_cdID = $1; + $line = updateVal($inputfile, $line, 1, $codeID, $old_cdID); + } + else { $line = updateVal($inputfile, $line, 1, $codeID) } + } + + # replace old fvsetupID with new ... + #----------------------------------- + if ($fvsetupID and m/^\s*fvsetupID:/) { + if (m/^\s*fvsetupID:\s*(\w+)/) { + $old_fvID = $1; + $line = (updateVal($inputfile, $line, 2, $fvsetupID, $old_fvID)); + } + else { $line = updateVal($inputfile, $line, 2, $fvsetupID) } + } + $updated = 1 unless $line eq $_; + print TMP $line; + } + close NPUT; + close TMP; + + # update file, if there was a change + #----------------------------------- + if ($updated) { + $tilde_file = $inputfile ."~"; + if (-e $tilde_file) { + unlink $inputfile; + move $tmpfile, $inputfile; + } + else { + move $inputfile, $tilde_file; + move $tmpfile, $inputfile; + } + } + else { + print "$inputfile: NO CHANGE\n" unless $quiet; + unlink $tmpfile; + } +} + +#======================================================================= +# name - updateVal +# purpose - prompt user before updating codeID or fvsetupID value +# +# input parameters +# => $file: name of *.input file being updated +# => $line: the line in the file being updated (containind ID value) +# => $valFLG: == 1 for codeID, == 2 for fvsetupID +# => $newVal: new ID value +# => $oldVal: (optional) old ID value +#======================================================================= +sub updateVal { + my ($ans, $file, $line, $valFLG, $newVal, $oldVal, $updateVal, $vType); + $file = shift @_; + $line = shift @_; + $valFLG = shift @_; + $newVal = shift @_; + $oldVal = shift @_; + + if ($valFLG == 1) { $vType = "codeID" } + else { $vType = "fvsetupID" } + + # return line as is, if no change or if $newVal == 0 + #--------------------------------------------------- + return $line if $oldVal and $oldVal eq $newVal; + return $line unless $newVal; + + # prompt user before making update + #--------------------------------- + unless ($noprompt) { + if ($oldVal) { print "$file: update $vType, $oldVal => $newVal" } + else { print "$file: update $vType => $newVal" } + print " (y/n) [y]: "; + chomp($ans = ); + } + else { $ans = "y" } + if (lc($ans) eq "a") { $ans = "y"; $noprompt = 1 } + + # update line + #------------ + if ($ans eq "" or lc($ans) eq "y") { + if ($oldVal) { $line =~ s/$oldVal/$newVal/ } + else { $line = "$vType: $newVal\n" } + unless ($quiet) { + if ($oldVal) { print "$file UPDATED: $vType, $oldVal => $newVal\n" } + else { print "$file UPDATED: $vType => $newVal\n" } + } + } + return $line; +} + +#======================================================================= +# name - pause +# purpose - pause interactive processing for user to consider previous output +#======================================================================= +sub pause { + print "Hit to continue ... "; + my $dummy = ; + return; +} + +#======================================================================= +# name - debug +# purpose - print debug info +#======================================================================= +sub debug { + print "="x35 ."\n"; + print "fvsetup: $fvsetup\n" if $fvsetup; + print "gitcmd: $gitcmd\n"; + foreach (sort keys %inputList) { print "input: $_\n" } + print "="x35 ."\n"; +} + +#======================================================================= +# name - usage +# purpose - print usage information +#======================================================================= +sub usage { + my $script = basename $0; + print <<"EOF"; + +This utility will update the codeID and fvsetupID values in the testsuite +*.input files. See Note #1 + +usage: $script [dotinput(s)] [options] +where dotInput(s) are *.input file names; see Notes #2, #3, and #4 + +options + -d fvsrc directory location for fvsetupID; see Note #5 + -cid codeID code git hash ID to use for update; if 0, then do not update; + defaults to system calculated code ID + -fid fvsetupID fvsetup git hash ID to use for update; if 0, then do not update; + defaults to abbreviated git hash of fvsetup in fvsrc + -np no prompt; do not prompt before making updates + -q quiet mode; do not print update messages + -h,-help print usage information + +Notes +1. This script should be run in the src/Applications/GEOSdas_App directory. +2. If no dotInput files are listed, then the script will default to use all + dotInput files in the local directory. +3. Multiple dotInput files can be listed, separated by commas, no spaces +4. All dotInput files listed must have the ".input" extension; However, they + can be specified without including the ".input" extension, e.g. C48f,C90C +5. The fvsrc directory value can be set to the top src directory in the GEOSadas + checkout, or to a directory containing fvsetup, or it can point directly to + the fvsetup script itself. + +EOF +exit; +} From ca1006e7a85af077cafc7bfd102adaa5e84a26b9 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Fri, 4 Mar 2022 13:37:05 -0500 Subject: [PATCH 158/205] but fixes to monthly mean progs --- components.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/components.yaml b/components.yaml index 5e02a70b..435593be 100644 --- a/components.yaml +++ b/components.yaml @@ -28,7 +28,7 @@ NCEP_Shared: GMAO_Shared: local: ./src/Shared/@GMAO_Shared remote: ../GMAO_Shared.git - tag: rt1_4_10_geosit_2 + tag: rt1_4_10_geosit_3 develop: main MAPL: From 548e8945eba044fa604a6a346c264ab4987e79a5 Mon Sep 17 00:00:00 2001 From: Joe Stassi Date: Wed, 9 Mar 2022 08:48:13 -0500 Subject: [PATCH 159/205] bug fix to handle traj_lcv_rst correctly --- src/Applications/GEOSdas_App/edhist.pl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Applications/GEOSdas_App/edhist.pl b/src/Applications/GEOSdas_App/edhist.pl index 6cf4e22f..ba0c1551 100755 --- a/src/Applications/GEOSdas_App/edhist.pl +++ b/src/Applications/GEOSdas_App/edhist.pl @@ -1377,7 +1377,7 @@ sub add_silo_mstorage_traits { #------------------------------ outer: foreach $name (@bottomList) { - next outer if $name =~ m/_rst/; + next outer if $name =~ m/_rst/ and $name ne "traj_lcv_rst"; unless ($traitHash{$name} =~ m/\bsilo\b/) { $traitHash{$name} =~ s/:template:/:template:silo.N1:/; From 7c86e19f067286b7a0976c8f491f1f808c01eaab Mon Sep 17 00:00:00 2001 From: saraqzhang Date: Thu, 31 Mar 2022 17:06:28 -0400 Subject: [PATCH 160/205] update atmos_eldas.csh corresponding to ldas FIRST_ENS_ID=1 modified: src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmos_eldas.csh --- .../NCEP_Etc/NCEP_enkf/scripts/gmao/atmos_eldas.csh | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmos_eldas.csh b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmos_eldas.csh index bb5de0fb..a9bd37d1 100755 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmos_eldas.csh +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmos_eldas.csh @@ -161,9 +161,12 @@ if ($lenkf_status =~ SUCCEEDED ) then # default name for AGCM: ldas_inc.yyyymmdd_hhnn00 @ n = 0 while ($n < $nmem) + #set lentag = `echo $n | awk '{printf "%04d", $1}'` + #echo $lentag + @ n++ set lentag = `echo $n | awk '{printf "%04d", $1}'` echo $lentag - @ n++ + set memtag = `echo $n | awk '{printf "%03d", $1}'` echo $memtag /bin/ln -s ${LINC_DIR}/Y${yyyy_a}/M${mm_a}/*.${lincr_native_name}${lentag}.$ldas_anlt[1]_${tttt_a}z.nc4\ From e6f0d631ecdd8fb9802711d9073312ec02e2fc87 Mon Sep 17 00:00:00 2001 From: saraqzhang Date: Thu, 31 Mar 2022 17:19:21 -0400 Subject: [PATCH 161/205] update atmos_eldas.csh corresponding to ldas FIRST_ENS_ID=1 --- .../NCEP_Etc/NCEP_enkf/scripts/gmao/atmos_eldas.csh | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmos_eldas.csh b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmos_eldas.csh index a9bd37d1..c0432218 100755 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmos_eldas.csh +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmos_eldas.csh @@ -161,8 +161,6 @@ if ($lenkf_status =~ SUCCEEDED ) then # default name for AGCM: ldas_inc.yyyymmdd_hhnn00 @ n = 0 while ($n < $nmem) - #set lentag = `echo $n | awk '{printf "%04d", $1}'` - #echo $lentag @ n++ set lentag = `echo $n | awk '{printf "%04d", $1}'` echo $lentag From e49487aa0dda2026aed729d6ee8aa8e4d940b8ed Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Tue, 5 Apr 2022 10:00:01 -0400 Subject: [PATCH 162/205] fix for roundoff issue in MAPL; fix for gridname in stoch-pert --- components.yaml | 4 ++-- .../NCEP_Etc/NCEP_enkf/scripts/gmao/setup_atmens.pl | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/components.yaml b/components.yaml index 435593be..2c02c3ec 100644 --- a/components.yaml +++ b/components.yaml @@ -28,13 +28,13 @@ NCEP_Shared: GMAO_Shared: local: ./src/Shared/@GMAO_Shared remote: ../GMAO_Shared.git - tag: rt1_4_10_geosit_3 + tag: rt1_4_10_stoch_grid_fix develop: main MAPL: local: ./src/Shared/@MAPL remote: ../MAPL.git - tag: v2.8.0.4 + tag: v2.8.0.7 develop: develop FMS: diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/setup_atmens.pl b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/setup_atmens.pl index 1f094977..e5741fd0 100755 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/setup_atmens.pl +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/setup_atmens.pl @@ -229,7 +229,7 @@ sub init { } elsif ($nodename eq "sky") { # $agcm_ncpus_per_node = 36; $enkf_cpus = 244; - $agcm_nx = 5; $agcm_ny = 24; + $agcm_nx = 3; $agcm_ny = 30; $miau_nx = 2; $miau_ny = 12; $obsv_nx = 4; $obsv_ny = 8; $stat_nx = 2; $stat_ny = 2; @@ -255,7 +255,7 @@ sub init { } elsif ($nodename eq "sky") { # $agcm_ncpus_per_node = 36; $enkf_cpus = 368; - $agcm_nx = 5; $agcm_ny = 24; + $agcm_nx = 4; $agcm_ny = 30; $miau_nx = 2; $miau_ny = 12; $obsv_nx = 4; $obsv_ny = 20; $stat_nx = 2; $stat_ny = 20; From 4c1733007ccd1b8c4c731b0737637bc5911acea0 Mon Sep 17 00:00:00 2001 From: gmao-msienkie Date: Mon, 18 Apr 2022 11:44:08 -0400 Subject: [PATCH 163/205] Bring in change to array size from obsproc_prep.v5.5.0 (Aug 2021) --- .../prepobs_prepacqc.fd/acftobs_qc.f | 75 ++++++++++++------- 1 file changed, 48 insertions(+), 27 deletions(-) diff --git a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/acftobs_qc.f b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/acftobs_qc.f index 0e5a03ef..c7771cc4 100644 --- a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/acftobs_qc.f +++ b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/acftobs_qc.f @@ -66,6 +66,18 @@ c - Intrinsic function "ifix" replaced with "int" for cases where the c argument is now a real*8 lat or lon (else compiler error if "ifix" c operates on a real*8 argument). +c 2020-08-20 J. Dong -- +c - Modified subroutine invalid_qc to correct a +c run-time error revealed when all debug options +c are enabled. When t_prcn has a missing value, +c 1.0000000E+09, multiplying by 100 exceeds the +c 32-bit signed integer maximum, 2,147,483,647. +c +c 2021-08-13 C. Hill / D. Stokes -- +c - Modified subroutine ordchk_qc to increase the +c array size of indx_save (from 200 to 1000). +c A working limit of 200 for indx_save is retained as a defined +c parameter for all quality checks preceding order_qc. c c BEST VIEWED WITH 94-CHARACTER WIDTH WINDOW ccccc @@ -11410,7 +11422,7 @@ subroutine invalid_qc(numreps,max_reps,c_acftreg,c_acftid,c_qc c write(io8,*) ' ht_ft = ',ht_ft(ii) c write(io8,*) ' ids = ',c_acftreg(ii),c_acftid(ii) c - if(ifix(t_prcn(ii)*100).eq.100.and. + if(t_prcn(ii).eq.1.and. $ itype(ii).eq.i_mdcrs) then c if(iob.eq.1) then @@ -18412,6 +18424,11 @@ subroutine ordchek_qc(numreps,max_reps,indx,csort,imiss,amiss c As data resolution has increased, some aspects of the track (such c as deciding a point is going backwards) have become less meaningful. c Changes were made to reduce the number of false positives. +c +c C. Hill/ D. Stokes 08/13/21 +c The array size of indx_save is increased (from 200 to 1000). +c A working limit of 200 for indx_save is retained as a defined +c parameter for all quality checks preceding order_qc. c implicit none c @@ -18820,7 +18837,9 @@ subroutine ordchek_qc(numreps,max_reps,indx,csort,imiss,amiss real vspd_thresh ! threshold vertical speed of aircraft $, vspd_bounce ! threshold vertical speed used in bounce test c - integer indx_save(200) ! pointer indices for rejected reports + integer maxll,llim ! parameterized limits for indx_save CH 2021 + parameter (maxll=1000,llim=200) + integer indx_save(maxll) ! pointer indices for rejected reports $, ll ! index for indx_save $, keep ! variable used in saving indices $, knt_bad ! number of reports in potential second flight @@ -21056,7 +21075,7 @@ subroutine ordchek_qc(numreps,max_reps,indx,csort,imiss,amiss c c_qc(ii)(2:2) = 'K' ll = ll + 1 - if(ll.gt.200) then + if(ll.gt.llim) then write(io8,*) 'll limit exceeded--indx not saved!', $ ii else @@ -21088,7 +21107,7 @@ subroutine ordchek_qc(numreps,max_reps,indx,csort,imiss,amiss c c_qc(iip1)(2:2) = 'K' ll = ll + 1 - if(ll.gt.200) then + if(ll.gt.llim) then write(io8,*) 'll limit exceeded--indx not saved!', $ iip1 else @@ -21134,7 +21153,7 @@ subroutine ordchek_qc(numreps,max_reps,indx,csort,imiss,amiss c_qc(iip1)(1:1) = 'p' c_qc(iip1)(3:4) = 'II' ll = ll + 1 - if(ll.gt.200) then + if(ll.gt.llim) then write(io8,*) 'll limit exceeded--indx not saved!', $ iip1 else @@ -21215,7 +21234,7 @@ subroutine ordchek_qc(numreps,max_reps,indx,csort,imiss,amiss c else ll = ll + 1 - if(ll.gt.200) then + if(ll.gt.llim) then write(io8,*) 'll limit exceeded--indx not saved!', $ ii else @@ -21294,7 +21313,7 @@ subroutine ordchek_qc(numreps,max_reps,indx,csort,imiss,amiss c else ll = ll + 1 - if(ll.gt.200) then + if(ll.gt.llim) then write(io8,*) 'll limit exceeded--indx not saved!', $ iip1 else @@ -21386,7 +21405,7 @@ subroutine ordchek_qc(numreps,max_reps,indx,csort,imiss,amiss c_qc(iip1)(5:5) = 'I' endif ll = ll + 1 - if(ll.gt.200) then + if(ll.gt.llim) then write(io8,*) 'll limit exceeded--indx not saved!', $ iip1 else @@ -21432,7 +21451,7 @@ subroutine ordchek_qc(numreps,max_reps,indx,csort,imiss,amiss c_qc(ii)(1:1) = 'P' c_qc(ii)(3:4) = 'II' ll = ll + 1 - if(ll.gt.200) then + if(ll.gt.llim) then write(io8,*) 'll limit exceeded--indx not saved!', $ ii else @@ -21443,7 +21462,7 @@ subroutine ordchek_qc(numreps,max_reps,indx,csort,imiss,amiss c_qc(iip1)(1:1) = 'P' c_qc(iip1)(3:4) = 'II' ll = ll + 1 - if(ll.gt.200) then + if(ll.gt.llim) then write(io8,*) 'll limit exceeded--indx not saved!', $ iip1 else @@ -22196,7 +22215,7 @@ subroutine ordchek_qc(numreps,max_reps,indx,csort,imiss,amiss c c_qc(iip1)(2:2) = 'K' ll = ll + 1 - if(ll.gt.200) then + if(ll.gt.llim) then write(io8,*) 'll limit exceeded--indx not saved!', $ iip1 else @@ -22206,7 +22225,7 @@ subroutine ordchek_qc(numreps,max_reps,indx,csort,imiss,amiss c c_qc(iip2)(2:2) = 'K' ll = ll + 1 - if(ll.gt.200) then + if(ll.gt.llim) then write(io8,*) 'll limit exceeded--indx not saved!' $ ,iip2 else @@ -22277,7 +22296,7 @@ subroutine ordchek_qc(numreps,max_reps,indx,csort,imiss,amiss c_qc(ii)(3:4) = 'II' c ll = ll + 1 - if(ll.gt.200) then + if(ll.gt.llim) then write(io8,*) 'll limit exceeded--indx not saved!', $ ii else @@ -22334,7 +22353,7 @@ subroutine ordchek_qc(numreps,max_reps,indx,csort,imiss,amiss c_qc(iip1)(3:4) = 'II' c ll = ll + 1 - if(ll.gt.200) then + if(ll.gt.llim) then write(io8,*) 'll limit exceeded--indx not saved!', $ iip1 else @@ -22432,7 +22451,7 @@ subroutine ordchek_qc(numreps,max_reps,indx,csort,imiss,amiss c_qc(iip1)(3:4) = 'II' c ll = ll + 1 - if(ll.gt.200) then + if(ll.gt.llim) then write(io8,*) 'll limit exceeded--indx not saved!' $ ,iip1 else @@ -22443,7 +22462,7 @@ subroutine ordchek_qc(numreps,max_reps,indx,csort,imiss,amiss c_qc(iip2)(1:1) = 'P' c_qc(iip2)(3:4) = 'II' ll = ll + 1 - if(ll.gt.200) then + if(ll.gt.llim) then write(io8,*) 'll limit exceeded--indx not saved!' $ ,iip2 else @@ -22482,7 +22501,7 @@ subroutine ordchek_qc(numreps,max_reps,indx,csort,imiss,amiss c_qc(iip1)(3:4) = 'II' c ll = ll + 1 - if(ll.gt.200) then + if(ll.gt.llim) then write(io8,*) 'll limit exceeded--indx not saved!', $ ii else @@ -22513,7 +22532,7 @@ subroutine ordchek_qc(numreps,max_reps,indx,csort,imiss,amiss c_qc(ii)(1:1) = 'P' c_qc(ii)(3:4) = 'II' ll = ll + 1 - if(ll.gt.200) then + if(ll.gt.llim) then write(io8,*) 'll limit exceeded--indx not saved!', $ ii else @@ -22524,7 +22543,7 @@ subroutine ordchek_qc(numreps,max_reps,indx,csort,imiss,amiss c_qc(iip1)(1:1) = 'P' c_qc(iip1)(3:4) = 'II' ll = ll + 1 - if(ll.gt.200) then + if(ll.gt.llim) then write(io8,*) 'll limit exceeded--indx not saved!', $ iip1 else @@ -22571,7 +22590,7 @@ subroutine ordchek_qc(numreps,max_reps,indx,csort,imiss,amiss endif c ll = ll + 1 - if(ll.gt.200) then + if(ll.gt.llim) then write(io8,*) 'll limit exceeded--indx not saved!', $ ii else @@ -22587,7 +22606,7 @@ subroutine ordchek_qc(numreps,max_reps,indx,csort,imiss,amiss endif c ll = ll + 1 - if(ll.gt.200) then + if(ll.gt.llim) then write(io8,*) 'll limit exceeded--indx not saved!', $ iip1 else @@ -22733,7 +22752,7 @@ subroutine ordchek_qc(numreps,max_reps,indx,csort,imiss,amiss c_qc(iip1)(5:5) = 'I' endif ll = ll + 1 - if(ll.gt.200) then + if(ll.gt.llim) then write(io8,*) 'll limit exceeded--indx not saved!', $ iip1 else @@ -22748,7 +22767,7 @@ subroutine ordchek_qc(numreps,max_reps,indx,csort,imiss,amiss c_qc(iip2)(5:5) = 'I' endif ll = ll + 1 - if(ll.gt.200) then + if(ll.gt.llim) then write(io8,*) 'll limit exceeded--indx not saved!', $ iip2 else @@ -22803,7 +22822,7 @@ subroutine ordchek_qc(numreps,max_reps,indx,csort,imiss,amiss c_qc(ii)(5:5) = 'I' endif ll = ll + 1 - if(ll.gt.200) then + if(ll.gt.llim) then write(io8,*) 'll limit exceeded--indx not saved!', $ ii else @@ -22859,7 +22878,7 @@ subroutine ordchek_qc(numreps,max_reps,indx,csort,imiss,amiss c_qc(iip1)(5:5) = 'I' endif ll = ll + 1 - if(ll.gt.200) then + if(ll.gt.llim) then write(io8,*) 'll limit exceeded--indx not saved!', $ iip1 else @@ -22895,7 +22914,7 @@ subroutine ordchek_qc(numreps,max_reps,indx,csort,imiss,amiss endif c ll = ll + 1 - if(ll.gt.200) then + if(ll.gt.llim) then write(io8,*) 'll limit exceeded--indx not saved!', $ ii else @@ -22911,7 +22930,7 @@ subroutine ordchek_qc(numreps,max_reps,indx,csort,imiss,amiss endif c ll = ll + 1 - if(ll.gt.200) then + if(ll.gt.llim) then write(io8,*) 'll limit exceeded--indx not saved!', $ iip1 else @@ -23325,6 +23344,8 @@ subroutine ordchek_qc(numreps,max_reps,indx,csort,imiss,amiss c write(io8,*) 'Skipping report from 2nd flt',ii ll = ll + 1 indx_save(ll) = ii +c Adding condition for ll increment CH 2021 + if(ll.ge.maxll) cycle c c If report not rejected... c ------------------------- From 8fc3e2b7bd1acb07a2e490df1f71b42edd3f3d83 Mon Sep 17 00:00:00 2001 From: gmao-msienkie Date: Mon, 18 Apr 2022 11:45:20 -0400 Subject: [PATCH 164/205] Updated README --- src/Applications/NCEP_Paqc/oiqc/README | 46 ++++++++++++++++++++++++++ 1 file changed, 46 insertions(+) diff --git a/src/Applications/NCEP_Paqc/oiqc/README b/src/Applications/NCEP_Paqc/oiqc/README index 7a55b2c6..1f57b2b9 100755 --- a/src/Applications/NCEP_Paqc/oiqc/README +++ b/src/Applications/NCEP_Paqc/oiqc/README @@ -27,3 +27,49 @@ execution of 'fv2ss.x' as an interim solution until we can replace New script "gmao_prepqc" replaces "ssprepqc" - we can now read the g5-eta files directly into the 'prevents' routine and so can eliminate 'fv2ss' step + + +2 Sep 2008 +Merged in modifications from NCEP to increase array sizes - allows handling +additional observations. Also includes J. Woollen fix to NDDSPLIT for load +balancing error. + +31 Jan 2012 + +Modify to use 'new' quality mark QMN instead of original mark QM, when writing +SSM/I wind speed data record. This will allow quality marks assigned by OIQC +to SSM/I windspeeds to be recorded in the output file. + +24 Sep 2013 + +Merge in changes for WCOSS (except subroutine PREPQM). Code now is +strictly MPI for simpler and better load balancing. New WCOSS code had +problem in PREPQM where events on last ob were not written so is not (yet) +updated. + +19 May 2017 + +Add call to 'maxout' to increase maximum BUFR record size for output. +Some raobs were being discarded from CQC/RADCOR because of overlarge +BUFR record sizes. + +2 Jan 2018 + +Bump up array limits to accomodate increasing numbers of obs +MAXREP 900K to 1500K, MAXLEV 1100K to 2200K + +5 Feb 2019 + +Added a change to allow calculation of forecast errors for wind observations +above 1 mb. (Will set the pressure level used to 1 mb.) + +20 Jan 2021 + +Modificatons to use 10-digit date from BUFR library instead of 8-digit default + +--- +26 May 2017 + +New version of gmao_prepqc to run new NRL QC instead of old acqc and acarsqc. + + From 285f493133f7ae02e5b2866678146d4fb9aa7809 Mon Sep 17 00:00:00 2001 From: Amal El Akkraoui Date: Thu, 28 Apr 2022 15:12:48 -0400 Subject: [PATCH 165/205] adds updates to handle GEOS-IT and GEOS-R21C system configurations --- src/Applications/GEOSdas_App/fvsetup | 133 ++++++++---- src/Applications/GEOSdas_App/gen_lnbcs.pl | 4 + .../GEOSdas_App/write_FVDAS_Run_Config.pl | 4 +- .../NCEP_enkf/scripts/gmao/etc/CMakeLists.txt | 11 + .../scripts/gmao/etc/R21C/atmos_enkf.nml.tmpl | 142 +++++++++++++ .../scripts/gmao/etc/R21C/obs1gsi_mean.rc | 195 ++++++++++++++++++ .../scripts/gmao/etc/R21C/obs1gsi_member.rc | 185 +++++++++++++++++ .../NCEP_enkf/scripts/gmao/setup_atmens.pl | 9 +- 8 files changed, 639 insertions(+), 44 deletions(-) create mode 100644 src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/R21C/atmos_enkf.nml.tmpl create mode 100644 src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/R21C/obs1gsi_mean.rc create mode 100644 src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/R21C/obs1gsi_member.rc diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index 9ad7eb59..94ccefce 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -1216,11 +1216,12 @@ sub get_specific_info { $r21c = 0; $ans = query(" Is this a MERRA2 (1), GEOSIT (2), R21C (3) experiment?", "0"); - return 0 unless ( $ans ); +# return 0 unless ( $ans ); if ($ans == 1) {$merra2 = 1}; if ($ans == 2) {$geosit = 1}; if ($ans == 3) {$r21c = 1}; + return 0; } @@ -2607,6 +2608,7 @@ EOF #======================================================================= sub get_lsmodel { + my $lndbcs_r21c = "Icarus-NLv3"; my $lndbcs_def = "Icarus_Updated"; my $lsdflt = 1; my $rrdflt = 0; @@ -2629,8 +2631,11 @@ LAND BCS Version EOF ; - - $landbcs = query(" Land Boundary Conditions?", $lndbcs_def); + if ( $r21c) { + $landbcs = query(" Land Boundary Conditions?", $lndbcs_r21c); + } else { + $landbcs = query(" Land Boundary Conditions?", $lndbcs_def); + } if ( "$landbcs" eq "Icarus-NLv3" ) { @@ -3138,6 +3143,7 @@ sub get_times { $asynbkg_min = 60; # time frequency of background fields (min) } else { $asynbkg_min = 180; # time frequency of background fields (min) + if ( $r21c) { $asynbkg_min = 60}; } } else { $splite = 0; $splitexe = 0; @@ -3256,8 +3262,7 @@ EOF $asynbkg_hms = sprintf("%6.6d","$asynbkg_hms"); #print "asynbkg_hms = $asynbkg_hms \n"; } - $pcp_forced = $merra2; # for now, we attach these two choices (it can be that PCP-forcing will be applied - # for other non-MERRA2-like runs, but not for a while ... + $pcp_forced = ($merra2 or $r21c ); $beg_date = "$nymdb $nhmsb" ; # GEOS-5 GCM starting date parameter $end_date = "$nymde $nhmse" ; # GEOS-5 GCM ending date parameter @@ -3321,6 +3326,7 @@ sub set_radcor { if ($obClass =~ "merra_upa_pre-qc_bufr" || $obClass =~ "merra_cdas_pre-qc_bufr" || $obClass =~ "merra2_cdas0_pre-qc_bufr" || $obClass =~ "merra2_upa_pre-qc_bufr" || $obClass =~ "merra2_cdas_pre-qc_bufr" ) { $radcor = "HAIMB_HRAD" }; + if($geosit || $r21c) {$radcor = "HAIMB_HRAD"}; # query user for radcor choice #----------------------------- @@ -3438,6 +3444,7 @@ sub get_setgsi { $anaexec = "GSIsa.x"; $hybrid = ".false."; $hyb_ens = -1; + if ($r21c) { $hyb_ens = 4} if ($merra2) { $nosfcana = 0 } # will apply similarity to produce xana.sfc else { $nosfcana = 1 } # will not generation xana.sfc @@ -3557,7 +3564,11 @@ sub set_atmens { # defaults (here for now) # ----------------------- - $aens_replay = "yes"; + if ($r21c) { + $aens_replay = "no"; + } else { + $aens_replay = "yes"; + } $aens_sppt = "yes"; $aens_res = "C90"; $aens_lev = "72"; @@ -3630,7 +3641,10 @@ EOF # If so, setup EnADAS # ------------------- - $flags = "-nlevs $aens_lev $setacftbc $rcorrarg $setradbc $aens_lsmodel -expdir $fvhome/.. $sppt_flag"; + if ($r21c) { + $bcopt = "-r21c"; + } + $flags = "-nlevs $aens_lev $setacftbc $rcorrarg $setradbc $aens_lsmodel -expdir $fvhome/.. $sppt_flag $bcopt"; $flags .= " -fvhome $fvhome" if $checkFLG; $params = " $aens_ana $expid $aens_im $aens_jm $aens_ocn $landbcs"; @@ -3805,11 +3819,13 @@ sub get_obsys { } elsif ($ans == 4) { # GEOS-IT $obsysrc = "$fvetc/obsys-${loc}-geosit.rc"; -# $rflags .= " -stem geosit"; + $obsysGrc = "$fvetc/obsys-${loc}-gaas-geosit.rc"; + $rflags .= " -stem geosit"; } elsif ($ans == 5) { # R21C $obsysrc = "$fvetc/obsys-${loc}-r21c.rc"; -# $rflags .= " -stem r21c"; + $obsysGrc = "$fvetc/obsys-${loc}-gaas-r21c.rc"; + $rflags .= " -stem r21c"; } $reqobs = $fvbin . "/require_obsys.pl"; @@ -4263,11 +4279,13 @@ EOF $emission{"4"} = "OPS"; $emission{"5"} = "PIESA"; $emission{"6"} = "GEOSIT"; + $emission{"7"} = "R21C"; %remission = reverse %emission; if ($nrt) { $dflt = "OPS" } elsif ($merra2) { $dflt = "MERRA2" } elsif ($geosit) { $dflt = "GEOSIT" } + elsif ($r21c) { $dflt = "R21C" } else { $dflt = "PIESA" } if ($gocart_tracers) { @@ -4670,6 +4688,9 @@ sub get_dimsg5gcm { $res = "C48"; $vres = 72; if ( $merra2 ) { $ores = "e34" } + elsif ($r21c) { $ores = "C"; + $res = "C360"; + } else { $ores = "f" } print <<"EOF"; @@ -5448,6 +5469,7 @@ sub archiving_rules { \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_msu_%c%c%c_%c%c%c.%y4%m2%d2_%h2z.bin \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_msu_tirosn_%c%c%c.%y4%m2%d2_%h2z.bin \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_omi_aura_%c%c%c.%y4%m2%d2_%h2z.bin +\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_ompslp_g_npp_%c%c%c.%y4%m2%d2_%h2z.bin \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_ompslpuv_npp_%c%c%c.%y4%m2%d2_%h2z.bin \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_ompslpvis_npp_%c%c%c.%y4%m2%d2_%h2z.bin \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_ompsnm_npp_%c%c%c.%y4%m2%d2_%h2z.bin @@ -5505,6 +5527,7 @@ sub archiving_rules { \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_msu_%c%c%c.%y4%m2%d2_%h2z.ods \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_msu_tirosn.%y4%m2%d2_%h2z.ods \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_omi_aura.%y4%m2%d2_%h2z.ods +\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_ompslp_g_npp.%y4%m2%d2_%h2z.ods \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_ompslpuv_npp.%y4%m2%d2_%h2z.ods \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_ompslpvis_npp.%y4%m2%d2_%h2z.ods \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_ompsnm_npp.%y4%m2%d2_%h2z.ods @@ -5561,6 +5584,7 @@ sub archiving_rules { \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp0hr_diag_msu_%c%c%c.%y4%m2%d2_%h2z.ods \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp0hr_diag_msu_tirosn.%y4%m2%d2_%h2z.ods \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp0hr_diag_omi_aura.%y4%m2%d2_%h2z.ods +\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp0hr_diag_ompslp_g_npp.%y4%m2%d2_%h2z.ods \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp0hr_diag_ompslpuv_npp.%y4%m2%d2_%h2z.ods \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp0hr_diag_ompslpvis_npp.%y4%m2%d2_%h2z.ods \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp0hr_diag_ompsnm_npp.%y4%m2%d2_%h2z.ods @@ -5601,10 +5625,11 @@ sub archiving_rules { #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_seviri_m%c%c_%c%c%c_%c%c%c_%c%c%c%c.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.bin #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_sbuv%c_%c%c%c_%c%c%c_%c%c%c%c.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.bin #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_omi_aura_%c%c%c_%c%c%c%c.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.bin +#\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_ompslp_g_npp_%c%c%c_%c%c%c%c.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.bin #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_ompslpuv_npp_%c%c%c_%c%c%c%c.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.bin #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_ompslpvis_npp_%c%c%c_%c%c%c%c.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.bin -#\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_ompslpnm_npp_%c%c%c_%c%c%c%c.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.bin -#\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_ompslpnp_npp_%c%c%c_%c%c%c%c.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.bin +#\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_ompsnm_npp_%c%c%c_%c%c%c%c.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.bin +#\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_ompsnp_npp_%c%c%c_%c%c%c%c.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.bin #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_hirs%c_%c%c%c_%c%c%c_%c%c%c%c.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.bin #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_hirs%c_metop-%c_%c%c%c_%c%c%c%c.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.bin #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_hirs%c_tirosn_%c%c%c_%c%c%c%c.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.bin @@ -5637,10 +5662,11 @@ sub archiving_rules { #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_pcp_tmi_%c%c%c%c_%c%c%c_%c%c%c%c.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_sbuv%c_%c%c%c_%c%c%c_%c%c%c%c.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_omi_aura_%c%c%c_%c%c%c%c.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods +#\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_ompslp_g_npp_%c%c%c_%c%c%c%c.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_ompslpuv_npp_%c%c%c_%c%c%c%c.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_ompslpvis_npp_%c%c%c_%c%c%c%c.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods -#\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_ompslpnm_npp_%c%c%c_%c%c%c%c.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods -#\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_ompslpnp_npp_%c%c%c_%c%c%c%c.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods +#\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_ompsnm_npp_%c%c%c_%c%c%c%c.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods +#\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_ompsnp_npp_%c%c%c_%c%c%c%c.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_hirs%c_%c%c%c_%c%c%c_%c%c%c%c.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_hirs%c_metop-%c_%c%c%c_%c%c%c_%c%c%c%c.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_hirs%c_tirosn_%c%c%c_%c%c%c_%c%c%c%c.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods @@ -5674,10 +5700,11 @@ sub archiving_rules { #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_pcp_tmi_%c%c%c%c_%c%c%c_%c%c%c%c.sigo.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_sbuv%c_%c%c%c_%c%c%c_%c%c%c%c.sigo.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_omi_aura_%c%c%c_%c%c%c%c.sigo.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods +#\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_ompslp_g_npp_%c%c%c_%c%c%c%c.sigo.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_ompslpuv_npp_%c%c%c_%c%c%c%c.sigo.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_ompslpvis_npp_%c%c%c_%c%c%c%c.sigo.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods -#\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_ompslpnm_npp_%c%c%c_%c%c%c%c.sigo.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods -#\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_ompslpnp_npp_%c%c%c_%c%c%c%c.sigo.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods +#\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_ompsnm_npp_%c%c%c_%c%c%c%c.sigo.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods +#\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_ompsnp_npp_%c%c%c_%c%c%c%c.sigo.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_hirs%c_%c%c%c_%c%c%c_%c%c%c%c.sigo.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_hirs%c_metop-%c_%c%c%c_%c%c%c_%c%c%c%c.sigo.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_hirs%c_tirosn_%c%c%c_%c%c%c_%c%c%c%c.sigo.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods @@ -6868,10 +6895,11 @@ sub arch_asens { \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_msu_tirosn.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_omi_aura.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_omieff_aura.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods +\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_ompslp_g_npp.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_ompslpuv_npp.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_ompslpvis_npp.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods -\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_ompslpnm_npp.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods -\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_ompslpnp_npp.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods +#\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_ompslpnm_npp.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods +#\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_ompslpnp_npp.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_ompsnm_npp.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_ompsnmeff_npp.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_ompsnp_npp.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods @@ -7451,12 +7479,16 @@ close(SCRIPT); #======================================================================= sub build_lnbcs { - $mymerra2 = ""; - if ( $merra2 ) { $mymerra2 = "-merra2" }; + $bcopt = ""; + if ( $merra2 ) { + $bcopt = "-merra2" ; + }elsif ( $r21c ) { + $bcopt = "-r21c"; + } if ( $cubed ) { - $cmd = "$fvbin/gen_lnbcs.pl -fvhome $fvhome -o lnbcs $mymerra2 -cubed $agcm_im $agcm_jm $ores $landbcs"; + $cmd = "$fvbin/gen_lnbcs.pl -fvhome $fvhome -o lnbcs $bcopt -cubed $agcm_im $agcm_jm $ogcm $landbcs"; } else { - $cmd = "$fvbin/gen_lnbcs.pl -fvhome $fvhome -o lnbcs $mymerra2 $agcm_im $agcm_jm $ores $landbcs"; + $cmd = "$fvbin/gen_lnbcs.pl -fvhome $fvhome -o lnbcs $bcopt $agcm_im $agcm_jm $ogcm $landbcs"; } print "$cmd\n"; system($cmd); @@ -8685,8 +8717,9 @@ sub write_FVDAS_Run_Config { $ENV{"VTXLEVS"} = $vtxlevs; $ENV{"VTXRELOC"} = $vtxreloc; - if ($geosit | $r21c) { + if ($geosit || $r21c) { $ENV{"MKSI_SIDB"} = "\$FVHOME/run/gmao_satinfo.db"; + $ENV{"MKSI_OZDB"} = "\$FVHOME/run/gmao_ozinfo.db"; } unless ( $ENV{"ARCHIVE"} ) { @@ -9734,6 +9767,7 @@ sub init_agcm_rc { # default is based on NCA settings (but line is commented since we don't want this done) if ( $pcp_forced ) { $pcp_fntmpl = "d5_merra/Y%y4/M%m2/d5_merra.tavg1_2d_lfo_Nx_corr.%y4%m2%d2_%h230z.nc"; + #if (r21c) { $pcp_fntmpl = " "}; # ADD when pcp files are ready } else { if ( $nymd < 19890101 ) { $pcp_fntmpl = "d5_merra_jan79/diag/Y%y4/d5_merra_jan79.tavg1_2d_lfo_Nx_corr.%y4%m2%d2_%h230z.nc"; @@ -10062,6 +10096,26 @@ sub copy_resources { # Create daotovs_fv.rc in FVHOME/run # ed_daotovs_fv(); + # When applicable, overwrite w/ templated RC files for GSI + # ------------------------------------------------------ + if ( $r21c ){ + if ( -d "$fvetc/gsi/R21C" ) { + my @files = glob("$fvetc/gsi/R21C" . "/*"); + foreach my $fn ( @files ) { + cp("$fn", "$fvhome/run"); + } + } + if ( -d "$fvetc/atmens/R21C" ){ + my @files = glob("$fvetc/atmens/R21C" . "/*"); + foreach my $fn ( @files ) { + cp("$fn","$fvhome/run/atmens"); + } + } + } + # Update gocart files for pre-2000 case + # To Be Done + # + # Edit psas.rc ed_psas_rc(); @@ -10166,34 +10220,29 @@ sub copy_resources { cp("$fn", "$fvhome/run"); } } + } + if ( $r21c ) { $casedir = "R21C" }; + if ( $geosit ) { $casedir = "GEOSIT"}; + if ( $r21c || $geosit ){ mkdir ("$fvhome/run/gmao_satinfo.db"); - if ( -d "$fvetc/gmao_satinfo.db/GEOSIT" ) { - my @files = glob("$fvetc/gmao_satinfo.db/GEOSIT" . "/*"); - foreach my $fn ( @files ) { - cp("$fn", "$fvhome/run/gmao_satinfo.db"); - } + if ( -d "$fvetc/gmao_satinfo.db/$casedir" ) { + my @files = glob("$fvetc/gmao_satinfo.db/$casedir" . "/*"); + foreach my $fn ( @files ) { + cp("$fn", "$fvhome/run/gmao_satinfo.db"); + } } else { - die "Cannot find GEOSIT sat.db under $fvetc, aborting ..."; - } - } - if ( $r21c ) { - if ( -d "$fvetc/gsi/R21C" ) { - my @files = glob("$fvetc/gsi/R21C" . "/*"); - foreach my $fn ( @files ) { - cp("$fn", "$fvhome/run"); - } + die "Cannot find $casedir sat.db under $fvetc, aborting ..."; } - mkdir ("$fvhome/run/gmao_satinfo.db"); - if ( -d "$fvetc/gmao_satinfo.db/R21C" ) { - my @files = glob("$fvetc/gmao_satinfo.db/R21C" . "/*"); + mkdir ("$fvhome/run/gmao_ozinfo.db"); + if ( -d "$fvetc/gmao_ozinfo.db/$casedir" ) { + my @files = glob("$fvetc/gmao_ozinfo.db/$casedir" . "/*"); foreach my $fn ( @files ) { - cp("$fn", "$fvhome/run/gmao_satinfo.db"); + cp("$fn", "$fvhome/run/gmao_ozinfo.db"); } } else { - die "Cannot find R21C sat.db under $fvetc, aborting ..."; + die "Cannot find $casedir oz.db under $fvetc, aborting ..."; } } - } #======================================================================= diff --git a/src/Applications/GEOSdas_App/gen_lnbcs.pl b/src/Applications/GEOSdas_App/gen_lnbcs.pl index dbefbc6e..6dcca493 100755 --- a/src/Applications/GEOSdas_App/gen_lnbcs.pl +++ b/src/Applications/GEOSdas_App/gen_lnbcs.pl @@ -32,6 +32,7 @@ "sstdir=s", "cubed", "merra2", + "r21c", "h" ); usage() if $opt_h; @@ -80,6 +81,8 @@ sub init { if ( $opt_merra2 ) { $pcp_loc = "/discover/nobackup/projects/gmao/share/dao_ops/fvInput/merra_land/precip_CPCUexcludeAfrica-CMAP_corrected_MERRA/GEOSdas-2_1_4"; +} elsif ( $opt_r21c ) { # This will updated + $pcp_loc = "/discover/nobackup/projects/gmao/share/dao_ops/fvInput/merra_land/precip_CPCUexcludeAfrica-CMAP_corrected_MERRA/GEOSdas-2_1_4"; } else { $pcp_loc = "/gpfsm/dnb51/projects/p15/iau/merra_land/precip_CPCU-CMAP_corrected_MERRA/GEOSdas-2_1_4"; } @@ -425,6 +428,7 @@ sub usage { -fvhome location of FVHOME (default: write script locally) -cubed needed for cubed GCM -merra2 specify to set related BCs + -r21c specify to set related BCs -h prints this usage notice EXAMPLE COMMAND LINE diff --git a/src/Applications/GEOSdas_App/write_FVDAS_Run_Config.pl b/src/Applications/GEOSdas_App/write_FVDAS_Run_Config.pl index 12598afd..5e9a5b8a 100755 --- a/src/Applications/GEOSdas_App/write_FVDAS_Run_Config.pl +++ b/src/Applications/GEOSdas_App/write_FVDAS_Run_Config.pl @@ -14,7 +14,7 @@ my ($ARCH, $HOST); my ($FVHOME, $FVROOT, $RUNDIR); my ($AOD_OBSCLASS, $BERROR, $DO_ECS_OUT, $DO_REM_SYNC, $EXPID, $FVARCH, - $FVBCS, $GID, $MONTHLY_MEANS, $MKSI_SIDB, $MP_SET_NUMTHREADS, $NCEPINPUT, $NOBACKUP, + $FVBCS, $GID, $MONTHLY_MEANS, $MKSI_SIDB, $MKSI_OZDB, $MP_SET_NUMTHREADS, $NCEPINPUT, $NOBACKUP, $OBSCLASS, $OBSCLASS_NOAIRS, $OMP_NUM_THREADS, $RUN_QUADS, $PYRADMON, $VTRACK, $VTXLEVS, $VTXRELOC); my ($BASEDIR, $FCSTID, $FVDMGET, $G5MODULES, $PLOTS_LOC, $GEOSUTIL, $GTAG); @@ -93,6 +93,7 @@ sub init { $GID = $ENV{"GID"}; $MONTHLY_MEANS = $ENV{"MONTHLY_MEANS"}; $MKSI_SIDB = $ENV{"MKSI_SIDB"}; + $MKSI_OZDB = $ENV{"MKSI_OZDB"}; $MP_SET_NUMTHREADS = $ENV{"MP_SET_NUMTHREADS"}; $NCEPINPUT = $ENV{"NCEPINPUT"}; $OBSCLASS = $ENV{"OBSCLASS"}; @@ -323,6 +324,7 @@ sub writefile { print RUNCONF "setenv FVDOLMS $FVDOLMS\n" if $FVDOLMS; print RUNCONF "setenv CASE $CASE\n" if $CASE; print RUNCONF "setenv MKSI_SIDB $MKSI_SIDB\n" if $MKSI_SIDB; + print RUNCONF "setenv MKSI_OZDB $MKSI_OZDB\n" if $MKSI_OZDB; print RUNCONF "setenv MP_SET_NUMTHREADS $MP_SET_NUMTHREADS\n" if $MP_SET_NUMTHREADS; print RUNCONF "setenv OMP_NUM_THREADS $OMP_NUM_THREADS\n" if $OMP_NUM_THREADS; print RUNCONF "setenv ARCH_QUEUE \"$ARCH_QUEUE\"\n" if $ARCH_QUEUE; diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/CMakeLists.txt b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/CMakeLists.txt index 949528ab..6a0f7409 100644 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/CMakeLists.txt +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/CMakeLists.txt @@ -39,3 +39,14 @@ install ( FILES ${ALLETC} DESTINATION etc/atmens ) + +set (R21C_files + R21C/atmos_enkf.nml.tmpl + R21C/obs1gsi_mean.rc + R21C/obs1gsi_member.rc + ) + +install ( + FILES ${R21C_files} + DESTINATION etc/atmens/R21C + ) diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/R21C/atmos_enkf.nml.tmpl b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/R21C/atmos_enkf.nml.tmpl new file mode 100644 index 00000000..04172e78 --- /dev/null +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/R21C/atmos_enkf.nml.tmpl @@ -0,0 +1,142 @@ +&nam_enkf + datestring=">>>YYYYMMDDHH<<<",datapath="./", + expid=">>>EXPID<<<", + analpertwtnh=0.85,analpertwtsh=0.85,analpertwttr=0.85, + covinflatemax=1.e2,covinflatemin=1,pseudo_rh=.true., + corrlengthnh=2000,corrlengthsh=2000,corrlengthtr=2000, + lnsigcutoffnh=2.0,lnsigcutoffsh=2.0,lnsigcutofftr=2.0, + lnsigcutoffsatnh=2.0,lnsigcutoffsatsh=2.0,lnsigcutoffsattr=2.0, + lnsigcutoffpsnh=2.0,lnsigcutoffpssh=2.0,lnsigcutoffpstr=2.0, + obtimelnh=1.e30,obtimelsh=1.e30,obtimeltr=1.e30, + saterrfact=1.0,numiter=1, + sprd_tol=1.e30,paoverpb_thresh=0.990,iassim_order=0, + nlevs=>>>ENS_NLEVS<<<,nanals=>>>NMEM<<<, + nsfcvars=2, +! ntrac=3, + nvars=9, + stats_usedob_only=.true., + deterministic=.true.,sortinc=.true.,lupd_satbiasc=.false., + readin_localization=.true., + nlats=>>>ENS_NLATS<<<,nlons=>>>ENS_NLONS<<<, +! nhr_anal(1)=3, +! nhr_anal(2)=4, +! nhr_anal(3)=5, +! nhr_anal(4)=6, +! nhr_anal(5)=7, +! nhr_anal(6)=8, +! nhr_anal(7)=9, +@RADBC newpc4pred=.true.,adp_anglebc=.true.,angord=4, +@RADBC use_edges=.false.,emiss_bc=.true., +! +! forward EFSO + fso_flag = .false., + fso_cycling = .true., + / +&satobs_enkf + sattypes_rad(1) = 'amsua_n15', dsis(1) = 'amsua_n15', + sattypes_rad(2) = 'amsub_n15', dsis(2) = 'amsub_n15', + sattypes_rad(3) = 'hirs3_n16', dsis(3) = 'hirs3_n16', + sattypes_rad(4) = 'amsua_n16', dsis(4) = 'amsua_n16', + sattypes_rad(5) = 'amsub_n16', dsis(5) = 'amsub_n16', + sattypes_rad(6) = 'hirs3_n17', dsis(6) = 'hirs3_n17', + sattypes_rad(7) = 'amsua_n17', dsis(7) = 'amsua_n17', + sattypes_rad(8) = 'amsub_n17', dsis(8) = 'amsub_n17', + sattypes_rad(9) = 'hirs4_n18', dsis(9) = 'hirs4_n18', + sattypes_rad(10)= 'amsua_n18', dsis(10)= 'amsua_n18', +! sattypes_rad(11)= 'amsub_n18', dsis(11)= 'amsub_n18', + sattypes_rad(12)= 'mhs_n18', dsis(12)= 'mhs_n18', + sattypes_rad(13)= 'hirs4_n19', dsis(13)= 'hirs4_n19', + sattypes_rad(14)= 'amsua_n19', dsis(14)= 'amsua_n19', +! sattypes_rad(15)= 'amsub_n19', dsis(15)= 'amsub_n19', + sattypes_rad(16)= 'mhs_n19', dsis(16)= 'mhs_n19', + sattypes_rad(17)= 'hirs4_metop-a', dsis(17)= 'hirs4_metop-a', + sattypes_rad(18)= 'amsua_metop-a', dsis(18)= 'amsua_metop-a', + sattypes_rad(19)= 'amsua_metop-b', dsis(19)= 'amsua_metop-b', + sattypes_rad(20)= 'iasi_metop-a', dsis(20)= 'iasi_metop-a', + sattypes_rad(21)= 'airs_aqua', dsis(21)= 'airs_aqua', + sattypes_rad(22)= 'amsua_aqua', dsis(22)= 'amsua_aqua', +! sattypes_rad(15)= 'goes_img_g11', dsis(15)= 'imgr_g11', +! sattypes_rad(16)= 'goes_img_g12', dsis(16)= 'imgr_g12', +! sattypes_rad(17)= 'goes_img_g13', dsis(17)= 'imgr_g13', +! sattypes_rad(18)= 'goes_img_g14', dsis(18)= 'imgr_g14', +! sattypes_rad(19)= 'goes_img_g15', dsis(19)= 'imgr_g15', + sattypes_rad(23)= 'amsre_aqua', dsis(23)= 'amsre_aqua', +! sattypes_rad(24)= 'ssmis_f16', dsis(24)= 'ssmis_f16', + sattypes_rad(25)= 'ssmis_f17', dsis(25)= 'ssmis_f17', + sattypes_rad(26)= 'ssmis_f18', dsis(26)= 'ssmis_f18', +! sattypes_rad(27)= 'ssmis_f19', dsis(27)= 'ssmis_f19', +! sattypes_rad(28)= 'ssmis_f20', dsis(28)= 'ssmis_f20', +! sattypes_rad(29)= 'sndrd1_g11', dsis(29)= 'sndrD1_g11', +! sattypes_rad(30)= 'sndrd2_g11', dsis(30)= 'sndrD2_g11', +! sattypes_rad(31)= 'sndrd3_g11', dsis(31)= 'sndrD3_g11', +! sattypes_rad(32)= 'sndrd4_g11', dsis(32)= 'sndrD4_g11', +! sattypes_rad(33)= 'sndrd1_g12', dsis(33)= 'sndrD1_g12', +! sattypes_rad(34)= 'sndrd2_g12', dsis(34)= 'sndrD2_g12', +! sattypes_rad(35)= 'sndrd3_g12', dsis(35)= 'sndrD3_g12', +! sattypes_rad(36)= 'sndrd4_g12', dsis(36)= 'sndrD4_g12', +! sattypes_rad(37)= 'sndrd1_g13', dsis(37)= 'sndrD1_g13', +! sattypes_rad(38)= 'sndrd2_g13', dsis(38)= 'sndrD2_g13', +! sattypes_rad(39)= 'sndrd3_g13', dsis(39)= 'sndrD3_g13', +! sattypes_rad(40)= 'sndrd4_g13', dsis(40)= 'sndrD4_g13', +! sattypes_rad(41)= 'sndrd1_g14', dsis(41)= 'sndrD1_g14', +! sattypes_rad(42)= 'sndrd2_g14', dsis(42)= 'sndrD2_g14', +! sattypes_rad(43)= 'sndrd3_g14', dsis(43)= 'sndrD3_g14', +! sattypes_rad(44)= 'sndrd4_g14', dsis(44)= 'sndrD4_g14', +! sattypes_rad(45)= 'sndrd1_g15', dsis(45)= 'sndrD1_g15', +! sattypes_rad(46)= 'sndrd2_g15', dsis(46)= 'sndrD2_g15', +! sattypes_rad(47)= 'sndrd3_g15', dsis(47)= 'sndrD3_g15', +! sattypes_rad(48)= 'sndrd4_g15', dsis(48)= 'sndrD4_g15', + sattypes_rad(49)= 'mhs_metop-a', dsis(49)= 'mhs_metop-a', + sattypes_rad(50)= 'atms_npp', dsis(50)= 'atms_npp', + sattypes_rad(51)= 'cris_npp', dsis(51)= 'cris_npp', +! sattypes_rad(52)= 'seviri_m08', dsis(52)= 'seviri_m08', +! sattypes_rad(53)= 'seviri_m09', dsis(53)= 'seviri_m09', +! sattypes_rad(54)= 'seviri_m10', dsis(54)= 'seviri_m10', + sattypes_rad(55)= 'mhs_metop-b', dsis(55)= 'mhs_metop-b', + sattypes_rad(56)= 'iasi_metop-b', dsis(56)= 'iasi_metop-b', + sattypes_rad(57)= 'avhrr_n18', dsis(57)= 'avhrr3_n18', + sattypes_rad(58)= 'avhrr_n19', dsis(58)= 'avhrr3_n19', + sattypes_rad(59)= 'avhrr_metop-a', dsis(59)= 'avhrr3_metop-a', + sattypes_rad(60)= 'avhrr_metop-b', dsis(60)= 'avhrr3_metop-b', + sattypes_rad(61)= 'gmi_gpm', dsis(61)= 'gmi_gpm', + sattypes_rad(62)= 'amsua_metop-c', dsis(62)= 'amsua_metop-c', + sattypes_rad(63)= 'mhs_metop-c', dsis(63)= 'mhs_metop-c', + sattypes_rad(64)= 'cris-fsr_n20', dsis(64)= 'cris-fsr_n20', + sattypes_rad(65)= 'cris-fsr_npp', dsis(65)= 'cris-fsr_npp', + sattypes_rad(66)= 'iasi_metop-c', dsis(66)= 'iasi_metop-c', + sattypes_rad(67)= 'msu_n11', dsis(67)= 'msu_n11', + sattypes_rad(68)= 'msu_n12', dsis(68)= 'msu_n12', + sattypes_rad(69)= 'msu_n14', dsis(69)= 'msu_n14', + sattypes_rad(70)= 'ssmi_f13', dsis(70)= 'ssmi_f13', + sattypes_rad(71)= 'ssmi_f14', dsis(71)= 'ssmi_f14', + sattypes_rad(72)= 'ssmi_f15', dsis(72)= 'ssmi_f15', + sattypes_rad(73)= 'tmi_trmm', dsis(73)= 'tmi_trmm', + sattypes_rad(74)= 'avhrr_n15', dsis(74)= 'avhrr3_n15', + sattypes_rad(75)= 'avhrr_n16', dsis(75)= 'avhrr3_n16', + sattypes_rad(76)= 'avhrr_n17', dsis(76)= 'avhrr3_n17', + sattypes_rad(77)= 'atms_n20', dsis(77)= 'atms_n20', + sattypes_rad(78)= 'amsr2_gcom-w1', dsis(78)= 'amsr2_gcom-w1', +/ +&ozobs_enkf + sattypes_oz(1) = 'sbuv8_n11', + sattypes_oz(2) = 'sbuv8_n14', + sattypes_oz(3) = 'sbuv8_n16', + sattypes_oz(4) = 'sbuv8_n17', + sattypes_oz(5) = 'sbuv8_n18', + sattypes_oz(6) = 'sbuv8_n19', + sattypes_oz(7) = 'mls55_aura', +!sattypes_oz(8) = 'omi_aura', +!sattypes_oz(9) = 'gome_metop-a', +!sattypes_oz(10) = 'gome_metop-b', +!sattypes_oz(11) = 'o3lev_aura', +/ + +spectral_truncation: 96 + +eps_for_log_transform_aod: -1.0 + +fso_ana_increment_test: no + +analysis_type4fso: null + +verification_type4fso: null diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/R21C/obs1gsi_mean.rc b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/R21C/obs1gsi_mean.rc new file mode 100644 index 00000000..2e5adc68 --- /dev/null +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/R21C/obs1gsi_mean.rc @@ -0,0 +1,195 @@ + &SETUP + miter=0,niter(1)=1,niter(2)=1, + niter_no_qc(1)=999,niter_no_qc(2)=999, + write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.false., + jiterstart=1, + gencode=82,qoption=2, + factqmin=0.005,factqmax=0.005,deltim=300, +!--gencode=82,qoption=1, +!--factqmin=0.8,factqmax=1.2,deltim=300, + ifact10=0, + pseudo_q2=.true., + use_prepb_satwnd=>>>USE_PREPB_SATWND<<<, + ec_amv_qc=.false., + iguess=-1, + diag_version=30303, + id_drifter=.true., + id_ship=.false., + tzr_qc=1, + oneobtest=.false.,retrieval=.false., + biascor=-0.10,bcoption=0,diurnalbc=1.0, + crtm_coeffs_path="CRTM_Coeffs/", + print_diag_pcg=.false., + use_compress=.true.,nsig_ext=@NSIG_EXT,gpstop=60.,lgpsbnd_revint=.true., + use_sp_eqspace=.true., + reduce_diag=.true., + luse_obsdiag=.true., + lread_obs_save=.true.,lread_obs_skip=.false.,lwrite_predterms=.true.,lwrite_peakwt=.true., + ens_nstarthr=3, +@RADBC newpc4pred=.true.,adp_anglebc=.true.,angord=4, +@RADBC passive_bc=.true.,use_edges=.false., +@RADBC diag_precon=.true.,step_start=1.e-3,emiss_bc=.true., + lrun_subdirs=.false., + / + &GRIDOPTS + JCAP=@GSI_JCAP,NLAT=@GSI_JM,NLON=@GSI_IM,nsig=@GSI_LM, + regional=.false., + nvege_type=13, + / + &BKGERR + vs=0.6, + hzscl=0.588,1.25,2.0, + hswgt=0.45,0.3,0.25, + bw=0.0,norsp=4, + bkgv_flowdep=.true.,bkgv_rewgtfct=1.5, + fpsproj=.false., + adjustozvar=.true., + / + &ANBKGERR + anisotropic=.false., + / + &JCOPTS + ljcpdry=.true.,bamp_jcpdry=2.5e7, + / + &STRONGOPTS +! tlnmc_option=1,nstrong=1,nvmodes_keep=24,period_max=6.,period_width=1.5, +! baldiag_full=.true.,baldiag_inc=.true., + / + &OBSQC + dfact=0.75,dfact1=3.0,noiqc=.false.,oberrflg=.true.,c_varqc=0.02,blacklst=.true., + use_poq7=.true.,qc_noirjaco3=.true.,qc_satwnds=.false.,cld_det_dec2bin=.true., +! tcp_ermin=0.75,tcp_ermax=0.75, + >>>AIRCFT_BIAS<<< + / + &OBS_INPUT + dmesh(1)=145.0,dmesh(2)=150.0,dmesh(3)=180.0,time_window_max=3.0, + / +OBS_INPUT:: +! dfile dtype dplat dsis dval dthin dsfcalc obclass + prepbufr ps null ps 0.0 0 0 gmao_prep_bufr + prepbufr t null t 0.0 0 0 gmao_prep_bufr + prepbufr q null q 0.0 0 0 gmao_prep_bufr + prepbufr uv null uv 0.0 0 0 gmao_prep_bufr + prepbufr_profl t prof t 0.0 0 0 gmao_acftpfl_bufr + prepbufr_profl uv prof uv 0.0 0 0 gmao_acftpfl_bufr + mlstbufr t aura t 0.0 0 0 r21c_gmao_mlst_bufr + gpsrobufr gps_bnd null gps 0.0 0 0 r21c_gpsro_bufr + tcvitl tcp null tcp 0.0 0 0 r21c_ncep_tcvitals + sbuvbufr sbuv2 n11 sbuv8_n11 0.0 0 0 r21c_osbuv8_bufr + sbuvbufr sbuv2 n14 sbuv8_n14 0.0 0 0 r21c_osbuv8_bufr + sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 r21c_osbuv8_bufr + sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 r21c_osbuv8_bufr + sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 r21c_osbuv8_bufr + sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0 r21c_osbuv8_bufr + ompsnmeffnc ompsnmeff npp ompsnmeff_npp 0.0 2 0 r21c_npp_ompsnmeff_nc +! ompsnpnc ompsnpnc npp ompsnpnc_npp 0.0 0 0 r21c_npp_ompsnp_nc + ompslpgnc ompslp_g npp ompslp_g_npp 1.0 0 0 r21c_ompslp_g_nc + ompslpvisnc ompslpvis npp ompslpvis_npp 0.0 0 0 r21c_ompslpvis_nc + mlsnc mls55 aura mls55_aura 0.0 0 0 r21c_mls_nc + omieffnc omieff aura omieff_aura 0.0 2 0 r21c_aura_omieff_nc + hirs2bufr hirs2 n11 hirs2_n11 0.0 1 0 r21c_1bhrs2_bufr + hirs2bufr hirs2 n12 hirs2_n12 0.0 1 0 r21c_1bhrs2_bufr + hirs2bufr hirs2 n14 hirs2_n14 0.0 1 0 r21c_1bhrs2_bufr + hirs3bufr hirs3 n15 hirs3_n15 0.0 1 0 r21c_1bhrs3_bufr + hirs3bufr hirs3 n16 hirs3_n16 0.0 1 0 r21c_1bhrs3_bufr + hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0 r21c_1bhrs3_bufr + hirs4bufr hirs4 n18 hirs4_n18 0.0 1 0 r21c_1bhrs4_bufr + hirs4bufr hirs4 n19 hirs4_n19 0.0 1 0 r21c_1bhrs4_bufr + hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 1 0 r21c_1bhrs4_bufr + hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 0 r21c_1bhrs4_bufr + airsbufr airs aqua airs_aqua 0.0 3 0 r21c_eosairs_bufr + eosamsua amsua aqua amsua_aqua 0.0 1 0 r21c_eosamsua_bufr + msubufr msu n11 msu_n11 0.0 1 0 r21c_1bmsu_bufr + msubufr msu n12 msu_n12 0.0 1 0 r21c_1bmsu_bufr + msubufr msu n14 msu_n14 0.0 1 0 r21c_1bmsu_bufr + ssubufr ssu n14 ssu_n14 0.0 1 0 r21c_1bssu_bufr + amsuabufr amsua n15 amsua_n15 0.0 1 0 r21c_1bamua_bufr + amsuabufr amsua n16 amsua_n16 0.0 1 0 r21c_1bamua_bufr + amsuabufr amsua n17 amsua_n17 0.0 1 0 r21c_1bamua_bufr + amsuabufr amsua n18 amsua_n18 0.0 1 0 r21c_1bamua_bufr + amsuabufr amsua n19 amsua_n19 0.0 1 0 r21c_1bamua_bufr + amsuabufr amsua metop-a amsua_metop-a 0.0 1 0 r21c_1bamua_bufr + amsuabufr amsua metop-b amsua_metop-b 0.0 1 0 r21c_1bamua_bufr + amsuabufr amsua metop-c amsua_metop-c 0.0 1 0 r21c_1bamua_bufr + amsubbufr amsub n15 amsub_n15 0.0 1 0 r21c_1bamub_bufr + amsubbufr amsub n16 amsub_n16 0.0 1 0 r21c_1bamub_bufr + amsubbufr amsub n17 amsub_n17 0.0 1 0 r21c_1bamub_bufr + mhsbufr mhs n18 mhs_n18 0.0 1 0 r21c_1bmhs_bufr + mhsbufr mhs n19 mhs_n19 0.0 1 0 r21c_1bmhs_bufr + mhsbufr mhs metop-a mhs_metop-a 0.0 1 0 r21c_1bmhs_bufr + mhsbufr mhs metop-b mhs_metop-b 0.0 1 0 r21c_1bmhs_bufr + mhsbufr mhs metop-c mhs_metop-c 0.0 1 0 r21c_mhs_bufr + seviribufr seviri m08 seviri_m08 0.0 1 0 r21c_sevcsr_bufr + seviribufr seviri m09 seviri_m09 0.0 1 0 r21c_sevcsr_bufr + seviribufr seviri m10 seviri_m10 0.0 1 0 r21c_sevcsr_bufr + smit11bufr ssmi f11 ssmi_f11 0.0 1 0 r21c_ssmit11_bufr + smit13bufr ssmi f13 ssmi_f13 0.0 1 0 r21c_ssmit13_bufr + smit14bufr ssmi f14 ssmi_f14 0.0 1 0 r21c_ssmit14_bufr + smit15bufr ssmi f15 ssmi_f15 0.0 1 0 r21c_ssmit15_bufr + iasibufr iasi metop-a iasi_metop-a 0.0 3 0 r21c_mtiasi_bufr + iasibufr iasi metop-b iasi_metop-b 0.0 3 0 r21c_mtiasi_bufr + iasibufr iasi metop-c iasi_metop-c 0.0 3 0 r21c_mtiasi_bufr + atmsbufr atms npp atms_npp 0.0 1 0 r21c_atms_bufr + atmsbufr atms n20 atms_n20 0.0 1 0 r21c_atms_bufr + crisfsrbufr cris-fsr npp cris-fsr_npp 0.0 3 0 r21c_crisfsr_bufr + crisfsrbufr cris-fsr n20 cris-fsr_n20 0.0 3 0 r21c_crisfsr_bufr + tmibufr tmi trmm tmi_trmm 0.0 1 0 r21c_tmi_bufr + gmibufr gmi gpm gmi_gpm 0.0 1 0 r21c_gmi_bufr + amsr2bufr amsr2 gcom-w1 amsr2_gcom-w1 0.0 1 0 r21c_amsr2_bufr + amsregmao amsre aqua amsre_aqua 0.0 1 0 r21c_amsre_bufr + satwndbufr uv null uv 0.0 0 0 r21c_satwnd_bufr + satwndavhr uv null uv 0.0 0 0 r21c_avhrr_satwnd_bufr + avcsambufr avhrr n15 avhrr3_n15 0.0 1 0 r21c_avcsam_bufr + avcsambufr avhrr n17 avhrr3_n17 0.0 1 0 r21c_avcsam_bufr + avcsambufr avhrr metop-a avhrr3_metop-a 0.0 1 0 r21c_avcsam_bufr + avcsambufr avhrr metop-b avhrr3_metop-b 0.0 1 0 r21c_avcsam_bufr + avcspmbufr avhrr n16 avhrr3_n16 0.0 1 0 r21c_avcspm_bufr + avcspmbufr avhrr n18 avhrr3_n18 0.0 1 0 r21c_avcspm_bufr + avcspmbufr avhrr n19 avhrr3_n19 0.0 1 0 r21c_avcspm_bufr +!!!!! +! prepbufr spd null spd 0.0 0 0 gmao_prep_bufr +! prepbufr pw null pw 0.0 0 0 gmao_prep_bufr +! ascatbufr uv null uv 0.0 0 0 merra2_ascat_bufr +! ssmisbufr ssmis f17 ssmis_f17 0.0 1 0 hist_ssmis_bufr +! ssmisbufr ssmis f18 ssmis_f18 0.0 1 0 hist_ssmis_bufr +! crisbufr cris npp cris_npp 0.0 3 0 hist_cris_bufr +! ompsnmbufr ompsnm npp ompsnm_npp 0.0 2 0 npp_ompsnm_bufr +! ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0 npp_ompsnp_bufr +! ompslpuvnc ompslpuv npp ompslpuv_npp 1.0 0 0 ompslpuv_nc +! sbuvbufr sbuv2 nim07 sbuv8_nim07 0.0 0 0 osbuv8_bufr +:: + &SUPEROB_RADAR + / + &LAG_DATA +! lag_accur=1e-6, +! infile_lag='inistate_lag.dat', +! lag_stepduration=900., +! lag_nmax_bal=100, +! lag_vorcore_stderr_a=2e3, +! lag_vorcore_stderr_b=0, + / + &HYBRID_ENSEMBLE + l_hyb_ens=.false.,n_ens=32,beta_s0=0.50,generate_ens=.false.,uv_hyb_ens=.true., + s_ens_h=800.,s_ens_v=-0.5, + jcap_ens=126,nlat_ens=181,nlon_ens=288,aniso_a_en=.false., + jcap_ens_test=126, + oz_univ_static=.true., +! use_localization_grid=.true., + readin_localization=.true., + readin_beta=.true., + use_gfs_ens=.false., + eqspace_ensgrid=.true., + / + &RAPIDREFRESH_CLDSURF +! dfi_radar_latent_heat_time_period=30.0, + / + &SINGLEOB_TEST +! maginnov=0.1,magoberr=0.1,oneob_type='t', +! oblat=45.,oblon=180.,obpres=1000.,obdattim=2004041512, +! obhourset=0., + / + &CHEM + / + &NST + nst_gsi=3, + / diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/R21C/obs1gsi_member.rc b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/R21C/obs1gsi_member.rc new file mode 100644 index 00000000..5f2c8075 --- /dev/null +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/R21C/obs1gsi_member.rc @@ -0,0 +1,185 @@ + &SETUP + miter=0,niter(1)=1,niter(2)=1, + niter_no_qc(1)=999,niter_no_qc(2)=999, + write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.false., + jiterstart=1, + gencode=82,qoption=2, + factqmin=0.005,factqmax=0.005,deltim=300, +!--gencode=82,qoption=1, +!--factqmin=0.8,factqmax=1.2,deltim=300, + ifact10=0, + pseudo_q2=.true., + use_prepb_satwnd=>>>USE_PREPB_SATWND<<<, + ec_amv_qc=.false., + iguess=-1, + diag_version=30303, + id_drifter=.true., + id_ship=.false., + tzr_qc=1, + oneobtest=.false.,retrieval=.false., + biascor=-0.10,bcoption=0,diurnalbc=1.0, + crtm_coeffs_path="CRTM_Coeffs/", + print_diag_pcg=.false., + use_compress=.true.,nsig_ext=@NSIG_EXT,gpstop=60.,lgpsbnd_revint=.true., + use_sp_eqspace=.true., + reduce_diag=.true., + luse_obsdiag=.true., + lread_obs_save=.false.,lread_obs_skip=.true.,lwrite_predterms=.true.,lwrite_peakwt=.true., + ens_nstarthr=3, +@RADBC newpc4pred=.true.,adp_anglebc=.true.,angord=4, +@RADBC passive_bc=.true.,use_edges=.false., +@RADBC diag_precon=.true.,step_start=1.e-3,emiss_bc=.true., + lrun_subdirs=.false., + / + &GRIDOPTS + JCAP=@GSI_JCAP,NLAT=@GSI_JM,NLON=@GSI_IM,nsig=@GSI_LM, + regional=.false., + nvege_type=13, + / + &BKGERR + vs=0.6, + hzscl=0.588,1.25,2.0, + hswgt=0.45,0.3,0.25, + bw=0.0,norsp=4, + bkgv_flowdep=.true.,bkgv_rewgtfct=1.5, + fpsproj=.false., + adjustozvar=.true., + / + &ANBKGERR + anisotropic=.false., + / + &JCOPTS + ljcpdry=.true.,bamp_jcpdry=2.5e7, + / + &STRONGOPTS +! tlnmc_option=1,nstrong=1,nvmodes_keep=24,period_max=6.,period_width=1.5, +! baldiag_full=.true.,baldiag_inc=.true., + / + &OBSQC + dfact=0.75,dfact1=3.0,noiqc=.false.,oberrflg=.true.,c_varqc=0.02,blacklst=.true., + use_poq7=.true.,qc_noirjaco3=.true.,qc_satwnds=.false.,cld_det_dec2bin=.true., +! tcp_ermin=0.75,tcp_ermax=0.75, + >>>AIRCFT_BIAS<<< + / + &OBS_INPUT + dmesh(1)=145.0,dmesh(2)=150.0,dmesh(3)=180.0,time_window_max=3.0, + / +OBS_INPUT:: +! dfile dtype dplat dsis dval dthin dsfcalc obclass + prepbufr ps null ps 0.0 0 0 gmao_prep_bufr + prepbufr t null t 0.0 0 0 gmao_prep_bufr + prepbufr q null q 0.0 0 0 gmao_prep_bufr + prepbufr uv null uv 0.0 0 0 gmao_prep_bufr + prepbufr_profl t prof t 0.0 0 0 gmao_acftpfl_bufr + prepbufr_profl uv prof uv 0.0 0 0 gmao_acftpfl_bufr + mlstbufr t aura t 0.0 0 0 r21c_gmao_mlst_bufr + gpsrobufr gps_bnd null gps 0.0 0 0 r21c_gpsro_bufr + tcvitl tcp null tcp 0.0 0 0 r21c_ncep_tcvitals + sbuvbufr sbuv2 n11 sbuv8_n11 0.0 0 0 r21c_osbuv8_bufr + sbuvbufr sbuv2 n14 sbuv8_n14 0.0 0 0 r21c_osbuv8_bufr + sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 r21c_osbuv8_bufr + sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 r21c_osbuv8_bufr + sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 r21c_osbuv8_bufr + sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0 r21c_osbuv8_bufr + ompsnmeffnc ompsnmeff npp ompsnmeff_npp 0.0 2 0 r21c_npp_ompsnmeff_nc +! ompsnpnc ompsnpnc npp ompsnpnc_npp 0.0 0 0 r21c_npp_ompsnp_nc + ompslpgnc ompslp_g npp ompslp_g_npp 1.0 0 0 r21c_ompslp_g_nc + ompslpvisnc ompslpvis npp ompslpvis_npp 0.0 0 0 r21c_ompslpvis_nc + mlsnc mls55 aura mls55_aura 0.0 0 0 r21c_mls_nc + omieffnc omieff aura omieff_aura 0.0 2 0 r21c_aura_omieff_nc + hirs2bufr hirs2 n11 hirs2_n11 0.0 1 0 r21c_1bhrs2_bufr + hirs2bufr hirs2 n12 hirs2_n12 0.0 1 0 r21c_1bhrs2_bufr + hirs2bufr hirs2 n14 hirs2_n14 0.0 1 0 r21c_1bhrs2_bufr + hirs3bufr hirs3 n15 hirs3_n15 0.0 1 0 r21c_1bhrs3_bufr + hirs3bufr hirs3 n16 hirs3_n16 0.0 1 0 r21c_1bhrs3_bufr + hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0 r21c_1bhrs3_bufr + hirs4bufr hirs4 n18 hirs4_n18 0.0 1 0 r21c_1bhrs4_bufr + hirs4bufr hirs4 n19 hirs4_n19 0.0 1 0 r21c_1bhrs4_bufr + hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 1 0 r21c_1bhrs4_bufr + hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 0 r21c_1bhrs4_bufr + airsbufr airs aqua airs_aqua 0.0 3 0 r21c_eosairs_bufr + eosamsua amsua aqua amsua_aqua 0.0 1 0 r21c_eosamsua_bufr + msubufr msu n11 msu_n11 0.0 1 0 r21c_1bmsu_bufr + msubufr msu n12 msu_n12 0.0 1 0 r21c_1bmsu_bufr + msubufr msu n14 msu_n14 0.0 1 0 r21c_1bmsu_bufr + ssubufr ssu n14 ssu_n14 0.0 1 0 r21c_1bssu_bufr + amsuabufr amsua n15 amsua_n15 0.0 1 0 r21c_1bamua_bufr + amsuabufr amsua n16 amsua_n16 0.0 1 0 r21c_1bamua_bufr + amsuabufr amsua n17 amsua_n17 0.0 1 0 r21c_1bamua_bufr + amsuabufr amsua n18 amsua_n18 0.0 1 0 r21c_1bamua_bufr + amsuabufr amsua n19 amsua_n19 0.0 1 0 r21c_1bamua_bufr + amsuabufr amsua metop-a amsua_metop-a 0.0 1 0 r21c_1bamua_bufr + amsuabufr amsua metop-b amsua_metop-b 0.0 1 0 r21c_1bamua_bufr + amsuabufr amsua metop-c amsua_metop-c 0.0 1 0 r21c_1bamua_bufr + amsubbufr amsub n15 amsub_n15 0.0 1 0 r21c_1bamub_bufr + amsubbufr amsub n16 amsub_n16 0.0 1 0 r21c_1bamub_bufr + amsubbufr amsub n17 amsub_n17 0.0 1 0 r21c_1bamub_bufr + mhsbufr mhs n18 mhs_n18 0.0 1 0 r21c_1bmhs_bufr + mhsbufr mhs n19 mhs_n19 0.0 1 0 r21c_1bmhs_bufr + mhsbufr mhs metop-a mhs_metop-a 0.0 1 0 r21c_1bmhs_bufr + mhsbufr mhs metop-b mhs_metop-b 0.0 1 0 r21c_1bmhs_bufr + mhsbufr mhs metop-c mhs_metop-c 0.0 1 0 r21c_mhs_bufr + seviribufr seviri m08 seviri_m08 0.0 1 0 r21c_sevcsr_bufr + seviribufr seviri m09 seviri_m09 0.0 1 0 r21c_sevcsr_bufr + seviribufr seviri m10 seviri_m10 0.0 1 0 r21c_sevcsr_bufr + smit11bufr ssmi f11 ssmi_f11 0.0 1 0 r21c_ssmit11_bufr + smit13bufr ssmi f13 ssmi_f13 0.0 1 0 r21c_ssmit13_bufr + smit14bufr ssmi f14 ssmi_f14 0.0 1 0 r21c_ssmit14_bufr + smit15bufr ssmi f15 ssmi_f15 0.0 1 0 r21c_ssmit15_bufr + iasibufr iasi metop-a iasi_metop-a 0.0 3 0 r21c_mtiasi_bufr + iasibufr iasi metop-b iasi_metop-b 0.0 3 0 r21c_mtiasi_bufr + iasibufr iasi metop-c iasi_metop-c 0.0 3 0 r21c_mtiasi_bufr + atmsbufr atms npp atms_npp 0.0 1 0 r21c_atms_bufr + atmsbufr atms n20 atms_n20 0.0 1 0 r21c_atms_bufr + crisfsrbufr cris-fsr npp cris-fsr_npp 0.0 3 0 r21c_crisfsr_bufr + crisfsrbufr cris-fsr n20 cris-fsr_n20 0.0 3 0 r21c_crisfsr_bufr + tmibufr tmi trmm tmi_trmm 0.0 1 0 r21c_tmi_bufr + gmibufr gmi gpm gmi_gpm 0.0 1 0 r21c_gmi_bufr + amsr2bufr amsr2 gcom-w1 amsr2_gcom-w1 0.0 1 0 r21c_amsr2_bufr + amsregmao amsre aqua amsre_aqua 0.0 1 0 r21c_amsre_bufr + satwndbufr uv null uv 0.0 0 0 r21c_satwnd_bufr + satwndavhr uv null uv 0.0 0 0 r21c_avhrr_satwnd_bufr + avcsambufr avhrr n15 avhrr3_n15 0.0 1 0 r21c_avcsam_bufr + avcsambufr avhrr n17 avhrr3_n17 0.0 1 0 r21c_avcsam_bufr + avcsambufr avhrr metop-a avhrr3_metop-a 0.0 1 0 r21c_avcsam_bufr + avcsambufr avhrr metop-b avhrr3_metop-b 0.0 1 0 r21c_avcsam_bufr + avcspmbufr avhrr n16 avhrr3_n16 0.0 1 0 r21c_avcspm_bufr + avcspmbufr avhrr n18 avhrr3_n18 0.0 1 0 r21c_avcspm_bufr + avcspmbufr avhrr n19 avhrr3_n19 0.0 1 0 r21c_avcspm_bufr +!!!!! +! prepbufr spd null spd 0.0 0 0 gmao_prep_bufr +! prepbufr pw null pw 0.0 0 0 gmao_prep_bufr +! ascatbufr uv null uv 0.0 0 0 merra2_ascat_bufr +! ssmisbufr ssmis f17 ssmis_f17 0.0 1 0 hist_ssmis_bufr +! ssmisbufr ssmis f18 ssmis_f18 0.0 1 0 hist_ssmis_bufr +! crisbufr cris npp cris_npp 0.0 3 0 hist_cris_bufr +! ompsnmbufr ompsnm npp ompsnm_npp 0.0 2 0 npp_ompsnm_bufr +! ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0 npp_ompsnp_bufr +! ompslpuvnc ompslpuv npp ompslpuv_npp 1.0 0 0 ompslpuv_nc +! sbuvbufr sbuv2 nim07 sbuv8_nim07 0.0 0 0 osbuv8_bufr +:: + &SUPEROB_RADAR + / + &LAG_DATA +! lag_accur=1e-6, +! infile_lag='inistate_lag.dat', +! lag_stepduration=900., +! lag_nmax_bal=100, +! lag_vorcore_stderr_a=2e3, +! lag_vorcore_stderr_b=0, + / + &HYBRID_ENSEMBLE + / + &RAPIDREFRESH_CLDSURF +! dfi_radar_latent_heat_time_period=30.0, + / + &SINGLEOB_TEST +! maginnov=0.1,magoberr=0.1,oneob_type='t', +! oblat=45.,oblon=180.,obpres=1000.,obdattim=2004041512, +! obhourset=0., + / + &CHEM + / + &NST + nst_gsi=3, + / diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/setup_atmens.pl b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/setup_atmens.pl index e5741fd0..c8b42bff 100755 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/setup_atmens.pl +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/setup_atmens.pl @@ -49,6 +49,7 @@ "nosppt", "ose", "rcorr", + "r21c", "h" ); usage() if $opt_h; @@ -121,6 +122,11 @@ sub init { } } + $bcopt = ""; + if ( $opt_r21c ) { + $bcopt = "-r21c"; + } + $setradbc = 0; if ( $opt_radbc ) { $setradbc = 1; @@ -420,7 +426,8 @@ sub install { cp("$FVROOT/bin/atm_ens.j","$FVHOME/run"); # generate boundary condition script -$cmd = "$FVROOT/bin/gen_lnbcs.pl $cubed -o $FVHOME/run/lnbcs_ens $aim $ajm $ogrid $lndbcs"; +# $cmd = "$FVROOT/bin/gen_lnbcs.pl $cubed -o $FVHOME/run/lnbcs_ens $aim $ajm $ogrid $lndbcs"; +$cmd = "$FVROOT/bin/gen_lnbcs.pl $cubed $bcopt -o $FVHOME/run/lnbcs_ens $aim $ajm $ogrid $lndbcs"; $rc = system($cmd); # make sure .no_archiving exists in ATMENS From 2085007fd90f9f93bf6fd9b839d09606937fa7ca Mon Sep 17 00:00:00 2001 From: gmao-msienkie Date: Tue, 3 May 2022 13:13:02 -0400 Subject: [PATCH 166/205] Update the readme file with a note about the 'generic' configuration for satellites --- .../NCEP_Etc/NCEP_bias/readme_init_coeffs.txt | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/Applications/NCEP_Etc/NCEP_bias/readme_init_coeffs.txt b/src/Applications/NCEP_Etc/NCEP_bias/readme_init_coeffs.txt index 87f5655a..d7828d88 100644 --- a/src/Applications/NCEP_Etc/NCEP_bias/readme_init_coeffs.txt +++ b/src/Applications/NCEP_Etc/NCEP_bias/readme_init_coeffs.txt @@ -45,6 +45,15 @@ directory with names in the format %s.diag_(dtype)_(dplat)_ges.%y4%m2%d2_%h2z.bin where the %s is substituted with the expid specified on the command line +Note: this program uses the "gsi.rc.tmpl" file to get values for 'dtype', +'dplat', and 'dsis' for each satellite instrument being fitted. The 'dtype' +and 'dplat' are used in determining the names of the diag files to read. +The 'dsis' indicates the entries in the "satbias" file to contain the results +of the coefficient fitting. If you are using the 'generic' method in your +"gsi.rc.tmpl" to configure your instrument you will need to supply another +file with an 'OBS_INPUT::' table like in the "gsi.rc.tmpl" which specifies +the 'dtype', 'dplat' and 'dsis' values for your satellite(s). + --------------------- EXAMPLES -------------------------------------------- 1) Using archived diag_*_ges.*.bin files as input From adfdff123527fb3c73c0d49f9097bc4a23a0ee37 Mon Sep 17 00:00:00 2001 From: Meta Sienkiewicz <53273921+gmao-msienkie@users.noreply.github.com> Date: Thu, 5 May 2022 17:19:44 -0400 Subject: [PATCH 167/205] Update readme_init_coeffs.txt Edited the file to remove some information that had been included twice. --- .../NCEP_Etc/NCEP_bias/readme_init_coeffs.txt | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/src/Applications/NCEP_Etc/NCEP_bias/readme_init_coeffs.txt b/src/Applications/NCEP_Etc/NCEP_bias/readme_init_coeffs.txt index d7828d88..ccf5ce84 100644 --- a/src/Applications/NCEP_Etc/NCEP_bias/readme_init_coeffs.txt +++ b/src/Applications/NCEP_Etc/NCEP_bias/readme_init_coeffs.txt @@ -45,14 +45,12 @@ directory with names in the format %s.diag_(dtype)_(dplat)_ges.%y4%m2%d2_%h2z.bin where the %s is substituted with the expid specified on the command line -Note: this program uses the "gsi.rc.tmpl" file to get values for 'dtype', -'dplat', and 'dsis' for each satellite instrument being fitted. The 'dtype' -and 'dplat' are used in determining the names of the diag files to read. -The 'dsis' indicates the entries in the "satbias" file to contain the results -of the coefficient fitting. If you are using the 'generic' method in your -"gsi.rc.tmpl" to configure your instrument you will need to supply another -file with an 'OBS_INPUT::' table like in the "gsi.rc.tmpl" which specifies -the 'dtype', 'dplat' and 'dsis' values for your satellite(s). +Note: Since this program uses the "gsi.rc.tmpl" file to get values for 'dtype', +'dplat', and 'dsis' for each satellite instrument being fitted, if you are +using the 'generic' value for these variables in your "gsi.rc.tmpl" to +configure your instrument you will need to supply another file with an +'OBS_INPUT::' table like in the "gsi.rc.tmpl" which specifies the actual +'dtype', 'dplat' and 'dsis' values for your satellite(s). --------------------- EXAMPLES -------------------------------------------- From a642b253081b0826e7f4e9d3c5b307b618960477 Mon Sep 17 00:00:00 2001 From: gmao-msienkie Date: Fri, 6 May 2022 00:54:32 -0400 Subject: [PATCH 168/205] add 'geoimr' (for OSSE) to list of satellites to fit with mean_only --- src/Applications/NCEP_Etc/NCEP_bias/init_coeffs.f90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Applications/NCEP_Etc/NCEP_bias/init_coeffs.f90 b/src/Applications/NCEP_Etc/NCEP_bias/init_coeffs.f90 index e3b8cf13..885daa46 100644 --- a/src/Applications/NCEP_Etc/NCEP_bias/init_coeffs.f90 +++ b/src/Applications/NCEP_Etc/NCEP_bias/init_coeffs.f90 @@ -613,7 +613,8 @@ program init_coeffs obstype = gsi_files(iii)%dtype select case (trim(obstype)) - case ('sndr','sndrd1','sndrd2','sndrd3','sndrd4','ssmi','ssmis','seviri','tmi','gmi','avhrr') + case ('sndr','sndrd1','sndrd2','sndrd3','sndrd4','ssmi','ssmis', & + 'seviri','tmi','gmi','avhrr','geoirs') mean_only = .true. np = 1 case default From 8215c94b97f9faf767671dfb8d27e214a02f4f63 Mon Sep 17 00:00:00 2001 From: gmao-msienkie Date: Fri, 6 May 2022 14:24:17 -0400 Subject: [PATCH 169/205] Adding a modification to init_coeffs.f90 for the OSSE geoimr instruments - add to mean_only list (no crosstrack estimate) --- src/Applications/NCEP_Etc/NCEP_bias/init_coeffs.f90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Applications/NCEP_Etc/NCEP_bias/init_coeffs.f90 b/src/Applications/NCEP_Etc/NCEP_bias/init_coeffs.f90 index e3b8cf13..885daa46 100644 --- a/src/Applications/NCEP_Etc/NCEP_bias/init_coeffs.f90 +++ b/src/Applications/NCEP_Etc/NCEP_bias/init_coeffs.f90 @@ -613,7 +613,8 @@ program init_coeffs obstype = gsi_files(iii)%dtype select case (trim(obstype)) - case ('sndr','sndrd1','sndrd2','sndrd3','sndrd4','ssmi','ssmis','seviri','tmi','gmi','avhrr') + case ('sndr','sndrd1','sndrd2','sndrd3','sndrd4','ssmi','ssmis', & + 'seviri','tmi','gmi','avhrr','geoirs') mean_only = .true. np = 1 case default From a8b3c1ac33fbe3fe22eb624c1bd5b6a51c115590 Mon Sep 17 00:00:00 2001 From: Joe Stassi Date: Tue, 10 May 2022 10:20:00 -0400 Subject: [PATCH 170/205] The script was modified to add an hourtype value for the traj_lcv_rst entry. --- .../GEOSdas_App/write_monthly_rc_arc.pl | 56 ++++++++++--------- 1 file changed, 29 insertions(+), 27 deletions(-) diff --git a/src/Applications/GEOSdas_App/write_monthly_rc_arc.pl b/src/Applications/GEOSdas_App/write_monthly_rc_arc.pl index 1d494f23..38a4c6a1 100755 --- a/src/Applications/GEOSdas_App/write_monthly_rc_arc.pl +++ b/src/Applications/GEOSdas_App/write_monthly_rc_arc.pl @@ -32,13 +32,17 @@ # # => %list: keys = analysis products, e.g. "ana.eta", and names of model # collections found in $histfile, e.g. "inst1_2d_asm_Nx" -# value = a single code containing one or more of the following +# values = a single code containing one or more of the following # letters, {C, M, T, P}, with the following meanings: # C => comment entry in monthly.rc # M => create monthly products # T => tar this product # P => create monthly plots for this product -# the code, except for the 'C', is written to the monthly.rc file +# the code, except for the 'C', is written to the monthly.rc file +# => %freq: keys = names of collections found in $histfile +# values = hour frequency (e.g. 1, 3, or 6) as specified in $histfile +# => %mode: keys = names of collections found in $histfile +# values = mode ("inst" or "tavg") as specified in $histfile # # key local variables in main program: # => @outRcArr: lines to write to the $outRc file (monthly.rc) @@ -60,6 +64,7 @@ my ($outRc, $outArc, $outArk); my ($rcFLG, $arcFLG, $arkFLG); my $script = basename $0; +my (%freq, %mode); # analysis and aod output names with default hour types # (hard-coded until I can figure out a way to get them from somewhere else) @@ -183,15 +188,8 @@ sub init { #======================================================================= # name - get_list_from_HIST # purpose - add collection names from $histfile to list -# -# key local variables -# => %freq: keys = names of collections found in $histfile -# values = hour frequency (e.g. 1, 3, or 6) as specified in $histfile -# => %mode: keys = names of collections found in $histfile -# values = mode ("inst" or "tavg") as specified in $histfile #======================================================================= sub get_list_from_HIST { - my (%freq, %mode); my ($colFLG, $extFLG); my ($colon, $doublecolon); @@ -227,8 +225,8 @@ sub get_list_from_HIST { # get frequency and mode information #----------------------------------- - extract_freq($_, \%freq) if /\.frequency\s*$colon/; - extract_mode($_, \%mode) if /\.mode\s*$colon/; + extract_freq($_) if /\.frequency\s*$colon/; + extract_mode($_) if /\.mode\s*$colon/; } close HIST; } @@ -302,18 +300,12 @@ sub plots_type { # # input parameter # => $line: line from $histfile containing frequency information for a collection -# -# input/output parameter -# => $freqAddr: address of %freq hash containing collection frequency info #======================================================================= sub extract_freq { - my ($line, $freqAddr); - + my ($line); $line = shift; - $freqAddr = shift; - if ( $line =~ /^\s*(\S*)\.frequency\s*:\s*(\d{6})\s*,/ ) { - $$freqAddr{$1} = $2 / 10000; + $freq{$1} = $2 / 10000; } } @@ -323,22 +315,26 @@ sub extract_freq { # # input parameter # => $line: line from $histfile containing mode information for a collection -# -# input/output parameter -# => $modeAddr: address of %mode hash containing collection mode info #======================================================================= sub extract_mode { - my ($line, $modeAddr); - my ($name); + my ($line, $name); + $line = shift; + if ( $line =~ /^\s*(\S*)\.mode\s*:/ ) { + $name = $1; + $mode{$name} = "inst" if $line =~ /instantaneous/; + $mode{$name} = "tavg" if $line =~ /time-averaged/; + } +} +sub extract_modeX { + my ($line, $name); $line = shift; - $modeAddr = shift; $name = undef; $name = $1 if $line =~ /^\s*(\S*)\.mode\s*:/; if ($name) { - $$modeAddr{$name} = "inst" if $line =~ /instantaneous/; - $$modeAddr{$name} = "tavg" if $line =~ /time-averaged/; + $mode{$name} = "inst" if $line =~ /instantaneous/; + $mode{$name} = "tavg" if $line =~ /time-averaged/; } } @@ -401,6 +397,12 @@ sub get_info_from_SILO { } close SILO; + # add additional hourtype requirements + #------------------------------------- + foreach (qw(traj_lcv_rst)) { + $hourtype{$_} = "$mode{$_}$freq{$_}"; + } + # entries for monthly.rc file #---------------------------- @$outRcArrAddr = (); From e695a276deddc84f21b812f641301f36d3eb3c2d Mon Sep 17 00:00:00 2001 From: Joe Stassi Date: Wed, 11 May 2022 09:56:03 -0400 Subject: [PATCH 171/205] Removed obsolete code. --- .../GEOSdas_App/write_monthly_rc_arc.pl | 16 ++-------------- 1 file changed, 2 insertions(+), 14 deletions(-) diff --git a/src/Applications/GEOSdas_App/write_monthly_rc_arc.pl b/src/Applications/GEOSdas_App/write_monthly_rc_arc.pl index 38a4c6a1..cb383bb2 100755 --- a/src/Applications/GEOSdas_App/write_monthly_rc_arc.pl +++ b/src/Applications/GEOSdas_App/write_monthly_rc_arc.pl @@ -60,11 +60,11 @@ # global variables #----------------- -my ($histfile, $siloarc, $ncana, %list); +my ($histfile, $siloarc, $ncana); my ($outRc, $outArc, $outArk); my ($rcFLG, $arcFLG, $arkFLG); my $script = basename $0; -my (%freq, %mode); +my (%list, %freq, %mode); # analysis and aod output names with default hour types # (hard-coded until I can figure out a way to get them from somewhere else) @@ -326,18 +326,6 @@ sub extract_mode { } } -sub extract_modeX { - my ($line, $name); - $line = shift; - - $name = undef; - $name = $1 if $line =~ /^\s*(\S*)\.mode\s*:/; - if ($name) { - $mode{$name} = "inst" if $line =~ /instantaneous/; - $mode{$name} = "tavg" if $line =~ /time-averaged/; - } -} - #======================================================================= # name - get_info_from_SILO # purpose - use information from the experiment archive file (e.g. silo.arc) From 36a75e815d92b72771b6999e2f304f8cfa3649c0 Mon Sep 17 00:00:00 2001 From: Joe Stassi Date: Wed, 11 May 2022 10:08:04 -0400 Subject: [PATCH 172/205] minor modification -- changed order of two variable declaration lines. That's all. --- src/Applications/GEOSdas_App/write_monthly_rc_arc.pl | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Applications/GEOSdas_App/write_monthly_rc_arc.pl b/src/Applications/GEOSdas_App/write_monthly_rc_arc.pl index cb383bb2..795621ea 100755 --- a/src/Applications/GEOSdas_App/write_monthly_rc_arc.pl +++ b/src/Applications/GEOSdas_App/write_monthly_rc_arc.pl @@ -63,9 +63,10 @@ my ($histfile, $siloarc, $ncana); my ($outRc, $outArc, $outArk); my ($rcFLG, $arcFLG, $arkFLG); -my $script = basename $0; my (%list, %freq, %mode); +my $script = basename $0; + # analysis and aod output names with default hour types # (hard-coded until I can figure out a way to get them from somewhere else) # (hour types are defined in the Manipulate_time.pm module) From 58fa96b8e2407fe3db26f00576f4ff51c72bcd4d Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Fri, 13 May 2022 10:35:00 -0400 Subject: [PATCH 173/205] updates for GEOS-IT and R21C - zero diff to 5.29.4 --- components.yaml | 12 ++++++------ .../GEOSdas_App/testsuites/geos_it.input | 2 +- src/Applications/GEOSdas_App/write_monthly_rc_arc.pl | 1 + 3 files changed, 8 insertions(+), 7 deletions(-) diff --git a/components.yaml b/components.yaml index 2c02c3ec..14f76997 100644 --- a/components.yaml +++ b/components.yaml @@ -28,7 +28,7 @@ NCEP_Shared: GMAO_Shared: local: ./src/Shared/@GMAO_Shared remote: ../GMAO_Shared.git - tag: rt1_4_10_stoch_grid_fix + tag: rt1_4_10_geosit develop: main MAPL: @@ -46,13 +46,13 @@ FMS: GEOSana_GridComp: local: ./src/Components/@GEOSana_GridComp remote: ../GEOSana_GridComp.git - tag: v1.5.4.1 + tag: v1.5.4.2 develop: develop GEOSgcm_GridComp: local: ./src/Components/@GEOSgcm_GridComp remote: ../GEOSgcm_GridComp.git - tag: rt1_12_4_tskinice + tag: rt1_12_4_geosit sparse: ./config/GEOSgcm_GridComp.sparse develop: develop @@ -83,7 +83,7 @@ fvdycore: GEOSchem_GridComp: local: ./src/Components/@GEOSgcm_GridComp/GEOSagcm_GridComp/GEOSphysics_GridComp/@GEOSchem_GridComp remote: ../GEOSchem_GridComp.git - tag: rt1.6.2 + tag: rt1.6.2_geosit develop: develop HEMCO: @@ -101,7 +101,7 @@ geos-chem: GOCART: local: ./src/Components/@GEOSgcm_GridComp/GEOSagcm_GridComp/GEOSphysics_GridComp/@GEOSchem_GridComp/@GOCART remote: ../GOCART.git - tag: rt1.0.1_CEDS + tag: rt1.0.1_geosit sparse: ./config/GOCART.sparse develop: develop @@ -121,7 +121,7 @@ mom6: GEOSgcm_App: local: ./src/Applications/@GEOSgcm_App remote: ../GEOSgcm_App.git - tag: rt1.5.6_geosit_hist1 + tag: rt1.5.6_geosit_hist2 develop: develop UMD_Etc: diff --git a/src/Applications/GEOSdas_App/testsuites/geos_it.input b/src/Applications/GEOSdas_App/testsuites/geos_it.input index 699ccad9..2762c9ff 100644 --- a/src/Applications/GEOSdas_App/testsuites/geos_it.input +++ b/src/Applications/GEOSdas_App/testsuites/geos_it.input @@ -45,7 +45,7 @@ The directory /discover/nobackup/projects/gmao/dadev/rtodling/geos_it does not e > Processing nodes (1:Westmere, 2:SandyBridge, 3:Ivy Bridge, 4:Haswell, 5:Skylake, 6:Cascase)? [4] -> 5 +> 6 Which case of variational analysis? [1] > diff --git a/src/Applications/GEOSdas_App/write_monthly_rc_arc.pl b/src/Applications/GEOSdas_App/write_monthly_rc_arc.pl index 795621ea..3e1422ca 100755 --- a/src/Applications/GEOSdas_App/write_monthly_rc_arc.pl +++ b/src/Applications/GEOSdas_App/write_monthly_rc_arc.pl @@ -106,6 +106,7 @@ "prog.sfc" => 1, "ptrj.prs" => 1, "traj.lcv" => 1, + "traj_lcv_rst" => 1, "vtx.mix" => 1, "vtx.prs" => 1 ); # main program From 9a375eda756e5d62d32531fb30e50b14ec767b8f Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Fri, 13 May 2022 15:58:31 -0400 Subject: [PATCH 174/205] revise obs system according to changes for GEOS-IT; notice that AERONET much not be in the AOD obs-class - not working --- src/Applications/GEOSdas_App/testsuites/geos_it.input | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Applications/GEOSdas_App/testsuites/geos_it.input b/src/Applications/GEOSdas_App/testsuites/geos_it.input index 2762c9ff..ae7301ea 100644 --- a/src/Applications/GEOSdas_App/testsuites/geos_it.input +++ b/src/Applications/GEOSdas_App/testsuites/geos_it.input @@ -138,7 +138,7 @@ Which main class of ObsSys (1: NRT; 2: MERRA; 3: MERRA-2; 4: GEOS-IT; 5: R21C)? > 4 OBSERVING SYSTEM CLASSES? -> merra2_cdas0_pre-qc_bufr,merra2_cdas_pre-qc_bufr,merra2_avhrrwnd_pre-qc_bufr,merra2_ascat_pre-qc_bufr,merra2_ers1_pre-qc_bufr,merra2_repro_ers2_pre-qc_bufr,merra2_qscat_jpl_pre-qc_bufr,merra2_wspd_pre-qc_bufr,merra2_nmodis_pre-qc_bufr,merra2_prof_pre-qc_bufr,merra2_cdas0_pre-qc_bufr,merra2_cdas_pre-qc_bufr,merra2_avhrrwnd_pre-qc_bufr,merra2_ascat_pre-qc_bufr,merra2_ers1_pre-qc_bufr,merra2_repro_ers2_pre-qc_bufr,merra2_qscat_jpl_pre-qc_bufr,merra2_wspd_pre-qc_bufr,merra2_nmodis_pre-qc_bufr,merra2_prof_pre-qc_bufr,merra2_ncep_tcvitals,ncep_ssmis_bufr,ncep_1bamua_bufr,ncep_mhs_bufr,ncep_1bhrs4_bufr,ncep_goesfv_bufr,ncep_gpsro_bufr,ncep_mtiasi_bufr,ncep_atms_bufr,ncep_cris_bufr,ncep_crisfsr_bufr,ncep_satwnd_bufr,ncep_sevcsr_bufr,ncep_avcsam_bufr,ncep_avcspm_bufr,disc_airs_bufr,disc_amsua_bufr,ncep_acftpfl_bufr,aura_omieff_nc,npp_ompsnp_nc,npp_ompsnmeff_nc,gmao_gmi_bufr,gmao_amsr2_bufr +> geosit_cdas_raob_pre-qc_bufr,geosit_cdas_conv_pre-qc_bufr,geosit_prof_pre-qc_bufr,geosit_avhrrwnd_pre-qc_bufr,geosit_nmodis_pre-qc_bufr,geosit_goes_pre-qc_prep_bufr,geosit_metsat_pre-qc_prep_bufr,geosit_jma_pre-qc_prep_bufr,geosit_ascat_pre-qc_bufr,geosit_repro_ers2_pre-qc_bufr,geosit_qscat_jpl_pre-qc_bufr,geosit_wspd_pre-qc_bufr,geosit_satwnd_bufr,geosit_avhrr_satwnd_bufr,geosit_ncep_tcvitals,geosit_tmi_bufr,geosit_gpsro_bufr,geosit_sevcsr_bufr,geosit_1bamua_bufr,geosit_1bamub_bufr,geosit_1bhrs2_bufr,geosit_1bhrs3_bufr,geosit_1bhrs4_bufr,geosit_1bmsu_bufr,geosit_1bmhs_bufr,geosit_1bssu_bufr,geosit_eosairs_bufr,geosit_eosamsua_bufr,geosit_mtiasi_bufr,geosit_atms_bufr,geosit_ssmit11_bufr,geosit_ssmit13_bufr,geosit_ssmit14_bufr,geosit_ssmit15_bufr,geosit_amsre_bufr,geosit_osbuv8_bufr,geosit_npp_ompsnp_nc,geosit_aura_omieff_nc,geosit_npp_ompsnmeff_nc,geosit_avcsam_bufr,geosit_avcspm_bufr,geosit_acftpfl_bufr,geosit_amsr2_bufr,geosit_crisfsr_bufr,geosit_gmi_bufr CHECKING OBSYSTEM? [2] > 1 @@ -195,7 +195,7 @@ Do Aerosol Analysis (y/n)? [y] > AOD OBSERVING CLASSES [or type 'none']? -> +> mod04_061_his,myd04_061_his Enable GAAS feedback to model (y/n)? [y] > From ed908ebb3ab09c13ee9fb1dd5f8c3707dfdfd47e Mon Sep 17 00:00:00 2001 From: gmao-msienkie Date: Thu, 2 Jun 2022 12:47:28 -0400 Subject: [PATCH 175/205] Try and remove requirement for 'satbang' file when running $ANGLEBC = 1 Modify code to check for presence of pre-qc files before running 'combfrd.x' and skip running prepqc if no pre-qc files are present --- src/Applications/GEOSdas_App/GEOSdas.csm | 44 +++++++++++++++--------- 1 file changed, 27 insertions(+), 17 deletions(-) diff --git a/src/Applications/GEOSdas_App/GEOSdas.csm b/src/Applications/GEOSdas_App/GEOSdas.csm index bb71b721..038dc452 100755 --- a/src/Applications/GEOSdas_App/GEOSdas.csm +++ b/src/Applications/GEOSdas_App/GEOSdas.csm @@ -1969,9 +1969,11 @@ exit 1 endif endif - set ars_list = ( satbias satbang ) + set ars_list = ( satbias ) if ($NEWRADBC || $ANGLEBC) then set ars_list = ( $ars_list satbiaspc ) + else if ( ! $ANGLEBC ) then + set ars_list = ( $ars_list satbang ) endif if ($ACFTBIAS) then set ars_list = ( $ars_list acftbias ) @@ -2972,27 +2974,35 @@ endif /bin/rm -f input_combfr.txt touch input_combfr.txt foreach qcpat ( `cat pre-qc.acq | sort | uniq`) - echorc.x -template dummy $nymdb $nhmsb -fill $qcpat >> input_combfr.txt +# echorc.x -template dummy $nymdb $nhmsb -fill $qcpat >> input_combfr.txt + set fn = `echorc.x -template dummy $nymdb $nhmsb -fill $qcpat` + if ( -e $fn && ! -z $fn ) echo $fn >> input_combfr.txt end - combfrd.x -d $pbdtg $pbname < input_combfr.txt - scanbuf0.x $pbname >! data_types.log - if ( `grep PROFLR data_types.log | wc -l `) then - setenv PROFQC 1 + if ( -z input_combfr.txt) then +# if no files to combine then no input for prepqc, so try setting prepqc 0 + if ($PREPQC) setenv PREPQC 0 else - setenv PROFQC 0 - endif + combfrd.x -d $pbdtg $pbname < input_combfr.txt + scanbuf0.x $pbname >! data_types.log - if ( `grep AIRCFT data_types.log | wc -l`) then - setenv ACFTQC 1 - else - setenv ACFTQC 0 - endif + if ( `grep PROFLR data_types.log | wc -l `) then + setenv PROFQC 1 + else + setenv PROFQC 0 + endif - if ( `grep AIRCAR data_types.log | wc -l`) then - setenv ACARSQC 1 - else - setenv ACARSQC 0 + if ( `grep AIRCFT data_types.log | wc -l`) then + setenv ACFTQC 1 + else + setenv ACFTQC 0 + endif + + if ( `grep AIRCAR data_types.log | wc -l`) then + setenv ACARSQC 1 + else + setenv ACARSQC 0 + endif endif endif endif From cb4c31c9d8293496c5f1010f87882d11b0c6ddc9 Mon Sep 17 00:00:00 2001 From: gmao-msienkie Date: Thu, 2 Jun 2022 22:07:06 -0400 Subject: [PATCH 176/205] Modified tp check for prescence of pre-qc data files and skip combfrd.x and prepqc if no pre-qc files are present --- src/Applications/NCEP_Paqc/oiqc/prepqc_daemon.pl | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/Applications/NCEP_Paqc/oiqc/prepqc_daemon.pl b/src/Applications/NCEP_Paqc/oiqc/prepqc_daemon.pl index fcaee1dc..244c0a42 100755 --- a/src/Applications/NCEP_Paqc/oiqc/prepqc_daemon.pl +++ b/src/Applications/NCEP_Paqc/oiqc/prepqc_daemon.pl @@ -88,9 +88,14 @@ open(FH1,"+>input_combfr.txt") || die "prepqc: could not open input_combfr.txt"; foreach $qcpat ( `cat pre-qc.acq | sort | uniq`) { $pat = `echorc.x -template dummy $nymd $nhms -fill $qcpat`; - print FH1 ("$pat"); + print FH1 ("$pat") if ( -e $pat && ! -z $pat ) ; } close(FH1); + if ( -z "input_combfr.txt "{ + print"No pre-qc files present, skipping PREPQC\n"; + system("touch prepqc.$nymd.$nhms.done"); + return + } `combfrd.x -d $pbdtg $pbname < input_combfr.txt`; open(FH1,"+>data_types.log") || die "prepqc: could not open data_types.log"; @types = `scanbuf0.x $pbname`; From ae66a47ba357db2ae1872228ba849472995c7537 Mon Sep 17 00:00:00 2001 From: Joe Stassi Date: Fri, 3 Jun 2022 14:52:19 -0400 Subject: [PATCH 177/205] Updated fvsetup to add ARCHIVE definition to fstat_run job script and to correct tail +2 syntax error (changed to tail -n +2). --- src/Applications/GEOSdas_App/fvsetup | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index 94ccefce..a002db27 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -8331,9 +8331,9 @@ print SCRIPT <<"EOF"; cd \$FVWORK if (`uname -n` =~ borg*) then - cat \$PBS_NODEFILE | head -1 > \$FVWORK/OIQC_list - cat \$PBS_NODEFILE | tail +2 > \$FVWORK/GCM_list - cat \$PBS_NODEFILE > \$FVWORK/ANA_list + cat \$PBS_NODEFILE | head -1 > \$FVWORK/OIQC_list + cat \$PBS_NODEFILE | tail -n +2 > \$FVWORK/GCM_list + cat \$PBS_NODEFILE > \$FVWORK/ANA_list subset_nodefile.pl \$NCPUS_IDF -f \$PBS_NODEFILE -o \$FVWORK/IDF_list subset_nodefile.pl \$NCPUS_IAU -f \$PBS_NODEFILE -o \$FVWORK/IAU_list endif @@ -8610,6 +8610,7 @@ EOF endif echo2 "" echo2 "setenv FVHOME \$FVHOME" + echo2 "setenv ARCHIVE \$FVARCH" echo2 "set Bin = \$Bin" echo2 "set output = \$lname2" echo2 "" From 12e765a54f05e286c9dbbb233f0709011d0bd24b Mon Sep 17 00:00:00 2001 From: Joe Stassi Date: Fri, 3 Jun 2022 14:55:49 -0400 Subject: [PATCH 178/205] Updated the fvsetupID in the *.input files to match the updated fvsetup script, so that the *.input files can be run using the runjob script. The codeID values were also updated, but these are not currently being used for anything. --- src/Applications/GEOSdas_App/testsuites/C180RPY.input | 4 ++-- src/Applications/GEOSdas_App/testsuites/C180T14RPY.input | 4 ++-- src/Applications/GEOSdas_App/testsuites/C360L181_replay.input | 4 ++-- src/Applications/GEOSdas_App/testsuites/C360L91_replay.input | 4 ++-- src/Applications/GEOSdas_App/testsuites/C48f.input | 4 ++-- src/Applications/GEOSdas_App/testsuites/C90C.input | 4 ++-- src/Applications/GEOSdas_App/testsuites/C90C_ens.input | 4 ++-- src/Applications/GEOSdas_App/testsuites/C90C_replay.input | 4 ++-- src/Applications/GEOSdas_App/testsuites/fpp.input | 4 ++-- src/Applications/GEOSdas_App/testsuites/geos_it.input | 4 ++-- src/Applications/GEOSdas_App/testsuites/prePP.input | 4 ++-- src/Applications/GEOSdas_App/testsuites/x0046a.input | 4 ++-- src/Applications/GEOSdas_App/testsuites/x0046aRPY.input | 4 ++-- src/Applications/GEOSdas_App/testsuites/x0046a_Summer.input | 4 ++-- 14 files changed, 28 insertions(+), 28 deletions(-) diff --git a/src/Applications/GEOSdas_App/testsuites/C180RPY.input b/src/Applications/GEOSdas_App/testsuites/C180RPY.input index 34f8f108..593a9bcf 100644 --- a/src/Applications/GEOSdas_App/testsuites/C180RPY.input +++ b/src/Applications/GEOSdas_App/testsuites/C180RPY.input @@ -2,9 +2,9 @@ # C180RPY.input #------------ -codeID: b3a880f +codeID: 523f29e description: C180RPY__GEOSadas-5_29_3__agrid_C180__ogrid_C -fvsetupID: f7d8d041c9 +fvsetupID: f7aaa973c7 ---ENDHEADERS--- diff --git a/src/Applications/GEOSdas_App/testsuites/C180T14RPY.input b/src/Applications/GEOSdas_App/testsuites/C180T14RPY.input index 725a4117..fe8ce1ae 100644 --- a/src/Applications/GEOSdas_App/testsuites/C180T14RPY.input +++ b/src/Applications/GEOSdas_App/testsuites/C180T14RPY.input @@ -2,9 +2,9 @@ # C180T14RPY.input #------------ -codeID: b3a880f +codeID: 523f29e description: C180T14RPY__GEOSadas-5_29_3__agrid_C180__ogrid_T14 -fvsetupID: f7d8d041c9 +fvsetupID: f7aaa973c7 ---ENDHEADERS--- diff --git a/src/Applications/GEOSdas_App/testsuites/C360L181_replay.input b/src/Applications/GEOSdas_App/testsuites/C360L181_replay.input index 8fb60c32..8005f506 100644 --- a/src/Applications/GEOSdas_App/testsuites/C360L181_replay.input +++ b/src/Applications/GEOSdas_App/testsuites/C360L181_replay.input @@ -2,9 +2,9 @@ # C360L181_replay.input #------------ -codeID: b3a880f +codeID: 523f29e description: C360L181_replay__GEOSadas-5_29_3__agrid_C360__ogrid_C -fvsetupID: f7d8d041c9 +fvsetupID: f7aaa973c7 ---ENDHEADERS--- diff --git a/src/Applications/GEOSdas_App/testsuites/C360L91_replay.input b/src/Applications/GEOSdas_App/testsuites/C360L91_replay.input index 8171c146..5f2c93b5 100644 --- a/src/Applications/GEOSdas_App/testsuites/C360L91_replay.input +++ b/src/Applications/GEOSdas_App/testsuites/C360L91_replay.input @@ -2,9 +2,9 @@ # C360L91_replay.input #------------ -codeID: b3a880f +codeID: 523f29e description: C360L91_replay__GEOSadas-5_29_3__agrid_C360__ogrid_C -fvsetupID: f7d8d041c9 +fvsetupID: f7aaa973c7 ---ENDHEADERS--- diff --git a/src/Applications/GEOSdas_App/testsuites/C48f.input b/src/Applications/GEOSdas_App/testsuites/C48f.input index 2fec9da4..3313d8a8 100644 --- a/src/Applications/GEOSdas_App/testsuites/C48f.input +++ b/src/Applications/GEOSdas_App/testsuites/C48f.input @@ -2,9 +2,9 @@ # C48f.input #----------- -codeID: b3a880f +codeID: 523f29e description: C48f__GEOSadas-5_29_3__agrid_C48__ogrid_f34 -fvsetupID: f7d8d041c9 +fvsetupID: f7aaa973c7 fvsetupflags: -sensdeg 1 ---ENDHEADERS--- diff --git a/src/Applications/GEOSdas_App/testsuites/C90C.input b/src/Applications/GEOSdas_App/testsuites/C90C.input index 6dfc95ad..b8e9572f 100644 --- a/src/Applications/GEOSdas_App/testsuites/C90C.input +++ b/src/Applications/GEOSdas_App/testsuites/C90C.input @@ -2,9 +2,9 @@ # C90C.input #----------- -codeID: b3a880f +codeID: 523f29e description: C90C__GEOSadas-5_29_3__agrid_C90__ogrid_CS -fvsetupID: f7d8d041c9 +fvsetupID: f7aaa973c7 ---ENDHEADERS--- diff --git a/src/Applications/GEOSdas_App/testsuites/C90C_ens.input b/src/Applications/GEOSdas_App/testsuites/C90C_ens.input index 0d1195e0..a13c1f2f 100644 --- a/src/Applications/GEOSdas_App/testsuites/C90C_ens.input +++ b/src/Applications/GEOSdas_App/testsuites/C90C_ens.input @@ -2,9 +2,9 @@ # C90C_ens.input #--------------- -codeID: b3a880f +codeID: 523f29e description: C90C_ens__GEOSadas-5_29_3__agrid_C90__ogrid_C -fvsetupID: f7d8d041c9 +fvsetupID: f7aaa973c7 ---ENDHEADERS--- diff --git a/src/Applications/GEOSdas_App/testsuites/C90C_replay.input b/src/Applications/GEOSdas_App/testsuites/C90C_replay.input index b06f63fb..77dbaef7 100644 --- a/src/Applications/GEOSdas_App/testsuites/C90C_replay.input +++ b/src/Applications/GEOSdas_App/testsuites/C90C_replay.input @@ -2,9 +2,9 @@ # C90C_replay.input #--------------- -codeID: b3a880f +codeID: 523f29e description: C90C_replay__86f27c6__agrid_C90__ogrid_C -fvsetupID: f7d8d041c9 +fvsetupID: f7aaa973c7 ---ENDHEADERS--- diff --git a/src/Applications/GEOSdas_App/testsuites/fpp.input b/src/Applications/GEOSdas_App/testsuites/fpp.input index 574527d3..58c1867e 100644 --- a/src/Applications/GEOSdas_App/testsuites/fpp.input +++ b/src/Applications/GEOSdas_App/testsuites/fpp.input @@ -2,9 +2,9 @@ # fpp.input #------------ -codeID: b3a880f +codeID: 523f29e description: fpp__GEOSadas-5_29_3__agrid_C720__ogrid_C -fvsetupID: f7d8d041c9 +fvsetupID: f7aaa973c7 ---ENDHEADERS--- diff --git a/src/Applications/GEOSdas_App/testsuites/geos_it.input b/src/Applications/GEOSdas_App/testsuites/geos_it.input index ae7301ea..8664196a 100644 --- a/src/Applications/GEOSdas_App/testsuites/geos_it.input +++ b/src/Applications/GEOSdas_App/testsuites/geos_it.input @@ -2,9 +2,9 @@ # geos_it.input #-------------- -codeID: 7f742b1 +codeID: 523f29e description: geos_it__agrid_C180__ogrid_C -fvsetupID: bbf4f10063 +fvsetupID: f7aaa973c7 ---ENDHEADERS--- diff --git a/src/Applications/GEOSdas_App/testsuites/prePP.input b/src/Applications/GEOSdas_App/testsuites/prePP.input index a2886f86..eca3e77d 100644 --- a/src/Applications/GEOSdas_App/testsuites/prePP.input +++ b/src/Applications/GEOSdas_App/testsuites/prePP.input @@ -2,9 +2,9 @@ # prePP.input #------------ -codeID: b3a880f +codeID: 523f29e description: prePP__GEOSadas-5_29_3__agrid_C720__ogrid_C -fvsetupID: f7d8d041c9 +fvsetupID: f7aaa973c7 ---ENDHEADERS--- diff --git a/src/Applications/GEOSdas_App/testsuites/x0046a.input b/src/Applications/GEOSdas_App/testsuites/x0046a.input index b42d5623..eb480021 100644 --- a/src/Applications/GEOSdas_App/testsuites/x0046a.input +++ b/src/Applications/GEOSdas_App/testsuites/x0046a.input @@ -2,9 +2,9 @@ # x0046a.input #------------ -codeID: b3a880f +codeID: 523f29e description: x0046a__GEOSadas-5_29_3__agrid_C360__ogrid_C -fvsetupID: f7d8d041c9 +fvsetupID: f7aaa973c7 ---ENDHEADERS--- diff --git a/src/Applications/GEOSdas_App/testsuites/x0046aRPY.input b/src/Applications/GEOSdas_App/testsuites/x0046aRPY.input index ea49cfa0..b6b99dbe 100644 --- a/src/Applications/GEOSdas_App/testsuites/x0046aRPY.input +++ b/src/Applications/GEOSdas_App/testsuites/x0046aRPY.input @@ -2,9 +2,9 @@ # x0046aRPY.input #------------ -codeID: b3a880f +codeID: 523f29e description: x0046aRPY__GEOSadas-5_29_3__agrid_C360__ogrid_C -fvsetupID: f7d8d041c9 +fvsetupID: f7aaa973c7 ---ENDHEADERS--- diff --git a/src/Applications/GEOSdas_App/testsuites/x0046a_Summer.input b/src/Applications/GEOSdas_App/testsuites/x0046a_Summer.input index 3f3c85e3..4544267a 100644 --- a/src/Applications/GEOSdas_App/testsuites/x0046a_Summer.input +++ b/src/Applications/GEOSdas_App/testsuites/x0046a_Summer.input @@ -2,9 +2,9 @@ # x0046a.input #------------ -codeID: b3a880f +codeID: 523f29e description: x0046a__GEOSadas-5_29_3__agrid_C360__ogrid_C -fvsetupID: f7d8d041c9 +fvsetupID: f7aaa973c7 ---ENDHEADERS--- From 24e3002c871986fad58bc8b83c95832a15e3aea0 Mon Sep 17 00:00:00 2001 From: Amal El Akkraoui Date: Thu, 23 Jun 2022 09:33:58 -0400 Subject: [PATCH 179/205] Update various reanalysis-related resource files for GEOSIT and R21C --- src/Applications/GAAS_App/patmosx_l2a.py | 2 +- src/Applications/GEOSdas_App/GEOSdas.csm | 44 ++++++++++++------- src/Applications/GEOSdas_App/fvsetup | 4 +- src/Applications/GEOSdas_App/gen_lnbcs.pl | 14 ++++-- .../scripts/gmao/etc/R21C/obs1gsi_mean.rc | 9 +++- .../scripts/gmao/etc/R21C/obs1gsi_member.rc | 9 +++- .../NCEP_enkf/scripts/gmao/setup_atmens.pl | 1 - .../GMAOprev/prepobs_errtable.global | 28 ++++++------ .../NCEP_Paqc/oiqc/prepqc_daemon.pl | 7 ++- 9 files changed, 78 insertions(+), 40 deletions(-) diff --git a/src/Applications/GAAS_App/patmosx_l2a.py b/src/Applications/GAAS_App/patmosx_l2a.py index c3ea6247..b763d0d5 100755 --- a/src/Applications/GAAS_App/patmosx_l2a.py +++ b/src/Applications/GAAS_App/patmosx_l2a.py @@ -43,7 +43,7 @@ def patmosx_has_obs(fname): """ Returns true if PATMOSX reflectance file has something in it. """ - return 'latitude' in load(fname).keys() + return 'latitude' in load(fname,allow_pickle=True).keys() #--------------------------------------------------------------------- diff --git a/src/Applications/GEOSdas_App/GEOSdas.csm b/src/Applications/GEOSdas_App/GEOSdas.csm index bb71b721..038dc452 100755 --- a/src/Applications/GEOSdas_App/GEOSdas.csm +++ b/src/Applications/GEOSdas_App/GEOSdas.csm @@ -1969,9 +1969,11 @@ exit 1 endif endif - set ars_list = ( satbias satbang ) + set ars_list = ( satbias ) if ($NEWRADBC || $ANGLEBC) then set ars_list = ( $ars_list satbiaspc ) + else if ( ! $ANGLEBC ) then + set ars_list = ( $ars_list satbang ) endif if ($ACFTBIAS) then set ars_list = ( $ars_list acftbias ) @@ -2972,27 +2974,35 @@ endif /bin/rm -f input_combfr.txt touch input_combfr.txt foreach qcpat ( `cat pre-qc.acq | sort | uniq`) - echorc.x -template dummy $nymdb $nhmsb -fill $qcpat >> input_combfr.txt +# echorc.x -template dummy $nymdb $nhmsb -fill $qcpat >> input_combfr.txt + set fn = `echorc.x -template dummy $nymdb $nhmsb -fill $qcpat` + if ( -e $fn && ! -z $fn ) echo $fn >> input_combfr.txt end - combfrd.x -d $pbdtg $pbname < input_combfr.txt - scanbuf0.x $pbname >! data_types.log - if ( `grep PROFLR data_types.log | wc -l `) then - setenv PROFQC 1 + if ( -z input_combfr.txt) then +# if no files to combine then no input for prepqc, so try setting prepqc 0 + if ($PREPQC) setenv PREPQC 0 else - setenv PROFQC 0 - endif + combfrd.x -d $pbdtg $pbname < input_combfr.txt + scanbuf0.x $pbname >! data_types.log - if ( `grep AIRCFT data_types.log | wc -l`) then - setenv ACFTQC 1 - else - setenv ACFTQC 0 - endif + if ( `grep PROFLR data_types.log | wc -l `) then + setenv PROFQC 1 + else + setenv PROFQC 0 + endif - if ( `grep AIRCAR data_types.log | wc -l`) then - setenv ACARSQC 1 - else - setenv ACARSQC 0 + if ( `grep AIRCFT data_types.log | wc -l`) then + setenv ACFTQC 1 + else + setenv ACFTQC 0 + endif + + if ( `grep AIRCAR data_types.log | wc -l`) then + setenv ACARSQC 1 + else + setenv ACARSQC 0 + endif endif endif endif diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index 94ccefce..920c0996 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -392,7 +392,7 @@ my ($sysfile, $nodeflg); my (@rmTilde); my ($merra2, $acftbias, $doRcorr, $nrt, $rstype); my ($hyb_ens, $do4diau, $newradbc, $siglevs, $vres, $aensupa); -my ($geosit, $r21c); +my ($geosit, $r21c,$bcopt); system clear; get_runtime_values(); @@ -7484,6 +7484,8 @@ sub build_lnbcs { $bcopt = "-merra2" ; }elsif ( $r21c ) { $bcopt = "-r21c"; + }elsif ($geosit) { + $bcopt = "-geosit"; } if ( $cubed ) { $cmd = "$fvbin/gen_lnbcs.pl -fvhome $fvhome -o lnbcs $bcopt -cubed $agcm_im $agcm_jm $ogcm $landbcs"; diff --git a/src/Applications/GEOSdas_App/gen_lnbcs.pl b/src/Applications/GEOSdas_App/gen_lnbcs.pl index 6dcca493..3eb7ee59 100755 --- a/src/Applications/GEOSdas_App/gen_lnbcs.pl +++ b/src/Applications/GEOSdas_App/gen_lnbcs.pl @@ -33,6 +33,7 @@ "cubed", "merra2", "r21c", + "geosit", "h" ); usage() if $opt_h; @@ -139,9 +140,15 @@ sub init { } else { $BCSTAG = "$lndbcs/Icarus_Ostia"; } - $fvrtbcs = "g5gcm/bcs/realtime/OSTIA_REYNOLDS"; - $sstfile = "dataoceanfile_OSTIA_REYNOLDS_SST.$ogrid.\$year.data"; - $icefile = "dataoceanfile_OSTIA_REYNOLDS_ICE.$ogrid.\$year.data"; + if ($opt_r21c or $opt_geosit){ + $fvrtbcs = "g5gcm/bcs/realtime/OSTIA_REYNOLDS_ITR21C"; + $sstfile = "dataoceanfile_OSTIA_REYNOLDS_ITR21C_SST.$ogrid.\$year.data"; + $icefile = "dataoceanfile_OSTIA_REYNOLDS_ITR21C_ICE.$ogrid.\$year.data"; + } else { + $fvrtbcs = "g5gcm/bcs/realtime/OSTIA_REYNOLDS"; + $sstfile = "dataoceanfile_OSTIA_REYNOLDS_SST.$ogrid.\$year.data"; + $icefile = "dataoceanfile_OSTIA_REYNOLDS_ICE.$ogrid.\$year.data"; + } } elsif ($ogcm eq "T") { # Coupled-Tripolar-Ocean $coupled = 1; @@ -429,6 +436,7 @@ sub usage { -cubed needed for cubed GCM -merra2 specify to set related BCs -r21c specify to set related BCs + -geosit specify to set related BCs -h prints this usage notice EXAMPLE COMMAND LINE diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/R21C/obs1gsi_mean.rc b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/R21C/obs1gsi_mean.rc index 2e5adc68..b2a263fd 100644 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/R21C/obs1gsi_mean.rc +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/R21C/obs1gsi_mean.rc @@ -72,6 +72,13 @@ OBS_INPUT:: prepbufr uv null uv 0.0 0 0 gmao_prep_bufr prepbufr_profl t prof t 0.0 0 0 gmao_acftpfl_bufr prepbufr_profl uv prof uv 0.0 0 0 gmao_acftpfl_bufr + prepbufrt ps null ps 0.0 0 0 r21c_prep_bufr + prepbufrt t null t 0.0 0 0 r21c_prep_bufr + prepbufrt q null q 0.0 0 0 r21c_prep_bufr + prepbufrt uv null uv 0.0 0 0 r21c_prep_bufr + prepbufrt_profl t prof t 0.0 0 0 r21c_acftpfl_bufr + prepbufrt_profl uv prof uv 0.0 0 0 r21c_acftpfl_bufr + loonwinds uv null uv 0.0 0 0 r21c_loon_winds mlstbufr t aura t 0.0 0 0 r21c_gmao_mlst_bufr gpsrobufr gps_bnd null gps 0.0 0 0 r21c_gpsro_bufr tcvitl tcp null tcp 0.0 0 0 r21c_ncep_tcvitals @@ -83,7 +90,7 @@ OBS_INPUT:: sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0 r21c_osbuv8_bufr ompsnmeffnc ompsnmeff npp ompsnmeff_npp 0.0 2 0 r21c_npp_ompsnmeff_nc ! ompsnpnc ompsnpnc npp ompsnpnc_npp 0.0 0 0 r21c_npp_ompsnp_nc - ompslpgnc ompslp_g npp ompslp_g_npp 1.0 0 0 r21c_ompslp_g_nc +! ompslpgnc ompslp_g npp ompslp_g_npp 1.0 0 0 r21c_ompslp_g_nc ompslpvisnc ompslpvis npp ompslpvis_npp 0.0 0 0 r21c_ompslpvis_nc mlsnc mls55 aura mls55_aura 0.0 0 0 r21c_mls_nc omieffnc omieff aura omieff_aura 0.0 2 0 r21c_aura_omieff_nc diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/R21C/obs1gsi_member.rc b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/R21C/obs1gsi_member.rc index 5f2c8075..76b2bc88 100644 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/R21C/obs1gsi_member.rc +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/R21C/obs1gsi_member.rc @@ -72,6 +72,13 @@ OBS_INPUT:: prepbufr uv null uv 0.0 0 0 gmao_prep_bufr prepbufr_profl t prof t 0.0 0 0 gmao_acftpfl_bufr prepbufr_profl uv prof uv 0.0 0 0 gmao_acftpfl_bufr + prepbufrt ps null ps 0.0 0 0 r21c_prep_bufr + prepbufrt t null t 0.0 0 0 r21c_prep_bufr + prepbufrt q null q 0.0 0 0 r21c_prep_bufr + prepbufrt uv null uv 0.0 0 0 r21c_prep_bufr + prepbufrt_profl t prof t 0.0 0 0 r21c_acftpfl_bufr + prepbufrt_profl uv prof uv 0.0 0 0 r21c_acftpfl_bufr + loonwinds uv null uv 0.0 0 0 r21c_loon_winds mlstbufr t aura t 0.0 0 0 r21c_gmao_mlst_bufr gpsrobufr gps_bnd null gps 0.0 0 0 r21c_gpsro_bufr tcvitl tcp null tcp 0.0 0 0 r21c_ncep_tcvitals @@ -83,7 +90,7 @@ OBS_INPUT:: sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0 r21c_osbuv8_bufr ompsnmeffnc ompsnmeff npp ompsnmeff_npp 0.0 2 0 r21c_npp_ompsnmeff_nc ! ompsnpnc ompsnpnc npp ompsnpnc_npp 0.0 0 0 r21c_npp_ompsnp_nc - ompslpgnc ompslp_g npp ompslp_g_npp 1.0 0 0 r21c_ompslp_g_nc +! ompslpgnc ompslp_g npp ompslp_g_npp 1.0 0 0 r21c_ompslp_g_nc ompslpvisnc ompslpvis npp ompslpvis_npp 0.0 0 0 r21c_ompslpvis_nc mlsnc mls55 aura mls55_aura 0.0 0 0 r21c_mls_nc omieffnc omieff aura omieff_aura 0.0 2 0 r21c_aura_omieff_nc diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/setup_atmens.pl b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/setup_atmens.pl index c8b42bff..516aea61 100755 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/setup_atmens.pl +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/setup_atmens.pl @@ -426,7 +426,6 @@ sub install { cp("$FVROOT/bin/atm_ens.j","$FVHOME/run"); # generate boundary condition script -# $cmd = "$FVROOT/bin/gen_lnbcs.pl $cubed -o $FVHOME/run/lnbcs_ens $aim $ajm $ogrid $lndbcs"; $cmd = "$FVROOT/bin/gen_lnbcs.pl $cubed $bcopt -o $FVHOME/run/lnbcs_ens $aim $ajm $ogrid $lndbcs"; $rc = system($cmd); diff --git a/src/Applications/NCEP_Paqc/GMAOprev/prepobs_errtable.global b/src/Applications/NCEP_Paqc/GMAOprev/prepobs_errtable.global index bb246a1c..733ef998 100755 --- a/src/Applications/NCEP_Paqc/GMAOprev/prepobs_errtable.global +++ b/src/Applications/NCEP_Paqc/GMAOprev/prepobs_errtable.global @@ -5968,20 +5968,20 @@ 0.30000E+03 0.10000E+10 0.10000E+10 0.10000E+10 0.10000E+10 0.10000E+10 0.25000E+03 0.10000E+10 0.10000E+10 0.10000E+10 0.10000E+10 0.10000E+10 0.20000E+03 0.10000E+10 0.10000E+10 0.10000E+10 0.10000E+10 0.10000E+10 - 0.15000E+03 0.10000E+10 0.10000E+10 0.10000E+10 0.10000E+10 0.10000E+10 - 0.10000E+03 0.10000E+10 0.10000E+10 0.10000E+10 0.10000E+10 0.10000E+10 - 0.75000E+02 0.10000E+10 0.10000E+10 0.10000E+10 0.10000E+10 0.10000E+10 - 0.50000E+02 0.10000E+10 0.10000E+10 0.10000E+10 0.10000E+10 0.10000E+10 - 0.40000E+02 0.10000E+10 0.10000E+10 0.10000E+10 0.10000E+10 0.10000E+10 - 0.30000E+02 0.10000E+10 0.10000E+10 0.10000E+10 0.10000E+10 0.10000E+10 - 0.20000E+02 0.10000E+10 0.10000E+10 0.10000E+10 0.10000E+10 0.10000E+10 - 0.10000E+02 0.10000E+10 0.10000E+10 0.10000E+10 0.10000E+10 0.10000E+10 - 0.50000E+01 0.10000E+10 0.10000E+10 0.10000E+10 0.10000E+10 0.10000E+10 - 0.40000E+01 0.10000E+10 0.10000E+10 0.10000E+10 0.10000E+10 0.10000E+10 - 0.30000E+01 0.10000E+10 0.10000E+10 0.10000E+10 0.10000E+10 0.10000E+10 - 0.20000E+01 0.10000E+10 0.10000E+10 0.10000E+10 0.10000E+10 0.10000E+10 - 0.10000E+01 0.10000E+10 0.10000E+10 0.10000E+10 0.10000E+10 0.10000E+10 - 0.00000E+00 0.10000E+10 0.10000E+10 0.10000E+10 0.10000E+10 0.10000E+10 + 0.15000E+03 0.10000E+10 0.10000E+10 0.60000E+01 0.10000E+10 0.10000E+10 + 0.10000E+03 0.10000E+10 0.10000E+10 0.60000E+01 0.10000E+10 0.10000E+10 + 0.75000E+02 0.10000E+10 0.10000E+10 0.60000E+01 0.10000E+10 0.10000E+10 + 0.50000E+02 0.10000E+10 0.10000E+10 0.60000E+01 0.10000E+10 0.10000E+10 + 0.40000E+02 0.10000E+10 0.10000E+10 0.60000E+01 0.10000E+10 0.10000E+10 + 0.30000E+02 0.10000E+10 0.10000E+10 0.60000E+01 0.10000E+10 0.10000E+10 + 0.20000E+02 0.10000E+10 0.10000E+10 0.60000E+01 0.10000E+10 0.10000E+10 + 0.10000E+02 0.10000E+10 0.10000E+10 0.60000E+01 0.10000E+10 0.10000E+10 + 0.50000E+01 0.10000E+10 0.10000E+10 0.60000E+01 0.10000E+10 0.10000E+10 + 0.40000E+01 0.10000E+10 0.10000E+10 0.60000E+01 0.10000E+10 0.10000E+10 + 0.30000E+01 0.10000E+10 0.10000E+10 0.60000E+01 0.10000E+10 0.10000E+10 + 0.20000E+01 0.10000E+10 0.10000E+10 0.60000E+01 0.10000E+10 0.10000E+10 + 0.10000E+01 0.10000E+10 0.10000E+10 0.60000E+01 0.10000E+10 0.10000E+10 + 0.00000E+00 0.10000E+10 0.10000E+10 0.60000E+01 0.10000E+10 0.10000E+10 276 OBSERVATION TYPE 0.11000E+04 0.10000E+10 0.10000E+10 0.10000E+10 0.10000E+10 0.10000E+10 0.10500E+04 0.10000E+10 0.10000E+10 0.10000E+10 0.10000E+10 0.10000E+10 diff --git a/src/Applications/NCEP_Paqc/oiqc/prepqc_daemon.pl b/src/Applications/NCEP_Paqc/oiqc/prepqc_daemon.pl index fcaee1dc..244c0a42 100755 --- a/src/Applications/NCEP_Paqc/oiqc/prepqc_daemon.pl +++ b/src/Applications/NCEP_Paqc/oiqc/prepqc_daemon.pl @@ -88,9 +88,14 @@ open(FH1,"+>input_combfr.txt") || die "prepqc: could not open input_combfr.txt"; foreach $qcpat ( `cat pre-qc.acq | sort | uniq`) { $pat = `echorc.x -template dummy $nymd $nhms -fill $qcpat`; - print FH1 ("$pat"); + print FH1 ("$pat") if ( -e $pat && ! -z $pat ) ; } close(FH1); + if ( -z "input_combfr.txt "{ + print"No pre-qc files present, skipping PREPQC\n"; + system("touch prepqc.$nymd.$nhms.done"); + return + } `combfrd.x -d $pbdtg $pbname < input_combfr.txt`; open(FH1,"+>data_types.log") || die "prepqc: could not open data_types.log"; @types = `scanbuf0.x $pbname`; From e5456cc63eb6d82e52dd3332f1e06b3bf2fc55c2 Mon Sep 17 00:00:00 2001 From: gmao-msienkie Date: Thu, 21 Jul 2022 12:45:15 -0400 Subject: [PATCH 180/205] Increased NRPT and NEVNT from 500000 to 800000 to accommodate recent increase in numbers of reports --- .../NCEP_Paqc/prepobs_cqcvad.fd/cqcvad.f | 30 ++++++++++++++----- 1 file changed, 22 insertions(+), 8 deletions(-) diff --git a/src/Applications/NCEP_Paqc/prepobs_cqcvad.fd/cqcvad.f b/src/Applications/NCEP_Paqc/prepobs_cqcvad.fd/cqcvad.f index c553e822..a30a603a 100755 --- a/src/Applications/NCEP_Paqc/prepobs_cqcvad.fd/cqcvad.f +++ b/src/Applications/NCEP_Paqc/prepobs_cqcvad.fd/cqcvad.f @@ -67,6 +67,8 @@ C Level 2 decoder. C 2016-12-18 D. Stokes Increased NSTN (maximum number of stations to C process) from 200 to 300. Made minor correction in GETDAT. +C 2022-07-21 M. Sienkiewicz Increased NRPT and NEVNT from 500000 to +C 800000 to accommodate recent increase in numbers of reports C C USAGE: C INPUT FILES: @@ -343,6 +345,8 @@ PROGRAM PREPOBS_CQCVAD C 500000 to accommodate VAD wind reports from Level 2 decoder. C 2016-12-18 D. Stokes Increased NSTN (maximum number of stations to C process) from 200 to 300. +C 2022-07-21 M. Sienkiewicz Increased NRPT and NEVNT from 500000 to +C 800000 to accommodate recent increase in numbers of reports C C USAGE: CALL COMSTAT C @@ -353,7 +357,7 @@ PROGRAM PREPOBS_CQCVAD C$$$ SUBROUTINE COMSTAT - PARAMETER (NL=34,NTIM=5,NTIMES=6,NRPT=500000,NSTN=300) + PARAMETER (NL=34,NTIM=5,NTIMES=6,NRPT=800000,NSTN=300) PARAMETER (NLEV=35,NINC=3) INTEGER N12(0:NL,0:NTIM) REAL U1(0:NL,0:NTIM), V1(0:NL,0:NTIM), @@ -1050,6 +1054,8 @@ SUBROUTINE DRCTSL(FAALL,RAALL,DOTPRD,NDIM,MAXDIM,NXXYY,NFT) C Level 2 decoder. C 2016-12-18 D. Stokes Increased NSTN (maximum number of stations to C process) from 200 to 300. +C 2022-07-21 M. Sienkiewicz Increased NRPT and NEVNT from 500000 to +C 800000 to accommodate recent increase in numbers of reports C C USAGE: CALL EVNOUT(NUM1,NUM2,NLV) C INPUT ARGUMENT LIST: @@ -1064,8 +1070,8 @@ SUBROUTINE DRCTSL(FAALL,RAALL,DOTPRD,NDIM,MAXDIM,NXXYY,NFT) C$$$ SUBROUTINE EVNOUT(NUM1,NUM2,NLV) - PARAMETER (NRPT=500000,NSTN=300,NLEV=35) - parameter (nevnt=500000) + PARAMETER (NRPT=800000,NSTN=300,NLEV=35) + parameter (nevnt=800000) REAL(8) BMISS COMMON /SINGLE/ ZOB(NRPT), ITM(NRPT),TIM(NRPT), @@ -1312,6 +1318,8 @@ SUBROUTINE EVENTW(LUNIT,EVNSTR,NLV,UOBS,VOBS,QMS,RCS,IND,NEVN, C process) from 200 to 300. Also made a minor logic correction C so that the station info for the "NSTN'th" id is stored if C there are at least that many unique ids. +C 2022-07-21 M. Sienkiewicz Increased NRPT and NEVNT from 500000 to +C 800000 to accommodate recent increase in numbers of reports C C USAGE: CALL GETDAT(ITIME) C INPUT ARGUMENT LIST: @@ -1324,7 +1332,7 @@ SUBROUTINE EVENTW(LUNIT,EVNSTR,NLV,UOBS,VOBS,QMS,RCS,IND,NEVN, C$$$ SUBROUTINE GETDAT(ITIME) - PARAMETER (NRPT=500000,NSTN=300,NLEV=35,NTIMES=6,NINC=3) + PARAMETER (NRPT=800000,NSTN=300,NLEV=35,NTIMES=6,NINC=3) PARAMETER (MLV=255) ! no. of possible levels INTEGER IDAT(8), JDAT(8), ITIMES(8,4) REAL TDIF(5,4), RINC(5) @@ -1768,6 +1776,8 @@ SUBROUTINE HT(Z,IHT,IER) C useful for future debugging. C 2016-12-18 D. Stokes Increased NSTN (maximum number of stations to C process) from 200 to 300. +C 2022-07-21 M. Sienkiewicz Increased NRPT and NEVNT from 500000 to +C 800000 to accommodate recent increase in numbers of reports C C USAGE: CALL INCDIST C @@ -1781,7 +1791,7 @@ SUBROUTINE HT(Z,IHT,IER) C$$$ SUBROUTINE INCDIST - PARAMETER (NRPT=500000,NSTN=300,NLEV=35,NDIV=23,NTIMES=6,NINC=3) + PARAMETER (NRPT=800000,NSTN=300,NLEV=35,NDIV=23,NTIMES=6,NINC=3) COMMON /STN/ SLAT(NSTN), SLON(NSTN), SIDS(NSTN), STNID(NRPT), & ZSTN(NSTN) @@ -1951,6 +1961,8 @@ SUBROUTINE INCDIST C 500000 to accommodate VAD wind reports from Level 2 decoder. C 2016-12-18 D. Stokes Increased NSTN (maximum number of stations to C process) from 200 to 300. +C 2022-07-21 M. Sienkiewicz Increased NRPT and NEVNT from 500000 to +C 800000 to accommodate recent increase in numbers of reports C C USAGE: CALL INCR C @@ -1961,7 +1973,7 @@ SUBROUTINE INCDIST C$$$ SUBROUTINE INCR - PARAMETER (NRPT=500000,NSTN=300,NLEV=35,NTIMES=6,NINC=3) + PARAMETER (NRPT=800000,NSTN=300,NLEV=35,NTIMES=6,NINC=3) REAL(8) BMISS @@ -2369,6 +2381,8 @@ SUBROUTINE MATR(IS,IT) C Level 2 decoder. C 2016-12-18 D. Stokes Increased NSTN (maximum number of stations to C process) from 200 to 300. +C 2022-07-21 M. Sienkiewicz Increased NRPT and NEVNT from 500000 to +C 800000 to accommodate recent increase in numbers of reports C C USAGE: CALL DMA(HONOR_FLAGS) C INPUT ARGUMENT LIST: @@ -2381,8 +2395,8 @@ SUBROUTINE MATR(IS,IT) C$$$ SUBROUTINE DMA(HONOR_FLAGS) - PARAMETER (NRPT=500000,NSTN=300,NLEV=35,NTIMES=6,NINC=3) - PARAMETER (nevnt=500000) + PARAMETER (NRPT=800000,NSTN=300,NLEV=35,NTIMES=6,NINC=3) + PARAMETER (nevnt=800000) CHARACTER*8 SIDS, STNID, SIDEV REAL(8) BMISS From f3634429ea7cc549777acfc7de6651b8b9329fbf Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Mon, 25 Jul 2022 09:21:45 -0400 Subject: [PATCH 181/205] reconfig RO top --- src/Applications/GEOSdas_App/fvsetup | 4 ++-- src/Applications/GEOSdas_App/gen_silo_arc.pl | 1 + .../NCEP_enkf/scripts/gmao/etc/obs1gsi_mean.rc | 3 ++- .../NCEP_enkf/scripts/gmao/etc/obs1gsi_member.rc | 3 ++- .../NCEP_enkf/scripts/gmao/setup_atmens.pl | 14 +++----------- 5 files changed, 10 insertions(+), 15 deletions(-) diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index aa50fddf..9185e80b 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -1776,9 +1776,9 @@ sub ed_ncep_rc { } if ( $siglevs <= 72 ) { - if($rcd =~ /\@NLEV_EXT/) {$rcd=~ s/\@NLEV_EXT/15/g; } + if($rcd =~ /\@NLEV_EXT/) {$rcd=~ s/\@NLEV_EXT/18/g; } } elsif ( $siglevs > 72 & $siglevs <= 132 ) { - if($rcd =~ /\@NLEV_EXT/) {$rcd=~ s/\@NLEV_EXT/17/g; } + if($rcd =~ /\@NLEV_EXT/) {$rcd=~ s/\@NLEV_EXT/21/g; } } elsif ( $siglevs > 132 ) { if($rcd =~ /\@NLEV_EXT/) {$rcd=~ s/\@NLEV_EXT/27/g; } } diff --git a/src/Applications/GEOSdas_App/gen_silo_arc.pl b/src/Applications/GEOSdas_App/gen_silo_arc.pl index 6d6cd137..08542578 100755 --- a/src/Applications/GEOSdas_App/gen_silo_arc.pl +++ b/src/Applications/GEOSdas_App/gen_silo_arc.pl @@ -342,6 +342,7 @@ sub append_other_info { \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.ana.obs.%y4%m2%d2_%h2z.ods \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.prepbufr.%y4%m2%d2.t%h2z.blk \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.acft_profl.%y4%m2%d2.t%h2z.bfr +\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.gmao_global_convinfo.%y4%m2%d2_%h2z.txt \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.gmao_global_satinfo.%y4%m2%d2_%h2z.txt \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.gmao_global_ozinfo.%y4%m2%d2_%h2z.txt \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.sac.nl.%y4%m2%d2_%h2z.txt diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/obs1gsi_mean.rc b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/obs1gsi_mean.rc index 8afcbf95..3efa76db 100644 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/obs1gsi_mean.rc +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/obs1gsi_mean.rc @@ -20,7 +20,8 @@ biascor=-0.10,bcoption=0,diurnalbc=1.0, crtm_coeffs_path="CRTM_Coeffs/", print_diag_pcg=.false., - use_compress=.true.,nsig_ext=@NSIG_EXT,gpstop=60.,lgpsbnd_revint=.true., + use_compress=.true.,nsig_ext=@NSIG_EXT,gpstop=55.,lgpsbnd_revint=.true., + commgpstop=45.,spiregpserrinf=2., use_sp_eqspace=.true., reduce_diag=.true., luse_obsdiag=.true., diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/obs1gsi_member.rc b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/obs1gsi_member.rc index 3df6806c..12ea1c25 100644 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/obs1gsi_member.rc +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/obs1gsi_member.rc @@ -20,7 +20,8 @@ biascor=-0.10,bcoption=0,diurnalbc=1.0, crtm_coeffs_path="CRTM_Coeffs/", print_diag_pcg=.false., - use_compress=.true.,nsig_ext=@NSIG_EXT,gpstop=60.,lgpsbnd_revint=.true., + use_compress=.true.,nsig_ext=@NSIG_EXT,gpstop=55.,lgpsbnd_revint=.true., + commgpstop=45.,spiregpserrinf=2., use_sp_eqspace=.true., reduce_diag=.true., luse_obsdiag=.true., diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/setup_atmens.pl b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/setup_atmens.pl index 516aea61..ef260d19 100755 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/setup_atmens.pl +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/setup_atmens.pl @@ -603,21 +603,13 @@ sub ed_obsv_rc { GSI_GridComp_ensfinal.rc.tmpl obs1gsi_mean.rc obs1gsi_member.rc ); - $nsig_ext = 15; + $nsig_ext = 18; if ( $obsv_lm > 72 & $obsv_lm <= 132 ) { - $nsig_ext = 17; + $nsig_ext = 21; } elsif ( $obsv_lm > 132 ) { - $nsig_ext = 25; + $nsig_ext = 27; } - if ( $siglevs <= 72 ) { - if($rcd =~ /\@NLEV_EXT/) {$rcd=~ s/\@NLEV_EXT/13/g; } - } elsif ( $siglevs > 72 & $siglevs <= 132 ) { - if($rcd =~ /\@NLEV_EXT/) {$rcd=~ s/\@NLEV_EXT/15/g; } - } elsif ( $siglevs > 132 ) { - if($rcd =~ /\@NLEV_EXT/) {$rcd=~ s/\@NLEV_EXT/21/g; } - } - foreach $file (@observer_files) { $tmprc = "$mydir/tmp.rc"; From 5577c663073973df5e1d169b95ccb4a4a4965ac6 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Wed, 3 Aug 2022 14:18:08 -0400 Subject: [PATCH 182/205] Spire RO, plus almost all for GEOS-IT --- components.yaml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/components.yaml b/components.yaml index 14f76997..5ded9eae 100644 --- a/components.yaml +++ b/components.yaml @@ -28,7 +28,7 @@ NCEP_Shared: GMAO_Shared: local: ./src/Shared/@GMAO_Shared remote: ../GMAO_Shared.git - tag: rt1_4_10_geosit + tag: rt1_4_10_geosit2 develop: main MAPL: @@ -46,7 +46,7 @@ FMS: GEOSana_GridComp: local: ./src/Components/@GEOSana_GridComp remote: ../GEOSana_GridComp.git - tag: v1.5.4.2 + tag: v1.5.4.3 develop: develop GEOSgcm_GridComp: @@ -101,7 +101,7 @@ geos-chem: GOCART: local: ./src/Components/@GEOSgcm_GridComp/GEOSagcm_GridComp/GEOSphysics_GridComp/@GEOSchem_GridComp/@GOCART remote: ../GOCART.git - tag: rt1.0.1_geosit + tag: rt1.0.1_geosit2 sparse: ./config/GOCART.sparse develop: develop @@ -121,7 +121,7 @@ mom6: GEOSgcm_App: local: ./src/Applications/@GEOSgcm_App remote: ../GEOSgcm_App.git - tag: rt1.5.6_geosit_hist2 + tag: rt1.5.6_geosit_hist3 develop: develop UMD_Etc: From d6f9b329d478853a4cb959a7ad204b09eaab01e0 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Mon, 15 Aug 2022 15:08:37 -0400 Subject: [PATCH 183/205] more GEOS-IT --- src/Applications/GAAS_App/ana.rc.tmpl | 2 +- src/Applications/GEOSdas_App/fvsetup | 11 +++++++---- src/Applications/GEOSdas_App/testsuites/geos_it.input | 10 +++++----- 3 files changed, 13 insertions(+), 10 deletions(-) diff --git a/src/Applications/GAAS_App/ana.rc.tmpl b/src/Applications/GAAS_App/ana.rc.tmpl index ff285eb7..19c33a67 100644 --- a/src/Applications/GAAS_App/ana.rc.tmpl +++ b/src/Applications/GAAS_App/ana.rc.tmpl @@ -38,7 +38,7 @@ ODS_files:: #___MISR___${FVWORK}/misr_F12_0022.bright_tc8.obs.%y4%m2%d2.ods -#___AERONET___${FVWORK}/aeronet.obs.%y4%m2%d2.ods +#___AERONET___${FVWORK}/aeronet.obs.%y4%m2%d2_%h2z.ods # Passive data #/nobackup/3/PARASOL/Level2/ODS/Y%y4/M%m2/PARASOL_L2.aero_tc8.obs.%y4%m2%d2.ods diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index 9185e80b..94684b3f 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -3062,7 +3062,7 @@ sub get_nodeflg { elsif ($ans == 3) { $nodeflg = "ivy"; $ncpus_per_node = 20 } elsif ($ans == 4) { $nodeflg = "hasw"; $ncpus_per_node = 24 } elsif ($ans == 5) { $nodeflg = "sky"; $ncpus_per_node = 36 } - elsif ($ans == 6) { $nodeflg = "cas"; $ncpus_per_node = 46 } + elsif ($ans == 6) { $nodeflg = "cas"; $ncpus_per_node = 45 } # currently not applicable at nccs #--------------------------------- @@ -3110,7 +3110,7 @@ sub get_times { # # ---- if ($res eq "C48") { $nx = 4; $ny = 24 } # (b) 96 elsif ($res eq "C90") { $nx = 4; $ny = 24 } # (c) 96 - elsif ($res eq "C180") { $nx = 8; $ny = 30 } # (d) 240 + elsif ($res eq "C180") { $nx = 15; $ny = 36 } # (d) 360 elsif ($res eq "C360") { $nx = 8; $ny = 48 } # (e) 384 else { $nx = 28; $ny = 48 } # (f+) 1344 } @@ -5007,6 +5007,9 @@ EOF $ana_im_ens = $ana_im; $ana_jm_ens = $ana_jm; } elsif ( "$res" eq "C180" ) { # Cubed-sphere + if ($geosit) { + $o_servers = 0; # 10; this does not payoff for C180 resolution + } $cubed = 1; # $ios_nds = 2; $specres = "254"; @@ -8060,7 +8063,7 @@ print SCRIPT <<"EOF"; setenv RUN_OPT_BLEND "esma_mpirun -np \$NCPUS \$HDF2RSX" if (\$G5GCM ) then if ( \$O_SERVERS > 0 ) then - setenv RUN_OPT_BEGIN "mpirun -np \$NCPUSX \$GCMX --npes_model \$NCUPS --nodes_output_server \$O_SERVERS --oserver_type multigroup --npes_backend_pernode \$O_SERVERS" + setenv RUN_OPT_BEGIN "mpirun -np \$NCPUSX \$GCMX --npes_model \$NCPUS --nodes_output_server \$O_SERVERS --oserver_type multigroup --npes_backend_pernode \$O_SERVERS" else setenv RUN_OPT_BEGIN "esma_mpirun -np \$NCPUS \$GCMX" endif @@ -9251,7 +9254,7 @@ print SCRIPT <<"EOF"; setenv RUN_OPT_BLEND "esma_mpirun -np \$NCPUS \$HDF2RSX" if (\$G5GCM ) then if ( \$O_SERVERS > 0 ) then - setenv RUN_OPT_BEGIN "mpirun -np \$NCPUSX \$GCMX --npes_model \$NCUPS --nodes_output_server \$O_SERVERS --oserver_type multigroup --npes_backend_pernode \$O_SERVERS" + setenv RUN_OPT_BEGIN "mpirun -np \$NCPUSX \$GCMX --npes_model \$NCPUS --nodes_output_server \$O_SERVERS --oserver_type multigroup --npes_backend_pernode \$O_SERVERS" else setenv RUN_OPT_BEGIN "esma_mpirun -np \$NCPUS \$GCMX" endif diff --git a/src/Applications/GEOSdas_App/testsuites/geos_it.input b/src/Applications/GEOSdas_App/testsuites/geos_it.input index 8664196a..1b00f2fc 100644 --- a/src/Applications/GEOSdas_App/testsuites/geos_it.input +++ b/src/Applications/GEOSdas_App/testsuites/geos_it.input @@ -98,11 +98,11 @@ Length of FORECAST run segments (in hours)? [123] Number of one-day DAS segments per PBS job? [1] > -Number of PEs in the zonal direction (NX)? [8] -> +Number of PEs in the zonal direction (NX)? [15] +> 15 -Number of PEs in the meridional direction (NY)? [30] -> 48 +Number of PEs in the meridional direction (NY)? [36] +> 36 Job nickname? [g5das] > git @@ -195,7 +195,7 @@ Do Aerosol Analysis (y/n)? [y] > AOD OBSERVING CLASSES [or type 'none']? -> mod04_061_his,myd04_061_his +> mod04_061_his,myd04_061_his,aeronet_obs Enable GAAS feedback to model (y/n)? [y] > From 50a843e8bb0328d8887483a69ec996b77b09d921 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Mon, 15 Aug 2022 15:09:37 -0400 Subject: [PATCH 184/205] more for GEOS-IT --- components.yaml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/components.yaml b/components.yaml index 5ded9eae..4bcfcf12 100644 --- a/components.yaml +++ b/components.yaml @@ -28,13 +28,13 @@ NCEP_Shared: GMAO_Shared: local: ./src/Shared/@GMAO_Shared remote: ../GMAO_Shared.git - tag: rt1_4_10_geosit2 + tag: rt1_4_10_geosit4 develop: main MAPL: local: ./src/Shared/@MAPL remote: ../MAPL.git - tag: v2.8.0.7 + tag: v2.8.0.9 develop: develop FMS: @@ -46,7 +46,7 @@ FMS: GEOSana_GridComp: local: ./src/Components/@GEOSana_GridComp remote: ../GEOSana_GridComp.git - tag: v1.5.4.3 + tag: v1.5.4.4 develop: develop GEOSgcm_GridComp: From 4448491eaf2c3ff92e654ae9bfa49f18f6abb289 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Mon, 15 Aug 2022 15:16:47 -0400 Subject: [PATCH 185/205] revise geos-it history --- components.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/components.yaml b/components.yaml index 4bcfcf12..ccc3b531 100644 --- a/components.yaml +++ b/components.yaml @@ -121,7 +121,7 @@ mom6: GEOSgcm_App: local: ./src/Applications/@GEOSgcm_App remote: ../GEOSgcm_App.git - tag: rt1.5.6_geosit_hist3 + tag: rt1.5.6_geosit_hist4 develop: develop UMD_Etc: From 0eff43fb35b5fa480042dbf275c30f0d16207d57 Mon Sep 17 00:00:00 2001 From: Joe Stassi Date: Mon, 22 Aug 2022 15:41:37 -0400 Subject: [PATCH 186/205] Updates to handle local acquire of obs and gaas_obs in the same manner. --- src/Applications/GEOSdas_App/GEOSdas.csm | 106 +++++------------------ src/Applications/GEOSdas_App/fvsetup | 6 +- 2 files changed, 27 insertions(+), 85 deletions(-) diff --git a/src/Applications/GEOSdas_App/GEOSdas.csm b/src/Applications/GEOSdas_App/GEOSdas.csm index bb71b721..e58b1698 100755 --- a/src/Applications/GEOSdas_App/GEOSdas.csm +++ b/src/Applications/GEOSdas_App/GEOSdas.csm @@ -158,7 +158,6 @@ if ( !($?STRICT) ) setenv STRICT 0 if ( !($?TIMEINC) ) setenv TIMEINC 360 if ( !($?USE_ASCAT) ) setenv USE_ASCAT 0 - if ( !($?USE_MODIS_STAGE) ) setenv USE_MODIS_STAGE 0 if ( !($?VAROFFSET) ) setenv VAROFFSET 180 if ( !($?VTRACK) ) setenv VTRACK 1 if ( !($?VTRKFRQA ) ) setenv VTRKFRQA 0 @@ -166,6 +165,12 @@ if ( !($?VTXRELOC ) ) setenv VTXRELOC 1 if ( !($?WCONSTRAINT) ) setenv WCONSTRAINT 0 + if ( $BATCH_SUBCMD == "sbatch" ) then + setenv blockflag "-W" + else + setenv blockflag "-W block=true" + endif + if ( !($?doPLOTS) ) setenv doPLOTS 0 if ( !($?doFSENS) ) then if ( -e stage4fsens.arc ) then @@ -613,15 +618,6 @@ exit 1 cp -f AGCM.BOOTSTRAP.rc.tmpl AGCM.rc.tmpl endif -# Turn off aerosol data sets for local acquire and replay -# ------------------------------------------------------- - if ( $LOCAL_ACQUIRE ) then - set aerosol_acquire = 0 - setenv USE_MODIS_STAGE 1 - else - set aerosol_acquire = 1 - endif - # If 4DVAR then link to adjoint nml file # -------------------------------------- if (-e fvcorepert_layout_4dvar.rc) then @@ -1557,11 +1553,7 @@ exit 1 fname2 " acquire -v -rc blend.acq -s $spool -d . -strict $nymd $nhms 060000 1 " fname2 "exit" - if ( $BATCH_SUBCMD == "sbatch" ) then - sbatch -W -o $acqlog $fname - else - qsub -W block=true -o $acqlog $fname - endif + $BATCH_SUBCMD $blockflag -o $acqlog $fname endif @@ -1699,11 +1691,7 @@ exit 1 endif fname2 "exit" - if ( $BATCH_SUBCMD == "sbatch" ) then - sbatch -W -o $acqlog $fname - else - qsub -W block=true -o $acqlog $fname - endif + $BATCH_SUBCMD $blockflag -o $acqlog $fname endif @@ -1897,11 +1885,7 @@ exit 1 fname2 " acquire -v -rc aod4fcst.acq -s $spool -d . -strict $initref[1] $initref[2] 030000 2 " fname2 "exit" - if ( $BATCH_SUBCMD == "sbatch" ) then - sbatch -W -o $acqlog $fname - else - qsub -W block=true -o $acqlog $fname - endif + $BATCH_SUBCMD $blockflag -o $acqlog $fname endif @@ -2477,11 +2461,7 @@ exit 1 fname2 "" fname2 "exit" - if ( $BATCH_SUBCMD == "sbatch" ) then - sbatch -W -o $acqlog $fname - else - qsub -W block=true -o $acqlog $fname - endif + $BATCH_SUBCMD $blockflag -o $acqlog $fname sleep 2 @ cyc_sec = $TIMEINC * 60 set next_cycle = (`tick $rpl_nymdb $rpl_nhmsb $cyc_sec`) @@ -2585,11 +2565,7 @@ exit 1 fname2 "acquire -v -rc obsys.acq -s $spool -d $FVWORK -ssh $strict $bnymd $bnhms $inhms 4" fname2 "exit" - if ( $BATCH_SUBCMD == "sbatch" ) then - sbatch -W -o $acqlog $fname - else - qsub -W block=true -o $acqlog $fname - endif + $BATCH_SUBCMD $blockflag -o $acqlog $fname sleep 2 set bnymd=`tick $bnymd` end @@ -2635,7 +2611,7 @@ exit 1 # Acquire data for obsys on cmd line # ---------------------------------- - if ( (`uname -n` !~ borg*) || ( $LOCAL_ACQUIRE ) ) then + if ( `uname -n` !~ borg* ) then # acquire tcvitals; ignore status return #--------------------------------------- @@ -2749,17 +2725,13 @@ exit 1 set obsflag = 2 set acqflags = "-d $spool -s $spool -e 999" set acqflags1 = "$acqflags" - set blockflag = "" + set qblock = "" else if ( !($?strict) ) set strict = "" set obsflag = 1 set acqflags = "-d $FVWORK -s $spool -strict" set acqflags1 = "-d $FVWORK -s $spool $strict" - if ( $BATCH_SUBCMD == "sbatch" ) then - set blockflag = "-W" - else - set blockflag = "-W block=true" - endif + set qblock = $blockflag endif # Check for available AOD obs classes @@ -2813,7 +2785,7 @@ exit 1 if ( $AOD_OBSCLASS == "" ) setenv AOD_OBSCLASS none if ( $AOD_OBSCLASS == 0 ) setenv AOD_OBSCLASS none - if ($GAAS_ANA && $aerosol_acquire && ("$AOD_OBSCLASS" != "none")) then + if ($GAAS_ANA && ! $REPLAY_ACQ && ("$AOD_OBSCLASS" != "none")) then @ mstep = $nstep * 2 fname2 acquire_obsys -v $acqflags -ssh -drc $AERO_OBSDBRC \\ fname2 " "$bnymd $bnhms 030000 $mstep \\ @@ -2845,7 +2817,12 @@ exit 1 # submit job script #------------------ - $BATCH_SUBCMD $blockflag -o $acqlog $fname # acquire observations; ignore status return + if ( $LOCAL_ACQUIRE ) then + chmod 744 $fname + $fname |& tee $acqlog + else + $BATCH_SUBCMD $qblock -o $acqlog $fname # acquire observations; ignore status return + endif sleep 2 if ($obsflag == 1 && ( -e obsys.acq )) then cat obsys.acq >>! obsys.acq.all @@ -4126,11 +4103,7 @@ endif "Central AGCM Failed " if ( -e agcm_central.j ) then - if ( $BATCH_SUBCMD == "sbatch" ) then - sbatch -W agcm_central.j - else - qsub -W block=true agcm_central.j - endif + $BATCH_SUBCMD $blockflag agcm_central.j else echo " ${MYNAME}: AGCM Failed to generate PBS jobs for Central, Aborting ... " exit(1) @@ -4268,22 +4241,6 @@ endif /bin/cp $FVHOME/run/gaas/avhrr_l2a.pcf $AODWORK /bin/cp $FVHOME/run/gaas/modis_l2a.pcf $AODWORK - # Reset value of MODIS_L2A_L2_DIR to $MODIS_STAGE_DIR? - # --------------------------------------------------- - if ($GAAS_ANA && $USE_MODIS_STAGE) then - if ( ! $?MODIS_STAGE_DIR ) then - echo "Error. MODIS_STAGE_DIR not defined" - echo "Aborting ... " - Call AbnormalExit_( 5 ) - endif - if ( ! -d $MODIS_STAGE_DIR ) then - echo "Error. MODIS_STAGE_DIR directory not found: $MODIS_STAGE_DIR" - echo "Aborting ... " - Call AbnormalExit_( 5 ) - endif - vED -i -vv MODIS_L2A_L2_DIR=$MODIS_STAGE_DIR $AODWORK/modis_l2a.pcf - endif - # Prepare ana.rc from template # ---------------------------- set ana_rc_tmpl = $FVHOME/run/gaas/ana.rc.tmpl @@ -4330,12 +4287,6 @@ endif endif end -# if ($USE_MODIS_STAGE) then -# setenv MODIS_L2_HDF 1 -# sed -i "s/#___AQUA_NRT___//" $ana_rc -# sed -i "s/#___TERRA_NRT___//" $ana_rc -# endif - echo "cat $ana_rc" cat $ana_rc @@ -4431,13 +4382,8 @@ endif # submit job and save job ID #--------------------------- - if ( $BATCH_SUBCMD == "sbatch" ) then - set qblock = "-W" - else - set qblock = "-W block=true" - endif if ( $AODBLOCKJOB ) then - set jobIDline = (`$PBS_BIN/$BATCH_SUBCMD $qblock -o $gaasLOG $jobf`) + set jobIDline = (`$PBS_BIN/$BATCH_SUBCMD $blockflag -o $gaasLOG $jobf`) else set jobIDline = (`$PBS_BIN/$BATCH_SUBCMD -o $gaasLOG $jobf`) endif @@ -4833,11 +4779,7 @@ endif fname2 " acquire_obsys -v -d $FVWORK $strict $anadate[1] $anadate[2] 060000 1 $tcvitals_class" fname2 "exit" - if ( $BATCH_SUBCMD == "sbatch" ) then - sbatch -W -o $acqlog $fname - else - qsub -W block=true -o $acqlog $fname - endif + $BATCH_SUBCMD $blockflag -o $acqlog $fname endif ls -lrt *vtx.prs* *vtx.mix* diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index 94ccefce..1ec85739 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -7771,8 +7771,6 @@ print SCRIPT <<"EOF"; setenv LDHOME4ENS $ldashome4ens # land analysis home dir for atm_ens setenv IGNORE_0 1 # 1 = ignore 0 length obs files in acquire setenv ACFTBIAS $acftbias - setenv USE_MODIS_STAGE 0 # 1 = use MODIS data from MODIS_STAGE_DIR; 0 = don't - setenv MODIS_STAGE_DIR /discover/nobackup/projects/gmao/input/dao_ops/ops/flk/modis # L2a non-archive data dir setenv FCSTIMES "$fcstimes" setenv FCSTATS "21" setenv FHOURS $fhours21 @@ -7783,7 +7781,9 @@ print SCRIPT <<"EOF"; # setenv DO_0HR_IMP 1 if ( -e \$FVHOME/run/replay.acq ) then - setenv USE_MODIS_STAGE 1 # for now, replay.acq controls only meteorology (AOD is not yet replayed to) + setenv REPLAY_ACQ 1 # for now, replay.acq controls only meteorology (AOD is not yet replayed to) + else + setenv REPLAY_ACQ 0 endif EOF From b0196d7944b3532745be67a7deb260c8f05637b0 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Tue, 23 Aug 2022 05:30:05 -0400 Subject: [PATCH 187/205] setting for geosit; revised o_writers --- src/Applications/GEOSdas_App/fvsetup | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index 94684b3f..3f0f796d 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -386,7 +386,7 @@ my ($acqloc); my ($fcstimes,$fcswait_hrs,$asnwait_hrs); my ($landbcs); my ($coupled, $ores, $mometc); -my ($o_servers); +my ($o_servers,$bckend_wrts); my ($sysfile, $nodeflg); my (@rmTilde); @@ -4735,6 +4735,7 @@ EOF $ny_pert = 6 * $nx_pert; $use_shmem = 0; $o_servers = 0; + $bckend_wrts = 0; $ios_nds = 1; $cldmicro = "1MOMENT"; if ( "$res" eq "c" && "$vres" eq "55" ) { @@ -5008,7 +5009,8 @@ EOF $ana_jm_ens = $ana_jm; } elsif ( "$res" eq "C180" ) { # Cubed-sphere if ($geosit) { - $o_servers = 0; # 10; this does not payoff for C180 resolution + $o_servers = 3; + $bckend_wrts = 24; } $cubed = 1; # $ios_nds = 2; @@ -5079,7 +5081,7 @@ EOF } elsif ( "$res" eq "C720" ) { # Cubed-sphere $cubed = 1; $o_servers = 8; -# $ios_nds = 3; + $bckend_wrts = 8; $specres = "254"; $jcap = "254"; $agcm_grid_type = "Cubed-Sphere"; @@ -7671,6 +7673,7 @@ print SCRIPT <<"EOF"; setenv NCPUS_GPERT $ncpus_gpert # Number of CPUs to run gcmPERT setenv NCPUS_AOD $ncpus_aod # Number of CPUs to run PSAS-AOD setenv O_SERVERS $o_servers # Number of IO servers + setenv O_WRITERS_PER_NODE $bckend_wrts # Number of backend writers #setenv GAAS_RUN_SLURM 1 # launch AOD analysis as separate batch job setenv AODBLOCKJOB 1 EOF @@ -8063,7 +8066,7 @@ print SCRIPT <<"EOF"; setenv RUN_OPT_BLEND "esma_mpirun -np \$NCPUS \$HDF2RSX" if (\$G5GCM ) then if ( \$O_SERVERS > 0 ) then - setenv RUN_OPT_BEGIN "mpirun -np \$NCPUSX \$GCMX --npes_model \$NCPUS --nodes_output_server \$O_SERVERS --oserver_type multigroup --npes_backend_pernode \$O_SERVERS" + setenv RUN_OPT_BEGIN "mpirun -np \$NCPUSX \$GCMX --npes_model \$NCPUS --nodes_output_server \$O_SERVERS --oserver_type multigroup --npes_backend_pernode \$O_WRITERS_PER_NODE" else setenv RUN_OPT_BEGIN "esma_mpirun -np \$NCPUS \$GCMX" endif @@ -8854,6 +8857,7 @@ print SCRIPT <<"EOF"; setenv NCPUS_GSI $ncpus_gsi # Numbers of CPUs to run GSI setenv NCPUS_GPERT $ncpus_gpert # Numbers of CPUs to run GSI setenv O_SERVERS $o_servers # Number of IO servers + setenv O_WRITERS_PER_NODE $bckend_wrts # Backend writers setenv N_CPU \$NCPUS setenv EXPID $expid # experiment ID setenv CASE \$EXPID # experiment ID (for LSM's sake) @@ -9254,7 +9258,7 @@ print SCRIPT <<"EOF"; setenv RUN_OPT_BLEND "esma_mpirun -np \$NCPUS \$HDF2RSX" if (\$G5GCM ) then if ( \$O_SERVERS > 0 ) then - setenv RUN_OPT_BEGIN "mpirun -np \$NCPUSX \$GCMX --npes_model \$NCPUS --nodes_output_server \$O_SERVERS --oserver_type multigroup --npes_backend_pernode \$O_SERVERS" + setenv RUN_OPT_BEGIN "mpirun -np \$NCPUSX \$GCMX --npes_model \$NCPUS --nodes_output_server \$O_SERVERS --oserver_type multigroup --npes_backend_pernode \$O_WRITERS_PER_NODE" else setenv RUN_OPT_BEGIN "esma_mpirun -np \$NCPUS \$GCMX" endif From 3cc6039c962d3a4b9a8abe321cecc735e09f5210 Mon Sep 17 00:00:00 2001 From: Amal El Akkraoui Date: Tue, 23 Aug 2022 07:20:39 -0400 Subject: [PATCH 188/205] updates to fix aerosol assimilation of AVHRR data for GEOSIT/R21C --- src/Applications/GAAS_App/ana.rc.tmpl | 7 ++++--- src/Applications/GEOSdas_App/GEOSdas.csm | 2 +- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Applications/GAAS_App/ana.rc.tmpl b/src/Applications/GAAS_App/ana.rc.tmpl index ff285eb7..1cab053b 100644 --- a/src/Applications/GAAS_App/ana.rc.tmpl +++ b/src/Applications/GAAS_App/ana.rc.tmpl @@ -17,8 +17,9 @@ ODS_files:: # Active data (Note: deep blue in MYD04 is passive) -#___AVHRR___${FVWORK}/${EXPID}.patmosx_v05r02_L2a.asc.%y4%m2%d2_%h200z.ods -#___AVHRR___${FVWORK}/${EXPID}.patmosx_v05r02_L2a.des.%y4%m2%d2_%h200z.ods +##___AVHRR___${FVWORK}/${EXPID}.patmosx_v05r02_L2a.asc.%y4%m2%d2_%h200z.ods +##___AVHRR___${FVWORK}/${EXPID}.patmosx_v05r02_L2a.des.%y4%m2%d2_%h200z.ods +#___AVHRR___${FVWORK}/patmosx.%y4%m2%d2_%h2z.ods #___TERRA_NRT___${FVWORK}/${EXPID}.MOD04_L2a.land.%y4%m2%d2_%h200z.ods #___TERRA_NRT___${FVWORK}/${EXPID}.MOD04_L2a.ocean.%y4%m2%d2_%h200z.ods @@ -38,7 +39,7 @@ ODS_files:: #___MISR___${FVWORK}/misr_F12_0022.bright_tc8.obs.%y4%m2%d2.ods -#___AERONET___${FVWORK}/aeronet.obs.%y4%m2%d2.ods +#___AERONET___${FVWORK}/aeronet.obs.%y4%m2%d2_%h2z.ods # Passive data #/nobackup/3/PARASOL/Level2/ODS/Y%y4/M%m2/PARASOL_L2.aero_tc8.obs.%y4%m2%d2.ods diff --git a/src/Applications/GEOSdas_App/GEOSdas.csm b/src/Applications/GEOSdas_App/GEOSdas.csm index 038dc452..669b6269 100755 --- a/src/Applications/GEOSdas_App/GEOSdas.csm +++ b/src/Applications/GEOSdas_App/GEOSdas.csm @@ -4321,7 +4321,7 @@ endif sed -i "s/#___AVHRR___//" $ana_rc endif - if ($aod_obs == patmosx_asc) sed -i "s/#___AVHRR___//" $ana_rc + if ($aod_obs == patmosx_asc || $aod_obs == patmosx_ods) sed -i "s/#___AVHRR___//" $ana_rc if ($aod_obs == aeronet_obs) sed -i "s/#___AERONET___//" $ana_rc if ($aod_obs == misr_F12_bright) sed -i "s/#___MISR___//" $ana_rc if ($aod_obs == mod04_land_nnr) sed -i "s/#___TERRA___//" $ana_rc From 90516bdc0af5e97ea0388c4d9ab5517c1e433fe8 Mon Sep 17 00:00:00 2001 From: Joe Stassi Date: Tue, 23 Aug 2022 08:37:43 -0400 Subject: [PATCH 189/205] Include hour marker (_%h2) in template for aeronet_obs data files. --- src/Applications/GAAS_App/ana.rc.tmpl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Applications/GAAS_App/ana.rc.tmpl b/src/Applications/GAAS_App/ana.rc.tmpl index ff285eb7..19c33a67 100644 --- a/src/Applications/GAAS_App/ana.rc.tmpl +++ b/src/Applications/GAAS_App/ana.rc.tmpl @@ -38,7 +38,7 @@ ODS_files:: #___MISR___${FVWORK}/misr_F12_0022.bright_tc8.obs.%y4%m2%d2.ods -#___AERONET___${FVWORK}/aeronet.obs.%y4%m2%d2.ods +#___AERONET___${FVWORK}/aeronet.obs.%y4%m2%d2_%h2z.ods # Passive data #/nobackup/3/PARASOL/Level2/ODS/Y%y4/M%m2/PARASOL_L2.aero_tc8.obs.%y4%m2%d2.ods From e6e8fc75328c0e2ceed033a07e375655efb79e84 Mon Sep 17 00:00:00 2001 From: Joe Stassi Date: Tue, 23 Aug 2022 12:18:35 -0400 Subject: [PATCH 190/205] Minor updates regarding how replay is handled; removed unnecessary code. --- src/Applications/GEOSdas_App/GEOSdas.csm | 2 +- src/Applications/GEOSdas_App/fvsetup | 5 ----- 2 files changed, 1 insertion(+), 6 deletions(-) diff --git a/src/Applications/GEOSdas_App/GEOSdas.csm b/src/Applications/GEOSdas_App/GEOSdas.csm index 2dd6e1d7..c064290a 100755 --- a/src/Applications/GEOSdas_App/GEOSdas.csm +++ b/src/Applications/GEOSdas_App/GEOSdas.csm @@ -2787,7 +2787,7 @@ exit 1 if ( $AOD_OBSCLASS == "" ) setenv AOD_OBSCLASS none if ( $AOD_OBSCLASS == 0 ) setenv AOD_OBSCLASS none - if ($GAAS_ANA && ! $REPLAY_ACQ && ("$AOD_OBSCLASS" != "none")) then + if ($GAAS_ANA && ("$AOD_OBSCLASS" != "none")) then @ mstep = $nstep * 2 fname2 acquire_obsys -v $acqflags -ssh -drc $AERO_OBSDBRC \\ fname2 " "$bnymd $bnhms 030000 $mstep \\ diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index 18b82e6e..bb183fcc 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -7785,11 +7785,6 @@ print SCRIPT <<"EOF"; setenv GSI_DIAG2TXT 1 # setenv DO_0HR_IMP 1 - if ( -e \$FVHOME/run/replay.acq ) then - setenv REPLAY_ACQ 1 # for now, replay.acq controls only meteorology (AOD is not yet replayed to) - else - setenv REPLAY_ACQ 0 - endif EOF if ( $merra2 ) { From 0d1dce59e7a821a31df6a63ca9a17f8da54eee73 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Tue, 23 Aug 2022 14:11:52 -0400 Subject: [PATCH 191/205] latest repo updates --- components.yaml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/components.yaml b/components.yaml index ccc3b531..6fb642db 100644 --- a/components.yaml +++ b/components.yaml @@ -28,7 +28,7 @@ NCEP_Shared: GMAO_Shared: local: ./src/Shared/@GMAO_Shared remote: ../GMAO_Shared.git - tag: rt1_4_10_geosit4 + tag: rt1_4_10_geosit5 develop: main MAPL: @@ -101,7 +101,7 @@ geos-chem: GOCART: local: ./src/Components/@GEOSgcm_GridComp/GEOSagcm_GridComp/GEOSphysics_GridComp/@GEOSchem_GridComp/@GOCART remote: ../GOCART.git - tag: rt1.0.1_geosit2 + tag: rt1.0.1_geosit3 sparse: ./config/GOCART.sparse develop: develop @@ -121,7 +121,7 @@ mom6: GEOSgcm_App: local: ./src/Applications/@GEOSgcm_App remote: ../GEOSgcm_App.git - tag: rt1.5.6_geosit_hist4 + tag: rt1.5.6_geosit_hist5 develop: develop UMD_Etc: From 0732926038bdd30feba2562126a10bcae26e1b0f Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Tue, 23 Aug 2022 14:47:25 -0400 Subject: [PATCH 192/205] minor caps of env var name --- src/Applications/GEOSdas_App/GEOSdas.csm | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/src/Applications/GEOSdas_App/GEOSdas.csm b/src/Applications/GEOSdas_App/GEOSdas.csm index 40cc0a07..a377d4a1 100755 --- a/src/Applications/GEOSdas_App/GEOSdas.csm +++ b/src/Applications/GEOSdas_App/GEOSdas.csm @@ -166,9 +166,9 @@ if ( !($?WCONSTRAINT) ) setenv WCONSTRAINT 0 if ( $BATCH_SUBCMD == "sbatch" ) then - setenv blockflag "-W" + setenv BLOCKFLAG "-W" else - setenv blockflag "-W block=true" + setenv BLOCKFLAG "-W block=true" endif if ( !($?doPLOTS) ) setenv doPLOTS 0 @@ -1553,7 +1553,7 @@ exit 1 fname2 " acquire -v -rc blend.acq -s $spool -d . -strict $nymd $nhms 060000 1 " fname2 "exit" - $BATCH_SUBCMD $blockflag -o $acqlog $fname + $BATCH_SUBCMD $BLOCKFLAG -o $acqlog $fname endif @@ -1691,7 +1691,7 @@ exit 1 endif fname2 "exit" - $BATCH_SUBCMD $blockflag -o $acqlog $fname + $BATCH_SUBCMD $BLOCKFLAG -o $acqlog $fname endif @@ -1885,7 +1885,7 @@ exit 1 fname2 " acquire -v -rc aod4fcst.acq -s $spool -d . -strict $initref[1] $initref[2] 030000 2 " fname2 "exit" - $BATCH_SUBCMD $blockflag -o $acqlog $fname + $BATCH_SUBCMD $BLOCKFLAG -o $acqlog $fname endif @@ -2463,7 +2463,7 @@ exit 1 fname2 "" fname2 "exit" - $BATCH_SUBCMD $blockflag -o $acqlog $fname + $BATCH_SUBCMD $BLOCKFLAG -o $acqlog $fname sleep 2 @ cyc_sec = $TIMEINC * 60 set next_cycle = (`tick $rpl_nymdb $rpl_nhmsb $cyc_sec`) @@ -2567,7 +2567,7 @@ exit 1 fname2 "acquire -v -rc obsys.acq -s $spool -d $FVWORK -ssh $strict $bnymd $bnhms $inhms 4" fname2 "exit" - $BATCH_SUBCMD $blockflag -o $acqlog $fname + $BATCH_SUBCMD $BLOCKFLAG -o $acqlog $fname sleep 2 set bnymd=`tick $bnymd` end @@ -2733,7 +2733,7 @@ exit 1 set obsflag = 1 set acqflags = "-d $FVWORK -s $spool -strict" set acqflags1 = "-d $FVWORK -s $spool $strict" - set qblock = $blockflag + set qblock = $BLOCKFLAG endif # Check for available AOD obs classes @@ -4113,7 +4113,7 @@ endif "Central AGCM Failed " if ( -e agcm_central.j ) then - $BATCH_SUBCMD $blockflag agcm_central.j + $BATCH_SUBCMD $BLOCKFLAG agcm_central.j else echo " ${MYNAME}: AGCM Failed to generate PBS jobs for Central, Aborting ... " exit(1) @@ -4393,7 +4393,7 @@ endif # submit job and save job ID #--------------------------- if ( $AODBLOCKJOB ) then - set jobIDline = (`$PBS_BIN/$BATCH_SUBCMD $blockflag -o $gaasLOG $jobf`) + set jobIDline = (`$PBS_BIN/$BATCH_SUBCMD $BLOCKFLAG -o $gaasLOG $jobf`) else set jobIDline = (`$PBS_BIN/$BATCH_SUBCMD -o $gaasLOG $jobf`) endif @@ -4789,7 +4789,7 @@ endif fname2 " acquire_obsys -v -d $FVWORK $strict $anadate[1] $anadate[2] 060000 1 $tcvitals_class" fname2 "exit" - $BATCH_SUBCMD $blockflag -o $acqlog $fname + $BATCH_SUBCMD $BLOCKFLAG -o $acqlog $fname endif ls -lrt *vtx.prs* *vtx.mix* From 9c8490b0cf0b4e519e9f5bff22736d183378531f Mon Sep 17 00:00:00 2001 From: Amal El Akkraoui Date: Thu, 25 Aug 2022 14:21:57 -0400 Subject: [PATCH 193/205] Add fixes to pre-2000 gocart emissions and fvsetup + fix to SBUV n19 total 22 --- src/Applications/GEOSdas_App/fvsetup | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index 16b1d172..22d7cabb 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -3143,7 +3143,6 @@ sub get_times { $asynbkg_min = 60; # time frequency of background fields (min) } else { $asynbkg_min = 180; # time frequency of background fields (min) - if ( $r21c) { $asynbkg_min = 60}; } } else { $splite = 0; $splitexe = 0; @@ -3444,7 +3443,6 @@ sub get_setgsi { $anaexec = "GSIsa.x"; $hybrid = ".false."; $hyb_ens = -1; - if ($r21c) { $hyb_ens = 4} if ($merra2) { $nosfcana = 0 } # will apply similarity to produce xana.sfc else { $nosfcana = 1 } # will not generation xana.sfc @@ -10117,8 +10115,20 @@ sub copy_resources { } } } + # Update gocart files for pre-2000 case - # To Be Done + if ( $r21c ) { $casedir = "R21C" }; + if ( $geosit ) { $casedir = "GEOSIT"}; + if ( $r21c || $geosit ){ + if ( $nymdb < 20000331 && $hhb < 23 ) { + if ( -d "$fvetc/$casedir" ){ + my @files = glob("$fvetc/$casedir/19600101-20000331/" . "/*"); + foreach my $fn ( @files ) { + cp("$fn","$fvhome/run/gocart"); + } + } + } + } # # Edit psas.rc From 84b66d930fb07107f5a050574643d9a7bb477797 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Fri, 2 Sep 2022 07:09:38 -0400 Subject: [PATCH 194/205] revise bkg for JEDI; reduce footprint of ensemble output by using deflate opt in history --- src/Applications/GEOSdas_App/GEOSdas.csm | 8 +-- src/Applications/GEOSdas_App/edhist.pl | 2 +- src/Applications/GEOSdas_App/fvsetup | 34 ++++++++++ src/Applications/GEOSdas_App/gen_silo_arc.pl | 2 +- .../GEOSdas_App/write_monthly_rc_arc.pl | 4 +- .../NCEP_enkf/scripts/gmao/atmens_arch.csh | 10 +-- .../NCEP_enkf/scripts/gmao/atmos_egsi.csh | 5 +- .../scripts/gmao/etc/AtmEnsConfig.csh | 4 +- .../scripts/gmao/etc/HISTAENS.rc.tmpl | 63 +++++++++++++++---- .../scripts/gmao/etc/HISTAGEPS.rc.tmpl | 28 ++++++++- .../scripts/gmao/etc/HISTAOSE.rc.tmpl | 36 +++++++++++ .../scripts/gmao/etc/atmens_storage.arc | 2 +- .../NCEP_enkf/scripts/gmao/obsvr_ensemble.csh | 12 ++-- .../NCEP_enkf/scripts/gmao/setup_atmens.pl | 2 +- .../NCEP_enkf/scripts/gmao/update_ens.csh | 10 +-- 15 files changed, 178 insertions(+), 44 deletions(-) diff --git a/src/Applications/GEOSdas_App/GEOSdas.csm b/src/Applications/GEOSdas_App/GEOSdas.csm index a377d4a1..980889ce 100755 --- a/src/Applications/GEOSdas_App/GEOSdas.csm +++ b/src/Applications/GEOSdas_App/GEOSdas.csm @@ -5953,10 +5953,10 @@ endif /bin/rm $EXPID.*rst*iter*.$RSTSUFFIX endif cd - - set lsttrajrst = `ls $EXPID.traj_lcv_rst.*$NCSUFFIX` - if ( ${%lsttrajrst} ) then - tar cvf $FVWORK/$EXPID.trajrst.${rtag3}.tar $lsttrajrst - /bin/rm $lsttrajrst + set lstbkgcrst = `ls $EXPID.bkg_clcv_rst.*$NCSUFFIX` + if ( ${%lstbkgcrst} ) then + tar cvf $FVWORK/$EXPID.bkgcrst.${rtag3}.tar $lstbkgcrst + /bin/rm $lstbkgcrst endif if ( $DO4DIAU ) then set lstagcmrst = `ls $EXPID.agcm_import_rst.*$NCSUFFIX` diff --git a/src/Applications/GEOSdas_App/edhist.pl b/src/Applications/GEOSdas_App/edhist.pl index ba0c1551..785dfb73 100755 --- a/src/Applications/GEOSdas_App/edhist.pl +++ b/src/Applications/GEOSdas_App/edhist.pl @@ -1377,7 +1377,7 @@ sub add_silo_mstorage_traits { #------------------------------ outer: foreach $name (@bottomList) { - next outer if $name =~ m/_rst/ and $name ne "traj_lcv_rst"; + next outer if $name =~ m/_rst/ and $name ne "bkg_clcv_rst"; unless ($traitHash{$name} =~ m/\bsilo\b/) { $traitHash{$name} =~ s/:template:/:template:silo.N1:/; diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index 22d7cabb..d45361e2 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -1359,6 +1359,8 @@ sub ed_g5hist_rc_new { . " -s \@COMPRESS=$cmprss" . " -s \@APERT_IM=$apert_im" . " -s \@APERT_JM=$apert_jm" + . " -s \@BJEDI_IM=$bjedi_im" + . " -s \@BJEDI_JM=$bjedi_jm" . " -s \@PERT_FREQ=$pert_freq" . " -s \@AGCM_GRIDNAME=$AGCM_GRIDNAME"; print "$cmd\n"; @@ -1453,6 +1455,8 @@ sub ed_g5prog_rc { if($rcd =~ /\@HIST_PERT_JM/) { $rcd=~ s/\@HIST_PERT_JM/$hist_pert_jm/ } if($rcd =~ /\@APERT_IM/) { $rcd=~ s/\@APERT_IM/$apert_im/ } if($rcd =~ /\@APERT_JM/) { $rcd=~ s/\@APERT_JM/$apert_jm/ } + if($rcd =~ /\@BJEDI_IM/) { $rcd=~ s/\@BJEDI_IM/$bjedi_im/ } + if($rcd =~ /\@BJEDI_JM/) { $rcd=~ s/\@BJEDI_JM/$bjedi_jm/ } if($rcd =~ /\@PERT_FREQ/) { $rcd=~ s/\@PERT_FREQ/$pert_freq/ } if($rcd =~ /\@FCSENS/) { if ($admtlm) { $rcd =~ s/\@FCSENS/ /; } @@ -1526,6 +1530,8 @@ sub ed_g5prog_rc_new { . " -s \@HIST_PERT_JM=$hist_pert_jm" . " -s \@APERT_IM=$apert_im" . " -s \@APERT_JM=$apert_jm" + . " -s \@BJEDI_IM=$bjedi_im" + . " -s \@BJEDI_JM=$bjedi_jm" . " -s \@PERT_FREQ=$pert_freq" . " -s \@AGCM_GRIDNAME=$AGCM_GRIDNAME"; print "$cmd\n"; @@ -1915,6 +1921,8 @@ sub ed_gsigridcomp_rc { if($rcd =~ /\@NYGSI/) {$rcd=~ s/\@NYGSI/$nygsi/g; } if($rcd =~ /\@APERT_IM/) {$rcd=~ s/\@APERT_IM/$apert_im/g; } if($rcd =~ /\@APERT_JM/) {$rcd=~ s/\@APERT_JM/$apert_jm/g; } + if($rcd =~ /\@BJEDI_IM/) {$rcd=~ s/\@BJEDI_IM/$apert_im/g; } + if($rcd =~ /\@BJEDI_JM/) {$rcd=~ s/\@BJEDI_JM/$apert_jm/g; } } if($rcd =~ /\@NSIG/) {$rcd=~ s/\@NSIG/$siglevs/g; } if($rcd =~ /\@VARWINDOW/) {$rcd=~ s/\@VARWINDOW/$varwnd_nhms/g; } @@ -4761,6 +4769,8 @@ EOF $hist_pert_jm = $agcm_jm; $apert_im = $ana_im; $apert_jm = $ana_jm; + $bjedi_im = $ana_im; + $bjedi_jm = $ana_jm; $anahgrd = substr($res,0,1); $jcap_ens = $jcap; $ana_im_ens = $ana_im; @@ -4790,6 +4800,8 @@ EOF $hist_pert_jm = $agcm_jm; $apert_im = $agcm_im; $apert_jm = $agcm_jm; + $bjedi_im = $agcm_im; + $bjedi_jm = $agcm_jm; $anahgrd = substr($res,0,1); $jcap_ens = $jcap; $ana_im_ens = $ana_im; @@ -4819,6 +4831,8 @@ EOF $hist_pert_jm = $agcm_jm; $apert_im = $agcm_im; $apert_jm = $agcm_jm; + $bjedi_im = $agcm_im; + $bjedi_jm = $agcm_jm; $anahgrd = substr($res,0,1); $jcap_ens = $jcap; $ana_im_ens = $ana_im; @@ -4846,6 +4860,8 @@ EOF $hist_pert_jm = $agcm_jm; $apert_im = $agcm_im; $apert_jm = $agcm_jm; + $bjedi_im = $agcm_im; + $bjedi_jm = $agcm_jm; $anahgrd = substr($res,0,1); $jcap_ens = $jcap; $ana_im_ens = $ana_im; @@ -4877,6 +4893,8 @@ EOF $hist_pert_jm = 181; $apert_im = 288; $apert_jm = 181; + $bjedi_im = 288; + $bjedi_jm = 181; $anahgrd = substr($res,0,1); $jcap_ens = 126; $ana_im_ens = 288; @@ -4908,6 +4926,8 @@ EOF $hist_pert_jm = 361; $apert_im = 576; $apert_jm = 361; + $bjedi_im = 288; + $bjedi_jm = 181; $anahgrd = substr($res,0,1); $jcap_ens = 126; $ana_im_ens = 288; @@ -4937,6 +4957,8 @@ EOF $hist_pert_jm = $agcm_jm; $apert_im = $agcm_im; $apert_jm = $agcm_jm; + $bjedi_im = $agcm_im; + $bjedi_jm = $agcm_jm; $anahgrd = substr($res,0,1); $jcap_ens = $jcap; $ana_im_ens = $ana_im; @@ -4969,6 +4991,8 @@ EOF $hist_pert_jm = $ana_jm; $apert_im = $agcm_im; $apert_jm = $agcm_jm; + $bjedi_im = $agcm_im; + $bjedi_jm = $agcm_jm; $anahgrd = "b"; $jcap_ens = $jcap; $ana_im_ens = $ana_im; @@ -5001,6 +5025,8 @@ EOF $hist_pert_jm = $ana_jm; $apert_im = $agcm_im; $apert_jm = $agcm_jm; + $bjedi_im = $agcm_im; + $bjedi_jm = $agcm_jm; $anahgrd = "c"; $jcap_ens = $jcap; $ana_im_ens = $ana_im; @@ -5038,6 +5064,8 @@ EOF $hist_pert_jm = 181; $apert_im = 90; $apert_jm = $apert_im * 6; + $bjedi_im = 90; + $bjedi_jm = $bjedi_im * 6; $anahgrd = "d"; $jcap_ens = 126; $ana_im_ens = 288; @@ -5071,6 +5099,8 @@ EOF $hist_pert_jm = 361; $apert_im = 180; $apert_jm = $apert_im * 6; + $bjedi_im = 90; + $bjedi_jm = $bjedi_im * 6; $anahgrd = "d"; $use_shmem = 1; $jcap_ens = 126; @@ -5106,6 +5136,8 @@ EOF $hist_pert_jm = 361; $apert_im = 180; $apert_jm = $apert_im * 6; + $jdedi_im = 180; + $jdedi_jm = $bjedi_im * 6; $anahgrd = "e"; $use_shmem = 1; $jcap_ens = 254; @@ -5141,6 +5173,8 @@ EOF $hist_pert_jm = 361; $apert_im = 180; $apert_jm = $apert_im * 6; + $bjedi_im = 180; + $bjedi_jm = $bjedi_im * 6; $anahgrd = "e"; $use_shmem = 1; $jcap_ens = 254; diff --git a/src/Applications/GEOSdas_App/gen_silo_arc.pl b/src/Applications/GEOSdas_App/gen_silo_arc.pl index 08542578..39d2504d 100755 --- a/src/Applications/GEOSdas_App/gen_silo_arc.pl +++ b/src/Applications/GEOSdas_App/gen_silo_arc.pl @@ -219,7 +219,7 @@ sub restart_info { printarc("$lineTAR\n"); $lineTAR = '${PESTOROOT}%s/rs/Y%y4/M%m2/%s.rst.%y4%m2%d2_%h2z.tar'; printarc("$lineTAR\n"); - $lineTAR = '${PESTOROOT}%s/rs/Y%y4/M%m2/%s.trajrst.%y4%m2%d2_%h2z.tar'; + $lineTAR = '${PESTOROOT}%s/rs/Y%y4/M%m2/%s.bkgcrst.%y4%m2%d2_%h2z.tar'; printarc("$lineTAR\n"); $lineTAR = '${PESTOROOT}%s/jedi/rs/Y%y4/M%m2/%s.jedi_agcmrst.%y4%m2%d2_%h2z.tar'; printarc("$lineTAR\n"); diff --git a/src/Applications/GEOSdas_App/write_monthly_rc_arc.pl b/src/Applications/GEOSdas_App/write_monthly_rc_arc.pl index 3e1422ca..9b83998a 100755 --- a/src/Applications/GEOSdas_App/write_monthly_rc_arc.pl +++ b/src/Applications/GEOSdas_App/write_monthly_rc_arc.pl @@ -106,7 +106,7 @@ "prog.sfc" => 1, "ptrj.prs" => 1, "traj.lcv" => 1, - "traj_lcv_rst" => 1, + "bkg_clcv_rst" => 1, "vtx.mix" => 1, "vtx.prs" => 1 ); # main program @@ -389,7 +389,7 @@ sub get_info_from_SILO { # add additional hourtype requirements #------------------------------------- - foreach (qw(traj_lcv_rst)) { + foreach (qw(bkg_clcv_rst)) { $hourtype{$_} = "$mode{$_}$freq{$_}"; } diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmens_arch.csh b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmens_arch.csh index bec47781..ba8fe2ac 100755 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmens_arch.csh +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmens_arch.csh @@ -17,7 +17,7 @@ # eoi0 - arch obs-imp on analysis # eprg - arch prognostic fields of all members # erst - arch rst's of all members -# etrj - arch trj's of all members +# ebkgx- arch extra background output of all members # evtk - arch vortex tracker information # eoimp- arch ensemble obs-impact-related output # fstat- arch forecast statistics @@ -91,7 +91,7 @@ if ( $#argv < 6 ) then echo " (Default: arch only central bkg files)" echo " ENSARCH_KEEP - when set will not remove dir with files for arch" echo " ENSARCH_FIELDS - components (list separate by comma), e.g.," - echo " eana,ebkg,edia,eprg,easm,erst,etrj,eoi0,stat,xtra " + echo " eana,ebkg,edia,eprg,easm,erst,ebkgx,eoi0,stat,xtra " echo " (Default: stat) " echo " ENSSILO_KEEP - when set will not remove siloens dir for current date/time" echo " ENSARCHJOB_KEEP - will keep cp of archiving script under FVHOME" @@ -374,11 +374,11 @@ if ( $doall && (-d $myball) ) then end end endif -# store trj_lcv files -set myball = $expid.atmens_etrj.${nymdb}_${hhb}z +# store bkg_clcv files +set myball = $expid.atmens_ebkgx.${nymdb}_${hhb}z if ( -d $myball ) then mkdir -p $myball - /bin/mv enstraj $myball + /bin/mv ensbkgx $myball endif # store obs-imp on analysis ... set myball = $expid.atmens_eoi0.${nymdb}_${hhb}z diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmos_egsi.csh b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmos_egsi.csh index bda4ee65..9b6f09f7 100755 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmos_egsi.csh +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/atmos_egsi.csh @@ -539,15 +539,14 @@ while ( $n < $nmem ) /bin/rm anavinfo ln -s ../ensctrl/anavinfo . + # since setobsvr.csh brings in these files w/ satbias/bang names link them to proper names if( -e satbias ) then - # since setobsvr.csh brings in these files w/ satbias/bang names link them to proper names ln -sf satbias satbias_in else - echo " ${MYNAME}: Unable to find satbias/bang files to run control-analysis, Aborting ... " + echo " ${MYNAME}: Unable to find satbias files to run control-analysis, Aborting ... " exit(1) endif if( -e satbang ) then - # since setobsvr.csh brings in these files w/ satbias/bang names link them to proper names ln -sf satbang satbias_angle endif if ( $ACFTBIAS ) then diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/AtmEnsConfig.csh b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/AtmEnsConfig.csh index abf6313a..a552b6a4 100644 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/AtmEnsConfig.csh +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/AtmEnsConfig.csh @@ -31,8 +31,8 @@ setenv ACFTBIAS @ACFTBIAS # 0: no aircraft bias correction # archiving # --------- setenv ENSARCH_ALLBKG 1 # set this and ALL bkg files are saved in tar ball -setenv ENSARCH_FIELDS "eana,ebkg,stat,ecbkg,eoi0,edia,ebaer,erst,etrj,eprg,eniana" -setenv ENSARCH_FIELDS "eana,ebkg,stat,ecbkg,eoi0,edia,ebaer,erst,eniana" +setenv ENSARCH_FIELDS "eana,ebkg,stat,ecbkg,eoi0,edia,ebaer,erst,ebkgx,eprg,eniana" +setenv ENSARCH_FIELDS "eana,ebkg,stat,ecbkg,eoi0,edia,ebaer,erst" setenv ENSARCH_WALLCLOCK 2:00:00 setenv ARCHLOC $FVARCH diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/HISTAENS.rc.tmpl b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/HISTAENS.rc.tmpl index 345ed08f..decf8a0c 100644 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/HISTAENS.rc.tmpl +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/HISTAENS.rc.tmpl @@ -58,7 +58,7 @@ COLLECTIONS: 'bkg.eta' # Vortex track/relocator # 'vtx.mix' # Cubed trajectory (background for JEDI) -# 'traj_lcv' +# 'bkg_clcv' :: # -------------------------- @@ -66,6 +66,8 @@ COLLECTIONS: 'bkg.eta' # -------------------------- Bkg.eta.format: 'CFIO' , + Bkg.eta.deflate: 2 , + Bkg.eta.regrid_method: 'BILINEAR_MONOTONIC' , Bkg.eta.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<', Bkg.eta.ref_date: >>>IOBBKGD<<< , Bkg.eta.ref_time: >>>IOBBKGT<<< , @@ -102,6 +104,8 @@ COLLECTIONS: 'bkg.eta' # -------------------------- bkg.eta.format: 'CFIO' , + bkg.eta.deflate: 2 , + bkg.eta.regrid_method: 'BILINEAR_MONOTONIC' , bkg.eta.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<', bkg.eta.ref_date: >>>IOBBKGD<<< , bkg.eta.ref_time: >>>IOBBKGT<<< , @@ -134,6 +138,8 @@ COLLECTIONS: 'bkg.eta' :: bkg.sfc.format: 'CFIO' , + bkg.sfc.deflate: 2 , + bkg.sfc.regrid_method: 'BILINEAR_MONOTONIC' , bkg.sfc.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<', bkg.sfc.ref_date: >>>IOBBKGD<<< , bkg.sfc.ref_time: >>>IOBBKGT<<< , @@ -194,6 +200,8 @@ COLLECTIONS: 'bkg.eta' :: cbkg.eta.format: 'CFIO' , + cbkg.eta.deflate: 2 , + cbkg.eta.regrid_method: 'BILINEAR_MONOTONIC' , cbkg.eta.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<' , cbkg.eta.ref_date: >>>IOBBKGD<<< , cbkg.eta.ref_time: >>>IOBBKGT<<< , @@ -212,6 +220,8 @@ COLLECTIONS: 'bkg.eta' :: gaas_bkg.sfc.format: 'CFIO' , + gaas_bkg.sfc.deflate: 2 , + gaas_bkg.sfc.regrid_method: 'BILINEAR_MONOTONIC' , gaas_bkg.sfc.template: '%y4%m2%d2_%h2z.>>>MEMBER<<<.>>>NCSUFFIX<<<' , gaas_bkg.sfc.ref_date: >>>IOBBKGD<<< , gaas_bkg.sfc.ref_time: >>>IOBBKGT<<< , @@ -235,6 +245,8 @@ COLLECTIONS: 'bkg.eta' # ---------------------- prog.eta.format: 'CFIO' , + prog.eta.deflate: 2 , + prog.eta.regrid_method: 'BILINEAR_MONOTONIC' , prog.eta.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<', prog.eta.ref_date: >>>IOFDATE<<< , prog.eta.ref_time: >>>IOFTIME<<< , @@ -265,6 +277,9 @@ COLLECTIONS: 'bkg.eta' :: abkg.eta.format: 'CFIO' , + abkg.eta.nbits: 10 , + abkg.eta.deflate: 2 , + abkg.eta.regrid_method: 'BILINEAR_MONOTONIC' , abkg.eta.descr: '3d,3-Hourly,Instantaneous,Model-Level,Analysis,Aerosol Concentrations' , abkg.eta.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<' , abkg.eta.ref_date: >>>IOBBKGD<<< , @@ -317,6 +332,8 @@ COLLECTIONS: 'bkg.eta' inst1_2d_asm_Nx.format: 'CFIO' , inst1_2d_asm_Nx.descr: '2d,1-Hourly,Instantaneous,Single-Level,Assimilation,Single-Level Diagnostics' , inst1_2d_asm_Nx.nbits: 10 , + inst1_2d_asm_Nx.deflate: 2 , + inst1_2d_asm_Nx.regrid_method: 'BILINEAR_MONOTONIC' , inst1_2d_asm_Nx.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<' , inst1_2d_asm_Nx.mode: 'instantaneous' , inst1_2d_asm_Nx.resolution: @DHIS_IM @DHIS_JM , @@ -355,6 +372,8 @@ COLLECTIONS: 'bkg.eta' tavg1_2d_slv_Nx.format: 'CFIO' , tavg1_2d_slv_Nx.descr: '2d,3-Hourly,Time-Averaged,Single-Level,Assimilation,Single-Level Diagnostics' , tavg1_2d_slv_Nx.nbits: 10 , + tavg1_2d_slv_Nx.deflate: 2 , + tavg1_2d_slv_Nx.regrid_method: 'BILINEAR_MONOTONIC' , tavg1_2d_slv_Nx.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<' , tavg1_2d_slv_Nx.mode: 'time-averaged' , tavg1_2d_slv_Nx.resolution: @DHIS_IM @DHIS_JM , @@ -405,6 +424,8 @@ COLLECTIONS: 'bkg.eta' inst3_3d_wxmc_Cp.format: 'CFIO' , inst3_3d_wxmc_Cp.nbits: 10, + inst3_3d_wxmc_Cp.deflate: 2 , + inst3_3d_wxmc_Cp.regrid_method: 'BILINEAR_MONOTONIC' , inst3_3d_wxmc_Cp.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<', inst3_3d_wxmc_Cp.mode: 'instantaneous', inst3_3d_wxmc_Cp.resolution: @DHIS_IM @DHIS_JM , @@ -425,6 +446,8 @@ COLLECTIONS: 'bkg.eta' inst3_3d_wxme_Np.format: 'CFIO' , inst3_3d_wxme_Np.nbits: 10 , + inst3_3d_wxme_Np.deflate: 2 , + inst3_3d_wxme_Np.regrid_method: 'BILINEAR_MONOTONIC' , inst3_3d_wxme_Np.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<' , inst3_3d_wxme_Np.mode: 'instantaneous' , inst3_3d_wxme_Np.resolution: @DHIS_IM @DHIS_JM , @@ -459,6 +482,8 @@ COLLECTIONS: 'bkg.eta' tavg3_2d_wxme_Nx.format: 'CFIO' , tavg3_2d_wxme_Nx.nbits: 10, + tavg3_2d_wxme_Nx.deflate: 2 , + tavg3_2d_wxme_Nx.regrid_method: 'BILINEAR_MONOTONIC' , tavg3_2d_wxme_Nx.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<', tavg3_2d_wxme_Nx.mode: 'time-averaged', tavg3_2d_wxme_Nx.resolution: @DHIS_IM @DHIS_JM , @@ -473,6 +498,8 @@ COLLECTIONS: 'bkg.eta' inst1_2d_ocn_Nx.format: 'CFIO' , inst1_2d_ocn_Nx.descr: '2d,1-Hourly,Time-Averaged,Single-Level,Assimilation,Ocean Surface' , inst1_2d_ocn_Nx.nbits: 10 , + inst1_2d_ocn_Nx.deflate: 2 , + inst1_2d_ocn_Nx.regrid_method: 'BILINEAR_MONOTONIC' , inst1_2d_ocn_Nx.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<' , inst1_2d_ocn_Nx.mode: 'instantaneous', inst1_2d_ocn_Nx.resolution: @DHIS_IM @DHIS_JM , @@ -532,6 +559,8 @@ COLLECTIONS: 'bkg.eta' tavg1_2d_lfo_Nx.format: 'CFIO' , tavg1_2d_lfo_Nx.descr: '2d,1-Hourly,Time-Averaged,Single-Level,Assimilation,Forecast Land Surface Forcings' , tavg1_2d_lfo_Nx.nbits: 10 , + tavg1_2d_lfo_Nx.deflate: 2 , + tavg1_2d_lfo_Nx.regrid_method: 'BILINEAR_MONOTONIC' , tavg1_2d_lfo_Nx.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<' , tavg1_2d_lfo_Nx.mode: 'time-averaged' , tavg1_2d_lfo_Nx.resolution: @DHIS_IM @DHIS_JM , @@ -552,6 +581,8 @@ COLLECTIONS: 'bkg.eta' inst1_2d_lfo_Nx.format: 'CFIO' , inst1_2d_lfo_Nx.descr: '2d,1-Hourly,Instantaneous,Single-Level,Assimilation, Land Surface Forcings' , inst1_2d_lfo_Nx.nbits: 10 , + inst1_2d_lfo_Nx.deflate: 2 , + inst1_2d_lfo_Nx.regrid_method: 'BILINEAR_MONOTONIC' , inst1_2d_lfo_Nx.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<' , inst1_2d_lfo_Nx.mode: 'instantaneous' , inst1_2d_lfo_Nx.resolution: @DHIS_IM @DHIS_JM , @@ -569,6 +600,8 @@ COLLECTIONS: 'bkg.eta' tavg1_2d_lnd_Nx.format: 'CFIO' , tavg1_2d_lnd_Nx.descr: '2d,1-Hourly,Time-Averaged,Single-Level,Assimilation, Land Surface Diagnostics' , tavg1_2d_lnd_Nx.nbits: 10 , + tavg1_2d_lnd_Nx.deflate: 2 , + tavg1_2d_lnd_Nx.regrid_method: 'BILINEAR_MONOTONIC' , tavg1_2d_lnd_Nx.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<' , tavg1_2d_lnd_Nx.mode: 'time-averaged' , tavg1_2d_lnd_Nx.resolution: @DHIS_IM @DHIS_JM , @@ -765,26 +798,30 @@ COLLECTIONS: 'bkg.eta' 'DQVDT_ANA' , 'AGCM' , 'DQVDTANA' , :: - traj_lcv.format: 'CFIO' , - traj_lcv.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.nc4', - traj_lcv.ref_date: >>>IOBBKGD<<< , - traj_lcv.ref_time: >>>IOBBKGT<<< , - traj_lcv.end_date: >>>IOEDATE<<< , - traj_lcv.end_time: >>>IOETIME<<< , - traj_lcv.frequency: 010000 , - traj_lcv.duration: 010000 , - traj_lcv.mode: 'instantaneous', - traj_lcv.grid_label: PE@CHIS_IMx@CHIS_JM-CF , - traj_lcv.fields: 'U_DGRID;V_DGRID' , 'DYN' , 'u;v' , + bkg_clcv.format: 'CFIO' , + bkg_clcv.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.nc4', + bkg_clcv.nbits: 10 , + bkg_clcv.deflate: 2 , + bkg_clcv.regrid_method: 'BILINEAR_MONOTONIC' , + bkg_clcv.ref_date: >>>IOBBKGD<<< , + bkg_clcv.ref_time: >>>IOBBKGT<<< , + bkg_clcv.end_date: >>>IOEDATE<<< , + bkg_clcv.end_time: >>>IOETIME<<< , + bkg_clcv.frequency: 010000 , + bkg_clcv.duration: 010000 , + bkg_clcv.mode: 'instantaneous', + bkg_clcv.grid_label: PE@CHIS_IMx@CHIS_JM-CF , + bkg_clcv.fields: 'U_DGRID;V_DGRID' , 'DYN' , 'u;v' , 'U;V' , 'DYN' , 'ua;va' , 'T' , 'DYN' , 't' , + 'TV' , 'DYN' , 'tv' , 'Q' , 'MOIST' , 'q' , 'DELP' , 'DYN' , 'delp' , 'QITOT' , 'AGCM' , 'qi' , 'QLTOT' , 'AGCM' , 'ql' , 'QSTOT' , 'MOIST' , 'qs' , 'QRTOT' , 'MOIST' , 'qr' , - 'O3PPMV' , 'CHEMISTRY' , 'o3mr' , + 'O3PPMV' , 'CHEMISTRY' , 'o3ppmv' , 'GOCART::CO2' , 'GOCART' , 'co2' , 'QCLSX0' , 'MOIST' , 'qls' , 'QCCNX0' , 'MOIST' , 'qcn' , diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/HISTAGEPS.rc.tmpl b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/HISTAGEPS.rc.tmpl index 17471a7d..2d72a4da 100644 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/HISTAGEPS.rc.tmpl +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/HISTAGEPS.rc.tmpl @@ -11,13 +11,15 @@ COLLECTIONS: 'prog.eta' # 'inst3_3d_wxme_Np' # 'tavg3_2d_wxme_Nx' # Vortex track/relocator -# 'vtx.mix' - :: +# 'vtx.mix' + :: # Forecasting output ... # ---------------------- prog.eta.format: 'CFIO' , + prog.eta.deflate: 2 , + prog.eta.regrid_method: 'BILINEAR_MONOTONIC' , prog.eta.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<', prog.eta.frequency: 060000 , prog.eta.duration: 060000 , @@ -50,6 +52,8 @@ COLLECTIONS: 'prog.eta' inst1_2d_asm_Nx.format: 'CFIO' , inst1_2d_asm_Nx.descr: '2d,1-Hourly,Instantaneous,Single-Level,Assimilation,Single-Level Diagnostics' , inst1_2d_asm_Nx.nbits: 10 , + inst1_2d_asm_Nx.deflate: 2 , + inst1_2d_asm_Nx.regrid_method: 'BILINEAR_MONOTONIC' , inst1_2d_asm_Nx.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<' , inst1_2d_asm_Nx.mode: 'instantaneous' , inst1_2d_asm_Nx.resolution: >>>HIST_IM<<< >>>HIST_JM<<<, @@ -85,6 +89,8 @@ COLLECTIONS: 'prog.eta' :: abkg.eta.format: 'CFIO' , + abkg.eta.deflate: 2 , + abkg.eta.regrid_method: 'BILINEAR_MONOTONIC' , abkg.eta.descr: '3d,3-Hourly,Instantaneous,Model-Level,Analysis,Aerosol Concentrations' , abkg.eta.template: '%y4%m2%d2_%h2z.>>>MEMBER<<<.>>>NCSUFFIX<<<' , abkg.eta.ref_date: >>>IOBBKGD<<< , @@ -134,6 +140,8 @@ COLLECTIONS: 'prog.eta' tavg1_2d_slv_Nx.format: 'CFIO' , tavg1_2d_slv_Nx.descr: '2d,3-Hourly,Time-Averaged,Single-Level,Assimilation,Single-Level Diagnostics' , tavg1_2d_slv_Nx.nbits: 10 , + tavg1_2d_slv_Nx.deflate: 2 , + tavg1_2d_slv_Nx.regrid_method: 'BILINEAR_MONOTONIC' , tavg1_2d_slv_Nx.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<' , tavg1_2d_slv_Nx.mode: 'time-averaged' , tavg1_2d_slv_Nx.resolution: >>>HIST_IM<<< >>>HIST_JM<<<, @@ -184,6 +192,8 @@ COLLECTIONS: 'prog.eta' inst3_3d_wxmc_Cp.format: 'CFIO' , inst3_3d_wxmc_Cp.nbits: 10, + inst3_3d_wxmc_Cp.deflate: 2 , + inst3_3d_wxmc_Cp.regrid_method: 'BILINEAR_MONOTONIC' , inst3_3d_wxmc_Cp.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<', inst3_3d_wxmc_Cp.mode: 'instantaneous', inst3_3d_wxmc_Cp.resolution: 288 181, @@ -204,6 +214,8 @@ COLLECTIONS: 'prog.eta' inst3_3d_wxme_Np.format: 'CFIO' , inst3_3d_wxme_Np.nbits: 10 , + inst3_3d_wxme_Np.deflate: 2 , + inst3_3d_wxme_Np.regrid_method: 'BILINEAR_MONOTONIC' , inst3_3d_wxme_Np.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<' , inst3_3d_wxme_Np.mode: 'instantaneous' , inst3_3d_wxme_Np.resolution: >>>HIST_IM<<< >>>HIST_JM<<<, @@ -238,6 +250,8 @@ COLLECTIONS: 'prog.eta' tavg3_2d_wxme_Nx.format: 'CFIO' , tavg3_2d_wxme_Nx.nbits: 10, + tavg3_2d_wxme_Nx.deflate: 2 , + tavg3_2d_wxme_Nx.regrid_method: 'BILINEAR_MONOTONIC' , tavg3_2d_wxme_Nx.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<', tavg3_2d_wxme_Nx.mode: 'time-averaged', tavg3_2d_wxme_Nx.resolution: >>>HIST_IM<<< >>>HIST_JM<<<, @@ -252,6 +266,8 @@ COLLECTIONS: 'prog.eta' inst1_2d_ocn_Nx.format: 'CFIO' , inst1_2d_ocn_Nx.descr: '2d,1-Hourly,Time-Averaged,Single-Level,Assimilation,Ocean Surface' , inst1_2d_ocn_Nx.nbits: 10 , + inst1_2d_ocn_Nx.deflate: 2 , + inst1_2d_ocn_Nx.regrid_method: 'BILINEAR_MONOTONIC' , inst1_2d_ocn_Nx.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<' , inst1_2d_ocn_Nx.mode: 'instantaneous', inst1_2d_ocn_Nx.resolution: >>>HIST_IM<<< >>>HIST_JM<<<, @@ -311,6 +327,8 @@ COLLECTIONS: 'prog.eta' tavg1_2d_lfo_Nx.format: 'CFIO' , tavg1_2d_lfo_Nx.descr: '2d,1-Hourly,Time-Averaged,Single-Level,Assimilation,Forecast Land Surface Forcings' , tavg1_2d_lfo_Nx.nbits: 10 , + tavg1_2d_lfo_Nx.deflate: 2 , + tavg1_2d_lfo_Nx.regrid_method: 'BILINEAR_MONOTONIC' , tavg1_2d_lfo_Nx.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<' , tavg1_2d_lfo_Nx.mode: 'time-averaged' , tavg1_2d_lfo_Nx.resolution: >>>HIST_IM<<< >>>HIST_JM<<<, @@ -331,6 +349,8 @@ COLLECTIONS: 'prog.eta' inst1_2d_lfo_Nx.format: 'CFIO' , inst1_2d_lfo_Nx.descr: '2d,1-Hourly,Instantaneous,Single-Level,Assimilation, Land Surface Forcings' , inst1_2d_lfo_Nx.nbits: 10 , + inst1_2d_lfo_Nx.deflate: 2 , + inst1_2d_lfo_Nx.regrid_method: 'BILINEAR_MONOTONIC' , inst1_2d_lfo_Nx.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<' , inst1_2d_lfo_Nx.mode: 'instantaneous' , inst1_2d_lfo_Nx.resolution: >>>HIST_IM<<< >>>HIST_JM<<<, @@ -348,6 +368,8 @@ COLLECTIONS: 'prog.eta' tavg1_2d_lnd_Nx.format: 'CFIO' , tavg1_2d_lnd_Nx.descr: '2d,1-Hourly,Time-Averaged,Single-Level,Assimilation, Land Surface Diagnostics' , tavg1_2d_lnd_Nx.nbits: 10 , + tavg1_2d_lnd_Nx.deflate: 2 , + tavg1_2d_lnd_Nx.regrid_method: 'BILINEAR_MONOTONIC' , tavg1_2d_lnd_Nx.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<' , tavg1_2d_lnd_Nx.mode: 'time-averaged' , tavg1_2d_lnd_Nx.resolution: >>>HIST_IM<<< >>>HIST_JM<<<, @@ -413,6 +435,8 @@ COLLECTIONS: 'prog.eta' # vtrack script too wired up and attached to filename # convention of central DAS. (RT) vtx.mix.format: 'CFIO' , + vtx.mix.deflate: 2 , + vtx.mix.regrid_method: 'BILINEAR_MONOTONIC' , vtx.mix.template: '%y4%m2%d2_%h2z.>>>NCSUFFIX<<<', vtx.mix.frequency: 060000 , vtx.mix.duration: 060000 , diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/HISTAOSE.rc.tmpl b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/HISTAOSE.rc.tmpl index 5a2f603b..bb42226e 100644 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/HISTAOSE.rc.tmpl +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/HISTAOSE.rc.tmpl @@ -36,6 +36,8 @@ COLLECTIONS: 'bkg.eta' # -------------------------- Bkg.eta.format: 'CFIO' , + Bkg.eta.deflate: 2 , + Bkg.eta.regrid_method: 'BILINEAR_MONOTONIC' , Bkg.eta.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<', Bkg.eta.ref_date: >>>IOBBKGD<<< , Bkg.eta.ref_time: >>>IOBBKGT<<< , @@ -72,6 +74,8 @@ COLLECTIONS: 'bkg.eta' # -------------------------- bkg.eta.format: 'CFIO' , + bkg.eta.deflate: 2 , + bkg.eta.regrid_method: 'BILINEAR_MONOTONIC' , bkg.eta.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<', bkg.eta.ref_date: >>>IOBBKGD<<< , bkg.eta.ref_time: >>>IOBBKGT<<< , @@ -104,6 +108,8 @@ COLLECTIONS: 'bkg.eta' :: bkg.sfc.format: 'CFIO' , + bkg.sfc.deflate: 2 , + bkg.sfc.regrid_method: 'BILINEAR_MONOTONIC' , bkg.sfc.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<', bkg.sfc.ref_date: >>>IOBBKGD<<< , bkg.sfc.ref_time: >>>IOBBKGT<<< , @@ -164,6 +170,8 @@ COLLECTIONS: 'bkg.eta' :: cbkg.eta.format: 'CFIO' , + cbkg.eta.deflate: 2 , + cbkg.eta.regrid_method: 'BILINEAR_MONOTONIC' , cbkg.eta.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<' , cbkg.eta.ref_date: >>>IOBBKGD<<< , cbkg.eta.ref_time: >>>IOBBKGT<<< , @@ -182,6 +190,8 @@ COLLECTIONS: 'bkg.eta' :: gaas_bkg.sfc.format: 'CFIO' , + gaas_bkg.sfc.deflate: 2 , + gaas_bkg.sfc.regrid_method: 'BILINEAR_MONOTONIC' , gaas_bkg.sfc.template: '%y4%m2%d2_%h2z.>>>MEMBER<<<.>>>NCSUFFIX<<<' , gaas_bkg.sfc.ref_date: >>>IOBBKGD<<< , gaas_bkg.sfc.ref_time: >>>IOBBKGT<<< , @@ -205,6 +215,8 @@ COLLECTIONS: 'bkg.eta' # ---------------------- prog.eta.format: 'CFIO' , + prog.eta.deflate: 2 , + prog.eta.regrid_method: 'BILINEAR_MONOTONIC' , prog.eta.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<', prog.eta.ref_date: >>>IOFDATE<<< , prog.eta.ref_time: >>>IOFTIME<<< , @@ -235,6 +247,9 @@ COLLECTIONS: 'bkg.eta' :: abkg.eta.format: 'CFIO' , + abkg.eta.nbits: 10 , + abkg.eta.deflate: 2 , + abkg.eta.regrid_method: 'BILINEAR_MONOTONIC' , abkg.eta.descr: '3d,3-Hourly,Instantaneous,Model-Level,Analysis,Aerosol Concentrations' , abkg.eta.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<' , abkg.eta.ref_date: >>>IOBBKGD<<< , @@ -280,12 +295,15 @@ COLLECTIONS: 'bkg.eta' 'GOCART::NO3an3' , 'GOCART' , 'NO3AN3' , :: + # General diagnostics ... # ----------------------- inst3_3d_asm_Np.format: 'CFIO' , inst3_3d_asm_Np.descr: '3d,3-Hourly,Instantaneous,Pressure-Level,Assimilation Fields (wind,temperature)' , inst3_3d_asm_Np.nbits: 10 , + inst3_3d_asm_Np.deflate: 2 , + inst3_3d_asm_Np.regrid_method: 'BILINEAR_MONOTONIC' , inst3_3d_asm_Np.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<' , inst3_3d_asm_Np.mode: 'instantaneous' , inst3_3d_asm_Np.resolution: @LHIS_IM @LHIS_JM , @@ -319,6 +337,8 @@ COLLECTIONS: 'bkg.eta' inst1_2d_asm_Nx.format: 'CFIO' , inst1_2d_asm_Nx.descr: '2d,1-Hourly,Instantaneous,Single-Level,Assimilation,Single-Level Diagnostics' , inst1_2d_asm_Nx.nbits: 10 , + inst1_2d_asm_Nx.deflate: 2 , + inst1_2d_asm_Nx.regrid_method: 'BILINEAR_MONOTONIC' , inst1_2d_asm_Nx.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<' , inst1_2d_asm_Nx.mode: 'instantaneous' , inst1_2d_asm_Nx.resolution: @DHIS_IM @DHIS_JM , @@ -357,6 +377,8 @@ COLLECTIONS: 'bkg.eta' tavg1_2d_slv_Nx.format: 'CFIO' , tavg1_2d_slv_Nx.descr: '2d,3-Hourly,Time-Averaged,Single-Level,Assimilation,Single-Level Diagnostics' , tavg1_2d_slv_Nx.nbits: 10 , + tavg1_2d_slv_Nx.deflate: 2 , + tavg1_2d_slv_Nx.regrid_method: 'BILINEAR_MONOTONIC' , tavg1_2d_slv_Nx.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<' , tavg1_2d_slv_Nx.mode: 'time-averaged' , tavg1_2d_slv_Nx.resolution: @DHIS_IM @DHIS_JM , @@ -407,6 +429,8 @@ COLLECTIONS: 'bkg.eta' inst3_3d_wxmc_Cp.format: 'CFIO' , inst3_3d_wxmc_Cp.nbits: 10, + inst3_3d_wxmc_Cp.deflate: 2 , + inst3_3d_wxmc_Cp.regrid_method: 'BILINEAR_MONOTONIC' , inst3_3d_wxmc_Cp.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<', inst3_3d_wxmc_Cp.mode: 'instantaneous', inst3_3d_wxmc_Cp.resolution: @DHIS_IM @DHIS_JM , @@ -427,6 +451,8 @@ COLLECTIONS: 'bkg.eta' inst3_3d_wxme_Np.format: 'CFIO' , inst3_3d_wxme_Np.nbits: 10 , + inst3_3d_wxme_Np.deflate: 2 , + inst3_3d_wxme_Np.regrid_method: 'BILINEAR_MONOTONIC' , inst3_3d_wxme_Np.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<' , inst3_3d_wxme_Np.mode: 'instantaneous' , inst3_3d_wxme_Np.resolution: @DHIS_IM @DHIS_JM , @@ -461,6 +487,8 @@ COLLECTIONS: 'bkg.eta' tavg3_2d_wxme_Nx.format: 'CFIO' , tavg3_2d_wxme_Nx.nbits: 10, + tavg3_2d_wxme_Nx.deflate: 2 , + tavg3_2d_wxme_Nx.regrid_method: 'BILINEAR_MONOTONIC' , tavg3_2d_wxme_Nx.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<', tavg3_2d_wxme_Nx.mode: 'time-averaged', tavg3_2d_wxme_Nx.resolution: @DHIS_IM @DHIS_JM , @@ -475,6 +503,8 @@ COLLECTIONS: 'bkg.eta' inst1_2d_ocn_Nx.format: 'CFIO' , inst1_2d_ocn_Nx.descr: '2d,1-Hourly,Time-Averaged,Single-Level,Assimilation,Ocean Surface' , inst1_2d_ocn_Nx.nbits: 10 , + inst1_2d_ocn_Nx.deflate: 2 , + inst1_2d_ocn_Nx.regrid_method: 'BILINEAR_MONOTONIC' , inst1_2d_ocn_Nx.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<' , inst1_2d_ocn_Nx.mode: 'instantaneous', inst1_2d_ocn_Nx.resolution: @DHIS_IM @DHIS_JM , @@ -534,6 +564,8 @@ COLLECTIONS: 'bkg.eta' tavg1_2d_lfo_Nx.format: 'CFIO' , tavg1_2d_lfo_Nx.descr: '2d,1-Hourly,Time-Averaged,Single-Level,Assimilation,Forecast Land Surface Forcings' , tavg1_2d_lfo_Nx.nbits: 10 , + tavg1_2d_lfo_Nx.deflate: 2 , + tavg1_2d_lfo_Nx.regrid_method: 'BILINEAR_MONOTONIC' , tavg1_2d_lfo_Nx.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<' , tavg1_2d_lfo_Nx.mode: 'time-averaged' , tavg1_2d_lfo_Nx.resolution: @DHIS_IM @DHIS_JM , @@ -554,6 +586,8 @@ COLLECTIONS: 'bkg.eta' inst1_2d_lfo_Nx.format: 'CFIO' , inst1_2d_lfo_Nx.descr: '2d,1-Hourly,Instantaneous,Single-Level,Assimilation, Land Surface Forcings' , inst1_2d_lfo_Nx.nbits: 10 , + inst1_2d_lfo_Nx.deflate: 2 , + inst1_2d_lfo_Nx.regrid_method: 'BILINEAR_MONOTONIC' , inst1_2d_lfo_Nx.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<' , inst1_2d_lfo_Nx.mode: 'instantaneous' , inst1_2d_lfo_Nx.resolution: @DHIS_IM @DHIS_JM , @@ -571,6 +605,8 @@ COLLECTIONS: 'bkg.eta' tavg1_2d_lnd_Nx.format: 'CFIO' , tavg1_2d_lnd_Nx.descr: '2d,1-Hourly,Time-Averaged,Single-Level,Assimilation, Land Surface Diagnostics' , tavg1_2d_lnd_Nx.nbits: 10 , + tavg1_2d_lnd_Nx.deflate: 2 , + tavg1_2d_lnd_Nx.regrid_method: 'BILINEAR_MONOTONIC' , tavg1_2d_lnd_Nx.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<' , tavg1_2d_lnd_Nx.mode: 'time-averaged' , tavg1_2d_lnd_Nx.resolution: @DHIS_IM @DHIS_JM , diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/atmens_storage.arc b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/atmens_storage.arc index 59078c43..6f10ce69 100644 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/atmens_storage.arc +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/atmens_storage.arc @@ -53,5 +53,5 @@ ${PESTOROOT}%s/atmens/Y%y4/M%m2/%s.atmens_evtk.%y4%m2%d2_%h2z.tar ${PESTOROOT}%s/atmens/Y%y4/M%m2/%s.atmens_fstat.%y4%m2%d2_%h2z.tar ${PESTOROOT}%s/atmens/Y%y4/M%m2/%s.atmens_stat.%y4%m2%d2_%h2z.tar ${PESTOROOT}%s/atmens/Y%y4/M%m2/%s.atmens_olog.%y4%m2%d2_%c%c%c.tar -${PESTOROOT}%s/atmens/Y%y4/M%m2/%s.atmens_etrj.%y4%m2%d2_%h2z.tar +${PESTOROOT}%s/atmens/Y%y4/M%m2/%s.atmens_ebkgx.%y4%m2%d2_%h2z.tar # diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/obsvr_ensemble.csh b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/obsvr_ensemble.csh index 556a670a..7e78a819 100755 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/obsvr_ensemble.csh +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/obsvr_ensemble.csh @@ -308,14 +308,18 @@ if (! -e $ENSWORK/.DONE_MEM001_ENSMEAN_${MYNAME}.$yyyymmddhh ) then /bin/rm anavinfo /bin/ln -s $ATMENSETC/gmao_global_anavinfo.rc anavinfo endif - if( -e satbias && -e satbang ) then - # since setobsvr.csh brings in these files w/ satbias/bang names link them to proper names + # since setobsvr.csh brings in these files w/ satbias/bang names link them to proper names + if( -e satbias ) then ln -sf satbias satbias_in - ln -sf satbang satbias_angle else - echo " ${MYNAME}: Unable to find satbias/bang files to run mean-observer, Aborting ... " + echo " ${MYNAME}: Unable to find satbias file to run mean-observer, Aborting ... " exit(1) endif + if( -e satbang ) then + ln -sf satbang satbias_angle + else + echo " ${MYNAME}: Unable to find satbang file to run mean-observer, proceed anyway ... " + endif if ( $ACFTBIAS ) then if ( -e acftbias ) then /bin/ln -sf acftbias aircftbias_in diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/setup_atmens.pl b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/setup_atmens.pl index ef260d19..079f8a56 100755 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/setup_atmens.pl +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/setup_atmens.pl @@ -778,8 +778,8 @@ sub ed_satbias_acq { #$ATMENS/central/$expid.ana.acftbias.%y4%m2%d2_%h2z.txt #$ATMENS/central/$expid.ana.satbias.%y4%m2%d2_%h2z.txt #$ATMENS/central/$expid.ana.satbang.%y4%m2%d2_%h2z.txt +#$ATMENS/RST/$expid.ana_satbang_rst.%y4%m2%d2_%h2z.txt => $expid.ana.satbang.%y4%m2%d2_%h2z.txt $ATMENS/RST/$expid.ana_satbias_rst.%y4%m2%d2_%h2z.txt => $expid.ana.satbias.%y4%m2%d2_%h2z.txt -$ATMENS/RST/$expid.ana_satbang_rst.%y4%m2%d2_%h2z.txt => $expid.ana.satbang.%y4%m2%d2_%h2z.txt $mysatbiaspc $mysetacftbc EOF diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/update_ens.csh b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/update_ens.csh index cead161a..01a84400 100755 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/update_ens.csh +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/update_ens.csh @@ -148,13 +148,13 @@ endif touch ../updated_ens/ensdiag/.no_archiving set fntype_all = (`edhist.pl -q 3 -list inc -X Bkg.eta,bkg.eta,bkg.sfc,abkg.eta,cbkg.eta,gaas_bkg.sfc -i $rcfile`) foreach fntype ( $fntype_all ) - if ( $fntype == "traj_lcv" ) then - if ( ! -d ../updated_ens/enstraj/${member} ) then - mkdir -p ../updated_ens/enstraj/${member} - touch ../updated_ens/enstraj/.no_archiving + if ( $fntype == "bkg_clcv" ) then + if ( ! -d ../updated_ens/ensbkgx/${member} ) then + mkdir -p ../updated_ens/ensbkgx/${member} + touch ../updated_ens/ensbkgx/.no_archiving foreach fn ( `/bin/ls $expid.${fntype}.*.${member}.$ncsuffix` ) set newname = `echo $fn | cut -d. -f1-3 ` - /bin/mv $fn ../updated_ens/enstraj/${member}/$newname.$ncsuffix + /bin/mv $fn ../updated_ens/ensbkgx/${member}/$newname.$ncsuffix end # fn endif else From 87fa0973243ed99b20c6cb8879ae5ca122e20b28 Mon Sep 17 00:00:00 2001 From: karpob Date: Fri, 2 Sep 2022 16:45:30 -0400 Subject: [PATCH 195/205] rename ompslp_g ompslpnc for clarity and IODA converter compliance --- src/Applications/GEOSdas_App/fvsetup | 14 +++++++------- .../scripts/gmao/etc/R21C/obs1gsi_mean.rc | 2 +- .../scripts/gmao/etc/R21C/obs1gsi_member.rc | 8 ++++---- 3 files changed, 12 insertions(+), 12 deletions(-) diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index 9185e80b..869c51b0 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -5469,7 +5469,7 @@ sub archiving_rules { \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_msu_%c%c%c_%c%c%c.%y4%m2%d2_%h2z.bin \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_msu_tirosn_%c%c%c.%y4%m2%d2_%h2z.bin \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_omi_aura_%c%c%c.%y4%m2%d2_%h2z.bin -\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_ompslp_g_npp_%c%c%c.%y4%m2%d2_%h2z.bin +\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_ompslpnc_npp_%c%c%c.%y4%m2%d2_%h2z.bin \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_ompslpuv_npp_%c%c%c.%y4%m2%d2_%h2z.bin \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_ompslpvis_npp_%c%c%c.%y4%m2%d2_%h2z.bin \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_ompsnm_npp_%c%c%c.%y4%m2%d2_%h2z.bin @@ -5527,7 +5527,7 @@ sub archiving_rules { \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_msu_%c%c%c.%y4%m2%d2_%h2z.ods \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_msu_tirosn.%y4%m2%d2_%h2z.ods \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_omi_aura.%y4%m2%d2_%h2z.ods -\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_ompslp_g_npp.%y4%m2%d2_%h2z.ods +\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_ompslpnc_npp.%y4%m2%d2_%h2z.ods \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_ompslpuv_npp.%y4%m2%d2_%h2z.ods \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_ompslpvis_npp.%y4%m2%d2_%h2z.ods \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_ompsnm_npp.%y4%m2%d2_%h2z.ods @@ -5584,7 +5584,7 @@ sub archiving_rules { \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp0hr_diag_msu_%c%c%c.%y4%m2%d2_%h2z.ods \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp0hr_diag_msu_tirosn.%y4%m2%d2_%h2z.ods \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp0hr_diag_omi_aura.%y4%m2%d2_%h2z.ods -\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp0hr_diag_ompslp_g_npp.%y4%m2%d2_%h2z.ods +\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp0hr_diag_ompslpnc_npp.%y4%m2%d2_%h2z.ods \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp0hr_diag_ompslpuv_npp.%y4%m2%d2_%h2z.ods \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp0hr_diag_ompslpvis_npp.%y4%m2%d2_%h2z.ods \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp0hr_diag_ompsnm_npp.%y4%m2%d2_%h2z.ods @@ -5625,7 +5625,7 @@ sub archiving_rules { #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_seviri_m%c%c_%c%c%c_%c%c%c_%c%c%c%c.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.bin #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_sbuv%c_%c%c%c_%c%c%c_%c%c%c%c.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.bin #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_omi_aura_%c%c%c_%c%c%c%c.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.bin -#\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_ompslp_g_npp_%c%c%c_%c%c%c%c.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.bin +#\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_ompslpnc_npp_%c%c%c_%c%c%c%c.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.bin #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_ompslpuv_npp_%c%c%c_%c%c%c%c.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.bin #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_ompslpvis_npp_%c%c%c_%c%c%c%c.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.bin #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.diag_ompsnm_npp_%c%c%c_%c%c%c%c.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.bin @@ -5662,7 +5662,7 @@ sub archiving_rules { #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_pcp_tmi_%c%c%c%c_%c%c%c_%c%c%c%c.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_sbuv%c_%c%c%c_%c%c%c_%c%c%c%c.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_omi_aura_%c%c%c_%c%c%c%c.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods -#\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_ompslp_g_npp_%c%c%c_%c%c%c%c.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods +#\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_ompslpnc_npp_%c%c%c_%c%c%c%c.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_ompslpuv_npp_%c%c%c_%c%c%c%c.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_ompslpvis_npp_%c%c%c_%c%c%c%c.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_ompsnm_npp_%c%c%c_%c%c%c%c.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods @@ -5700,7 +5700,7 @@ sub archiving_rules { #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_pcp_tmi_%c%c%c%c_%c%c%c_%c%c%c%c.sigo.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_sbuv%c_%c%c%c_%c%c%c_%c%c%c%c.sigo.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_omi_aura_%c%c%c_%c%c%c%c.sigo.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods -#\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_ompslp_g_npp_%c%c%c_%c%c%c%c.sigo.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods +#\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_ompslpnc_npp_%c%c%c_%c%c%c%c.sigo.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_ompslpuv_npp_%c%c%c_%c%c%c%c.sigo.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_ompslpvis_npp_%c%c%c_%c%c%c%c.sigo.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_ompsnm_npp_%c%c%c_%c%c%c%c.sigo.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods @@ -6895,7 +6895,7 @@ sub arch_asens { \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_msu_tirosn.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_omi_aura.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_omieff_aura.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods -\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_ompslp_g_npp.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods +\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_ompslpnc_npp.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_ompslpuv_npp.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods \${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_ompslpvis_npp.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods #\${PESTOROOT}%s/obs/Y%y4/M%m2/D%d2/H%h2/%s.imp%c_%c%c%c_ompslpnm_npp.obs.%y4%m2%d2_%h2z+%y4%m2%d2_%h2z-%y4%m2%d2_%h2z.ods diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/R21C/obs1gsi_mean.rc b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/R21C/obs1gsi_mean.rc index b2a263fd..ac478400 100644 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/R21C/obs1gsi_mean.rc +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/R21C/obs1gsi_mean.rc @@ -90,7 +90,7 @@ OBS_INPUT:: sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0 r21c_osbuv8_bufr ompsnmeffnc ompsnmeff npp ompsnmeff_npp 0.0 2 0 r21c_npp_ompsnmeff_nc ! ompsnpnc ompsnpnc npp ompsnpnc_npp 0.0 0 0 r21c_npp_ompsnp_nc -! ompslpgnc ompslp_g npp ompslp_g_npp 1.0 0 0 r21c_ompslp_g_nc +! ompslpgnc ompslpnc npp ompslpnc_npp 1.0 0 0 r21c_ompslpnc_nc ompslpvisnc ompslpvis npp ompslpvis_npp 0.0 0 0 r21c_ompslpvis_nc mlsnc mls55 aura mls55_aura 0.0 0 0 r21c_mls_nc omieffnc omieff aura omieff_aura 0.0 2 0 r21c_aura_omieff_nc diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/R21C/obs1gsi_member.rc b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/R21C/obs1gsi_member.rc index 76b2bc88..18bd7cba 100644 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/R21C/obs1gsi_member.rc +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/R21C/obs1gsi_member.rc @@ -62,7 +62,7 @@ >>>AIRCFT_BIAS<<< / &OBS_INPUT - dmesh(1)=145.0,dmesh(2)=150.0,dmesh(3)=180.0,time_window_max=3.0, + dmesh(1)=145.0,dmesh(2)=150.0,dmesh(3)=180.0,time_window_max=3.0, / OBS_INPUT:: ! dfile dtype dplat dsis dval dthin dsfcalc obclass @@ -90,14 +90,14 @@ OBS_INPUT:: sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0 r21c_osbuv8_bufr ompsnmeffnc ompsnmeff npp ompsnmeff_npp 0.0 2 0 r21c_npp_ompsnmeff_nc ! ompsnpnc ompsnpnc npp ompsnpnc_npp 0.0 0 0 r21c_npp_ompsnp_nc -! ompslpgnc ompslp_g npp ompslp_g_npp 1.0 0 0 r21c_ompslp_g_nc +! ompsnpnc ompsnpnc npp ompsnpnc_npp 0.0 0 0 r21c_npp_ompsnp_nc ompslpvisnc ompslpvis npp ompslpvis_npp 0.0 0 0 r21c_ompslpvis_nc mlsnc mls55 aura mls55_aura 0.0 0 0 r21c_mls_nc omieffnc omieff aura omieff_aura 0.0 2 0 r21c_aura_omieff_nc hirs2bufr hirs2 n11 hirs2_n11 0.0 1 0 r21c_1bhrs2_bufr hirs2bufr hirs2 n12 hirs2_n12 0.0 1 0 r21c_1bhrs2_bufr hirs2bufr hirs2 n14 hirs2_n14 0.0 1 0 r21c_1bhrs2_bufr - hirs3bufr hirs3 n15 hirs3_n15 0.0 1 0 r21c_1bhrs3_bufr + hirs3bufr hirs3 n15 hirs3_n15 0.0 1 0 r21c_1bhrs3_bufr hirs3bufr hirs3 n16 hirs3_n16 0.0 1 0 r21c_1bhrs3_bufr hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0 r21c_1bhrs3_bufr hirs4bufr hirs4 n18 hirs4_n18 0.0 1 0 r21c_1bhrs4_bufr @@ -164,7 +164,7 @@ OBS_INPUT:: ! ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0 npp_ompsnp_bufr ! ompslpuvnc ompslpuv npp ompslpuv_npp 1.0 0 0 ompslpuv_nc ! sbuvbufr sbuv2 nim07 sbuv8_nim07 0.0 0 0 osbuv8_bufr -:: +:: &SUPEROB_RADAR / &LAG_DATA From b63668df9b92f7c7f83eee385ae2a2bfbf6a6070 Mon Sep 17 00:00:00 2001 From: Amal El Akkraoui Date: Tue, 6 Sep 2022 10:01:52 -0400 Subject: [PATCH 196/205] Second round of fixes to GEOSIT resource files --- src/Applications/GEOSdas_App/fvsetup | 12 +++++++++++- .../GEOSdas_App/write_FVDAS_Run_Config.pl | 8 +++++--- 2 files changed, 16 insertions(+), 4 deletions(-) diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index 22d7cabb..9eb1c713 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -8721,7 +8721,8 @@ sub write_FVDAS_Run_Config { if ($geosit || $r21c) { $ENV{"MKSI_SIDB"} = "\$FVHOME/run/gmao_satinfo.db"; - $ENV{"MKSI_OZDB"} = "\$FVHOME/run/gmao_ozinfo.db"; + $ENV{"MKSIOZ_SIDB"} = "\$FVHOME/run/gmao_ozinfo.db"; + $ENV{"MKSICN_SIDB"} = "\$FVHOME/run/gmao_convinfo.db" } unless ( $ENV{"ARCHIVE"} ) { @@ -10257,6 +10258,15 @@ sub copy_resources { } else { die "Cannot find $casedir oz.db under $fvetc, aborting ..."; } + mkdir ("$fvhome/run/gmao_convinfo.db"); + if ( -d "$fvetc/gmao_convinfo.db/$casedir" ) { + my @files = glob("$fvetc/gmao_convinfo.db/$casedir" . "/*"); + foreach my $fn ( @files ) { + cp("$fn", "$fvhome/run/gmao_convinfo.db"); + } + } else { + die "Cannot find $casedir conv.db under $fvetc, aborting ..."; + } } } diff --git a/src/Applications/GEOSdas_App/write_FVDAS_Run_Config.pl b/src/Applications/GEOSdas_App/write_FVDAS_Run_Config.pl index 5e9a5b8a..2cecac8a 100755 --- a/src/Applications/GEOSdas_App/write_FVDAS_Run_Config.pl +++ b/src/Applications/GEOSdas_App/write_FVDAS_Run_Config.pl @@ -14,7 +14,7 @@ my ($ARCH, $HOST); my ($FVHOME, $FVROOT, $RUNDIR); my ($AOD_OBSCLASS, $BERROR, $DO_ECS_OUT, $DO_REM_SYNC, $EXPID, $FVARCH, - $FVBCS, $GID, $MONTHLY_MEANS, $MKSI_SIDB, $MKSI_OZDB, $MP_SET_NUMTHREADS, $NCEPINPUT, $NOBACKUP, + $FVBCS, $GID, $MONTHLY_MEANS, $MKSI_SIDB, $MKSIOZ_SIDB, $MKSICN_SIDB, $MP_SET_NUMTHREADS, $NCEPINPUT, $NOBACKUP, $OBSCLASS, $OBSCLASS_NOAIRS, $OMP_NUM_THREADS, $RUN_QUADS, $PYRADMON, $VTRACK, $VTXLEVS, $VTXRELOC); my ($BASEDIR, $FCSTID, $FVDMGET, $G5MODULES, $PLOTS_LOC, $GEOSUTIL, $GTAG); @@ -93,7 +93,8 @@ sub init { $GID = $ENV{"GID"}; $MONTHLY_MEANS = $ENV{"MONTHLY_MEANS"}; $MKSI_SIDB = $ENV{"MKSI_SIDB"}; - $MKSI_OZDB = $ENV{"MKSI_OZDB"}; + $MKSIOZ_SIDB = $ENV{"MKSIOZ_SIDB"}; + $MKSICN_SIDB = $ENV{"MKSICN_SIDB"}; $MP_SET_NUMTHREADS = $ENV{"MP_SET_NUMTHREADS"}; $NCEPINPUT = $ENV{"NCEPINPUT"}; $OBSCLASS = $ENV{"OBSCLASS"}; @@ -324,7 +325,8 @@ sub writefile { print RUNCONF "setenv FVDOLMS $FVDOLMS\n" if $FVDOLMS; print RUNCONF "setenv CASE $CASE\n" if $CASE; print RUNCONF "setenv MKSI_SIDB $MKSI_SIDB\n" if $MKSI_SIDB; - print RUNCONF "setenv MKSI_OZDB $MKSI_OZDB\n" if $MKSI_OZDB; + print RUNCONF "setenv MKSIOZ_SIDB $MKSIOZ_SIDB\n" if $MKSIOZ_SIDB; + print RUNCONF "setenv MKSICN_SIDB $MKSICN_SIDB\n" if $MKSICN_SIDB; print RUNCONF "setenv MP_SET_NUMTHREADS $MP_SET_NUMTHREADS\n" if $MP_SET_NUMTHREADS; print RUNCONF "setenv OMP_NUM_THREADS $OMP_NUM_THREADS\n" if $OMP_NUM_THREADS; print RUNCONF "setenv ARCH_QUEUE \"$ARCH_QUEUE\"\n" if $ARCH_QUEUE; From 89d16d3fed984e69d3adb7e0e8cd8df6794f2b64 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Tue, 6 Sep 2022 11:00:34 -0400 Subject: [PATCH 197/205] orbital param ups per GCM group; other stuff is zero diff --- .../NCEP_enkf/scripts/gmao/etc/AGCM.rc.tmpl | 3 +++ .../scripts/gmao/etc/obs1gsi_mean.rc | 22 +++++++++++-------- .../scripts/gmao/etc/obs1gsi_member.rc | 22 +++++++++++-------- 3 files changed, 29 insertions(+), 18 deletions(-) diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/AGCM.rc.tmpl b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/AGCM.rc.tmpl index 8aae31e9..669fa294 100644 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/AGCM.rc.tmpl +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/AGCM.rc.tmpl @@ -26,6 +26,9 @@ SATSIM_DT: 3600 SOLARAvrg: 0 IRRADAvrg: 0 +ORBIT_ANAL2B: .TRUE. +EOT: .TRUE. + # UNCOMMENT to use Morrison-Gettelman-Barahona cloud microphysics #CLDMICRO: 2MOMENT diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/obs1gsi_mean.rc b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/obs1gsi_mean.rc index 3efa76db..c0e4781b 100644 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/obs1gsi_mean.rc +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/obs1gsi_mean.rc @@ -58,7 +58,8 @@ / &OBSQC dfact=0.75,dfact1=3.0,noiqc=.false.,oberrflg=.true.,c_varqc=0.02,blacklst=.true., - use_poq7=.true.,qc_noirjaco3=.true.,qc_satwnds=.false.,cld_det_dec2bin=.true., + use_poq7=.true.,qc_noirjaco3=.false.,qc_satwnds=.false.,cld_det_dec2bin=.true., + half_goesr_err=.false., ! tcp_ermin=0.75,tcp_ermax=0.75, >>>AIRCFT_BIAS<<< / @@ -69,19 +70,20 @@ OBS_INPUT:: ! dfile dtype dplat dsis dval dthin dsfcalc obsclass prepbufr ps null ps 0.0 0 0 ncep_prep_bufr prepbufr t null t 0.0 0 0 ncep_prep_bufr - prepbufr_profl t null t 0.0 0 0 ncep_acftpfl_bufr + prepbufr_profl t prof t 0.0 0 0 ncep_acftpfl_bufr prepbufr q null q 0.0 0 0 ncep_prep_bufr prepbufr uv null uv 0.0 0 0 ncep_prep_bufr - prepbufr_profl uv null uv 0.0 0 0 ncep_acftpfl_bufr + prepbufr_profl uv prof uv 0.0 0 0 ncep_acftpfl_bufr prepbufr spd null spd 0.0 0 0 ncep_prep_bufr radarbufr rw null rw 0.0 0 0 ncep_radar_bufr prepbufr dw null dw 0.0 0 0 ncep_prep_bufr -! prepbufr sst null sst 0.0 0 0 ncep_prep_bufr - modsbufr sst mods sst 0.0 0 0 test +! mlstbufr t aura t 1.0 0 0 gmao_mlst_bufr +!! prepbufr sst null sst 0.0 0 0 ncep_prep_bufr + modsbufr sst mods sst 0.0 0 0 to_be_done prepbufr pw null pw 0.0 0 0 ncep_prep_bufr preprscat uv null uv 0.0 0 0 rscat_bufr gpsrobufr gps_bnd null gps 0.0 0 0 ncep_gpsro_bufr - gpsrobufr gps_bnd null gps 0.0 0 0 ncep_gpsro_com_bufr + gpsrocombufr gps_bnd null gps 0.0 0 0 ncep_gpsro_com_bufr ssmirrbufr pcp_ssmi dmsp pcp_ssmi 0.0 0 0 ncep_spssmi_bufr tmirrbufr pcp_tmi trmm pcp_tmi 0.0 0 0 ncep_sptrmm_bufr sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 ncep_osbuv_bufr @@ -90,6 +92,7 @@ OBS_INPUT:: omibufr omi aura omi_aura 0.0 2 0 ncep_aura_omi_bufr ! ompsnmbufr ompsnm npp ompsnm_npp 0.0 2 0 npp_ompsnm_bufr ! ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0 npp_ompsnp_bufr +! ompsnpnc ompsnpnc npp ompsnpnc_npp 0.0 0 0 npp_ompsnp_nc ! NOomibufr omi aura omi_aura 0.0 2 0 test hirs2bufr hirs2 n14 hirs2_n14 0.0 1 0 ncep_1bhrs2_bufr hirs3bufr hirs3 n16 hirs3_n16 0.0 1 0 ncep_1bhrs3_bufr @@ -120,6 +123,7 @@ OBS_INPUT:: amsrebufr amsre_low aqua amsre_aqua 0.0 1 0 ncep_amsre_bufr amsrebufr amsre_mid aqua amsre_aqua 0.0 1 0 ncep_amsre_bufr amsrebufr amsre_hig aqua amsre_aqua 0.0 1 0 ncep_amsre_bufr +! amsregmao amsre aqua amsre_aqua 0.0 1 0 gmao_amsre_bufr ! ssmisbufr ssmis_las f16 ssmis_f16 0.0 1 0 test ! ssmisbufr ssmis_uas f16 ssmis_f16 0.0 1 0 test ! ssmisbufr ssmis_img f16 ssmis_f16 0.0 1 0 test @@ -143,6 +147,7 @@ OBS_INPUT:: ! gomebufr gome metop-a gome_metop-a 0.0 2 0 test ! mlsoz o3lev aura mls_aura_ozlv 0.0 0 0 test ! mlsozbufr o3lev aura o3lev_aura 0.0 0 0 test +! ompslpgnc ompslpnc npp ompslpnc_npp 1.0 0 0 ompslpnc_nc ! ompslpuvnc ompslpuv npp ompslpuv_npp 1.0 0 0 ompslpuv_nc ! ompslpvisnc ompslpvis npp ompslpvis_npp 1.0 0 0 ompslpvis_nc ! mlsoztext o3lev aura o3lev_aura 0.0 0 0 test @@ -165,7 +170,6 @@ OBS_INPUT:: iasibufr iasi metop-c iasi_metop-c 0.0 3 0 ncep_mtiasi_bufr atmsbufr atms npp atms_npp 0.0 1 0 ncep_atms_bufr atmsbufr atms n20 atms_n20 0.0 1 0 ncep_atms_bufr -! crisbufr cris npp cris_npp 0.0 3 0 ncep_cris_bufr crisfsrbufr cris-fsr npp cris-fsr_npp 0.0 3 0 ncep_crisfsr_bufr crisfsrbufr cris-fsr n20 cris-fsr_n20 0.0 3 0 ncep_crisfsr_bufr satwndbufr uv null uv 0.0 0 0 ncep_satwnd_bufr @@ -174,8 +178,8 @@ OBS_INPUT:: avcsambufr avhrr metop-a avhrr3_metop-a 0.0 1 0 ncep_avcsam_bufr avcsambufr avhrr metop-b avhrr3_metop-b 0.0 1 0 ncep_avcsam_bufr ! omieffbufr omieff aura omieff_aura 0.0 2 0 test -! omieffnc omieff aura omieff_aura 0.0 2 0 test -! mlstbufr t aura t 0.0 0 0 test +! omieffnc omieff aura omieff_aura 0.0 2 0 aura_omieff_nc +! ompsnmeffnc ompsnmeff npp ompsnmeff_npp 0.0 2 0 npp_ompsnmeff_nc gsnd1bufr sndrd1 g15 sndrD1_g15 0.0 1 0 ncep_goesfv_bufr gsnd1bufr sndrd2 g15 sndrD2_g15 0.0 1 0 ncep_goesfv_bufr gsnd1bufr sndrd3 g15 sndrD3_g15 0.0 1 0 ncep_goesfv_bufr diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/obs1gsi_member.rc b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/obs1gsi_member.rc index 12ea1c25..84bb45d7 100644 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/obs1gsi_member.rc +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/obs1gsi_member.rc @@ -58,7 +58,8 @@ / &OBSQC dfact=0.75,dfact1=3.0,noiqc=.false.,oberrflg=.true.,c_varqc=0.02,blacklst=.true., - use_poq7=.true.,qc_noirjaco3=.true.,qc_satwnds=.false.,cld_det_dec2bin=.true., + use_poq7=.true.,qc_noirjaco3=.false.,qc_satwnds=.false.,cld_det_dec2bin=.true., + half_goesr_err=.false., ! tcp_ermin=0.75,tcp_ermax=0.75, >>>AIRCFT_BIAS<<< / @@ -69,19 +70,20 @@ OBS_INPUT:: ! dfile dtype dplat dsis dval dthin dsfcalc obsclass prepbufr ps null ps 0.0 0 0 ncep_prep_bufr prepbufr t null t 0.0 0 0 ncep_prep_bufr - prepbufr_profl t null t 0.0 0 0 ncep_acftpfl_bufr + prepbufr_profl t prof t 0.0 0 0 ncep_acftpfl_bufr prepbufr q null q 0.0 0 0 ncep_prep_bufr prepbufr uv null uv 0.0 0 0 ncep_prep_bufr - prepbufr_profl uv null uv 0.0 0 0 ncep_acftpfl_bufr + prepbufr_profl uv prof uv 0.0 0 0 ncep_acftpfl_bufr prepbufr spd null spd 0.0 0 0 ncep_prep_bufr radarbufr rw null rw 0.0 0 0 ncep_radar_bufr prepbufr dw null dw 0.0 0 0 ncep_prep_bufr -! prepbufr sst null sst 0.0 0 0 ncep_prep_bufr - modsbufr sst mods sst 0.0 0 0 test +! mlstbufr t aura t 1.0 0 0 gmao_mlst_bufr +!! prepbufr sst null sst 0.0 0 0 ncep_prep_bufr + modsbufr sst mods sst 0.0 0 0 to_be_done prepbufr pw null pw 0.0 0 0 ncep_prep_bufr preprscat uv null uv 0.0 0 0 rscat_bufr gpsrobufr gps_bnd null gps 0.0 0 0 ncep_gpsro_bufr - gpsrobufr gps_bnd null gps 0.0 0 0 ncep_gpsro_com_bufr + gpsrocombufr gps_bnd null gps 0.0 0 0 ncep_gpsro_com_bufr ssmirrbufr pcp_ssmi dmsp pcp_ssmi 0.0 0 0 ncep_spssmi_bufr tmirrbufr pcp_tmi trmm pcp_tmi 0.0 0 0 ncep_sptrmm_bufr sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 ncep_osbuv_bufr @@ -90,6 +92,7 @@ OBS_INPUT:: omibufr omi aura omi_aura 0.0 2 0 ncep_aura_omi_bufr ! ompsnmbufr ompsnm npp ompsnm_npp 0.0 2 0 npp_ompsnm_bufr ! ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0 npp_ompsnp_bufr +! ompsnpnc ompsnpnc npp ompsnpnc_npp 0.0 0 0 npp_ompsnp_nc ! NOomibufr omi aura omi_aura 0.0 2 0 test hirs2bufr hirs2 n14 hirs2_n14 0.0 1 0 ncep_1bhrs2_bufr hirs3bufr hirs3 n16 hirs3_n16 0.0 1 0 ncep_1bhrs3_bufr @@ -120,6 +123,7 @@ OBS_INPUT:: amsrebufr amsre_low aqua amsre_aqua 0.0 1 0 ncep_amsre_bufr amsrebufr amsre_mid aqua amsre_aqua 0.0 1 0 ncep_amsre_bufr amsrebufr amsre_hig aqua amsre_aqua 0.0 1 0 ncep_amsre_bufr +! amsregmao amsre aqua amsre_aqua 0.0 1 0 gmao_amsre_bufr ! ssmisbufr ssmis_las f16 ssmis_f16 0.0 1 0 test ! ssmisbufr ssmis_uas f16 ssmis_f16 0.0 1 0 test ! ssmisbufr ssmis_img f16 ssmis_f16 0.0 1 0 test @@ -143,6 +147,7 @@ OBS_INPUT:: ! gomebufr gome metop-a gome_metop-a 0.0 2 0 test ! mlsoz o3lev aura mls_aura_ozlv 0.0 0 0 test ! mlsozbufr o3lev aura o3lev_aura 0.0 0 0 test +! ompslpgnc ompslpnc npp ompslpnc_npp 1.0 0 0 ompslpnc_nc ! ompslpuvnc ompslpuv npp ompslpuv_npp 1.0 0 0 ompslpuv_nc ! ompslpvisnc ompslpvis npp ompslpvis_npp 1.0 0 0 ompslpvis_nc ! mlsoztext o3lev aura o3lev_aura 0.0 0 0 test @@ -165,7 +170,6 @@ OBS_INPUT:: iasibufr iasi metop-c iasi_metop-c 0.0 3 0 ncep_mtiasi_bufr atmsbufr atms npp atms_npp 0.0 1 0 ncep_atms_bufr atmsbufr atms n20 atms_n20 0.0 1 0 ncep_atms_bufr -! crisbufr cris npp cris_npp 0.0 3 0 ncep_cris_bufr crisfsrbufr cris-fsr npp cris-fsr_npp 0.0 3 0 ncep_crisfsr_bufr crisfsrbufr cris-fsr n20 cris-fsr_n20 0.0 3 0 ncep_crisfsr_bufr satwndbufr uv null uv 0.0 0 0 ncep_satwnd_bufr @@ -174,8 +178,8 @@ OBS_INPUT:: avcsambufr avhrr metop-a avhrr3_metop-a 0.0 1 0 ncep_avcsam_bufr avcsambufr avhrr metop-b avhrr3_metop-b 0.0 1 0 ncep_avcsam_bufr ! omieffbufr omieff aura omieff_aura 0.0 2 0 test -! omieffnc omieff aura omieff_aura 0.0 2 0 test -! mlstbufr t aura t 0.0 0 0 test +! omieffnc omieff aura omieff_aura 0.0 2 0 aura_omieff_nc +! ompsnmeffnc ompsnmeff npp ompsnmeff_npp 0.0 2 0 npp_ompsnmeff_nc gsnd1bufr sndrd1 g15 sndrD1_g15 0.0 1 0 ncep_goesfv_bufr gsnd1bufr sndrd2 g15 sndrD2_g15 0.0 1 0 ncep_goesfv_bufr gsnd1bufr sndrd3 g15 sndrD3_g15 0.0 1 0 ncep_goesfv_bufr From 13dbcc72fec7eff4792f5811cf6c0e8bf0d64e51 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Tue, 6 Sep 2022 14:56:44 -0400 Subject: [PATCH 198/205] non-zero diff due to orbital params changes in AGCM.rc --- components.yaml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/components.yaml b/components.yaml index 6fb642db..8770ab9d 100644 --- a/components.yaml +++ b/components.yaml @@ -28,7 +28,7 @@ NCEP_Shared: GMAO_Shared: local: ./src/Shared/@GMAO_Shared remote: ../GMAO_Shared.git - tag: rt1_4_10_geosit5 + tag: rt1_4_10_geosit6 develop: main MAPL: @@ -46,7 +46,7 @@ FMS: GEOSana_GridComp: local: ./src/Components/@GEOSana_GridComp remote: ../GEOSana_GridComp.git - tag: v1.5.4.4 + tag: v1.5.4.6 develop: develop GEOSgcm_GridComp: @@ -101,7 +101,7 @@ geos-chem: GOCART: local: ./src/Components/@GEOSgcm_GridComp/GEOSagcm_GridComp/GEOSphysics_GridComp/@GEOSchem_GridComp/@GOCART remote: ../GOCART.git - tag: rt1.0.1_geosit3 + tag: rt1.0.1_geosit4 sparse: ./config/GOCART.sparse develop: develop @@ -121,7 +121,7 @@ mom6: GEOSgcm_App: local: ./src/Applications/@GEOSgcm_App remote: ../GEOSgcm_App.git - tag: rt1.5.6_geosit_hist5 + tag: rt1.5.6_orbParam develop: develop UMD_Etc: From c22f9046669d9e063d4c6c0cebb706b6f6063b75 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Wed, 7 Sep 2022 15:30:43 -0400 Subject: [PATCH 199/205] add geosit_prep_bufr --- src/Applications/GEOSdas_App/testsuites/geos_it.input | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Applications/GEOSdas_App/testsuites/geos_it.input b/src/Applications/GEOSdas_App/testsuites/geos_it.input index 1b00f2fc..5c312bf6 100644 --- a/src/Applications/GEOSdas_App/testsuites/geos_it.input +++ b/src/Applications/GEOSdas_App/testsuites/geos_it.input @@ -138,7 +138,7 @@ Which main class of ObsSys (1: NRT; 2: MERRA; 3: MERRA-2; 4: GEOS-IT; 5: R21C)? > 4 OBSERVING SYSTEM CLASSES? -> geosit_cdas_raob_pre-qc_bufr,geosit_cdas_conv_pre-qc_bufr,geosit_prof_pre-qc_bufr,geosit_avhrrwnd_pre-qc_bufr,geosit_nmodis_pre-qc_bufr,geosit_goes_pre-qc_prep_bufr,geosit_metsat_pre-qc_prep_bufr,geosit_jma_pre-qc_prep_bufr,geosit_ascat_pre-qc_bufr,geosit_repro_ers2_pre-qc_bufr,geosit_qscat_jpl_pre-qc_bufr,geosit_wspd_pre-qc_bufr,geosit_satwnd_bufr,geosit_avhrr_satwnd_bufr,geosit_ncep_tcvitals,geosit_tmi_bufr,geosit_gpsro_bufr,geosit_sevcsr_bufr,geosit_1bamua_bufr,geosit_1bamub_bufr,geosit_1bhrs2_bufr,geosit_1bhrs3_bufr,geosit_1bhrs4_bufr,geosit_1bmsu_bufr,geosit_1bmhs_bufr,geosit_1bssu_bufr,geosit_eosairs_bufr,geosit_eosamsua_bufr,geosit_mtiasi_bufr,geosit_atms_bufr,geosit_ssmit11_bufr,geosit_ssmit13_bufr,geosit_ssmit14_bufr,geosit_ssmit15_bufr,geosit_amsre_bufr,geosit_osbuv8_bufr,geosit_npp_ompsnp_nc,geosit_aura_omieff_nc,geosit_npp_ompsnmeff_nc,geosit_avcsam_bufr,geosit_avcspm_bufr,geosit_acftpfl_bufr,geosit_amsr2_bufr,geosit_crisfsr_bufr,geosit_gmi_bufr +> geosit_cdas_raob_pre-qc_bufr,geosit_cdas_conv_pre-qc_bufr,geosit_prof_pre-qc_bufr,geosit_avhrrwnd_pre-qc_bufr,geosit_nmodis_pre-qc_bufr,geosit_goes_pre-qc_prep_bufr,geosit_metsat_pre-qc_prep_bufr,geosit_jma_pre-qc_prep_bufr,geosit_ascat_pre-qc_bufr,geosit_repro_ers2_pre-qc_bufr,geosit_qscat_jpl_pre-qc_bufr,geosit_wspd_pre-qc_bufr,geosit_satwnd_bufr,geosit_avhrr_satwnd_bufr,geosit_ncep_tcvitals,geosit_tmi_bufr,geosit_gpsro_bufr,geosit_sevcsr_bufr,geosit_1bamua_bufr,geosit_1bamub_bufr,geosit_1bhrs2_bufr,geosit_1bhrs3_bufr,geosit_1bhrs4_bufr,geosit_1bmsu_bufr,geosit_1bmhs_bufr,geosit_1bssu_bufr,geosit_eosairs_bufr,geosit_eosamsua_bufr,geosit_mtiasi_bufr,geosit_atms_bufr,geosit_ssmit11_bufr,geosit_ssmit13_bufr,geosit_ssmit14_bufr,geosit_ssmit15_bufr,geosit_amsre_bufr,geosit_osbuv8_bufr,geosit_npp_ompsnp_nc,geosit_aura_omieff_nc,geosit_npp_ompsnmeff_nc,geosit_avcsam_bufr,geosit_avcspm_bufr,geosit_acftpfl_bufr,geosit_amsr2_bufr,geosit_crisfsr_bufr,geosit_gmi_bufr,geosit_prep_bufr CHECKING OBSYSTEM? [2] > 1 From 5acf6c6a7f635e708e9dfca0e4b2f8942561ae78 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Thu, 15 Sep 2022 06:55:04 -0400 Subject: [PATCH 200/205] version numbers now to all repos --- components.yaml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/components.yaml b/components.yaml index 8770ab9d..38de4929 100644 --- a/components.yaml +++ b/components.yaml @@ -28,7 +28,7 @@ NCEP_Shared: GMAO_Shared: local: ./src/Shared/@GMAO_Shared remote: ../GMAO_Shared.git - tag: rt1_4_10_geosit6 + tag: v1.4.10.1 develop: main MAPL: @@ -52,7 +52,7 @@ GEOSana_GridComp: GEOSgcm_GridComp: local: ./src/Components/@GEOSgcm_GridComp remote: ../GEOSgcm_GridComp.git - tag: rt1_12_4_geosit + tag: v1.12.4.1 sparse: ./config/GEOSgcm_GridComp.sparse develop: develop @@ -83,7 +83,7 @@ fvdycore: GEOSchem_GridComp: local: ./src/Components/@GEOSgcm_GridComp/GEOSagcm_GridComp/GEOSphysics_GridComp/@GEOSchem_GridComp remote: ../GEOSchem_GridComp.git - tag: rt1.6.2_geosit + tag: v1.6.1 develop: develop HEMCO: @@ -101,7 +101,7 @@ geos-chem: GOCART: local: ./src/Components/@GEOSgcm_GridComp/GEOSagcm_GridComp/GEOSphysics_GridComp/@GEOSchem_GridComp/@GOCART remote: ../GOCART.git - tag: rt1.0.1_geosit4 + tag: v1.0.2 sparse: ./config/GOCART.sparse develop: develop @@ -121,7 +121,7 @@ mom6: GEOSgcm_App: local: ./src/Applications/@GEOSgcm_App remote: ../GEOSgcm_App.git - tag: rt1.5.6_orbParam + tag: v1.5.6.1 develop: develop UMD_Etc: From 8aa1ea072a64c2a5576b61f13febd26047cd78d8 Mon Sep 17 00:00:00 2001 From: vbuchard Date: Fri, 30 Sep 2022 13:51:53 -0400 Subject: [PATCH 201/205] vb:update ana_aod.F code to handle both AOD and LAOD obs at the same time --- src/Applications/GAAS_App/ana_aod.F | 31 +++++++++++++++++------------ 1 file changed, 18 insertions(+), 13 deletions(-) diff --git a/src/Applications/GAAS_App/ana_aod.F b/src/Applications/GAAS_App/ana_aod.F index 2e7d9a31..0745c39b 100644 --- a/src/Applications/GAAS_App/ana_aod.F +++ b/src/Applications/GAAS_App/ana_aod.F @@ -67,9 +67,10 @@ program ana_aod ! --------------- integer :: im, jm, km, nch integer :: im_so, jm_so ! dimension of superob space - integer :: rc, nobs, nobs_good, nODS, i + integer :: rc, nobs, nobs_good, nODS, i, naod, nlaod integer :: nymd=0, nhms=0, nymd_b, nhms_b integer :: myKTobs + integer :: kt_list(2) real*8 :: alpha ! bias update coefficient real*8 :: chAOD(2) ! Range of AOD waenumbers (nm) to analyze @@ -255,34 +256,38 @@ program ana_aod if ( rc /= 0 ) then call die ( myname, 'could not read ODS files') end if - myKTobs=ktAOD + ! can read AOD and log AOD obs + kt_list = (/ktAOD,ktLogAOD/) call ods_select( ods_, ods_%data%nobs, nobs, rc, - & qcexcl=0, kt=myKTobs, odss = ods ) ! keep what we need + & qcexcl=0, kt_list=kt_list, odss = ods ) ! keep what we need if ( rc .eq. 0 ) then nobs = ods%data%nobs - if ( nobs==0 ) then - call ods_clean(ods,rc) - ! try reading log(AOD) - print *, myname//': could not find obs with kt = ', myKTobs - myKTobs=ktLogAOD - print *, myname//': trying kt = ', myKTobs, ' ... ' - call ods_select( ods_, ods_%data%nobs, nobs, rc, - & qcexcl=0, kt=myKTobs, odss = ods ) ! keep what we need + naod = count(ods%data%kt==ktAOD) + nlaod = count(ods%data%kt==ktLogAOD) + ! if Log AOD available then convert the obs into AOD + if (nlaod >0.) then + where (ods%data%kt == ktLogAOD) + ods%data%obs = max(eps,exp(ods%data%obs)-0.01) + ods%data%kt = ktAOD + endwhere endif - call ods_clean(ods_,rc) ! get rid of what we don't need + myKTobs = ktAOD ! all obs are now supposed to be AOD + call ods_clean(ods_,rc) ! get rid of what we do not need print *, myname//': read ODS files' print *, myname//': nobs = ', nobs + print *, myname//': naod = ', naod, ' and nlaod = ', nlaod print * else call die ( myname, 'could not perform ODS select') end if + ! Prints out input ODS summary ! ---------------------------- call fix_odsmeta(ods) call ODS_Tally ( 6, ods, nobs, rc ) -! Call observer for this date/time +! Call observer for this date/time (the convert option becomes obsolete now) ! -------------------------------- call zeit_ci ( 'Observer' ) call Observer ( nymd, nhms, y_f, nobs, ods, nobs_good, convertOb2AOD=(myKTobs==ktLogAOD) ) From f3a1383283b1a9cee3dede321181adcd6c7eb445 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Mon, 3 Oct 2022 07:12:35 -0400 Subject: [PATCH 202/205] minor fixes for GEOSIT - one fix for FP (EnKF) --- components.yaml | 4 +- src/Applications/GEOSdas_App/edhist.pl | 4 +- .../GEOSdas_App/monthly.yyyymm.pl.tmpl | 4 +- .../GEOSdas_App/testsuites/geos_it.input | 4 +- .../GEOSdas_App/write_monthly_rc_arc.pl | 31 +- .../NCEP_Etc/NCEP_enkf/innovstats.f90 | 980 +++++++++--------- .../NCEP_enkf/scripts/gmao/etc/AGCM.rc.tmpl | 2 +- 7 files changed, 530 insertions(+), 499 deletions(-) diff --git a/components.yaml b/components.yaml index 38de4929..5ca4037c 100644 --- a/components.yaml +++ b/components.yaml @@ -46,7 +46,7 @@ FMS: GEOSana_GridComp: local: ./src/Components/@GEOSana_GridComp remote: ../GEOSana_GridComp.git - tag: v1.5.4.6 + tag: v1.5.4.7 develop: develop GEOSgcm_GridComp: @@ -71,7 +71,7 @@ GEOSagcmPert_GridComp: FVdycoreCubed_GridComp: local: ./src/Components/@GEOSgcm_GridComp/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/@FVdycoreCubed_GridComp remote: ../FVdycoreCubed_GridComp.git - tag: v1.2.15 + tag: v1.2.15.1 develop: develop fvdycore: diff --git a/src/Applications/GEOSdas_App/edhist.pl b/src/Applications/GEOSdas_App/edhist.pl index 785dfb73..4b8e6100 100755 --- a/src/Applications/GEOSdas_App/edhist.pl +++ b/src/Applications/GEOSdas_App/edhist.pl @@ -1363,8 +1363,8 @@ sub add_silo_mstorage_traits { my (@anaID, @chemID, @diagID, @progID, $name, $storage); @anaID = qw( vtx .eta .sfc .prs ); - @chemID = qw( _adg_ _aer_ _chm_ _gas_ _nav_ _tag_ - adg_ aer_ chm_ gas_ nav_ tag_ ); + @chemID = qw( _adg_ _aer_ _ctm_ _chm_ _gas_ _nav_ _tag_ + adg_ aer_ ctm_ chm_ gas_ nav_ tag_ ); @diagID = qw( _asm_ _chm_ _cld_ _csp_ _dyn_ _ext_ _flx_ _glc_ _hwl_ _int_ _lfo_ _lnd_ _lsf_ _met_ _mst_ _ocn_ _odt_ _qdt_ _rad_ _slv_ _tdt_ _tmp_ _trb_ _udt_ _wnd_ diff --git a/src/Applications/GEOSdas_App/monthly.yyyymm.pl.tmpl b/src/Applications/GEOSdas_App/monthly.yyyymm.pl.tmpl index d33dce9b..c47ae017 100644 --- a/src/Applications/GEOSdas_App/monthly.yyyymm.pl.tmpl +++ b/src/Applications/GEOSdas_App/monthly.yyyymm.pl.tmpl @@ -63,8 +63,8 @@ my ($walltime_cl, $walltime_mm, $walltime_mp, $walltime_pf); my ($partition, $qos, $runlocal); my ($datamove_constraint); -$partition = "preops"; -$qos = "dastest"; +#$partition = "preops"; +#$qos = "dastest"; my %valid = ( "fetch" => 1, "means" => 1, diff --git a/src/Applications/GEOSdas_App/testsuites/geos_it.input b/src/Applications/GEOSdas_App/testsuites/geos_it.input index 5c312bf6..6fd72854 100644 --- a/src/Applications/GEOSdas_App/testsuites/geos_it.input +++ b/src/Applications/GEOSdas_App/testsuites/geos_it.input @@ -138,7 +138,7 @@ Which main class of ObsSys (1: NRT; 2: MERRA; 3: MERRA-2; 4: GEOS-IT; 5: R21C)? > 4 OBSERVING SYSTEM CLASSES? -> geosit_cdas_raob_pre-qc_bufr,geosit_cdas_conv_pre-qc_bufr,geosit_prof_pre-qc_bufr,geosit_avhrrwnd_pre-qc_bufr,geosit_nmodis_pre-qc_bufr,geosit_goes_pre-qc_prep_bufr,geosit_metsat_pre-qc_prep_bufr,geosit_jma_pre-qc_prep_bufr,geosit_ascat_pre-qc_bufr,geosit_repro_ers2_pre-qc_bufr,geosit_qscat_jpl_pre-qc_bufr,geosit_wspd_pre-qc_bufr,geosit_satwnd_bufr,geosit_avhrr_satwnd_bufr,geosit_ncep_tcvitals,geosit_tmi_bufr,geosit_gpsro_bufr,geosit_sevcsr_bufr,geosit_1bamua_bufr,geosit_1bamub_bufr,geosit_1bhrs2_bufr,geosit_1bhrs3_bufr,geosit_1bhrs4_bufr,geosit_1bmsu_bufr,geosit_1bmhs_bufr,geosit_1bssu_bufr,geosit_eosairs_bufr,geosit_eosamsua_bufr,geosit_mtiasi_bufr,geosit_atms_bufr,geosit_ssmit11_bufr,geosit_ssmit13_bufr,geosit_ssmit14_bufr,geosit_ssmit15_bufr,geosit_amsre_bufr,geosit_osbuv8_bufr,geosit_npp_ompsnp_nc,geosit_aura_omieff_nc,geosit_npp_ompsnmeff_nc,geosit_avcsam_bufr,geosit_avcspm_bufr,geosit_acftpfl_bufr,geosit_amsr2_bufr,geosit_crisfsr_bufr,geosit_gmi_bufr,geosit_prep_bufr +> geosit_cdas_raob_pre-qc_bufr,geosit_cdas_conv_pre-qc_bufr,geosit_prof_pre-qc_bufr,geosit_avhrrwnd_pre-qc_bufr,geosit_nmodis_pre-qc_bufr,geosit_goes_pre-qc_prep_bufr,geosit_metsat_pre-qc_prep_bufr,geosit_jma_pre-qc_prep_bufr,geosit_ascat_pre-qc_bufr,geosit_repro_ers2_pre-qc_bufr,geosit_qscat_jpl_pre-qc_bufr,geosit_satwnd_bufr,geosit_avhrr_satwnd_bufr,geosit_ncep_tcvitals,geosit_tmi_bufr,geosit_gpsro_bufr,geosit_sevcsr_bufr,geosit_1bamua_bufr,geosit_1bamub_bufr,geosit_1bhrs2_bufr,geosit_1bhrs3_bufr,geosit_1bhrs4_bufr,geosit_1bmsu_bufr,geosit_1bmhs_bufr,geosit_eosairs_bufr,geosit_eosamsua_bufr,geosit_mtiasi_bufr,geosit_atms_bufr,geosit_ssmit11_bufr,geosit_ssmit13_bufr,geosit_ssmit14_bufr,geosit_ssmit15_bufr,geosit_amsre_bufr,geosit_osbuv8_bufr,geosit_npp_ompsnp_nc,geosit_aura_omieff_nc,geosit_npp_ompsnmeff_nc,geosit_avcsam_bufr,geosit_avcspm_bufr,geosit_acftpfl_bufr,geosit_amsr2_bufr,geosit_crisfsr_bufr,geosit_gmi_bufr,geosit_prep_bufr CHECKING OBSYSTEM? [2] > 1 @@ -195,7 +195,7 @@ Do Aerosol Analysis (y/n)? [y] > AOD OBSERVING CLASSES [or type 'none']? -> mod04_061_his,myd04_061_his,aeronet_obs +> patmosx_ods,mod04_061_flk,myd04_061_flk,mod04_061_his,myd04_061_his,aeronet_obs Enable GAAS feedback to model (y/n)? [y] > diff --git a/src/Applications/GEOSdas_App/write_monthly_rc_arc.pl b/src/Applications/GEOSdas_App/write_monthly_rc_arc.pl index 9b83998a..9b35f70d 100755 --- a/src/Applications/GEOSdas_App/write_monthly_rc_arc.pl +++ b/src/Applications/GEOSdas_App/write_monthly_rc_arc.pl @@ -108,7 +108,36 @@ "traj.lcv" => 1, "bkg_clcv_rst" => 1, "vtx.mix" => 1, - "vtx.prs" => 1 ); + "vtx.prs" => 1, + "asm_inst_3hr_glo_C180x180x6_v72" => 1, + "asm_tavg_3hr_glo_C180x180x6_v72" => 1, + "asm_inst_1hr_glo_C180x180x6_slv" => 1, + "cld_tavg_3hr_glo_C180x180x6_v72" => 1, + "mst_tavg_3hr_glo_C180x180x6_v73" => 1, + "mst_tavg_3hr_glo_C180x180x6_v72" => 1, + "rad_tavg_3hr_glo_C180x180x6_v72" => 1, + "trb_tavg_3hr_glo_C180x180x6_v73" => 1, + "tdt_tavg_3hr_glo_C180x180x6_v72" => 1, + "udt_tavg_3hr_glo_C180x180x6_v72" => 1, + "qdt_tavg_3hr_glo_C180x180x6_v72" => 1, + "odt_tavg_3hr_glo_C180x180x6_v72" => 1, + "slv_tavg_1hr_glo_C180x180x6_slv" => 1, + "flx_tavg_1hr_glo_C180x180x6_slv" => 1, + "rad_tavg_1hr_glo_C180x180x6_slv" => 1, + "lnd_tavg_1hr_glo_C180x180x6_slv" => 1, + "lfo_tavg_1hr_glo_C180x180x6_slv" => 1, + "lfo_inst_1hr_glo_C180x180x6_slv" => 1, + "ocn_tavg_1hr_glo_C180x180x6_slv" => 1, + "aer_inst_3hr_glo_C180x180x6_v72" => 1, + "chm_inst_3hr_glo_C180x180x6_v72" => 1, + "aer_tavg_3hr_glo_C180x180x6_slv" => 1, + "adg_tavg_3hr_glo_C180x180x6_slv" => 1, + "chm_tavg_3hr_glo_C180x180x6_slv" => 1, + "nav_tavg_3hr_glo_C180x180x6_v72" => 1, + "nav_tavg_3hr_glo_C180x180x6_v73" => 1, + "ctm_tavg_1hr_glo_C180x180x6_v72" => 1, + "ctm_inst_1hr_glo_C180x180x6_v72" => 1, + "asm_const_0hr_glo_C180x180x6_slv" => 1 ); # main program #------------- { diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/innovstats.f90 b/src/Applications/NCEP_Etc/NCEP_enkf/innovstats.f90 index 69aa283c..5fbd118c 100644 --- a/src/Applications/NCEP_Etc/NCEP_enkf/innovstats.f90 +++ b/src/Applications/NCEP_Etc/NCEP_enkf/innovstats.f90 @@ -1,511 +1,513 @@ -module innovstats -!$$$ module documentation block -! -! module: innovstats print ensemble innovation statistics. -! -! prgmmr: whitaker org: esrl/psd date: 2009-02-23 -! -! abstract: -! -! Public Subroutines: -! print_innovstats: given obfit_prior and obsprd_prior (observation - -! ensemble mean observation variable, ensemble standard deviation of -! observation variable), print some statistics useful for monitoring. -! -! Public Variables: None -! -! program history log: -! 2009-02-23 Initial version. -! 2012-05- Todling : added the Jo fits to the statistics table -! 2012-05-14 El Akkraoui : use the oberr_orig instead of oberrvar in the -! statistics table -! 2016-03-21 Todling - add stats for AOD -! 2017-05-20 Todling - allow calc of stats for assimilated obs only -! -! attributes: -! language: f95 -! -!$$$ + module innovstats + !$$$ module documentation block + ! + ! module: innovstats print ensemble innovation statistics. + ! + ! prgmmr: whitaker org: esrl/psd date: 2009-02-23 + ! + ! abstract: + ! + ! Public Subroutines: + ! print_innovstats: given obfit_prior and obsprd_prior (observation - + ! ensemble mean observation variable, ensemble standard deviation of + ! observation variable), print some statistics useful for monitoring. + ! + ! Public Variables: None + ! + ! program history log: + ! 2009-02-23 Initial version. + ! 2012-05- Todling : added the Jo fits to the statistics table + ! 2012-05-14 El Akkraoui : use the oberr_orig instead of oberrvar in the + ! statistics table + ! 2016-03-21 Todling - add stats for AOD + ! 2017-05-20 Todling - allow calc of stats for assimilated obs only + ! + ! attributes: + ! language: f95 + ! + !$$$ -use enkf_obsmod, only: oberrvar,ob,ensmean_ob,obtype,nobs_conv,nobs_oz,& - nobs_sat,nobstot,obloclat,ensmean_obnobc,obpress,stattype,& - oberrvar_orig,indxsat,iused -use params, only : latbound,stats_usedob_only -use kinds, only: i_kind, r_kind,r_single -use radinfo, only: jpch_rad,nusis,nuchan -use constants, only: one,zero + use enkf_obsmod, only: oberrvar,ob,ensmean_ob,obtype,nobs_conv,nobs_oz,& + nobs_sat,nobstot,obloclat,ensmean_obnobc,obpress,stattype,& + oberrvar_orig,indxsat,iused + use params, only : latbound,stats_usedob_only + use kinds, only: i_kind, r_kind,r_single + use radinfo, only: jpch_rad,nusis,nuchan + use constants, only: one,zero -implicit none + implicit none -private + private -public :: print_innovstats + public :: print_innovstats -contains + contains -subroutine print_innovstats(obfit,obsprd) -real(r_single), intent(in) :: obfit(nobstot), obsprd(nobstot) -integer(i_kind) nobst_nh,nobst_sh,nobst_tr,& - nobspw_nh,nobspw_sh,nobspw_tr,& - nobsspd_nh,nobsspd_sh,nobsspd_tr,& - nobsgps_nh,nobsgps_sh,nobsgps_tr,& - nobsaod_nh,nobsaod_sh,nobsaod_tr,& - nobsq_nh,nobsq_sh,nobsq_tr,nobswnd_nh,nobswnd_sh,nobswnd_tr,& - nobsoz_nh,nobsoz_sh,nobsoz_tr,nobsps_sh,nobsps_nh,nobsps_tr,nob, & - nobsps_tot,nobst_tot,nobswnd_tot,nobsq_tot,nobsoz_tot,nobspw_tot,& - nobsspd_tot,nobsgps_tot,nobsaod_tot -integer(i_kind) nobssat_tot,ntotassim -real(r_single) sumps_nh,biasps_nh,sumps_sh,biasps_sh,& - sumps_tr,biasps_tr,& - sumps_spread_nh,sumps_spread_sh,sumps_spread_tr,sumps_oberr_nh,& - sumps_oberr_sh,sumps_oberr_tr,& - sumt_nh,biast_nh,sumt_spread_nh,sumt_oberr_nh,& - sumt_sh,biast_sh,sumt_spread_sh,sumt_oberr_sh,& - sumt_tr,biast_tr,sumt_spread_tr,sumt_oberr_tr,& - sumq_nh,biasq_nh,sumq_spread_nh,sumq_oberr_nh,& - sumq_sh,biasq_sh,sumq_spread_sh,sumq_oberr_sh,& - sumq_tr,biasq_tr,sumq_spread_tr,sumq_oberr_tr,& - sumspd_nh,biasspd_nh,sumspd_spread_nh,sumspd_oberr_nh,& - sumspd_sh,biasspd_sh,sumspd_spread_sh,sumspd_oberr_sh,& - sumspd_tr,biasspd_tr,sumspd_spread_tr,sumspd_oberr_tr,& - sumgps_nh,biasgps_nh,sumgps_spread_nh,sumgps_oberr_nh,& - sumgps_sh,biasgps_sh,sumgps_spread_sh,sumgps_oberr_sh,& - sumgps_tr,biasgps_tr,sumgps_spread_tr,sumgps_oberr_tr,& - sumaod_nh,biasaod_nh,sumaod_spread_nh,sumaod_oberr_nh,& - sumaod_sh,biasaod_sh,sumaod_spread_sh,sumaod_oberr_sh,& - sumaod_tr,biasaod_tr,sumaod_spread_tr,sumaod_oberr_tr,& - sumpw_nh,biaspw_nh,sumpw_spread_nh,sumpw_oberr_nh,& - sumpw_sh,biaspw_sh,sumpw_spread_sh,sumpw_oberr_sh,& - sumpw_tr,biaspw_tr,sumpw_spread_tr,sumpw_oberr_tr,& - sumoz_nh,biasoz_nh,sumoz_spread_nh,sumoz_oberr_nh,& - sumoz_sh,biasoz_sh,sumoz_spread_sh,sumoz_oberr_sh,& - sumoz_tr,biasoz_tr,sumoz_spread_tr,sumoz_oberr_tr,& - sumwnd_nh,biaswnd_nh,sumwnd_spread_nh,sumwnd_oberr_nh,& - sumwnd_sh,biaswnd_sh,sumwnd_spread_sh,sumwnd_oberr_sh,& - sumwnd_tr,biaswnd_tr,sumwnd_spread_tr,sumwnd_oberr_tr -real(r_single) sumpsjo_nh,sumpsjo_sh,sumpsjo_tr,sumpsjo -real(r_single) sumtjo_nh,sumtjo_sh,sumtjo_tr,sumtjo -real(r_single) sumwndjo_nh,sumwndjo_sh,sumwndjo_tr,sumwndjo -real(r_single) sumqjo_nh,sumqjo_sh,sumqjo_tr,sumqjo -real(r_single) sumspdjo_nh,sumspdjo_sh,sumspdjo_tr,sumspdjo -real(r_single) sumgpsjo_nh,sumgpsjo_sh,sumgpsjo_tr,sumgpsjo -real(r_single) sumaodjo_nh,sumaodjo_sh,sumaodjo_tr,sumaodjo -real(r_single) sumpwjo_nh,sumpwjo_sh,sumpwjo_tr,sumpwjo -real(r_single) sumozjo_nh,sumozjo_sh,sumozjo_tr,sumozjo -real(r_single) sumjo_tot -! stuff for computing sat data innovation stats. -real(r_single) sumsprd_sat(jpch_rad),sumerr_sat(jpch_rad), & - sumfit_sat(jpch_rad),sumfitsq_sat(jpch_rad),sumjo_sat(jpch_rad),& - predicted_innov,innov -integer(i_kind) nob_sat(jpch_rad),nchan,nn -real(r_single) :: denom -!==> stats for conventional + ozone obs. - !==> pre-process obs, obs metadata. - nobsps_nh = 0 - nobsps_sh = 0 - nobsps_tr = 0 - nobsps_tot= 0 - nobst_nh = 0 - nobst_sh = 0 - nobst_tr = 0 - nobst_tot=0 - nobsq_nh = 0 - nobsq_sh = 0 - nobsq_tr = 0 - nobsq_tot=0 - nobsoz_nh = 0 - nobsoz_sh = 0 - nobsoz_tr = 0 - nobsoz_tot=0 - nobswnd_nh = 0 - nobswnd_sh = 0 - nobswnd_tr = 0 - nobswnd_tot=0 - nobspw_nh = 0 - nobspw_sh = 0 - nobspw_tr = 0 - nobspw_tot=0 - nobsgps_nh = 0 - nobsgps_sh = 0 - nobsgps_tr = 0 - nobsgps_tot=0 - nobsaod_nh = 0 - nobsaod_sh = 0 - nobsaod_tr = 0 - nobsaod_tot=0 - nobsspd_nh = 0 - nobsspd_sh = 0 - nobsspd_tr = 0 - nobsspd_tot=0 - nobssat_tot=0 - ntotassim=0 - sumpsjo =0.0 - sumtjo =0.0 - sumwndjo=0.0 - sumqjo =0.0 - sumspdjo=0.0 - sumpwjo =0.0 - sumgpsjo=0.0 - sumaodjo=0.0 - sumozjo =0.0 - sumjo_tot=0.0 - sumps_nh =0.0;sumps_tr =0.0;sumps_sh =0.0 - sumq_nh =0.0;sumq_tr =0.0;sumq_sh =0.0 - sumt_nh =0.0;sumt_tr =0.0;sumt_sh =0.0 - sumpw_nh =0.0;sumpw_tr =0.0;sumpw_sh =0.0 - sumaod_nh=0.0;sumaod_tr=0.0;sumaod_sh=0.0 - sumgps_nh=0.0;sumgps_tr=0.0;sumgps_sh=0.0 - sumspd_nh=0.0;sumspd_tr=0.0;sumspd_sh=0.0 - sumwnd_nh=0.0;sumwnd_tr=0.0;sumwnd_sh=0.0 - sumoz_nh =0.0;sumoz_tr =0.0;sumoz_sh =0.0 -if (nobs_conv+nobs_oz > 0) then - do nob=1,nobs_conv+nobs_oz - if(stats_usedob_only) then - if(iused(nob)==0) cycle ! do not include not assim obs in statistics - endif - if(oberrvar(nob) < 1.e10_r_single)then - if (obtype(nob)(1:3) == ' ps') then - call obstats(obfit(nob),oberrvar(nob),oberrvar_orig(nob),& - obsprd(nob),obloclat(nob),& - sumps_nh,biasps_nh,sumps_spread_nh,sumps_oberr_nh,nobsps_nh,sumpsjo_nh,& - sumps_sh,biasps_sh,sumps_spread_sh,sumps_oberr_sh,nobsps_sh,sumpsjo_sh,& - sumps_tr,biasps_tr,sumps_spread_tr,sumps_oberr_tr,nobsps_tr,sumpsjo_tr) - nobsps_tot = nobsps_nh + nobsps_sh + nobsps_tr - sumpsjo = sumpsjo_nh + sumpsjo_sh + sumpsjo_tr - ntotassim=ntotassim+1 - else if (obtype(nob)(1:3) == ' t' .and. stattype(nob) /= 121) then - call obstats(obfit(nob),oberrvar(nob),oberrvar_orig(nob),& - obsprd(nob),obloclat(nob),& - sumt_nh,biast_nh,sumt_spread_nh,sumt_oberr_nh,nobst_nh,sumtjo_nh,& - sumt_sh,biast_sh,sumt_spread_sh,sumt_oberr_sh,nobst_sh,sumtjo_sh,& - sumt_tr,biast_tr,sumt_spread_tr,sumt_oberr_tr,nobst_tr,sumtjo_tr) - nobst_tot = nobst_nh + nobst_sh + nobst_tr - sumtjo = sumtjo_nh + sumtjo_sh + sumtjo_tr - ntotassim=ntotassim+1 - ! all winds - else if (obtype(nob)(1:3) == ' u' .or. obtype(nob)(1:3) == ' v') then - ! only in-situ winds (no sat winds) - !else if (obtype(nob)(1:3) == ' u' .or. obtype(nob)(1:3) == ' v' .and. & - ! ((stattype(nob) >= 280 .and. stattype(nob) <= 282) .or. & - ! (stattype(nob) >= 220 .and. stattype(nob) <= 221) .or. & - ! (stattype(nob) >= 230 .and. stattype(nob) <= 235) ) then - call obstats(obfit(nob),oberrvar(nob),oberrvar_orig(nob),& - obsprd(nob),obloclat(nob),& - sumwnd_nh,biaswnd_nh,sumwnd_spread_nh,sumwnd_oberr_nh,nobswnd_nh,sumwndjo_nh,& - sumwnd_sh,biaswnd_sh,sumwnd_spread_sh,sumwnd_oberr_sh,nobswnd_sh,sumwndjo_sh,& - sumwnd_tr,biaswnd_tr,sumwnd_spread_tr,sumwnd_oberr_tr,nobswnd_tr,sumwndjo_tr) - nobswnd_tot = nobswnd_nh + nobswnd_sh + nobswnd_tr - sumwndjo = sumwndjo_nh + sumwndjo_sh + sumwndjo_tr - ntotassim=ntotassim+1 - else if (obtype(nob)(1:3) == ' q') then - call obstats(obfit(nob),oberrvar(nob),oberrvar_orig(nob),& - obsprd(nob),obloclat(nob),& - sumq_nh,biasq_nh,sumq_spread_nh,sumq_oberr_nh,nobsq_nh,sumqjo_nh,& - sumq_sh,biasq_sh,sumq_spread_sh,sumq_oberr_sh,nobsq_sh,sumqjo_sh,& - sumq_tr,biasq_tr,sumq_spread_tr,sumq_oberr_tr,nobsq_tr,sumqjo_tr) - nobsq_tot = nobsq_nh + nobsq_sh + nobsq_tr - sumqjo = sumqjo_nh + sumqjo_sh + sumqjo_tr - ntotassim=ntotassim+1 - else if (obtype(nob)(1:3) == 'spd') then - call obstats(obfit(nob),oberrvar(nob),oberrvar_orig(nob),& - obsprd(nob),obloclat(nob),& - sumspd_nh,biasspd_nh,sumspd_spread_nh,sumspd_oberr_nh,nobsspd_nh,sumspdjo_nh,& - sumspd_sh,biasspd_sh,sumspd_spread_sh,sumspd_oberr_sh,nobsspd_sh,sumspdjo_sh,& - sumspd_tr,biasspd_tr,sumspd_spread_tr,sumspd_oberr_tr,nobsspd_tr,sumspdjo_tr) - nobsspd_tot = nobsspd_nh + nobsspd_sh + nobsspd_tr - sumspdjo = sumspdjo_nh + sumspdjo_sh + sumspdjo_tr - ntotassim=ntotassim+1 - else if (obtype(nob)(1:3) == 'gps') then - call obstats(obfit(nob),oberrvar(nob),oberrvar_orig(nob),& - obsprd(nob),obloclat(nob),& - sumgps_nh,biasgps_nh,sumgps_spread_nh,sumgps_oberr_nh,nobsgps_nh,sumgpsjo_nh,& - sumgps_sh,biasgps_sh,sumgps_spread_sh,sumgps_oberr_sh,nobsgps_sh,sumgpsjo_sh,& - sumgps_tr,biasgps_tr,sumgps_spread_tr,sumgps_oberr_tr,nobsgps_tr,sumgpsjo_tr) - nobsgps_tot = nobsgps_nh + nobsgps_sh + nobsgps_tr - sumgpsjo = sumgpsjo_nh + sumgpsjo_sh + sumgpsjo_tr - ntotassim=ntotassim+1 - else if (obtype(nob)(1:3) == ' pw') then - call obstats(obfit(nob),oberrvar(nob),oberrvar_orig(nob),& - obsprd(nob),obloclat(nob),& - sumpw_nh,biaspw_nh,sumpw_spread_nh,sumpw_oberr_nh,nobspw_nh,sumpwjo_nh,& - sumpw_sh,biaspw_sh,sumpw_spread_sh,sumpw_oberr_sh,nobspw_sh,sumpwjo_sh,& - sumpw_tr,biaspw_tr,sumpw_spread_tr,sumpw_oberr_tr,nobspw_tr,sumpwjo_tr) - nobspw_tot = nobspw_nh + nobspw_sh + nobspw_tr - sumpwjo = sumpwjo_nh + sumpwjo_sh + sumpwjo_tr - ntotassim=ntotassim+1 - else if (nob > nobs_conv .and. nob < nobs_conv+nobs_oz) then - call obstats(obfit(nob),oberrvar(nob),oberrvar_orig(nob),& - obsprd(nob),obloclat(nob),& - sumoz_nh,biasoz_nh,sumoz_spread_nh,sumoz_oberr_nh,nobsoz_nh,sumozjo_nh,& - sumoz_sh,biasoz_sh,sumoz_spread_sh,sumoz_oberr_sh,nobsoz_sh,sumozjo_sh,& - sumoz_tr,biasoz_tr,sumoz_spread_tr,sumoz_oberr_tr,nobsoz_tr,sumozjo_tr) - nobsoz_tot = nobsoz_nh + nobsoz_sh + nobsoz_tr - sumozjo= sumozjo_nh + sumozjo_sh + sumozjo_tr - ntotassim=ntotassim+1 - end if - end if - end do ! loop over non-radiance obs - do nob=nobs_conv+nobs_oz+nobs_sat+1,size(obtype) - if(stats_usedob_only) then - if(iused(nob)==0) cycle ! do not include not assim obs in statistics - endif - if(oberrvar(nob) < 1.e10_r_kind)then - if (obtype(nob)(1:3) == 'aod') then - call obstats(obfit(nob),oberrvar(nob),oberrvar_orig(nob),& - obsprd(nob),obloclat(nob),& - sumaod_nh,biasaod_nh,sumaod_spread_nh,sumaod_oberr_nh,nobsaod_nh,sumaodjo_nh,& - sumaod_sh,biasaod_sh,sumaod_spread_sh,sumaod_oberr_sh,nobsaod_sh,sumaodjo_sh,& - sumaod_tr,biasaod_tr,sumaod_spread_tr,sumaod_oberr_tr,nobsaod_tr,sumaodjo_tr) - nobsaod_tot = nobsaod_nh + nobsaod_sh + nobsaod_tr - sumaodjo = sumaodjo_nh + sumaodjo_sh + sumaodjo_tr - ntotassim=ntotassim+1 - endif - endif - end do ! loop over aod observations -!--> print innovation statistics for subset of conventional data. - print *,'conventional obs' - print *,'region, obtype, nobs, bias, innov stdev, sqrt(S+R), sqrt(S), sqrt(R), Jo:' - call printstats(' all ps',sumps_nh,biasps_nh,sumps_spread_nh,sumps_oberr_nh,sumpsjo_nh,nobsps_nh,& - sumps_sh,biasps_sh,sumps_spread_sh,sumps_oberr_sh,sumpsjo_sh,nobsps_sh,& - sumps_tr,biasps_tr,sumps_spread_tr,sumps_oberr_tr,sumpsjo_tr,nobsps_tr) - call printstats(' all t',sumt_nh,biast_nh,sumt_spread_nh,sumt_oberr_nh,sumtjo_nh,nobst_nh,& - sumt_sh,biast_sh,sumt_spread_sh,sumt_oberr_sh,sumtjo_sh,nobst_sh,& - sumt_tr,biast_tr,sumt_spread_tr,sumt_oberr_tr,sumtjo_tr,nobst_tr) - call printstats(' all uv',sumwnd_nh,biaswnd_nh,sumwnd_spread_nh,sumwnd_oberr_nh,sumwndjo_nh,nobswnd_nh,& - sumwnd_sh,biaswnd_sh,sumwnd_spread_sh,sumwnd_oberr_sh,sumwndjo_sh,nobswnd_sh,& - sumwnd_tr,biaswnd_tr,sumwnd_spread_tr,sumwnd_oberr_tr,sumwndjo_tr,nobswnd_tr) - call printstats(' all q',sumq_nh,biasq_nh,sumq_spread_nh,sumq_oberr_nh,sumqjo_nh,nobsq_nh,& - sumq_sh,biasq_sh,sumq_spread_sh,sumq_oberr_sh,sumqjo_sh,nobsq_sh,& - sumq_tr,biasq_tr,sumq_spread_tr,sumq_oberr_tr,sumqjo_tr,nobsq_tr) - call printstats(' all spd',sumspd_nh,biasspd_nh,sumspd_spread_nh,sumspd_oberr_nh,sumspdjo_nh,nobsspd_nh,& - sumspd_sh,biasspd_sh,sumspd_spread_sh,sumspd_oberr_sh,sumspdjo_sh,nobsspd_sh,& - sumspd_tr,biasspd_tr,sumspd_spread_tr,sumspd_oberr_tr,sumspdjo_tr,nobsspd_tr) - call printstats(' all pw',sumpw_nh,biasq_nh,sumpw_spread_nh,sumpw_oberr_nh,sumpwjo_nh,nobspw_nh,& - sumpw_sh,biaspw_sh,sumpw_spread_sh,sumpw_oberr_sh,sumpwjo_sh,nobspw_sh,& - sumpw_tr,biaspw_tr,sumpw_spread_tr,sumpw_oberr_tr,sumpwjo_tr,nobspw_tr) - call printstats(' all gps',sumgps_nh,biasq_nh,sumgps_spread_nh,sumgps_oberr_nh,sumgpsjo_nh,nobsgps_nh,& - sumgps_sh,biasgps_sh,sumgps_spread_sh,sumgps_oberr_sh,sumgpsjo_sh,nobsgps_sh,& - sumgps_tr,biasgps_tr,sumgps_spread_tr,sumgps_oberr_tr,sumgpsjo_tr,nobsgps_tr) - call printstats(' all aod',sumaod_nh,biasq_nh,sumaod_spread_nh,sumaod_oberr_nh,sumaodjo_nh,nobsaod_nh,& - sumaod_sh,biasaod_sh,sumaod_spread_sh,sumaod_oberr_sh,sumaodjo_sh,nobsaod_sh,& - sumaod_tr,biasaod_tr,sumaod_spread_tr,sumaod_oberr_tr,sumaodjo_tr,nobsaod_tr) - call printstats(' sbuv2 oz',sumoz_nh,biasoz_nh,sumoz_spread_nh,sumoz_oberr_nh,sumozjo_nh,nobsoz_nh,& - sumoz_sh,biasoz_sh,sumoz_spread_sh,sumoz_oberr_sh,sumozjo_sh,nobsoz_sh,& - sumoz_tr,biasoz_tr,sumoz_spread_tr,sumoz_oberr_tr,sumozjo_tr,nobsoz_tr) -end if ! nobs_conv+nobs_oz > 0 + subroutine print_innovstats(obfit,obsprd) + real(r_single), intent(in) :: obfit(nobstot), obsprd(nobstot) + integer(i_kind) nobst_nh,nobst_sh,nobst_tr,& + nobspw_nh,nobspw_sh,nobspw_tr,& + nobsspd_nh,nobsspd_sh,nobsspd_tr,& + nobsgps_nh,nobsgps_sh,nobsgps_tr,& + nobsaod_nh,nobsaod_sh,nobsaod_tr,& + nobsq_nh,nobsq_sh,nobsq_tr,nobswnd_nh,nobswnd_sh,nobswnd_tr,& + nobsoz_nh,nobsoz_sh,nobsoz_tr,nobsps_sh,nobsps_nh,nobsps_tr,nob, & + nobsps_tot,nobst_tot,nobswnd_tot,nobsq_tot,nobsoz_tot,nobspw_tot,& + nobsspd_tot,nobsgps_tot,nobsaod_tot + integer(i_kind) nobssat_tot,ntotassim + real(r_single) sumps_nh,biasps_nh,sumps_sh,biasps_sh,& + sumps_tr,biasps_tr,& + sumps_spread_nh,sumps_spread_sh,sumps_spread_tr,sumps_oberr_nh,& + sumps_oberr_sh,sumps_oberr_tr,& + sumt_nh,biast_nh,sumt_spread_nh,sumt_oberr_nh,& + sumt_sh,biast_sh,sumt_spread_sh,sumt_oberr_sh,& + sumt_tr,biast_tr,sumt_spread_tr,sumt_oberr_tr,& + sumq_nh,biasq_nh,sumq_spread_nh,sumq_oberr_nh,& + sumq_sh,biasq_sh,sumq_spread_sh,sumq_oberr_sh,& + sumq_tr,biasq_tr,sumq_spread_tr,sumq_oberr_tr,& + sumspd_nh,biasspd_nh,sumspd_spread_nh,sumspd_oberr_nh,& + sumspd_sh,biasspd_sh,sumspd_spread_sh,sumspd_oberr_sh,& + sumspd_tr,biasspd_tr,sumspd_spread_tr,sumspd_oberr_tr,& + sumgps_nh,biasgps_nh,sumgps_spread_nh,sumgps_oberr_nh,& + sumgps_sh,biasgps_sh,sumgps_spread_sh,sumgps_oberr_sh,& + sumgps_tr,biasgps_tr,sumgps_spread_tr,sumgps_oberr_tr,& + sumaod_nh,biasaod_nh,sumaod_spread_nh,sumaod_oberr_nh,& + sumaod_sh,biasaod_sh,sumaod_spread_sh,sumaod_oberr_sh,& + sumaod_tr,biasaod_tr,sumaod_spread_tr,sumaod_oberr_tr,& + sumpw_nh,biaspw_nh,sumpw_spread_nh,sumpw_oberr_nh,& + sumpw_sh,biaspw_sh,sumpw_spread_sh,sumpw_oberr_sh,& + sumpw_tr,biaspw_tr,sumpw_spread_tr,sumpw_oberr_tr,& + sumoz_nh,biasoz_nh,sumoz_spread_nh,sumoz_oberr_nh,& + sumoz_sh,biasoz_sh,sumoz_spread_sh,sumoz_oberr_sh,& + sumoz_tr,biasoz_tr,sumoz_spread_tr,sumoz_oberr_tr,& + sumwnd_nh,biaswnd_nh,sumwnd_spread_nh,sumwnd_oberr_nh,& + sumwnd_sh,biaswnd_sh,sumwnd_spread_sh,sumwnd_oberr_sh,& + sumwnd_tr,biaswnd_tr,sumwnd_spread_tr,sumwnd_oberr_tr + real(r_single) sumpsjo_nh,sumpsjo_sh,sumpsjo_tr,sumpsjo + real(r_single) sumtjo_nh,sumtjo_sh,sumtjo_tr,sumtjo + real(r_single) sumwndjo_nh,sumwndjo_sh,sumwndjo_tr,sumwndjo + real(r_single) sumqjo_nh,sumqjo_sh,sumqjo_tr,sumqjo + real(r_single) sumspdjo_nh,sumspdjo_sh,sumspdjo_tr,sumspdjo + real(r_single) sumgpsjo_nh,sumgpsjo_sh,sumgpsjo_tr,sumgpsjo + real(r_single) sumaodjo_nh,sumaodjo_sh,sumaodjo_tr,sumaodjo + real(r_single) sumpwjo_nh,sumpwjo_sh,sumpwjo_tr,sumpwjo + real(r_single) sumozjo_nh,sumozjo_sh,sumozjo_tr,sumozjo + real(r_single) sumjo_tot + ! stuff for computing sat data innovation stats. + real(r_single) sumsprd_sat(jpch_rad),sumerr_sat(jpch_rad), & + sumfit_sat(jpch_rad),sumfitsq_sat(jpch_rad),sumjo_sat(jpch_rad),& + predicted_innov,innov + integer(i_kind) nob_sat(jpch_rad),nchan,nn + real(r_single) :: denom + !==> stats for conventional + ozone obs. + !==> pre-process obs, obs metadata. + nobsps_nh = 0 + nobsps_sh = 0 + nobsps_tr = 0 + nobsps_tot= 0 + nobst_nh = 0 + nobst_sh = 0 + nobst_tr = 0 + nobst_tot=0 + nobsq_nh = 0 + nobsq_sh = 0 + nobsq_tr = 0 + nobsq_tot=0 + nobsoz_nh = 0 + nobsoz_sh = 0 + nobsoz_tr = 0 + nobsoz_tot=0 + nobswnd_nh = 0 + nobswnd_sh = 0 + nobswnd_tr = 0 + nobswnd_tot=0 + nobspw_nh = 0 + nobspw_sh = 0 + nobspw_tr = 0 + nobspw_tot=0 + nobsgps_nh = 0 + nobsgps_sh = 0 + nobsgps_tr = 0 + nobsgps_tot=0 + nobsaod_nh = 0 + nobsaod_sh = 0 + nobsaod_tr = 0 + nobsaod_tot=0 + nobsspd_nh = 0 + nobsspd_sh = 0 + nobsspd_tr = 0 + nobsspd_tot=0 + nobssat_tot=0 + ntotassim=0 + sumpsjo =0.0 + sumtjo =0.0 + sumwndjo=0.0 + sumqjo =0.0 + sumspdjo=0.0 + sumpwjo =0.0 + sumgpsjo=0.0 + sumaodjo=0.0 + sumozjo =0.0 + sumjo_tot=0.0 + sumps_nh =0.0;sumps_tr =0.0;sumps_sh =0.0 + sumq_nh =0.0;sumq_tr =0.0;sumq_sh =0.0 + sumt_nh =0.0;sumt_tr =0.0;sumt_sh =0.0 + sumpw_nh =0.0;sumpw_tr =0.0;sumpw_sh =0.0 + sumaod_nh=0.0;sumaod_tr=0.0;sumaod_sh=0.0 + sumgps_nh=0.0;sumgps_tr=0.0;sumgps_sh=0.0 + sumspd_nh=0.0;sumspd_tr=0.0;sumspd_sh=0.0 + sumwnd_nh=0.0;sumwnd_tr=0.0;sumwnd_sh=0.0 + sumoz_nh =0.0;sumoz_tr =0.0;sumoz_sh =0.0 + if (nobs_conv+nobs_oz > 0) then + do nob=1,nobs_conv+nobs_oz + if(stats_usedob_only) then + if(iused(nob)==0) cycle ! do not include not assim obs in statistics + endif + if(oberrvar(nob) < 1.e10_r_single)then + if (obtype(nob)(1:3) == ' ps') then + call obstats(obfit(nob),oberrvar(nob),oberrvar_orig(nob),& + obsprd(nob),obloclat(nob),& + sumps_nh,biasps_nh,sumps_spread_nh,sumps_oberr_nh,nobsps_nh,sumpsjo_nh,& + sumps_sh,biasps_sh,sumps_spread_sh,sumps_oberr_sh,nobsps_sh,sumpsjo_sh,& + sumps_tr,biasps_tr,sumps_spread_tr,sumps_oberr_tr,nobsps_tr,sumpsjo_tr) + nobsps_tot = nobsps_nh + nobsps_sh + nobsps_tr + sumpsjo = sumpsjo_nh + sumpsjo_sh + sumpsjo_tr + ntotassim=ntotassim+1 + else if (obtype(nob)(1:3) == ' t' .and. stattype(nob) /= 121) then + call obstats(obfit(nob),oberrvar(nob),oberrvar_orig(nob),& + obsprd(nob),obloclat(nob),& + sumt_nh,biast_nh,sumt_spread_nh,sumt_oberr_nh,nobst_nh,sumtjo_nh,& + sumt_sh,biast_sh,sumt_spread_sh,sumt_oberr_sh,nobst_sh,sumtjo_sh,& + sumt_tr,biast_tr,sumt_spread_tr,sumt_oberr_tr,nobst_tr,sumtjo_tr) + nobst_tot = nobst_nh + nobst_sh + nobst_tr + sumtjo = sumtjo_nh + sumtjo_sh + sumtjo_tr + ntotassim=ntotassim+1 + ! all winds + else if (obtype(nob)(1:3) == ' u' .or. obtype(nob)(1:3) == ' v') then + ! only in-situ winds (no sat winds) + !else if (obtype(nob)(1:3) == ' u' .or. obtype(nob)(1:3) == ' v' .and. & + ! ((stattype(nob) >= 280 .and. stattype(nob) <= 282) .or. & + ! (stattype(nob) >= 220 .and. stattype(nob) <= 221) .or. & + ! (stattype(nob) >= 230 .and. stattype(nob) <= 235) ) then + call obstats(obfit(nob),oberrvar(nob),oberrvar_orig(nob),& + obsprd(nob),obloclat(nob),& + sumwnd_nh,biaswnd_nh,sumwnd_spread_nh,sumwnd_oberr_nh,nobswnd_nh,sumwndjo_nh,& + sumwnd_sh,biaswnd_sh,sumwnd_spread_sh,sumwnd_oberr_sh,nobswnd_sh,sumwndjo_sh,& + sumwnd_tr,biaswnd_tr,sumwnd_spread_tr,sumwnd_oberr_tr,nobswnd_tr,sumwndjo_tr) + nobswnd_tot = nobswnd_nh + nobswnd_sh + nobswnd_tr + sumwndjo = sumwndjo_nh + sumwndjo_sh + sumwndjo_tr + ntotassim=ntotassim+1 + else if (obtype(nob)(1:3) == ' q') then + call obstats(obfit(nob),oberrvar(nob),oberrvar_orig(nob),& + obsprd(nob),obloclat(nob),& + sumq_nh,biasq_nh,sumq_spread_nh,sumq_oberr_nh,nobsq_nh,sumqjo_nh,& + sumq_sh,biasq_sh,sumq_spread_sh,sumq_oberr_sh,nobsq_sh,sumqjo_sh,& + sumq_tr,biasq_tr,sumq_spread_tr,sumq_oberr_tr,nobsq_tr,sumqjo_tr) + nobsq_tot = nobsq_nh + nobsq_sh + nobsq_tr + sumqjo = sumqjo_nh + sumqjo_sh + sumqjo_tr + ntotassim=ntotassim+1 + else if (obtype(nob)(1:3) == 'spd') then + call obstats(obfit(nob),oberrvar(nob),oberrvar_orig(nob),& + obsprd(nob),obloclat(nob),& + sumspd_nh,biasspd_nh,sumspd_spread_nh,sumspd_oberr_nh,nobsspd_nh,sumspdjo_nh,& + sumspd_sh,biasspd_sh,sumspd_spread_sh,sumspd_oberr_sh,nobsspd_sh,sumspdjo_sh,& + sumspd_tr,biasspd_tr,sumspd_spread_tr,sumspd_oberr_tr,nobsspd_tr,sumspdjo_tr) + nobsspd_tot = nobsspd_nh + nobsspd_sh + nobsspd_tr + sumspdjo = sumspdjo_nh + sumspdjo_sh + sumspdjo_tr + ntotassim=ntotassim+1 + else if (obtype(nob)(1:3) == 'gps') then + call obstats(obfit(nob),oberrvar(nob),oberrvar_orig(nob),& + obsprd(nob),obloclat(nob),& + sumgps_nh,biasgps_nh,sumgps_spread_nh,sumgps_oberr_nh,nobsgps_nh,sumgpsjo_nh,& + sumgps_sh,biasgps_sh,sumgps_spread_sh,sumgps_oberr_sh,nobsgps_sh,sumgpsjo_sh,& + sumgps_tr,biasgps_tr,sumgps_spread_tr,sumgps_oberr_tr,nobsgps_tr,sumgpsjo_tr) + nobsgps_tot = nobsgps_nh + nobsgps_sh + nobsgps_tr + sumgpsjo = sumgpsjo_nh + sumgpsjo_sh + sumgpsjo_tr + ntotassim=ntotassim+1 + else if (obtype(nob)(1:3) == ' pw') then + call obstats(obfit(nob),oberrvar(nob),oberrvar_orig(nob),& + obsprd(nob),obloclat(nob),& + sumpw_nh,biaspw_nh,sumpw_spread_nh,sumpw_oberr_nh,nobspw_nh,sumpwjo_nh,& + sumpw_sh,biaspw_sh,sumpw_spread_sh,sumpw_oberr_sh,nobspw_sh,sumpwjo_sh,& + sumpw_tr,biaspw_tr,sumpw_spread_tr,sumpw_oberr_tr,nobspw_tr,sumpwjo_tr) + nobspw_tot = nobspw_nh + nobspw_sh + nobspw_tr + sumpwjo = sumpwjo_nh + sumpwjo_sh + sumpwjo_tr + ntotassim=ntotassim+1 + else if (nob > nobs_conv .and. nob < nobs_conv+nobs_oz) then + call obstats(obfit(nob),oberrvar(nob),oberrvar_orig(nob),& + obsprd(nob),obloclat(nob),& + sumoz_nh,biasoz_nh,sumoz_spread_nh,sumoz_oberr_nh,nobsoz_nh,sumozjo_nh,& + sumoz_sh,biasoz_sh,sumoz_spread_sh,sumoz_oberr_sh,nobsoz_sh,sumozjo_sh,& + sumoz_tr,biasoz_tr,sumoz_spread_tr,sumoz_oberr_tr,nobsoz_tr,sumozjo_tr) + nobsoz_tot = nobsoz_nh + nobsoz_sh + nobsoz_tr + sumozjo= sumozjo_nh + sumozjo_sh + sumozjo_tr + ntotassim=ntotassim+1 + end if + end if + end do ! loop over non-radiance obs + do nob=nobs_conv+nobs_oz+nobs_sat+1,size(obtype) + if(stats_usedob_only) then + if(iused(nob)==0) cycle ! do not include not assim obs in statistics + endif + if(oberrvar(nob) < 1.e10_r_kind)then + if (obtype(nob)(1:3) == 'aod') then + call obstats(obfit(nob),oberrvar(nob),oberrvar_orig(nob),& + obsprd(nob),obloclat(nob),& + sumaod_nh,biasaod_nh,sumaod_spread_nh,sumaod_oberr_nh,nobsaod_nh,sumaodjo_nh,& + sumaod_sh,biasaod_sh,sumaod_spread_sh,sumaod_oberr_sh,nobsaod_sh,sumaodjo_sh,& + sumaod_tr,biasaod_tr,sumaod_spread_tr,sumaod_oberr_tr,nobsaod_tr,sumaodjo_tr) + nobsaod_tot = nobsaod_nh + nobsaod_sh + nobsaod_tr + sumaodjo = sumaodjo_nh + sumaodjo_sh + sumaodjo_tr + ntotassim=ntotassim+1 + endif + endif + end do ! loop over aod observations + !--> print innovation statistics for subset of conventional data. + print *,'conventional obs' + print *,'region, obtype, nobs, bias, innov stdev, sqrt(S+R), sqrt(S), sqrt(R), Jo:' + call printstats(' all ps',sumps_nh,biasps_nh,sumps_spread_nh,sumps_oberr_nh,sumpsjo_nh,nobsps_nh,& + sumps_sh,biasps_sh,sumps_spread_sh,sumps_oberr_sh,sumpsjo_sh,nobsps_sh,& + sumps_tr,biasps_tr,sumps_spread_tr,sumps_oberr_tr,sumpsjo_tr,nobsps_tr) + call printstats(' all t',sumt_nh,biast_nh,sumt_spread_nh,sumt_oberr_nh,sumtjo_nh,nobst_nh,& + sumt_sh,biast_sh,sumt_spread_sh,sumt_oberr_sh,sumtjo_sh,nobst_sh,& + sumt_tr,biast_tr,sumt_spread_tr,sumt_oberr_tr,sumtjo_tr,nobst_tr) + call printstats(' all uv',sumwnd_nh,biaswnd_nh,sumwnd_spread_nh,sumwnd_oberr_nh,sumwndjo_nh,nobswnd_nh,& + sumwnd_sh,biaswnd_sh,sumwnd_spread_sh,sumwnd_oberr_sh,sumwndjo_sh,nobswnd_sh,& + sumwnd_tr,biaswnd_tr,sumwnd_spread_tr,sumwnd_oberr_tr,sumwndjo_tr,nobswnd_tr) + call printstats(' all q',sumq_nh,biasq_nh,sumq_spread_nh,sumq_oberr_nh,sumqjo_nh,nobsq_nh,& + sumq_sh,biasq_sh,sumq_spread_sh,sumq_oberr_sh,sumqjo_sh,nobsq_sh,& + sumq_tr,biasq_tr,sumq_spread_tr,sumq_oberr_tr,sumqjo_tr,nobsq_tr) + call printstats(' all spd',sumspd_nh,biasspd_nh,sumspd_spread_nh,sumspd_oberr_nh,sumspdjo_nh,nobsspd_nh,& + sumspd_sh,biasspd_sh,sumspd_spread_sh,sumspd_oberr_sh,sumspdjo_sh,nobsspd_sh,& + sumspd_tr,biasspd_tr,sumspd_spread_tr,sumspd_oberr_tr,sumspdjo_tr,nobsspd_tr) + call printstats(' all pw',sumpw_nh,biasq_nh,sumpw_spread_nh,sumpw_oberr_nh,sumpwjo_nh,nobspw_nh,& + sumpw_sh,biaspw_sh,sumpw_spread_sh,sumpw_oberr_sh,sumpwjo_sh,nobspw_sh,& + sumpw_tr,biaspw_tr,sumpw_spread_tr,sumpw_oberr_tr,sumpwjo_tr,nobspw_tr) + call printstats(' all gps',sumgps_nh,biasq_nh,sumgps_spread_nh,sumgps_oberr_nh,sumgpsjo_nh,nobsgps_nh,& + sumgps_sh,biasgps_sh,sumgps_spread_sh,sumgps_oberr_sh,sumgpsjo_sh,nobsgps_sh,& + sumgps_tr,biasgps_tr,sumgps_spread_tr,sumgps_oberr_tr,sumgpsjo_tr,nobsgps_tr) + call printstats(' all aod',sumaod_nh,biasq_nh,sumaod_spread_nh,sumaod_oberr_nh,sumaodjo_nh,nobsaod_nh,& + sumaod_sh,biasaod_sh,sumaod_spread_sh,sumaod_oberr_sh,sumaodjo_sh,nobsaod_sh,& + sumaod_tr,biasaod_tr,sumaod_spread_tr,sumaod_oberr_tr,sumaodjo_tr,nobsaod_tr) + if(nobs_oz>0) then + call printstats(' sbuv2 oz',sumoz_nh,biasoz_nh,sumoz_spread_nh,sumoz_oberr_nh,sumozjo_nh,nobsoz_nh,& + sumoz_sh,biasoz_sh,sumoz_spread_sh,sumoz_oberr_sh,sumozjo_sh,nobsoz_sh,& + sumoz_tr,biasoz_tr,sumoz_spread_tr,sumoz_oberr_tr,sumozjo_tr,nobsoz_tr) + endif + end if ! nobs_conv+nobs_oz > 0 -if (size(obtype)-(nobs_conv+nobs_oz+nobs_sat+1) > 0) then - do nob=nobs_conv+nobs_oz+nobs_sat+1,size(obtype) - if(stats_usedob_only) then - if(iused(nob)==0) cycle ! do not include not assim obs in statistics - endif - if(oberrvar(nob) < 1.e10_r_kind)then - if (obtype(nob)(1:3) == 'aod') then - call obstats(obfit(nob),oberrvar(nob),oberrvar_orig(nob),& - obsprd(nob),obloclat(nob),& - sumaod_nh,biasaod_nh,sumaod_spread_nh,sumaod_oberr_nh,nobsaod_nh,sumaodjo_nh,& - sumaod_sh,biasaod_sh,sumaod_spread_sh,sumaod_oberr_sh,nobsaod_sh,sumaodjo_sh,& - sumaod_tr,biasaod_tr,sumaod_spread_tr,sumaod_oberr_tr,nobsaod_tr,sumaodjo_tr) - nobsaod_tot = nobsaod_nh + nobsaod_sh + nobsaod_tr - sumaodjo = sumaodjo_nh + sumaodjo_sh + sumaodjo_tr - ntotassim=ntotassim+1 - endif - endif - end do ! loop over aod observations - call printstats(' all aod',sumaod_nh,biasq_nh,sumaod_spread_nh,sumaod_oberr_nh,sumaodjo_nh,nobsaod_nh,& - sumaod_sh,biasaod_sh,sumaod_spread_sh,sumaod_oberr_sh,sumaodjo_sh,nobsaod_sh,& - sumaod_tr,biasaod_tr,sumaod_spread_tr,sumaod_oberr_tr,sumaodjo_tr,nobsaod_tr) -endif + if (size(obtype)-(nobs_conv+nobs_oz+nobs_sat+1) > 0) then + do nob=nobs_conv+nobs_oz+nobs_sat+1,size(obtype) + if(stats_usedob_only) then + if(iused(nob)==0) cycle ! do not include not assim obs in statistics + endif + if(oberrvar(nob) < 1.e10_r_kind)then + if (obtype(nob)(1:3) == 'aod') then + call obstats(obfit(nob),oberrvar(nob),oberrvar_orig(nob),& + obsprd(nob),obloclat(nob),& + sumaod_nh,biasaod_nh,sumaod_spread_nh,sumaod_oberr_nh,nobsaod_nh,sumaodjo_nh,& + sumaod_sh,biasaod_sh,sumaod_spread_sh,sumaod_oberr_sh,nobsaod_sh,sumaodjo_sh,& + sumaod_tr,biasaod_tr,sumaod_spread_tr,sumaod_oberr_tr,nobsaod_tr,sumaodjo_tr) + nobsaod_tot = nobsaod_nh + nobsaod_sh + nobsaod_tr + sumaodjo = sumaodjo_nh + sumaodjo_sh + sumaodjo_tr + ntotassim=ntotassim+1 + endif + endif + end do ! loop over aod observations + call printstats(' all aod',sumaod_nh,biasq_nh,sumaod_spread_nh,sumaod_oberr_nh,sumaodjo_nh,nobsaod_nh,& + sumaod_sh,biasaod_sh,sumaod_spread_sh,sumaod_oberr_sh,sumaodjo_sh,nobsaod_sh,& + sumaod_tr,biasaod_tr,sumaod_spread_tr,sumaod_oberr_tr,sumaodjo_tr,nobsaod_tr) + endif -sumjo_tot = sumpsjo+sumtjo+sumwndjo+sumqjo+sumspdjo+sumpwjo+sumgpsjo+sumaodjo+sumozjo -!==> stats for satellite brightness temp obs (amsua only). - sumsprd_sat = zero - sumfit_sat = zero - sumerr_sat = zero - sumfitsq_sat = zero - sumjo_sat = zero - nob_sat = 0 -if (nobs_sat > 0) then - nn = 0 - do nob=nobs_conv+nobs_oz+1,nobs_conv+nobs_oz+nobs_sat - nn = nn + 1 - if(stats_usedob_only) then - if(iused(nob)==0) cycle ! do not include not assim obs in statistics - endif - nchan = indxsat(nn) - if (oberrvar(nob) < 1.e10_r_single .and. nchan > 0) then - sumsprd_sat(nchan)=sumsprd_sat(nchan)+obsprd(nob) - sumerr_sat(nchan)=sumerr_sat(nchan)+oberrvar_orig(nob) - sumfitsq_sat(nchan)=sumfitsq_sat(nchan)+obfit(nob)**2 - sumfit_sat(nchan)=sumfit_sat(nchan)+obfit(nob) - sumjo_sat(nchan)=sumjo_sat(nchan)+obfit(nob)**2/oberrvar(nob) - nob_sat(nchan)=nob_sat(nchan) + 1 - nobssat_tot=nobssat_tot+1 - ntotassim=ntotassim+1 - end if - end do ! loop over obs + sumjo_tot = sumpsjo+sumtjo+sumwndjo+sumqjo+sumspdjo+sumpwjo+sumgpsjo+sumaodjo+sumozjo + !==> stats for satellite brightness temp obs (amsua only). + sumsprd_sat = zero + sumfit_sat = zero + sumerr_sat = zero + sumfitsq_sat = zero + sumjo_sat = zero + nob_sat = 0 + if (nobs_sat > 0) then + nn = 0 + do nob=nobs_conv+nobs_oz+1,nobs_conv+nobs_oz+nobs_sat + nn = nn + 1 + if(stats_usedob_only) then + if(iused(nob)==0) cycle ! do not include not assim obs in statistics + endif + nchan = indxsat(nn) + if (oberrvar(nob) < 1.e10_r_single .and. nchan > 0) then + sumsprd_sat(nchan)=sumsprd_sat(nchan)+obsprd(nob) + sumerr_sat(nchan)=sumerr_sat(nchan)+oberrvar_orig(nob) + sumfitsq_sat(nchan)=sumfitsq_sat(nchan)+obfit(nob)**2 + sumfit_sat(nchan)=sumfit_sat(nchan)+obfit(nob) + sumjo_sat(nchan)=sumjo_sat(nchan)+obfit(nob)**2/oberrvar(nob) + nob_sat(nchan)=nob_sat(nchan) + 1 + nobssat_tot=nobssat_tot+1 + ntotassim=ntotassim+1 + end if + end do ! loop over obs - sumjo_tot = sumjo_tot + sum(sumjo_sat) + sumjo_tot = sumjo_tot + sum(sumjo_sat) -!--> print innovation statistics for amsu-a sat data.. - print *,'satellite brightness temp' - print *,'instrument, channel #, nobs, bias, innov stdev, sqrt(S+R), sqrt(S), sqrt(R), Jo:' - do nchan=1,jpch_rad - if (nob_sat(nchan) > 0) then - denom=one/real(nob_sat(nchan),r_single) - sumfit_sat(nchan) = sumfit_sat(nchan)*denom - sumfitsq_sat(nchan) = sumfitsq_sat(nchan)*denom - sumerr_sat(nchan) = sumerr_sat(nchan)*denom - sumsprd_sat(nchan) = sumsprd_sat(nchan)*denom - predicted_innov = sqrt(sumsprd_sat(nchan)+sumerr_sat(nchan)) - !innov = sqrt(sumfitsq_sat(nchan)-sumfit_sat(nchan)**2) - innov = sqrt(sumfitsq_sat(nchan)) - write(6,9805) trim(adjustl(nusis(nchan))),nuchan(nchan),nob_sat(nchan),sumfit_sat(nchan),innov,& - predicted_innov,sqrt(sumsprd_sat(nchan)),& - sqrt(sumerr_sat(nchan)),sumjo_sat(nchan) - end if - end do - write(6,9805) trim(adjustl('GL all sat')), 999, 999,sum(sumfit_sat),0.,& - 0.,0.,0.,sum(sumjo_sat) -9805 format(a20,i4,1x,i5,1p,6(1x,e10.3)) -end if !nobs_sat>0 + !--> print innovation statistics for amsu-a sat data.. + print *,'satellite brightness temp' + print *,'instrument, channel #, nobs, bias, innov stdev, sqrt(S+R), sqrt(S), sqrt(R), Jo:' + do nchan=1,jpch_rad + if (nob_sat(nchan) > 0) then + denom=one/real(nob_sat(nchan),r_single) + sumfit_sat(nchan) = sumfit_sat(nchan)*denom + sumfitsq_sat(nchan) = sumfitsq_sat(nchan)*denom + sumerr_sat(nchan) = sumerr_sat(nchan)*denom + sumsprd_sat(nchan) = sumsprd_sat(nchan)*denom + predicted_innov = sqrt(sumsprd_sat(nchan)+sumerr_sat(nchan)) + !innov = sqrt(sumfitsq_sat(nchan)-sumfit_sat(nchan)**2) + innov = sqrt(sumfitsq_sat(nchan)) + write(6,9805) trim(adjustl(nusis(nchan))),nuchan(nchan),nob_sat(nchan),sumfit_sat(nchan),innov,& + predicted_innov,sqrt(sumsprd_sat(nchan)),& + sqrt(sumerr_sat(nchan)),sumjo_sat(nchan) + end if + end do + write(6,9805) trim(adjustl('GL all sat')), 999, 999,sum(sumfit_sat),0.,& + 0.,0.,0.,sum(sumjo_sat) + 9805 format(a20,i4,1x,i5,1p,6(1x,e10.3)) + end if !nobs_sat>0 -write(6,9806)'Observation Type',' ','Nobs','Jo','Jo/n' -if(nobsps_tot >0) write(6,9807) "surface pressure",nobsps_tot,real(sumpsjo,r_kind),real(sumpsjo/nobsps_tot,r_kind) -if(nobst_tot >0) write(6,9807) "temperature",nobst_tot,real(sumtjo,r_kind),real(sumtjo/nobst_tot,r_kind) -if(nobswnd_tot>0) write(6,9807) "wind",nobswnd_tot,real(sumwndjo,r_kind),real(sumwndjo/nobswnd_tot,r_kind) -if(nobsq_tot >0) write(6,9807) "moisture",nobsq_tot,real(sumqjo,r_kind),real(sumqjo/nobsq_tot,r_kind) -if(nobspw_tot >0) write(6,9807) "precipitation",nobspw_tot,real(sumpwjo,r_kind),real(sumpwjo/nobspw_tot,r_kind) -if(nobsoz_tot >0) write(6,9807) "ozone",nobsoz_tot,real(sumozjo,r_kind),real(sumozjo/nobsoz_tot,r_kind) -if(nobsgps_tot>0) write(6,9807) "gps",nobsgps_tot,real(sumgpsjo,r_kind),real(sumgpsjo/nobsgps_tot,r_kind) -if(nobsaod_tot>0) write(6,9807) "aod",nobsaod_tot,real(sumaodjo,r_kind),real(sumaodjo/nobsaod_tot,r_kind) -if(nobssat_tot>0) write(6,9807) "radiance",nobssat_tot,real(sum(sumjo_sat),r_kind),real(sum(sumjo_sat)/nobssat_tot,r_kind) -if(ntotassim > 0) write(6,9807) "Jo Global",ntotassim,real(sumjo_tot,r_kind),& - real(sumjo_tot/(ntotassim),r_kind) -9806 format(a20,2x,a3,2x,a8,2x,a24,4x,a8) -9807 format(a20,2x,3x,2x,i8,2x,es24.16,2x,f10.3) + write(6,9806)'Observation Type',' ','Nobs','Jo','Jo/n' + if(nobsps_tot >0) write(6,9807) "surface pressure",nobsps_tot,real(sumpsjo,r_kind),real(sumpsjo/nobsps_tot,r_kind) + if(nobst_tot >0) write(6,9807) "temperature",nobst_tot,real(sumtjo,r_kind),real(sumtjo/nobst_tot,r_kind) + if(nobswnd_tot>0) write(6,9807) "wind",nobswnd_tot,real(sumwndjo,r_kind),real(sumwndjo/nobswnd_tot,r_kind) + if(nobsq_tot >0) write(6,9807) "moisture",nobsq_tot,real(sumqjo,r_kind),real(sumqjo/nobsq_tot,r_kind) + if(nobspw_tot >0) write(6,9807) "precipitation",nobspw_tot,real(sumpwjo,r_kind),real(sumpwjo/nobspw_tot,r_kind) + if(nobsoz_tot >0) write(6,9807) "ozone",nobsoz_tot,real(sumozjo,r_kind),real(sumozjo/nobsoz_tot,r_kind) + if(nobsgps_tot>0) write(6,9807) "gps",nobsgps_tot,real(sumgpsjo,r_kind),real(sumgpsjo/nobsgps_tot,r_kind) + if(nobsaod_tot>0) write(6,9807) "aod",nobsaod_tot,real(sumaodjo,r_kind),real(sumaodjo/nobsaod_tot,r_kind) + if(nobssat_tot>0) write(6,9807) "radiance",nobssat_tot,real(sum(sumjo_sat),r_kind),real(sum(sumjo_sat)/nobssat_tot,r_kind) + if(ntotassim > 0) write(6,9807) "Jo Global",ntotassim,real(sumjo_tot,r_kind),& + real(sumjo_tot/(ntotassim),r_kind) + 9806 format(a20,2x,a3,2x,a8,2x,a24,4x,a8) + 9807 format(a20,2x,3x,2x,i8,2x,es24.16,2x,f10.3) -end subroutine print_innovstats + end subroutine print_innovstats -subroutine obstats(obfit,oberrjo,oberrvar,obsprd,obloclat,& - sumfit_nh,sumbias_nh,sumspread_nh,sumoberr_nh,nobs_nh,sumjo_nh,& - sumfit_sh,sumbias_sh,sumspread_sh,sumoberr_sh,nobs_sh,sumjo_sh,& - sumfit_tr,sumbias_tr,sumspread_tr,sumoberr_tr,nobs_tr,sumjo_tr) + subroutine obstats(obfit,oberrjo,oberrvar,obsprd,obloclat,& + sumfit_nh,sumbias_nh,sumspread_nh,sumoberr_nh,nobs_nh,sumjo_nh,& + sumfit_sh,sumbias_sh,sumspread_sh,sumoberr_sh,nobs_sh,sumjo_sh,& + sumfit_tr,sumbias_tr,sumspread_tr,sumoberr_tr,nobs_tr,sumjo_tr) - implicit none - real(r_single), intent(in out) :: sumfit_nh, sumbias_nh, sumspread_nh, sumoberr_nh,& - sumfit_tr, sumbias_tr, sumspread_tr, sumoberr_tr,& - sumfit_sh, sumbias_sh, sumspread_sh, sumoberr_sh,& - sumjo_nh, sumjo_sh, sumjo_tr - real(r_single), intent(in) :: obfit,oberrjo, oberrvar, obsprd, obloclat - integer(i_kind), intent(in out) :: nobs_nh, nobs_sh, nobs_tr + implicit none + real(r_single), intent(in out) :: sumfit_nh, sumbias_nh, sumspread_nh, sumoberr_nh,& + sumfit_tr, sumbias_tr, sumspread_tr, sumoberr_tr,& + sumfit_sh, sumbias_sh, sumspread_sh, sumoberr_sh,& + sumjo_nh, sumjo_sh, sumjo_tr + real(r_single), intent(in) :: obfit,oberrjo, oberrvar, obsprd, obloclat + integer(i_kind), intent(in out) :: nobs_nh, nobs_sh, nobs_tr -! compute innovation statistics in nh,sh,tropics. + ! compute innovation statistics in nh,sh,tropics. - if (obloclat > latbound) then - if (nobs_nh == 0) then - sumfit_nh = obfit**2 - sumbias_nh = obfit - sumspread_nh = obsprd - sumoberr_nh = oberrvar - sumjo_nh = obfit**2/oberrjo - else - sumfit_nh = sumfit_nh + obfit**2 - sumbias_nh = sumbias_nh + obfit - sumspread_nh = sumspread_nh + obsprd - sumoberr_nh = sumoberr_nh + oberrvar - sumjo_nh = sumjo_nh + obfit**2/oberrjo - end if - nobs_nh = nobs_nh + 1 - else if (obloclat < -latbound) then - if (nobs_sh == 0) then - sumfit_sh = obfit**2 - sumbias_sh = obfit - sumspread_sh = obsprd - sumoberr_sh = oberrvar - sumjo_sh = obfit**2/oberrjo - else - sumfit_sh = sumfit_sh + obfit**2 - sumbias_sh = sumbias_sh + obfit - sumspread_sh = sumspread_sh + obsprd - sumoberr_sh = sumoberr_sh + oberrvar - sumjo_sh = sumjo_sh + obfit**2/oberrjo - end if - nobs_sh = nobs_sh + 1 - else - if (nobs_tr == 0) then - sumfit_tr = obfit**2 - sumbias_tr = obfit - sumspread_tr = obsprd - sumoberr_tr = oberrvar - sumjo_tr = obfit**2/oberrjo - else - sumfit_tr = sumfit_tr + obfit**2 - sumbias_tr = sumbias_tr + obfit - sumspread_tr = sumspread_tr + obsprd - sumoberr_tr = sumoberr_tr + oberrvar - sumjo_tr = sumjo_tr + obfit**2/oberrjo - end if - nobs_tr = nobs_tr + 1 - end if + if (obloclat > latbound) then + if (nobs_nh == 0) then + sumfit_nh = obfit**2 + sumbias_nh = obfit + sumspread_nh = obsprd + sumoberr_nh = oberrvar + sumjo_nh = obfit**2/oberrjo + else + sumfit_nh = sumfit_nh + obfit**2 + sumbias_nh = sumbias_nh + obfit + sumspread_nh = sumspread_nh + obsprd + sumoberr_nh = sumoberr_nh + oberrvar + sumjo_nh = sumjo_nh + obfit**2/oberrjo + end if + nobs_nh = nobs_nh + 1 + else if (obloclat < -latbound) then + if (nobs_sh == 0) then + sumfit_sh = obfit**2 + sumbias_sh = obfit + sumspread_sh = obsprd + sumoberr_sh = oberrvar + sumjo_sh = obfit**2/oberrjo + else + sumfit_sh = sumfit_sh + obfit**2 + sumbias_sh = sumbias_sh + obfit + sumspread_sh = sumspread_sh + obsprd + sumoberr_sh = sumoberr_sh + oberrvar + sumjo_sh = sumjo_sh + obfit**2/oberrjo + end if + nobs_sh = nobs_sh + 1 + else + if (nobs_tr == 0) then + sumfit_tr = obfit**2 + sumbias_tr = obfit + sumspread_tr = obsprd + sumoberr_tr = oberrvar + sumjo_tr = obfit**2/oberrjo + else + sumfit_tr = sumfit_tr + obfit**2 + sumbias_tr = sumbias_tr + obfit + sumspread_tr = sumspread_tr + obsprd + sumoberr_tr = sumoberr_tr + oberrvar + sumjo_tr = sumjo_tr + obfit**2/oberrjo + end if + nobs_tr = nobs_tr + 1 + end if -end subroutine obstats + end subroutine obstats -subroutine printstats(obtype,sum_nh,bias_nh,sum_spread_nh,sum_oberr_nh,sum_jo_nh,nobs_nh,& - sum_sh,bias_sh,sum_spread_sh,sum_oberr_sh,sum_jo_sh,nobs_sh,& - sum_tr,bias_tr,sum_spread_tr,sum_oberr_tr,sum_jo_tr,nobs_tr) - implicit none - real(r_single), intent(in out) :: bias_nh, sum_spread_nh, sum_oberr_nh,& - bias_tr, sum_spread_tr, sum_oberr_tr,& - bias_sh, sum_spread_sh, sum_oberr_sh, & - sum_nh,sum_sh,sum_tr - real(r_single), intent(in out) :: sum_jo_nh,sum_jo_sh,sum_jo_tr - integer(i_kind), intent(in) :: nobs_nh, nobs_sh, nobs_tr - character(len=9), intent(in) :: obtype - real(r_single) :: denom - integer(i_kind) :: ntot - real(r_single) :: sum_tot,bias_tot,sum_oberr_tot,sum_spread_tot,sum_jo_tot + subroutine printstats(obtype,sum_nh,bias_nh,sum_spread_nh,sum_oberr_nh,sum_jo_nh,nobs_nh,& + sum_sh,bias_sh,sum_spread_sh,sum_oberr_sh,sum_jo_sh,nobs_sh,& + sum_tr,bias_tr,sum_spread_tr,sum_oberr_tr,sum_jo_tr,nobs_tr) + implicit none + real(r_single), intent(in out) :: bias_nh, sum_spread_nh, sum_oberr_nh,& + bias_tr, sum_spread_tr, sum_oberr_tr,& + bias_sh, sum_spread_sh, sum_oberr_sh, & + sum_nh,sum_sh,sum_tr + real(r_single), intent(in out) :: sum_jo_nh,sum_jo_sh,sum_jo_tr + integer(i_kind), intent(in) :: nobs_nh, nobs_sh, nobs_tr + character(len=9), intent(in) :: obtype + real(r_single) :: denom + integer(i_kind) :: ntot + real(r_single) :: sum_tot,bias_tot,sum_oberr_tot,sum_spread_tot,sum_jo_tot -! print *,'obtype,nobs_nh,nobs_sh,nobs_tr ',obtype,nobs_nh,nobs_sh,nobs_tr - if (nobs_nh > 0) then - denom=one!_RT/real(nobs_nh,r_single) - sum_nh = sum_nh*denom - bias_nh = bias_nh*denom - sum_oberr_nh = sum_oberr_nh*denom - sum_spread_nh = sum_spread_nh*denom - write(6,9805) & - 'NH',obtype,nobs_nh,bias_nh,sqrt(sum_nh),sqrt(sum_spread_nh+sum_oberr_nh),sqrt(sum_spread_nh),sqrt(sum_oberr_nh),& - sum_jo_nh - end if - if (nobs_tr > 0) then - denom=one!_RT/real(nobs_tr,r_single) - sum_tr = sum_tr*denom - bias_tr = bias_tr*denom - sum_oberr_tr = sum_oberr_tr*denom - sum_spread_tr = sum_spread_tr*denom - write(6,9805) & - 'TR',obtype,nobs_tr,bias_tr,sqrt(sum_tr),sqrt(sum_spread_tr+sum_oberr_tr),sqrt(sum_spread_tr),sqrt(sum_oberr_tr),& - sum_jo_tr - end if - if (nobs_sh > 0) then - denom=one!_RT/real(nobs_sh,r_single) - sum_sh = sum_sh*denom - bias_sh = bias_sh*denom - sum_oberr_sh = sum_oberr_sh*denom - sum_spread_sh = sum_spread_sh*denom - write(6,9805) & - 'SH',obtype,nobs_sh,bias_sh,sqrt(sum_sh),sqrt(sum_spread_sh+sum_oberr_sh),sqrt(sum_spread_sh),sqrt(sum_oberr_sh),& - sum_jo_sh - end if - ntot=nobs_nh+nobs_tr+nobs_sh - if ( ntot>0 ) then - sum_tot = (sum_nh+sum_tr+sum_sh)/ntot - bias_tot = (bias_nh+bias_tr+bias_sh)/ntot - sum_oberr_tot = (sum_oberr_nh+sum_oberr_tr+sum_oberr_sh)/ntot - sum_spread_tot = (sum_spread_nh+sum_spread_tr+sum_spread_sh)/ntot - sum_jo_tot = sum_jo_nh+sum_jo_tr+sum_jo_sh - write(6,9805) & - 'GL',obtype,ntot,bias_tot,sqrt(sum_tot),sqrt(sum_spread_tot+sum_oberr_tot),sqrt(sum_spread_tot),sqrt(sum_oberr_tot),& + ! print *,'obtype,nobs_nh,nobs_sh,nobs_tr ',obtype,nobs_nh,nobs_sh,nobs_tr + if (nobs_nh > 0) then + denom=one!_RT/real(nobs_nh,r_single) + sum_nh = sum_nh*denom + bias_nh = bias_nh*denom + sum_oberr_nh = sum_oberr_nh*denom + sum_spread_nh = sum_spread_nh*denom + write(6,9805) & + 'NH',obtype,nobs_nh,bias_nh,sqrt(sum_nh),sqrt(sum_spread_nh+sum_oberr_nh),sqrt(sum_spread_nh),sqrt(sum_oberr_nh),& + sum_jo_nh + end if + if (nobs_tr > 0) then + denom=one!_RT/real(nobs_tr,r_single) + sum_tr = sum_tr*denom + bias_tr = bias_tr*denom + sum_oberr_tr = sum_oberr_tr*denom + sum_spread_tr = sum_spread_tr*denom + write(6,9805) & + 'TR',obtype,nobs_tr,bias_tr,sqrt(sum_tr),sqrt(sum_spread_tr+sum_oberr_tr),sqrt(sum_spread_tr),sqrt(sum_oberr_tr),& + sum_jo_tr + end if + if (nobs_sh > 0) then + denom=one!_RT/real(nobs_sh,r_single) + sum_sh = sum_sh*denom + bias_sh = bias_sh*denom + sum_oberr_sh = sum_oberr_sh*denom + sum_spread_sh = sum_spread_sh*denom + write(6,9805) & + 'SH',obtype,nobs_sh,bias_sh,sqrt(sum_sh),sqrt(sum_spread_sh+sum_oberr_sh),sqrt(sum_spread_sh),sqrt(sum_oberr_sh),& + sum_jo_sh + end if + ntot=nobs_nh+nobs_tr+nobs_sh + if ( ntot>0 ) then + sum_tot = (sum_nh+sum_tr+sum_sh)/ntot + bias_tot = (bias_nh+bias_tr+bias_sh)/ntot + sum_oberr_tot = (sum_oberr_nh+sum_oberr_tr+sum_oberr_sh)/ntot + sum_spread_tot = (sum_spread_nh+sum_spread_tr+sum_spread_sh)/ntot + sum_jo_tot = sum_jo_nh+sum_jo_tr+sum_jo_sh + write(6,9805) & + 'GL',obtype,ntot,bias_tot,sqrt(sum_tot),sqrt(sum_spread_tot+sum_oberr_tot),sqrt(sum_spread_tot),sqrt(sum_oberr_tot),& sum_jo_tot end if 9805 format(a2,1x,a9,1x,i6,1p,6(1x,e10.3)) diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/AGCM.rc.tmpl b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/AGCM.rc.tmpl index 669fa294..35229131 100644 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/AGCM.rc.tmpl +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/AGCM.rc.tmpl @@ -706,7 +706,7 @@ USE_RRTMG_IRRAD: 1.0 USE_RRTMG_SORAD: 1.0 ISOLVAR: 2 USE_NRLSSI2: .TRUE. -SOLAR_CYCLE_FILE_NAME: ExtData/g5gcm/solar/NRLSSI2.v2020.txt +SOLAR_CYCLE_FILE_NAME: ExtData/g5gcm/solar/NRLSSI2.v2021.txt # GOCART broadband aerosol optics tables # ----------------------------------------------------- From 15bb5315d8e013bb83fe188de98a735fe4b6dcb5 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Mon, 3 Oct 2022 14:29:30 -0400 Subject: [PATCH 203/205] minor changes to make sure eps is defined; notice ana.rc and obs.rc have diff entries for eps --- src/Applications/GAAS_App/ana.rc | 2 ++ src/Applications/GAAS_App/ana_aod.F | 25 ++++++++++++++++++++----- src/Applications/GAAS_App/m_obs.F90 | 3 ++- 3 files changed, 24 insertions(+), 6 deletions(-) diff --git a/src/Applications/GAAS_App/ana.rc b/src/Applications/GAAS_App/ana.rc index 3f12f767..f0ae1db9 100644 --- a/src/Applications/GAAS_App/ana.rc +++ b/src/Applications/GAAS_App/ana.rc @@ -51,6 +51,8 @@ do_you_want_to_skip_PSAS: no # yes or no alpha_for_bias_estimation: 0.010 +eps_for_log_transform_aod_on_input: 0.01 + range_of_wavenumbers_to_analyze_in_nm: 470 870 # superob_IMxJM: 576 361 # superob dimension (if <0, same as input grid) diff --git a/src/Applications/GAAS_App/ana_aod.F b/src/Applications/GAAS_App/ana_aod.F index 0745c39b..08f99afe 100644 --- a/src/Applications/GAAS_App/ana_aod.F +++ b/src/Applications/GAAS_App/ana_aod.F @@ -265,11 +265,15 @@ program ana_aod naod = count(ods%data%kt==ktAOD) nlaod = count(ods%data%kt==ktLogAOD) ! if Log AOD available then convert the obs into AOD - if (nlaod >0.) then - where (ods%data%kt == ktLogAOD) - ods%data%obs = max(eps,exp(ods%data%obs)-0.01) - ods%data%kt = ktAOD - endwhere + if (eps<=0.0) then + call die ( myname, 'eps not defined for conversion of log(AOD) obs into AOD') + else + if (nlaod >0 .and. eps>0.0) then + where (ods%data%kt == ktLogAOD) + ods%data%obs = max(eps,exp(ods%data%obs)-eps) + ods%data%kt = ktAOD + endwhere + endif endif myKTobs = ktAOD ! all obs are now supposed to be AOD call ods_clean(ods_,rc) ! get rid of what we do not need @@ -787,6 +791,17 @@ subroutine Init_ ( expid, aerFile, pre_ods, mODS, end if end if +! Try reading eps, ok if not present but code will only handle +! AOD in the input file; code will fail is log AOD found and eps +! is not defined. + call i90_label ( 'eps_for_log_transform_aod_on_input:', ier ) + if (ier==0) then + eps = i90_gfloat ( ier ) + else + print *, trim(myname), ': WARNING, eps not defined early enough' + print *, trim(myname), ': WARNING, code can only handle AOD in input(ODS)' + endif + ! Bias coefficient ! ---------------- if ( do_SBC ) then diff --git a/src/Applications/GAAS_App/m_obs.F90 b/src/Applications/GAAS_App/m_obs.F90 index 655d73ce..25837c9f 100644 --- a/src/Applications/GAAS_App/m_obs.F90 +++ b/src/Applications/GAAS_App/m_obs.F90 @@ -67,13 +67,14 @@ MODULE m_obs ! 14dec2000 da Silva Increased mBoxes from 32 to 128. ! 05jun2002 Dee Convert heights to layer-mean virtual temperatures ! 09feb2010 da Silva Adapted from old GEOS-4 observer for AOD. +! 03oct2022 Todling initilize eps in preamble. ! !EOP !------------------------------------------------------------------------- logical :: do_sqc = .true. ! whether or not to statistical qc logical :: log_transf = .false. ! whether to log-transform AOD - real :: eps ! eps for log-transform + real :: eps = -obs_missing ! eps for log-transform logical :: do_dupelim = .true. ! duplicate elimination? ! Resource file From 92ea7363fdd66586c8bc51cb1bd742fc2fddacc8 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Mon, 3 Oct 2022 17:59:15 -0400 Subject: [PATCH 204/205] minor changes --- src/Applications/GAAS_App/ana_aod.F | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Applications/GAAS_App/ana_aod.F b/src/Applications/GAAS_App/ana_aod.F index 08f99afe..a76ffb62 100644 --- a/src/Applications/GAAS_App/ana_aod.F +++ b/src/Applications/GAAS_App/ana_aod.F @@ -261,14 +261,14 @@ program ana_aod call ods_select( ods_, ods_%data%nobs, nobs, rc, & qcexcl=0, kt_list=kt_list, odss = ods ) ! keep what we need if ( rc .eq. 0 ) then - nobs = ods%data%nobs - naod = count(ods%data%kt==ktAOD) + nobs = ods%data%nobs + naod = count(ods%data%kt==ktAOD) nlaod = count(ods%data%kt==ktLogAOD) - ! if Log AOD available then convert the obs into AOD + ! if Log AOD comes in as input, convert obs into AOD if (eps<=0.0) then call die ( myname, 'eps not defined for conversion of log(AOD) obs into AOD') else - if (nlaod >0 .and. eps>0.0) then + if (nlaod >0) then where (ods%data%kt == ktLogAOD) ods%data%obs = max(eps,exp(ods%data%obs)-eps) ods%data%kt = ktAOD From 1d73731d8353cc2a7ec848ba598960ee8951a2d5 Mon Sep 17 00:00:00 2001 From: Ricardo Todling Date: Tue, 4 Oct 2022 12:48:35 -0400 Subject: [PATCH 205/205] minor fixes for GEOSIT --- components.yaml | 4 +- src/Applications/GAAS_App/ana.rc | 60 --------------------------- src/Applications/GAAS_App/ana.rc.tmpl | 2 + 3 files changed, 4 insertions(+), 62 deletions(-) delete mode 100644 src/Applications/GAAS_App/ana.rc diff --git a/components.yaml b/components.yaml index 5ca4037c..fe7491f2 100644 --- a/components.yaml +++ b/components.yaml @@ -28,7 +28,7 @@ NCEP_Shared: GMAO_Shared: local: ./src/Shared/@GMAO_Shared remote: ../GMAO_Shared.git - tag: v1.4.10.1 + tag: v1.4.10.2 develop: main MAPL: @@ -121,7 +121,7 @@ mom6: GEOSgcm_App: local: ./src/Applications/@GEOSgcm_App remote: ../GEOSgcm_App.git - tag: v1.5.6.1 + tag: v1.5.6.2 develop: develop UMD_Etc: diff --git a/src/Applications/GAAS_App/ana.rc b/src/Applications/GAAS_App/ana.rc deleted file mode 100644 index f0ae1db9..00000000 --- a/src/Applications/GAAS_App/ana.rc +++ /dev/null @@ -1,60 +0,0 @@ -# -# FVPSAS Analysis resource file. -# -# !REVISION HISTORY: -# -# 14feb2010 da Silva Adapted from GEOS-4 ana.rc. -# -# This configuration increases the bias timescale to ~ 15 days -# -#----------------------------------------------------------------------------- - -# ------------------- -# INPUT ODS FILES -# ------------------- - -ODS_files:: - -# AERONET data produced off-line - -/home/adasilva/iesa/aerosol/data/MERRA-2/AERONET/Y%y4/M%m2/aeronet.obs.%y4%m2%d2.ods - -# AVHRR Produced off-line -#/home/adasilva/silo/GAAS/AVHRR/obs/Level2/Y%y4/M%m2/nnr_001.patmosx_v05r02_L2a.asc.%y4%m2%d2_%h200z.ods -#/home/adasilva/silo/GAAS/AVHRR/obs/Level2/Y%y4/M%m2/nnr_001.patmosx_v05r02_L2a.des.%y4%m2%d2_%h200z.ods - -# Produced off-line - -/home/adasilva/iesa/aerosol/data/MERRA-2/MOD04//Y%y4/M%m2/nnr_002.MOD04_L2a.land.%y4%m2%d2_%h200z.ods -/home/adasilva/iesa/aerosol/data/MERRA-2/MOD04//Y%y4/M%m2/nnr_002.MOD04_L2a.ocean.%y4%m2%d2_%h200z.ods -/home/adasilva/iesa/aerosol/data/MERRA-2/MYD04//Y%y4/M%m2/nnr_002.MYD04_L2a.land.%y4%m2%d2_%h200z.ods -/home/adasilva/iesa/aerosol/data/MERRA-2/MYD04//Y%y4/M%m2/nnr_002.MYD04_L2a.ocean.%y4%m2%d2_%h200z.ods - -#./misr_F12_0022.bright_tc8.obs.%y4%m2%d2.ods - -# Passive data -#/nobackup/3/PARASOL/Level2/ODS/Y%y4/M%m2/PARASOL_L2.aero_tc8.obs.%y4%m2%d2.ods -#/nobackup/3/OMI/Level2/ODS/Y%y4/M%m2/omi.aero_tc8.obs.%y4%m2%d2.ods -#/nobackup/3/AERONET/Level2/ODS/Y%y4/M%m2/AERONET.aero_tc8.obs.%y4%m2%d2.ods -:: - -do_statistical_bias_correction: no # yes or no - - -# ----------------- -# ANALYZER -# ----------------- - -do_averaging_kernel: yes - -do_you_want_to_skip_PSAS: no # yes or no - -alpha_for_bias_estimation: 0.010 - -eps_for_log_transform_aod_on_input: 0.01 - -range_of_wavenumbers_to_analyze_in_nm: 470 870 - -# superob_IMxJM: 576 361 # superob dimension (if <0, same as input grid) - -#. diff --git a/src/Applications/GAAS_App/ana.rc.tmpl b/src/Applications/GAAS_App/ana.rc.tmpl index 1cab053b..f52f2cb2 100644 --- a/src/Applications/GAAS_App/ana.rc.tmpl +++ b/src/Applications/GAAS_App/ana.rc.tmpl @@ -59,6 +59,8 @@ do_you_want_to_skip_PSAS: no # yes or no alpha_for_bias_estimation: 0.010 +eps_for_log_transform_aod_on_input: 0.01 + range_of_wavenumbers_to_analyze_in_nm: 540 560 # superob_IMxJM: 576 361 # superob dimension (if <0, same as input grid)