PROGRAM testret,3
!
!##################################################################
!##################################################################
!###### ######
!###### PROGRAM TESTRET ######
!###### ######
!###### Developed by ######
!###### Center for Analysis and Prediction of Storms ######
!###### University of Oklahoma ######
!###### ######
!##################################################################
!##################################################################
!
!
!-----------------------------------------------------------------------
!
! PURPOSE:
!
! Test writing of retrieval columns.
!
!-----------------------------------------------------------------------
!
! AUTHOR: Keith Brewster
!
! MODIFICATION HISTORY:
!
!-----------------------------------------------------------------------
!
! DATA ARRAYS READ IN:
!
! x x coordinate of grid points in physical/comp. space (m)
! y y coordinate of grid points in physical/comp. space (m)
! z z coordinate of grid points in computational space (km)
! zp z coordinate of grid points in computational space (m)
!
! uprt x component of perturbation velocity (m/s)
! vprt y component of perturbation velocity (m/s)
! wprt Vertical component of perturbation velocity in Cartesian
! coordinates (m/s).
!
! ptprt Perturbation potential temperature (K)
! pprt Perturbation pressure (Pascal)
!
! qvprt Perturbation water vapor mixing ratio (kg/kg)
! qc Cloud water mixing ratio (kg/kg)
! qr Rainwater mixing ratio (kg/kg)
! qi Cloud ice mixing ratio (kg/kg)
! qs Snow mixing ratio (kg/kg)
! qh Hail mixing ratio (kg/kg)
!
! ubar Base state x velocity component (m/s)
! vbar Base state y velocity component (m/s)
! wbar Base state z velocity component (m/s)
! ptbar Base state potential temperature (K)
! pbar Base state pressure (Pascal)
! rhobar Base state air density (kg/m**3)
! qvbar Base state water vapor mixing ratio (kg/kg)
!
! CALCULATED DATA ARRAYS:
!
! u x component of velocity (m/s)
! v y component of velocity (m/s)
! w z component of velocity (m/s)
! pt Potential temperature (K)
! qv Water vapor mixing ratio (kg/kg)
!
!
! WORK ARRAYS:
!
! tem1 Temporary work array.
! tem2 Temporary work array.
! tem3 Temporary work array.
!
!
!-----------------------------------------------------------------------
!
! Variable Declarations:
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
!
!-----------------------------------------------------------------------
!
! Include files:
!
!-----------------------------------------------------------------------
!
INCLUDE 'globcst.inc'
INCLUDE 'indtflg.inc'
INCLUDE 'grid.inc'
INTEGER :: nx, ny, nz ! Dimensions declaration
!
!-----------------------------------------------------------------------
!
! Arrays to be read in:
!
!-----------------------------------------------------------------------
!
REAL, ALLOCATABLE :: x (:) ! The x-coord. of the physical and
! computational grid. Defined at u-point.
REAL, ALLOCATABLE :: y (:) ! The y-coord. of the physical and
! computational grid. Defined at v-point.
REAL, ALLOCATABLE :: z (:) ! The z-coord. of the computational grid.
! Defined at w-point on the staggered grid.
REAL, ALLOCATABLE :: zp (:,:,:) ! The physical height coordinate defined at
! w-point of the staggered grid.
REAL, ALLOCATABLE :: j1 (:,:,:) ! Coordinate transformation Jacobian defined
! as - d( zp )/d( x )
REAL, ALLOCATABLE :: j2 (:,:,:) ! Coordinate transformation Jacobian defined
! as - d( zp )/d( y )
REAL, ALLOCATABLE :: j3 (:,:,:) ! Coordinate transformation Jacobian defined
! as d( zp )/d( z )
REAL, ALLOCATABLE :: u(:,:,:) ! Total u-velocity (m/s)
REAL, ALLOCATABLE :: v(:,:,:) ! Total v-velocity (m/s)
REAL, ALLOCATABLE :: w(:,:,:) ! Total w-velocity (m/s)
REAL, ALLOCATABLE :: pt(:,:,:) ! Total potential temperature (K)
REAL, ALLOCATABLE :: qv (:,:,:) ! Water vapor specific humidity (kg/kg)
REAL, ALLOCATABLE :: qc (:,:,:) ! Cloud water mixing ratio (kg/kg)
REAL, ALLOCATABLE :: qr (:,:,:) ! Rain water mixing ratio (kg/kg)
REAL, ALLOCATABLE :: qi (:,:,:) ! Cloud ice mixing ratio (kg/kg)
REAL, ALLOCATABLE :: qs (:,:,:) ! Snow mixing ratio (kg/kg)
REAL, ALLOCATABLE:: qh (:,:,:) ! Hail mixing ratio (kg/kg)
REAL, ALLOCATABLE :: tke (:,:,:) ! Turbulent Kinetic Energy ((m/s)**2)
REAL, ALLOCATABLE :: kmh (:,:,:) ! Horizontal turb. mixing coef. for
! momentum. ( m**2/s )
REAL, ALLOCATABLE :: kmv (:,:,:) ! Vertical turb. mixing coef. for
! momentum. ( m**2/s )
REAL, ALLOCATABLE :: ubar (:,:,:) ! Base state u-velocity (m/s)
REAL, ALLOCATABLE :: vbar (:,:,:) ! Base state v-velocity (m/s)
REAL, ALLOCATABLE :: wbar (:,:,:) ! Base state w-velocity (m/s)
REAL, ALLOCATABLE :: ptbar (:,:,:) ! Base state potential temperature (K)
REAL, ALLOCATABLE :: rhobar(:,:,:) ! Base state air density (kg/m**3)
REAL, ALLOCATABLE :: pbar (:,:,:) ! Base state pressure (Pascal)
REAL, ALLOCATABLE :: qvbar (:,:,:) ! Base state water vapor specific humidity
! (kg/kg)
INTEGER :: nstyps
PARAMETER (nstyps=4)
INTEGER, ALLOCATABLE:: soiltyp (:,:,:) ! Soil type
REAL, ALLOCATABLE :: stypfrct(:,:,:) ! Fraction of soil types
INTEGER, ALLOCATABLE :: vegtyp (:,:) ! Vegetation type
REAL, ALLOCATABLE :: lai (:,:) ! Leaf Area Index
REAL, ALLOCATABLE :: roufns (:,:) ! Surface roughness
REAL, ALLOCATABLE :: veg (:,:) ! Vegetation fraction
REAL, ALLOCATABLE :: tsfc (:,:,:) ! Temperature at surface (K)
REAL, ALLOCATABLE :: tsoil (:,:,:) ! Deep soil temperature (K)
REAL, ALLOCATABLE :: wetsfc (:,:,:) ! Surface soil moisture
REAL, ALLOCATABLE :: wetdp (:,:,:) ! Deep soil moisture
REAL, ALLOCATABLE :: wetcanp(:,:,:) ! Canopy water amount
REAL, ALLOCATABLE :: snowdpth(:,:) ! Snow depth (m)
REAL, ALLOCATABLE :: raing (:,:) ! Grid supersaturation rain
REAL, ALLOCATABLE :: rainc (:,:) ! Cumulus convective rain
REAL, ALLOCATABLE :: prcrate(:,:,:) ! precipitation rate (kg/(m**2*s))
! prcrate(1,1,1) = total precip. rate
! prcrate(1,1,2) = grid scale precip. rate
! prcrate(1,1,3) = cumulus precip. rate
! prcrate(1,1,4) = microphysics precip. rate
REAL, ALLOCATABLE :: radfrc(:,:,:) ! Radiation forcing (K/s)
REAL , ALLOCATABLE:: radsw (:,:) ! Solar radiation reaching the surface
REAL, ALLOCATABLE :: rnflx (:,:) ! Net radiation flux absorbed by surface
REAL, ALLOCATABLE :: usflx (:,:) ! Surface flux of u-momentum (kg/(m*s**2))
REAL, ALLOCATABLE :: vsflx (:,:) ! Surface flux of v-momentum (kg/(m*s**2))
REAL, ALLOCATABLE :: ptsflx(:,:) ! Surface heat flux (K*kg/(m*s**2))
REAL, ALLOCATABLE :: qvsflx(:,:) ! Surface moisture flux (kg/(m**2*s))
REAL, ALLOCATABLE :: uprt (:,:,:) ! Perturbation u-velocity (m/s)
REAL, ALLOCATABLE :: vprt (:,:,:) ! Perturbation v-velocity (m/s)
REAL, ALLOCATABLE :: wprt (:,:,:) ! Perturbation w-velocity (m/s)
REAL, ALLOCATABLE :: ptprt (:,:,:) ! Perturbation potential temperature (K)
REAL, ALLOCATABLE :: pprt (:,:,:) ! Perturbation pressure (Pascal)
REAL, ALLOCATABLE :: rhoprt(:,:,:) ! Perturbation air density (kg/m**3)
REAL, ALLOCATABLE :: qvprt (:,:,:) ! Perturbation water vapor specific
! humidity (kg/kg)
!
!-----------------------------------------------------------------------
!
! Other data variables
!
!-----------------------------------------------------------------------
!
REAL :: time
!
!-----------------------------------------------------------------------
!
! Temporary working arrays:
!
!-----------------------------------------------------------------------
!
REAL, ALLOCATABLE :: tem1(:,:,:)
REAL, ALLOCATABLE :: tem2(:,:,:)
REAL, ALLOCATABLE :: tem3(:,:,:)
REAL, ALLOCATABLE :: tem1d1(:),tem1d2(:),tem1d3(:),tem1d4(:), &
tem1d5(:), tem1d6(:),tem1d7(:),tem1d8(:),tem1d9(:)
!
!-----------------------------------------------------------------------
!
! "Fake" radar id stuff
!
!-----------------------------------------------------------------------
!
INTEGER :: iretfmt
CHARACTER (LEN=80) :: retfname
PARAMETER(iretfmt=1)
CHARACTER (LEN=4) :: radid
REAL :: latrad,lonrad,elvrad
PARAMETER(radid='KTLX', &
latrad=35.3331, &
lonrad=-97.2778, &
elvrad=389.4)
!
!-----------------------------------------------------------------------
!
! Misc internal variables
!
!-----------------------------------------------------------------------
!
REAL, ALLOCATABLE :: xsc(:)
REAL, ALLOCATABLE :: ysc(:)
REAL, ALLOCATABLE :: zpsc(:,:,:)
REAL :: latnot(2)
!
INTEGER :: i,j,k,ireturn
INTEGER :: istride,jstride,kstride
PARAMETER (istride=2, &
jstride=2, &
kstride=1)
CHARACTER (LEN=80) :: filename
CHARACTER (LEN=80) :: grdbasfn
INTEGER :: ngchan,nchanl,lenfil,lengbf
INTEGER :: nchin,iyr
INTEGER :: istatus
!----------------------------------------------------------------------
!
! NAMELIST declaration
!
!----------------------------------------------------------------------
NAMELIST /grid_dims/ nx, ny, nz
NAMELIST /input_fn/ hdmpfmt, grdbasfn, filename
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
WRITE(6,'(/11(/5x,a)/)') &
'###############################################################', &
'###############################################################', &
'### ###', &
'### Welcome to ARPSPRT ###', &
'### This program reads in the history dump data ###', &
'### sets generated by ARPS, and prints the array ###', &
'### contents as 2-D arrays tables at user specified ###', &
'### slices. ###', &
'### ###', &
'###############################################################', &
'###############################################################'
READ(5,grid_dims,END=100)
WRITE(6,'(/a)') 'Namelist block grid_dims successfully read.'
!-----------------------------------------------------------------------
!
! Allocate all arrays and fill them with zero, which is the default
! value of the data arrays.
!
!-----------------------------------------------------------------------
!
ALLOCATE( x=0
ALLOCATE( y=0
ALLOCATE( z=0
ALLOCATE(zp(nx,ny,nz),STAT=istatus)
zp=0
ALLOCATE(j1(nx,ny,nz),STAT=istatus)
j1=0
ALLOCATE(j2(nx,ny,nz),STAT=istatus)
j2=0
ALLOCATE(j3(nx,ny,nz),STAT=istatus)
j3=0
ALLOCATE( u=0
ALLOCATE( v=0
ALLOCATE( w=0
ALLOCATE(pt(nx,ny,nz),STAT=istatus)
pt=0
ALLOCATE(qv(nx,ny,nz),STAT=istatus)
qv=0
ALLOCATE(qc(nx,ny,nz),STAT=istatus)
qc=0
ALLOCATE(qr(nx,ny,nz),STAT=istatus)
qr=0
ALLOCATE(qi(nx,ny,nz),STAT=istatus)
qi=0
ALLOCATE(qs(nx,ny,nz),STAT=istatus)
qs=0
ALLOCATE(qh(nx,ny,nz),STAT=istatus)
qh=0
ALLOCATE(tke(nx,ny,nz),STAT=istatus)
tke=0
ALLOCATE(kmh(nx,ny,nz),STAT=istatus)
kmh=0
ALLOCATE(kmv(nx,ny,nz),STAT=istatus)
kmv=0
ALLOCATE(ubar(nx,ny,nz),STAT=istatus)
ubar=0
ALLOCATE(vbar(nx,ny,nz),STAT=istatus)
vbar=0
ALLOCATE(wbar(nx,ny,nz),STAT=istatus)
wbar=0
ALLOCATE(ptbar(nx,ny,nz),STAT=istatus)
ptbar=0
ALLOCATE(rhobar(nx,ny,nz),STAT=istatus)
rhobar=0
ALLOCATE(pbar(nx,ny,nz),STAT=istatus)
pbar=0
ALLOCATE(qvbar(nx,ny,nz),STAT=istatus)
qvbar=0
ALLOCATE(soiltyp(nx,ny,nstyps),STAT=istatus)
soiltyp=0
ALLOCATE(stypfrct(nx,ny,nstyps),STAT=istatus)
stypfrct=0
ALLOCATE(vegtyp(nx,ny),STAT=istatus)
vegtyp=0
ALLOCATE(lai(nx,ny),STAT=istatus)
lai=0
ALLOCATE(roufns(nx,ny),STAT=istatus)
roufns=0
ALLOCATE(veg(nx,ny),STAT=istatus)
veg=0
ALLOCATE(tsfc(nx,ny,0:nstyps),STAT=istatus)
tsfc=0
ALLOCATE(tsoil(nx,ny,0:nstyps),STAT=istatus)
tsoil=0
ALLOCATE(wetsfc(nx,ny,0:nstyps),STAT=istatus)
wetsfc=0
ALLOCATE(wetdp(nx,ny,0:nstyps),STAT=istatus)
wetdp=0
ALLOCATE(wetcanp(nx,ny,0:nstyps),STAT=istatus)
wetcanp=0
ALLOCATE(snowdpth(nx,ny),STAT=istatus)
snowdpth=0
ALLOCATE(raing(nx,ny),STAT=istatus)
raing=0
ALLOCATE(rainc(nx,ny),STAT=istatus)
rainc=0
ALLOCATE(prcrate(nx,ny,4),STAT=istatus)
prcrate=0
ALLOCATE(radfrc(nx,ny,nz),STAT=istatus)
radfrc=0
ALLOCATE(radsw(nx,ny),STAT=istatus)
radsw=0
ALLOCATE(rnflx(nx,ny),STAT=istatus)
rnflx=0
ALLOCATE(usflx(nx,ny),STAT=istatus)
usflx=0
ALLOCATE(vsflx(nx,ny),STAT=istatus)
vsflx=0
ALLOCATE(ptsflx(nx,ny),STAT=istatus)
ptsflx=0
ALLOCATE(qvsflx(nx,ny),STAT=istatus)
qvsflx=0
ALLOCATE(uprt(nx,ny,nz),STAT=istatus)
uprt=0
ALLOCATE(vprt(nx,ny,nz),STAT=istatus)
vprt=0
ALLOCATE(wprt(nx,ny,nz),STAT=istatus)
wprt=0
ALLOCATE(ptprt(nx,ny,nz),STAT=istatus)
ptprt=0
ALLOCATE(pprt(nx,ny,nz),STAT=istatus)
pprt=0
ALLOCATE(rhoprt(nx,ny,nz),STAT=istatus)
rhoprt=0
ALLOCATE(qvprt(nx,ny,nz),STAT=istatus)
qvprt=0
!-----------------------------------------------------------------------
!
! Get the name of the input data set.
!
!-----------------------------------------------------------------------
!
READ(5,input_fn,END=100)
WRITE(6,'(/a,a)')' Namelist block input_fn successfully read in.'
lengbf=LEN_trim(grdbasfn)
lenfil=LEN_trim(filename)
WRITE(6,'(/a,a)')' The data set name is ', filename(1:lenfil)
!
!-----------------------------------------------------------------------
!
! Read all input data arrays
!
!-----------------------------------------------------------------------
!
CALL dtaread
(nx,ny,nz,nstyps, &
hdmpfmt,nchin,grdbasfn(1:lengbf),lengbf, &
filename(1:lenfil),lenfil,time, &
x,y,z,zp, uprt ,vprt ,wprt ,ptprt, pprt , &
qvprt, qc, qr, qi, qs, qh, tke,kmh,kmv, &
ubar, vbar, wbar, ptbar, pbar, rhobar, qvbar, &
soiltyp,stypfrct,vegtyp,lai,roufns,veg, &
tsfc,tsoil,wetsfc,wetdp,wetcanp,snowdpth, &
raing,rainc,prcrate, &
radfrc,radsw,rnflx, &
usflx,vsflx,ptsflx,qvsflx, &
ireturn, tem1,tem2,tem3)
curtim = time
!
!-----------------------------------------------------------------------
!
! ireturn = 0 for a successful read
!
!-----------------------------------------------------------------------
!
IF( ireturn == 0 ) THEN ! successful read
DO i=1,nx-1
xsc(i)=0.5*(x(i)+x(i+1))
END DO
xsc(nx)=2.*xsc(nx-1)-xsc(nx-2)
DO j=1,ny-1
ysc(j)=0.5*(y(i)+y(i+1))
END DO
ysc(ny)=2.*ysc(ny-1)-ysc(ny-2)
DO k=1,nz-1
DO j=1,ny-1
DO i=1,nx-1
zpsc(i,j,k)=0.5*(zp(i,j,k)+zp(i,j,k+1))
tem1(i,j,k)=0.5*(uprt( i,j,k)+ubar( i,j,k) &
+uprt(i+1,j,k)+ubar(i+1,j,k))
tem2(i,j,k)=0.5*(vprt(i, j,k)+vbar(i, j,k) &
+vprt(1,j+1,k)+vbar(i,j+1,k))
IF(MOD(i,istride) == 0 .AND. MOD(j,jstride) == 0 .AND. &
MOD(k,kstride) == 0 ) THEN
tem3(i,j,k)=1.0
ELSE
tem3(i,j,k)=-999.
END IF
END DO
END DO
END DO
latnot(1) = trulat1
latnot(2) = trulat2
CALL setmapr(mapproj,1.0,latnot,trulon)
iyr=MOD(year,100)
WRITE(retfname,'(a,a,i2.2,i2.2,i2.2,a,i2.2,i2.2)') &
radid,'.',iyr,month,day,'.',hour,minute
PRINT *, ' Writing data into ',retfname
CALL wtretcol(nx,ny,nz, &
2,nx-2,2,ny-2,2,nz-2, &
iyr,month,day,hour,minute,second, &
iretfmt,retfname,radid,latrad,lonrad,elvrad, &
xsc,ysc,zpsc, &
tem1,tem2,ptprt,pprt,qvprt,qr, &
ptbar,pbar,qvbar,tem3, &
tem1d1,tem1d2,tem1d3,tem1d4, &
tem1d5,tem1d6,tem1d7,tem1d8,tem1d9)
END IF ! successful read
GOTO 101
100 CONTINUE
WRITE(6,'(/a,a)') 'Error reading NAMELIST file. The program will abort.'
101 CONTINUE
STOP
END PROGRAM testret
!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE WTRETCOL ######
!###### ######
!###### Developed by ######
!###### Center for Analysis and Prediction of Storms ######
!###### University of Oklahoma ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE wtretcol(nx,ny,nz, & 2,9
ibeg,iend,jbeg,jend,kbeg,kend, &
iyr,imon,iday,ihr,imin,isec, &
iretfmt,retfname,radid,latrad,lonrad,elvrad, &
xsc,ysc,zpsc, &
us,vs,ptprt,pprt,qvprt,qr, &
ptbar,pbar,qvbar,retrflg, &
outk,outhgt,outu,outv, &
outpr,outpt,outqv,outqr,outret)
!
!-----------------------------------------------------------------------
!
! PURPOSE:
!
! Test writing of retrieval columns.
!
!-----------------------------------------------------------------------
!
! AUTHOR: Keith Brewster
!
! MODIFICATION HISTORY:
!
!-----------------------------------------------------------------------
!
! Writes gridded radar data to a file
!
! INPUT
!
! x x coordinate of grid points in physical/comp. space (m)
! y y coordinate of grid points in physical/comp. space (m)
! z z coordinate of grid points in computational space (km)
! zp z coordinate of grid points in computational space (m)
!
! uprt x component of perturbation velocity (m/s)
! vprt y component of perturbation velocity (m/s)
! wprt Vertical component of perturbation velocity in Cartesian
! coordinates (m/s).
!
! ptprt Perturbation potential temperature (K)
! pprt Perturbation pressure (Pascal)
!
! qvprt Perturbation water vapor mixing ratio (kg/kg)
! qc Cloud water mixing ratio (kg/kg)
! qr Rainwater mixing ratio (kg/kg)
! qi Cloud ice mixing ratio (kg/kg)
! qs Snow mixing ratio (kg/kg)
! qh Hail mixing ratio (kg/kg)
!
! ubar Base state x velocity component (m/s)
! vbar Base state y velocity component (m/s)
! wbar Base state z velocity component (m/s)
! ptbar Base state potential temperature (K)
! pbar Base state pressure (Pascal)
! rhobar Base state air density (kg/m**3)
! qvbar Base state water vapor mixing ratio (kg/kg)
! qr Rainwater mixing ratio (kg/kg)
!
!-----------------------------------------------------------------------
!
!
IMPLICIT NONE
!
INTEGER :: nx,ny,nz
INTEGER :: ibeg,iend,jbeg,jend,kbeg,kend
!
REAL :: xsc(nx)
REAL :: ysc(ny)
REAL :: zpsc(nx,ny,nz)
REAL :: us(nx,ny,nz) ! total u velocity component at scalar points
REAL :: vs(nx,ny,nz) ! total v velocity component at scalar points
REAL :: ptprt (nx,ny,nz) ! Perturbation potential temperature (K)
REAL :: pprt (nx,ny,nz) ! Perturbation pressure (Pascal)
REAL :: qvprt (nx,ny,nz) ! Perturbation water vapor specific
! humidity (kg/kg)
REAL :: qr (nx,ny,nz) ! Rain water mixing ratio (kg/kg)
REAL :: ptbar (nx,ny,nz) ! Base state potential temperature (K)
REAL :: pbar (nx,ny,nz) ! Base state pressure (Pascal)
REAL :: qvbar (nx,ny,nz) ! Base state water vapor specific humidity
! (kg/kg)
REAL :: retrflg(nx,ny,nz)
!
INTEGER :: iretfmt
CHARACTER (LEN=80) :: retfname
CHARACTER (LEN=4) :: radid
REAL :: latrad
REAL :: lonrad
REAL :: elvrad
INTEGER :: iyr,imon,iday,ihr,imin,isec
!
!-----------------------------------------------------------------------
!
! Retrieval output variables
!
!-----------------------------------------------------------------------
!
REAL :: outk(nz)
REAL :: outhgt(nz)
REAL :: outu(nz)
REAL :: outv(nz)
REAL :: outpr(nz)
REAL :: outpt(nz)
REAL :: outqv(nz)
REAL :: outqr(nz)
REAL :: outret(nz)
!
!-----------------------------------------------------------------------
!
! Retrieved data threshold
!
!-----------------------------------------------------------------------
!
REAL :: retrthr
PARAMETER(retrthr=0.)
!
!-----------------------------------------------------------------------
!
! Include file
!
!-----------------------------------------------------------------------
!
INCLUDE 'globcst.inc'
INCLUDE 'grid.inc'
!
!-----------------------------------------------------------------------
!
! Misc. local variables
!
!-----------------------------------------------------------------------
!
INTEGER :: iunit,myr,itime
INTEGER :: i,j,k,klev,kk,kntcol
INTEGER :: nradvr,iradvr,ireftim,idummy
REAL :: gridlat,gridlon,elev,rdummy
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
myr=1900+iyr
IF(myr < 1960) myr=myr+100
CALL ctim2abss(myr,imon,iday,ihr,imin,isec,itime)
!
CALL getunit(iunit)
!
! Open file for output
!
OPEN(iunit,FILE=retfname,STATUS='unknown', &
FORM='unformatted')
!
! Write retrieval description variables
!
WRITE(iunit) radid
WRITE(iunit) ireftim,itime,idummy,idummy,idummy, &
idummy,idummy,idummy,idummy,idummy
!
! Write grid description variables
! This should provide enough info to verify that the
! proper grid has been chosen. To recreate the grid,
! icluding elevation information,
! the reading program should get a grid-base-file
! named runname.grdbasfil
!
idummy=0
rdummy=0.
WRITE(iunit) runname
WRITE(iunit) hdmpfmt,strhopt,mapproj,idummy,idummy, &
idummy,idummy,idummy,idummy,idummy
WRITE(iunit) dx,dy,dz,dzmin,ctrlat, &
ctrlon,trulat1,trulat2,trulon,sclfct, &
latrad,lonrad,elvrad,rdummy,rdummy
WRITE(iunit) nradvr,iradvr
!
! For each horizontal grid point form a column of remapped
! data containing the non-missing grid points
!
kntcol=0
DO j=jbeg,jend
DO i=ibeg,iend
klev=0
DO k=kbeg,kend
IF(retrflg(i,j,k) > retrthr) THEN
klev=klev+1
outk(klev)=FLOAT(k)
outhgt(klev)=zpsc(i,j,k)
outu(klev)=us(i,j,k)
outv(klev)=vs(i,j,k)
outpr(klev)=pprt(i,j,k)+pbar(i,j,k)
outpt(klev)=ptprt(i,j,k)+ptbar(i,j,k)
outqv(klev)=qvprt(i,j,k)+qvbar(i,j,k)
outqr(klev)=qr(i,j,k)
outret(klev)=retrflg(i,j,k)
END IF
END DO
!
! If there are data in this column, write them to the file.
!
IF(klev > 0) THEN
kntcol=kntcol+1
CALL xytoll(1,1,xsc(i),ysc(j),gridlat,gridlon)
elev=0.5*(zpsc(i,j,1)+zpsc(i,j,2))
WRITE(iunit) i,j,xsc(i),ysc(j), &
gridlat,gridlon,elev,klev
WRITE(iunit) (outk(kk),kk=1,klev)
WRITE(iunit) (outhgt(kk),kk=1,klev)
WRITE(iunit) (outu(kk),kk=1,klev)
WRITE(iunit) (outv(kk),kk=1,klev)
WRITE(iunit) (outpr(kk),kk=1,klev)
WRITE(iunit) (outpt(kk),kk=1,klev)
WRITE(iunit) (outqv(kk),kk=1,klev)
WRITE(iunit) (outqr(kk),kk=1,klev)
WRITE(iunit) (outret(kk),kk=1,klev)
END IF
END DO
END DO
!
CLOSE(iunit)
CALL retunit(iunit)
!
! Report on what data were written
!
WRITE(6,'(//a,i2.2,i2.2,i2.2,a1,i2.2,a1,i2.2)') &
' Output statistics for time ', &
iyr,imon,iday,' ',ihr,':',imin
WRITE(6,'(a,i6,a,/a,i6,a//)') &
' There were ',kntcol,' columns written ', &
' of a total ',(nx*ny),' possible.'
!
RETURN
END SUBROUTINE wtretcol