module module_HIFREQ 2
#ifdef HWRF
! This module implements the high-frequency output requested by the
! National Hurricane Center in 2010. The hifreq_write routine will
! write a file that contains max. 10m wind, min. MSLP, their locations,
! and the nest center location once per timestep. The hifreq_read
! routine is a sample routine for reading that output. The hifreq_open
! routine is a convenience routine that can generate a nice-looking
! filename using WRF filename generation routines.
!------------------------------------------------------------------------------------------------------
private
public HIFREQ_WRITE, HIFREQ_READ, HIFREQ_OPEN
CONTAINS
!----------------------------------------------------------------------------------
! These two simple routines return an N, S, E or W for the hemisphere of
! a latitude or longitude:
character(1) function get_lat_ns(lat)
implicit none ; real lat
if(lat>=0) then
get_lat_ns='N'
else
get_lat_ns='S'
endif
end function get_lat_ns
character(1) function get_lon_ew(lon)
implicit none ; real lon
if(lon>=0) then
get_lon_ew='E'
else
get_lon_ew='W'
endif
end function get_lon_ew
!------------------------------------------------------------------------------------------------------
!
SUBROUTINE HIFREQ_READ(LUN,mingbl_mslp,maxgbl_wind,plat,plon,wlat,wlon,clat,clon,tm,ierr)
!**********************************************************************
!$$$ SUBPROGRAM DOCUMENTATION BLOCK
! . . .
! PRGRMMR: Sam Trahan
!
! ABSTRACT:
! Call this routine to write one line to read in the values
! written out by hifreq_write. Call this routine repeatedly
! to retrieve all lines.
!
! PROGRAM HISTORY LOG:
! 05-2011 : Sam Trahan
!
! ATTRIBUTES:
! LANGUAGE: FORTRAN 90
! MACHINE : IBM SP
!
! INPUT ARGUMENTS:
! LUN -- logical unit to read from
!
! OUTPUT ARGUMENTS:
! IERR -- 0 on success, 1 on error (integer)
! TM -- forecast second (real)
! MINGBL_MSLP -- min. MSLP in mbar (real)
! MAXGBL_MSLP -- max. 10m wind in knots (real)
! plat, plon -- lat & lon of MSLP minimum (degrees, real)
! wlat, wlon -- lat & lon of wind maximum (degrees, real)
! clat, clon -- lat & lon of nest center (degrees, real)
!$$$
!**********************************************************************
!
implicit none
real, intent(out) :: MINGBL_MSLP, MAXGBL_WIND
real, intent(out) :: plat, plon
real, intent(out) :: wlat, wlon
real, intent(out) :: clat, clon
real, intent(out) :: tm
integer, intent(in) :: lun
integer, intent(out) :: ierr
character*1 :: pns,pew,wns,wew,cns,cew
ierr=0
3131 format(F11.2,", ", &
F9.4,", ",F6.3,A1,", ",F7.3,A1,", ", &
F7.3,", ",F6.3,A1,", ",F7.3,A1,", ", &
F6.3,A1,", ",F7.3,A1)
read(lun,3131,err=3132) tm, &
MINGBL_MSLP,plat,pns,plon,pew, &
MAXGBL_WIND,wlat,wns,wlon,wew, &
clat,cns,clon,cew
if(pns == 'S') plat=-plat
if(pew == 'W') plon=-plon
if(wns == 'S') wlat=-wlat
if(wew == 'W') wlon=-wlon
if(cns == 'S') clat=-clat
if(cew == 'W') clon=-clon
return
3132 continue ! I/O error or end of file.
ierr=1
END SUBROUTINE HIFREQ_READ
SUBROUTINE HIFREQ_WRITE (LUN,NTSD,DT,HLAT,HLON & 1,3
,U10,V10,PINT,T,Q &
,FIS,PD,PDTOP &
,DETA1,DETA2 &
,IDS,IDE,JDS,JDE,KDS,KDE &
,IMS,IME,JMS,JME,KMS,KME &
,ITS,ITE,JTS,JTE,KTS,KTE )
!**********************************************************************
!$$$ SUBPROGRAM DOCUMENTATION BLOCK
! . . .
! PRGRMMR: Original by Young Kwon, modified by Sam Trahan
!
! ABSTRACT:
! Call this routine to write one line to the given LUN,
! containing the minimum MSLP, max 10m wind, their locations,
! and the nest center location.
! PROGRAM HISTORY LOG:
! 05-2011 : Young Kwon
! 05-2011 : Sam Trahan -- Modified for efficiency, eliminated need
! for an external parser script.
!
! ATTRIBUTES:
! LANGUAGE: FORTRAN 90
! MACHINE : IBM SP
!$$$
!**********************************************************************
!
USE MODULE_NEST_UTIL
, only : MSLP_DIAG
USE MODULE_DM, only : wrf_dm_minloc_real, wrf_dm_maxloc_real
IMPLICIT NONE
!
LOGICAL, EXTERNAL :: wrf_dm_on_monitor
INTEGER,INTENT(IN) :: NTSD, LUN
INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
& ,IMS,IME,JMS,JME,KMS,KME &
& ,ITS,ITE,JTS,JTE,KTS,KTE
!
REAL, INTENT(IN) :: PDTOP, DT
REAL, DIMENSION(KMS:KME), INTENT(IN) :: DETA1,DETA2
REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(IN) :: FIS,PD,HLAT,HLON
REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(IN) :: U10,V10
REAL, DIMENSION(IMS:IME,JMS:JME,KMS:KME), INTENT(IN) :: PINT,T,Q
!----------------------------------------------------------------------
REAL, DIMENSION(IMS:IME,JMS:JME) :: WIND10SQ, MSLP
REAL :: MINGBL_MSLP, MAXGBL_WIND, ZDUM, PREF
REAL :: CLAT,CLON,PLAT,PLON,WLAT,WLON, WREF, HAVE_CEN
INTEGER :: IWIND,JWIND, IMSLP,JMSLP
INTEGER :: ICEN,JCEN,I,J,ITF,JTF
!----------------------------------------------------------------------
ITF=MIN(ITE,IDE-1)
JTF=MIN(JTE,JDE-1)
! Get the MSLP and the square of the 10m wind:
WIND10SQ(its:itf,jts:jtf) = U10(its:itf,jts:jtf)**2+ &
V10(its:itf,jts:jtf)**2
call MSLP_DIAG (MSLP,PINT,T,Q &
,FIS,PD,DETA1,DETA2,PDTOP &
,IDS,IDE,JDS,JDE,KDS,KDE &
,IMS,IME,JMS,JME,KMS,KME &
,ITS,ITE,JTS,JTE,KTS,KTE )
! Find the location of the wind & pressure extrema in this tile:
imslp=its; jmslp=jts
iwind=its; jwind=jts
pref=MSLP(imslp,jmslp) ! min mslp
wref=WIND10SQ(iwind,jwind) ! max wind
do j=jts,jtf
do i=its,itf
if(MSLP(i,j) < pref) then
imslp=i ; jmslp=j
pref=MSLP(imslp,jmslp)
endif
if(WIND10SQ(i,j) > wref) then
iwind=i ; jwind=j
wref=WIND10SQ(iwind,jwind)
end if
enddo
enddo
MINGBL_MSLP=pref ; MAXGBL_WIND=sqrt(wref)/0.514444
PLAT=HLAT(imslp,jmslp) ; WLAT=HLAT(iwind,jwind)
PLON=HLON(imslp,jmslp) ; WLON=HLON(iwind,jwind)
zdum=0
! Get the center of the domain:
ICEN=(IDE-1)/2
JCEN=(JDE-1)/2
HAVE_CEN=0
if(ICEN>=its .and. ICEN<=itf .and. JCEN>=jts .and. JCEN<=jtf) then
HAVE_CEN=1
CLAT=HLAT(ICEN,JCEN)
CLON=HLON(ICEN,JCEN)
end if
! Get grid-wide extrema:
call WRF_DM_MAXLOC_REAL(have_cen,clat,clon,zdum,icen,jcen)
call WRF_DM_MINLOC_REAL(mingbl_mslp,plat,plon,zdum,imslp,jmslp)
call WRF_DM_MAXLOC_REAL(maxgbl_wind,wlat,wlon,zdum,iwind,jwind)
! Monitor process writes out values.
if(wrf_dm_on_monitor()) then
! Write out in a standard format (use hifreq_read to read it):
1313 format(F11.2,", ", &
F8.3,", ",F6.3,A1,", ",F7.3,A1,", ", &
F7.3,", ",F6.3,A1,", ",F7.3,A1,", ", &
F6.3,A1,", ",F7.3,A1)
write(LUN,1313) &
dt*ntsd, &
MINGBL_MSLP/100,abs(plat),get_lat_ns(plat),abs(plon),get_lon_ew(plon), &
MAXGBL_WIND,abs(wlat),get_lat_ns(wlat),abs(wlon),get_lon_ew(wlon), &
abs(clat),get_lat_ns(clat),abs(clon),get_lon_ew(clon)
if(mod(ntsd,126)==125) then
! bug fix for IBM: will not write unless a flush is done periodically
flush(lun)
endif
endif
RETURN
END SUBROUTINE hifreq_write
SUBROUTINE hifreq_open ( grid , config_flags ) 2,8
! Driver layer
USE module_domain , ONLY : domain, domain_clock_get
USE module_configure , ONLY : grid_config_rec_type
IMPLICIT NONE
LOGICAL, EXTERNAL :: wrf_dm_on_monitor
! Arguments
TYPE(domain) :: grid
TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags
! Local
CHARACTER*256 :: outname
INTEGER :: fid
LOGICAL :: opened
CHARACTER*80 :: timestr
character*256 :: message
integer, parameter :: unitbase = 93, giveup=unitbase+1000
INTERFACE
SUBROUTINE construct_filename2a( result , basename , fld1 , len1 , date_char )
IMPLICIT NONE
CHARACTER*(*) :: result
CHARACTER*(*) :: basename
CHARACTER*(*) :: date_char
INTEGER , INTENT(IN) :: fld1 , len1
END SUBROUTINE construct_filename2a
END INTERFACE
CALL domain_clock_get( grid, current_timestr=timestr )
CALL construct_filename2a ( outname ,config_flags%high_freq_outname, grid%id , 2 , timestr )
#ifdef DM_PARALLEL
if(wrf_dm_on_monitor()) then
#endif
! Find an unused unit number
fid = unitbase + grid%id
fid_loop:do while(fid <= giveup)
write(message,'("HIFREQ OPEN TRY FID = ",I0)') fid
call wrf_message(message)
inquire(unit=fid,opened=opened)
if(.not.opened) then
write(message,'("HIFREQ OPEN UNUSED!! ",I0)') fid
call wrf_message(message)
exit fid_loop
end if
fid=fid+1
enddo fid_loop
if(fid>giveup) then
call wrf_error_fatal('Could not find an unused LUN in highfreq_open')
endif
write(message,'("HIFREQ APPEND ",A1,A80,A1)') '"',trim(outname),'"'
call wrf_message(message)
open(unit=fid,file=trim(outname),position='append',form='formatted')
grid%hifreq_lun=fid
#ifdef DM_PARALLEL
else
grid%hifreq_lun=-99 ! must be non-zero but invalid
endif
#endif
END SUBROUTINE hifreq_open
! only used by HWRF...
#endif
end module module_HIFREQ