!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE RDPROF ######
!###### ######
!###### Developed by ######
!###### Center for Analysis and Prediction of Storms ######
!###### University of Oklahoma ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE rdprof(nvar,nzua,mxua,jsrc,proffile, & 1,2
stnua,elevua,xua,yua,hgtua,obsua, &
qualua,isrcua,nlevsua, &
rmiss,nprev,ntotal,istatus)
!
!-----------------------------------------------------------------------
!
! PURPOSE:
!
! Read ASCII file containing wind profiler data.
!
!-----------------------------------------------------------------------
!
! AUTHOR: Keith Brewster
! July, 1995
!
! MODIFICATION HISTORY:
! 9/3/96 Keith Brewster
! Added full documentation.
!
! 2/16/98 Keith Brewster
! Added jsrc, source number to the variable list
!
!-----------------------------------------------------------------------
!
! INPUT :
!
! nvar Number of variables in analysis (array dimension)
! nzua Maximum number of vertical levels (array dimension)
! mxua Maximum number of UA stations (array dimension)
! jsrc Source number of data set
! proffile Name of profiler data file to read
! rmiss Missing data fill value
! nprev Number of stations read previously into UA observation
! data arrays (array index)
!
! OUTPUT :
!
! stnua station name (character*4)
! elevua station elevation (m MSL)
! xua station location x-coordinate (m)
! yua station location y-coordinate (m)
! hgtua height of data (m MSL)
! obsua observation data
! qualua observation quality indicator
! isrcua data source index
! nlevsua number of levels of data
! ntotal number of stations
! istatus status indicator
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
INTEGER :: nvar,nzua,mxua
!
INTEGER :: jsrc
CHARACTER (LEN=132) :: proffile
CHARACTER (LEN=5) :: stnua(mxua)
REAL :: elevua(mxua)
REAL :: xua(mxua)
REAL :: yua(mxua)
REAL :: hgtua(nzua,mxua)
REAL :: obsua(nvar,nzua,mxua)
INTEGER :: qualua(nvar,nzua,mxua)
INTEGER :: isrcua(mxua)
INTEGER :: nlevsua(mxua)
REAL :: rmiss
INTEGER :: nprev,ntotal
INTEGER :: istatus
!
!-----------------------------------------------------------------------
!
! Misc. local variables
!
!-----------------------------------------------------------------------
!
INTEGER :: ista,ivar,jlev,jend,ksta,mxprof,nprof
INTEGER :: numsta
REAL :: hgtdum,rlat,rlon,DIRECT,speed,ddrot
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
OPEN(12,FILE=trim(proffile),ERR=400,STATUS='old')
!
mxprof=mxua-nprev
!
!-----------------------------------------------------------------------
!
! Fill arrays with "missing data" indicator
!
!-----------------------------------------------------------------------
!
DO ista=1,mxprof
DO jlev=1,nzua
DO ivar=1,nvar
ksta=ista+nprev
obsua(ivar,jlev,ksta)=rmiss
qualua(ivar,jlev,ksta)=-99
END DO
END DO
END DO
!
!-----------------------------------------------------------------------
!
! Main data-reading loop
!
!-----------------------------------------------------------------------
!
DO ista=1,mxprof
ksta=ista+nprev
READ(12,'(i12,i12,f11.0,f15.0,f15.0,5x,a5)',ERR=250,END=250) &
numsta,nlevsua(ksta),rlat,rlon,elevua(ksta),stnua(ksta)
PRINT *, 'Reading Wind Profiler <', stnua(ksta), '>'
!
isrcua(ksta)=jsrc
CALL lltoxy
(1,1,rlat,rlon,xua(ksta),yua(ksta))
!
jend=MIN(nlevsua(ksta),nzua)
DO jlev=1,jend
READ(12,*,ERR=250,END=250) hgtua(jlev,ksta),DIRECT,speed
IF(DIRECT >= 0. .AND. speed >= 0.) THEN
CALL ddrotuv(1,rlon,DIRECT,speed,ddrot, &
obsua(1,jlev,ksta),obsua(2,jlev,ksta))
! print *, ' direct,speed,u,v=',direct,speed,
! + obsua(1,jlev,ksta),obsua(2,jlev,ksta)
qualua(1,jlev,ksta)=100
qualua(2,jlev,ksta)=100
END IF
!
END DO
!
!-----------------------------------------------------------------------
!
! Read any extra levels after nzua, but discard them.
!
!-----------------------------------------------------------------------
!
IF(nlevsua(ksta) > nzua) THEN
WRITE(6,'(//a,a/,a,i4,a)') ' RDPROF: WARNING profiler: ', &
stnua(ksta),' truncated to nzua=',nzua,' levels.'
WRITE(6,'(a,i4,a)') ' Data file has ',nlevsua(ksta), &
' levels.'
WRITE(6,'(a/)') ' Increase nz_ua in adas.inc'
DO jlev=jend+1,nlevsua(ksta)
READ(12,*,ERR=250,END=250) hgtdum,DIRECT,speed
END DO
nlevsua(ksta)=nzua
END IF
END DO
!
!-----------------------------------------------------------------------
!
! End-of-file destination
!
!-----------------------------------------------------------------------
!
250 CONTINUE
nprof=ista-1
ntotal=nprev+nprof
WRITE(6,'(a,i4,a)') ' Read ',nprof,' profiler sites'
CLOSE(12)
istatus=1
RETURN
!
!-----------------------------------------------------------------------
!
! Error opening file destination
!
!-----------------------------------------------------------------------
!
400 CONTINUE
WRITE(6,'(a)') ' Error opening profiler file: ',proffile
ntotal=nprev
istatus=-1
RETURN
END SUBROUTINE rdprof
!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE RDRAOB ######
!###### ######
!###### Developed by ######
!###### Center for Analysis and Prediction of Storms ######
!###### University of Oklahoma ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE rdraob(nvar,nzua,mxua,jsrc,raobfile, & 1,3
stnua,elevua,xua,yua,hgtua,obsua, &
qualua,isrcua,nlevsua, &
rmiss,nprev,ntotal,istatus)
!
!-----------------------------------------------------------------------
!
! PURPOSE:
!
! Read ASCII file containing rawinsonde observations (RAOBs).
!
!-----------------------------------------------------------------------
!
! AUTHOR: Keith Brewster
! Jan, 1994
!
! MODIFICATION HISTORY:
! 9/3/96 Keith Brewster
! Restored proper calculation of moisture variable.
! Added full documentation.
!
! 2/16/98 Keith Brewster
! Added jsrc, source number to the variable list
!
!-----------------------------------------------------------------------
!
! INPUT :
!
! nvar Number of variables in analysis (array dimension)
! nzua Maximum number of vertical levels (array dimension)
! mxua Maximum number of UA stations (array dimension)
! jsrc Source number of RAOB data set
! raobfile Name of profiler data file to read
! rmiss Missing data fill value
! nprev Number of stations read previously into UA observation
! data arrays (array index)
!
! OUTPUT :
!
! stnua station name (character*4)
! elevua station elevation (m MSL)
! xua station location x-coordinate (m)
! yua station location y-coordinate (m)
! hgtua height of data (m MSL)
! obsua observation data
! qualua observation quality indicator
! isrcua data source index
! nlevsua number of levels of data
! ntotal number of stations
! istatus status indicator
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
INTEGER :: nvar,nzua,mxua
!
INTEGER :: jsrc
CHARACTER (LEN=132) :: raobfile
CHARACTER (LEN=5) :: stnua(mxua)
REAL :: elevua(mxua)
REAL :: xua(mxua)
REAL :: yua(mxua)
REAL :: hgtua(nzua,mxua)
REAL :: obsua(nvar,nzua,mxua)
INTEGER :: qualua(nvar,nzua,mxua)
INTEGER :: isrcua(mxua)
INTEGER :: nlevsua(mxua)
REAL :: rmiss
INTEGER :: nprev,ntotal
INTEGER :: istatus
!
REAL :: mbtopa
PARAMETER (mbtopa=100.)
!
INCLUDE 'phycst.inc'
!
!-----------------------------------------------------------------------
!
! Misc. local variables
!
!-----------------------------------------------------------------------
!
INTEGER :: ista,ivar,jlev,jend,ksta,nraob,mxraob
INTEGER :: numsta
INTEGER :: nlevlast
REAL :: rlat,rlon,hgtdum,press,temp,tdew,DIRECT,speed,ddrot,tdk
REAL :: u1last,v1last,pr1last,pt1last,rh1last
!
!-----------------------------------------------------------------------
!
! Function f_qvsat and inline directive for Cray PVP
!
!-----------------------------------------------------------------------
!
REAL :: f_qvsat
!fpp$ expand (f_qvsat)
!dir$ inline always f_qvsat
!*$* inline routine (f_qvsat)
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
OPEN(12,FILE=trim(raobfile),ERR=400,STATUS='old')
!
mxraob=mxua-nprev
nlevlast=0
u1last=-9999.
v1last=-9999.
pr1last=-9999.
pt1last=-9999.
rh1last=-9999.
!
!-----------------------------------------------------------------------
!
! Fill arrays with "missing data" indicator
!
!-----------------------------------------------------------------------
!
DO ista=1,mxraob
DO jlev=1,nzua
DO ivar=1,nvar
ksta=ista+nprev
obsua(ivar,jlev,ksta)=rmiss
qualua(ivar,jlev,ksta)=-99
END DO
END DO
END DO
!
!-----------------------------------------------------------------------
!
! Main data-reading loop
!
!-----------------------------------------------------------------------
!
ksta=nprev+1
ntotal=nprev
DO ista=1, mxraob
READ(12,'(i12,i12,f11.4,f15.4,f15.0,5x,a5)',ERR=250,END=250) &
numsta,nlevsua(ksta),rlat,rlon,elevua(ksta),stnua(ksta)
!
isrcua(ksta)=jsrc
CALL lltoxy(1,1,rlat,rlon,xua(ksta),yua(ksta))
!
jend=MIN(nlevsua(ksta),nzua)
DO jlev=1,jend
READ(12,*,ERR=250,END=250) &
hgtua(jlev,ksta),press,temp,tdew,DIRECT,speed
!
!-----------------------------------------------------------------------
!
! observed u,v
!
!-----------------------------------------------------------------------
!
IF(DIRECT >= 0. .AND. speed >= 0.) THEN
CALL ddrotuv(1,rlon,DIRECT,speed,ddrot, &
obsua(1,jlev,ksta),obsua(2,jlev,ksta))
qualua(1,jlev,ksta)=100
qualua(2,jlev,ksta)=100
END IF
!
!-----------------------------------------------------------------------
!
! observed press and potential temperature
!
!-----------------------------------------------------------------------
!
IF(press >= 0.) THEN
obsua(3,jlev,ksta)=press*mbtopa
qualua(3,jlev,ksta)=100
IF(temp > -99.) THEN
obsua(4,jlev,ksta)= &
(temp+273.15)*((p0/obsua(3,jlev,ksta))**rddcp)
qualua(4,jlev,ksta)=100
END IF
!
!-----------------------------------------------------------------------
!
! observed specific humidity
!
!-----------------------------------------------------------------------
!
IF(temp > -99. .AND. tdew > -99.) THEN
tdk=tdew + 273.15
obsua(5,jlev,ksta)= &
MAX(1.0E-08,f_qvsat(obsua(3,jlev,ksta),tdk))
qualua(5,jlev,ksta)=100
END IF
END IF
END DO
!
!-----------------------------------------------------------------------
!
! Read any extra levels after nzua, but discard them.
!
!-----------------------------------------------------------------------
!
IF(nlevsua(ksta) > nzua) THEN
WRITE(6,'(//a,a/,a,i4,a)') ' RDRAOB: WARNING rawinsonde: ', &
stnua(ksta),' truncated to nzua=',nzua,' levels.'
WRITE(6,'(a,i4,a)') ' Data file has ',nlevsua(ksta), &
' levels.'
WRITE(6,'(a/)') ' Increase nz_ua in adas.inc'
!
DO jlev=jend+1,nlevsua(ksta)
READ(12,*,ERR=250,END=250) &
hgtdum,press,temp,tdew,DIRECT,speed
END DO
nlevsua(ksta)=nzua
END IF
!
!-----------------------------------------------------------------------
!
! Check for duplicate sounding to to error some .snd files
! If dupe is found, do not increment ksta or ntotal counter.
!
!-----------------------------------------------------------------------
!
IF(nlevsua(ksta) == nlevlast .AND. obsua(1,1,ksta) == u1last .AND. &
obsua(2,1,ksta) == v1last .AND. &
obsua(3,1,ksta) == pr1last .AND. &
obsua(4,1,ksta) == pt1last .AND. &
obsua(5,1,ksta) == rh1last ) THEN
WRITE(6,'(a,a)') &
' Discarding erroneous duplicate data stored for', &
stnua(ksta)
ELSE
!wdt update
WRITE(6,'(a,i5,2A)') ' Read', nlevsua(ksta), &
' levels of data from radiosonde station ', TRIM(stnua(ksta))
nlevlast=nlevsua(ksta)
u1last=obsua(1,1,ksta)
v1last=obsua(2,1,ksta)
pr1last=obsua(3,1,ksta)
pt1last=obsua(4,1,ksta)
rh1last=obsua(5,1,ksta)
ksta=ksta+1
ntotal=ntotal+1
END IF
END DO
!
!-----------------------------------------------------------------------
!
! End-of-file destination
!
!-----------------------------------------------------------------------
!
250 CONTINUE
nraob=ntotal-nprev
CLOSE(12)
RETURN
!
!-----------------------------------------------------------------------
!
! Error opening file destination
!
!-----------------------------------------------------------------------
!
400 CONTINUE
WRITE(6,'(a)') ' Error opening raob file: ',raobfile
ntotal=nprev
RETURN
END SUBROUTINE rdraob