!-----------------------------------------------------------------------
SUBROUTINE SFC_GRIB2NC(PREFIX,NEST_TOP_RATIO,IM,JM)
!
USE GRIB_MOD
USE GRIDINFO_MODULE
USE NETCDF
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
!
!-----------------------------------------------------------------------
!
CHARACTER(LEN=*), INTENT(IN) :: PREFIX
INTEGER, INTENT(IN) :: NEST_TOP_RATIO
INTEGER, INTENT(IN) :: IM,JM
!
!-----------------------------------------------------------------------
!
INTEGER,PARAMETER :: NUM_FIELDS=6
!
INTEGER :: IUNIT_IN=20
!
REAL, PARAMETER :: G=9.81
!
! These names must be identical to the grib file names created by gridgen_sfc
!
CHARACTER(len=15),DIMENSION(1:NUM_FIELDS) :: FILEIN=(/ &
'elevtiles ' &
,'soiltiles ' &
,'vegtiles ' &
,'mxsnoalb ' &
,'slmask ' &
,'tbot ' &
/)
!
! These names must be identical to the FIELD_NAME in the Move Bundle
!
CHARACTER(len=6),DIMENSION(1:NUM_FIELDS) :: FILEOUT=(/ &
'FIS ' &
,'ISLTYP' &
,'IVGTYP' &
,'MXSNAL' &
,'SM ' &
,'TG ' &
/)
!
!-----------------------------------------------------------------------
!
CHARACTER(LEN=128) :: FILENAME
CHARACTER(LEN=20) :: NETCDF_FILENAME
CHARACTER(LEN=2) :: ID_SFC_FILE
!
TYPE(GRIBFIELD) :: GFLD
INTEGER, DIMENSION(200) :: JIDS,JPDT,JGDT
!
INTEGER :: I,J,K,IERR,NF,NR
!
INTEGER,DIMENSION(1:IM,1:JM) :: IARRAY_IJ
!
REAL,DIMENSION(1:IM,1:JM) :: ARRAY_IJ
LOGICAL*1, DIMENSION(1:IM,1:JM) :: BMAPCHECK
!
REAL,DIMENSION(1:IM,1:JM,4) :: ALBASE4
REAL,DIMENSION(1:IM,1:JM,12) :: VEGFRC12
!
REAL :: DUMMY
!
LOGICAL :: INTEGER_DATA
INTEGER :: NCID,VAR_ID,XDIM_ID,XVAR_ID,YDIM_ID,YVAR_ID
INTEGER,DIMENSION(1:2) :: DIM_IDS
REAL,DIMENSION(:),ALLOCATABLE :: X_INDX,Y_INDX
!
!-----------------------------------------------------------------------
!***********************************************************************
!-----------------------------------------------------------------------
!
ALLOCATE(X_INDX(1:IM))
ALLOCATE(Y_INDX(1:JM))
!
DO I=1,IM
X_INDX(I)=REAL(I)
ENDDO
!
DO J=1,JM
Y_INDX(J)=REAL(J)
ENDDO
!
!*** Loop over all fields/grib files which contain only one record
!
field_loop: DO NF=1,NUM_FIELDS
!
!-----------------------------------------------------------------------
!
INTEGER_DATA=FILEOUT(NF)=='ISLTYP' &
.OR. &
FILEOUT(NF)=='IVGTYP'
!
!-----------------------------------------------------------------------
!
WRITE(FILENAME,"(A,A,A,A)") PREFIX,"_",TRIM(FILEIN(NF)),".grb2"
CALL BAOPENR(IUNIT_IN,TRIM(FILENAME),IERR)
IF (IERR/=0) THEN
WRITE(0,*)' ierr .ne. 0 for baopenr ',TRIM(FILENAME), IERR
STOP
END IF
JIDS=-9999
JPDT=-9999
JGDT=-9999
CALL GETGB2(IUNIT_IN,IUNIT_IN,0,-1,JIDS,-1,JPDT,-1,JGDT,.TRUE.,K,GFLD,IERR)
IF (IERR/=0) THEN
WRITE(0,*)' ierr .ne. 0 for getgb2 ',TRIM(FILENAME), IERR
STOP
ELSE
ARRAY_IJ = RESHAPE(GFLD%FLD, (/ IM, JM /))
IF(GFLD%IBMAP .eq. 0 .or. GFLD%IBMAP .eq. 254) THEN
BMAPCHECK = RESHAPE(GFLD%BMAP, (/ IM, JM /))
ELSE
BMAPCHECK = .true.
ENDIF
END IF
CALL GF_FREE(GFLD)
CALL BACLOSE(IUNIT_IN,IERR)
IF (IERR/=0) THEN
WRITE(0,*)' ierr .ne. 0 for baclose ',TRIM(FILENAME), IERR
STOP
END IF
!
!-----------------------------------------------------------------------
!
IF(NEST_TOP_RATIO<=9)THEN
WRITE(ID_SFC_FILE,'(I1.1)')NEST_TOP_RATIO
ELSEIF(NEST_TOP_RATIO>=10)THEN
WRITE(ID_SFC_FILE,'(I2.2)')NEST_TOP_RATIO
ENDIF
!
!-----------------------------------------------------------------------
!*** Create the netCDF file.
!-----------------------------------------------------------------------
!
NETCDF_FILENAME=TRIM(FILEOUT(NF))//'_'//TRIM(ID_SFC_FILE)//'.nc'
CALL CHECK(NF90_CREATE(NETCDF_FILENAME &
,NF90_NOCLOBBER &
,NCID ) ) !<-- The netCDF file's ID
!
!-----------------------------------------------------------------------
!*** Define the netCDF file dimensions.
!-----------------------------------------------------------------------
!
CALL CHECK(NF90_DEF_DIM(NCID &
,'x_indx' &
,IM &
,XDIM_ID ) ) !<-- The X dimension's ID
!
CALL CHECK(NF90_DEF_DIM(NCID &
,'y_indx' &
,JM &
,YDIM_ID ) ) !<-- The Y dimension's ID
!
!-----------------------------------------------------------------------
!*** Define the index variables.
!-----------------------------------------------------------------------
!
CALL CHECK(NF90_DEF_VAR(NCID &
,'x_indx' &
,NF90_REAL &
,XDIM_ID &
,XVAR_ID ) )
!
CALL CHECK(NF90_DEF_VAR(NCID &
,'y_indx' &
,NF90_REAL &
,YDIM_ID &
,YVAR_ID ) )
!
DIM_IDS=(/XDIM_ID,YDIM_ID/)
!
!-----------------------------------------------------------------------
!*** Define the data variable.
!-----------------------------------------------------------------------
!
IF(INTEGER_DATA)THEN
CALL CHECK(NF90_DEF_VAR(NCID &
,TRIM(FILEOUT(NF)) &
,NF90_INT &
,DIM_IDS &
,VAR_ID ) )
ELSE
CALL CHECK(NF90_DEF_VAR(NCID &
,TRIM(FILEOUT(NF)) &
,NF90_FLOAT &
,DIM_IDS &
,VAR_ID ) )
ENDIF
!
CALL CHECK(NF90_ENDDEF(NCID))
!
!-----------------------------------------------------------------------
!*** For FIS we must multiply the elevation by G.
!-----------------------------------------------------------------------
!
IF(FILEIN(NF)(1:9)=='elevtiles')THEN
DO J=1,JM
DO I=1,IM
ARRAY_IJ(I,J)=ARRAY_IJ(I,J)*G
ENDDO
ENDDO
ENDIF
!
!-----------------------------------------------------------------------
!*** For the seamask we must flip the values so that 1=>sea, 0=>land.
!-----------------------------------------------------------------------
!
IF(FILEIN(NF)(1:6)=='slmask')THEN
DO J=1,JM
DO I=1,IM
IF(ARRAY_IJ(I,J)>0.5)THEN
ARRAY_IJ(I,J)=0.
ELSE
ARRAY_IJ(I,J)=1.
ENDIF
ENDDO
ENDDO
ENDIF
!
!-----------------------------------------------------------------------
!*** Albedo must be multiplied by 0.01.
!-----------------------------------------------------------------------
!
IF(FILEIN(NF)(1:8)=='mxsnoalb')THEN
DO J=1,JM
DO I=1,IM
IF(BMAPCHECK(I,J))THEN
IF(ARRAY_IJ(I,J)<1000.)THEN
ARRAY_IJ(I,J)=ARRAY_IJ(I,J)*0.01
ELSE
ARRAY_IJ(I,J)=0.08
ENDIF
ELSE
ARRAY_IJ(I,J)=0.08
ENDIF
ENDDO
ENDDO
ENDIF
!
!-----------------------------------------------------------------------
!*** TG has a dummy value.
!-----------------------------------------------------------------------
!
IF(FILEIN(NF)(1:4)=='tbot')THEN
DO J=1,JM
DO I=1,IM
IF(BMAPCHECK(I,J))THEN
IF(ARRAY_IJ(I,J)<1000.)THEN
ARRAY_IJ(I,J)=ARRAY_IJ(I,J)
ELSE
ARRAY_IJ(I,J)=273.16
ENDIF
ELSE
ARRAY_IJ(I,J)=273.16
ENDIF
ENDDO
ENDDO
ENDIF
!
!-----------------------------------------------------------------------
!*** Soil and vegetation types must be converted to integers.
!*** At water points they have nonsense values so change them
!*** to zero.
!-----------------------------------------------------------------------
!
IF(FILEIN(NF)(1:9)=='soiltiles' &
.OR. &
FILEIN(NF)(1:8)=='vegtiles' &
)THEN
!
DO J=1,JM
DO I=1,IM
IF(BMAPCHECK(I,J))THEN
IARRAY_IJ(I,J)=NINT(ARRAY_IJ(I,J))
IF(IARRAY_IJ(I,J)>100)THEN
IARRAY_IJ(I,J)=0
ENDIF
ELSE
if(FILEIN(NF)(1:8)=='vegtiles') then
if (use_igbp) then
IARRAY_IJ(I,J)=17 ! IGBP water
else
IARRAY_IJ(I,J)=16 ! USGS water
endif
else
IARRAY_IJ(I,J)=14 ! SOIL TYPE for water
endif
ENDIF
ENDDO
ENDDO
!
ENDIF
!
!-----------------------------------------------------------------------
!*** Insert the data into the netCDF file.
!-----------------------------------------------------------------------
!
CALL CHECK(NF90_PUT_VAR(NCID &
,XVAR_ID &
,X_INDX ) )
!
CALL CHECK(NF90_PUT_VAR(NCID &
,YVAR_ID &
,Y_INDX ) )
!
IF(INTEGER_DATA)THEN
CALL CHECK(NF90_PUT_VAR(NCID &
,VAR_ID &
,IARRAY_IJ ) )
ELSE
CALL CHECK(NF90_PUT_VAR(NCID &
,VAR_ID &
,ARRAY_IJ ) )
ENDIF
!
CALL CHECK(NF90_CLOSE(NCID))
!
!-----------------------------------------------------------------------
!
ENDDO field_loop
!
!*** Linearly interpolate in time ALBASE and VEGFRC
!
!*** ALBASE data is quarterly (4 records)
!
WRITE(FILENAME,"(A,A)") PREFIX,"_snowfree_albedo.grb2"
CALL BAOPENR(IUNIT_IN,TRIM(FILENAME),IERR)
IF (IERR/=0) THEN
WRITE(0,*)' ierr .ne. 0 for baopenr ',TRIM(FILENAME), IERR
STOP
END IF
JIDS=-9999
JPDT=-9999
JGDT=-9999
DO NR=1,4
CALL GETGB2(IUNIT_IN,IUNIT_IN,NR-1,-1,JIDS,-1,JPDT,-1,JGDT,.TRUE.,K,GFLD,IERR)
IF (IERR/=0) THEN
WRITE(0,*)' ierr .ne. 0 for getgb2 ',TRIM(FILENAME), IERR
STOP
ELSE
ALBASE4(:,:,NR) = RESHAPE(GFLD%FLD, (/ IM, JM /))
BMAPCHECK(:,:) = RESHAPE(GFLD%BMAP, (/ IM, JM /))
END IF
CALL GF_FREE(GFLD)
END DO
CALL quarterly_interp_to_date ( ALBASE4, start_date(1)//'.0000' , ARRAY_IJ , &
1 , IM , 1 , JM , 1 , 1 , &
1 , IM , 1 , JM , 1 , 1 , &
1 , IM , 1 , JM , 1 , 1 )
DO J=1,JM
DO I=1,IM
IF (BMAPCHECK(I,J)) THEN
IF(ARRAY_IJ(I,J)<1000.)THEN
ARRAY_IJ(I,J)=ARRAY_IJ(I,J)*0.01
ELSE
ARRAY_IJ(I,J)=0.06
ENDIF
ELSE
ARRAY_IJ(I,J)=0.06
ENDIF
ENDDO
ENDDO
CALL BACLOSE(IUNIT_IN,IERR)
IF (IERR/=0) THEN
WRITE(0,*)' ierr .ne. 0 for baclose ',TRIM(FILENAME), IERR
STOP
END IF
IF(NEST_TOP_RATIO<=9)THEN
WRITE(ID_SFC_FILE,'(I1.1)')NEST_TOP_RATIO
ELSEIF(NEST_TOP_RATIO>=10)THEN
WRITE(ID_SFC_FILE,'(I2.2)')NEST_TOP_RATIO
ENDIF
!
!-----------------------------------------------------------------------
!*** Create the netCDF file.
!-----------------------------------------------------------------------
!
NETCDF_FILENAME='ALBASE_'//TRIM(ID_SFC_FILE)//'.nc'
CALL CHECK(NF90_CREATE(NETCDF_FILENAME &
,NF90_NOCLOBBER &
,NCID ) ) !<-- The netCDF file's ID
!
!-----------------------------------------------------------------------
!*** Define the netCDF file dimensions.
!-----------------------------------------------------------------------
!
CALL CHECK(NF90_DEF_DIM(NCID &
,'x_indx' &
,IM &
,XDIM_ID ) ) !<-- The X dimension's ID
!
CALL CHECK(NF90_DEF_DIM(NCID &
,'y_indx' &
,JM &
,YDIM_ID ) ) !<-- The Y dimension's ID
!
!-----------------------------------------------------------------------
!*** Define the index variables.
!-----------------------------------------------------------------------
!
CALL CHECK(NF90_DEF_VAR(NCID &
,'x_indx' &
,NF90_REAL &
,XDIM_ID &
,XVAR_ID ) )
!
CALL CHECK(NF90_DEF_VAR(NCID &
,'y_indx' &
,NF90_REAL &
,YDIM_ID &
,YVAR_ID ) )
!
DIM_IDS=(/XDIM_ID,YDIM_ID/)
!
!-----------------------------------------------------------------------
!*** Define the data variable.
!-----------------------------------------------------------------------
!
CALL CHECK(NF90_DEF_VAR(NCID &
,'ALBASE' &
,NF90_FLOAT &
,DIM_IDS &
,VAR_ID ) )
!
CALL CHECK(NF90_ENDDEF(NCID))
!
!
!-----------------------------------------------------------------------
!*** Insert the data into the netCDF file.
!-----------------------------------------------------------------------
!
CALL CHECK(NF90_PUT_VAR(NCID &
,XVAR_ID &
,X_INDX ) )
!
CALL CHECK(NF90_PUT_VAR(NCID &
,YVAR_ID &
,Y_INDX ) )
!
CALL CHECK(NF90_PUT_VAR(NCID &
,VAR_ID &
,ARRAY_IJ ) )
!
CALL CHECK(NF90_CLOSE(NCID))
!
!-----------------------------------------------------------------------
!
!*** VEGFRC is monthly (12 records).
!
WRITE(FILENAME,"(A,A)") PREFIX,"_vegfrac.grb2"
CALL BAOPENR(IUNIT_IN,TRIM(FILENAME),IERR)
IF (IERR/=0) THEN
WRITE(0,*)' ierr .ne. 0 for baopenr ',TRIM(FILENAME), IERR
STOP
END IF
JIDS=-9999
JPDT=-9999
JGDT=-9999
DO NR=1,12
CALL GETGB2(IUNIT_IN,IUNIT_IN,NR-1,-1,JIDS,-1,JPDT,-1,JGDT,.TRUE.,K,GFLD,IERR)
IF (IERR/=0) THEN
WRITE(0,*)' ierr .ne. 0 for getgb2 ',TRIM(FILENAME), IERR
STOP
ELSE
VEGFRC12(:,:,NR) = RESHAPE(GFLD%FLD, (/ IM, JM /))
END IF
CALL GF_FREE(GFLD)
END DO
CALL monthly_interp_to_date ( VEGFRC12, start_date(1)//'.0000' , ARRAY_IJ , &
1 , IM , 1 , JM , 1 , 1 , &
1 , IM , 1 , JM , 1 , 1 , &
1 , IM , 1 , JM , 1 , 1 )
DO J=1,JM
DO I=1,IM
IF(ARRAY_IJ(I,J)<1000.)THEN
ARRAY_IJ(I,J)=ARRAY_IJ(I,J)*0.01
ELSE
ARRAY_IJ(I,J)=0.0
ENDIF
ENDDO
ENDDO
CALL BACLOSE(IUNIT_IN,IERR)
IF (IERR/=0) THEN
WRITE(0,*)' ierr .ne. 0 for baclose ',TRIM(FILENAME), IERR
STOP
END IF
IF(NEST_TOP_RATIO<=9)THEN
WRITE(ID_SFC_FILE,'(I1.1)')NEST_TOP_RATIO
ELSEIF(NEST_TOP_RATIO>=10)THEN
WRITE(ID_SFC_FILE,'(I2.2)')NEST_TOP_RATIO
ENDIF
!
!-----------------------------------------------------------------------
!*** Create the netCDF file.
!-----------------------------------------------------------------------
!
NETCDF_FILENAME='VEGFRC_'//TRIM(ID_SFC_FILE)//'.nc'
CALL CHECK(NF90_CREATE(NETCDF_FILENAME &
,NF90_NOCLOBBER &
,NCID ) ) !<-- The netCDF file's ID
!
!-----------------------------------------------------------------------
!*** Define the netCDF file dimensions.
!-----------------------------------------------------------------------
!
CALL CHECK(NF90_DEF_DIM(NCID &
,'x_indx' &
,IM &
,XDIM_ID ) ) !<-- The X dimension's ID
!
CALL CHECK(NF90_DEF_DIM(NCID &
,'y_indx' &
,JM &
,YDIM_ID ) ) !<-- The Y dimension's ID
!
!-----------------------------------------------------------------------
!*** Define the index variables.
!-----------------------------------------------------------------------
!
CALL CHECK(NF90_DEF_VAR(NCID &
,'x_indx' &
,NF90_REAL &
,XDIM_ID &
,XVAR_ID ) )
!
CALL CHECK(NF90_DEF_VAR(NCID &
,'y_indx' &
,NF90_REAL &
,YDIM_ID &
,YVAR_ID ) )
!
DIM_IDS=(/XDIM_ID,YDIM_ID/)
!
!-----------------------------------------------------------------------
!*** Define the data variable.
!-----------------------------------------------------------------------
!
CALL CHECK(NF90_DEF_VAR(NCID &
,'VEGFRC' &
,NF90_FLOAT &
,DIM_IDS &
,VAR_ID ) )
!
CALL CHECK(NF90_ENDDEF(NCID))
!
!
!-----------------------------------------------------------------------
!*** Insert the data into the netCDF file.
!-----------------------------------------------------------------------
!
CALL CHECK(NF90_PUT_VAR(NCID &
,XVAR_ID &
,X_INDX ) )
!
CALL CHECK(NF90_PUT_VAR(NCID &
,YVAR_ID &
,Y_INDX ) )
!
CALL CHECK(NF90_PUT_VAR(NCID &
,VAR_ID &
,ARRAY_IJ ) )
!
CALL CHECK(NF90_CLOSE(NCID))
!
!-----------------------------------------------------------------------
!
CONTAINS
SUBROUTINE CHECK(RC)
!
IMPLICIT NONE
!
INTEGER,INTENT(IN) :: RC
!
!-----------------------------------------------------------------------
!***********************************************************************
!-----------------------------------------------------------------------
!
IF(RC/=NF90_NOERR)THEN
WRITE(*,*)TRIM(ADJUSTL(NF90_STRERROR(RC)))
! WRITE(0,11101)RC
11101 FORMAT(' ERROR: RC=',I5)
ENDIF
!
END SUBROUTINE CHECK
!
!-----------------------------------------------------------------------
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!-----------------------------------------------------------------------
!
!*** The following routines are copied from nemsinterp (module_vinterp_routines.F90)
!
SUBROUTINE monthly_interp_to_date ( field_in , date_str , field_out , &
ids , ide , jds , jde , kds , kde , &
ims , ime , jms , jme , kms , kme , &
its , ite , jts , jte , kts , kte )
! Linearly in time interpolate data to a current valid time. The data is
! assumed to come in "monthly", valid at the 15th of every month.
IMPLICIT NONE
INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
ims , ime , jms , jme , kms , kme , &
its , ite , jts , jte , kts , kte
CHARACTER (LEN=24) , INTENT(IN) :: date_str
REAL , DIMENSION(ims:ime,jms:jme,12) , INTENT(IN) :: field_in
REAL , DIMENSION(ims:ime, jms:jme) , INTENT(OUT) :: field_out
! Local vars
INTEGER :: i , j , l
INTEGER , DIMENSION(0:13) :: middle
INTEGER :: target_julyr , target_julday , target_date
INTEGER :: julyr , julday , int_month, next_month
REAL :: gmt
CHARACTER (LEN=4) :: yr
CHARACTER (LEN=2) :: mon , day15
WRITE(day15,FMT='(I2.2)') 15
DO l = 1 , 13
WRITE(mon,FMT='(I2.2)') l
CALL get_julgmt ( date_str(1:4)//'-'//mon//'-'//day15//'_'//'00:00:00.0000' , julyr , julday , gmt)
middle(L) = julyr*1000 + julday
END DO
l = 0
middle(l) = middle( 1) - 30
l = 13
middle(l) = middle(12) + 30
CALL get_julgmt ( date_str , target_julyr , target_julday , gmt )
target_date = target_julyr * 1000 + target_julday
find_month : DO l = 0 , 12
IF ( ( middle(l) .LT. target_date ) .AND. ( middle(l+1) .GE. target_date ) ) THEN
DO j = jts , MIN ( jde-1 , jte )
DO i = its , MIN (ide-1 , ite )
int_month = MOD ( l , 12 )
IF ( int_month .EQ. 0 ) int_month=12
IF (int_month == 12) THEN
next_month=1
ELSE
next_month=int_month+1
ENDIF
field_out(i,j) = ( field_in(i,j,next_month) * ( target_date - middle(l) ) + &
field_in(i,j,int_month ) * ( middle(l+1) - target_date ) ) / &
( middle(l+1) - middle(l) )
END DO
END DO
EXIT find_month
END IF
END DO find_month
END SUBROUTINE monthly_interp_to_date
! -------------------------------------------------------------------
SUBROUTINE quarterly_interp_to_date( field_in , date_str , field_out , &
ids , ide , jds , jde , kds , kde , &
ims , ime , jms , jme , kms , kme , &
its , ite , jts , jte , kts , kte )
! Linearly in time interpolate data to a current valid time. The data is
! assumed to come in "quarterly", valid at the 15th of every month.
IMPLICIT NONE
INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
ims , ime , jms , jme , kms , kme , &
its , ite , jts , jte , kts , kte
CHARACTER (LEN=24) , INTENT(IN) :: date_str
REAL , DIMENSION(ims:ime,jms:jme,4) , INTENT(IN) :: field_in
REAL , DIMENSION(ims:ime, jms:jme) , INTENT(OUT) :: field_out
! Local vars
INTEGER :: i , j , l, LL
INTEGER , DIMENSION(0:5) :: middle
INTEGER :: target_julyr , target_julday , target_date
INTEGER :: julyr , julday , int_quart, next_quart
REAL :: gmt
CHARACTER (LEN=4) :: yr
CHARACTER (LEN=2) :: mon , day30
WRITE(day30,FMT='(I2.2)') 30
LL=0
DO l = 1 , 10, 3
LL=LL+1
WRITE(mon,FMT='(I2.2)') l
CALL get_julgmt ( date_str(1:4)//'-'//mon//'-'//day30//'_'//'00:00:00.0000' , julyr , julday , gmt)
middle(LL) = julyr*1000 + julday
END DO
l = 0
middle(l) = middle( 1) - 90
l = 5
middle(l) = middle(4) + 90
CALL get_julgmt ( date_str , target_julyr , target_julday , gmt )
target_date = target_julyr * 1000 + target_julday
find_quarter : DO l = 0 , 4
IF ( ( middle(l) .LT. target_date ) .AND. ( middle(l+1) .GE. target_date ) ) THEN
int_quart = MOD ( l , 4 )
IF ( int_quart .EQ. 0 ) int_quart = 4
IF (int_quart == 4) THEN
next_quart=1
ELSE
next_quart=int_quart+1
ENDIF
DO j = jts , MIN ( jde-1 , jte )
DO i = its , MIN (ide-1 , ite )
field_out(i,j) = ( field_in(i,j,next_quart) * ( target_date - middle(l) ) + &
field_in(i,j,int_quart ) * ( middle(l+1) - target_date ) ) / &
( middle(l+1) - middle(l) )
END DO
END DO
EXIT find_quarter
END IF
END DO find_quarter
END SUBROUTINE quarterly_interp_to_date
! -------------------------------------------------------------------
SUBROUTINE get_julgmt(date_str,julyr,julday,gmt)
IMPLICIT NONE
! Arguments
CHARACTER (LEN=24) , INTENT(IN) :: date_str
INTEGER, INTENT(OUT ) :: julyr
INTEGER, INTENT(OUT ) :: julday
REAL , INTENT(OUT ) :: gmt
! Local
INTEGER :: ny , nm , nd , nh , ni , ns , nt
INTEGER :: my1, my2, my3, monss
INTEGER, DIMENSION(12) :: mmd
DATA MMD/31,28,31,30,31,30,31,31,30,31,30,31/
CALL split_date_char ( date_str , ny , nm , nd , nh , ni , ns , nt )
GMT=nh+FLOAT(ni)/60.+FLOAT(ns)/3600.
MY1=MOD(ny,4)
MY2=MOD(ny,100)
MY3=MOD(ny,400)
IF(MY1.EQ.0.AND.MY2.NE.0.OR.MY3.EQ.0)MMD(2)=29
JULDAY=nd
JULYR=ny
DO MONSS=1,nm-1
JULDAY=JULDAY+MMD(MONSS)
ENDDO
END SUBROUTINE get_julgmt
!---------------------------------------------------------
SUBROUTINE split_date_char ( date , century_year , month , day , hour , minute , second , ten_thousandth)
IMPLICIT NONE
! Input data.
CHARACTER(LEN=24) , INTENT(IN) :: date
! Output data.
INTEGER , INTENT(OUT) :: century_year , month , day , hour , minute , second , ten_thousandth
READ(date,FMT='( I4)') century_year
READ(date,FMT='( 5X,I2)') month
READ(date,FMT='( 8X,I2)') day
READ(date,FMT='(11X,I2)') hour
READ(date,FMT='(14X,I2)') minute
READ(date,FMT='(17X,I2)') second
READ(date,FMT='(20X,I4)') ten_thousandth
END SUBROUTINE split_date_char
!
!-----------------------------------------------------------------------
!
END SUBROUTINE SFC_GRIB2NC
!-----------------------------------------------------------------------