SUBROUTINE GET_ACARS_TIMES ( sffile, time_list, ntimf, iret ) C************************************************************************ C* SNLIST * C* * C* This program lists data from a sounding dataset. * C* * C* Log: * C* I. Graffman/RDS 8/87 * C* M. desJardins/GSFC 10/88 Rewritten * C* M. desJardins/GSFC 4/89 Modify to list unmerged data * C* S. Schotz/GSC 8/90 Corrected bogus error message for * C* unmerged listing * C* J. Whistler/SSAI 5/91 Changed output*20 to output*48 * C* S. Jacobs/NMC 6/94 STNDEX*48 --> *72 * C* L. Williams/EAI 7/94 Removed call to SNLUPD * C* S. Jacobs/NMC 3/95 Changed call to SNLLEV to pass file num * C* L. Hinson/AWC 3/03 Defined/Init lenaux * C************************************************************************ INCLUDE 'GEMPRM.PRM' INCLUDE 'ERMISS.FNC' C* CHARACTER*(*) sffile CHARACTER time_list(500)*20 CHARACTER sffcur*72, pmdset (MMPARM)*4 LOGICAL newfil C------------------------------------------------------------------------ C* Initialize user interface. C iret = 0 CALL IN_BDTA ( ier ) C C* Open the input file. C sffcur = ' ' CALL SFLFIL ( sffile, sffcur, isffln, newfil, iflsrc, + pmdset, npmdst, iret ) IF ( iret .eq. 0 ) THEN C C* Get input times and pointers. C CALL SF_GTIM ( isffln, LLMXTM, ntimf, time_list, ier ) C CALL SF_CLOS ( isffln, iret ) END IF C* END SUBROUTINE GET_ACARS_POINTS ( sffile, ntime, tlist, iret ) INCLUDE 'GEMPRM.PRM' CHARACTER*(*) sffile INTEGER ntime CHARACTER tlist(500)*20 CHARACTER times(LLMXTM)*15,stn*8,sffcur*72 CHARACTER pmdset (MMPARM)*4 REAL slat(MMHDRS), slon(MMHDRS), selv(MMHDRS) LOGICAL newfil,pltval REAL breaks(24) INTEGER icolors(24), istns c do i=1,ntime c write(*,*) 'look dattim ',i,tlist(i) c end do ncolor = 23 mrktyp = 1 sizmrk = .4 mrkwid = 1 pltval = .false. iposn = 0 do i=1,ncolor c breaks(i) = float(i * 10000)/float(ncolor) breaks(i) = float(i * 450) icolors(i) = 31 - i end do icolors(24) = 7 breaks(24) = 10800 CALL GG_CBAR('31/V/CR/.02;.5/.85;.01/',ncolor,breaks, + icolors,ier) iret = 0 sffcur = ' ' isffln = 0 CALL IN_BDTA ( ier ) CALL SFLFIL ( sffile, sffcur, isffln, newfil, iflsrc, + pmdset, npmdst, iret ) IF ( iret .eq. 0 ) THEN if(ntime .eq. 0) then CALL SF_GTIM ( isffln, LLMXTM, ntimf, times, ier ) c write(*,*) 'get time ',ntimf,ier else ntimf = ntime do i=1,ntime times(i) = tlist(i)(1:15) end do end if itime = 0 iext = ier istns = 0 do while ((itime .lt. ntimf).and.(iext.eq.0)) itime = itime + 1 CALL SF_STIM ( isffln, times (itime), ier ) CALL SF_BEGS ( isffln, ier ) C C* Loop through stations. C iout = 0 DO WHILE ( iout .eq. 0 ) C C* Get next station. C istns = istns + 1 CALL SF_SNXT ( isffln, stn, istnm, + slat(istns), slon(istns), + selv(istns), ispri, iout ) END DO istns = istns - 1 end do IF (istns .gt. 0) THEN CALL MAP_MARK (istns, slat, slon, selv, + ncolor, breaks, icolors, mrktyp, + sizmrk, mrkwid, pltval, ipos, iret) END IF CALL SF_CLOS ( isffln, iret ) END IF CALL GEPLOT ( ier ) RETURN END SUBROUTINE FLTPATH (lat1, lon1, lat2, lon2) REAL lat1,lat2,lon1,lon2 REAL x(2), y(2) INTEGER iret CALL GSCOLR(1, iret) CALL GSLINE(10,2,1,2,iret) x(1) = lat1 x(2) = lat2 y(1) = lon1 y(2) = lon2 CALL GLINE ('M',2,x,y,iret) RETURN END SUBROUTINE MKNAM (ival,istr,iret) INTEGER ival CHARACTER*(*) istr CHARACTER*4 ichnam INTEGER nampos, icnt, iret nampos = 1 ichnam = ' ' iret = 0 do while(ival .gt. 0) if(nampos.gt.8) then iret = -1 return endif if(mod(ival,36) .lt. 10) then ichnam(nampos:nampos) = char(mod(ival,36) + 48) else ichnam(nampos:nampos) = char(mod(ival,36) + 65 - 10) endif ival = ival / 36 nampos = nampos + 1 end do icnt = 1 do while(nampos .gt. 1) nampos = nampos - 1 istr(icnt:icnt) = ichnam(nampos:nampos) icnt = icnt + 1 end do RETURN END SUBROUTINE GET_APTS (isffln, data, ip1, ip2, ip3, apts) INTEGER isffln REAL data(*) INTEGER ip1, ip2, ip3 CHARACTER*(*) apts(3) apts(1) = ' ' apts(2) = ' ' apts(3) = ' ' if(ip1.gt.0) then ival = data(ip1) call mknam(ival,apts(1),ier) endif if(ip2.gt.0) then ival = data(ip2) call mknam(ival,apts(2),ier) endif if(ip3.gt.0) then ival = data(ip3) call mknam(ival,apts(3),ier) endif RETURN END SUBROUTINE GET_NEAREST ( sffile, ntime, tlist, + lat, lon, cstn, auxinfo) INCLUDE 'GEMPRM.PRM' CHARACTER*(*) sffile CHARACTER*(*) cstn, auxinfo CHARACTER tlist(500)*20 INTEGER ntime REAL lat,lon CHARACTER times(LLMXTM)*15,sffcur*72 CHARACTER pmdset (MMPARM)*4 REAL slat, slon, selv LOGICAL newfil CHARACTER alat1*9,alon1*9,alat2*9,alon2*9 CHARACTER tarea*48,area*48,arecur*48 CHARACTER stn*8,astn*8,apts(3)*4,atime*15 REAL data (LLMXDT) REAL dist,mindist INTEGER lenaux lenaux=0 nlev = 0 mindist = 999999. rlatsz = .3 rlonsz = .3 CALL IN_BDTA ( ier ) CALL ST_RLCH (lat-rlatsz,3,alat1,ier) CALL ST_RLCH (lon-rlonsz,3,alon1,ier) CALL ST_RLCH (lat+rlatsz,3,alat2,ier) CALL ST_RLCH (lon+rlonsz,3,alon2,ier) tarea = alat1//';'//alon1//';'//alat2//';'//alon2 CALL ST_RMBL(tarea,area,lenarea,ier) sffcur = ' ' newfil = .true. isffln = 0 iret = 0 CALL SFLFIL ( sffile, sffcur, isffln, newfil, iflsrc, + pmdset, npmdst, iret ) if(iret.ne.0) return CALL ST_FIND ( 'PRES', pmdset, npmdst, ip_pres, ier) CALL ST_FIND ( 'HGHT', pmdset, npmdst, ip_hght, ier) CALL ST_FIND ( 'TMPC', pmdset, npmdst, ip_tmpc, ier) CALL ST_FIND ( 'DWPC', pmdset, npmdst, ip_dwpc, ier) CALL ST_FIND ( 'SPED', pmdset, npmdst, ip_sped, ier) CALL ST_FIND ( 'DRCT', pmdset, npmdst, ip_drct, ier) CALL ST_FIND ( 'ORIG', pmdset, npmdst, ip_orig, ier) CALL ST_FIND ( 'DEST', pmdset, npmdst, ip_dest, ier) CALL ST_FIND ( 'RPTS', pmdset, npmdst, ip_rpts, ier) CALL LC_UARE ( area, newfil, isffln, arecur, astn, ier ) IF ( iret .eq. 0 ) THEN if(ntime .eq. 0) then CALL SF_GTIM ( isffln, LLMXTM, ntimf, times, ier ) else ntimf = ntime do i=1,ntime times(i) = tlist(i)(1:15) end do end if itime = 0 iext = ier cstn = ' ' do while ((itime .lt. ntimf).and.(iext.eq.0)) itime = itime + 1 CALL SF_STIM ( isffln, times (itime), ier ) CALL SF_BEGS ( isffln, ier ) C C* Loop through stations. C iout = 0 DO WHILE ( iout .eq. 0 ) C C* Get next station. C CALL SF_SNXT ( isffln, stn, istnm, slat, slon, + selv, ispri, iret ) if(iret.eq.0) then dist = (slat - lat)*(slat - lat) + + (slon - lon)*(slon - lon) if(dist.lt.mindist) then cstn = stn atime = times (itime) mindist = dist CALL SF_RDAT (isffln, data, ihhmm, iret ) CALL GET_APTS (isffln, data, ip_orig, ip_dest, + ip_rpts, apts) end if else iout = iret endif END DO end do CALL SF_CLOS ( isffln, iret ) end if if(mindist.lt.999999) then c write(auxinfo,*) 'Station ',cstn,' Time: ',atime, c + apts(1),'->',apts(2),' [',apts(3),']' write(auxinfo,*) cstn,' ',atime, + apts(1),'->',apts(2),' [',apts(3),']' do i=1,len(auxinfo) if(ichar( auxinfo(i:i) ) .lt. 32) + auxinfo(i:i) = ' ' end do c write(*,*) auxinfo lenaux=len(auxinfo) call st_lstr(auxinfo,lenaux,iret) write(auxinfo(lenaux+1:),10) data(ip_pres),data(ip_hght), + data(ip_tmpc), data(ip_dwpc), data(ip_sped), data(ip_drct) 10 FORMAT(6 (1x,F8.2) ) c if(ip_pres.gt.0) write(*,*) 'PRES = ',data(ip_pres) c if(ip_hght.gt.0) write(*,*) 'HGHT = ',data(ip_hght) c if(ip_tmpc.gt.0) write(*,*) 'TMPC = ',data(ip_tmpc) c if(ip_dwpc.gt.0) write(*,*) 'DWPC = ',data(ip_dwpc) c if(ip_sped.gt.0) write(*,*) 'SPED = ',data(ip_sped) c if(ip_drct.gt.0) write(*,*) 'DRCT = ',data(ip_drct) endif RETURN END SUBROUTINE GET_ACARS_SND ( sffile, ntime, tlist, + mode, lat, lon, cstn, rdata, nlev ) INCLUDE 'GEMPRM.PRM' CHARACTER*(*) sffile,cstn CHARACTER tlist(500)*20 REAL rdata(*) INTEGER nlev, ntime REAL lat,lon INTEGER mode CHARACTER times(LLMXTM)*15,sffcur*72 CHARACTER pmdset (MMPARM)*4 REAL slat, slon, selv, plat, plon LOGICAL newfil CHARACTER alat1*9,alon1*9,alat2*9,alon2*9 CHARACTER tarea*48,area*48,arecur*48 CHARACTER stn*8,astn*8,apts(3)*4 REAL data (LLMXDT) nlev = 0 plat = -9999. plon = -9999. rlatsz = 0.7 rlonsz = 0.7 CALL IN_BDTA ( ier ) if(mode.eq.1) then CALL ST_RLCH (lat-rlatsz,3,alat1,ier) CALL ST_RLCH (lon-rlonsz,3,alon1,ier) CALL ST_RLCH (lat+rlatsz,3,alat2,ier) CALL ST_RLCH (lon+rlonsz,3,alon2,ier) tarea = alat1//';'//alon1//';'//alat2//';'//alon2 else tarea = '@'//cstn endif CALL ST_RMBL(tarea,area,lenarea,ier) sffcur = ' ' newfil = .true. isffln = 0 iret = 0 CALL SFLFIL ( sffile, sffcur, isffln, newfil, iflsrc, + pmdset, npmdst, iret ) if(iret.ne.0) return CALL ST_FIND ( 'PRES', pmdset, npmdst, ip_pres, ier) CALL ST_FIND ( 'HGHT', pmdset, npmdst, ip_hght, ier) CALL ST_FIND ( 'TMPC', pmdset, npmdst, ip_tmpc, ier) CALL ST_FIND ( 'DWPC', pmdset, npmdst, ip_dwpc, ier) CALL ST_FIND ( 'SPED', pmdset, npmdst, ip_sped, ier) CALL ST_FIND ( 'DRCT', pmdset, npmdst, ip_drct, ier) CALL ST_FIND ( 'ORIG', pmdset, npmdst, ip_orig, ier) CALL ST_FIND ( 'DEST', pmdset, npmdst, ip_dest, ier) CALL ST_FIND ( 'RPTS', pmdset, npmdst, ip_rpts, ier) CALL LC_UARE ( area, newfil, isffln, arecur, astn, ier ) IF ( iret .eq. 0 ) THEN if(ntime .eq. 0) then CALL SF_GTIM ( isffln, LLMXTM, ntimf, times, ier ) else ntimf = ntime do i=1,ntime times(i) = tlist(i)(1:15) end do end if itime = 0 iext = ier do while ((itime .lt. ntimf).and.(iext.eq.0)) itime = itime + 1 CALL SF_STIM ( isffln, times (itime), ier ) CALL SF_BEGS ( isffln, ier ) C C* Loop through stations. C iout = 0 if(nlev.ge.200) then write(*,*) 'Found more than 200 observations' write(*,*) 'Decrease time range' iout = -1 iext = -1 endif DO WHILE ( iout .eq. 0 ) C C* Get next station. C CALL SF_SNXT ( isffln, stn, istnm, slat, slon, + selv, ispri, iret ) IF ( iret .ne. 0 ) THEN iout = iret ELSE nlev = nlev + 1 CALL SF_RDAT (isffln, data, ihhmm, iret ) do icnt=1,7 rdata((nlev-1)*7+icnt) = -999. if(data(icnt).lt.-9998) data(icnt) =-999. end do if(ip_pres.gt.0) rdata((nlev-1)*7+2) = + data(ip_pres) if(ip_hght.gt.0) rdata((nlev-1)*7+3) = + data(ip_hght) if(ip_tmpc.gt.0) rdata((nlev-1)*7+4) = + data(ip_tmpc) if(ip_dwpc.gt.0) rdata((nlev-1)*7+5) = + data(ip_dwpc) if(ip_drct.gt.0) rdata((nlev-1)*7+6) = + data(ip_drct) C LJH modified this line to get wind speed in knots...SKNT does not work if(ip_sped.gt.0) rdata((nlev-1)*7+7) = + data(ip_sped) * 1.94254 CALL GET_APTS (isffln, data, ip_orig, ip_dest, + ip_rpts, apts) c write(*,*) nlev,' ',times(itime),' ',stn,slat,slon, c + data(1),data(2), c + apts(1),' ',apts(2),' ',apts(3) if(mode.eq.3) then if(plat.lt.-9998) then plat = slat plon = slon else call fltpath (plat,plon,slat,slon) plat = slat plon = slon endif endif END IF if(nlev.ge.200) then write(*,*) 'Found more than 200 observations' write(*,*) 'Decrease time range' iout = -1 iext = -1 endif END DO end do CALL SF_CLOS ( isffln, iret ) END IF C ioff = 2 (pressure) ioff = 2 isrt = 1 do while(isrt.ne.0) isrt = 0 do i=1,nlev-1 j = (i - 1)*7 if(rdata(j+ioff).lt.rdata(j+7+ioff)) then isrt = isrt + 1 do k=1,7 rtemp = rdata(j+k) rdata(j+k) = rdata(j+7+k) rdata(j+7+k) = rtemp end do endif end do end do RETURN END