!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE INCRSAVE ######
!###### ######
!###### Center for Analysis and Prediction of Storms ######
!###### University of Oklahoma. ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE incrsave(nx,ny,nz,nxndg,nyndg,nzndg, & 2
u,v,w,pprt,ptprt,qv, &
qc,qr,qi,qs,qh, &
uincr,vincr,wincr,pincr,ptincr,qvincr, &
qcincr,qrincr,qiincr,qsincr,qhincr, &
istatus)
!
!-----------------------------------------------------------------------
!
! PURPOSE: Save the original background field in the incrememt
! arrays for later computiona of the total analysis increment.
!
!-----------------------------------------------------------------------
!
! AUTHOR: Keith Brewster
! March 1998
!
! MODIFICATION HISTORY:
!
! 07/10/2001 (K. Brewster)
! Changed to accomodate dynamically allocated increment arrays.
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
INTEGER :: nx,ny,nz
INTEGER :: nxndg,nyndg,nzndg
!
REAL :: u(nx,ny,nz)
REAL :: v(nx,ny,nz)
REAL :: w(nx,ny,nz)
REAL :: pprt(nx,ny,nz)
REAL :: ptprt(nx,ny,nz)
REAL :: qv(nx,ny,nz)
REAL :: qc(nx,ny,nz)
REAL :: qr(nx,ny,nz)
REAL :: qi(nx,ny,nz)
REAL :: qs(nx,ny,nz)
REAL :: qh(nx,ny,nz)
!
REAL :: uincr(nxndg,nyndg,nzndg)
REAL :: vincr(nxndg,nyndg,nzndg)
REAL :: wincr(nxndg,nyndg,nzndg)
REAL :: pincr(nxndg,nyndg,nzndg)
REAL :: ptincr(nxndg,nyndg,nzndg)
REAL :: qvincr(nxndg,nyndg,nzndg)
REAL :: qcincr(nxndg,nyndg,nzndg)
REAL :: qrincr(nxndg,nyndg,nzndg)
REAL :: qiincr(nxndg,nyndg,nzndg)
REAL :: qsincr(nxndg,nyndg,nzndg)
REAL :: qhincr(nxndg,nyndg,nzndg)
INTEGER :: istatus
!
!-----------------------------------------------------------------------
!
! Misc local variables
!
!-----------------------------------------------------------------------
!
INTEGER :: i,j,k
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
DO k=1,nzndg
DO j=1,nyndg
DO i=1,nxndg
uincr(i,j,k) = u(i,j,k)
vincr(i,j,k) = v(i,j,k)
wincr(i,j,k) = w(i,j,k)
pincr(i,j,k) = pprt(i,j,k)
ptincr(i,j,k)=ptprt(i,j,k)
qvincr(i,j,k)= qv(i,j,k)
qcincr(i,j,k)= qc(i,j,k)
qrincr(i,j,k)= qr(i,j,k)
qiincr(i,j,k)= qi(i,j,k)
qsincr(i,j,k)= qs(i,j,k)
qhincr(i,j,k)= qh(i,j,k)
END DO
END DO
END DO
RETURN
END SUBROUTINE incrsave
!
!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE INCRCALC ######
!###### ######
!###### Center for Analysis and Prediction of Storms ######
!###### University of Oklahoma. ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE incrcalc(nx,ny,nz,nxndg,nyndg,nzndg, & 2
u,v,w,pprt,ptprt,qv, &
qc,qr,qi,qs,qh, &
uincr,vincr,wincr,pincr,ptincr,qvincr, &
qcincr,qrincr,qiincr,qsincr,qhincr, &
istatus)
!
!-----------------------------------------------------------------------
!
! PURPOSE: Calculate total analysis increment by subtracting
! the analyzed fields from the original background fields which
! were temporarily held in the incr arrays.
!
!-----------------------------------------------------------------------
!
! AUTHOR: Keith Brewster
! March 1998
!
! MODIFICATION HISTORY:
!
! 07/10/2001 (K. Brewster)
! Changed to accomodate dynamically allocated increment arrays.
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
INTEGER :: nx,ny,nz
INTEGER :: nxndg,nyndg,nzndg
!
REAL :: u(nx,ny,nz)
REAL :: v(nx,ny,nz)
REAL :: w(nx,ny,nz)
REAL :: pprt(nx,ny,nz)
REAL :: ptprt(nx,ny,nz)
REAL :: qv(nx,ny,nz)
REAL :: qc(nx,ny,nz)
REAL :: qr(nx,ny,nz)
REAL :: qi(nx,ny,nz)
REAL :: qs(nx,ny,nz)
REAL :: qh(nx,ny,nz)
!
REAL :: uincr(nxndg,nyndg,nzndg)
REAL :: vincr(nxndg,nyndg,nzndg)
REAL :: wincr(nxndg,nyndg,nzndg)
REAL :: pincr(nxndg,nyndg,nzndg)
REAL :: ptincr(nxndg,nyndg,nzndg)
REAL :: qvincr(nxndg,nyndg,nzndg)
REAL :: qcincr(nxndg,nyndg,nzndg)
REAL :: qrincr(nxndg,nyndg,nzndg)
REAL :: qiincr(nxndg,nyndg,nzndg)
REAL :: qsincr(nxndg,nyndg,nzndg)
REAL :: qhincr(nxndg,nyndg,nzndg)
INTEGER :: istatus
!
!-----------------------------------------------------------------------
!
! Misc local variables
!
!-----------------------------------------------------------------------
!
INTEGER :: i,j,k
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
DO k=1,nzndg
DO j=1,nyndg
DO i=1,nxndg
uincr(i,j,k) = u(i,j,k)- uincr(i,j,k)
vincr(i,j,k) = v(i,j,k)- vincr(i,j,k)
wincr(i,j,k) = w(i,j,k)- wincr(i,j,k)
pincr(i,j,k) = pprt(i,j,k)- pincr(i,j,k)
ptincr(i,j,k)=ptprt(i,j,k)-ptincr(i,j,k)
qvincr(i,j,k)= qv(i,j,k)-qvincr(i,j,k)
qcincr(i,j,k)= qc(i,j,k)-qcincr(i,j,k)
qrincr(i,j,k)= qr(i,j,k)-qrincr(i,j,k)
qiincr(i,j,k)= qi(i,j,k)-qiincr(i,j,k)
qsincr(i,j,k)= qs(i,j,k)-qsincr(i,j,k)
qhincr(i,j,k)= qh(i,j,k)-qhincr(i,j,k)
END DO
END DO
END DO
RETURN
END SUBROUTINE incrcalc
!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE INCRDUMP ######
!###### ######
!###### Center for Analysis and Prediction of Storms ######
!###### University of Oklahoma. ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE incrdump(nxndg,nyndg,nzndg,incrdmp,incrcompr,incrfnam, & 2,46
uincr,vincr,wincr,pincr,ptincr,qvincr, &
qcincr,qrincr,qiincr,qsincr,qhincr, &
uincdmp,vincdmp,wincdmp, &
pincdmp,ptincdmp,qvincdmp, &
qcincdmp,qrincdmp,qiincdmp,qsincdmp,qhincdmp, &
istatus)
!
!-----------------------------------------------------------------------
!
! PURPOSE:
!
! Write analysis increments shift vectors to a file for use in
! Newtonian nudging assimilation.
!
!-----------------------------------------------------------------------
!
! AUTHOR: Keith Brewster
! March, 1998
!
!-----------------------------------------------------------------------
!
! INPUT :
!
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
INTEGER :: nxndg,nyndg,nzndg
INTEGER :: incrdmp ! Option to write ADAS analysis increments
! to a file
! = 0, Don't create increment file;
! = 1, write increment file
! (unformatted IEEE binary);
! = 3, write HDF format increment file.
INTEGER :: incrcompr ! HDF4 compressed option
CHARACTER (LEN=*) :: incrfnam
REAL :: uincr(nxndg,nyndg,nzndg)
REAL :: vincr(nxndg,nyndg,nzndg)
REAL :: wincr(nxndg,nyndg,nzndg)
REAL :: pincr(nxndg,nyndg,nzndg)
REAL :: ptincr(nxndg,nyndg,nzndg)
REAL :: qvincr(nxndg,nyndg,nzndg)
REAL :: qcincr(nxndg,nyndg,nzndg)
REAL :: qrincr(nxndg,nyndg,nzndg)
REAL :: qiincr(nxndg,nyndg,nzndg)
REAL :: qsincr(nxndg,nyndg,nzndg)
REAL :: qhincr(nxndg,nyndg,nzndg)
!
INTEGER :: uincdmp,vincdmp,wincdmp,pincdmp,ptincdmp,qvincdmp, &
qcincdmp,qrincdmp,qiincdmp,qsincdmp,qhincdmp
!
INTEGER :: istatus
!
!-----------------------------------------------------------------------
!
! Misc local variables
!
!-----------------------------------------------------------------------
!
INTEGER :: i4time
INTEGER :: nchinc,ierr
INTEGER (KIND=selected_int_kind(4)), ALLOCATABLE :: itmp(:,:,:)
REAL, allocatable :: hmax(:), hmin(:) ! Temporary array
INTEGER :: sd_id, stat
!-----------------------------------------------------------------------
!
! Include files
!
!-----------------------------------------------------------------------
!
INCLUDE 'globcst.inc'
INCLUDE 'grid.inc' ! Grid parameters
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
IF (incrdmp == 0) RETURN
IF (incrcompr > 3) THEN
allocate (itmp(nxndg,nyndg,nzndg),stat=stat)
IF (stat /= 0) THEN
WRITE (6,*) "INCRDUMP: ERROR allocating itmp, returning"
RETURN
END IF
allocate (hmax(nzndg),stat=stat)
IF (stat /= 0) THEN
WRITE (6,*) "INCRDUMP: ERROR allocating hmax, returning"
RETURN
END IF
allocate (hmin(nzndg),stat=stat)
IF (stat /= 0) THEN
WRITE (6,*) "INCRDUMP: ERROR allocating hmin, returning"
RETURN
END IF
END IF
!-----------------------------------------------------------------------
!
! Write out in Fortran unformatted.
!
!-----------------------------------------------------------------------
IF (incrdmp == 1) THEN
CALL getunit
(nchinc)
CALL asnctl ('NEWLOCAL', 1, ierr)
CALL asnfile(incrfnam,'-F f77 -N ieee', ierr)
OPEN(nchinc,FILE=TRIM(incrfnam),ERR=950, &
FORM='unformatted',STATUS='unknown')
GO TO 900
950 CONTINUE
WRITE(6,'(/a,a,a/)') &
'INCRDUMP: Error opening analysis increment output file: ', &
TRIM(incrfnam),'. No file was written.'
istatus = -1
RETURN
900 CONTINUE
!
CALL ctim2abss( year,month,day,hour,minute,second, i4time)
WRITE(nchinc) runname,nxndg,nyndg,nzndg,i4time, &
year,month,day,hour,minute,second
!
WRITE(nchinc) mapproj,trulat1,trulat2,trulon, &
sclfct,ctrlat,ctrlon
!
WRITE(nchinc) uincdmp,vincdmp,wincdmp,pincdmp,ptincdmp,qvincdmp, &
qcincdmp,qrincdmp,qiincdmp,qsincdmp,qhincdmp
!
IF(uincdmp > 0) THEN
WRITE(nchinc) 'uinc '
WRITE(nchinc) uincr
END IF
IF(vincdmp > 0) THEN
WRITE(nchinc) 'vinc '
WRITE(nchinc) vincr
END IF
IF(wincdmp > 0) THEN
WRITE(nchinc) 'winc '
WRITE(nchinc) wincr
END IF
IF(pincdmp > 0) THEN
WRITE(nchinc) 'pinc '
WRITE(nchinc) pincr
END IF
IF(ptincdmp > 0) THEN
WRITE(nchinc) 'ptinc '
WRITE(nchinc) ptincr
END IF
IF(qvincdmp > 0) THEN
WRITE(nchinc) 'qvinc '
WRITE(nchinc) qvincr
END IF
IF(qcincdmp > 0) THEN
WRITE(nchinc) 'qcinc '
WRITE(nchinc) qcincr
END IF
IF(qrincdmp > 0) THEN
WRITE(nchinc) 'qrinc '
WRITE(nchinc) qrincr
END IF
IF(qiincdmp > 0) THEN
WRITE(nchinc) 'qiinc '
WRITE(nchinc) qiincr
END IF
IF(qsincdmp > 0) THEN
WRITE(nchinc) 'qsinc '
WRITE(nchinc) qsincr
END IF
IF(qhincdmp > 0) THEN
WRITE(nchinc) 'qhinc '
WRITE(nchinc) qhincr
END IF
!
CLOSE(nchinc)
CALL retunit(nchinc)
!-----------------------------------------------------------------------
!
! Write out in HDF4.
!
!-----------------------------------------------------------------------
ELSE IF (incrdmp == 3) THEN
CALL hdfopen(TRIM(incrfnam), 2, sd_id)
IF (sd_id < 0) THEN
WRITE(6,'(/a,a,a/)') &
'INCRDUMP: Error opening analysis increment output file: ', &
TRIM(incrfnam),'. No file was written.'
istatus = -1
RETURN
END IF
CALL ctim2abss( year,month,day,hour,minute,second, i4time)
CALL hdfwrti(sd_id, 'i4time', i4time, stat)
CALL hdfwrti(sd_id, 'day', day, stat)
CALL hdfwrti(sd_id, 'year', year, stat)
CALL hdfwrti(sd_id, 'month', month, stat)
CALL hdfwrti(sd_id, 'hour', hour, stat)
CALL hdfwrti(sd_id, 'minute', minute, stat)
CALL hdfwrti(sd_id, 'second', second, stat)
CALL hdfwrti(sd_id, 'nx', nxndg, stat)
CALL hdfwrti(sd_id, 'ny', nyndg, stat)
CALL hdfwrti(sd_id, 'nz', nzndg, stat)
CALL hdfwrtr(sd_id, 'dx', dx, stat)
CALL hdfwrtr(sd_id, 'dy', dy, stat)
CALL hdfwrtr(sd_id, 'dz', dz, stat)
CALL hdfwrtr(sd_id, 'dzmin', dzmin, stat)
CALL hdfwrti(sd_id, 'strhopt', strhopt, stat)
CALL hdfwrtr(sd_id, 'zrefsfc', zrefsfc, stat)
CALL hdfwrtr(sd_id, 'dlayer1', dlayer1, stat)
CALL hdfwrtr(sd_id, 'dlayer2', dlayer2, stat)
CALL hdfwrtr(sd_id, 'zflat', zflat, stat)
CALL hdfwrtr(sd_id, 'strhtune', strhtune, stat)
CALL hdfwrti(sd_id, 'mapproj', mapproj, stat)
CALL hdfwrtr(sd_id, 'trulat1', trulat1, stat)
CALL hdfwrtr(sd_id, 'trulat2', trulat2, stat)
CALL hdfwrtr(sd_id, 'trulon', trulon, stat)
CALL hdfwrtr(sd_id, 'sclfct', sclfct, stat)
CALL hdfwrtr(sd_id, 'ctrlat', ctrlat, stat)
CALL hdfwrtr(sd_id, 'ctrlon', ctrlon, stat)
IF(uincdmp > 0) THEN
CALL hdfwrt3d(uincr,nxndg,nyndg,nzndg,sd_id,1,incrcompr, &
'uincr','u-velocity increment','m/s', &
itmp,hmax,hmin)
END IF
IF(vincdmp > 0) THEN
CALL hdfwrt3d(vincr,nxndg,nyndg,nzndg,sd_id,1,incrcompr, &
'vincr','v-velocity increment','m/s', &
itmp,hmax,hmin)
END IF
IF(wincdmp > 0) THEN
CALL hdfwrt3d(wincr,nxndg,nyndg,nzndg,sd_id,1,incrcompr, &
'wincr','w-velocity increment','m/s', &
itmp,hmax,hmin)
END IF
IF(pincdmp > 0) THEN
CALL hdfwrt3d(pincr,nxndg,nyndg,nzndg,sd_id,1,incrcompr, &
'pincr','Pressure increment','Pascal', &
itmp,hmax,hmin)
END IF
IF(ptincdmp > 0) THEN
CALL hdfwrt3d(ptincr,nxndg,nyndg,nzndg,sd_id,1,incrcompr, &
'ptincr','Potential temperature increment','K', &
itmp,hmax,hmin)
END IF
IF(qvincdmp > 0) THEN
CALL hdfwrt3d(qvincr,nxndg,nyndg,nzndg,sd_id,1,incrcompr, &
'qvincr','Water vapor specific humidity increment','kg/kg', &
itmp,hmax,hmin)
END IF
IF(qcincdmp > 0) THEN
CALL hdfwrt3d(qcincr,nxndg,nyndg,nzndg,sd_id,1,incrcompr, &
'qcincr','Cloud water mixing ratio increment','kg/kg', &
itmp,hmax,hmin)
END IF
IF(qrincdmp > 0) THEN
CALL hdfwrt3d(qrincr,nxndg,nyndg,nzndg,sd_id,1,incrcompr, &
'qrincr','Rain water mixing ratio increment','kg/kg', &
itmp,hmax,hmin)
END IF
IF(qiincdmp > 0) THEN
CALL hdfwrt3d(qiincr,nxndg,nyndg,nzndg,sd_id,1,incrcompr, &
'qiincr','Cloud ice mixing ratio increment','kg/kg', &
itmp,hmax,hmin)
END IF
IF(qsincdmp > 0) THEN
CALL hdfwrt3d(qsincr,nxndg,nyndg,nzndg,sd_id,1,incrcompr, &
'qsincr','Snow mixing ratio increment','kg/kg', &
itmp,hmax,hmin)
END IF
IF(qhincdmp > 0) THEN
CALL hdfwrt3d(qhincr,nxndg,nyndg,nzndg,sd_id,1,incrcompr, &
'qhincr','Hail mixing ratio increment','kg/kg', &
itmp,hmax,hmin)
END IF
CALL hdfclose(sd_id,stat)
deallocate (itmp,stat=stat)
deallocate (hmax,stat=stat)
deallocate (hmin,stat=stat)
ELSE
! alternate dump format ...
WRITE(6,*) 'The supported increment data dump format are ', &
'binary (incrdmp=1) and HDF4 (incrdmp = 3).'
CALL arpsstop('Increment data dump format is not supported.',1)
END IF
WRITE(6,'(/a,a,a/)') &
'INCRDUMP: Successfully wrote analysis incr file: ', &
TRIM(incrfnam),'.'
istatus = 0
RETURN
END SUBROUTINE incrdump