! The subroutine SOIL_VEG_GEN_PARM was yanked from the WRF source code file "module_sf_noahdrv.F". ! For it to work outside of WRF, it has been embedded into a module, MODULE_READ_TABLES_SAMPLE_SUBROUTINE. ! This module defines variables and arrays expected by subroutine SOIL_VEG_GEN_PARM. ! ! There are a variety of WRF-specific subroutine and function calls in SOIL_VEG_GEN_PARM. For ! this subroutine to work outside of WRF, those WRF-specific subroutine and function calls must be ! avoided. We do this via CPP, defining a CPP name "_COUPLED_" as zero with a "#define" directive, and ! not including those WRF-specific calls with a "#if _COUPLED_" directive. ! Define _COUPLED_ to zero to bypass WRF-specific subroutine calls. #define _COUPLED_ 0 MODULE module_read_tables_sample_subroutine ! VEGETATION PARAMETERS INTEGER :: LUCATS , BARE INTEGER :: NATURAL integer, PARAMETER :: NLUS=50 CHARACTER(LEN=256) LUTYPE INTEGER, DIMENSION(1:NLUS) :: NROTBL real, dimension(1:NLUS) :: SNUPTBL, RSTBL, RGLTBL, HSTBL, & SHDTBL, MAXALB, & EMISSMINTBL, EMISSMAXTBL, & LAIMINTBL, LAIMAXTBL, & Z0MINTBL, Z0MAXTBL, & ALBEDOMINTBL, ALBEDOMAXTBL REAL :: TOPT_DATA,CMCMAX_DATA,CFACTR_DATA,RSMAX_DATA ! SOIL PARAMETERS INTEGER :: SLCATS INTEGER, PARAMETER :: NSLTYPE=30 CHARACTER(LEN=256) SLTYPE REAL, DIMENSION (1:NSLTYPE) :: BB,DRYSMC,F11, & MAXSMC, REFSMC,SATPSI,SATDK,SATDW, WLTSMC,QTZ ! LSM GENERAL PARAMETERS INTEGER :: SLPCATS INTEGER, PARAMETER :: NSLOPE=30 REAL, DIMENSION (1:NSLOPE) :: SLOPE_DATA REAL :: SBETA_DATA,FXEXP_DATA,CSOIL_DATA,SALP_DATA,REFDK_DATA, & REFKDT_DATA,FRZK_DATA,ZBOT_DATA, SMLOW_DATA,SMHIGH_DATA, & CZIL_DATA CONTAINS !----------------------------------------------------------------- SUBROUTINE SOIL_VEG_GEN_PARM( MMINLU, MMINSL) !----------------------------------------------------------------- #if _COUPLED_ USE module_wrf_error #endif IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: MMINLU, MMINSL integer :: LUMATCH, IINDEX, LC, NUM_SLOPE integer :: ierr INTEGER , PARAMETER :: OPEN_OK = 0 character*128 :: mess , message #if _COUPLED_ logical, external :: wrf_dm_on_monitor #endif !-----SPECIFY VEGETATION RELATED CHARACTERISTICS : ! ALBBCK: SFC albedo (in percentage) ! Z0: Roughness length (m) ! SHDFAC: Green vegetation fraction (in percentage) ! Note: The ALBEDO, Z0, and SHDFAC values read from the following table ! ALBEDO, amd Z0 are specified in LAND-USE TABLE; and SHDFAC is ! the monthly green vegetation data ! CMXTBL: MAX CNPY Capacity (m) ! NROTBL: Rooting depth (layer) ! RSMIN: Mimimum stomatal resistance (s m-1) ! RSMAX: Max. stomatal resistance (s m-1) ! RGL: Parameters used in radiation stress function ! HS: Parameter used in vapor pressure deficit functio ! TOPT: Optimum transpiration air temperature. (K) ! CMCMAX: Maximum canopy water capacity ! CFACTR: Parameter used in the canopy inteception calculati ! SNUP: Threshold snow depth (in water equivalent m) that ! implies 100% snow cover ! LAI: Leaf area index (dimensionless) ! MAXALB: Upper bound on maximum albedo over deep snow ! !-----READ IN VEGETAION PROPERTIES FROM VEGPARM.TBL ! #if _COUPLED_ IF ( wrf_dm_on_monitor() ) THEN #endif OPEN(19, FILE='VEGPARM.TBL',FORM='FORMATTED',STATUS='OLD',IOSTAT=ierr) IF(ierr .NE. OPEN_OK ) THEN WRITE(message,FMT='(A)') & 'module_sf_noahlsm.F: soil_veg_gen_parm: failure opening VEGPARM.TBL' #if _COUPLED_ CALL wrf_error_fatal ( message ) #else write(*,*) message stop #endif END IF LUMATCH=0 FIND_LUTYPE : DO WHILE (LUMATCH == 0) READ (19,*,END=2002) READ (19,*,END=2002)LUTYPE READ (19,*)LUCATS,IINDEX IF(LUTYPE.EQ.MMINLU)THEN WRITE( mess , * ) 'LANDUSE TYPE = ' // TRIM ( LUTYPE ) // ' FOUND', LUCATS,' CATEGORIES' #if _COUPLED_ CALL wrf_message( mess ) #else write(*,*) mess #endif LUMATCH=1 ELSE #if _COUPLED_ call wrf_message ( "Skipping over LUTYPE = " // TRIM ( LUTYPE ) ) #else write(*,*) "Skipping over LUTYPE = " // TRIM ( LUTYPE ) #endif DO LC = 1, LUCATS+12 read(19,*) ENDDO ENDIF ENDDO FIND_LUTYPE ! prevent possible array overwrite, Bill Bovermann, IBM, May 6, 2008 IF ( SIZE(SHDTBL) < LUCATS .OR. & SIZE(NROTBL) < LUCATS .OR. & SIZE(RSTBL) < LUCATS .OR. & SIZE(RGLTBL) < LUCATS .OR. & SIZE(HSTBL) < LUCATS .OR. & SIZE(SNUPTBL) < LUCATS .OR. & SIZE(MAXALB) < LUCATS .OR. & SIZE(LAIMINTBL) < LUCATS .OR. & SIZE(LAIMAXTBL) < LUCATS .OR. & SIZE(Z0MINTBL) < LUCATS .OR. & SIZE(Z0MAXTBL) < LUCATS .OR. & SIZE(ALBEDOMINTBL) < LUCATS .OR. & SIZE(ALBEDOMAXTBL) < LUCATS .OR. & SIZE(EMISSMINTBL ) < LUCATS .OR. & SIZE(EMISSMAXTBL ) < LUCATS ) THEN #if _COUPLED_ CALL wrf_error_fatal('Table sizes too small for value of LUCATS in module_sf_noahdrv.F') #else write(*,*) 'Table sizes too small for value of LUCATS in module_sf_noahdrv.F' stop #endif ENDIF IF(LUTYPE.EQ.MMINLU)THEN DO LC=1,LUCATS READ (19,*)IINDEX,SHDTBL(LC), & NROTBL(LC),RSTBL(LC),RGLTBL(LC),HSTBL(LC), & SNUPTBL(LC),MAXALB(LC), LAIMINTBL(LC), & LAIMAXTBL(LC),EMISSMINTBL(LC), & EMISSMAXTBL(LC), ALBEDOMINTBL(LC), & ALBEDOMAXTBL(LC), Z0MINTBL(LC), Z0MAXTBL(LC) ENDDO ! READ (19,*) READ (19,*)TOPT_DATA READ (19,*) READ (19,*)CMCMAX_DATA READ (19,*) READ (19,*)CFACTR_DATA READ (19,*) READ (19,*)RSMAX_DATA READ (19,*) READ (19,*)BARE READ (19,*) READ (19,*)NATURAL ENDIF ! 2002 CONTINUE CLOSE (19) IF (LUMATCH == 0) then #if _COUPLED_ CALL wrf_error_fatal ("Land Use Dataset '"//MMINLU//"' not found in VEGPARM.TBL.") #else write(*,*) "Land Use Dataset '"//MMINLU//"' not found in VEGPARM.TBL." stop #endif ENDIF #if _COUPLED_ ENDIF #endif #if _COUPLED_ CALL wrf_dm_bcast_string ( LUTYPE , 4 ) CALL wrf_dm_bcast_integer ( LUCATS , 1 ) CALL wrf_dm_bcast_integer ( IINDEX , 1 ) CALL wrf_dm_bcast_integer ( LUMATCH , 1 ) CALL wrf_dm_bcast_real ( SHDTBL , NLUS ) CALL wrf_dm_bcast_real ( NROTBL , NLUS ) CALL wrf_dm_bcast_real ( RSTBL , NLUS ) CALL wrf_dm_bcast_real ( RGLTBL , NLUS ) CALL wrf_dm_bcast_real ( HSTBL , NLUS ) CALL wrf_dm_bcast_real ( SNUPTBL , NLUS ) CALL wrf_dm_bcast_real ( LAIMINTBL , NLUS ) CALL wrf_dm_bcast_real ( LAIMAXTBL , NLUS ) CALL wrf_dm_bcast_real ( Z0MINTBL , NLUS ) CALL wrf_dm_bcast_real ( Z0MAXTBL , NLUS ) CALL wrf_dm_bcast_real ( EMISSMINTBL , NLUS ) CALL wrf_dm_bcast_real ( EMISSMAXTBL , NLUS ) CALL wrf_dm_bcast_real ( ALBEDOMINTBL , NLUS ) CALL wrf_dm_bcast_real ( ALBEDOMAXTBL , NLUS ) CALL wrf_dm_bcast_real ( MAXALB , NLUS ) CALL wrf_dm_bcast_real ( TOPT_DATA , 1 ) CALL wrf_dm_bcast_real ( CMCMAX_DATA , 1 ) CALL wrf_dm_bcast_real ( CFACTR_DATA , 1 ) CALL wrf_dm_bcast_real ( RSMAX_DATA , 1 ) CALL wrf_dm_bcast_integer ( BARE , 1 ) CALL wrf_dm_bcast_integer ( NATURAL , 1 ) #endif ! !-----READ IN SOIL PROPERTIES FROM SOILPARM.TBL ! #if _COUPLED_ IF ( wrf_dm_on_monitor() ) THEN #endif OPEN(19, FILE='SOILPARM.TBL',FORM='FORMATTED',STATUS='OLD',IOSTAT=ierr) IF(ierr .NE. OPEN_OK ) THEN WRITE(message,FMT='(A)') & 'module_sf_noahlsm.F: soil_veg_gen_parm: failure opening SOILPARM.TBL' #if _COUPLED_ CALL wrf_error_fatal ( message ) #else write(*,*) message stop #endif END IF WRITE(mess,*) 'INPUT SOIL TEXTURE CLASSIFICAION = ', TRIM ( MMINSL ) #if _COUPLED_ CALL wrf_message( mess ) #else write(*,*) mess #endif LUMATCH=0 READ (19,*) READ (19,2000,END=2003)SLTYPE 2000 FORMAT (A4) READ (19,*)SLCATS,IINDEX IF(SLTYPE.EQ.MMINSL)THEN WRITE( mess , * ) 'SOIL TEXTURE CLASSIFICATION = ', TRIM ( SLTYPE ) , ' FOUND', & SLCATS,' CATEGORIES' #if _COUPLED_ CALL wrf_message ( mess ) #else write(*,*) mess #endif LUMATCH=1 ENDIF ! prevent possible array overwrite, Bill Bovermann, IBM, May 6, 2008 IF ( SIZE(BB ) < SLCATS .OR. & SIZE(DRYSMC) < SLCATS .OR. & SIZE(F11 ) < SLCATS .OR. & SIZE(MAXSMC) < SLCATS .OR. & SIZE(REFSMC) < SLCATS .OR. & SIZE(SATPSI) < SLCATS .OR. & SIZE(SATDK ) < SLCATS .OR. & SIZE(SATDW ) < SLCATS .OR. & SIZE(WLTSMC) < SLCATS .OR. & SIZE(QTZ ) < SLCATS ) THEN #if _COUPLED_ CALL wrf_error_fatal('Table sizes too small for value of SLCATS in module_sf_noahdrv.F') #else write(*,*) 'Table sizes too small for value of SLCATS in module_sf_noahdrv.F' stop #endif ENDIF IF(SLTYPE.EQ.MMINSL)THEN DO LC=1,SLCATS READ (19,*) IINDEX,BB(LC),DRYSMC(LC),F11(LC),MAXSMC(LC),& REFSMC(LC),SATPSI(LC),SATDK(LC), SATDW(LC), & WLTSMC(LC), QTZ(LC) ENDDO ENDIF 2003 CONTINUE CLOSE (19) #if _COUPLED_ ENDIF #endif #if _COUPLED_ CALL wrf_dm_bcast_integer ( LUMATCH , 1 ) CALL wrf_dm_bcast_string ( SLTYPE , 4 ) CALL wrf_dm_bcast_string ( MMINSL , 4 ) ! since this is reset above, see oct2 ^ CALL wrf_dm_bcast_integer ( SLCATS , 1 ) CALL wrf_dm_bcast_integer ( IINDEX , 1 ) CALL wrf_dm_bcast_real ( BB , NSLTYPE ) CALL wrf_dm_bcast_real ( DRYSMC , NSLTYPE ) CALL wrf_dm_bcast_real ( F11 , NSLTYPE ) CALL wrf_dm_bcast_real ( MAXSMC , NSLTYPE ) CALL wrf_dm_bcast_real ( REFSMC , NSLTYPE ) CALL wrf_dm_bcast_real ( SATPSI , NSLTYPE ) CALL wrf_dm_bcast_real ( SATDK , NSLTYPE ) CALL wrf_dm_bcast_real ( SATDW , NSLTYPE ) CALL wrf_dm_bcast_real ( WLTSMC , NSLTYPE ) CALL wrf_dm_bcast_real ( QTZ , NSLTYPE ) #endif IF(LUMATCH.EQ.0)THEN #if _COUPLED_ CALL wrf_message( 'SOIl TEXTURE IN INPUT FILE DOES NOT ' ) CALL wrf_message( 'MATCH SOILPARM TABLE' ) CALL wrf_error_fatal ( 'INCONSISTENT OR MISSING SOILPARM FILE' ) #else write(*,*) 'SOIl TEXTURE IN INPUT FILE DOES NOT ' write(*,*) 'MATCH SOILPARM TABLE' write(*,*) 'INCONSISTENT OR MISSING SOILPARM FILE' stop #endif ENDIF ! !-----READ IN GENERAL PARAMETERS FROM GENPARM.TBL ! #if _COUPLED_ IF ( wrf_dm_on_monitor() ) THEN #endif OPEN(19, FILE='GENPARM.TBL',FORM='FORMATTED',STATUS='OLD',IOSTAT=ierr) IF(ierr .NE. OPEN_OK ) THEN WRITE(message,FMT='(A)') & 'module_sf_noahlsm.F: soil_veg_gen_parm: failure opening GENPARM.TBL' #if _COUPLED_ CALL wrf_error_fatal ( message ) #else write(*,*) message stop #endif END IF READ (19,*) READ (19,*) READ (19,*) NUM_SLOPE SLPCATS=NUM_SLOPE ! prevent possible array overwrite, Bill Bovermann, IBM, May 6, 2008 IF ( SIZE(slope_data) < NUM_SLOPE ) THEN #if _COUPLED_ CALL wrf_error_fatal('NUM_SLOPE too large for slope_data array in module_sf_noahdrv') #else write(*,*) 'NUM_SLOPE too large for slope_data array in module_sf_noahdrv' stop #endif ENDIF DO LC=1,SLPCATS READ (19,*)SLOPE_DATA(LC) ENDDO READ (19,*) READ (19,*)SBETA_DATA READ (19,*) READ (19,*)FXEXP_DATA READ (19,*) READ (19,*)CSOIL_DATA READ (19,*) READ (19,*)SALP_DATA READ (19,*) READ (19,*)REFDK_DATA READ (19,*) READ (19,*)REFKDT_DATA READ (19,*) READ (19,*)FRZK_DATA READ (19,*) READ (19,*)ZBOT_DATA READ (19,*) READ (19,*)CZIL_DATA READ (19,*) READ (19,*)SMLOW_DATA READ (19,*) READ (19,*)SMHIGH_DATA CLOSE (19) #if _COUPLED_ ENDIF #endif #if _COUPLED_ CALL wrf_dm_bcast_integer ( NUM_SLOPE , 1 ) CALL wrf_dm_bcast_integer ( SLPCATS , 1 ) CALL wrf_dm_bcast_real ( SLOPE_DATA , NSLOPE ) CALL wrf_dm_bcast_real ( SBETA_DATA , 1 ) CALL wrf_dm_bcast_real ( FXEXP_DATA , 1 ) CALL wrf_dm_bcast_real ( CSOIL_DATA , 1 ) CALL wrf_dm_bcast_real ( SALP_DATA , 1 ) CALL wrf_dm_bcast_real ( REFDK_DATA , 1 ) CALL wrf_dm_bcast_real ( REFKDT_DATA , 1 ) CALL wrf_dm_bcast_real ( FRZK_DATA , 1 ) CALL wrf_dm_bcast_real ( ZBOT_DATA , 1 ) CALL wrf_dm_bcast_real ( CZIL_DATA , 1 ) CALL wrf_dm_bcast_real ( SMLOW_DATA , 1 ) CALL wrf_dm_bcast_real ( SMHIGH_DATA , 1 ) #endif !----------------------------------------------------------------- END SUBROUTINE SOIL_VEG_GEN_PARM !----------------------------------------------------------------- end MODULE module_read_tables_sample_subroutine program sample use module_read_tables_sample_subroutine integer :: n character(len=256) :: mminlu = "USGS" ! character(len=256) :: mminlu = "MODIFIED_IGBP_MODIS_NOAH" character(len=256) :: mminsl = "STAS" call soil_veg_gen_parm(mminlu, mminsl) write(*,'("Vegetation parameters")') do n = 1, LUCATS write(*,'(I2,14F12.5)') N, SNUPTBL(N), RSTBL(N), RGLTBL(N), HSTBL(N), SHDTBL(N), MAXALB(N), & EMISSMINTBL(N), EMISSMAXTBL(N), LAIMINTBL(N), LAIMAXTBL(N), Z0MINTBL(N), Z0MAXTBL(N), & ALBEDOMINTBL(N), ALBEDOMAXTBL(N) enddo write(*,*) TOPT_DATA write(*,*) CMCMAX_DATA write(*,*) CFACTR_DATA write(*,*) RSMAX_DATA write(*,*) BARE write(*,*) NATURAL write(*,'(/,"Soil parameters")') do n = 1, SLCATS write(*,'(I2, 10F12.5)') n, bb(n), drysmc(n), f11(n), maxsmc(n), refsmc(n), satpsi(n), satdk(n), satdw(n), wltsmc(n), qtz(n) enddo write(*,'(/,"General parameters")') write(*,'(100F12.4)') SLOPE_DATA(1:SLPCATS) write(*,*) SBETA_DATA write(*,*) FXEXP_DATA write(*,*) CSOIL_DATA write(*,*) SALP_DATA write(*,*) REFDK_DATA write(*,*) REFKDT_DATA write(*,*) FRZK_DATA write(*,*) ZBOT_DATA write(*,*) CZIL_DATA write(*,*) SMLOW_DATA write(*,*) SMHIGH_DATA end program sample