! ! $Author: pkubota $ ! $Date: 2008/04/09 12:42:57 $ ! $Revision: 1.12 $ ! MODULE SFC_SSiB ! InitSSiB ! !fysiks -----| pbl ------| root ! | | ! | | raduse ! | | ! | | stomat ! | | ! | | interc ! | | ! | | sflxes ------| vntlax ! | | ! | | rbrd ! | | ! | | cut ! | | ! | | stres2 ! | | ! | | temres ! | | ! | | update ! | | ! | | airmod ! | ! | snowm ! | ! | runoff ! | ! | seasfc ------| vntlt1 ! | ! | sextrp ! | ! | sibwet ------| extrak ! | ! | sibwet_GLSM ------| extrak ! | ! | Albedo --- radalb ! | ! | radalb ! | ! | vegin ! | ! |re_assign_sib_soil_prop ! | ! | wheat USE Constants, ONLY : & ityp, imon, icg, iwv, idp, ibd, tice,& gasr, & pie, & cp, & hl, & grav, & stefan, & snomel, & tf, & epsfac, & clai, & athird, & cw, & z0ice, & oceald , & icealn , & icealv , & r8,i8,r4,i4 USE Options, ONLY: & nfsibt,fNameSibmsk,& nftgz0,fNameTg3zrl,& nfzol,fNameRouLen,& reducedGrid,initlz,& ifalb , ifsst , & ifslm , ifsnw , & ifozone, sstlag, & intsst , fint , & iglsm_w, mxiter, & record_type, fNameSoilType ,& fNameVegType,fNameSoilMoist,& nfsoiltp,nfvegtp,nfslmtp,nfsibi,isimp,& nfprt , nfctrl, nfsibd, nfalb,filta,epsflt,istrt,Model1D,yrl,monl,schemes,& ifndvi,intsoilm,& ifslmSib2,& intndvi,iftracer,OCFLUX,omlmodel,oml_hml0,SLABOCEAN,atmpbl,ICEMODEL USE Parallelism, ONLY: & MsgOne, FatalError USE Utils, ONLY: & IJtoIBJB, & NearestIJtoIBJB, & LinearIJtoIBJB, & AveBoxIJtoIBJB, & FreqBoxIJtoIBJB, & vfirec USE InputOutput, ONLY: & getsbc USE IOLowLevel, ONLY: & ReadVar , & ReadGetNFTGZ USE Sfc_SeaFlux_Interface , Only : seasfc USE SlabOceanModel , Only : GetOceanAlb USE Sfc_SeaIceFlux_WRF_Model , Only : GetIceOceanAlb,& TC_SeaIce ,& TGS_SeaIce ,& TD_SeaIce ,& TA_SeaIce ,& SNOA_SeaIce,& SNOB_SeaIce USE FieldsPhysics, ONLY: & npatches , & npatches_actual, & nzg , & sheleg , & imask , & AlbVisDiff , & gtsea , & gndvi , & soilm , & o3mix , & tg1 , & tg2 , & tg3 , & rVisDiff , & ssib , & wsib3d , & ppli , & ppci , & capac0 , & gl0 , & Mmlen , & tseam , & w0 , & td0 , & tg0 , & tc0 , & tm0 , & qm0 , & tmm , & qmm , & tcm , & tgm , & tdm , & wm , & capacm , & qsfc0 , & tsfc0 , & qsfcm , & tsfcm , & z0 , & zorl , & tkemyj , & MskAnt , & tracermix , & HML , & HUML , & HVML , & TSK , & z0sea , & mlsi , & ! add solange 13-11-2012 sm0 , & ! add solange 13-11-2012 sfc,PBL_CoefKm, PBL_CoefKh,tauresx,tauresy IMPLICIT NONE PRIVATE PUBLIC :: Init_SSiB PUBLIC :: Finalize_SSiB PUBLIC :: InitCheckSSiBFile PUBLIC :: InitSurfTemp PUBLIC :: ReStartSSiB PUBLIC :: Albedo PUBLIC :: Phenology PUBLIC :: SSiB_Driver PUBLIC :: x0x PUBLIC :: xd PUBLIC :: xdc PUBLIC :: xbc REAL(KIND=r8) :: expcut REAL(KIND=r8) :: rbyg REAL(KIND=r8) , ALLOCATABLE :: cedfu (:,:,:) REAL(KIND=r8) , ALLOCATABLE :: cedir (:,:,:,:) REAL(KIND=r8) , ALLOCATABLE :: cedfu1(:,:,:,:,:) REAL(KIND=r8) , ALLOCATABLE :: cedir1(:,:,:,:,:,:) REAL(KIND=r8) , ALLOCATABLE :: cedfu2(:,:,:,:,:) REAL(KIND=r8) , ALLOCATABLE :: cedir2(:,:,:,:,:,:) REAL(KIND=r8) , ALLOCATABLE :: cledfu(:,:,:) REAL(KIND=r8) , ALLOCATABLE :: cledir(:,:,:,:) REAL(KIND=r8) , ALLOCATABLE :: xmiu (:,:) REAL(KIND=r8) , ALLOCATABLE :: cether(:,:,:) REAL(KIND=r8) , ALLOCATABLE :: xmiw (:,:) REAL(KIND=r8) , ALLOCATABLE :: ystpar(:,:) REAL(KIND=r8) , ALLOCATABLE :: yopt (:) REAL(KIND=r8) , ALLOCATABLE :: yll (:) REAL(KIND=r8) , ALLOCATABLE :: yu (:) REAL(KIND=r8) , ALLOCATABLE :: yefac (:) REAL(KIND=r8) , ALLOCATABLE :: yh1 (:) REAL(KIND=r8) , ALLOCATABLE :: yh2 (:) REAL(KIND=r8) , ALLOCATABLE :: yootd (:) REAL(KIND=r8) , ALLOCATABLE :: yreen (:,:) REAL(KIND=r8) , ALLOCATABLE :: ycover(:,:) REAL(KIND=r8) , ALLOCATABLE :: ylt (:,:) REAL(KIND=r8) , ALLOCATABLE :: rstpar_fixed (:,:,:) REAL(KIND=r8) , ALLOCATABLE :: chil_fixed (:,:) REAL(KIND=r8) , ALLOCATABLE :: topt_fixed (:,:) REAL(KIND=r8) , ALLOCATABLE :: tll_fixed (:,:) REAL(KIND=r8) , ALLOCATABLE :: tu_fixed (:,:) REAL(KIND=r8) , ALLOCATABLE :: defac_fixed (:,:) REAL(KIND=r8) , ALLOCATABLE :: ph1_fixed (:,:) REAL(KIND=r8) , ALLOCATABLE :: ph2_fixed (:,:) REAL(KIND=r8) , ALLOCATABLE :: rootd (:,:) REAL(KIND=r8) , ALLOCATABLE :: bee (:) REAL(KIND=r8) , ALLOCATABLE :: phsat (:) REAL(KIND=r8) , ALLOCATABLE :: satco (:) REAL(KIND=r8) , ALLOCATABLE :: poros (:) REAL(KIND=r8) , ALLOCATABLE :: zdepth (:,:) REAL(KIND=r8) , ALLOCATABLE :: green_fixed (:,:,:) REAL(KIND=r8) , ALLOCATABLE :: xcover_fixed (:,:,:) REAL(KIND=r8) , ALLOCATABLE :: zlt_fixed (:,:,:) REAL(KIND=r8) , ALLOCATABLE :: x0x (:,:) REAL(KIND=r8) , ALLOCATABLE :: xd (:,:) REAL(KIND=r8) , ALLOCATABLE :: z2 (:,:) REAL(KIND=r8) , ALLOCATABLE :: z1 (:,:) REAL(KIND=r8) , ALLOCATABLE :: xdc (:,:) REAL(KIND=r8) , ALLOCATABLE :: xbc (:,:) REAL(KIND=r8) , ALLOCATABLE :: zlt(:, :, :) REAL(KIND=r8) , ALLOCATABLE :: xcover (:, :, :) REAL(KIND=r8) , ALLOCATABLE :: ph2(:,:) REAL(KIND=r8) , ALLOCATABLE :: ph1(:,:) REAL(KIND=r8) , ALLOCATABLE :: green(:,:,:) REAL(KIND=r8) , ALLOCATABLE :: defac(:,:) REAL(KIND=r8) , ALLOCATABLE :: tu(:,:) REAL(KIND=r8) , ALLOCATABLE :: tll(:,:) REAL(KIND=r8) , ALLOCATABLE :: topt(:,:) REAL(KIND=r8) , ALLOCATABLE :: rstpar(:,:,:) REAL(KIND=r8) , ALLOCATABLE :: chil(:,:) REAL(KIND=r8), TARGET , ALLOCATABLE :: vcover_gbl (:,:,:) REAL(KIND=r8) , ALLOCATABLE :: zlt_gbl (:,:,:) REAL(KIND=r8) , ALLOCATABLE :: green_gbl (:,:,:) REAL(KIND=r8) , ALLOCATABLE :: chil_gbl (:,:,:) REAL(KIND=r8) , ALLOCATABLE :: topt_gbl (:,:,:) REAL(KIND=r8) , ALLOCATABLE :: tll_gbl (:,:,:) REAL(KIND=r8) , ALLOCATABLE :: tu_gbl (:,:,:) REAL(KIND=r8) , ALLOCATABLE :: defac_gbl (:,:,:) REAL(KIND=r8) , ALLOCATABLE :: ph2_gbl (:,:,:) REAL(KIND=r8) , ALLOCATABLE :: ph1_gbl (:,:,:) REAL(KIND=r8) , ALLOCATABLE :: rstpar_gbl (:,:,:,:) ! REAL(KIND=r8) , ALLOCATABLE :: snow_gbl (:,:,:) REAL(KIND=r8), ALLOCATABLE :: satcap3d (:,:,:) REAL(KIND=r8), ALLOCATABLE :: extk_gbl (:,:,:,:,:) REAL(KIND=r8), ALLOCATABLE :: radfac_gbl(:,:,:,:,:) REAL(KIND=r8), ALLOCATABLE :: closs_gbl (:,:) REAL(KIND=r8), ALLOCATABLE :: gloss_gbl (:,:) REAL(KIND=r8), ALLOCATABLE :: thermk_gbl(:,:) REAL(KIND=r8), ALLOCATABLE :: p1f_gbl (:,:) REAL(KIND=r8), ALLOCATABLE :: p2f_gbl (:,:) REAL(KIND=r8), ALLOCATABLE :: tgeff_gbl (:,:) REAL(KIND=r8), PUBLIC, ALLOCATABLE :: zlwup_SSiB (:,:) REAL(KIND=r8), ALLOCATABLE :: AlbGblSSiB(:,:,:,:) INTEGER(KIND=i8), ALLOCATABLE :: MskAntSSiB (:,:) INTEGER(KIND=i8), ALLOCATABLE :: iMaskSSiB (:,:) REAL(KIND=r8), ALLOCATABLE :: glsm_w (:,:,:) ! initial soil wetness data at soil model REAL(KIND=r8), ALLOCATABLE:: veg_type (:,:,:)! SIB veg type REAL(KIND=r8), PUBLIC, ALLOCATABLE :: frac_occ(:,:,:) ! fractional area ! coverage REAL(KIND=r8), PUBLIC, ALLOCATABLE, DIMENSION(:,: ) :: soil_type! FAO/USDA soil texture CHARACTER(LEN=200) :: path_in CHARACTER(LEN=200) :: fNameSibVeg CHARACTER(LEN=200) :: fNameSibAlb real, parameter, public :: MAPL_AIRMW = 28.97 ! kg/Kmole real, parameter, public :: MAPL_H2OMW = 18.01 ! kg/Kmole real, parameter, public :: MAPL_VIREPS = MAPL_AIRMW/MAPL_H2OMW-1.0 ! -- CONTAINS SUBROUTINE Init_SSiB(ibMax ,jbMax ,iMax ,jMax , & kMax ,delsig ,path ,fNameSibVeg_in, & fNameSibAlb_in,ifdy ,ids , & idc ,ifday ,tod ,todsib , & idate ,idatec ,si ,sl , & ibMaxPerJB ) INTEGER, INTENT(IN) :: ibMax INTEGER, INTENT(IN) :: jbMax INTEGER, INTENT(IN) :: iMax INTEGER, INTENT(IN) :: jMax INTEGER, INTENT(IN) :: kMax REAL(KIND=r8) , INTENT(IN ) :: delsig(kMax) CHARACTER(LEN=*), INTENT(IN ) :: path CHARACTER(LEN=*), INTENT(IN ) :: fNameSibVeg_in CHARACTER(LEN=*), INTENT(IN ) :: fNameSibAlb_in INTEGER , INTENT(OUT ) :: ifdy INTEGER , INTENT(OUT ) :: ids(4) INTEGER , INTENT(OUT ) :: idc(4) INTEGER , INTENT(IN ) :: ifday REAL(KIND=r8) , INTENT(IN ) :: tod REAL(KIND=r8) , INTENT(OUT ) :: todsib INTEGER , INTENT(IN ) :: idate(4) INTEGER , INTENT(IN ) :: idatec(4) REAL(KIND=r8) , INTENT(IN ) :: si(kMax+1) REAL(KIND=r8) , INTENT(IN ) :: sl(kMax) INTEGER , INTENT(IN ) :: ibMaxPerJB(jbMax) expcut=- LOG(1.0e53_r8) rbyg =gasr/grav*delsig(1)*0.5_r8 path_in=path fNameSibVeg = fNameSibVeg_in fNameSibAlb = fNameSibAlb_in ALLOCATE(vcover_gbl (ibMax,jbMax,icg) ) vcover_gbl=0.0_r8 sfc%vcover=>vcover_gbl(1:ibMax,1:jbMax,1) ALLOCATE(zlt_gbl (ibMax,jbMax,icg)) zlt_gbl =0.0_r8 ALLOCATE(green_gbl (ibMax,jbMax,icg)) green_gbl =0.0_r8 ALLOCATE(chil_gbl (ibMax,jbMax,icg)) chil_gbl =0.0_r8 ALLOCATE(topt_gbl (ibMax,jbMax,icg)) topt_gbl =0.0_r8 ALLOCATE(tll_gbl (ibMax,jbMax,icg)) tll_gbl =0.0_r8 ALLOCATE(tu_gbl (ibMax,jbMax,icg)) tu_gbl=0.0_r8 ALLOCATE(defac_gbl (ibMax,jbMax,icg)) defac_gbl =0.0_r8 ALLOCATE(ph2_gbl (ibMax,jbMax,icg)) ph2_gbl =0.0_r8 ALLOCATE(ph1_gbl (ibMax,jbMax,icg)) ph1_gbl =0.0_r8 ALLOCATE(rstpar_gbl (ibMax,jbMax,icg,iwv)) rstpar_gbl=0.0_r8 ! ALLOCATE(snow_gbl (ibMax,jbMax,icg)) ! snow_gbl =0.0_r8 ALLOCATE( satcap3d (ibMax,icg,jbMax)) satcap3d=0.0_r8 ALLOCATE( extk_gbl (ibMax,icg,iwv,ibd,jbMax)) extk_gbl=0.0_r8 ALLOCATE( radfac_gbl(ibMax,icg,iwv,ibd,jbMax)) radfac_gbl=0.0_r8 ALLOCATE( closs_gbl (ibMax,jbMax)) closs_gbl=0.0_r8 ALLOCATE( gloss_gbl (ibMax,jbMax)) gloss_gbl=0.0_r8 ALLOCATE( thermk_gbl(ibMax,jbMax)) thermk_gbl=0.0_r8 ALLOCATE( p1f_gbl (ibMax,jbMax)) p1f_gbl=0.0_r8 ALLOCATE( p2f_gbl (ibMax,jbMax)) p2f_gbl=0.0_r8 ALLOCATE( tgeff_gbl (ibMax,jbMax)) tgeff_gbl=0.0_r8 ALLOCATE( zlwup_SSiB(ibMax,jbMax)) zlwup_SSiB=0.0_r8 ALLOCATE( AlbGblSSiB(ibMax,2,2,jbMax)) AlbGblSSiB=0.0_r8 ALLOCATE(MskAntSSiB(ibMax,jbMax)) MskAntSSiB=0_i8 ALLOCATE(iMaskSSiB(ibMax,jbMax)) ;iMaskSSiB=0_i8 ALLOCATE(glsm_w (ibMax,jbMax,nzg )) glsm_w=0.0_r8 ALLOCATE(veg_type (ibMax,jbMax,npatches)) veg_type=0.0_r8 ALLOCATE(frac_occ (ibMax,jbMax,npatches)) frac_occ=0.0_r8 ALLOCATE(soil_type(ibMax,jbMax )) soil_type=0.0_r8 IF(TRIM(isimp).NE.'YES') THEN CALL InitSSiBBoundCond(iMax ,jMax ,ibMax,jbMax,kMax ,ifday ,& tod ,si(1) ,sl(1) ,idate ,& idatec ,ibMaxPerJB,ifdy ,& ids ,idc ,todsib ) END IF END SUBROUTINE Init_SSiB SUBROUTINE InitSSiBBoundCond(iMax ,& jMax ,& ibMax ,& jbMax ,& kMax ,& ifday ,& tod ,& si1 ,& sl1 ,& idate ,& idatec ,& ibMaxPerJB,& ifdy ,& ids ,& idc ,& todsib & ) IMPLICIT NONE INTEGER , INTENT(IN ) :: iMax INTEGER , INTENT(IN ) :: jMax INTEGER , INTENT(IN ) :: ibMax INTEGER , INTENT(IN ) :: jbMax INTEGER , INTENT(IN ) :: kMax INTEGER , INTENT(IN ) :: ifday REAL(KIND=r8), INTENT(IN ) :: tod REAL(KIND=r8), INTENT(IN ) :: si1 REAL(KIND=r8), INTENT(IN ) :: sl1 INTEGER , INTENT(IN ) :: idate (4) INTEGER , INTENT(IN ) :: idatec(4) INTEGER , INTENT(IN ) :: ibMaxPerJB(jbmax) INTEGER , INTENT(OUT ) :: ifdy INTEGER , INTENT(OUT ) :: ids (4) INTEGER , INTENT(OUT ) :: idc (4) REAL(KIND=r8), INTENT(OUT ) :: todsib INTEGER :: ncount INTEGER :: LRecIN INTEGER :: irec INTEGER :: ierr INTEGER(KIND=i4) :: ibuf (iMax,jMax) REAL(KIND=r4) :: brf (iMax,jMax) REAL(KIND=r8) :: buf (iMax,jMax,4) INTEGER(KIND=i8) :: imask_in (iMax,jMax) INTEGER(KIND=i8) :: mskant_in(iMax,jMax) REAL(KIND=r8) :: VegType (iMax,jMax,npatches) ! SIB veg type REAL(KIND=r8), ALLOCATABLE :: wsib (:,:) REAL(KIND=r8), PARAMETER :: t0 =271.17_r8 REAL(KIND=r8) :: sinmax REAL(KIND=r8), PARAMETER :: xl0 =10.0_r8 REAL(KIND=r8), PARAMETER :: zero =0.0e3_r8 REAL(KIND=r8), PARAMETER :: thousd=1.0e3_r8 CHARACTER(LEN=*), PARAMETER :: h='**(InitSSiBBoundCond)**' INTEGER :: ier(iMax,jMax) ! INTEGER :: ibMax !INTEGER :: jbMax INTEGER :: i INTEGER :: j ibuf=0 brf=0.0_r4 buf=0.0_r8 imask_in =0_i8 mskant_in=0_i8 sheleg=0.0_r8 buf=0.0_r8 ier=0 ! ibMax=size(imask,1) !jbMax=size(imask,2) ALLOCATE(wsib(ibMax,jbMax));wsib=0.0_r8 CALL vegin (si1 , sl1) INQUIRE (IOLENGTH=LRecIN) ibuf OPEN (UNIT=nfsibt, FILE=TRIM(fNameSibmsk),FORM='FORMATTED', ACCESS='SEQUENTIAL',& ACTION='READ',STATUS='OLD', IOSTAT=ierr) IF (ierr /= 0) THEN WRITE(UNIT=nfprt,FMT="('**(ERROR)** Open file ',a,' returned iostat=',i4)") & TRIM(fNameSibmsk), ierr STOP "**(ERROR)**" END IF brf=0.0_r4 INQUIRE (IOLENGTH=LRecIN) brf OPEN (UNIT=nftgz0,FILE=TRIM(fNameTg3zrl), FORM='FORMATTED', ACCESS='SEQUENTIAL', & ACTION='read', STATUS='OLD', IOSTAT=ierr) IF (ierr /= 0) THEN WRITE(UNIT=nfprt,FMT="('**(ERROR)** Open file ',a,' returned iostat=',i4)") & TRIM(fNameTg3zrl), ierr STOP "**(ERROR)**" END IF INQUIRE (IOLENGTH=LRecIN) brf OPEN (UNIT=nfzol,FILE=TRIM(fNameRouLen),FORM='FORMATTED', ACCESS='SEQUENTIAL',& ACTION='READ', STATUS='OLD', IOSTAT=ierr) IF (ierr /= 0) THEN WRITE(UNIT=nfprt,FMT="('**(ERROR)** Open file ',a,' returned iostat=',i4)") & TRIM(fNameRouLen), ierr STOP "**(ERROR)**" END IF READ(nfsibt, *) ibuf imask_in=ibuf IF (reducedGrid) THEN CALL FreqBoxIJtoIBJB(imask_in,iMaskSSiB) ELSE CALL IJtoIBJB( imask_in,iMaskSSiB) END IF imask=iMaskSSiB DO j=1,jMax DO i=1,iMax IF (imask_in(i,j) >= 1_i8) THEN ier(i,j) = 0 ELSE ier(i,j) = 1 END IF END DO IF (ANY( ier(1:iMax,j) /= 0)) THEN DO i=1,iMax mskant_in(i,j) = 1_i8 END DO ELSE DO i=1,iMax mskant_in(i,j) = 0_i8 END DO END IF END DO IF (reducedGrid) THEN CALL FreqBoxIJtoIBJB(mskant_in,MskAntSSiB) ELSE CALL IJtoIBJB( mskant_in,MskAntSSiB) END IF MskAnt=MskAntSSiB ! ! ! initialize sib variables ! IF( ifday == 0.AND. tod == 0.0_r8 .AND. initlz >= 0 ) THEN call MsgOne(h,'Cold start SSib variables') CALL getsbc (iMax ,jMax ,kMax, AlbVisDiff,gtsea,gndvi,soilm,sheleg,o3mix,tracermix,wsib3d,& ifday , tod ,idate ,idatec,& ifalb,ifsst,ifndvi,ifslm ,ifslmSib2,ifsnw,ifozone,iftracer, & sstlag,intsst,intndvi,intsoilm,fint ,tice , & yrl ,monl,ibMax,jbMax,ibMaxPerJB) irec=1 CALL ReadGetNFTGZ(nftgz0,irec,buf(1:iMax,1:jMax,1),buf(1:iMax,1:jMax,2),buf(1:iMax,1:jMax,3),'txt') READ (nfzol, *) brf buf(1:iMax,1:jMax,4)=brf(1:iMax,1:jMax) IF (reducedGrid) THEN CALL LinearIJtoIBJB(buf(1:iMax,1:jMax,1),tg1) !CALL AveBoxIJtoIBJB(buf(1:iMax,1:jMax,1),tg1) ELSE CALL IJtoIBJB(buf(1:iMax,1:jMax,1) ,tg1 ) END IF IF (reducedGrid) THEN CALL LinearIJtoIBJB(buf(1:iMax,1:jMax,2),tg2) !CALL AveBoxIJtoIBJB(buf(1:iMax,1:jMax,2),tg2) ELSE CALL IJtoIBJB(buf(1:iMax,1:jMax,2) ,tg2 ) END IF IF (reducedGrid) THEN CALL LinearIJtoIBJB(buf(1:iMax,1:jMax,3),tg3) !CALL AveBoxIJtoIBJB(buf(1:iMax,1:jMax,3),tg3) ELSE CALL IJtoIBJB(buf(1:iMax,1:jMax,3) ,tg3 ) END IF IF (reducedGrid) THEN CALL LinearIJtoIBJB(buf(1:iMax,1:jMax,4),zorl) !CALL AveBoxIJtoIBJB(buf(1:iMax,1:jMax,4),zorl) ELSE CALL IJtoIBJB(buf(1:iMax,1:jMax,4),zorl ) END IF z0 =zorl sinmax=150.0_r8 ! ! use rVisDiff as temporary for abs(soilm) ! DO j=1,jbMax DO i=1,ibMaxPerJB(j) rVisDiff(i,j)=ABS(soilm(i,j)) END DO END DO !-srf-------------------------------- IF(iglsm_w == 0) THEN IF(ifslm == 5 .AND. intsoilm <=0)THEN DO j=1,jbMax ncount=0 DO i=1,ibMaxPerJB(j) wsib(i,j)=wsib3d(i,j,3) ssib(i,j)=wsib3d(i,j,3) END DO END DO ELSE CALL sibwet(ibMax,jbMax,rVisDiff,sinmax,iMaskSSiB,wsib,ssib, & mxiter,ibMaxPerJB) END IF ELSE ! !- rotina para chamar leitura da umidade do solo ! CALL read_gl_sm_bc(imax , & jmax , & jbMax , & nzg , & npatches , & npatches_actual, & ibMaxPerJB , & record_type , & fNameSoilType , & fNameVegType , & fNameSoilMoist , & glsm_w , & soil_type , & veg_type , & frac_occ , & VegType ) CALL re_assign_sib_soil_prop(imax , & ! IN jmax , & ! IN npatches , & ! IN imask_in , & ! INOUT VegType ) ! IN IF (reducedGrid) THEN CALL FreqBoxIJtoIBJB(imask_in,iMaskSSiB) ELSE CALL IJtoIBJB( imask_in,iMaskSSiB) END IF ! !- for output isurf, use rlsm array ! DO j=1,jbMax DO i=1,ibMaxPerJB(j) ! rlsm(i,j)=REAL(imask(i,j),r8) END DO END DO CALL sibwet_GLSM (ibMax , & ! IN jbMax , & ! IN iMaskSSiB , & ! IN wsib , & ! OUT ssib , & ! IN mxiter , & ! IN ibMaxPerJB , & ! IN soilm , & ! OUT nzg , & ! in wsib3d , & ! OUT glsm_w) ! IN END IF !-srf-------------------------------- ppli =0.0_r8 ppci =0.0_r8 capac0=0.0_r8 capacm=0.0_r8 ! ! td0 (deep soil temp) is temporarily defined as tg3 ! !$OMP PARALLEL DO PRIVATE(ncount,i) DO j=1,jbMax ncount=0 DO i=1,ibMaxPerJB(j) gl0(i,j)=xl0 Mmlen(i,j)=xl0 IF(iMaskSSiB(i,j) >= 1_i8)gtsea(i,j)=290.0_r8 tseam(i,j)=gtsea(i,j) TSK (I,J)=ABS(gtsea(i,j)) IF (omlmodel) THEN HML (i,j) = oml_hml0 - 13.5_r8*log(MAX(ABS(TSK(i,j))-tice+0.01_r8,1.0_r8)) HUML (I,J)=0.0_r8 HVML (I,J)=0.0_r8 END IF IF(iMaskSSiB(i,j) == 0_i8) THEN IF(-gtsea(i,j).LT.t0) THEN iMaskSSiB(i,j)=-1_i8 imask(i,j)=-1_i8 END IF ELSE ncount=ncount+1 IF(iglsm_w == 0) THEN w0 (ncount,1,j)=wsib(i,j) w0 (ncount,2,j)=wsib(i,j) w0 (ncount,3,j)=wsib(i,j) ELSE !-srf-------------------------------- w0 (ncount,1,j)=wsib3d(i,j,1) w0 (ncount,2,j)=wsib3d(i,j,2) w0 (ncount,3,j)=wsib3d(i,j,3) !-srf-------------------------------- END IF sm0(ncount,1,j)=w0(ncount,1,j)*poros(imask(i,j)) sm0(ncount,2,j)=w0(ncount,2,j)*poros(imask(i,j)) sm0(ncount,3,j)=w0(ncount,3,j)*poros(imask(i,j)) td0 (ncount, j)=tg3 (i,j) IF(iglsm_w == 0) THEN wm (ncount,1,j)=wsib(i,j) wm (ncount,2,j)=wsib(i,j) wm (ncount,3,j)=wsib(i,j) ELSE !-srf-------------------------------- wm (ncount,1,j)=wsib3d(i,j,1) wm (ncount,2,j)=wsib3d(i,j,2) wm (ncount,3,j)=wsib3d(i,j,3) !-srf-------------------------------- END IF tdm (ncount, j)=tg3 (i,j) tgm (ncount, j)=tg3 (i,j) tcm (ncount, j)=tg3 (i,j) ssib (ncount,j )=0.0_r8 IF(soilm(i,j).LT.0.0_r8)ssib(ncount,j)=wsib(i,j) IF(sheleg(i,j).GT.zero) THEN capac0(ncount,2,j)=sheleg(i,j)/thousd capacm(ncount,2,j)=sheleg(i,j)/thousd END IF END IF END DO END DO !$OMP END PARALLEL DO ELSE call MsgOne(h,'Warm start SSib variables') READ(UNIT=nfsibi) ifdy,todsib,ids,idc READ(UNIT=nfsibi) tm0 ,tmm READ(UNIT=nfsibi) qm0 ,qmm READ(UNIT=nfsibi) td0 ,tdm READ(UNIT=nfsibi) tg0 ,tgm READ(UNIT=nfsibi) tc0 ,tcm READ(UNIT=nfsibi) w0 ,wm READ(UNIT=nfsibi) capac0,capacm READ(UNIT=nfsibi) ppci ,ppli,tkemyj READ(UNIT=nfsibi) gl0 ,zorl ,gtsea ,tseam,qsfc0,tsfc0,qsfcm,tsfcm,HML,HUML,HVML,TSK,z0sea,& TC_SeaIce,TGS_SeaIce,TD_SeaIce,TA_SeaIce,SNOA_SeaIce,SNOB_SeaIce,PBL_CoefKm, PBL_CoefKh,tauresx,tauresy Mmlen=gl0 REWIND nfsibi IF (initlz < 0 .AND. initlz >= -3 )THEN IF(initlz == -2 .or. initlz == -3 )ifsst=-1 CALL getsbc (iMax ,jMax ,kMax, AlbVisDiff,gtsea,gndvi,soilm,sheleg,o3mix,tracermix,wsib3d,& ifday , tod ,idate ,idatec,& ifalb,ifsst,ifndvi,ifslm ,ifslmSib2,ifsnw,ifozone,iftracer, & sstlag,intsst,intndvi,intsoilm,fint ,tice , & yrl ,monl,ibMax,jbMax,ibMaxPerJB) IF( initlz == -2 .or. initlz == -3 ) THEN !$OMP PARALLEL DO PRIVATE(i) DO j=1,jbMax DO i=1,ibMaxPerJB(j) IF(iMaskSSiB(i,j) >= 1_i8) gtsea(i,j)=290.0_r8 tseam(i,j) = gtsea(i,j) TSK (I,J) = ABS(gtsea(i,j)) IF (omlmodel) THEN HML (i,j) = oml_hml0 - 13.5_r8*log(MAX(ABS(TSK(i,j))-tice+0.01_r8,1.0_r8)) HUML (I,J)=0.0_r8 HVML (I,J)=0.0_r8 END IF IF(iMaskSSiB(i,j) == 0_i8) THEN IF(-gtsea(i,j).LT.t0) THEN iMaskSSiB(i,j)=-1_i8 imask(i,j)=-1_i8 END IF END IF END DO END DO !$OMP END PARALLEL DO END IF END IF !$OMP PARALLEL DO PRIVATE(ncount,i) DO j=1,jbMax ncount=0 DO i=1,ibMaxPerJB(j) IF(iMaskSSiB(i,j) >= 1_i8)THEN ncount=ncount+1 ssib(ncount,j)=0.0_r8 IF(w0(ncount,1,j).LT.0.0_r8)THEN ssib(ncount,j)=ABS(w0(ncount,1,j)) w0(ncount,1,j)=ABS(w0(ncount,1,j)) w0(ncount,2,j)=ABS(w0(ncount,2,j)) w0(ncount,3,j)=ABS(w0(ncount,3,j)) wm(ncount,1,j)=ABS(wm(ncount,1,j)) wm(ncount,2,j)=ABS(wm(ncount,2,j)) wm(ncount,3,j)=ABS(wm(ncount,3,j)) END IF sm0(ncount,1,j)=w0(ncount,1,j)*poros(imask(i,j)) sm0(ncount,2,j)=w0(ncount,2,j)*poros(imask(i,j)) sm0(ncount,3,j)=w0(ncount,3,j)*poros(imask(i,j)) END IF END DO END DO !$OMP END PARALLEL DO IF(nfctrl(5).GE.1)WRITE(UNIT=nfprt,FMT=444) ifdy,todsib,ids,idc END IF DEALLOCATE(wsib) 444 FORMAT(' SIB PROGNOSTIC VARIABLES READ IN. AT FORECAST DAY', & I8,' TOD ',F8.1/' STARTING',3I3,I5,' CURRENT',3I3,I5) END SUBROUTINE InitSSiBBoundCond SUBROUTINE SSiB_Driver(& jdt ,latitu ,dtc3x ,ncols ,& nmax ,kMax ,ktm ,initlz ,& kt ,nsx ,iswrad ,ilwrad ,& gt ,gq ,gu ,gv ,& gps ,tmtx ,qmtx ,umtx ,& zenith ,colrad ,cos2 ,mon ,& cosz ,beam_visb ,beam_visd ,beam_nirb ,& beam_nird ,dlwbot ,xvisb ,xvisd ,& xnirb ,xnird ,slrad ,ppli ,& ppci ,tsea ,ssib ,intg ,& tseam ,tsurf ,qsurf ,sigki ,& delsig ,imask ,itype ,tg ,& ra ,rb ,rd ,rc ,& rg ,ta ,ea ,etc ,& etg ,radt ,rst ,rsoil ,& ect ,eci ,egt ,egi ,& egs ,ec ,eg ,hc ,& hg ,egmass ,etmass ,hflux ,& chf ,shf ,fluxef ,roff ,& drag ,cu ,ustar ,hr ,& sens ,evap ,umom ,vmom ,& zorl ,rmi ,rhi ,cond ,& stor ,z0x ,speedm ,Ustarm ,& z0sea ,rho ,d ,qsfc ,& tsfc ,mskant ,bstar , & HML ,HUML ,HVML , & TSK ,cldtot ,ySwSfcNet ,LwSfcNet ,& pblh ,QCF ,QCL , & sm0 ,mlsi ,LwSfcDown ,month ,& Mmlen )! add solange: sm0, mlsi 13-11-2012 IMPLICIT NONE INTEGER , INTENT(in ) :: jdt INTEGER , INTENT(in ) :: latitu REAL(KIND=r8), INTENT(in ) :: dtc3x INTEGER , INTENT(in ) :: nCols INTEGER , INTENT(in ) :: nmax INTEGER , INTENT(in ) :: kMax INTEGER , INTENT(IN ) :: ktm INTEGER , INTENT(IN ) :: initlz INTEGER , INTENT(IN ) :: kt INTEGER , INTENT(IN ) :: nsx(nCols) CHARACTER(len=*),INTENT(IN ) :: iswrad CHARACTER(len=*),INTENT(IN ) :: ilwrad REAL(KIND=r8), INTENT(INOUT) :: gt (nCols,kmax) REAL(KIND=r8), INTENT(INOUT) :: gq (nCols,kmax) REAL(KIND=r8), INTENT(IN ) :: gu (nCols,kmax) REAL(KIND=r8), INTENT(IN ) :: gv (nCols,kmax) REAL(KIND=r8), INTENT(IN ) :: gps (nCols) REAL(KIND=r8), INTENT(INOUT) :: tmtx (nCols,kmax,3) REAL(KIND=r8), INTENT(INOUT) :: qmtx (nCols,kmax,3) REAL(KIND=r8), INTENT(INOUT) :: umtx (nCols,kmax,4) REAL(KIND=r8), INTENT(IN ) :: zenith (nCols) REAL(KIND=r8), INTENT(IN ) :: colrad (nCols) REAL(KIND=r8), INTENT(IN ) :: cos2 (nCols) INTEGER , INTENT(inout) :: mon (ncols) REAL(KIND=r8), INTENT(inout) :: cosz (ncols) REAL(KIND=r8), INTENT(IN ) :: beam_visb(nCols) REAL(KIND=r8), INTENT(IN ) :: beam_visd(nCols) REAL(KIND=r8), INTENT(IN ) :: beam_nirb(nCols) REAL(KIND=r8), INTENT(IN ) :: beam_nird(nCols) REAL(KIND=r8), INTENT(IN ) :: dlwbot (nCols) REAL(KIND=r8), INTENT(IN ) :: xvisb (nCols) REAL(KIND=r8), INTENT(IN ) :: xvisd (nCols) REAL(KIND=r8), INTENT(IN ) :: xnirb (nCols) REAL(KIND=r8), INTENT(IN ) :: xnird (nCols) REAL(KIND=r8), INTENT(IN ) :: slrad (nCols) REAL(KIND=r8), INTENT(IN ) :: ppli (nCols) REAL(KIND=r8), INTENT(IN ) :: ppci (nCols) REAL(KIND=r8), INTENT(INOUT) :: tsea (nCols) REAL(KIND=r8), INTENT(IN ) :: ssib (ncols) REAL(KIND=r8), INTENT(INOUT) :: sm0 (ncols,3) INTEGER , INTENT(IN ) :: intg REAL(KIND=r8), INTENT(INOUT) :: tseam (nCols) REAL(KIND=r8), INTENT(INOUT) :: tsurf (nCols) REAL(KIND=r8), INTENT(IN ) :: qsurf (nCols) REAL(KIND=r8), INTENT(IN ) :: sigki (1) REAL(KIND=r8), INTENT(IN ) :: delsig (1:kMax) INTEGER(KIND=i8),INTENT(IN ) :: imask (nCols) INTEGER , INTENT(in ) :: itype (ncols) REAL(KIND=r8), INTENT(inout) :: tg (ncols) ! ! variables calculated from above and ambient conditions ! REAL(KIND=r8), INTENT(inout) :: ra (ncols) REAL(KIND=r8), INTENT(inout) :: rb (ncols) REAL(KIND=r8), INTENT(inout) :: rd (ncols) REAL(KIND=r8), INTENT(inout) :: rc (ncols) REAL(KIND=r8), INTENT(inout) :: rg (ncols) REAL(KIND=r8), INTENT(inout) :: ta (ncols) REAL(KIND=r8), INTENT(inout) :: ea (ncols) REAL(KIND=r8), INTENT(inout) :: etc (ncols) REAL(KIND=r8), INTENT(inout) :: etg (ncols) REAL(KIND=r8), INTENT(inout) :: radt (ncols,icg) REAL(KIND=r8), INTENT(inout) :: rst (ncols,icg) REAL(KIND=r8), INTENT(inout) :: rsoil (ncols) ! ! heat fluxes : c-canopy, g-ground, t-trans, e-evap in j m-2 ! REAL(KIND=r8), INTENT(inout) :: ect (ncols) REAL(KIND=r8), INTENT(inout) :: eci (ncols) REAL(KIND=r8), INTENT(inout) :: egt (ncols) REAL(KIND=r8), INTENT(inout) :: egi (ncols) REAL(KIND=r8), INTENT(inout) :: egs (ncols) REAL(KIND=r8), INTENT(inout) :: ec (ncols) REAL(KIND=r8), INTENT(inout) :: eg (ncols) REAL(KIND=r8), INTENT(inout) :: hc (ncols) REAL(KIND=r8), INTENT(inout) :: hg (ncols) REAL(KIND=r8), INTENT(inout) :: egmass(ncols) REAL(KIND=r8), INTENT(inout) :: etmass(ncols) REAL(KIND=r8), INTENT(inout) :: hflux (ncols) REAL(KIND=r8), INTENT(inout) :: chf (ncols) REAL(KIND=r8), INTENT(inout) :: shf (ncols) REAL(KIND=r8), INTENT(inout) :: fluxef(ncols) REAL(KIND=r8), INTENT(inout) :: roff (ncols) REAL(KIND=r8), INTENT(inout) :: drag (ncols) ! ! this is for coupling with closure turbulence model ! REAL(KIND=r8), INTENT(inout) :: cu (ncols) REAL(KIND=r8), INTENT(inout) :: ustar (ncols) REAL(KIND=r8), INTENT(inout) :: hr (ncols) REAL(KIND=r8), INTENT(INOUT) :: sens (nCols) REAL(KIND=r8), INTENT(INOUT) :: evap (nCols) REAL(KIND=r8), INTENT(INOUT) :: umom (nCols) REAL(KIND=r8), INTENT(INOUT) :: vmom (nCols) REAL(KIND=r8), INTENT(INOUT) :: zorl (nCols) REAL(KIND=r8), INTENT(INOUT) :: rmi (nCols) REAL(KIND=r8), INTENT(INOUT) :: rhi (nCols) REAL(KIND=r8), INTENT(INOUT) :: cond (nCols) REAL(KIND=r8), INTENT(INOUT) :: stor (nCols) REAL(KIND=r8), INTENT(INOUT) :: z0x (nCols) REAL(KIND=r8), INTENT(INOUT) :: speedm (nCols) REAL(KIND=r8), INTENT(INOUT) :: Ustarm (nCols) REAL(KIND=r8), INTENT(INOUT) :: z0sea (nCols) REAL(KIND=r8), INTENT(INOUT) :: rho (nCols) REAL(KIND=r8), INTENT(INOUT) :: d (ncols) REAL(KIND=r8), INTENT(INOUT) :: qsfc (ncols) REAL(KIND=r8), INTENT(INOUT) :: tsfc (ncols) INTEGER(KIND=i8),INTENT(IN ) :: mskant (ncols) INTEGER(KIND=i8), INTENT(INOUT) :: mlsi (ncols) REAL(KIND=r8),INTENT(out ) :: bstar (ncols) REAL(KIND=r8), INTENT(INOUT) :: HML (ncols) REAL(KIND=r8), INTENT(INOUT) :: HUML (ncols) REAL(KIND=r8), INTENT(INOUT) :: HVML (ncols) REAL(KIND=r8), INTENT(INOUT) :: TSK (ncols) REAL(KIND=r8) , INTENT(IN ) :: cldtot (nCols,kMax) REAL(KIND=r8) , INTENT(IN ) :: ySwSfcNet (ncols) REAL(KIND=r8) , INTENT(IN ) :: LwSfcNet (ncols) REAL(KIND=r8) , INTENT(IN ) :: pblh (ncols) REAL(KIND=r8) , INTENT(IN ) :: QCF(nCols,kMax) REAL(KIND=r8) , INTENT(IN ) :: QCL(nCols,kMax) REAL(KIND=r8) , INTENT(IN ) :: LwSfcDown(1:nCols ) INTEGER , INTENT(IN ) :: month(1:nCols) REAL(KIND=r8) , INTENT(IN ) :: Mmlen (1:nCols) ! ! the size of working area is ncols*187 ! atmospheric parameters as boudary values for sib ! REAL(KIND=r8) :: qm (ncols) REAL(KIND=r8) :: tm (ncols) REAL(KIND=r8) :: um (ncols) REAL(KIND=r8) :: vm (ncols) REAL(KIND=r8) :: psur(ncols) REAL(KIND=r8) :: ppc (ncols) REAL(KIND=r8) :: ppl (ncols) REAL(KIND=r8) :: radn(ncols,3,2) ! ! prognostic variables ! REAL(KIND=r8) :: tc (ncols) REAL(KIND=r8) :: td (ncols) REAL(KIND=r8) :: capac(ncols,2) REAL(KIND=r8) :: w (ncols,3) REAL(KIND=r8) :: tcta (ncols) REAL(KIND=r8) :: tgta (ncols) REAL(KIND=r8) :: btc (ncols) REAL(KIND=r8) :: btg (ncols) REAL(KIND=r8) :: u2 (ncols) REAL(KIND=r8) :: par (ncols,icg) REAL(KIND=r8) :: pd (ncols,icg) REAL(KIND=r8) :: phroot(ncols,icg) REAL(KIND=r8) :: hrr (ncols) REAL(KIND=r8) :: phsoil(ncols,idp) REAL(KIND=r8) :: cc (ncols) REAL(KIND=r8) :: cg (ncols) REAL(KIND=r8) :: satcap(ncols,icg) REAL(KIND=r8) :: snow (ncols,icg) REAL(KIND=r8) :: dtc (ncols) REAL(KIND=r8) :: dtg (ncols) REAL(KIND=r8) :: dtm (ncols) REAL(KIND=r8) :: dqm (ncols) REAL(KIND=r8) :: stm (ncols,icg) REAL(KIND=r8) :: extk (ncols,icg,iwv,ibd) REAL(KIND=r8) :: radfac(ncols,icg,iwv,ibd) REAL(KIND=r8) :: closs (ncols) REAL(KIND=r8) :: gloss (ncols) REAL(KIND=r8) :: thermk(ncols) REAL(KIND=r8) :: p1f (ncols) REAL(KIND=r8) :: p2f (ncols) REAL(KIND=r8) :: ecidif(ncols) REAL(KIND=r8) :: egidif(ncols) REAL(KIND=r8) :: ecmass(ncols) REAL(KIND=r8) :: bps (ncols) REAL(KIND=r8) :: psb (ncols) REAL(KIND=r8) :: dzm (ncols) REAL(KIND=r8) :: em (ncols) REAL(KIND=r8) :: gmt (ncols,3) REAL(KIND=r8) :: gmq (ncols,3) REAL(KIND=r8) :: gmu (ncols,4) REAL(KIND=r8) :: cuni (ncols) REAL(KIND=r8) :: ctni (ncols) REAL(KIND=r8) :: sinclt(ncols) REAL(KIND=r8) :: rhoair(ncols) REAL(KIND=r8) :: psy (ncols) REAL(KIND=r8) :: rcp (ncols) REAL(KIND=r8) :: wc (ncols) REAL(KIND=r8) :: wg (ncols) REAL(KIND=r8) :: fc (ncols) REAL(KIND=r8) :: fg (ncols) REAL(KIND=r8) :: zlwup_local (ncols) REAL(KIND=r8) :: salb (ncols,2,2) REAL(KIND=r8) :: tgeff (ncols) REAL(KIND=r8) :: rstpar2 (ncols,icg,iwv) REAL(KIND=r8) :: zlt2 (ncols,icg) REAL(KIND=r8) :: green2 (ncols,icg) REAL(KIND=r8) :: chil2 (ncols,icg) REAL(KIND=r8) :: vcover (ncols,icg) REAL(KIND=r8) :: rdc (ncols) REAL(KIND=r8) :: rbc (ncols) REAL(KIND=r8) :: z0 (ncols) REAL(KIND=r8) :: topt2 (ncols,icg) REAL(KIND=r8) :: tll2 (ncols,icg) REAL(KIND=r8) :: tu2 (ncols,icg) REAL(KIND=r8) :: defac2 (ncols,icg) REAL(KIND=r8) :: xsea (nCols) REAL(KIND=r8) :: tmin (ncols) REAL(KIND=r8) :: tmax (ncols) REAL(KIND=r8) :: z0xloc (ncols) REAL(KIND=r8) :: ph22 (ncols,icg) REAL(KIND=r8) :: ph12 (ncols,icg) REAL(KIND=r8) :: bstar1 (ncols) REAL(KIND=r8) :: cpsy REAL(KIND=r8) :: r100 REAL(KIND=r8) :: dzcut LOGICAL :: InitMod REAL(KIND=r8) :: GSW (nCols) REAL(KIND=r8) :: GLW (nCols) INTEGER :: ncount,i,n,m,k,ll,j,itr,ind,nint,IntSib pd=0.0_r8 phsoil=0.0_r8 PHROOT=0.0_r8 PAR=0.0_r8 SNOW=0.0_r8 STM=0.0_r8 ! ! cp ! cpsy = ------------ ! L*epsfac ! cpsy=cp/(hl*epsfac) r100=100.0e0_r8 /gasr DO i=1,nCols GSW(I) = xvisb (i)+xvisd (i)+xnirb (i)+xnird (i) GLW(I) = dlwbot (i) END DO DO j=1,icg DO i=1,nmax vcover (i,j) = vcover_gbl (i,latitu,j) zlt2 (i,j) = zlt_gbl (i,latitu,j) green2 (i,j) = green_gbl (i,latitu,j) chil2 (i,j) = chil_gbl (i,latitu,j) topt2 (i,j) = topt_gbl (i,latitu,j) tll2 (i,j) = tll_gbl (i,latitu,j) tu2 (i,j) = tu_gbl (i,latitu,j) defac2 (i,j) = defac_gbl (i,latitu,j) ph12 (i,j) = ph1_gbl (i,latitu,j) ph22 (i,j) = ph2_gbl (i,latitu,j) rstpar2 (i,j,1) = rstpar_gbl (i,latitu,j,1) rstpar2 (i,j,2) = rstpar_gbl (i,latitu,j,2) rstpar2 (i,j,3) = rstpar_gbl (i,latitu,j,3) satcap (i,j) = satcap3d (i,j,latitu) !snow (i,j) = snow_gbl (i,latitu,j) END DO END DO DO i=1,nmax closs(i) = closs_gbl(i,latitu) gloss(i) = gloss_gbl(i,latitu) thermk(i) = thermk_gbl(i,latitu) p1f (i) = p1f_gbl(i,latitu) p2f (i) = p2f_gbl(i,latitu) zlwup_local(i) = zlwup_SSiB(i,latitu) salb (i,1,1) = AlbGblSSiB(i,1,1,latitu) salb (i,1,2) = AlbGblSSiB(i,1,2,latitu) salb (i,2,1) = AlbGblSSiB(i,2,1,latitu) salb (i,2,2) = AlbGblSSiB(i,2,2,latitu) tgeff (i) = tgeff_gbl(i,latitu) END DO DO m=1,ibd DO n=1,iwv DO ll=1,icg DO i=1,nmax extk (i,ll,n,m) = extk_gbl (i,ll,n,m,latitu) radfac(i,ll,n,m) = radfac_gbl(i,ll,n,m,latitu) END DO END DO END DO END DO ! ! Forcing the soil moisture with observation data [specific case] ! IF(ifslm == 5) THEN DO k=1,3 ncount=0 DO i=1,nCols IF(imask(i) >= 1_i8)THEN ncount=ncount+1 wm(ncount,k,latitu)=wsib3d(i,j,k) w0(ncount,k,latitu)=wsib3d(i,j,k) END IF END DO END DO END IF ! ! Due implicit scheme of the ssib. Initializate the prognostics variable with time step t-1 ! DO i=1,nmax td (i) = tdm (i,latitu) tg (i) = tgm (i,latitu) tc (i) = tcm (i,latitu) capac(i,1) = capacm(i,1,latitu) capac(i,2) = capacm(i,2,latitu) w (i,1) = wm (i,1,latitu) w (i,2) = wm (i,2,latitu) w (i,3) = wm (i,3,latitu) END DO ncount=0 DO i=1,nCols IF(imask(i).GE.1_i8) THEN ncount=ncount+1 mlsi(i) = 1_i8 !add solange 13-11-2012 sinclt(ncount) = SIN(colrad(i)) psur(ncount)=gps(i) tm (ncount)=gt (i,1) qm (ncount)=gq (i,1) um (ncount)=gu (i,1)/SIN( colrad(i)) vm (ncount)=gv (i,1)/SIN( colrad(i)) psy (ncount)=cpsy*psur(ncount) ! ! P =rho*R*T and P = rho*g*Z ! ! P ! DP = rho*g*DZ and rho = ---- ! R*T ! P ! DP = ----*g*DZ ! R*T ! ! RT DP ! DZ = ---- * ----- ! g P ! ! RT P2 - P1 ! Z2 - Z1 = ----- *--------- ! g P2 ! ! ! R si(k) - si(k+1) ! dzm (i) = --- * (----------------) * tm(i) ! g 2 ! ! (J/kg/K) ! dzm (i) =--------*K ! m/s^2 ! ! J*s^2 ! dzm (i) = -----------*K ! kg*K * m ! ! (kg*m*s^-2*m)*s^2 ! dzm (i) = ---------------------*K ! kg*K * m ! ! (m*m) ! dzm (i) = --------- = m ! m dzm (ncount)=rbyg*tm(ncount) ! ! presure of vapor at atmosphere ! em (ncount)=qm(ncount)*psur(ncount)/(epsfac+qm(ncount)) ! ! Factor conversion to potention temperature ! bps (ncount)=sigki(1) ! ! Difference of pressure ! psb (ncount)=psur(ncount)*delsig(1) ! !Density of air ! ! ! P =rho*R*T ! ! P !rho =------- ! R*T ! ! 1 100*psur 1 Pa !rhoair(i) = ------- * ---------- = ----------- *----------------- ! R Tm (J/kg/K) K ! ! kg*K N/m^2 !rhoair(i) = ----------- *----------------- ! J K ! ! kg*K kg*m*s^-2* m^-2 !rhoair(i) = ---------------- * ----------------- ! (kg*m*s^-2*m) K ! ! kg !rhoair(i) = -------- ! m^3 ! rhoair(ncount)=r100*psur(ncount)/tm(ncount) ! ! J kg J ! rcp = -------- * ------- = ---------- ! kg * K m^3 K * m^3 ! rcp (ncount)=cp*rhoair(ncount) ! gmt (ncount,1)=tmtx(i,1,1) gmt (ncount,2)=tmtx(i,1,2) gmt (ncount,3)=tmtx(i,1,3) gmq (ncount,1)=qmtx(i,1,1) gmq (ncount,2)=qmtx(i,1,2) gmq (ncount,3)=qmtx(i,1,3) gmu (ncount,1)=umtx(i,1,1) gmu (ncount,2)=umtx(i,1,2) gmu (ncount,3)=umtx(i,1,3) gmu (ncount,4)=umtx(i,1,4) rbc (ncount) = xbc (itype(ncount),mon(ncount)) rdc (ncount) = xdc (itype(ncount),mon(ncount)) ! z0x (ncount) = x0x (itype(ncount),mon(ncount)) z0xloc (ncount) = x0x (itype(ncount),mon(ncount)) ! tvsgm - Global Mean Surface Virtual Temperature IF(itype(ncount) == 1) THEN ! dz - mean height of the first model layer !tvsgm=288.16_r8 !dz=(gasr*tvsgm/grav)*LOG(si1/sl1) ! Forest !dzcut=0.75_r8*dz dzcut=0.6_r8*dzm(ncount) d (ncount) = MIN(xd (itype(ncount),mon(ncount)),dzcut) IF((dzm(ncount) - d (ncount)) < 1.0_r8)dzm(ncount) = d (ncount) + 1.0_r8 !xd(1,1:imon)=MIN(xd(1,1:imon),dzcut) ELSE ! Other ! SiB calibration values ! 45 m - height of the first tower level of measurements ! 27 m - maximum calibrated displacement height dzcut=(27.0_r8/45.0_r8)*dzm(ncount) d (ncount) = MIN(xd (itype(ncount),mon(ncount)),dzcut) IF((dzm(ncount) - d (ncount)) < 1.0_r8)dzm(ncount) = d (ncount) + 1.0_r8 !xd(2:ityp,1:imon)=MIN(xd(2:ityp,1:imon),dzcut) END IF !d (ncount) = xd (itype(ncount),mon(ncount)) END IF END DO InitMod = (initlz >= 0 .AND. ktm == -1 .AND. kt == 0 .AND. nmax >= 1) IF(InitMod)THEN nint=2 IntSib=5 ELSE nint=1 IntSib=1 END IF IF(TRIM(iswrad).NE.'NON'.AND.TRIM(ilwrad).NE.'NON') THEN IF(InitMod)THEN DO ind=1,nint ncount=0 DO i=1,nCols IF(imask(i).GE.1_i8) THEN ncount=ncount+1 IF(ind.EQ.1) THEN ! ! night ! radn(ncount,1,1)=0.0e0_r8 radn(ncount,1,2)=0.0e0_r8 radn(ncount,2,1)=0.0e0_r8 radn(ncount,2,2)=0.0e0_r8 cosz(ncount) =0.0e0_r8 ELSE ! ! noon ! radn(ncount,1,1)=beam_visb (i) ! radn(1,1)=!Downward Surface shortwave fluxe visible beam (cloudy) radn(ncount,1,2)=beam_visd (i) ! radn(1,2)=!Downward Surface shortwave fluxe visible diffuse (cloudy) radn(ncount,2,1)=beam_nirb (i) ! radn(2,1)=!Downward Surface shortwave fluxe Near-IR beam (cloudy) radn(ncount,2,2)=beam_nird (i) ! radn(2,2)=!Downward Surface shortwave fluxe Near-IR diffuse (cloudy) cosz(ncount) =cos2(i) END IF radn(ncount,3,1)=0.0e0_r8 radn(ncount,3,2)=dlwbot(i) ! ! precipitation ! ppl (ncount) =0.0e0_r8 ppc (ncount) =0.0e0_r8 END IF END DO DO itr=1,IntSib CALL radalb( & nmax ,mon(1:nmax) ,nmax ,itype(1:nmax) , & tc(1:nmax) ,tg(1:nmax) ,capac(1:nmax,:) , & satcap(1:nmax,:) ,extk(1:nmax,:,:,:) ,radfac(1:nmax,:,:,:),closs(1:nmax) , & gloss(1:nmax) ,thermk(1:nmax) ,p1f(1:nmax) ,p2f(1:nmax) , & zlwup_local(1:nmax),salb(1:nmax,:,:) ,tgeff(1:nmax) ,cosz(1:nmax) , & nsx (1:nmax) ,latitu ) CALL fysiks(& vcover(1:nmax,:) ,z0xloc(1:nmax) ,d(1:nmax) ,rdc(1:nmax) ,& rbc(1:nmax) ,z0(1:nmax) ,jdt ,latitu ,& bps(1:nmax) ,psb(1:nmax) ,dzm(1:nmax) ,em(1:nmax) ,& gmt(1:nmax,:) ,gmq(1:nmax,:) ,gmu(1:nmax,:) ,cu(1:nmax) ,& cuni(1:nmax) ,ctni(1:nmax) ,ustar(1:nmax) ,cosz(1:nmax) ,& sinclt(1:nmax) ,rhoair(1:nmax) ,psy(1:nmax) ,rcp(1:nmax) ,& wc(1:nmax) ,wg(1:nmax) ,fc(1:nmax) ,fg(1:nmax) ,& hr(1:nmax) ,ect(1:nmax) ,eci(1:nmax) ,egt(1:nmax) ,& egi(1:nmax) ,egs(1:nmax) ,ec(1:nmax) ,eg(1:nmax) ,& hc(1:nmax) ,hg(1:nmax) ,ecidif(1:nmax) ,egidif(1:nmax) ,& ecmass(1:nmax) ,egmass(1:nmax) ,etmass(1:nmax) ,hflux(1:nmax) ,& chf(1:nmax) ,shf(1:nmax) ,fluxef(1:nmax) ,roff(1:nmax) ,& drag(1:nmax) ,ra(1:nmax) ,rb(1:nmax) ,rd(1:nmax) ,& rc(1:nmax) ,rg(1:nmax) ,tcta(1:nmax) ,tgta(1:nmax) ,& ta(1:nmax) ,ea(1:nmax) ,etc(1:nmax) ,etg(1:nmax) ,& btc(1:nmax) ,btg(1:nmax) ,u2(1:nmax) ,radt(1:nmax,:) ,& par(1:nmax,:) ,pd(1:nmax,:) ,rst(1:nmax,:) ,rsoil(1:nmax) ,& phroot(1:nmax,:) ,hrr(1:nmax) ,phsoil(1:nmax,:),cc(1:nmax) ,& cg(1:nmax) ,satcap(1:nmax,:) ,snow(1:nmax,:) ,dtc(1:nmax) ,& dtg(1:nmax) ,dtm(1:nmax) ,dqm(1:nmax) ,stm(1:nmax,:) ,& extk(1:nmax,:,:,:),radfac(1:nmax,:,:,:),closs(1:nmax) ,gloss(1:nmax) ,& thermk(1:nmax) ,p1f(1:nmax) ,p2f(1:nmax) ,tc(1:nmax) ,& tg(1:nmax) ,td(1:nmax) ,capac(1:nmax,:) ,w(1:nmax,:) ,& qm(1:nmax) ,tm(1:nmax) ,um(1:nmax) ,vm(1:nmax) ,& psur(1:nmax) ,ppc(1:nmax) ,ppl(1:nmax) ,radn(1:nmax,:,:),& itype(1:nmax) ,dtc3x ,mon (1:nmax) ,nmax ,& nmax ,zlt2(1:nmax,:) ,green2(1:nmax,:),chil2(1:nmax,:) ,& rstpar2(1:nmax,:,:),topt2(1:nmax,:) ,tll2(1:nmax,:) ,tu2(1:nmax,:) ,& defac2(1:nmax,:) ,ph12(1:nmax,:) ,ph22(1:nmax,:) ,bstar1(1:nmax)) ncount=0 DO i=1,nCols IF(imask(i).GE.1_i8) THEN ncount=ncount+1 tm (ncount )=gt (i,1) qm (ncount )=gq (i,1) gmt(ncount,1)=tmtx(i,1,1) gmt(ncount,2)=tmtx(i,1,2) gmt(ncount,3)=tmtx(i,1,3) gmq(ncount,1)=qmtx(i,1,1) gmq(ncount,2)=qmtx(i,1,2) gmq(ncount,3)=qmtx(i,1,3) gmu(ncount,1)=umtx(i,1,1) gmu(ncount,2)=umtx(i,1,2) gmu(ncount,3)=umtx(i,1,3) gmu(ncount,4)=umtx(i,1,4) END IF END DO END DO DO i=1,nmax capac(i,1)=capacm(i,1,latitu) capac(i,2)=capacm(i,2,latitu) w (i,1)=wm (i,1,latitu) w (i,2)=wm (i,2,latitu) w (i,3)=wm (i,3,latitu) td (i) =tdm (i,latitu) tc (i) =tcm (i,latitu) IF(ind.EQ.1) THEN tmin (i) =tg (i) ELSE tmax (i) =tg (i) END IF tg (i) =tgm(i,latitu) END DO END DO DO i=1,nmax td (i) =0.9_r8*0.5_r8*(tmax(i)+tmin(i))+0.1_r8*tdm(i,latitu) tdm (i,latitu) =td(i) td0 (i,latitu) =td(i) END DO ! ! this is a start of equilibrium tg,tc comp. ! ncount=0 DO i=1,nCols IF(imask(i).GE.1_i8) THEN ncount=ncount+1 cosz(ncount) =zenith(i) END IF END DO DO i=1,nmax IF(cosz(i).LT.0.0e0_r8) THEN tgm (i,latitu) =tmin(i) tg0 (i,latitu) =tmin(i) END IF END DO CALL radalb ( & nmax ,mon(1:nmax) ,nmax ,itype(1:nmax) , & tc(1:nmax) ,tg(1:nmax) ,capac(1:nmax,:) , & satcap(1:nmax,:) ,extk(1:nmax,:,:,:) ,radfac(1:nmax,:,:,:),closs(1:nmax) , & gloss(1:nmax) ,thermk(1:nmax) ,p1f(1:nmax) ,p2f(1:nmax) , & zlwup_local(1:nmax),salb(1:nmax,:,:) ,tgeff(1:nmax) ,cosz(1:nmax) , & nsx (1:nmax) ,latitu ) END IF END IF IF(nmax.GE.1) THEN ncount=0 DO i=1,nCols IF(imask(i).GE.1_i8) THEN ncount=ncount+1 ! ! this is for radiation interpolation ! IF(cosz(ncount).GE.0.01746e0_r8 ) THEN radn(ncount,1,1)=xvisb (i) radn(ncount,1,2)=xvisd (i) radn(ncount,2,1)=xnirb (i) radn(ncount,2,2)=xnird (i) ELSE radn(ncount,1,1)=0.0e0_r8 radn(ncount,1,2)=0.0e0_r8 radn(ncount,2,1)=0.0e0_r8 radn(ncount,2,2)=0.0e0_r8 END IF radn(ncount,3,1)=0.0e0_r8 radn(ncount,3,2)=dlwbot(i) ! ! precipitation ! ppl (ncount) =ppli (i) ppc (ncount) =ppci (i) END IF END DO CALL fysiks(& vcover(1:nmax,:) ,z0xloc(1:nmax) ,d(1:nmax) ,rdc(1:nmax) ,& rbc(1:nmax) ,z0(1:nmax) ,jdt ,latitu ,& bps(1:nmax) ,psb(1:nmax) ,dzm(1:nmax) ,em(1:nmax) ,& gmt(1:nmax,:) ,gmq(1:nmax,:) ,gmu(1:nmax,:) ,cu(1:nmax) ,& cuni(1:nmax) ,ctni(1:nmax) ,ustar(1:nmax) ,cosz(1:nmax) ,& sinclt(1:nmax) ,rhoair(1:nmax) ,psy(1:nmax) ,rcp(1:nmax) ,& wc(1:nmax) ,wg(1:nmax) ,fc(1:nmax) ,fg(1:nmax) ,& hr(1:nmax) ,ect(1:nmax) ,eci(1:nmax) ,egt(1:nmax) ,& egi(1:nmax) ,egs(1:nmax) ,ec(1:nmax) ,eg(1:nmax) ,& hc(1:nmax) ,hg(1:nmax) ,ecidif(1:nmax) ,egidif(1:nmax) ,& ecmass(1:nmax) ,egmass(1:nmax) ,etmass(1:nmax) ,hflux(1:nmax) ,& chf(1:nmax) ,shf(1:nmax) ,fluxef(1:nmax) ,roff(1:nmax) ,& drag(1:nmax) ,ra(1:nmax) ,rb(1:nmax) ,rd(1:nmax) ,& rc(1:nmax) ,rg(1:nmax) ,tcta(1:nmax) ,tgta(1:nmax) ,& ta(1:nmax) ,ea(1:nmax) ,etc(1:nmax) ,etg(1:nmax) ,& btc(1:nmax) ,btg(1:nmax) ,u2(1:nmax) ,radt(1:nmax,:) ,& par(1:nmax,:) ,pd(1:nmax,:) ,rst(1:nmax,:) ,rsoil(1:nmax) ,& phroot(1:nmax,:) ,hrr(1:nmax) ,phsoil(1:nmax,:),cc(1:nmax) ,& cg(1:nmax) ,satcap(1:nmax,:) ,snow(1:nmax,:) ,dtc(1:nmax) ,& dtg(1:nmax) ,dtm(1:nmax) ,dqm(1:nmax) ,stm(1:nmax,:) ,& extk(1:nmax,:,:,:),radfac(1:nmax,:,:,:),closs(1:nmax) ,gloss(1:nmax) ,& thermk(1:nmax) ,p1f(1:nmax) ,p2f(1:nmax) ,tc(1:nmax) ,& tg(1:nmax) ,td(1:nmax) ,capac(1:nmax,:) ,w(1:nmax,:) ,& qm(1:nmax) ,tm(1:nmax) ,um(1:nmax) ,vm(1:nmax) ,& psur(1:nmax) ,ppc(1:nmax) ,ppl(1:nmax) ,radn(1:nmax,:,:),& itype(1:nmax) ,dtc3x ,mon (1:nmax) ,nmax ,& nmax ,zlt2(1:nmax,:) ,green2(1:nmax,:),chil2(1:nmax,:) ,& rstpar2(1:nmax,:,:),topt2(1:nmax,:) ,tll2(1:nmax,:) ,tu2(1:nmax,:) ,& defac2(1:nmax,:) ,ph12(1:nmax,:) ,ph22(1:nmax,:) ,bstar1(1:nmax)) END IF ! ! temperature and snow depths in Antarctica and Groenland ! ncount=0 DO i=1,nCols IF(imask(i).GE.1_i8 ) THEN ncount=ncount+1 IF ( imask(i).EQ.13_i8 ) THEN w (ncount,1) = 1.0_r8 w (ncount,2) = 1.0_r8 w (ncount,3) = 1.0_r8 TD(ncount ) = MAX(MIN(TD(ncount) ,273.15_r8),218.15_r8) TC(ncount ) = MAX(MIN(TC(ncount) ,273.15_r8),218.15_r8) tg(ncount ) = MAX(MIN(tg(ncount) ,273.15_r8),218.15_r8) END IF END IF END DO ! ! sib time integaration and time filter ! DO i=1,nmax !tm(i)=ABS(ta(i))/bps(i) !qm(i)=0.622e0_r8*EXP(21.65605e0_r8 -5418.0e0_r8 /tm(i))/gps(i) qm(i)=MAX(1.0e-12_r8,qm(i)) END DO CALL sextrp ( & td(1:nCols) ,tg(1:nCols) ,tc(1:nmax) ,w(1:nCols,1:3) , & capac(1:nCols,1:2) ,td0(1:nCols,latitu) ,tg0(1:nCols,latitu) ,tc0 (1:nCols,latitu) , & w0(1:nCols,1:3,latitu) ,capac0(1:nCols,1:2,latitu),tdm(1:nCols,latitu) ,tgm(1:nCols,latitu) , & tcm(1:nCols,latitu) ,wm(1:nCols,1:3,latitu) ,capacm(1:nCols,1:2,latitu),istrt , & ncols ,nmax ,epsflt ,intg , & latitu ,tm0(1:nCols,latitu) ,qm0(1:nCols,latitu) ,tm(1:nCols) , & qm(1:nCols) ,tmm(1:nCols,latitu) ,qmm(1:nCols,latitu) ) ! ! fix soil moisture at selected locations ! DO i=1,nmax IF(ssib(i).GT.0.0_r8)THEN qm(i)=MAX(1.0e-12_r8,qm(i)) w0(i,1,latitu)=ssib(i) w0(i,2,latitu)=ssib(i) w0(i,3,latitu)=ssib(i) wm(i,1,latitu)=ssib(i) wm(i,2,latitu)=ssib(i) wm(i,3,latitu)=ssib(i) END IF END DO ncount=0 DO i=1,nCols IF(imask(i).GE.1_i8) THEN ncount=ncount+1 tmtx(i,1,3)=gmt(ncount,3) qmtx(i,1,3)=gmq(ncount,3) umtx(i,1,3)=gmu(ncount,3) umtx(i,1,4)=gmu(ncount,4) tsea(i) =tgeff(ncount) IF(omlmodel)TSK (i)=tgeff(ncount) z0x(ncount)=z0(ncount) END IF END DO ncount=0 DO i=1,nCols IF(imask(i).GE.1_i8 ) THEN ncount=ncount+1 IF ( imask(i).EQ.13_i8 ) THEN sm0 (ncount,1) = poros (imask(i)) ELSE sm0 (ncount,1) = w0(ncount,1,latitu)* poros (imask(i)) sm0 (ncount,2) = w0(ncount,2,latitu)* poros (imask(i)) sm0 (ncount,3) = w0(ncount,3,latitu)* poros (imask(i)) END IF END IF END DO ! ! sea or sea ice ! gu gv gps colrad sigki delsig sens evap umom vmom rmi rhi cond stor zorl rnet ztn2 THETA_2M VELC_2m MIXQ_2M ! THETA_10M VELC_10M MIXQ_10M ! including case 1D physics DO i=1,nCols IF(MskAnt(i) == 1_i8)THEN xsea (i) = tseam(i) tsfc (i) = tsfcm(i,latitu) qsfc (i) = qsfcm(i,latitu) END IF END DO CALL seasfc( & tmtx (1:nCols,1:kMax,1:3) ,umtx (1:nCols,1:kMax,1:4),qmtx (1:nCols,1:kMax,1:3) ,& kmax ,kmax ,slrad (1:nCols) ,& tsurf (1:nCols) ,qsurf (1:nCols) ,gu (1:nCols,1:kMax) ,& gv (1:nCols,1:kMax) ,gt (1:nCols,1:kMax) ,gq (1:nCols,1:kMax) ,& gps (1:nCols) ,xsea (1:nCols) ,dtc3x ,& SIN(colrad(1:nCols)) ,sigki (1) ,delsig(1:kMax) ,& sens (1:nCols) ,evap (1:nCols) ,umom (1:nCols) ,& vmom (1:nCols) ,rmi (1:nCols) ,rhi (1:nCols) ,& cond (1:nCols) ,stor (1:nCols) ,zorl (1:nCols) ,& nCols ,speedm(1:nCols) ,bstar (1:nCols) ,& Ustarm(1:nCols) ,z0sea (1:nCols) ,rho (1:nCols) ,& qsfc (1:nCols) ,tsfc (1:nCols) ,MskAnt(1:nCols) ,& iMask (1:nCols) ,zenith (1:nCols) ,ppli (1:nCols) ,& ppci (1:nCols) ,LwSfcDown(1:nCols) ,xvisb (1:nCols) ,& xvisd (1:nCols) ,xnirb(1:nCols) ,xnird (1:nCols) ,& HML (1:nCols) ,HUML (1:nCols) ,HVML (1:nCols) ,& TSK (1:nCols) ,GSW(1:nCols) ,GLW(1:nCols) ,& cldtot(1:nCols,1:kMax) ,ySwSfcNet(1:nCols) ,month(1:nCols) ,& LwSfcNet(1:nCols) ,pblh (1:nCols) ,QCF (1:nCols,1:kMax) ,& QCL (1:nCols,1:kMax) ,mlsi (1:nCols) ,latitu ,& Mmlen (1:nCols) ) DO i=1,nCols IF(MskAnt(i) == 1_i8 .and. tsea(i).LE.0.0e0_r8.AND.tsurf(i).LT.tice+0.01e0_r8 ) THEN IF(intg.EQ.2) THEN IF(istrt.EQ.0) THEN tseam(i)=filta*tsea (i) + epsflt*(tseam(i)+xsea(i)) qsfc (i)=MAX(1.0e-12_r8,qsfc(i)) tsfcm(i,latitu)=filta*tsfc0 (i,latitu) + epsflt*(tsfcm(i,latitu)+tsfc(i)) qsfcm(i,latitu)=filta*qsfc0 (i,latitu) + epsflt*(qsfcm(i,latitu)+qsfc(i)) END IF tsea (i) = xsea(i) qsfc (i) = MAX(1.0e-12_r8,qsfc(i)) tsfc0(i,latitu) = tsfc(i) qsfc0(i,latitu) = qsfc(i) ELSE tsea (i) = xsea(i) tseam(i) = xsea(i) qsfc (i) = MAX(1.0e-12_r8,qsfc(i)) tsfc0(i,latitu) = tsfc(i) qsfc0(i,latitu) = qsfc(i) tsfcm(i,latitu) = tsfc(i) qsfcm(i,latitu) = qsfc(i) END IF END IF IF(MskAnt(i) == 1_i8 .and. tsea(i).LT.0.0e0_r8.AND.tsurf(i).GE.tice+0.01e0_r8) THEN tseam(i) = tsea (i) tsfcm(i,latitu) = tsfc0(i,latitu) qsfcm(i,latitu) = qsfc0(i,latitu) END IF END DO ncount=0 DO i=1,nCols IF(imask(i).GE.1_i8) THEN ncount=ncount+1 bstar (i) = bstar1(ncount) sens (i) = (hc (ncount) + hg(ncount))*(1.0_r8/dtc3x) evap (i) = (ec (ncount) + eg(ncount))*(1.0_r8/dtc3x) QSfc0(i,latitu)=MAX(1.0e-12_r8,qm0 (ncount,latitu)) QSfcm(i,latitu)=MAX(1.0e-12_r8,qmm (ncount,latitu)) TSfc0(i,latitu)=tm0 (ncount,latitu) TSfcm(i,latitu)=tmm (ncount,latitu) zlwup_SSiB(ncount,latitu) = zlwup_local(ncount) z0x (ncount) = z0 (ncount) END IF END DO ! DO j=1,icg ! ncount=0 ! DO i=1,nCols ! IF(imask(i).GE.1_i8) THEN ! ncount=ncount+1 ! snow_gbl (ncount,latitu,j) =snow (ncount,j) ! END IF ! END DO ! END DO END SUBROUTINE SSiB_Driver SUBROUTINE CopySurfaceData(itype,mon,colrad2,xday,idatec,nsx,nCols,nmax,latitu) INTEGER , INTENT(IN ) :: nCols INTEGER , INTENT(IN ) :: nmax INTEGER , INTENT(IN ) :: latitu INTEGER , INTENT(in ) :: itype (nCols) INTEGER , INTENT(in ) :: mon (nCols) REAL(KIND=r8), INTENT(in ) :: colrad2 (nCols) REAL(KIND=r8), INTENT(in ) :: xday INTEGER , INTENT(in ) :: idatec(4) INTEGER , INTENT(inout) :: nsx (nCols) INTEGER :: i,j xcover = xcover_fixed zlt = zlt_fixed green = green_fixed ph2 = ph2_fixed ph1 = ph1_fixed defac = defac_fixed tu = tu_fixed tll = tll_fixed topt = topt_fixed rstpar = rstpar_fixed chil = chil_fixed DO j=1,icg DO i=1,nmax vcover_gbl (i,latitu,j) = xcover_fixed(itype(i),mon(i),j) zlt_gbl (i,latitu,j) = zlt_fixed (itype(i),mon(i),j) green_gbl (i,latitu,j) = green_fixed (itype(i),mon(i),j) chil_gbl (i,latitu,j) = chil_fixed (itype(i),j) topt_gbl (i,latitu,j) = topt_fixed (itype(i),j) tll_gbl (i,latitu,j) = tll_fixed (itype(i),j) tu_gbl (i,latitu,j) = tu_fixed (itype(i),j) defac_gbl (i,latitu,j) = defac_fixed (itype(i),j) ph1_gbl (i,latitu,j) = ph1_fixed (itype(i),j) ph2_gbl (i,latitu,j) = ph2_fixed (itype(i),j) rstpar_gbl (i,latitu,j,1)= rstpar_fixed(itype(i),j,1) rstpar_gbl (i,latitu,j,2)= rstpar_fixed(itype(i),j,2) rstpar_gbl (i,latitu,j,3)= rstpar_fixed(itype(i),j,3) END DO END DO CALL wheat (latitu,itype ,nmax ,colrad2 ,mon ,xday ,yrl , & idatec,monl ,nsx ) END SUBROUTINE CopySurfaceData ! airmod :alteration of aerodynamic transfer properties in case of snow ! accumulation. ! SUBROUTINE airmod (tg, capac, z0x, d, rdc, rbc, itype, & mon, nmax, ncols) ! ! !----------------------------------------------------------------------- ! input parameters !----------------------------------------------------------------------- ! tg............ground temperature ! tf............freezing point ! z2............height of canopy top ! capac(cg).....liquid water stored on canopy/ground cover foliage ! (m) ! d.............displacement height (m) ! z0x...........roughness length (m) ! rdc...........constant related to aerodynamic resistance ! between ground and canopy air space ! rbc...........constant related to bulk boundary layer ! resistance !----------------------------------------------------------------------- ! output parameters !----------------------------------------------------------------------- ! d.............displacement height (m) ! z0x...........roughness length (m) ! rdc...........constant related to aerodynamic resistance ! between ground and canopy air space ! rbc...........constant related to bulk boundary layer ! resistance !----------------------------------------------------------------------- !======================================================================= ! ncols.........Numero de ponto por faixa de latitude ! ityp..........Numero do tipo de solo 13 ! imon..........Numero maximo de meses no ano (12) ! mon...........Numero do mes do ano (1-12) ! nmax ! xd............Deslocamento do plano zero (m) ! itype.........Classe de textura do solo !======================================================================= INTEGER, INTENT(in ) :: ncols INTEGER, INTENT(in ) :: mon(ncols) INTEGER, INTENT(in ) :: nmax ! ! vegetation and soil parameters ! INTEGER, INTENT(in ) :: itype (ncols) REAL(KIND=r8), INTENT(inout) :: z0x (ncols) REAL(KIND=r8), INTENT(inout) :: d (ncols) REAL(KIND=r8), INTENT(inout) :: rdc (ncols) REAL(KIND=r8), INTENT(inout) :: rbc (ncols) ! ! prognostic variables ! REAL(KIND=r8), INTENT(in ) :: tg (ncols) REAL(KIND=r8), INTENT(in ) :: capac(ncols,2) ! REAL(KIND=r8) :: sdep(ncols) REAL(KIND=r8) :: xz (ncols) ! INTEGER :: i INTEGER :: ntyp DO i = 1, nmax IF( (tg(i) <= tf) .AND. (capac(i,2) >= 0.001_r8) )THEN ntyp=itype(i) xz (i)=z2(ntyp,mon(i)) sdep(i)=capac(i,2)*5.0_r8 sdep(i)=MIN( sdep(i) , xz(i)*0.95_r8 ) d (i)=xz (i)-( xz(i)- d(i) )/xz(i)*(xz(i)-sdep(i)) z0x(i)=z0x(i)/( xz(i)-xd(ntyp,mon(i)))*(xz(i)-d (i)) rdc(i)=rdc(i)*( xz(i)-sdep(i) )/xz(i) rbc(i)=rbc(i)*xz(i)/( xz(i)-sdep(i) ) END IF END DO END SUBROUTINE airmod SUBROUTINE temres(& bps ,psb ,em ,gmt ,gmq ,psy ,rcp ,wc ,wg , & fc ,fg ,hr ,hgdtg ,hgdtc ,hgdtm ,hcdtg ,hcdtc ,hcdtm , & egdtg ,egdtc ,egdqm ,ecdtg ,ecdtc ,ecdqm ,deadtg,deadtc,deadqm, & ect ,eci ,egt ,egi ,egs ,ec ,eg ,hc ,hg , & ecidif,egidif,ra ,rb ,rd ,rc ,rg ,ta ,ea , & etc ,etg ,btc ,btg ,radt ,rst ,rsoil ,hrr ,cc , & cg ,satcap,dtc ,dtg ,dtm ,dqm ,thermk,tc ,tg , & td ,capac ,qm ,tm ,psur ,dtc3x , & nmax ,vcover,ncols ) ! !----------------------------------------------------------------------- ! temres :performs temperature tendency equations with interception loss. !----------------------------------------------------------------------- ! ncols.......Numero de ponto por faixa de latitude ! ityp........numero das classes de solo 13 ! imon........Numero maximo de meses no ano (12) ! icg.........Parametros da vegetacao (icg=1 topo e icg=2 base) ! pie.........Constante Pi=3.1415926e0 ! stefan .....Constante de Stefan Boltzmann ! cp..........specific heat of air (j/kg/k) ! hl..........heat of evaporation of water (j/kg) ! grav........gravity constant (m/s**2) ! tf..........Temperatura de congelamento (K) ! epsfac......Constante 0.622 Razao entre as massas moleculares do vapor ! de agua e do ar seco ! dtc3x.......time increment dt ! nmax........ ! xcover......Fracao de cobertura vegetal icg=1 topo ! xcover......Fracao de cobertura vegetal icg=2 base ! vcover......Fracao de cobertura vegetal icg=1 topo ! vcover......Fracao de cobertura vegetal icg=2 topo ! qm..........specific humidity of reference (fourier) ! tm..........Temperature of reference (fourier) ! psur........surface pressure in mb ! tc..........Temperatura da copa "dossel" canopy leaf temperature(K) ! tg..........Temperatura da superficie do solo ground temperature (K) ! td .........Temperatura do solo profundo (K) ! capac(iv)...Agua interceptada iv=1 no dossel "water store capacity of leaves"(m) ! capac(iv)...Agua interceptada iv=2 na cobertura do solo (m) ! ra..........Resistencia Aerodinamica (s/m) ! rb..........bulk boundary layer resistance (s/m) ! rd..........aerodynamic resistance between ground ! and canopy air space (s/m) ! rc..........Resistencia do topo da copa (s/m) ! rg..........Resistencia da base da copa (s/m) ! ta..........Temperatura no nivel de fonte de calor do dossel (K) ! ea..........Pressao de vapor ! etc.........Pressure of vapor at top of the copa ! etg.........Pressao de vapor no base da copa ! btc.........btc(i)=EXP(30.25353 -5418.0 /tc(i))/(tc(i)*tc(i)). ! btg.........btg(i)=EXP(30.25353 -5418.0 /tg(i))/(tg(i)*tg(i)) ! radt........net heat received by canopy/ground vegetation ! rst.........Resisttencia Estomatica "Stomatal resistence" (s/m) ! rsoil ......Resistencia do solo (s/m) ! hrr.........rel. humidity in top layer ! cc..........heat capacity of the canopy ! cg..........heat capacity of the ground ! satcap......saturation liquid water capacity (m) ! dtc.........dtc(i)=pblsib(i,2,5)*dtc3x ! dtg.........dtg(i)=pblsib(i,1,5)*dtc3x ! dtm.........dtm(i)=pblsib(i,3,5)*dtc3x ! dqm.........dqm(i)=pblsib(i,4,5)*dtc3x ! thermk......canopy emissivity ! ect.........Transpiracao(J/m*m) ! eci.........Evaporacao da agua interceptada (J/m*m) ! egt.........Transpiracao na base da copa (J/m*m) ! egi.........Evaporacao da neve (J/m*m) ! egs.........Evaporacao do solo arido (J/m*m) ! ec..........Soma da Transpiracao e Evaporacao da agua interceptada pelo ! topo da copa ec (i)=eci(i)+ect(i) ! eg..........Soma da transpiracao na base da copa + Evaporacao do solo arido ! + Evaporacao da neve " eg (i)=egt(i)+egs(i)+egi(i)" ! hc..........total sensible heat lost of top from the veggies. ! hg..........total sensible heat lost of base from the veggies. ! ecidif......check if interception loss term has exceeded canopy storage ! ecidif(i)=MAX(0.0 , eci(i)-capac(i,1)*hl3 ) ! egidif......check if interception loss term has exceeded canopy storage ! ecidif(i)=MAX(0.0 , egi(i)-capac(i,1)*hl3 ) ! hgdtg ......n.b. fluxes expressed in joules m-2 ! hgdtc.......n.b. fluxes expressed in joules m-2 ! hgdtm.......n.b. fluxes expressed in joules m-2 ! hcdtg.......n.b. fluxes expressed in joules m-2 ! hcdtc.......n.b. fluxes expressed in joules m-2 ! hcdtm.......n.b. fluxes expressed in joules m-2 ! egdtg.......partial derivative calculation for latent heat ! egdtc.......partial derivative calculation for latent heat ! egdqm.......partial derivative calculation for latent heat ! ecdtg ......partial derivative calculation for latent heat ! ecdtc ......partial derivative calculation for latent heat ! ecdqm.......partial derivative calculation for latent heat ! deadtg...... ! deadtc...... ! deadqm...... ! bps......... ! psb......... ! em..........Pressao de vapor da agua ! gmt......... ! gmq.........specific humidity of reference (fourier) ! psy.........(cp/(hl*epsfac))*psur(i) ! rcp.........densidade do ar vezes o calor especifico do ar ! wc..........Minimo entre 1 e a razao entre a agua interceptada pelo ! indice de area foliar no topo da copa ! wg..........Minimo entre 1 e a razao entre a agua interceptada pelo ! indice de area foliar na base da copa ! fc..........Condicao de oravalho 0 ou 1 na topo da copa ! fg..........Condicao de oravalho 0 ou 1 na base da copa ! hr..........rel. humidity in top layer !----------------------------------------------------------------------- INTEGER, INTENT(in ) :: ncols REAL(KIND=r8), INTENT(in ) :: dtc3x INTEGER, INTENT(in ) :: nmax ! ! vegetation and soil parameters ! REAL(KIND=r8), INTENT(in) :: vcover(ncols,icg) ! ! the size of working area is ncols*187 ! atmospheric parameters as boudary values for sib ! REAL(KIND=r8), INTENT(in ) :: qm (ncols) REAL(KIND=r8), INTENT(in ) :: tm (ncols) REAL(KIND=r8), INTENT(in ) :: psur(ncols) ! ! prognostic variables ! REAL(KIND=r8), INTENT(in ) :: tc (ncols) REAL(KIND=r8), INTENT(in ) :: tg (ncols) REAL(KIND=r8), INTENT(in ) :: td (ncols) REAL(KIND=r8), INTENT(in ) :: capac(ncols,2) ! ! variables calculated from above and ambient conditions ! REAL(KIND=r8), INTENT(in ) :: ra (ncols) REAL(KIND=r8), INTENT(in ) :: rb (ncols) REAL(KIND=r8), INTENT(in ) :: rd (ncols) REAL(KIND=r8), INTENT(inout ) :: rc (ncols) REAL(KIND=r8), INTENT(inout ) :: rg (ncols) REAL(KIND=r8), INTENT(inout ) :: ta (ncols) REAL(KIND=r8), INTENT(inout ) :: ea (ncols) REAL(KIND=r8), INTENT(in ) :: etc (ncols) REAL(KIND=r8), INTENT(in ) :: etg (ncols) REAL(KIND=r8), INTENT(in ) :: btc (ncols) REAL(KIND=r8), INTENT(in ) :: btg (ncols) REAL(KIND=r8), INTENT(inout) :: radt (ncols,icg) REAL(KIND=r8), INTENT(inout) :: rst (ncols,icg) REAL(KIND=r8), INTENT(in ) :: rsoil (ncols) REAL(KIND=r8), INTENT(in ) :: hrr (ncols) REAL(KIND=r8), INTENT(in ) :: cc (ncols) REAL(KIND=r8), INTENT(in ) :: cg (ncols) REAL(KIND=r8), INTENT(in ) :: satcap(ncols,icg) REAL(KIND=r8), INTENT(inout ) :: dtc (ncols) REAL(KIND=r8), INTENT(inout ) :: dtg (ncols) REAL(KIND=r8), INTENT(inout ) :: dtm (ncols) REAL(KIND=r8), INTENT(inout ) :: dqm (ncols) REAL(KIND=r8), INTENT(in ) :: thermk(ncols) ! ! heat fluxes : c-canopy, g-ground, t-trans, e-evap in j m-2 ! REAL(KIND=r8), INTENT(inout ) :: ect (ncols) REAL(KIND=r8), INTENT(inout ) :: eci (ncols) REAL(KIND=r8), INTENT(inout ) :: egt (ncols) REAL(KIND=r8), INTENT(inout ) :: egi (ncols) REAL(KIND=r8), INTENT(inout ) :: egs (ncols) REAL(KIND=r8), INTENT(inout ) :: ec (ncols) REAL(KIND=r8), INTENT(inout ) :: eg (ncols) REAL(KIND=r8), INTENT(inout ) :: hc (ncols) REAL(KIND=r8), INTENT(inout ) :: hg (ncols) REAL(KIND=r8), INTENT(inout ) :: ecidif(ncols) REAL(KIND=r8), INTENT(inout ) :: egidif(ncols) ! ! derivatives ! REAL(KIND=r8), INTENT(inout ) :: hgdtg (ncols) REAL(KIND=r8), INTENT(inout ) :: hgdtc (ncols) REAL(KIND=r8), INTENT(inout ) :: hgdtm (ncols) REAL(KIND=r8), INTENT(inout ) :: hcdtg (ncols) REAL(KIND=r8), INTENT(inout ) :: hcdtc (ncols) REAL(KIND=r8), INTENT(inout ) :: hcdtm (ncols) REAL(KIND=r8), INTENT(inout ) :: egdtg (ncols) REAL(KIND=r8), INTENT(inout ) :: egdtc (ncols) REAL(KIND=r8), INTENT(inout ) :: egdqm (ncols) REAL(KIND=r8), INTENT(inout ) :: ecdtg (ncols) REAL(KIND=r8), INTENT(inout ) :: ecdtc (ncols) REAL(KIND=r8), INTENT(inout ) :: ecdqm (ncols) REAL(KIND=r8), INTENT(inout ) :: deadtg(ncols) REAL(KIND=r8), INTENT(inout ) :: deadtc(ncols) REAL(KIND=r8), INTENT(inout ) :: deadqm(ncols) ! ! this is for coupling with closure turbulence model ! REAL(KIND=r8), INTENT(in ) :: bps (ncols) REAL(KIND=r8), INTENT(in ) :: psb (ncols) REAL(KIND=r8), INTENT(in ) :: em (ncols) REAL(KIND=r8), INTENT(in ) :: gmt (ncols,3) REAL(KIND=r8), INTENT(in ) :: gmq (ncols,3) REAL(KIND=r8), INTENT(in ) :: psy (ncols) REAL(KIND=r8), INTENT(in ) :: rcp (ncols) REAL(KIND=r8), INTENT(inout ) :: wc (ncols) REAL(KIND=r8), INTENT(inout ) :: wg (ncols) REAL(KIND=r8), INTENT(in ) :: fc (ncols) REAL(KIND=r8), INTENT(in ) :: fg (ncols) REAL(KIND=r8), INTENT(inout ) :: hr (ncols) REAL(KIND=r8) :: vcover2(ncols,icg) REAL(KIND=r8) :: pblsib(ncols,4,5) REAL(KIND=r8) :: coc REAL(KIND=r8) :: rsurf REAL(KIND=r8) :: cog1 REAL(KIND=r8) :: cog2 REAL(KIND=r8) :: d1 REAL(KIND=r8) :: d2 REAL(KIND=r8) :: d1i REAL(KIND=r8) :: top REAL(KIND=r8) :: ak (ncols) REAL(KIND=r8) :: ah (ncols) REAL(KIND=r8) :: cci (ncols) REAL(KIND=r8) :: cgi (ncols) REAL(KIND=r8) :: ecpot (ncols) REAL(KIND=r8) :: egpot (ncols) REAL(KIND=r8) :: ecf REAL(KIND=r8) :: egf REAL(KIND=r8) :: coct REAL(KIND=r8) :: cogt REAL(KIND=r8) :: cogs1 REAL(KIND=r8) :: cogs2 REAL(KIND=r8) :: psyi (ncols) REAL(KIND=r8) :: fac1 REAL(KIND=r8) :: rcdtc (ncols) REAL(KIND=r8) :: rcdtg (ncols) REAL(KIND=r8) :: rgdtc (ncols) REAL(KIND=r8) :: rgdtg (ncols) REAL(KIND=r8), PARAMETER :: capi =1.0_r8/4.0e-3_r8 REAL(KIND=r8) :: timcon REAL(KIND=r8) :: timcn2 REAL(KIND=r8) :: tim REAL(KIND=r8) :: dtc3xi REAL(KIND=r8) :: fak REAL(KIND=r8) :: fah INTEGER :: i REAL(KIND=r8) :: stb4 REAL(KIND=r8) :: stb8 REAL(KIND=r8) :: hlat3 timcon = pie/86400.0_r8 timcn2 = 2.0_r8 * timcon tim = 1.0_r8 + timcn2*dtc3x dtc3xi = 1.0_r8 / dtc3x fak = 0.01_r8 * grav/cp fah = 0.01_r8 * grav/hl vcover2=vcover DO i = 1, nmax ! ! -- -- ! | razao entre a agua interceptada no topo da copa | ! wc = Minimo*| 1 , --------------------------------------------------| ! | indice de area foliar no topo da copa | ! -- -- ! wc (i)=MIN( 1.0_r8 , capac(i,1)/satcap(i,1)) ! -- -- ! | razao entre a agua interceptada na base da copa | ! wg = Minimo*| 1 ,---------------------------------------------------| ! | indice de area foliar na base da copa | ! -- -- ! wg (i)=MIN( 1.0_r8 , capac(i,2)/satcap(i,2)) ! ! Temperatura de congelamento (K) ! IF (tg(i) <= tf) THEN vcover2(i,2)=1.0_r8 wg (i) =MIN(1.0_r8 ,capac(i,2)*capi) ! ! rsoil ......Resistencia do solo (s/m) ! rst (i,2)=rsoil(i) END IF ! ! ! DT d d[w'T'] ! ---- = -- ---------- ! Dt dt dz ! !H =rho*cp*w'T' ! ! H !w'T' = ------- ! rho*cp ! ! DT d 1 dH ! ---- = ---- --------- * ----- ! Dt dt rho*cp dz ! ! P =rho*R*T and P = rho*g*Z ! ! P ! DP = rho*g*DZ and rho = ---- ! R*T ! ! 1 1 !----= rho*g* ----- ! DZ DP ! ! 1 1 1 !--- * ---- = g* ----- !rho DZ DP ! ! ! DT d g dH ! ---- = ---- *----- * ----- ! Dt dt cp dP ! ! g d ! ak(i) = ----- * ----- ! cp dP ! grav 1 !ak(i) = 0.01 * ------ * ------------------ ! cp (psb(i)*bps(i)) ! ! -(R/Cp) ! g sl(k) ! ak(i) = 0.01 * ------- * ------------------------------- ! cp (P * (si(k) - si(k+1))) ! ak (i) =fak/(psb(i)*bps(i)) ! !L =rho*hl*w'Q' ! ! ! g 1 !ah(i) = 0.01 * ------ * -------------------------- ! hl (P * (si(k) - si(k+1))) ! ah (i) =fah/ psb(i) ! ! cc..........heat capacity of the canopy ! cg..........heat capacity of the ground ! cgi (i) =1.0_r8 / cg(i) cci (i) =1.0_r8 / cc(i) ! ! rcp ---- densidade do ar vezes o calor especifico do ar ! !(cp/(hl*epsfac))*psur(i) ! psyi(i) =rcp(i)/psy(i) END DO ! ! partial derivative calculations for sensible heat ! DO i = 1, nmax ! ! 1 1 1 ! d1 =------- + -------- + -------- ! ra(i) rb(i) rd(i) ! ! rb(i)*rd(i) + ra(i)*rd(i) + ra(i)*rb(i) ! d1 = -------------------------------------------- ! ra(i)*rb(i)*rd(i) ! d1 =1.0_r8/ra(i) + 1.0_r8/rb(i) + 1.0_r8/rd(i) ! ! rcp(i) rcp(i) rcp(i) ! d1i = --------- + -------- + -------- ! ra(i) rb(i) rd(i) ! ! ! rb(i)*rd(i)*rcp(i) + ra(i)*rd(i)*rcp(i) + ra(i)*rb(i)*rcp(i) ! d1i = ---------------------------------------------------------------------- ! ra(i)*rb(i)*rd(i) ! d1i =rcp(i)/d1 ! ! -- -- ! | tg(i) tc(i) tm(i)*bps(i) | / !ta(i)=|------- + -------- + -------------- | /d1 ! | rd(i) rb(i) ra(i) |/ ! -- -- ! ta(i)=( tg(i)/rd(i) + tc(i)/rb(i) + tm(i)*bps(i)/ra(i) )/d1 ! !dtc3x = time increment dt !rcp----densidade do ar vezes o calor especifico do ar ! ! ! total sensible heat lost of top from the veggies. ! (tc(i)-ta(i)) !hc(i) = rcp(i) * ----------------*dt ! rb(i) ! hc(i)=rcp(i) * ( tc(i) - ta(i) ) / rb(i) * dtc3x ! ! total sensible heat lost of base from the veggies. ! ! (tg(i)-ta(i)) !hg(i) = rcp(i) * ---------------*dt ! rd(i) ! hg(i)=rcp(i) * ( tg(i) - ta(i) ) / rd(i) * dtc3x ! J ! n.b. fluxes expressed in joules m-2 = ------ ! m^2 ! rcp(i) rcp(i) rcp(i) ! d1i = --------- + -------- + -------- ! ra(i) rb(i) rd(i) ! ! rb(i)*rd(i)*rcp(i) + ra(i)*rd(i)*rcp(i) + ra(i)*rb(i)*rcp(i) ! d1i = ---------------------------------------------------------------------- ! ra(i)*rb(i)*rd(i) ! ! -- -- ! d1i | 1.0 1.0 | !hcdtc(i) = ------- * | ------ + -------- | ! rb(i) | ra(i) rd(i) | ! -- -- ! hcdtc(i)= d1i / rb(i)*( 1.0_r8/ra(i) + 1.0_r8/rd(i) ) ! ! -d1i !hcdtg(i) = --------------- ! rb(i) * rd(i) ! hcdtg(i)=-d1i / ( rb(i)*rd(i) ) ! ! ra(i)*rb(i)*rd(i)*rcp(i) ! d1i = -------------------------------------------- ! rb(i)*rd(i) + ra(i)*rd(i) + ra(i)*rb(i) ! ! -d1i ! hcdtm(i)= ----------------- * bps(i) ! ( rb(i)*ra(i) ) ! ! - rd(i)*rcp(i) ! hcdtm(i)= ---------------------------------------------- * bps(i) ! rb(i)*rd(i) + ra(i)*rd(i) + ra(i)*rb(i) ! hcdtm(i)=-d1i / ( rb(i)*ra(i) ) *bps(i) ! ! -- -- ! d1i | 1.0 1.0 | ! hgdtg(i) = ------- * | ------ + -------- | ! rd(i) | ra(i) rb(i) | ! -- -- ! hgdtg(i)= d1i / rd(i)*( 1.0_r8/ra(i) + 1.0_r8/rb(i)) ! ! -d1i !hgdtc(i) = ----------------- ! ( rd(i)*rb(i) ) ! ! hgdtc(i)=-d1i / ( rd(i)*rb(i) ) ! ! -d1i (R/Cp) ! hgdtm(i) = ----------------- * sl(k) ! ( rd(i)*ra(i) ) ! ! ! - rb(i)*rcp(i) (R/Cp) ! hgdtm(i)= ---------------------------------------------- * sl(k) ! rb(i)*rd(i) + ra(i)*rd(i) + ra(i)*rb(i) hgdtm(i)=-d1i / ( rd(i)*ra(i) ) *bps(i) ! END DO ! ! partial derivative calculations for longwave radiation flux ! stb4 = 4.0_r8 * stefan stb8 = 8.0_r8 * stefan ! DO i = 1, nmax fac1 = vcover2(i,1)*(1.0_r8 - thermk(i)) rcdtc(i) = fac1 * stb8 * tc(i)*tc(i)*tc(i) rcdtg(i) =-fac1 * stb4 * tg(i)*tg(i)*tg(i) rgdtc(i) =-fac1 * stb4 * tc(i)*tc(i)*tc(i) rgdtg(i) = stb4 * tg(i)*tg(i)*tg(i) END DO DO i = 1, nmax ! ! partial derivative calculation for latent heat ! modification for soil dryness : hr=rel. humidity in top layer ! hr (i) = hrr(i) * fg(i) + 1.0_r8 - fg(i) ! ! fc = Condicao de oravalho 0 ou 1 na topo da copa ! rc (i) = rst(i,1) * fc(i) + 2.0_r8 * rb(i) ! ! ( 1.0_r8 - wc(i) ) wc(i) ! coc = -------------------- + ------------------ ! rc(i) (2.0_r8 * rb(i)) ! coc = ( 1.0_r8 - wc(i) ) / rc(i) + wc(i)/(2.0_r8 * rb(i)) ! ! fg = Condicao de oravalho 0 ou 1 na base da copa ! rg (i) = rst(i,2)*fg(i) ! rsurf = rsoil(i)*fg(i) ! ! hr..........rel. humidity in top layer ! vcover......Fracao de cobertura vegetal icg=1 topo ! vcover......Fracao de cobertura vegetal icg=2 topo ! ! (1 - wg(i)) (1 - vcover(i,2)) vcover(i,2) ! cog1 = vcover(i,2)*--------------- + hr(i)*------------------- + hr(i)*---------------------- ! (rg(i)+rd(i)) (rsurf + rd(i)) (rsurf + rd(i) + 44) ! cog1 = vcover2(i,2)*(1.0_r8 - wg(i))/(rg(i)+rd(i)) & + (1.0_r8 - vcover2(i,2))/(rsurf + rd(i)) * hr(i) & + vcover2(i,2) / (rsurf + rd(i) + 44.0_r8) * hr(i) ! ! (1 - wg(i)) (1 - vcover(i,2)) vcover(i,2) ! cog2 = vcover(i,2)*--------------- + ------------------- + ---------------------- ! (rg(i)+rd(i)) (rsurf + rd(i)) (rsurf + rd(i) + 44) ! cog2 = vcover2(i,2)*(1.0_r8 - wg(i))/(rg(i)+rd(i)) & + (1.0_r8 - vcover2(i,2))/(rsurf + rd(i)) & + vcover2(i,2)/(rsurf +rd(i)+44.0_r8) ! (1 - wg(i)) hr(i)*(1 - vcover(i,2)) hr(i)*vcover(i,2) wg(i)* vcover(i,2) ! cog1 = vcover(i,2) * -------------- + ------------------------- + --------------------- + -------------------- ! (rg(i)+rd(i)) (rsurf + rd(i)) (rsurf + rd(i) + 44) rd(i) ! ! cog1 = cog1 + wg(i) / rd(i)*vcover2(i,2) ! ! wg(i) ! cog2 = cog2 + -------- * vcover(i,2) ! rd(i) ! cog2 = cog2 + wg(i)/rd(i)*vcover2(i,2) ! ! 1.0 ( 1.0_r8 - wc(i) ) wc(i) !d2 = --------- + -------------------- + ------------------ + cog2 ! ra(i) rc(i) (2.0_r8 * rb(i)) ! d2 = 1.0_r8/ra(i) + coc + cog2 ! ! em(i) !top = coc * etc(i) + cog1 * etg(i) + ------- ! ra(i) ! top = coc * etc(i) + cog1 * etg(i) + em(i)/ra(i) ! ea (i) = top/d2 ! ! psyi(i) =rcp(i)/psy(i) ! ! The rate of evaporation from the wetted portions of the vegetation ! ! ( 1 - wc(i) ) wc(i) ! coc = ---------------- + -------------- ! rc(i) ( 2 * rb(i) ) ! !The latent heat fluxes from the canopy is defined by: ! ! ! -- -- -- -- ! | | rho(i) * cp | wc 1 - wc | !ec = LEc = | e[Tc] - ea | * -------------- * | ---- + ---------| ! | | psy(i) | rb rb + rc | ! -- -- -- -- ! ec (i) = ( etc(i)-ea(i) ) * coc * psyi(i) * dtc3x ! !The latent heat fluxes from the ground is defined by: ! ! -- -- -- -- ! | | rho(i) * cp | 1 | ! eg = LEgs =|fh*e[Tgs] - ea | * -------------- * |------------| ! | | psy(i) | rsurf + rd | ! -- -- -- -- ! eg (i) = (etg(i)*cog1 - ea(i)*cog2 )*psyi(i)*dtc3x ! deadtc(i) = btc(i) * coc / d2 ! deadtg(i) = btg(i) * cog1 / d2 ! ! psur(i) ! deadqm(i) = epsfac * ------------------------------------------ ! ( ( epsfac + qm(i) )**2 * ra(i)*d2 ) ! deadqm(i) = epsfac * psur(i)/( (epsfac+qm(i))**2 * ra(i)*d2 ) ! ecdtc(i) = (btc(i) - deadtc(i) ) * coc * psyi(i) ! ecdtg(i) = -deadtg(i) * coc * psyi(i) ! ecdqm(i) = -deadqm(i) * coc * psyi(i) ! egdtg(i) = ( btg(i) * cog1 - deadtg(i) * cog2 )*psyi(i) ! egdtc(i) = -deadtc(i) * cog2 * psyi(i) ! egdqm(i) = -deadqm(i) * cog2 * psyi(i) ! END DO ! ! solve for time changes of pbl and sib variables, ! using a semi-implicit scheme. ! DO i = 1, nmax ! ! tg equation ! ! cc..........heat capacity of the canopy ! cg..........heat capacity of the ground ! ! 1.0 1.0 ! cgi (i) = ----- = --------------------------------- ! cg(i) heat capacity of the ground ! ! 1.0 1.0 ! cci (i) =------ = -------------------------------------- ! cc(i) heat capacity of the canopy ! ! 2 * pi * dt s !tim = 1.0 + ------------- = --- ! 86400.0 s ! pblsib(i,1,1) = tim + dtc3x * cgi(i) * (hgdtg(i) + egdtg(i) + rgdtg(i)) pblsib(i,1,2) = dtc3x * cgi(i) * (hgdtc(i) + egdtc(i) + rgdtc(i)) pblsib(i,1,3) = dtc3x * cgi(i) * hgdtm(i) pblsib(i,1,4) = dtc3x * cgi(i) * egdqm(i) ! ! tc equation ! pblsib(i,2,1) = dtc3x * cci(i) * ( hcdtg(i) + ecdtg(i) + rcdtg(i) ) ! pblsib(i,2,2) = 1.0_r8 + dtc3x * cci(i) * ( hcdtc(i) + ecdtc(i) + rcdtc(i) ) ! ! ! -d1i (R/Cp) ! hcdtm(i)= ----------------- * sl(k) ! Cc(i)*( rb(i)*ra(i) ) ! pblsib(i,2,3) = dtc3x * cci(i) * hcdtm(i) ! pblsib(i,2,4) = dtc3x * cci(i) * ecdqm(i) ! ! tm equation ! ! -(R/Cp) ! g sl(k) ! ak(i) = 0.01 * ------- * ------------------------------- ! cp (P * (si(k) - si(k+1))) ! ! pblsib(i,3,1) = -dtc3x * ak(i) * ( hgdtg(i) + hcdtg(i) ) ! pblsib(i,3,2) = -dtc3x * ak(i) * ( hgdtc(i) + hcdtc(i) ) ! ! ! -- -- -(R/Cp) -- -- -(R/Cp) ! | P | | | !bps |-------| == |sl(k) | ! | P0 | | | ! -- -- -- -- ! ! -- -- -(R/Cp) ! | P | !Tpot = T * |-------| ! | P0 | ! -- -- ! ! ! P =rho*R*T and P = rho*g*Z ! ! P ! DP = rho*g*DZ and rho = ---- ! R*T ! ! P ! DP = ----*g*DZ ! R*T ! ! R*T ! DZ = ------*DP ! g*P ! ! 1 g*P 1 ! ------ = ------ * ------ ! DZ R*T DP ! ! T g P ! ------ = ------ * ------ ! DZ R DP ! ! -(R/Cp) ! g sl(k) ! ak(i) = 0.01 * ------- * ------------------------------- ! cp (P * (si(k) - si(k+1))) ! ! ! pblsib(i,3,3) = gmt(i,2) - 2*dt*ak(i)*(hgdtm(i) + hcdtm(i)) ! ! T 1 !Pbl_KMbyDZ_1 = 2*Dt * Km*---- * ---- ! dZ dZ ! ! T 1 !Pbl_KMbyDZ_1 = 2*Dt * Km*---- * ---- ! dZ dZ ! ! -- -- -- -- ! | | | Pbl_KMbyDZ_1(i,k)*Pbl_KMbyDZ_2(i,k+1) | !gmt(i,2) =|1.0 + Pbl_KMbyDZ_1(i,k) + Pbl_KMbyDZ_2(i,k)| - |-----------------------------------------------| ! | | |1.0 + Pbl_KMbyDZ_1(i,k+1) + Pbl_KMbyDZ_2(i,k+1)| ! -- -- -- -- pblsib(i,3,3) = gmt(i,2) - dtc3x * ak(i) * ( hgdtm(i) + hcdtm(i) ) pblsib(i,3,4) = 0.0_r8 ! ! qm equation ! ! ! g 1 !ah(i) = 0.01 * ------ * -------------------------- ! hl (P * (si(k) - si(k+1))) ! pblsib(i,4,1) = - dtc3x * ah(i) * ( egdtg(i) + ecdtg(i) ) pblsib(i,4,2) = - dtc3x * ah(i) * ( egdtc(i) + ecdtc(i) ) pblsib(i,4,3) = 0.0_r8 ! pblsib(i,4,4) = gmq(i,2) - dtc3x * ah(i) * ( egdqm(i) + ecdqm(i) ) ! ! Rngs ! radt = net heat received by canopy/ground vegetation = -------- ! dt ! ! dTgs 2*PI*Cgs ! Cgs*------ = Rngs - Hgs - LHgs - ------------ * (Tgs - Td) ! dt dayleg ! ! dTgs Rngs Hgs LHgs 2*PI ! ------ = ------ - ------ - ------- - -------------- * (Tgs - Td) ! dt Cgs Cgs Cgs dayleg ! ! -- -- ! dTgs | Rngs Hgs LHgs | 2*PI ! ------ = | ------ - ------ - ------| - -------------- * (Tgs - Td) ! dt | Cgs Cgs Cgs | dayleg ! -- -- ! ! -- -- ! dTgs | | 1 2*PI ! ------ = | Rngs - ( Hgs + LHgs )| *------ - -------------- * (Tgs - Td) ! dt | | Cgs dayleg ! -- -- ! ! cgi(i) 2*pi !pblsib(i,1,5) = (radt(i,2)* cgi(i) - ( hg(i) + eg(i) ) * -------- ) - --------- * ( tg(i) - td(i) ) ! dt 86400.0 ! 2*pi ! timcn2 = --------- ! 86400.0 pblsib(i,1,5) = (radt(i,2) - ( hg(i) + eg(i) ) * dtc3xi ) * cgi(i) - timcn2 * ( tg(i) - td(i) ) ! ! dTc ! Cc*------ = Rnc - Hc - LHc ! dt ! ! -- -- ! dTc | | 1 ! ------ =|Rnc - Hc - LHc | * ----- ! dt | | Cc ! -- -- ! -- -- ! | 1 | 1 !pblsib(i,2,5) = |radt(i,1) - ( hc(i) + ec(i) ) * -------- | * ------- ! | dt | cc(i) ! -- -- ! -- -- ! | 1 | !pblsib(i,2,5) = |radt(i,1) - ( hc(i) + ec(i) ) * -------- | * cci(i) ! | dt | ! -- -- pblsib(i,2,5) = (radt(i,1) - ( hc(i) + ec(i) ) * dtc3xi ) * cci(i) ! ! -(R/Cp) -- -- ! dTm g sl(k) | hg(i) + hc(i) | ! ------ = 0.01 * ------- * ------------------------------- *| --------------| ! dt cp (P * (si(k) - si(k+1))) | dt | ! -- -- ! -- -- ! dTm m*kg*K 1 | J | ! ------ = 0.01 * ----------- * ------------------------------- *| ------ | ! dt s^2*J Pa | m^2*s | ! -- -- ! dTm m*kg*K m^2 | N*m | ! ------ = 0.01 * ----------- * ------------------------------- *| --------| ! dt s^2*N*m N | m^2*s | ! dTm m*Kg*K*s^2 m^3 ! ------ = 0.01 * ------------- * --------------- ! dt s^2*kg*m*m m^2*s ! dTm K m ! ------ = 0.01 * ------------- *------- ! dt m s ! ! dTm K ! ------ = 0.01 * ---- ! dt s ! ! -(R/Cp) -- -- ! g sl(k) | hg(i) + hc(i) | ! pblsib(i,3,5) = 0.01 * ------- * ------------------------------- *| --------------| ! cp (P * (si(k) - si(k+1))) | dt | ! -- -- ! pblsib(i,3,5) = gmt(i,3) + ak(i) * ( hg(i) + hc(i) ) * dtc3xi ! ! -- -- ! g 1 | eg(i) + ec(i) | !pblsib(i,4,5) = 0.01 * ------ * ------------------------- * | --------------| ! hl (P * (si(k) - si(k+1))) | dt | ! -- -- ! pblsib(i,4,5) = gmq(i,3) + ah(i) * ( eg(i) + ec(i) ) * dtc3xi END DO ! ! solve 4 x 5 matrix equation ! DO i = 1, nmax pblsib(i,2,2) = pblsib(i,2,2) - pblsib(i,2,1) * ( pblsib(i,1,2) / pblsib(i,1,1) ) pblsib(i,2,3) = pblsib(i,2,3) - pblsib(i,2,1) * ( pblsib(i,1,3) / pblsib(i,1,1) ) pblsib(i,2,4) = pblsib(i,2,4) - pblsib(i,2,1) * ( pblsib(i,1,4) / pblsib(i,1,1) ) pblsib(i,2,5) = pblsib(i,2,5) - pblsib(i,2,1) * ( pblsib(i,1,5) / pblsib(i,1,1) ) pblsib(i,3,2) = pblsib(i,3,2) - pblsib(i,3,1) * ( pblsib(i,1,2) / pblsib(i,1,1) ) pblsib(i,3,3) = pblsib(i,3,3) - pblsib(i,3,1) * ( pblsib(i,1,3) / pblsib(i,1,1) ) pblsib(i,3,4) = pblsib(i,3,4) - pblsib(i,3,1) * ( pblsib(i,1,4) / pblsib(i,1,1) ) pblsib(i,3,5) = pblsib(i,3,5) - pblsib(i,3,1) * ( pblsib(i,1,5) / pblsib(i,1,1) ) pblsib(i,4,2) = pblsib(i,4,2) - pblsib(i,4,1) * ( pblsib(i,1,2) / pblsib(i,1,1) ) pblsib(i,4,3) = pblsib(i,4,3) - pblsib(i,4,1) * ( pblsib(i,1,3) / pblsib(i,1,1) ) pblsib(i,4,4) = pblsib(i,4,4) - pblsib(i,4,1) * ( pblsib(i,1,4) / pblsib(i,1,1) ) pblsib(i,4,5) = pblsib(i,4,5) - pblsib(i,4,1) * ( pblsib(i,1,5) / pblsib(i,1,1) ) pblsib(i,3,3) = pblsib(i,3,3) - pblsib(i,3,2) * ( pblsib(i,2,3) / pblsib(i,2,2) ) pblsib(i,3,4) = pblsib(i,3,4) - pblsib(i,3,2) * ( pblsib(i,2,4) / pblsib(i,2,2) ) pblsib(i,3,5) = pblsib(i,3,5) - pblsib(i,3,2) * ( pblsib(i,2,5) / pblsib(i,2,2) ) pblsib(i,4,3) = pblsib(i,4,3) - pblsib(i,4,2) * ( pblsib(i,2,3) / pblsib(i,2,2) ) pblsib(i,4,4) = pblsib(i,4,4) - pblsib(i,4,2) * ( pblsib(i,2,4) / pblsib(i,2,2) ) pblsib(i,4,5) = pblsib(i,4,5) - pblsib(i,4,2) * ( pblsib(i,2,5) / pblsib(i,2,2) ) pblsib(i,4,4) = pblsib(i,4,4) - pblsib(i,4,3) * ( pblsib(i,3,4) / pblsib(i,3,3) ) pblsib(i,4,5) = pblsib(i,4,5) - pblsib(i,4,3) * ( pblsib(i,3,5) / pblsib(i,3,3) ) pblsib(i,4,5) = pblsib(i,4,5) / pblsib(i,4,4) pblsib(i,3,5) = ( pblsib(i,3,5) / pblsib(i,3,3) ) & - ( pblsib(i,3,4) / pblsib(i,3,3) ) * pblsib(i,4,5) pblsib(i,2,5) = ( pblsib(i,2,5) / pblsib(i,2,2) ) & - ( pblsib(i,2,4) / pblsib(i,2,2) ) * pblsib(i,4,5) & - ( pblsib(i,2,3) / pblsib(i,2,2) ) * pblsib(i,3,5) pblsib(i,1,5) = ( pblsib(i,1,5) / pblsib(i,1,1) ) & - ( pblsib(i,1,4) / pblsib(i,1,1) ) * pblsib(i,4,5) & - ( pblsib(i,1,3) / pblsib(i,1,1) ) * pblsib(i,3,5) & - ( pblsib(i,1,2) / pblsib(i,1,1) ) * pblsib(i,2,5) END DO DO i = 1, nmax dtg(i) = pblsib(i,1,5) * dtc3x dtc(i) = pblsib(i,2,5) * dtc3x dtm(i) = pblsib(i,3,5) * dtc3x dqm(i) = pblsib(i,4,5) * dtc3x hc (i) = hc(i) + dtc3x * ( hcdtc(i) * dtc(i) + hcdtg(i) * dtg(i) + hcdtm(i) * dtm(i) ) hg (i) = hg(i) + dtc3x * ( hgdtc(i) * dtc(i) + hgdtg(i) * dtg(i) + hgdtm(i) * dtm(i) ) ! ! check if interception loss term has exceeded canopy storage ! ecpot(i)=( etc(i) - ea(i) ) + ( btc(i) - deadtc(i) ) * dtc(i) & -deadtg(i) * dtg(i) - deadqm(i) * dqm(i) egpot(i)=( etg(i) - ea(i) ) + ( btg(i) - deadtg(i) ) * dtg(i) & -deadtc(i) * dtc(i) - deadqm(i) * dqm(i) END DO !---------------------------------------------------------------------- ! EVAPORATION LOSSES ARE EXPRESSED IN J M-2 : WHEN DIVIDED BY ! ( hl*1000.) LOSS IS IN M M-2 (hl(J/kg))(1 J/kg ==> 1000J/m-3) ! MASS TERMS ARE IN KG M-2 DT-1 !---------------------------------------------------------------------- hlat3=1.0e+03_r8*hl DO i = 1, nmax eci (i) = ecpot(i) * wc(i) * psyi(i) / ( 2.0_r8 * rb(i) ) * dtc3x ecidif(i) = MAX( 0.0_r8 , eci(i) - capac(i,1) * hlat3 ) hc (i) = hc(i) + ecidif(i) eci (i) = MIN( eci(i) , capac(i,1) * hlat3 ) egi (i) = egpot(i) * vcover2(i,2) * wg(i) * psyi(i) / rd(i)*dtc3x egidif(i) = MAX( 0.0_r8 , egi(i) - capac(i,2) * hlat3 ) hg (i) = hg(i) + egidif(i) egi (i) = MIN( egi(i) , capac(i,2) * hlat3 ) ! ! evaporation is given in j m-2, calculated from gradients ! rsurf = rsoil(i) * fg(i) coct = ( 1.0_r8 - wc(i) )/rc(i) cogt = vcover2(i,2) * ( 1.0_r8 - wg(i) ) / ( rg(i) + rd(i) ) cogs1 = ( 1.0_r8 - vcover2(i,2) ) * hr(i)/( rd(i) + rsurf ) & + vcover2(i,2) / ( rd(i) + rsurf + 44.0_r8 ) * hr(i) cogs2 = cogs1/hr(i) ect (i) = ecpot(i)*coct*psyi(i)*dtc3x ec (i) = eci(i)+ect(i) egt (i) = egpot(i)*cogt*psyi(i)*dtc3x egs (i) = (etg(i)+btg(i)*dtg(i))*cogs1 & -(ea(i)+deadtg(i)*dtg(i)+deadtc(i)*dtc(i)+deadqm(i)*dqm(i) & ) *cogs2 egs (i) = egs(i)*psyi(i)*dtc3x eg (i) = egt(i)+egs(i)+egi(i) !vcover2(i,2)=xcover(itype(i),mon(i),2) END DO ! ! test of dew condition. recalculation ensues if necessary. ! DO i = 1, nmax radt(i,1) = radt(i,1) - rcdtc(i) * dtc(i) - rcdtg(i) * dtg(i) radt(i,2) = radt(i,2) - rgdtc(i) * dtc(i) - rgdtg(i) * dtg(i) ecf = SIGN(1.0_r8 ,ecpot(i)) * ( fc(i) * 2.0_r8 - 1.0_r8 ) egf = SIGN(1.0_r8 ,egpot(i)) * ( fg(i) * 2.0_r8 - 1.0_r8 ) IF ( ecf <= 0.0_r8 ) THEN hc (i) = hc(i) + eci(i) + ect(i) eci(i) = 0.0_r8 ect(i) = 0.0_r8 ec (i) = 0.0_r8 END IF IF (egf <= 0.0_r8) THEN hg (i) = hg(i)+egi(i)+egt(i)+egs(i) egi(i) = 0.0_r8 egt(i) = 0.0_r8 egs(i) = 0.0_r8 eg (i) = 0.0_r8 END IF END DO END SUBROUTINE temres ! cut :performs vapor pressure calculation at level "a". SUBROUTINE cut( & icheck,em ,rhoair,rcp ,wc ,wg ,fc ,fg ,hr , & ra ,rb ,rd ,rc ,rg ,ea ,etc ,etg ,rst , & rsoil ,vcover,nmax ,ncols ) ! !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! input parameters ! fc fg hr wc wg rhoair cp ! rst ra rb rg rd rsurf vcover ! etc etg em !----------------------------------------------------------------------- ! output parameters ! ea !----------------------------------------------------------------------- ! ncols......Numero de ponto por faixa de latitude ! icg........Parametros da vegetacao (icg=1 topo e icg=2 base) ! cp.........specific heat of air (j/kg/k) ! nmax....... ! vcover(iv).Fracao de cobertura da vegetacao iv=1 topo () ! vcover(iv).Fracao de cobertura da vegetacao iv=2 bottom () ! ra.........Resistencia Aerodinamica (s/m) ! rb.........bulk boundary layer resistance (s/m) ! rd.........aerodynamic resistance between ground ! and canopy air space (s/m) ! rc.........Resistencia do topo da copa ! rg.........Resistencia da base da copa ! ea.........Pressao de vapor ! etc........Pressao de vapor no topo da copa ! etg........Pressao de vapor no base da copa ! rst........Resistencia stomatal (s/m) ! rsoil......Resistencia do solo (s/m) ! em.........Pressao de vapor da agua ! rhoair.....Desnsidade do ar ! rcp........densidade do ar vezes o calor especifico do ar ! wc.........Minimo entre 1 e a razao entre a agua interceptada pelo ! indice de area foliar no topo da copa ! wg.........Minimo entre 1 e a razao entre a agua interceptada pelo ! indice de area foliar na parte inferior da copa ! fc.........Condicao de oravalho 0 ou 1 no topo da copa ! fg.........Condicao de oravalho 0 ou 1 na base da copa ! hr.........Rel. humidity in top layer ! icheck !----------------------------------------------------------------------- INTEGER, INTENT(in ) :: ncols INTEGER, INTENT(in ) :: nmax REAL(KIND=r8), INTENT(in ) :: vcover(ncols,icg) ! ! variables calculated from above and ambient conditions ! REAL(KIND=r8), INTENT(in ) :: ra (ncols) REAL(KIND=r8), INTENT(in ) :: rb (ncols) REAL(KIND=r8), INTENT(in ) :: rd (ncols) REAL(KIND=r8), INTENT(inout ) :: rc (ncols) REAL(KIND=r8), INTENT(inout ) :: rg (ncols) REAL(KIND=r8), INTENT(inout ) :: ea (ncols) REAL(KIND=r8), INTENT(in ) :: etc (ncols) REAL(KIND=r8), INTENT(in ) :: etg (ncols) REAL(KIND=r8), INTENT(in ) :: rst (ncols,icg) REAL(KIND=r8), INTENT(in ) :: rsoil (ncols) ! ! this is for coupling with closure turbulence model ! REAL(KIND=r8), INTENT(in ) :: em (ncols) REAL(KIND=r8), INTENT(in ) :: rhoair(ncols) REAL(KIND=r8), INTENT(inout ) :: rcp (ncols) REAL(KIND=r8), INTENT(in ) :: wc (ncols) REAL(KIND=r8), INTENT(in ) :: wg (ncols) REAL(KIND=r8), INTENT(in ) :: fc (ncols) REAL(KIND=r8), INTENT(in ) :: fg (ncols) REAL(KIND=r8), INTENT(in ) :: hr (ncols) INTEGER, INTENT(in ) :: icheck(ncols) REAL(KIND=r8) :: coc REAL(KIND=r8) :: rsurf REAL(KIND=r8) :: cog1 REAL(KIND=r8) :: cog2 REAL(KIND=r8) :: d2 REAL(KIND=r8) :: top REAL(KIND=r8) :: xnum REAL(KIND=r8) :: tem INTEGER :: i DO i = 1, nmax IF (icheck(i) == 1) THEN rcp (i) = rhoair(i)*cp rc (i) = rst(i,1)*fc(i)+rb(i)+rb(i)*fc(i) coc = (1.0_r8 -wc(i))/rc(i)+wc(i)/(2.0_r8 *rb(i)) rg (i) = rst(i,2)*fg(i) rsurf = rsoil(i)*fg(i) tem = vcover(i,2)*(1.0_r8-wg(i))/(rg(i)+rd(i)) cog2 = tem & + (1.0_r8 -vcover(i,2))/(rsurf +rd(i)) & + vcover(i,2)/(rsurf +rd(i)+44.0_r8) cog1 = (cog2 -tem )*hr(i)+tem xnum = wg(i)/rd(i)*vcover(i,2) cog1 = cog1 +xnum cog2 = cog2 +xnum d2 = 1.0_r8 /ra(i)+coc+cog2 top = coc*etc(i)+em(i)/ra(i)+cog1 *etg(i) ! ! vapor pressure at level "a" ! ea (i) = top /d2 END IF END DO END SUBROUTINE cut ! rbrd :calculates bulk boundary layer resistance and aerodynamic ! resistence betweenground and canopi air space4 as functions ! of wind speed at top of canopy and temperatures. SUBROUTINE rbrd(rb ,rd ,tcta ,tgta ,u2 ,tg ,rdc ,rbc ,itype , & z2 ,mon ,nmax ,ncols , zlt2) ! ! ! rb and rd as functions of u2 and temperatures. simplified( xue et ! al. 1991) ! !----------------------------------------------------------------------- ! input parameters !----------------------------------------------------------------------- ! tcta..........diferenca entre tc-ta (k) ! tgta..........diferenca entre tg-ta (k) ! tg............ground temperature (k) ! u2............wind speed at top of canopy (m/s) ! z2............height of canopy top (m) ! zlt(cg).......canopy/ground cover leaf and stem area density ! (m**2/m**3) ! rbc...........constant related to bulk boundary layer ! resistance ! rdc...........constant related to aerodynamic resistance ! between ground and canopy air space !----------------------------------------------------------------------- ! output parameters !----------------------------------------------------------------------- ! rb............bulk boundary layer resistance (s/m) ! rd............aerodynamic resistance between ground (s/m) ! and canopy air space !----------------------------------------------------------------------- ! ncols.........Numero de ponto por faixa de latitude ! ityp..........numero das classes de solo 13 ! imon...........Numero maximo de meses no ano (12) ! icg...........Parametros da vegetacao (icg=1 topo e icg=2 base) ! mon...........Numero do mes do ano (1-12) ! nmax ......... ! itype.........Classe de textura do solo !======================================================================= INTEGER, INTENT(in ) :: ncols INTEGER, INTENT(in ) :: mon (ncols) INTEGER, INTENT(in ) :: nmax ! ! vegetation and soil parameters ! REAL(KIND=r8), INTENT(in ) :: z2 (ityp,imon) INTEGER, INTENT(in ) :: itype (ncols) REAL(KIND=r8), INTENT(in ) :: rdc (ncols) REAL(KIND=r8), INTENT(in ) :: rbc (ncols) ! ! prognostic variables ! REAL(KIND=r8), INTENT(in ) :: tg (ncols) ! ! variables calculated from above and ambient conditions ! REAL(KIND=r8), INTENT(inout ) :: rb (ncols) REAL(KIND=r8), INTENT(inout ) :: rd (ncols) REAL(KIND=r8), INTENT(in ) :: tcta (ncols) REAL(KIND=r8), INTENT(in ) :: tgta (ncols) REAL(KIND=r8), INTENT(in ) :: u2 (ncols) REAL(KIND=r8), INTENT(in ) :: zlt2(ncols,icg) REAL(KIND=r8) :: temdif(ncols) REAL(KIND=r8) :: fih (ncols) REAL(KIND=r8), PARAMETER :: factg=88.29_r8 INTEGER :: i INTEGER :: ntyp DO i = 1, nmax ntyp=itype(i) IF (tcta(i) > 0.0_r8 ) THEN temdif(i)=tcta(i)+0.1_r8 ELSE temdif(i)= 0.1_r8 END IF rb (i)=1.0_r8 /(SQRT(u2(i))/rbc(i)+zlt2(i,1)*0.004_r8 ) IF (tgta(i) > 0) THEN temdif(i)=tgta(i)+0.1_r8 ELSE temdif(i)= 0.1_r8 END IF fih(i)=sqrt & (1.0_r8 +factg*temdif(i)*z2(ntyp,mon(i))/(tg(i)*u2(i)*u2(i))) rd(i) =rdc(i)/(u2(i)*fih(i)) END DO END SUBROUTINE rbrd ! vntlax :performs ventilation mass flux, based on deardorff, mwr, 1972?. SUBROUTINE vntlax(ustarn, & icheck,bps ,dzm ,cu ,ct,cuni ,ctni ,ustar ,ra ,ta , & u2 ,tm ,um ,vm ,d ,z0 ,itype ,z2 , & mon ,nmax ,jstneu,ncols ) ! ! !----------------------------------------------------------------------- ! input parameters !----------------------------------------------------------------------- ! ! ea..........Pressao de vapor ! ta..........Temperatura no nivel de fonte de calor do dossel (K) ! um..........Razao entre zonal pseudo-wind (fourier) e seno da ! colatitude ! vm..........Razao entre meridional pseudo-wind (fourier) e seno da ! colatitude ! qm..........specific humidity of reference (fourier) ! tm..........Temperature of reference (fourier) ! dzm .......Altura media de referencia para o vento para o calculo ! da estabilidade do escoamento ! grav........gravity constant (m/s**2) ! cpair.......specific heat of air (j/kg/k) ! gasr........gas constant of dry air (j/kg/k) ! bps ........ ! z2..........height of canopy top ! d...........displacement height (m) ! epsfac......parametro para o gas 0.622 ! ! ! !----------------------------------------------------------------------- ! output parameters !----------------------------------------------------------------------- ! ! ustar.........surface friction velocity (m/s) ! ra............Resistencia Aerodinamica (s/m) ! u2............wind speed at top of canopy (m/s) ! ventmf........ventilation mass flux !----------------------------------------------------------------------- !======================================================================= ! ncols........Numero de ponto por faixa de latitude ! ityp.........Numero do tipo de solo ! imon.........Numero maximo de meses no ano (12) ! jstneu.......The first call to vntlat just gets the neutral values ! of ustar and ventmf para jstneu=.TRUE.. ! mon..........Numero do mes do ano (1-12) ! nmax......... ! itype........Classe de textura do solo ! z0...........roughness length ! bps..........bps (i)=sigki(1)=1.0e0/EXP(akappa*LOG(sig(k))) ! cu...........friction transfer coefficients. ! ct...........heat transfer coefficients. ! cuni.........neutral friction transfer coefficients. ! ctni.........neutral heat transfer coefficients. ! icheck.......this version assumes dew-free conditions "icheck=1" to ! estimate ea for buoyancy term in vntmf or ra. !======================================================================= INTEGER, INTENT(in ) :: ncols LOGICAL, INTENT(in ) :: jstneu INTEGER, INTENT(in ) :: mon(ncols) INTEGER, INTENT(in ) :: nmax ! ! vegetation and soil parameters ! REAL(KIND=r8), INTENT(in ) :: z2 (ityp,imon) INTEGER, INTENT(in ) :: itype (ncols) REAL(KIND=r8), INTENT(in ) :: d (ncols) REAL(KIND=r8), INTENT(in ) :: z0 (ncols) ! ! the size of working area is ncols*187 ! atmospheric parameters as boudary values for sib ! REAL(KIND=r8), INTENT(in ) :: tm (ncols) REAL(KIND=r8), INTENT(in ) :: um (ncols) REAL(KIND=r8), INTENT(in ) :: vm (ncols) ! ! variables calculated from above and ambient conditions ! REAL(KIND=r8), INTENT(inout) :: ra (ncols) REAL(KIND=r8), INTENT(in ) :: ta (ncols) REAL(KIND=r8), INTENT(inout) :: u2 (ncols) ! ! this is for coupling with closure turbulence model ! REAL(KIND=r8), INTENT(in ) :: bps (ncols) REAL(KIND=r8), INTENT(in ) :: dzm (ncols) REAL(KIND=r8), INTENT(inout) :: cu (ncols) REAL(KIND=r8), INTENT(inout) :: ct (ncols) REAL(KIND=r8), INTENT(inout) :: cuni (ncols) REAL(KIND=r8), INTENT(inout) :: ctni (ncols) REAL(KIND=r8), INTENT(inout) :: ustar (ncols) INTEGER, INTENT(in ) :: icheck(ncols) REAL(KIND=r8), INTENT(inout) :: ustarn(ncols) !REAL(KIND=r8) :: thm(ncols) !**(JP)** scalar REAL(KIND=r8) :: thm !REAL(KIND=r8) :: ros(ncols) !**(JP)** unused REAL(KIND=r8) :: speedm(ncols) !REAL(KIND=r8) :: thvgm(ncols) !**(JP)** scalar REAL(KIND=r8) :: thvgm !REAL(KIND=r8) :: rib(ncols) !**(JP)** scalar REAL(KIND=r8) :: rib !REAL(KIND=r8) :: cui(ncols) !**(JP)** scalar REAL(KIND=r8) :: cui !REAL(KIND=r8) :: ran(ncols) !**(JP)** unused !REAL(KIND=r8) :: cti(ncols) !**(JP)** scalar REAL(KIND=r8) :: cti !REAL(KIND=r8) :: ct (ncols) !**(JP)** unused REAL(KIND=r8), PARAMETER :: vkrmn=0.40_r8 REAL(KIND=r8), PARAMETER :: fsc=66.85_r8 REAL(KIND=r8), PARAMETER :: ftc=0.904_r8 REAL(KIND=r8), PARAMETER :: fvc=0.315_r8 REAL(KIND=r8) :: rfac REAL(KIND=r8) :: vkrmni REAL(KIND=r8) :: g2 REAL(KIND=r8) :: zl REAL(KIND=r8) :: xct1 REAL(KIND=r8) :: xct2 REAL(KIND=r8) :: xctu1 REAL(KIND=r8) :: xctu2 REAL(KIND=r8) :: grib REAL(KIND=r8) :: grzl REAL(KIND=r8) :: grz2 REAL(KIND=r8) :: fvv REAL(KIND=r8) :: ftt REAL(KIND=r8) :: rzl REAL(KIND=r8) :: rz2 INTEGER :: i INTEGER :: ntyp rfac =1.0e2_r8 /gasr vkrmni=1.0_r8 /vkrmn g2 = 0.75_r8 DO i = 1, nmax IF (icheck(i) == 1) THEN speedm(i)=SQRT(um(i)**2+vm(i)**2) speedm(i)=MAX(2.0_r8 ,speedm(i)) END IF END DO ! ! cu and ct are the friction and heat transfer coefficients. ! cun and ctn are the neutral friction and heat transfer ! coefficients. ! IF (jstneu) THEN DO i = 1, nmax ntyp=itype(i) zl = z2(ntyp,mon(i)) + 11.785_r8 * z0(i) !ANNE cuni(i)=LOG((dzm(i)-d(i))/z0(i))*vkrmni cuni(i)=LOG(MAX((dzm(i)-d(i))/z0(i),0.0001_r8))*vkrmni ustarn(i)=speedm(i)/cuni(i) IF (zl < dzm(i)) THEN !ANNE xct1 = LOG((dzm(i)-d(i))/(zl-d(i))) !ANNE xct2 = LOG((zl-d(i))/z0(i)) xct1 = LOG(MAX((dzm(i)-d(i))/(zl-d(i)),0.0001_r8)) xct2 = LOG(MAX((zl-d(i))/z0(i),0.0001_r8)) xctu1 = xct1 !ANNE xctu2 = LOG((zl-d(i))/(z2(ntyp,mon(i))-d(i))) xctu2 = LOG(MAX((zl-d(i))/(z2(ntyp,mon(i))-d(i)),0.0001_r8)) ctni(i) = (xct1 + g2 * xct2) *vkrmni ELSE !ANNE xct2 = LOG((dzm(i)-d(i))/z0(i)) xct2 = LOG(MAX((dzm(i)-d(i))/z0(i),0.0001_r8)) xctu1 = 0.0_r8 !ANNE xctu2 = LOG((dzm(i)-d(i))/(z2(ntyp,mon(i))-d(i))) xctu2 = LOG(MAX((dzm(i)-d(i))/(z2(ntyp,mon(i))-d(i)),0.0001_r8)) ctni(i) = g2 * xct2 *vkrmni END IF ! ! neutral values of ustar and ventmf ! !ANNE u2(i) = speedm(i) - ustarn(i)*vkrmni*(xctu1 + g2*xctu2) u2(i) = max(speedm(i) - ustarn(i)*vkrmni*(xctu1 + g2*xctu2),0.01_r8) END DO RETURN END IF ! ! stability branch based on bulk richardson number. ! DO i = 1, nmax IF (icheck(i) == 1) THEN ! ! freelm(i)=.false. ! thm= tm(i)*bps(i) ntyp=itype(i) zl = z2(ntyp,mon(i)) + 11.785_r8 * z0(i) thvgm = ta(i)-thm !ANNE rib =-thvgm *grav*(dzm(i)-d(i)) & rib =-thvgm *grav*(MAX(dzm(i)-d(i),0.0001_r8)) & /(thm*(speedm(i)-u2(i))**2) ! Manzi Suggestion: ! rib (i)=max(-10.0_r8 ,rib(i)) rib =MAX(-1.5_r8 ,rib ) rib =MIN( 0.165_r8 ,rib ) IF (rib < 0.0_r8) THEN grib = -rib !ANNE grzl = -rib * (zl-d(i))/(dzm(i)-d(i)) !ANNE grz2 = -rib * z0(i)/(dzm(i)-d(i)) grzl = -rib * (zl-d(i))/(MAX(dzm(i)-d(i),0.0001_r8)) grz2 = -rib * z0(i)/(MAX(dzm(i)-d(i),0.0001_r8)) fvv = fvc*grib IF (zl < dzm(i)) THEN ftt = (ftc*grib) + (g2-1.0_r8) * (ftc*grzl) - g2 * (ftc*grz2) ELSE ftt = g2*((ftc*grib) - (ftc*grz2)) END IF cui = cuni(i) - fvv cti = ctni(i) - ftt ELSE !ANNE rzl = rib /(dzm(i)-d(i))*(zl-d(i)) !ANNE rz2 = rib /(dzm(i)-d(i))*z0(i) rzl = rib /(MAX(dzm(i)-d(i),0.0001_r8))*(zl-d(i)) rz2 = rib /(MAX(dzm(i)-d(i),0.0001_r8))*z0(i) fvv = fsc*rib IF (zl < dzm(i)) THEN ftt = (fsc*rib) + (g2-1) * (fsc*rzl) - g2 * (fsc*rz2) ELSE ftt = g2 * ((fsc*rib) - (fsc*rz2)) END IF cui = cuni(i) + fvv cti = ctni(i) + ftt ENDIF cu (i)=1.0_r8/cui !**(JP)** ct is not used anywhere else ct (i)=1.0_r8/cti ! ! ! surface friction velocity and ventilation mass flux ! ustar (i)=speedm(i)*cu(i) ra(i) = cti / ustar(i) !**(JP)** ran is not used anywhere else !ran(i) = ctni(i) / ustarn(i) !ran(i) = MAX(ran(i), 0.8_r8 ) ra(i) = MAX(ra(i), 0.8_r8 ) END IF END DO END SUBROUTINE vntlax ! runoff :performs inter-layer moisture exchanges. SUBROUTINE runoff( & roff ,tg ,td ,capac ,w ,itype ,dtc3x ,nmax ,ncols ) ! !----------------------------------------------------------------------- ! input parameters !----------------------------------------------------------------------- ! w(3) roff slope bee satco zdepth ! phsat poros pie dtc3x snomel ! w(3) ! !----------------------------------------------------------------------- ! output parameters !----------------------------------------------------------------------- ! w(3) roff !----------------------------------------------------------------------- ! ! roff.......Runoff (escoamente superficial e drenagem)(m) ! slope......Inclinacao de perda hidraulica na camada profunda do solo ! bee........Fator de retencao da umidade no solo (expoente da umidade do ! solo) ! satco......Condutividade hidraulica do solo saturado(m/s) ! zdepth(id).Profundidade das camadas de solo id=1 superficial ! zdepth(id).Profundidade das camadas de solo id=2 camada de raizes ! zdepth(id).Profundidade das camadas de solo id=3 camada de drenagem ! phsat......Potencial matricial do solo saturado(m) (tensao do solo em ! saturacao) ! poros......Porosidade do solo ! pie........pi = 3.1415926e0 ! dtc3x......time increment dt ! snomel.....Calor latente de fusao(J/kg) ! w(id)......Grau de saturacao de umidade do solo id=1 na camada superficial ! w(id)......Grau de saturacao de umidade do solo id=2 na camada de raizes ! w(id)......Grau de saturacao de umidade do solo id=3 na camada de drenagem ! capac(iv)..Agua interceptada iv=1 no dossel (m) ! capac(iv)..Agua interceptada iv=2 na cobertura do solo (m) ! tg.........Temperatura da superficie do solo (K) ! td.........Temperatura do solo profundo (K) ! itype......Classe de textura do solo ! tf.........Temperatura de congelamento (K) ! idp........Parametro para as camadas de solo idp=1->3 ! nmax....... ! ncols......Numero de ponto por faixa de latitude ! ityp.......13 !----------------------------------------------------------------------- INTEGER, INTENT(in ) :: ncols REAL(KIND=r8), INTENT(in ) :: dtc3x INTEGER, INTENT(in ) :: nmax INTEGER, INTENT(in ) :: itype (ncols) ! ! prognostic variables ! REAL(KIND=r8), INTENT(in ) :: tg (ncols) REAL(KIND=r8), INTENT(in ) :: td (ncols) REAL(KIND=r8), INTENT(in ) :: capac(ncols,2) REAL(KIND=r8), INTENT(inout) :: w (ncols,3) ! ! heat fluxes : c-canopy, g-ground, t-trans, e-evap in j m-2 ! REAL(KIND=r8), INTENT(inout) :: roff (ncols) REAL(KIND=r8) :: q3g (ncols) REAL(KIND=r8) :: div (ncols) REAL(KIND=r8) :: twi (ncols,3) REAL(KIND=r8) :: twip (ncols,3) REAL(KIND=r8) :: twipp (ncols,3) REAL(KIND=r8) :: avk (ncols) REAL(KIND=r8) :: aaa_1, aaa_2 REAL(KIND=r8) :: bbb_1, bbb_2 REAL(KIND=r8) :: ccc_1, ccc_2 REAL(KIND=r8) :: qqq_1, qqq_2 REAL(KIND=r8) :: subdt REAL(KIND=r8) :: subdti REAL(KIND=r8) :: slop REAL(KIND=r8) :: pows REAL(KIND=r8) :: wmax REAL(KIND=r8) :: wmin REAL(KIND=r8) :: pmax REAL(KIND=r8) :: pmin REAL(KIND=r8) :: dpdw REAL(KIND=r8) :: rsame REAL(KIND=r8) :: tsnow REAL(KIND=r8) :: areas REAL(KIND=r8) :: tgs REAL(KIND=r8) :: ts REAL(KIND=r8) :: props REAL(KIND=r8) :: dpdwdz REAL(KIND=r8) :: denom REAL(KIND=r8) :: rdenom REAL(KIND=r8) :: qmax REAL(KIND=r8) :: qmin REAL(KIND=r8) :: excess REAL(KIND=r8) :: deficit INTEGER :: n INTEGER :: i INTEGER :: ntyp REAL(KIND=r8), PARAMETER :: smal2 = 1.0e-3_r8 subdt =dtc3x subdti=1.0_r8 /dtc3x q3g=0.0_r8 ! ! eliinate negative soil moisture ! DO n = 1, nmax IF (w(n,1) < 0.0_r8) w(n,1)=smal2 IF (w(n,2) < 0.0_r8) w(n,2)=smal2 IF (w(n,3) < 0.0_r8) w(n,3)=smal2 END DO DO i = 1, 3 DO n = 1, nmax ntyp =itype(n) twi(n,i)=MIN(1.0_r8, MAX(0.03_r8,w(n,i))) twip(n,i) =EXP(-bee(ntyp)*LOG(twi(n,i))) twipp(n,i)=EXP((2.0_r8*bee(ntyp)+3.0_r8)*LOG(MIN(1.0_r8,twi(n,i)))) END DO END DO DO n = 1, nmax ntyp = itype(n) slop = 0.1736_r8 IF (poros(ntyp) == 0.4352_r8) slop = 0.0872_r8 IF (poros(ntyp) == 0.4577_r8) slop = 0.3420_r8 ! ! calculation of gravitationally driven drainage from w(3) : taken ! as an integral of time varying conductivity.addition of liston ! baseflow term to original q3g to insure flow in ! dry season. modified liston baseflow constant scaled ! by available water. ! ! q3g (q3) : equation (62) , se-86 ! pows = 2.0_r8 *bee(ntyp)+2.0_r8 q3g (n) = EXP(-pows*LOG(twi(n,3))) & +satco(ntyp)/(zdepth(ntyp,3)*poros(ntyp))* & slop*pows*subdt q3g (n) = EXP(LOG(q3g(n))/pows) q3g (n) =-(1.0_r8 /q3g(n)-w(n,3)) & *poros(ntyp)*zdepth(ntyp,3)*subdti q3g (n) = MAX(0.0_r8 ,q3g(n)) q3g (n) = MIN(q3g(n), w(n,3)*poros(ntyp)*zdepth(ntyp,3) & *subdti) q3g (n) = q3g(n)+0.002_r8*poros(ntyp)*zdepth(ntyp,3)*0.5_r8 & /86400.0_r8*w(n,3) END DO ! ! calculation of inter-layer exchanges of water due to gravitation ! and hydraulic gradient. the values of w(x) + dw(x) are used to ! calculate the potential gradients between layers. ! modified calculation of mean conductivities follows milly and ! eagleson (1982 ), reduces recharge flux to top layer. ! ! dpdw : estimated derivative of soil moisture potential ! with respect to soil wetness. assumption of ! gravitational drainage used to estimate likely ! minimum wetness over the time step. ! ! qqq (q ) : equation (61) , s-86 ! i,i+1 ! - ! avk (k ) : equation (4.14) , milly and eagleson (1982) ! i,i+1 ! DO n = 1, nmax ntyp=itype(n) wmax = MAX( w(n,1), w(n,2), w(n,3), 0.05_r8 ) wmax = MIN( wmax, 1.0_r8 ) pmax = EXP(-bee(ntyp)*LOG(wmax)) wmin = EXP(-1.0_r8/bee(ntyp)*LOG(pmax-2.0_r8/(phsat(ntyp) & *(zdepth(ntyp,1)+2.0_r8*zdepth(ntyp,2)+zdepth(ntyp,3))))) wmin = MIN( w(n,1), w(n,2), w(n,3), wmin ) wmin = MAX( wmin, 0.02_r8 ) pmin = EXP(-bee(ntyp)*LOG(wmin)) dpdw = phsat(ntyp)*( pmax-pmin )/( wmax-wmin ) ! hand unrolling of next do loop, first iteration rsame = 0.0_r8 avk(n) =twip(n,1)*twipp(n,1)-twip(n,1+1)*twipp(n,1+1) div(n) =twip(n,1+1) - twip(n,1) IF(ABS(div(n)).LE.1.0e-7_r8) rsame = 1.0_r8 avk(n)=satco(ntyp)*avk(n)/ & ((1.0_r8 +3.0_r8 /bee(ntyp))*div(n)+ rsame) avk(n)=MAX(avk(n),satco(ntyp)*MIN(twipp(n,1),twipp(n,1+1))) avk(n)=MIN(avk(n),1.01_r8*(satco(ntyp) & *MAX(twipp(n,1),twipp(n,1+1)))) ! ! conductivities and base flow reduced when temperature drops below ! freezing ! tsnow = MIN (tf-0.01_r8, tg(n)) areas = MIN (0.999_r8,13.2_r8*capac(n,2)) tgs = tsnow*areas + tg(n)*(1.0_r8-areas) ts = tgs*(2-1) + td(n)*(1-1) props = (ts-(tf-10.0_r8))/10.0_r8 props = MAX(0.05_r8,MIN(1.0_r8, props)) avk(n) = avk(n) * props q3g(n) = q3g(n) * props ! ! backward implicit calculation of flows between soil layers ! dpdwdz= dpdw * 2.0_r8/( zdepth(ntyp,1) + zdepth(ntyp,1+1) ) aaa_1=1.0_r8+avk(n)*dpdwdz* & (1.0_r8/zdepth(ntyp,1)+1.0_r8/zdepth(ntyp,1+1)) & *subdt/poros(ntyp) bbb_1 =-avk(n)* dpdwdz*1.0_r8/zdepth(ntyp,2)*subdt/poros(ntyp) ccc_1 = avk(n) * (dpdwdz * ( w(n,1)-w(n,1+1) )+1.0_r8+(1-1) & *dpdwdz*q3g(n)*1.0_r8/zdepth(ntyp,3)*subdt/poros(ntyp)) ! hand unrolling of next do loop, second iteration rsame = 0.0_r8 avk(n) =twip(n,2)*twipp(n,2)-twip(n,2+1)*twipp(n,2+1) div(n) =twip(n,2+1) - twip(n,2) IF(ABS(div(n)).LE.1.0e-7_r8) rsame = 1.0_r8 avk(n)=satco(ntyp)*avk(n)/ & ((1.0_r8 +3.0_r8 /bee(ntyp))*div(n)+ rsame) avk(n)=MAX(avk(n),satco(ntyp)*MIN(twipp(n,2),twipp(n,2+1))) avk(n)=MIN(avk(n),1.01_r8*(satco(ntyp) & *MAX(twipp(n,2),twipp(n,2+1)))) ! ! conductivities and base flow reduced when temperature drops below ! freezing ! tsnow = MIN (tf-0.01_r8, tg(n)) areas = MIN (0.999_r8,13.2_r8*capac(n,2)) tgs = tsnow*areas + tg(n)*(1.0_r8-areas) ts = tgs*(2-2) + td(n)*(2-1) props = (ts-(tf-10.0_r8))/10.0_r8 props = MAX(0.05_r8,MIN(1.0_r8, props)) avk(n) = avk(n) * props q3g(n) = q3g(n) * props ! ! backward implicit calculation of flows between soil layers ! dpdwdz= dpdw * 2.0_r8/( zdepth(ntyp,2) + zdepth(ntyp,2+1) ) aaa_2=1.0_r8+avk(n)*dpdwdz* & (1.0_r8/zdepth(ntyp,2)+1.0_r8/zdepth(ntyp,2+1)) & *subdt/poros(ntyp) bbb_2 =-avk(n)* dpdwdz*1.0_r8/zdepth(ntyp,2)*subdt/poros(ntyp) ccc_2 = avk(n) * (dpdwdz * ( w(n,2)-w(n,2+1) )+1.0_r8+(2-1) & *dpdwdz*q3g(n)*1.0_r8/zdepth(ntyp,3)*subdt/poros(ntyp)) ! DO i = 1, 2 ! rsame = 0.0_r8 ! avk(n) =twip(n,i)*twipp(n,i)-twip(n,i+1)*twipp(n,i+1) ! div(n) =twip(n,i+1) - twip(n,i) ! IF(ABS(div(n)).LE.1.0e-7_r8) rsame = 1.0_r8 ! avk(n)=satco(ntyp)*avk(n)/ & ! ((1.0_r8 +3.0_r8 /bee(ntyp))*div(n)+ rsame) ! avk(n)=MAX(avk(n),satco(ntyp)*MIN(twipp(n,i),twipp(n,i+1))) ! avk(n)=MIN(avk(n),1.01_r8*(satco(ntyp) & ! *MAX(twipp(n,i),twipp(n,i+1)))) ! ! ! ! conductivities and base flow reduced when temperature drops below ! ! freezing ! ! ! tsnow = MIN (tf-0.01_r8, tg(n)) ! areas = MIN (0.999_r8,13.2_r8*capac(n,2)) ! tgs = tsnow*areas + tg(n)*(1.0_r8-areas) ! ts = tgs*(2-i) + td(n)*(i-1) ! props = (ts-(tf-10.0_r8))/10.0_r8 ! props = MAX(0.05_r8,MIN(1.0_r8, props)) ! avk(n) = avk(n) * props ! q3g(n) = q3g(n) * props ! ! ! ! backward implicit calculation of flows between soil layers ! ! ! dpdwdz= dpdw * 2.0_r8/( zdepth(ntyp,i) + zdepth(ntyp,i+1) ) ! aaa(i)=1.0_r8+avk(n)*dpdwdz* & ! (1.0_r8/zdepth(ntyp,i)+1.0_r8/zdepth(ntyp,i+1)) & ! *subdt/poros(ntyp) ! bbb(i) =-avk(n)* dpdwdz*1.0_r8/zdepth(ntyp,2)*subdt/poros(ntyp) ! ccc(i) = avk(n) * (dpdwdz * ( w(n,i)-w(n,i+1) )+1.0_r8+(i-1) & ! *dpdwdz*q3g(n)*1.0_r8/zdepth(ntyp,3)*subdt/poros(ntyp)) ! END DO denom = ( aaa_1*aaa_2 - bbb_1*bbb_2 ) rdenom = 0.0_r8 IF (ABS(denom) < 1.e-6_r8 ) rdenom = 1.0_r8 rdenom = ( 1.0_r8-rdenom)/( denom + rdenom ) qqq_1 = ( aaa_2*ccc_1 - bbb_1*ccc_2 ) * rdenom qqq_2 = ( aaa_1*ccc_2 - bbb_2*ccc_1 ) * rdenom ! ! update wetness of each soil moisture layer due to layer interflow ! and base flow. ! w(n,3) = w(n,3) - q3g(n)*subdt/(poros(ntyp)*zdepth(ntyp,3)) roff(n) = roff(n) + q3g(n) * subdt ! hand unrolling of next do loop, first iteration qmax = w(n,1) * (poros(ntyp)*zdepth(ntyp,1) /subdt) qmin = -w(n,1+1) * (poros(ntyp)*zdepth(ntyp,1+1)/subdt) qqq_1 = MIN( qqq_1,qmax) qqq_1 = MAX( qqq_1,qmin) w(n,1) = w(n,1) -qqq_1/(poros(ntyp)*zdepth(ntyp,1) /subdt) w(n,1+1) = w(n,1+1)+ & qqq_1/(poros(ntyp)*zdepth(ntyp,1+1)/subdt) ! hand unrolling of next do loop, second iteration qmax = w(n,2) * (poros(ntyp)*zdepth(ntyp,2) /subdt) qmin = -w(n,2+1) * (poros(ntyp)*zdepth(ntyp,2+1)/subdt) qqq_2 = MIN( qqq_2,qmax) qqq_2 = MAX( qqq_2,qmin) w(n,2) = w(n,2) -qqq_2/(poros(ntyp)*zdepth(ntyp,2) /subdt) w(n,2+1) = w(n,2+1)+ & qqq_2/(poros(ntyp)*zdepth(ntyp,2+1)/subdt) ! DO i = 1, 2 ! qmax = w(n,i) * (poros(ntyp)*zdepth(ntyp,i) /subdt) ! qmin = -w(n,i+1) * (poros(ntyp)*zdepth(ntyp,i+1)/subdt) ! qqq(i) = MIN( qqq(i),qmax) ! qqq(i) = MAX( qqq(i),qmin) ! w(n,i) = w(n,i) -qqq(i)/(poros(ntyp)*zdepth(ntyp,i) /subdt) ! w(n,i+1) = w(n,i+1)+ & ! qqq(i)/(poros(ntyp)*zdepth(ntyp,i+1)/subdt) ! END DO ! hand unrolling of next do loop, first iteration excess = MAX(0.0_r8,(w(n,1) - 1.0_r8)) w(n,1) = w(n,1) - excess roff(n) = roff(n) + excess * poros(ntyp)*zdepth(ntyp,1) ! hand unrolling of next do loop, second iteration excess = MAX(0.0_r8,(w(n,2) - 1.0_r8)) w(n,2) = w(n,2) - excess roff(n) = roff(n) + excess * poros(ntyp)*zdepth(ntyp,2) ! hand unrolling of next do loop, third iteration excess = MAX(0.0_r8,(w(n,3) - 1.0_r8)) w(n,3) = w(n,3) - excess roff(n) = roff(n) + excess * poros(ntyp)*zdepth(ntyp,3) ! DO i = 1, 3 ! excess = MAX(0.0_r8,(w(n,i) - 1.0_r8)) ! w(n,i) = w(n,i) - excess ! roff(n) = roff(n) + excess * poros(ntyp)*zdepth(ntyp,i) ! END DO ! hand unrolling of next do loop, first iteration deficit = MAX (0.0_r8,(1.e-12_r8 - w(n,1))) w(n,1) = w(n,1) + deficit w(n,1+1) = w(n,1+1)-deficit*zdepth(ntyp,1)/zdepth(ntyp,1+1) ! hand unrolling of next do loop, second iteration deficit = MAX (0.0_r8,(1.e-12_r8 - w(n,2))) w(n,2) = w(n,2) + deficit w(n,2+1) = w(n,2+1)-deficit*zdepth(ntyp,2)/zdepth(ntyp,2+1) ! ! prevent negative values of www(i) ! ! DO i = 1,2 ! deficit = MAX (0.0_r8,(1.e-12_r8 - w(n,i))) ! w(n,i) = w(n,i) + deficit ! w(n,i+1) = w(n,i+1)-deficit*zdepth(ntyp,i)/zdepth(ntyp,i+1) ! END DO w(n,3) = MAX (w(n,3),1.0e-12_r8) END DO END SUBROUTINE runoff ! stres2 :calculates the adjustment to light dependent stomatal resistance ! by temperature, humidity and stress factors (simplified). SUBROUTINE stres2( & icount,ft1 ,fp1 ,icheck,ta ,ea ,rst ,phsoil,stm , & tc ,tg ,w ,vcover,itype , & rootd ,zdepth,nmax ,ncols ,topt2 ,tll2 ,tu2 , & defac2,ph12 ,ph22) ! ! !----------------------------------------------------------------------- ! ityp........numero das classes de solo 13 ! icg.........Parametros da vegetacao (icg=1 topo e icg=2 base) ! idp.........Parametro para as camadas de solo idp=1->3 ! icount...... ! ft1.........temperature factor simplified ! fp1.........soil water potential factor simplified ! hl........heat of evaporation of water (j/kg) ! nmax........ ! topt........Temperatura ideal de funcionamento estomatico ! tll.........Temperatura minima de funcionamento estomatico ! tu..........Temperatura maxima de funcionamento estomatico ! defac.......Parametro de deficit de pressao de vapor d'agua ! ph1.........Coeficiente para o efeito da agua no solo ! ph2 ........Potencial de agua no solo para ponto de Wilting ! rootd.......Profundidade das raizes ! zdepth......Profundidade para as tres camadas de solo ! itype.......Classe de textura do solo ! vcover(iv)..Fracao de cobertura de vegetacao iv=1 Top ! vcover(iv)..Fracao de cobertura de vegetacao iv=2 Bottom ! tc..........Temperatura da copa "dossel"(K) ! tg .........Temperatura da superficie do solo (K) ! w(id).......Grau de saturacao de umidade do solo id=1 na camada superficial ! w(id).......Grau de saturacao de umidade do solo id=2 na camada de raizes ! w(id).......Grau de saturacao de umidade do solo id=3 na camada de drenagem ! ta..........Temperatura no nivel de fonte de calor do dossel (K) ! ea..........Pressao de vapor ! rst ........Resisttencia Estomatica "Stomatal resistence" (s/m) ! phsoil......soil moisture potential of the i-th soil layer ! stm.........Resisttencia Estomatica "Stomatal resistence" (s/m) ! icheck......this version assumes dew-free conditions "icheck=1" to ! estimate ea for buoyancy term in vntmf or ra. !----------------------------------------------------------------------- INTEGER, INTENT(IN ) :: ncols INTEGER, INTENT(IN ) :: icount REAL(KIND=r8), INTENT(INOUT) :: ft1 (ncols) REAL(KIND=r8), INTENT(INOUT) :: fp1 (ncols) ! INTEGER, INTENT(in ) :: nmax ! ! vegetation and soil parameters ! REAL(KIND=r8), INTENT(in ) :: rootd (ityp,icg) REAL(KIND=r8), INTENT(in ) :: zdepth(ityp,idp) INTEGER, INTENT(in ) :: itype (ncols) REAL(KIND=r8), INTENT(in ) :: vcover(ncols,icg) ! ! prognostic variables ! REAL(KIND=r8), INTENT(in ) :: tc (ncols) REAL(KIND=r8), INTENT(in ) :: tg (ncols) REAL(KIND=r8), INTENT(in ) :: w (ncols,3) ! ! variables calculated from above and ambient conditions ! REAL(KIND=r8), INTENT(in ) :: ta (ncols) REAL(KIND=r8), INTENT(in ) :: ea (ncols) REAL(KIND=r8), INTENT(inout) :: rst (ncols,icg) REAL(KIND=r8), INTENT(in ) :: phsoil(ncols,idp) REAL(KIND=r8), INTENT(in ) :: stm (ncols,icg) INTEGER, INTENT(in ) :: icheck(ncols) REAL(KIND=r8) , INTENT(in ) :: topt2 (ncols,icg) REAL(KIND=r8) , INTENT(in ) :: tll2 (ncols,icg) REAL(KIND=r8) , INTENT(in ) :: tu2 (ncols,icg) REAL(KIND=r8) , INTENT(in ) :: defac2(ncols,icg) REAL(KIND=r8) , INTENT(in ) :: ph12 (ncols,icg) REAL(KIND=r8) , INTENT(in ) :: ph22 (ncols,icg) ! REAL(KIND=r8) :: tv (ncols) REAL(KIND=r8) :: d2 (ncols) REAL(KIND=r8) :: ft (ncols) REAL(KIND=r8) :: drop(ncols) REAL(KIND=r8) :: fd (ncols) REAL(KIND=r8) :: fp (ncols) REAL(KIND=r8) :: ftpd(ncols) REAL(KIND=r8) :: dep(3) REAL(KIND=r8) :: hl3i REAL(KIND=r8) :: xrot REAL(KIND=r8) :: xdr REAL(KIND=r8) :: arg INTEGER :: iveg INTEGER :: i INTEGER :: ntyp ! ! humidity, temperature and transpiration factors ! tv=0.0_r8 ! CALL reset(tv,ncols*13) hl3i=1.0_r8 /(hl*1000.0_r8 ) iveg=1 IF (icount == 1) THEN !cdir novector DO i = 1, nmax IF (icheck(i) == 1) THEN ntyp=itype(i) IF ((ntyp == 11) .OR. (ntyp == 13)) THEN CONTINUE ELSE IF (iveg == 1) THEN tv (i)=tc(i) ELSE tv (i)=tg(i) END IF tv(i)=MIN((tu2 (i,iveg)-0.1_r8 ),tv(i)) tv(i)=MAX((tll2(i,iveg)+0.1_r8 ),tv(i)) d2(i)=(tu2 (i,iveg)-topt2(i,iveg)) & /(topt2(i,iveg)-tll2 (i,iveg)) ft(i)=(tv(i)-tll2(i,iveg))/ & (topt2(i,iveg)-tll2(i,iveg)) & *EXP(d2(i)*LOG( & (tu2 (i,iveg)-tv(i))/ & (tu2(i,iveg)-topt2(i,iveg)) ) ) ft(i) = MIN(ft(i), 1.e0_r8) ft(i) = MAX(ft(i), 1.e-5_r8) ft1(i) = ft(i) ! ! simplified calculation of soil water potential factor, fp ! xrot = rootd(ntyp,iveg) dep(1) = 0.0e0_r8 dep(2) = 0.0e0_r8 dep(3) = 0.0e0_r8 dep(1) = MIN(zdepth(ntyp,1), xrot) xrot = xrot - zdepth(ntyp,1) IF (xrot > 0.0e0_r8) THEN dep(2) = MIN(zdepth(ntyp,2), xrot) xrot = xrot - zdepth(ntyp,2) ENDIF IF (xrot > 0.0e0_r8) THEN dep(3) = MIN(zdepth(ntyp,3), xrot) xrot = xrot - zdepth(ntyp,3) ENDIF xdr = (phsoil(i,1) * dep(1) + phsoil(i,2) * dep(2) & +phsoil(i,3) * dep(3)) / rootd(ntyp,iveg) xdr = - xdr IF (xdr <= 1.0e-5_r8) xdr = 1.0e-5_r8 xdr = LOG (xdr) arg = -ph12(i,1)*(ph22(i,1)-xdr) arg = MIN(arg,0.0_r8) fp(i) = 1.e0_r8 - EXP(arg) IF ((w(i,2) > 0.15e0_r8) .AND. (fp(i) < 0.05e0_r8)) fp(i)=0.05e0_r8 fp(i) = MIN(fp(i), 1.e0_r8) fp(i) = MAX(fp(i), 1.e-5_r8) fp1(i) = fp(i) END IF END IF END DO END IF DO i = 1, nmax IF (icheck(i) == 1) THEN ntyp=itype(i) drop(i)=EXP(21.65605_r8 -5418.0_r8 /ta(i)) -ea(i) fd(i) = MAX( 1.0e-5_r8, 1.0_r8/(1.0_r8+ defac2(i,iveg)*drop(i))) fd(i) = MIN(fd(i), 1.e0_r8) END IF END DO DO i = 1, nmax IF (icheck(i) == 1) THEN ntyp=itype(i) rst(i,2) = 1.e5_r8 IF ((ntyp == 11) .OR. (ntyp == 13)) THEN rst(i,1) = 1.0e5_r8 CYCLE END IF ftpd(i) = fd(i)* ft1(i) * fp1(i) rst(i,iveg)=stm(i,iveg)/(ftpd(i)*vcover(i,iveg)) rst(i,iveg)=MIN(rst(i,iveg),1.0e5_r8) END IF END DO END SUBROUTINE stres2 ! update :performs the updating of soil moisture stores ! and interception capacity. SUBROUTINE update( & bps ,deadtg,deadtc,deadqm,ect ,eci ,egt ,egi ,egs , & eg ,hc ,hg ,ecmass,egmass,etmass,hflux ,chf ,shf , & ra ,rb ,rd ,ea ,etc ,etg ,btc ,btg ,cc , & cg ,dtc ,dtg ,dtm ,dqm ,tc ,tg ,td ,capac , & tm ,nmax ,dtc3x ,ncols) ! !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! ncols.......Numero de ponto por faixa de latitude ! pie.........Constante Pi=3.1415926e0 ! hl..........heat of evaporation of water (j/kg) ! snomel......heat of melting ! tf..........Temperatura de congelamento (K) ! dtc3x.......time increment dt ! nmax........ ! tm..........Temperature of reference (fourier) ! tc..........Temperatura da copa "dossel" canopy leaf temperature(K) ! tg..........Temperatura da superficie do solo ground temperature (K) ! td..........Temperatura do solo profundo (K) ! capac ......Agua interceptada iv=1 no dossel "water store capacity of leaves"(m) ! capac.......Agua interceptada iv=2 na cobertura do solo (m) ! ra..........Resistencia Aerodinamica (s/m) ! rb .........bulk boundary layer resistance (s/m) ! rd..........aerodynamic resistance between ground ! and canopy air space ! ea..........Pressao de vapor ! etc.........Pressure of vapor at top of the copa ! etg.........Pressao de vapor no base da copa ! btc.........btc(i)=EXP(30.25353 -5418.0 /tc(i))/(tc(i)*tc(i)) ! btg.........btg(i)=EXP(30.25353 -5418.0 /tg(i))/(tg(i)*tg(i)) ! cc..........heat capacity of the canopy ! cg..........heat capacity of the ground ! dtc.........dtc(i)=pblsib(i,2,5)*dtc3x ! dtg.........dtg(i)=pblsib(i,1,5)*dtc3x ! dtm.........dtm(i)=pblsib(i,3,5)*dtc3x ! dqm.........dqm(i)=pblsib(i,4,5)*dtc3x ! ect.........Transpiracao(J/m*m) ! eci.........Evaporacao da interceptacao da agua (J/m*m) ! egt ........Transpiracao na base da copa (J/m*m) . ! egi.........Evaporacao da neve (J/m*m) ! egs.........Evaporacao do solo arido (J/m*m) ! eg..........Soma da transpiracao na base da copa + Evaporacao do solo arido ! + Evaporacao da neve " eg (i)=egt(i)+egs(i)+egi(i)" ! hc..........total sensible heat lost of top from the veggies. ! hg..........total sensible heat lost of base from the veggies. ! ecmass......Mass of water lost of top from the veggies. ! egmass......Mass of water lost of base from the veggies. ! etmass......total mass of water lost from the veggies. ! hflux.......total sensible heat lost from the veggies. ! chf.........heat fluxes into the canopy in w/m**2 ! shf.........heat fluxes into the ground, in w/m**2 ! deadtg...... ! deadtc...... ! deadqm...... ! bps......... !----------------------------------------------------------------------- INTEGER, INTENT(in ) :: ncols REAL(KIND=r8), INTENT(in ) :: dtc3x INTEGER, INTENT(in ) :: nmax ! ! the size of working area is ncols*187 ! atmospheric parameters as boudary values for sib ! REAL(KIND=r8), INTENT(in ) :: tm (ncols) ! ! prognostic variables ! REAL(KIND=r8), INTENT(in ) :: tc (ncols) REAL(KIND=r8), INTENT(in ) :: tg (ncols) REAL(KIND=r8), INTENT(in ) :: td (ncols) REAL(KIND=r8), INTENT(inout) :: capac(ncols,2) ! ! variables calculated from above and ambient conditions ! REAL(KIND=r8), INTENT(in ) :: ra (ncols) REAL(KIND=r8), INTENT(in ) :: rb (ncols) REAL(KIND=r8), INTENT(in ) :: rd (ncols) REAL(KIND=r8), INTENT(in ) :: ea (ncols) REAL(KIND=r8), INTENT(in ) :: etc (ncols) REAL(KIND=r8), INTENT(in ) :: etg (ncols) REAL(KIND=r8), INTENT(in ) :: btc (ncols) REAL(KIND=r8), INTENT(in ) :: btg (ncols) REAL(KIND=r8), INTENT(in ) :: cc (ncols) REAL(KIND=r8), INTENT(in ) :: cg (ncols) REAL(KIND=r8), INTENT(in ) :: dtc (ncols) REAL(KIND=r8), INTENT(in ) :: dtg (ncols) REAL(KIND=r8), INTENT(in ) :: dtm (ncols) REAL(KIND=r8), INTENT(in ) :: dqm (ncols) ! ! heat fluxes : c-canopy, g-ground, t-trans, e-evap in j m-2 ! REAL(KIND=r8), INTENT(inout) :: ect (ncols) REAL(KIND=r8), INTENT(inout) :: eci (ncols) REAL(KIND=r8), INTENT(inout) :: egt (ncols) REAL(KIND=r8), INTENT(inout) :: egi (ncols) REAL(KIND=r8), INTENT(inout) :: egs (ncols) REAL(KIND=r8), INTENT(in ) :: eg (ncols) REAL(KIND=r8), INTENT(in ) :: hc (ncols) REAL(KIND=r8), INTENT(in ) :: hg (ncols) REAL(KIND=r8), INTENT(inout ) :: ecmass(ncols) REAL(KIND=r8), INTENT(inout ) :: egmass(ncols) REAL(KIND=r8), INTENT(inout ) :: etmass(ncols) REAL(KIND=r8), INTENT(inout ) :: hflux (ncols) REAL(KIND=r8), INTENT(inout ) :: chf (ncols) REAL(KIND=r8), INTENT(inout ) :: shf (ncols) ! ! derivatives ! REAL(KIND=r8), INTENT(in ) :: deadtg(ncols) REAL(KIND=r8), INTENT(in ) :: deadtc(ncols) REAL(KIND=r8), INTENT(in ) :: deadqm(ncols) ! ! this is for coupling with closure turbulence model ! REAL(KIND=r8), INTENT(in ) :: bps (ncols) REAL(KIND=r8) :: tgen (ncols) REAL(KIND=r8) :: tcen (ncols) REAL(KIND=r8) :: tmen (ncols) REAL(KIND=r8) :: taen (ncols) REAL(KIND=r8) :: eaen (ncols) REAL(KIND=r8) :: d1 (ncols) REAL(KIND=r8) :: estarc(ncols) REAL(KIND=r8) :: estarg(ncols) REAL(KIND=r8) :: facks (ncols) INTEGER :: i REAL(KIND=r8) :: timcon REAL(KIND=r8) :: dtc3xi REAL(KIND=r8) :: hlati REAL(KIND=r8) :: hlat3i REAL(KIND=r8) :: snofac ! ! adjustment of temperatures and vapor pressure , ! sensible heat fluxes. n.b. latent heat fluxes cannot be derived ! from estarc, estarg, ea due to linear result of implicit method ! ! ! ! DO i = 1, nmax tgen(i)=tg(i)+dtg(i) tcen(i)=tc(i)+dtc(i) tmen(i)=tm(i)+dtm(i) d1(i)=1.0_r8 /ra(i)+1.0_r8 /rb(i)+1.0_r8 /rd(i) ! ! compute the fluxes consistent with the differencing scheme. ! taen(i)=(tgen(i)/rd(i)+tcen(i)/ & rb(i)+tmen(i)*bps(i)/ra(i))/d1(i) eaen(i)=ea(i)+deadtc(i)*dtc(i)+deadtg(i)* & dtg(i)+deadqm(i)*dqm(i) ! ! vapor pressures within the canopy and the moss. ! estarc(i)=etc(i)+btc(i)*dtc(i) estarg(i)=etg(i)+btg(i)*dtg(i) END DO DO i = 1, nmax IF (tgen(i) <= tf) THEN egs(i)=eg(i)-egi(i) egt(i)=0.0_r8 END IF END DO ! ! heat fluxes into the canopy and the ground, in w/m**2 ! timcon=2.0_r8 *pie/86400.0_r8 dtc3xi=1.0_r8 /dtc3x hlati =1.0_r8 / hl hlat3i=1.0_r8 /(1.0e3_r8*hl) DO i = 1, nmax chf(i)=dtc3xi*cc(i)*dtc(i) shf(i)=dtc3xi*cg(i)*dtg(i) + timcon*cg(i)*(tg(i)+dtg(i)-td(i)) END DO ! ! evaporation losses are expressed in j m-2 : when divided by ! ( hl*1000.0_r8) loss is in m m-2 ! snofac=1.0_r8 /( 1.0_r8 +snomel*hlat3i) DO i = 1, nmax facks(i)=1.0_r8 IF (tcen(i) <= tf) facks(i)=snofac IF ((ect(i)+eci(i)) <= 0.0_r8) THEN eci(i) =ect(i)+eci(i) ect(i) =0.0_r8 facks(i)=1.0_r8 /facks(i) END IF END DO DO i = 1, nmax capac(i,1)=capac(i,1)-eci(i)*facks(i)*hlat3i ! ! mass terms are in kg m-2 dt-1 ! ecmass(i)=(ect(i)+eci(i)*facks(i))*hlati END DO DO i = 1, nmax facks(i)=1.0_r8 IF (tgen(i) <= tf) facks(i)=snofac IF ((egt(i)+egi(i)) <= 0.0_r8) THEN egi(i) =egt(i)+egi(i) egt(i) =0.0_r8 facks(i)=1.0_r8 /facks(i) END IF END DO DO i = 1, nmax capac(i,2)=capac(i,2)-egi(i)*facks(i)*hlat3i egmass(i)=(egt(i)+egs(i)+egi(i)*facks(i))*hlati ! ! total mass of water and total sensible heat lost from the veggies. ! etmass(i)=ecmass(i)+egmass(i) hflux (i)=hc(i)+hg(i) END DO END SUBROUTINE update SUBROUTINE sflxes(& hgdtg ,hgdtc ,hgdtm ,hcdtg ,hcdtc ,hcdtm ,egdtg ,egdtc ,egdqm , & ecdtg ,ecdtc ,ecdqm ,deadtg,deadtc,deadqm,icheck,bps ,psb , & dzm ,em ,gmt ,gmq ,cu ,cuni ,ctni ,ustar ,rhoair, & psy ,rcp ,wc ,wg ,fc ,fg ,hr ,ect ,eci , & egt ,egi ,egs ,ec ,eg ,hc ,hg ,ecidif,egidif, & ecmass,egmass,etmass,hflux ,chf ,shf ,ra ,rb ,rd , & rc ,rg ,tcta ,tgta ,ta ,ea ,etc ,etg ,btc , & btg ,u2 ,radt ,rst ,rsoil ,hrr ,phsoil,cc ,cg , & satcap,dtc ,dtg ,dtm ,dqm ,stm ,thermk,tc ,tg , & td ,capac ,w ,qm ,tm ,um ,vm ,psur ,vcover, & z0x ,d ,rdc ,rbc ,z0 ,itype ,dtc3x ,mon ,nmax , & jstneu,ncols ,zlt2 ,topt2 ,tll2 ,tu2 ,defac2,ph12 ,ph22 , & ct) !----------------------------------------------------------------------- ! sflxes :performs surface flux parameterization. !----------------------------------------------------------------------- ! ! ncols........Numero de ponto por faixa de latitude ! ityp........numero das classes de solo 13 ! imon........Numero maximo de meses no ano (12) ! icg.........Parametros da vegetacao (icg=1 topo e icg=2 base) ! idp.........Camadas de solo (1 a 3) ! pie.........Constante Pi=3.1415926e0 ! stefan......Constante de Stefan Boltzmann ! cp..........specific heat of air (j/kg/k) ! hl..........heat of evaporation of water (j/kg) ! grav........gravity constant (m/s**2) ! snomel......heat of melting (j m-1) ! tf..........Temperatura de congelamento (K) ! gasr........Constant of dry air (j/kg/k) ! epsfac......Constante 0.622 Razao entre as massas moleculares do vapor ! de agua e do ar seco ! jstneu......The first call to vntlat just gets the neutral values of ustar ! and ventmf para jstneu=.TRUE.. ! dtc3x.......time increment dt ! mon.........Number of month at year (1-12) ! nmax........ ! topt........Temperatura ideal de funcionamento estomatico ! tll.........Temperatura minima de funcionamento estomatico ! tu..........Temperatura maxima de funcionamento estomatico ! defac.......Parametro de deficit de pressao de vapor d'agua ! ph1.........Coeficiente para o efeito da agua no solo ! ph2.........Potencial de agua no solo para ponto de Wilting ! rootd.......Profundidade das raizes ! bee.........Expoente da curva de retencao "expoente para o solo umido" ! phsat.......Tensao do solo saturado " Potencial de agua no solo saturado" ! zdepth......Profundidade para as tres camadas de solo ! zlt(icg)....Indice de area foliar "LEAF AREA INDEX" icg=1 topo da copa ! zlt(icg)....Indice de area foliar "LEAF AREA INDEX" icg=2 base da copa ! x0x.........Comprimento de rugosidade ! xd..........Deslocamento do plano zero ! z2..........Altura do topo do dossel ! xdc.........Constant related to aerodynamic resistance ! between ground and canopy air space ! xbc.........Constant related to bulk boundary layer resistance ! itype.......Classe de textura do solo ! vcover(iv)..Fracao de cobertura de vegetacao iv=1 Top ! vcover(iv)..Fracao de cobertura de vegetacao iv=2 Botto ! z0x.........roughness length (m) ! d...........Displacement height (m) ! rdc.........Constant related to aerodynamic resistance ! between ground and canopy air space ! rbc.........Constant related to bulk boundary layer resistance ! z0..........Roughness length ! qm..........reference specific humidity (fourier) ! tm .........reference temperature (fourier) (k) ! um..........Razao entre zonal pseudo-wind (fourier) e seno da ! colatitude ! vm..........Razao entre meridional pseudo-wind (fourier) e seno da ! colatitude ! psur........surface pressure in mb ! tc..........Temperatura da copa "dossel"(K) ! tg..........Temperatura da superficie do solo (K) ! td..........Temperatura do solo profundo (K) ! capac(iv)...Agua interceptada iv=1 no dossel "water store capacity of leaves"(m) ! capac(iv)...Agua interceptada iv=2 na cobertura do solo (m) ! w(id).......Grau de saturacao de umidade do solo id=1 na camada superficial ! w(id).......Grau de saturacao de umidade do solo id=2 na camada de raizes ! w(id).......Grau de saturacao de umidade do solo id=3 na camada de drenagem ! ra..........Resistencia Aerodinamica (s/m) ! rb..........bulk boundary layer resistance (s/m) ! rd..........aerodynamic resistance between ground (s/m) ! and canopy air space ! rc..........Resistencia do topo da copa ! rg......... Resistencia da base da copa ! tcta........Diferenca entre tc-ta (k) ! tgta........Diferenca entre tg-ta (k) ! ta..........Temperatura no nivel de fonte de calor do dossel (K) ! ea..........Pressure of vapor ! etc.........Pressure of vapor at top of the copa ! etg.........Pressao de vapor no base da copa ! btc.........btc(i)=EXP(30.25353 -5418.0 /tc(i))/(tc(i)*tc(i)). ! btg.........btg(i)=EXP(30.25353 -5418.0 /tg(i))/(tg(i)*tg(i)) ! u2..........wind speed at top of canopy (m/s) ! radt........net heat received by canopy/ground vegetation ! rst ........Resisttencia Estomatica "Stomatal resistence" (s/m) ! rsoil ......Resistencia do solo (s/m) ! hrr.........rel. humidity in top layer ! phsoil......soil moisture potential of the i-th soil layer ! cc..........heat capacity of the canopy ! cg..........heat capacity of the ground ! satcap......saturation liquid water capacity (m) ! dtc.........dtc(i)=pblsib(i,2,5)*dtc3x ! dtg.........dtg(i)=pblsib(i,1,5)*dtc3x ! dtm.........dtm(i)=pblsib(i,3,5)*dtc3x ! dqm.........dqm(i)=pblsib(i,4,5)*dtc3x ! stm ........Variavel utilizada mo cal. da Resistencia ! thermk......canopy emissivity ! ect.........Transpiracao no topo da copa (J/m*m) ! eci.........Evaporacao da agua interceptada no topo da copa (J/m*m) ! egt.........Transpiracao na base da copa (J/m*m) ! egi.........Evaporacao da neve (J/m*m) ! egs.........Evaporacao do solo arido (J/m*m) ! ec..........Soma da Transpiracao e Evaporacao da agua interceptada pelo ! topo da copa ec (i)=eci(i)+ect(i) ! eg..........Soma da transpiracao na base da copa + Evaporacao do solo arido ! + Evaporacao da neve " eg (i)=egt(i)+egs(i)+egi(i)" ! hc..........total sensible heat lost of top from the veggies. ! hg..........total sensible heat lost of base from the veggies. ! ecidif......check if interception loss term has exceeded canopy storage ! ecidif(i)=MAX(0.0 , eci(i)-capac(i,1)*hlat3 ) ! egidif......check if interception loss term has exceeded canopy storage ! ecidif(i)=MAX(0.0 , egi(i)-capac(i,1)*hlat3 ) ! ecmass......Mass of water lost of top from the veggies. ! egmass......Mass of water lost of base from the veggies. ! etmass......total mass of water lost from the veggies. ! hflux.......total sensible heat lost from the veggies. ! chf.........heat fluxes into the canopy in w/m**2 ! shf.........heat fluxes into the ground, in w/m**2 ! bps......... ! psb......... ! dzm.........Altura media de referencia para o vento para o calculo ! da estabilidade do escoamento ! em..........Pressao de vapor da agua ! gmt......... ! gmq.........specific humidity of reference (fourier) ! cu..........Friction transfer coefficients. ! cuni........neutral friction transfer coefficients. ! ctni........neutral heat transfer coefficients. ! ustar.......surface friction velocity (m/s) ! rhoair......Desnsidade do ar ! psy.........(cp/(hl*epsfac))*psur(i) ! rcp.........densidade do ar vezes o calor especifico do ar ! wc..........Minimo entre 1 e a razao entre a agua interceptada pelo ! indice de area foliar no topo da copa ! wg..........Minimo entre 1 e a razao entre a agua interceptada pelo ! indice de area foliar na base da copa ! fc..........Condicao de oravalho 0 ou 1 na topo da copa ! fg..........Condicao de oravalho 0 ou 1 na base da copa ! hr..........rel. humidity in top layer ! icheck......this version assumes dew-free conditions "icheck=1" to ! estimate ea for buoyancy term in vntmf or ra. ! hgdtg.......n.b. fluxes expressed in joules m-2 ! hgdtc.......n.b. fluxes expressed in joules m-2 ! hgdtm.......n.b. fluxes expressed in joules m-2 ! hcdtg.......n.b. fluxes expressed in joules m-2 ! hcdtc.......n.b. fluxes expressed in joules m-2 ! hcdtm.......n.b. fluxes expressed in joules m-2 ! egdtg.......partial derivative calculation for latent heat ! egdtc.......partial derivative calculation for latent heat ! egdqm.......partial derivative calculation for latent heat ! ecdtg.......partial derivative calculation for latent heat ! ecdtc.......partial derivative calculation for latent heat ! ecdqm.......partial derivative calculation for latent heat ! deadtg...... ! deadtc...... ! deadqm...... ! !----------------------------------------------------------------------- INTEGER, INTENT(in ) :: ncols LOGICAL, INTENT(inout ) :: jstneu REAL(KIND=r8) , INTENT(in ) :: dtc3x INTEGER, INTENT(in ) :: mon(ncols) INTEGER, INTENT(in ) :: nmax ! INTEGER, INTENT(in ) :: itype (ncols) ! REAL(KIND=r8), INTENT(in) :: vcover(ncols,icg) REAL(KIND=r8), INTENT(inout) :: z0x (ncols) REAL(KIND=r8), INTENT(inout) :: d (ncols) REAL(KIND=r8), INTENT(inout) :: rdc (ncols) REAL(KIND=r8), INTENT(inout) :: rbc (ncols) REAL(KIND=r8), INTENT(inout) :: z0 (ncols) ! ! the size of working area is ncols*187 ! atmospheric parameters as boudary values for sib ! REAL(KIND=r8), INTENT(inout) :: qm (ncols) REAL(KIND=r8), INTENT(inout) :: tm (ncols) REAL(KIND=r8), INTENT(in ) :: um (ncols) REAL(KIND=r8), INTENT(in ) :: vm (ncols) REAL(KIND=r8), INTENT(inout) :: psur(ncols) ! ! prognostic variables ! REAL(KIND=r8), INTENT(inout) :: tc (ncols) REAL(KIND=r8), INTENT(inout) :: tg (ncols) REAL(KIND=r8), INTENT(inout) :: td (ncols) REAL(KIND=r8), INTENT(inout) :: capac(ncols,2) REAL(KIND=r8), INTENT(inout) :: w (ncols,3) ! ! variables calculated from above and ambient conditions ! REAL(KIND=r8), INTENT(inout) :: ra (ncols) REAL(KIND=r8), INTENT(inout ) :: rb (ncols) REAL(KIND=r8), INTENT(inout ) :: rd (ncols) REAL(KIND=r8), INTENT(inout ) :: rc (ncols) REAL(KIND=r8), INTENT(inout ) :: rg (ncols) REAL(KIND=r8), INTENT(inout ) :: tcta (ncols) REAL(KIND=r8), INTENT(inout ) :: tgta (ncols) REAL(KIND=r8), INTENT(inout ) :: ta (ncols) REAL(KIND=r8), INTENT(inout ) :: ea (ncols) REAL(KIND=r8), INTENT(inout ) :: etc (ncols) REAL(KIND=r8), INTENT(inout ) :: etg (ncols) REAL(KIND=r8), INTENT(inout ) :: btc (ncols) REAL(KIND=r8), INTENT(inout ) :: btg (ncols) REAL(KIND=r8), INTENT(inout) :: u2 (ncols) REAL(KIND=r8), INTENT(inout) :: radt (ncols,icg) REAL(KIND=r8), INTENT(inout) :: rst (ncols,icg) REAL(KIND=r8), INTENT(inout ) :: rsoil (ncols) REAL(KIND=r8), INTENT(inout ) :: hrr (ncols) REAL(KIND=r8), INTENT(inout) :: phsoil(ncols,idp) REAL(KIND=r8), INTENT(inout) :: cc (ncols) REAL(KIND=r8), INTENT(inout) :: cg (ncols) REAL(KIND=r8), INTENT(inout) :: satcap(ncols,icg) REAL(KIND=r8), INTENT(inout ) :: dtc (ncols) REAL(KIND=r8), INTENT(inout ) :: dtg (ncols) REAL(KIND=r8), INTENT(inout ) :: dtm (ncols) REAL(KIND=r8), INTENT(inout ) :: dqm (ncols) REAL(KIND=r8), INTENT(inout ) :: stm (ncols,icg) REAL(KIND=r8), INTENT(inout) :: thermk(ncols) ! ! heat fluxes : c-canopy, g-ground, t-trans, e-evap in j m-2 ! REAL(KIND=r8), INTENT(inout) :: ect (ncols) REAL(KIND=r8), INTENT(inout) :: eci (ncols) REAL(KIND=r8), INTENT(inout) :: egt (ncols) REAL(KIND=r8), INTENT(inout) :: egi (ncols) REAL(KIND=r8), INTENT(inout) :: egs (ncols) REAL(KIND=r8), INTENT(inout ) :: ec (ncols) REAL(KIND=r8), INTENT(inout ) :: eg (ncols) REAL(KIND=r8), INTENT(inout ) :: hc (ncols) REAL(KIND=r8), INTENT(inout ) :: hg (ncols) REAL(KIND=r8), INTENT(inout ) :: ecidif(ncols) REAL(KIND=r8), INTENT(inout ) :: egidif(ncols) REAL(KIND=r8), INTENT(inout ) :: ecmass(ncols) REAL(KIND=r8), INTENT(inout ) :: egmass(ncols) REAL(KIND=r8), INTENT(inout ) :: etmass(ncols) REAL(KIND=r8), INTENT(inout ) :: hflux (ncols) REAL(KIND=r8), INTENT(inout ) :: chf (ncols) REAL(KIND=r8), INTENT(inout ) :: shf (ncols) ! ! this is for coupling with closure turbulence model ! REAL(KIND=r8), INTENT(in ) :: bps (ncols) REAL(KIND=r8), INTENT(in ) :: psb (ncols) REAL(KIND=r8), INTENT(in ) :: dzm (ncols) REAL(KIND=r8), INTENT(in ) :: em (ncols) REAL(KIND=r8), INTENT(inout) :: gmt (ncols,3) REAL(KIND=r8), INTENT(inout) :: gmq (ncols,3) REAL(KIND=r8), INTENT(inout) :: cu (ncols) REAL(KIND=r8), INTENT(inout) :: ct (ncols) REAL(KIND=r8), INTENT(inout) :: cuni (ncols) REAL(KIND=r8), INTENT(inout) :: ctni (ncols) REAL(KIND=r8), INTENT(inout) :: ustar (ncols) REAL(KIND=r8), INTENT(in ) :: rhoair(ncols) REAL(KIND=r8), INTENT(in ) :: psy (ncols) REAL(KIND=r8), INTENT(inout ) :: rcp (ncols) REAL(KIND=r8), INTENT(inout) :: wc (ncols) REAL(KIND=r8), INTENT(inout) :: wg (ncols) REAL(KIND=r8), INTENT(inout) :: fc (ncols) REAL(KIND=r8), INTENT(inout) :: fg (ncols) REAL(KIND=r8), INTENT(inout) :: hr (ncols) INTEGER, INTENT(inout ) :: icheck(ncols) ! ! derivatives ! REAL(KIND=r8), INTENT(inout ) :: hgdtg (ncols) REAL(KIND=r8), INTENT(inout ) :: hgdtc (ncols) REAL(KIND=r8), INTENT(inout ) :: hgdtm (ncols) REAL(KIND=r8), INTENT(inout ) :: hcdtg (ncols) REAL(KIND=r8), INTENT(inout ) :: hcdtc (ncols) REAL(KIND=r8), INTENT(inout ) :: hcdtm (ncols) REAL(KIND=r8), INTENT(inout ) :: egdtg (ncols) REAL(KIND=r8), INTENT(inout ) :: egdtc (ncols) REAL(KIND=r8), INTENT(inout ) :: egdqm (ncols) REAL(KIND=r8), INTENT(inout ) :: ecdtg (ncols) REAL(KIND=r8), INTENT(inout ) :: ecdtc (ncols) REAL(KIND=r8), INTENT(inout ) :: ecdqm (ncols) REAL(KIND=r8), INTENT(inout ) :: deadtg(ncols) REAL(KIND=r8), INTENT(inout ) :: deadtc(ncols) REAL(KIND=r8), INTENT(inout ) :: deadqm(ncols) ! REAL(KIND=r8), INTENT(in ) :: zlt2 (ncols,icg) REAL(KIND=r8) , INTENT(in ) :: topt2 (ncols,icg) REAL(KIND=r8) , INTENT(in ) :: tll2 (ncols,icg) REAL(KIND=r8) , INTENT(in ) :: tu2 (ncols,icg) REAL(KIND=r8) , INTENT(in ) :: defac2 (ncols,icg) REAL(KIND=r8) , INTENT(in ) :: ph12 (ncols,icg) REAL(KIND=r8) , INTENT(in ) :: ph22 (ncols,icg) ! REAL(KIND=r8) :: ustarn(ncols) REAL(KIND=r8) :: psit REAL(KIND=r8) :: fac REAL(KIND=r8) :: y1 REAL(KIND=r8) :: y2 REAL(KIND=r8) :: ecf (ncols) REAL(KIND=r8) :: egf (ncols) REAL(KIND=r8) :: dewc(ncols) REAL(KIND=r8) :: dewg(ncols) ! REAL(KIND=r8) :: tcsav (ncols) REAL(KIND=r8) :: tgsav (ncols) REAL(KIND=r8) :: tmsav (ncols) REAL(KIND=r8) :: qmsav (ncols) REAL(KIND=r8) :: tsav (ncols) REAL(KIND=r8) :: esav (ncols) REAL(KIND=r8) :: rdsav (ncols,2) REAL(KIND=r8) :: wt REAL(KIND=r8) :: ft1 (ncols) REAL(KIND=r8) :: fp1 (ncols) INTEGER :: idewco(ncols) ! INTEGER, PARAMETER :: icmax = 10 REAL(KIND=r8), PARAMETER :: small = 1.0e-3_r8 REAL(KIND=r8) :: gxx REAL(KIND=r8) :: capaci REAL(KIND=r8) :: eee REAL(KIND=r8) :: dtmdt REAL(KIND=r8) :: dqmdt REAL(KIND=r8) :: vcover2(ncols,icg) INTEGER :: i INTEGER :: ntyp INTEGER :: ncount INTEGER :: icount ! vcover2=vcover DO i = 1, nmax tcsav(i)=tc(i) tgsav(i)=tg(i) tmsav(i)=tm(i) qmsav(i)=qm(i) rdsav(i,1)=radt(i,1) rdsav(i,2)=radt(i,2) stm(i,1)=rst(i,1) stm(i,2)=rst(i,2) END DO ! ! airmod checks for the effects of snow ! CALL airmod( & tg ,capac ,z0x ,d ,rdc ,rbc ,itype , & mon ,nmax ,ncols ) ! ! sib roughness length ! DO i = 1, nmax z0 (i)=z0x(i) END DO gxx =grav/461.5_r8 capaci= 1.0_r8 /0.004_r8 DO i = 1, nmax ntyp =itype(i) wc (i)=MIN(1.0_r8 ,capac(i,1)/satcap(i,1)) wg (i)=MIN(1.0_r8 ,capac(i,2)/satcap(i,2)) ! ! rsoil function from fit to camillo and gurney (1985) data. ! wetness of upper 0.5 cm of soil calculated from approximation ! to milly flow equation with reduced (1/50) conductivity in ! top layer. ! wt = MAX(small,w(i,1)) wt=wt+(0.75_r8*zdepth(ntyp,1)/(zdepth(ntyp,1)+ & zdepth(ntyp,2)))*(wt-(w(i,2)*w(i,2)/wt))*0.5_r8*50.0_r8 fac =MIN(wt,0.99_r8) fac =MAX(fac ,small) rsoil(i)=101840.0_r8*(1.0_r8 - EXP(0.0027_r8 * LOG(fac ))) ! !phsat = " Potencial de agua no solo saturado" ! psit = phsat(ntyp) * EXP(-bee(ntyp) * LOG(fac )) ! ! -- -- ! | PSI*g | ! eee = |---------| ! | Tg*R | ! -- -- ! eee = psit * gxx/tg(i) ! !The relative humidity of air at the soil surface ! ! -- -- ! | PSI*g | ! fh = exp*|---------| ! | Tg*R | ! -- -- ! hrr (i)=MAX (small,EXP(eee)) ! hr (i)=hrr(i) ! IF (tg(i) <= tf) THEN vcover2(i,2)=1.0_r8 wg (i) =MIN(1.0_r8 ,capac(i,2)*capaci) rst (i,2)=rsoil(i) stm (i,2)=rsoil(i) END IF ! fc(i)=1.0_r8 fg(i)=1.0_r8 END DO ! ! this is the start of iteration of time integration ! to avoid oscillation ! ncount=0 7000 CONTINUE ncount=ncount+1 DO i = 1, nmax icheck(i)=1 ! ! etc.........Pressure of vapor at top of the copa ! etg.........Pressao de vapor no base da copa ! etc(i)=EXP(21.65605_r8 -5418.0_r8 / tc(i)) etg(i)=EXP(21.65605_r8 -5418.0_r8 / tg(i)) END DO ! ! first guesses for ta and ea ! IF (ncount == 1) THEN DO i = 1, nmax ta (i)=tc(i) ! ! ea..........Pressure of vapor ! ea (i)=qm(i)*psur(i)/(epsfac+qm(i)) END DO END IF ! ! the first call to vntlat just gets the neutral values of ustar ! and ventmf. ! jstneu=.TRUE. CALL vntlax(ustarn, & icheck,bps ,dzm ,cu ,ct ,cuni ,ctni ,ustar ,ra ,ta , & u2 ,tm ,um ,vm ,d ,z0 ,itype ,z2 , & mon ,nmax ,jstneu,ncols ) jstneu=.FALSE. CALL vntlax(ustarn, & icheck ,bps ,dzm ,cu ,ct ,cuni ,ctni ,ustar ,ra ,ta , & u2 ,tm ,um ,vm ,d ,z0 ,itype ,z2 , & mon ,nmax ,jstneu,ncols ) DO i = 1, nmax tcta(i)=tc(i)/bps(i)-tm(i) tgta(i)=tg(i)/bps(i)-tm(i) END DO CALL rbrd( & rb ,rd ,tcta ,tgta ,u2 ,tg ,rdc ,rbc ,itype , & z2 ,mon ,nmax ,ncols ,zlt2) ! ! iterate for air temperature and ventilation mass flux ! n.b. this version assumes dew-free conditions to estimate ea ! for buoyancy term in vntmf or ra. ! icount = 0 2000 icount = icount + 1 DO i = 1, nmax IF (icheck(i) == 1) THEN tsav(i) = ta (i) esav(i) = ea (i) END IF END DO CALL vntlax(ustarn, & icheck,bps ,dzm ,cu ,ct ,cuni ,ctni ,ustar ,ra ,ta , & u2 ,tm ,um ,vm ,d ,z0 ,itype ,z2 , & mon ,nmax ,jstneu,ncols ) CALL cut( & icheck,em ,rhoair,rcp ,wc ,wg ,fc ,fg ,hr , & ra ,rb ,rd ,rc ,rg ,ea ,etc ,etg ,rst , & rsoil ,vcover2,nmax ,ncols ) CALL stres2( & icount,ft1 ,fp1 ,icheck,ta ,ea ,rst ,phsoil,stm , & tc ,tg ,w ,vcover2,itype ,& rootd ,zdepth,nmax ,ncols ,topt2 ,tll2 ,tu2 , & defac2,ph12 ,ph22) CALL cut( & icheck,em ,rhoair,rcp ,wc ,wg ,fc ,fg ,hr , & ra ,rb ,rd ,rc ,rg ,ea ,etc ,etg ,rst , & rsoil ,vcover2,nmax ,ncols ) DO i = 1, nmax IF (icheck(i) == 1) THEN ta(i)= (tg(i)/rd(i)+tc(i)/rb(i)+tm(i)/ra(i)*bps(i)) & /(1.0_r8 /rd(i)+1.0_r8 /rb(i)+1.0_r8 /ra(i)) END IF END DO DO i = 1, nmax IF (icheck(i) == 1) THEN y1 =ABS(ta(i)-tsav(i)) y2 =ABS(ea(i)-esav(i)) IF((y1 <= 1.0e-2_r8 .AND. y2 <= 5.0e-3_r8) & .OR. icount > icmax) THEN icheck(i)=0 END IF END IF END DO DO i = 1, nmax IF (icheck(i) == 1) GOTO 2000 END DO DO i = 1, nmax fc (i)=1.0_r8 fg (i)=1.0_r8 idewco(i)=0 icheck(i)=1 END DO DO i = 1, nmax tc(i) =tcsav(i) tg(i) =tgsav(i) tm(i) =tmsav(i) qm(i) =qmsav(i) radt(i,1)=rdsav(i,1) radt(i,2)=rdsav(i,2) etc(i)=EXP(21.65605_r8 -5418.0_r8 /tc(i)) etg(i)=EXP(21.65605_r8 -5418.0_r8 /tg(i)) btc(i)=EXP(30.25353_r8 -5418.0_r8 /tc(i))/(tc(i)*tc(i)) btg(i)=EXP(30.25353_r8 -5418.0_r8 /tg(i))/(tg(i)*tg(i)) END DO 3000 CONTINUE CALL cut( & icheck,em ,rhoair,rcp ,wc ,wg ,fc ,fg ,hr , & ra ,rb ,rd ,rc ,rg ,ea ,etc ,etg ,rst , & rsoil ,vcover2,nmax ,ncols ) DO i = 1, nmax IF (icheck(i) == 1) THEN ecf (i)=SIGN(1.0_r8 ,etc(i)-ea(i)) egf (i)=SIGN(1.0_r8 ,etg(i)-ea(i)) dewc(i)=fc(i)*2.0_r8 -1.0_r8 dewg(i)=fg(i)*2.0_r8 -1.0_r8 ecf (i)=ecf(i)*dewc(i) egf (i)=egf(i)*dewg(i) END IF END DO DO i = 1, nmax IF ( (ecf(i) > 0.0_r8 .AND. egf(i) > 0.0_r8 ).OR. & idewco(i) == 3) THEN icheck(i)=0 ELSE idewco(i)=idewco(i)+1 IF (idewco(i) == 1) THEN fc(i)=0.0_r8 fg(i)=1.0_r8 ELSE IF (idewco(i) == 2) THEN fc(i)=1.0_r8 fg(i)=0.0_r8 ELSE IF (idewco(i) == 3) THEN fc(i)=0.0_r8 fg(i)=0.0_r8 END IF END IF END DO DO i=1,nmax IF (icheck(i) == 1) go to 3000 END DO CALL temres(& bps ,psb ,em ,gmt ,gmq ,psy ,rcp ,wc ,wg , & fc ,fg ,hr ,hgdtg ,hgdtc ,hgdtm ,hcdtg ,hcdtc ,hcdtm , & egdtg ,egdtc ,egdqm ,ecdtg ,ecdtc ,ecdqm ,deadtg,deadtc,deadqm, & ect ,eci ,egt ,egi ,egs ,ec ,eg ,hc ,hg , & ecidif,egidif,ra ,rb ,rd ,rc ,rg ,ta ,ea , & etc ,etg ,btc ,btg ,radt ,rst ,rsoil ,hrr ,cc , & cg ,satcap,dtc ,dtg ,dtm ,dqm ,thermk,tc ,tg , & td ,capac ,qm ,tm ,psur ,dtc3x , & nmax ,vcover2,ncols) IF (ncount <= 1) THEN DO i = 1, nmax tc(i)=tc(i)+dtc(i) tg(i)=tg(i)+dtg(i) tm(i)=tm(i)+dtm(i) qm(i)=qm(i)+dqm(i) END DO go to 7000 END IF CALL update( & bps ,deadtg,deadtc,deadqm,ect ,eci ,egt ,egi ,egs , & eg ,hc ,hg ,ecmass,egmass,etmass,hflux ,chf ,shf , & ra ,rb ,rd ,ea ,etc ,etg ,btc ,btg ,cc , & cg ,dtc ,dtg ,dtm ,dqm ,tc ,tg ,td ,capac , & tm ,nmax ,dtc3x ,ncols) DO i = 1, nmax fac =grav/(100.0_r8 *psb(i)*dtc3x) dtmdt =(gmt(i,3) + hflux (i) * fac /(cp*bps(i)))/gmt(i,2) dqmdt =(gmq(i,3) + etmass(i) * fac) / gmq(i,2) dtm (i)=dtmdt * dtc3x dqm (i)=dqmdt * dtc3x gmt(i,3)=dtmdt gmq(i,3)=dqmdt tm (i)=tm(i)+dtm(i) qm (i)=qm(i)+dqm(i) END DO DO i = 1, nmax ntyp=itype(i) !vcover(i,2)=xcover(ntyp,mon(i),2) d (i)=xd (ntyp,mon(i)) z0x (i)=x0x(ntyp,mon(i)) rdc (i)=xdc(ntyp,mon(i)) rbc (i)=xbc(ntyp,mon(i)) END DO END SUBROUTINE sflxes ! ! ! ! interc :calculation of (1) interception and drainage of rainfall and snow ! (2) specific heat terms fixed for time step ! (3) modifications for 4-th order model may not ! conserve energy; ! modification: non-uniform precipitation convective ppn ! is described by area-intensity relationship :- ! ! f(x)=a*exp(-b*x)+c ! ! throughfall, interception and infiltration ! excess are functional on this relationship ! and proportion of large-scale ppn. SUBROUTINE interc( & roff ,cc ,cg ,satcap,snow ,extk ,tc ,tg ,td , & capac ,w ,tm ,ppc ,ppl ,vcover,itype ,dtc3x , & nmax ,ncols ,zlt2 ) ! ! ! input parameters !----------------------------------------------------------------------- ! ppc.............precipitation rate ( cumulus ) (mm/s) ! ppl.............precipitation rate ( large scale ) (mm/s) ! w(1)............soil wetnessof ground surface ! poros...........porosity ! pie.............pai=3.14159.. ! cw..............liquid water heat capacity (j/m**3) ! clai............heat capacity of foliage ! capac(cg).......canopy/ground cover liquid water capacity(m) ! satcap(cg)......saturation liquid water capacity (m) ! extk(cg, , )..extinction coefficient ! zlt(1)..........canopy leaf and stem area density (m**2/m**3) ! zlt(2)..........ground cover leaf and stem area index (m**2/m**2) ! vcover(cg)......vegetation cover ! tm..............reference temperature (k) ! tc..............canopy temperature (k) ! tg..............ground temperature (k) ! tf..............freezing point (k) ! satco............mean soil hydraulic conductivity in the root zone ! (m/s) ! dtc3x...........time increment dt ! snomel..........heat of melting (j/kg) !----------------------------------------------------------------------- ! in subr. parameters !----------------------------------------------------------------------- ! chisl...........soil conductivity ! difsl...........soil diffusivity !----------------------------------------------------------------------- ! output parameters !----------------------------------------------------------------------- ! roff............runoff ! snow............snow amount ! capac(cg).......canopy/ground cover liquid water capacity(m) ! cc..............heat capacity of the canopy ! cg..............heat capacity of the ground ! w(1)............soil wetnessof ground surface !----------------------------------------------------------------------- ! ncols...........Numero de ponto por faixa de latitude ! ityp............numero das classes de solo 13 ! imon............Numero maximo de meses no ano (12) ! icg.............Parametros da vegetacao (icg=1 topo e icg=2 base) ! iwv.............Compriment de onda iwv=1=visivel, iwv=2=infravermelho ! proximo, iwv=3 infravermelho termal ! idp.............Camadas de solo (1 a 3) ! ibd.............Estado da vegetacao ibd=1 verde / ibd=2 seco ! mon.............Numero do mes do ano (1-12) ! nmax ! zdepth..........Profundidade para as tres camadas de solo ! itype...........Classe de textura do solo ! td..............Temperatura do solo profundo (K) !----------------------------------------------------------------------- INTEGER, INTENT(in ) :: ncols REAL(KIND=r8), INTENT(in ) :: dtc3x INTEGER, INTENT(in ) :: nmax INTEGER, INTENT(in ) :: itype (ncols) REAL(KIND=r8), INTENT(in ) :: vcover(ncols,icg) ! ! the size of working area is ncols*187 ! ! atmospheric parameters as boudary values for sib ! REAL(KIND=r8), INTENT(in ) :: tm (ncols) REAL(KIND=r8), INTENT(in ) :: ppc (ncols) REAL(KIND=r8), INTENT(in ) :: ppl (ncols) ! ! prognostic variables ! REAL(KIND=r8), INTENT(inout) :: tc (ncols) REAL(KIND=r8), INTENT(inout) :: tg (ncols) REAL(KIND=r8), INTENT(in ) :: td (ncols) REAL(KIND=r8), INTENT(inout) :: capac(ncols,2) REAL(KIND=r8), INTENT(inout) :: w (ncols,3) ! ! variables calculated from above and ambient conditions ! REAL(KIND=r8), INTENT(inout ) :: cc (ncols) REAL(KIND=r8), INTENT(inout ) :: cg (ncols) REAL(KIND=r8), INTENT(in ) :: satcap(ncols,icg) REAL(KIND=r8), INTENT(inout) :: snow (ncols,icg) REAL(KIND=r8), INTENT(in ) :: extk (ncols,icg,iwv,ibd) ! ! heat fluxes : c-canopy, g-ground, t-trans, e-evap in j m-2 ! REAL(KIND=r8), INTENT(inout) :: roff (ncols) REAL(KIND=r8) , INTENT(in ) :: zlt2 (ncols,icg) ! REAL(KIND=r8) :: ap (ncols) REAL(KIND=r8) :: cp (ncols) REAL(KIND=r8) :: totalp(ncols) REAL(KIND=r8) :: thru (ncols) REAL(KIND=r8) :: fpi (ncols) REAL(KIND=r8) :: chisl (ncols) REAL(KIND=r8) :: csoil (ncols) REAL(KIND=r8) :: p0 (ncols) REAL(KIND=r8) :: ts (ncols) REAL(KIND=r8) :: specht(ncols) REAL(KIND=r8) :: spwet1(ncols) REAL(KIND=r8) :: zload (ncols) REAL(KIND=r8) :: ccp (ncols) REAL(KIND=r8) :: cct (ncols) REAL(KIND=r8) :: zmelt (ncols) REAL(KIND=r8) :: xsc (ncols) REAL(KIND=r8) :: tti (ncols) REAL(KIND=r8) :: xs (ncols) REAL(KIND=r8) :: arg (ncols) REAL(KIND=r8) :: tex (ncols) REAL(KIND=r8) :: tsd (ncols) REAL(KIND=r8) :: pinf (ncols) REAL(KIND=r8) :: equdep(ncols) REAL(KIND=r8) :: roffo (ncols) REAL(KIND=r8) :: tsf (ncols) REAL(KIND=r8) :: diff (ncols) REAL(KIND=r8) :: freeze(ncols) REAL(KIND=r8) :: ccc (ncols) REAL(KIND=r8) :: spwet (ncols) REAL(KIND=r8) :: snowp (ncols,2) REAL(KIND=r8) :: capacp(ncols,2) REAL(KIND=r8), PARAMETER :: pcoefs(2,2) = RESHAPE ( & (/20.0_r8 ,0.0001_r8 ,0.206e-8_r8,0.9999_r8 /), & (/2,2/)) REAL(KIND=r8), PARAMETER :: bp = 20.0_r8 REAL(KIND=r8), PARAMETER :: difsl = 5.0e-7_r8 REAL(KIND=r8) :: d1x REAL(KIND=r8) :: theta INTEGER :: i INTEGER :: iveg INTEGER :: ntyp ! ! diffusivity of the soil ! -- -- ! | 86400.0 | !d1x =SQRT|--------------|*0.5 ! | (pie*difsl | ! -- -- d1x =SQRT(86400.0_r8 /(pie*difsl))*0.5_r8 ! ap = 0.0_r8 ! CALL reset(ap,ncols*33) DO i = 1, nmax ap(i)=pcoefs(2,1) cp(i)=pcoefs(2,2) totalp(i) = ppc(i) + ppl(i) IF (totalp(i) >= 1.0e-8_r8) THEN ! ! (ppc(i)*pcoefs(1,1) + ppl(i)*pcoefs(2,1)) !ap(i)=--------------------------------------------- ! totalp(i) ! ap(i)=(ppc(i)*pcoefs(1,1) + ppl(i)*pcoefs(2,1))/totalp(i) ! ! (ppc(i)*pcoefs(1,1) + ppl(i)*pcoefs(2,1)) !ap(i)=--------------------------------------------- ! totalp(i) ! cp(i)=(ppc(i)*pcoefs(1,2) + ppl(i)*pcoefs(2,2))/totalp(i) ! END IF roff(i)=0.0_r8 thru(i)=0.0_r8 fpi (i)=0.0_r8 ! ! conductivity of the soil, taking into account porosity ! ntyp = itype(i) ! theta = w(i,1)*poros(ntyp) ! ! ( 9.8e-4 + 1.2e-3 * theta ) !chisl(i) = ----------------------------- ! ( 1.1 - 0.4 * theta ) ! chisl(i) = ( 9.8e-4_r8 + 1.2e-3_r8 *theta ) / ( 1.1_r8 - 0.4_r8 *theta ) ! chisl(i) = chisl(i)*4.186e2_r8 ! ! heat capacity of the soil ! ! -- -- ! | 86400.0 | !d1x =SQRT|--------------|*0.5 ! | (pie*difsl) | ! -- -- csoil(i)=chisl(i)*d1x ! ! precipitation is given in mm ! p0(i)=totalp(i)*0.001_r8 END DO ! ! ! DO iveg = 1, 2 IF (iveg == 1) THEN DO i = 1, nmax ntyp =itype(i) ts (i)=tc (i) ! zlt(icg) = Indice de area foliar "LEAF AREA INDEX" icg=1 topo da copa /icg=2 base da copa ! clai = heat capacity of foliage specht(i)=zlt2(i,1)*clai END DO ELSE DO i = 1, nmax ts (i)=tg (i) specht(i)=csoil(i) ! heat capacity of the soil END DO END IF DO i = 1, nmax IF (iveg == 1 .OR. ts(i) > tf) THEN ! ! capac(1/2) = canopy/ground cover liquid water capacity(m) ! satcap(cg) = saturation liquid water capacity (m) ! xsc(i) = MAX(0.0_r8 , capac(i,iveg) - satcap(i,iveg)) ! capac(i,iveg) = capac(i,iveg) - xsc(i) ! roff(i) = roff(i) + xsc(i) END IF END DO DO i = 1, nmax ntyp=itype(i) ! ! cw = liquid water heat capacity (j/m**3) ! spwet1(i)=MIN(0.05_r8 ,capac(i,iveg))*cw ! capacp(i,iveg)=0.0_r8 ! snowp (i,iveg)=0.0_r8 ! IF (ts(i) > tf) THEN capacp(i,iveg)=capac (i,iveg) ELSE snowp (i,iveg)=capac (i,iveg) END IF ! capac (i,iveg)=capacp(i,iveg) ! snow (i,iveg)=snowp (i,iveg) ! zload (i) =capac (i,iveg) + snow(i,iveg) ! ! -- -- ! | -- -- | ! | | -extk(i,iveg,3,1) * zlt2(i,iveg) || !fpi (i) =| 1.0 - EXP|----------------------------------|| * vcover(i,iveg) ! | | vcover(i,iveg) || ! | -- --| ! -- -- ! fpi (i) =( 1.0_r8 -EXP(-extk(i,iveg,3,1)*zlt2(i,iveg) & /vcover(i,iveg))) *vcover(i,iveg) ! tti(i)=p0(i)*( 1.0_r8 -fpi(i) ) ! IF (iveg.EQ.2) tti(i) = p0(i) END DO ! ! proportional saturated area (xs) and leaf drainage(tex) ! DO i = 1, nmax xs(i)=1.0_r8 IF (p0(i) >= 1.0e-9_r8) THEN ! ! (satcap(i,iveg) - zload(i)) cp(i) !arg(i)=----------------------------- - --------- ! (p0(i)*fpi(i)*ap(i)) ap(i) ! arg(i)=(satcap(i,iveg)-zload(i))/ & (p0(i)*fpi(i)*ap(i)) - cp(i)/ap(i) IF (arg(i) >= 1.0e-9_r8) THEN ! ! -1.0 !xs(i) = ------ * LOG(arg(i)) ! bp ! xs(i)=-1.0_r8/bp * LOG( arg(i) ) xs(i)= MIN ( xs(i) , 1.0_r8 ) xs(i)= MAX ( xs(i) , 0.0_r8 ) END IF END IF END DO DO i = 1, nmax ! -- -- ! | ap(i) | !tex(i)=p0(i)*fpi(i)*|-------*(1.0 - EXP(-bp*xs(i))) + cp(i)*xs(i)|-(satcap(i,iveg) - zload(i))*xs(i) ! | bp | ! -- -- tex(i)=p0(i)*fpi(i)*(ap(i)/bp*(1.0_r8 -EXP(-bp*xs(i)))+cp(i)*xs(i)) & -(satcap(i,iveg)-zload(i))*xs(i) tex(i)= MAX ( tex(i), 0.0_r8 ) ! IF (iveg == 2) tex(i) = 0.0_r8 ! ! total throughfall (thru) and store augmentation ! thru(i)=tti(i)+tex(i) IF (iveg == 2 .AND. tg(i) <= tf) THEN thru(i)=0.0_r8 END IF pinf(i)=p0(i) - thru(i) IF (tm(i) > tf) THEN capac(i,iveg) = capac(i,iveg) + pinf(i) ELSE snow (i,iveg) = snow (i,iveg) + pinf(i) END IF END DO IF (iveg == 2) THEN DO i = 1, nmax ntyp=itype(i) IF (tm(i) <= tf) THEN snow (i,iveg) = snowp(i,iveg) + p0(i) thru (i)=0.0_r8 ELSE ! ! instantaneous overland flow contribution ( roff ) ! equdep(i)=satco(ntyp)*dtc3x xs(i)=1.0_r8 IF (thru(i) >= 1.0e-9_r8) THEN arg(i)=equdep(i)/( thru(i)*ap(i) ) -cp(i)/ap(i) IF (arg(i) >= 1.0e-9_r8) THEN xs(i)=-1.0_r8 /bp* LOG( arg(i) ) xs(i)= MIN ( xs(i), 1.0_r8 ) xs(i)= MAX ( xs(i), 0.0_r8 ) END IF END IF roffo(i)=thru(i)* & (ap(i)/bp*(1.0_r8 -EXP(-bp*xs(i)))+cp(i)*xs(i)) & -equdep(i)*xs(i) roffo(i)= MAX ( roffo(i), 0.0_r8 ) roff (i)= roff (i)+roffo(i) w(i,1)=w(i,1)+(thru(i)-roffo(i))/ & ( poros(ntyp)*zdepth(ntyp,1)) END IF END DO END IF ! ! temperature change due to addition of precipitation ! DO i = 1, nmax diff(i)=(capac (i,iveg)+snow (i,iveg) & -capacp(i,iveg)-snowp(i,iveg))*cw ccp(i)=specht(i)+spwet1(i) cct(i)=specht(i)+spwet1(i)+diff(i) tsd(i)=( ts(i)*ccp(i)+tm(i)*diff(i) )/cct(i) tsf(i)=( ts(i)-tf)*( tm(i)-tf) END DO DO i = 1, nmax IF (tsf(i) < 0.0_r8) THEN IF (tsd(i) <= tf) THEN ! ! freezing of water on canopy or ground ! ccc(i)=capacp(i,iveg)*snomel IF (ts(i) < tm(i)) ccc(i)=diff(i)*snomel/cw tsd (i)=( ts(i)*ccp(i)+tm(i)*diff(i)+ccc(i) )/cct(i) freeze(i)= tf*cct(i)-( ts(i)*ccp(i)+tm(i)*diff(i) ) freeze(i)=( MIN ( ccc(i), freeze(i) ))/snomel IF (tsd(i) > tf) tsd(i) = tf - 0.1_r8 snow (i,iveg)=snow (i,iveg)+freeze(i) capac(i,iveg)=capac(i,iveg)-freeze(i) ELSE ! ! melting of water on canopy or ground ! ccc(i)=- snow(i,iveg)*snomel IF (ts(i) > tm(i)) ccc(i)=- diff(i)*snomel/cw tsd (i)=( ts(i)*ccp(i)+tm(i)*diff(i)+ccc(i) )/cct(i) freeze(i)=( tf*cct(i)-( ts(i)*ccp(i)+tm(i)*diff(i) )) freeze(i)= MAX ( ccc(i), freeze(i) ) /snomel IF (tsd(i) <= tf) tsd(i) = tf - 0.1_r8 snow (i,iveg)=snow (i,iveg)+freeze(i) capac(i,iveg)=capac(i,iveg)-freeze(i) END IF END IF END DO DO i = 1, nmax IF (iveg == 1) THEN tc(i)=tsd(i) ELSE tg(i)=tsd(i) END IF END DO DO i = 1, nmax IF (snow(i,iveg) >= 0.0000001_r8 .OR. iveg == 2) THEN zmelt(i) = 0.0_r8 IF (td(i) > tf) THEN zmelt(i)=capac(i,iveg) ELSE roff (i)=roff(i)+capac(i,iveg) END IF capac(i,iveg)=0.0_r8 ! ! if tg is less than tf water accumulates as snowpack in capac(2) ! ntyp=itype(i) w(i,1)=w(i,1)+zmelt(i)/( poros(ntyp)*zdepth(ntyp,1)) END IF END DO DO i = 1, nmax ! ! these lines exist to eliminate a cray compiler error ! IF (iveg == 2) THEN IF (snow(i,2) > 0.0_r8 .AND. tg(i) > 273.16_r8) THEN END IF IF (capac(i,2) > 0.0_r8 .AND. tg(i) > 273.16_r8) THEN END IF END IF capac(i,iveg)=capac(i,iveg)+snow(i,iveg) snow (i,iveg)=0.0_r8 p0(i)=thru(i) END DO END DO ! ! calculation of canopy and ground heat capacities. ! DO i = 1, nmax ntyp=itype(i) cc(i)=zlt2(i,1)*clai+capac(i,1)*cw spwet(i)=MIN( 0.05_r8 , capac(i,2))*cw cg(i)=csoil(i)+spwet(i) END DO END SUBROUTINE interc ! stomat :performs stomatal resistance. SUBROUTINE stomat( & cosz ,par ,pd ,rst ,extk ,vcover,itype ,nmax ,ncols ,& zlt2 ,green2,chil2 ,rstpar2) ! ! !----------------------------------------------------------------------- ! input parameters !----------------------------------------------------------------------- ! cosz.............cosine of zenith angle ! extk(cg,vnt,bd)..extinction coefficient ! zlt (cg).......leaf area index ! vcover(cg).......fraction of vegetation cover ! green (cg).......fraction of grenn leaves ! chil (cg).......leaf orientation pameter ! rstpar(cg,3).....coefficints related to par influence on ! stomatal resistance ! radn (vnt,bd)..downward sw/lw radiation at the surface ! par (cg).......par( photo-synthetic active radiation) ! pd (cg).......ratio of par(beam) to par(beam+diffuse) !----------------------------------------------------------------------- ! output parameters !----------------------------------------------------------------------- ! rst(cg)..........stomatal reistance !----------------------------------------------------------------------- ! itype............Classe de textura do solo ! nmax ! pie..............Constante Pi=3.1415926e0 ! athird...........Constante athird=1.0e0 /3.0e0 ! ncols............Numero de ponto por faixa de latitude ! ityp.............numero das classes de solo 13 ! imon.............Numero maximo de meses no ano (12) ! icg..............Parametros da vegetacao (icg=1 topo e icg=2 base) ! iwv..............Compriment de onda iwv=1=visivel, iwv=2=infravermelho ! proximo, iwv=3 infravermelho termal ! ibd..............Estado da vegetacao ibd=1 verde / ibd=2 seco !----------------------------------------------------------------------- ! INTEGER, INTENT(in ) :: ncols INTEGER, INTENT(in ) :: nmax REAL(KIND=r8) , INTENT(in ) :: rstpar2(ncols,icg,iwv) INTEGER, INTENT(in ) :: itype (ncols) REAL(KIND=r8), INTENT(in ) :: vcover(ncols,icg) REAL(KIND=r8) , INTENT(in ) :: zlt2 (ncols,icg) REAL(KIND=r8) , INTENT(in ) :: green2 (ncols,icg) REAL(KIND=r8) , INTENT(in ) :: chil2 (ncols,icg) ! ! variables calculated from above and ambient conditions ! REAL(KIND=r8), INTENT(in ) :: par (ncols,icg) REAL(KIND=r8), INTENT(in ) :: pd (ncols,icg) REAL(KIND=r8), INTENT(inout ) :: rst (ncols,icg) REAL(KIND=r8), INTENT(inout) :: extk (ncols,icg,iwv,ibd) ! ! this is for coupling with closure turbulence model ! REAL(KIND=r8), INTENT(in ) :: cosz (ncols) ! REAL(KIND=r8) :: f (ncols) REAL(KIND=r8) :: gamma (ncols) REAL(KIND=r8) :: at (ncols) REAL(KIND=r8) :: power1(ncols) REAL(KIND=r8) :: power2(ncols) REAL(KIND=r8) :: aa (ncols) REAL(KIND=r8) :: bb (ncols) REAL(KIND=r8) :: zat (ncols) REAL(KIND=r8) :: zk (ncols) REAL(KIND=r8) :: ekat (ncols) REAL(KIND=r8) :: rho4 (ncols) REAL(KIND=r8) :: avflux(ncols) ! INTEGER :: i INTEGER :: iveg INTEGER :: irad REAL(KIND=r8) :: fcon REAL(KIND=r8) :: xabc REAL(KIND=r8) :: xabd REAL(KIND=r8) :: ftemp ! ! ! bounding of product of extinction coefficient and local l.a.i. ! DO i = 1, nmax f(i) = MAX( cosz(i), 0.01746_r8 ) END DO ! DO iveg = 1, 2 DO irad = 1, 2 !Estado da vegetacao irad=1 verde / irad=2 seco DO i = 1, nmax ! -- -- ! | 150 | ! extk = MIN | extk, -------------- | ! | zlt2 * vcover | ! -- -- ! extk(i,iveg,1,irad)=min(extk(i,iveg,1,irad),150.0_r8 / & zlt2(i,iveg)*vcover(i,iveg)) END DO END DO END DO ! fcon =0.25_r8*pie + athird iveg=1 ! DO i = 1, nmax IF (itype(i) == 13 .OR. itype(i) == 11) THEN rst(i,iveg) = 1.0e5_r8 ELSE ! ! zlt2 leaf area index ! at = -------- = ------------------------------ ! vcover fraction of vegetation cover ! ! at(i) = zlt2(i,iveg)/vcover(i,iveg) ! IF (par(i,iveg) <= 0.00101_r8) THEN ! ! iwv........Compriment de onda iwv=1=visivel, iwv=2=infravermelho ! proximo, iwv=3 infravermelho termal ! ! rstpar(visivel) ! xabc = ------------------------- + rstpar(infravermelho termal) ! rstpar(infravermelho) ! xabc = rstpar2(i,iveg,1) / rstpar2(i,iveg,2) + rstpar2(i,iveg,3) ! ! 0.5 ! xabd =------ * at(i) ! xabc ! xabd = 0.5_r8 / xabc * at(i) ! ! 1 ! rst = ------ ! xabd ! rst(i,iveg) = 1.0_r8 / xabd ELSE ! ! (rstpar2(visivel) + rstpar2(infravermelho)* rstpar2(infravermelho termal)) ! gamma =--------------------------------------------------------------------------- ! rstpar2(infravermelho termal) ! gamma(i) = (rstpar2(i,iveg,1) + rstpar2(i,iveg,2) & * rstpar2(i,iveg,3))/ rstpar2(i,iveg,3) ! ! single extinction coefficient using weighted ! values of direct and diffus contributions to p.a.r. ! ! ! zlt leaf area index ! at = -------- = ------------------------------ ! vcover fraction of vegetation cover ! ! at(i) = zlt2(i,iveg)/vcover(i,iveg) ! ! zlt 150 !power1 = -------- * -------------- ! vcover zlt2 * vcover ! power1(i) = at(i)*extk(i,iveg,1,1)!Estado da vegetacao irad=1 verde power2(i) = at(i)*extk(i,iveg,1,2)!Estado da vegetacao irad=2 seco ! ! chil2 Leaf orientation parameter ! icg Parameters of vagetation (icg=1 top e icg=2 bottom) ! ! aa(i) = 0.5 - (0.633 + 0.33 * chil2(i,icg)) * chil2(i,icg) ! aa(i) = 0.5_r8 -(0.633_r8 + 0.33_r8 * chil2(i,iveg)) * chil2(i,iveg) ! bb(i) = 0.877_r8 -1.754_r8 *aa(i) ! ! ! LOG(( EXP(-power1(i)) + 1 ) * 0.5 ) * pd(i,iveg) !zat = ------------------------------------------------------ ! extk(i,iveg,1,1) ! ! zat(i) = LOG(( EXP(-power1(i))+1.0_r8 )*0.5_r8 ) * pd(i,iveg) / extk(i,iveg,1,1) ! zat(i) = zat(i) + LOG((EXP(-power2(i)) + 1.0_r8 )*0.5_r8 )*( 1.0_r8 -pd(i,iveg))/extk(i,iveg,1,2) ! zk(i) = 1.0_r8 /zat(i) * LOG(pd(i,iveg) *EXP( power1(i)*zat(i)/at(i) ) & + (1.0_r8 -pd(i,iveg))*EXP( power2(i)*zat(i)/at(i) )) ! ! canopy and ground cover bulk resistances using ! ross-goudriaan leaf function , total par flux (avflux) and ! mean extinction coefficient (zk) ! ftemp = MIN( zk(i)*at(i),20.0_r8 ) ekat (i) = EXP( ftemp ) ! ! -- -- ! | aa(i) | !avflux = par(i,iveg) * (pd(i,iveg)*|------ + bb(i)| + (1 - pd(i,iveg))*(bb(i) * fcon + aa(i)*1.5)) ! | f(i) | ! -- -- ! avflux(i) = par(i,iveg)*( pd(i,iveg)*( aa(i)/f(i)+bb(i)) & + ( 1.0_r8 -pd(i,iveg))*( bb(i)*fcon+aa(i)*1.5_r8 )) ! ! gamma(i) !rho4(i) = ---------------- ! avflux(i) ! rho4(i) = gamma(i)/avflux(i) ! ! rstpar2(i,iveg,2) !rst(i,iveg) = ---------------------------------------------- ! -- -- ! | (rho4(i) * ekat(i) + 1.0) | ! gamma(i)*LOG|----------------------------| ! | (rho4(i) + 1.0 ) | ! -- -- ! rst(i,iveg) = rstpar2(i,iveg,2) / gamma(i)*LOG((rho4(i)*ekat(i)+1.0_r8 )/(rho4(i)+1.0_r8 )) ! ! ! ! ! rst(i,iveg)=rst(i,iveg) - LOG((rho4(i)+1.0_r8 /ekat(i))/(rho4(i)+1.0_r8 )) ! ! rst(i,iveg) ! rst =---------------------------- ! zk(i) * rstpar2(i,iveg,3) ! ! rst(i,iveg)=rst(i,iveg)/(zk(i)*rstpar2(i,iveg,3)) ! ! 1 ! rst = -------------------------------- ! rst(i,iveg) * green2(i,iveg) ! rst(i,iveg)=1.0_r8 /( rst(i,iveg)*green2(i,iveg)) END IF END IF END DO ! DO i = 1, nmax rst(i,2) = 1.0e5_r8 END DO ! END SUBROUTINE stomat ! raduse :performs the absorption of radiation by surface. SUBROUTINE raduse(radt ,par ,pd ,radfac,closs ,gloss ,thermk,p1f , & p2f ,radn ,vcover,nmax ,ncols ) ! !----------------------------------------------------------------------- ! input parameters !----------------------------------------------------------------------- ! tf...............freezing temperature ! tg...............ground temperature ! polar............ ! radsav...........passesd from subr.radalb ! radfac(cg,vn,bd).fractions of downward solar radiation at surface ! passed from subr.radalb ! radn(vnt,bd).....downward sw/lw radiation at the surface ! vcover(cg).......vegetation cover !----------------------------------------------------------------------- ! output parameters !----------------------------------------------------------------------- ! radt(cg).........net heat received by canopy/ground vegetation ! by radiation & conduction ! par(cg)..........par incident on canopy ! pd(cg)...........ratio of par beam to total par !----------------------------------------------------------------------- ! INTEGER, INTENT(in ) :: ncols INTEGER, INTENT(in ) :: nmax REAL(KIND=r8), INTENT(in ) :: vcover(ncols,icg) ! ! the size of working area is ncols*187 ! atmospheric parameters as boudary values for sib ! REAL(KIND=r8), INTENT(in ) :: radn (ncols,3,2) ! ! variables calculated from above and ambient conditions ! REAL(KIND=r8), INTENT(inout ) :: radt (ncols,icg) REAL(KIND=r8), INTENT(inout ) :: par (ncols,icg) REAL(KIND=r8), INTENT(inout ) :: pd (ncols,icg) REAL(KIND=r8), INTENT(in ) :: radfac(ncols,icg,iwv,ibd) REAL(KIND=r8), INTENT(in ) :: closs (ncols) REAL(KIND=r8), INTENT(in ) :: gloss (ncols) REAL(KIND=r8), INTENT(in ) :: thermk(ncols) REAL(KIND=r8), INTENT(in ) :: p1f (ncols) REAL(KIND=r8), INTENT(in ) :: p2f (ncols) REAL(KIND=r8) :: p1 (ncols) REAL(KIND=r8) :: p2 (ncols) INTEGER :: i INTEGER :: iveg INTEGER :: iwave INTEGER :: irad DO i = 1, nmax radt(i,1)=0.0_r8 radt(i,2)=0.0_r8 END DO ! ! radn(1,1)=!Downward Surface shortwave fluxe visible beam (cloudy) ! radn(1,2)=!Downward Surface shortwave fluxe visible diffuse (cloudy) ! radn(2,1)=!Downward Surface shortwave fluxe Near-IR beam (cloudy) ! radn(2,2)=!Downward Surface shortwave fluxe Near-IR diffuse (cloudy) ! radfac(cg,vn,bd).fractions of downward solar radiation at surface ! passed from subr.radalb ! ! summation of radiation fractions for canopy and ground ! DO iveg = 1, 2 DO iwave = 1, 2 DO irad = 1, 2 DO i = 1, nmax radt(i,iveg)=radt(i,iveg)+radfac(i,iveg,iwave,irad)*radn(i,iwave,irad) END DO END DO END DO END DO ! ! total long wave ( and polar ice conduction ) adjustments to ! canopy and ground net radiation terms ! thermk = canopy emissivity DO i = 1, nmax radt(i,1) = radt(i,1) + radn(i,3,2) * vcover(i,1)*(1.0_r8 -thermk(i)) - closs(i) radt(i,2) = radt(i,2) + radn(i,3,2) * (1.0_r8 - vcover(i,1)*(1.0_r8 -thermk(i))) - gloss(i) par(i,1) = radn(i,1,1) + radn(i,1,2) + 0.001_r8! total par incident on canopy pd (i,1) = (radn(i,1,1) + 0.001_r8 ) / par(i,1)! ratio of par beam on topo of the canopy to total par p1(i) = p1f(i)*radn(i,1,1) + 0.001_r8 ! net par beam on topo of the canopy p2(i) = p2f(i)*radn(i,1,2) ! net par beam on base of the canopy par(i,2) = p1(i)+p2(i)! net par incident on canopy and ground IF (par(i,1) <= 0.000001_r8) par(i,1) = 0.000001_r8 IF (par(i,2) <= 0.000001_r8) par(i,2) = 0.000001_r8 pd (i,2) = p1(i)/par(i,2) !ratio of net par beam to net par incident on canopy and ground END DO END SUBROUTINE raduse ! root :performs soil moisture potentials in root zone of each ! vegetation layer and summed soil+root resistance. SUBROUTINE root(phroot,phsoil,w ,itype ,nmax , ncols ) ! ! input parameters !----------------------------------------------------------------------- ! w(1).............wetness of surface store ! w(2).............wetness of root zone ! w(3).............wetness of recharge zone ! phsat............soil moisture potential at saturation (m) ! bee..............empirical constant ! zdepth(3)........depth of the i-th soil layer (m) ! rootd (cg).......rooting depth (m) ! satco............mean soil hydraulic conductivity in the root zone ! (m/s) ! rootl(cg)........root density (m/m**3) ! rootca(cg).......root cross section (m**2) ! rdres(cg)........resistance per unit root length (s/m) ! rplant(cg).......area averaged resistance imposed by the plant ! vascular system (s) !----------------------------------------------------------------------- ! output parameters !----------------------------------------------------------------------- ! vroot............root volume density (m**3/m**3) !----------------------------------------------------------------------- ! output parameters !----------------------------------------------------------------------- ! phsoil(3)........soil moisture potential of the i-th soil layer ! (m) ! rootr(cg)........root resistance (s) !----------------------------------------------------------------------- ! ! imax.............Numero de ponto por faixa de latitude ! ityp.............numero das classes de solo 13 ! icg..............Parametros da vegetacao (icg=1 topo e icg=2 base) ! idp..............Camadas de solo (1 a 3) ! nmax............. ! itype............Classe de textura do solo ! phroot...........Soil moisture potentials in root zone of each ! vegetation layer and summed soil+root resistance. ! INTEGER, INTENT(in ) :: ncols INTEGER, INTENT(in ) :: nmax INTEGER, INTENT(in ) :: itype (ncols) ! ! prognostic variables ! REAL(KIND=r8), INTENT(in ) :: w (ncols,3) ! ! variables calculated from above and ambient conditions ! REAL(KIND=r8), INTENT(inout ) :: phroot(ncols,icg) REAL(KIND=r8), INTENT(inout ) :: phsoil(ncols,idp) REAL(KIND=r8) :: www (ncols,3) INTEGER :: i INTEGER :: n DO i = 1, 3 DO n = 1, nmax ! 0 !w = ----- ! 0s ! www (n,i) = MAX(0.10_r8 ,w(n,i)) ! -- -- ! | 0 | ! phsoil(n,i) = phsat * EXP |-b*LOG(-----) | ! | 0s | ! -- -- phsoil(n,i) = phsat(itype(n)) * EXP(-bee( itype(n))*LOG(www(n,i))) ! END DO END DO ! ! Soil moisture potentials in root zone of each ! vegetation layer and summed soil+root resistance. ! DO n = 1, nmax phroot(n,1) = phsoil(n,1) - 0.01_r8 DO i = 2, 3 phroot(n,1) = MAX( phroot(n,1), phsoil(n,i)) END DO phroot(n,2) = phroot(n,1) END DO END SUBROUTINE root ! pbl :performs planetary boundary layer parameterization. SUBROUTINE pbl(jstneu, hgdtg , hgdtc , hgdtm , hcdtg , hcdtc , hcdtm , & egdtg , egdtc , egdqm , ecdtg , ecdtc , ecdqm , deadtg, & deadtc, deadqm,icheck , ect , eci , egt , egi , & egs , ec , eg , hc , hg , ecidif, egidif, & ecmass, egmass, etmass, hflux , chf , shf , roff , & bps , psb , dzm , em , gmt , gmq , cu , & cuni , ctni , ustar , cosz , rhoair, psy , rcp , & wc , wg , fc , fg , hr , vcover, z0x , & d , rdc , rbc , z0 , qm , tm , um , & vm , psur , ppc , ppl , radn , ra , rb , & rd , rc , rg , tcta , tgta , ta , ea , & etc , etg , btc , btg , u2 , radt , par , & pd , rst , rsoil , phroot, hrr , phsoil, cc , & cg , satcap, snow , dtc , dtg , dtm , dqm , & stm , extk , radfac, closs , gloss , thermk, p1f , & p2f , tc , tg , td , capac , w , itype , & dtc3x , mon , nmax , ncols ,zlt2 ,green2,chil2,rstpar2,& topt2,tll2 ,tu2 , defac2,ph12 ,ph22 ,ct ) ! ! jstneu......The first call to vntlat just gets the neutral values of ustar ! and ventmf para jstneu=.TRUE.. ! hgdtg.......n.b. fluxes expressed in joules m-2 ! hgdtc.......n.b. fluxes expressed in joules m-2 ! hgdtm.......n.b. fluxes expressed in joules m-2 ! hcdtg.......n.b. fluxes expressed in joules m-2 ! hcdtc.......n.b. fluxes expressed in joules m-2 ! hcdtm.......n.b. fluxes expressed in joules m-2 ! egdtg.......partial derivative calculation for latent heat ! egdtc.......partial derivative calculation for latent heat ! egdqm.......partial derivative calculation for latent heat ! ecdtg.......partial derivative calculation for latent heat ! ecdtc.......partial derivative calculation for latent heat ! ecdqm.......partial derivative calculation for latent heat ! deadtg ! deadtc ! deadqm ! icheck......this version assumes dew-free conditions "icheck=1" to ! estimate ea for buoyancy term in vntmf or ra. ! ect.........Transpiracao no topo da copa (J/m*m) ! eci.........Evaporacao da agua interceptada no topo da copa (J/m*m) ! egt.........Transpiracao na base da copa (J/m*m) ! egi.........Evaporacao da neve (J/m*m) ! egs.........Evaporacao do solo arido (J/m*m) ! ec..........Soma da Transpiracao e Evaporacao da agua interceptada pelo ! topo da copa ec (i)=eci(i)+ect(i) ! eg..........Soma da transpiracao na base da copa + Evaporacao do solo arido ! + Evaporacao da neve " eg (i)=egt(i)+egs(i)+egi(i)" ! hc..........total sensible heat lost of top from the veggies. ! hg..........total sensible heat lost of base from the veggies. ! ecidif......check if interception loss term has exceeded canopy storage ! ecidif(i)=MAX(0.0 , eci(i)-capac(i,1)*hlat3 ) ! egidif......check if interception loss term has exceeded canopy storage ! ecidif(i)=MAX(0.0 , egi(i)-capac(i,1)*hlat3 ) ! ecmass......Mass of water lost of top from the veggies. ! egmass......Mass of water lost of base from the veggies. ! etmass......total mass of water lost from the veggies. ! hflux.......total sensible heat lost from the veggies. ! chf.........heat fluxes into the canopy in w/m**2 ! shf.........heat fluxes into the ground, in w/m**2 ! roff........runoff ! pie.........Constante Pi=3.1415926e0 ! stefan......Constante de Stefan Boltzmann ! cpair.......specific heat of air (j/kg/k) ! hlat........heat of evaporation of water (j/kg) ! grav........gravity constant (m/s**2) ! snomel......heat of melting (j m-1) ! tf..........Temperatura de congelamento (K) ! clai........heat capacity of foliage ! cw..........liquid water heat capacity (j/m**3) ! gasr........Constant of dry air (j/kg/k) ! epsfac......Constante 0.622 Razao entre as massas moleculares do vapor ! de agua e do ar seco ! athird......Constante athird=1.0e0 /3.0e0 ! bps ! psb ! dzm.........Altura media de referencia para o vento para o calculo ! da estabilidade do escoamento ! em..........Pressao de vapor da agua ! gmt(i,k,3)..virtual temperature tendency due to vertical diffusion ! gmq.........specific humidity of reference (fourier) ! cu..........Friction transfer coefficients. ! cuni........neutral friction transfer coefficients. ! ctni........neutral heat transfer coefficients. ! ustar.......surface friction velocity (m/s) ! cosz........cosine of zenith angle ! rhoair......Desnsidade do ar ! psy ........(cp/(hl*epsfac))*psur(i) ! rcp.........densidade do ar vezes o calor especifico do ar ! wc..........Minimo entre 1 e a razao entre a agua interceptada pelo ! indice de area foliar no topo da copa ! wg..........Minimo entre 1 e a razao entre a agua interceptada pelo ! indice de area foliar na base da copa ! fc..........Condicao de oravalho 0 ou 1 na topo da copa ! fg..........Condicao de oravalho 0 ou 1 na base da copa ! hr..........rel. humidity in top layer ! vcover(iv)..Fracao de cobertura de vegetacao iv=1 Top ! vcover(iv)..Fracao de cobertura de vegetacao iv=2 Botto ! z0x.........roughness length ! d...........Displacement height ! rdc.........Constant related to aerodynamic resistance ! between ground and canopy air space ! rbc.........Constant related to bulk boundary layer resistance ! z0..........Roughness length ! qm..........reference specific humidity (fourier) ! tm .........reference temperature (fourier) (k) ! um..........Razao entre zonal pseudo-wind (fourier) e seno da ! colatitude ! vm..........Razao entre meridional pseudo-wind (fourier) e seno da ! colatitude ! psur........surface pressure in mb ! ppc.........precipitation rate ( cumulus ) (mm/s) ! ppl.........precipitation rate ( large scale ) (mm/s) ! radn........downward sw/lw radiation at the surface ! ra..........Resistencia Aerodinamica (s/m) ! rb..........bulk boundary layer resistance (s/m) ! rd..........aerodynamic resistance between ground (s/m) ! and canopy air space ! rc..........Resistencia do topo da copa ! rg......... Resistencia da base da copa ! tcta........Diferenca entre tc-ta (k) ! tgta........Diferenca entre tg-ta (k) ! ta..........Temperatura no nivel de fonte de calor do dossel (K) ! ea..........Pressure of vapor ! etc.........Pressure of vapor at top of the copa ! etg.........Pressao de vapor no base da copa ! btc.........btc(i)=EXP(30.25353 -5418.0 /tc(i))/(tc(i)*tc(i)). ! btg.........btg(i)=EXP(30.25353 -5418.0 /tg(i))/(tg(i)*tg(i)) ! u2..........wind speed at top of canopy (m/s) ! radt........net heat received by canopy/ground vegetation ! par.........par incident on canopy ! pd..........ratio of par beam to total par ! rst ........Resisttencia Estomatica "Stomatal resistence" (s/m) ! rsoil ......Resistencia do solo (s/m) ! phroot......Soil moisture potentials in root zone of each ! vegetation layer and summed soil+root resistance. ! hrr.........rel. humidity in top layer ! phsoil......soil moisture potential of the i-th soil layer ! cc..........heat capacity of the canopy ! cg..........heat capacity of the ground ! satcap......saturation liquid water capacity (m) ! snow........snow amount ! dtc.........dtc(i)=pblsib(i,2,5)*dtc3x ! dtg.........dtg(i)=pblsib(i,1,5)*dtc3x ! dtm.........dtm(i)=pblsib(i,3,5)*dtc3x ! dqm ........dqm(i)=pblsib(i,4,5)*dtc3x ! stm ........Variavel utilizada mo cal. da Resisttencia ! extk........extinction coefficient ! radfac......fractions of downward solar radiation at surface ! passed from subr.radalb ! closs.......radiation loss from canopy ! gloss.......radiation loss from ground ! thermk......canopy emissivity ! p1f ! p2f ! tc..........Temperatura da copa "dossel"(K) ! tg..........Temperatura da superficie do solo (K) ! td..........Temperatura do solo profundo (K) ! capac(iv)...Agua interceptada iv=1 no dossel "water store capacity ! of leaves"(m) ! capac(iv)...Agua interceptada iv=2 na cobertura do solo (m) ! w(id).......Grau de saturacao de umidade do solo id=1 na camada superficial ! w(id).......Grau de saturacao de umidade do solo id=2 na camada de raizes ! w(id).......Grau de saturacao de umidade do solo id=3 na camada de drenagem ! itype ......Classe de textura do solo ! rstpar(cg,3).coefficints related to par influence on ! stomatal resistance ! chil........leaf orientation pameter ! topt........Temperatura ideal de funcionamento estomatico ! tll.........Temperatura minima de funcionamento estomatico ! tu..........Temperatura maxima de funcionamento estomatico ! defac.......Parametro de deficit de pressao de vapor d'agua ! ph1.........Coeficiente para o efeito da agua no solo ! ph2.........Potencial de agua no solo para ponto de Wilting ! rootd.......Profundidade das raizes ! bee.........Expoente da curva de retencao "expoente para o solo umido" ! phsat.......Tensao do solo saturado " Potencial de agua no solo saturado" ! satco.......mean soil hydraulic conductivity in the root zone ! poros.......porosity ! zdepth......Profundidade para as tres camadas de solo ! green.......fraction of grenn leaves ! xcover(iv)..Fracao de cobertura de vegetacao iv=2 Bottom ! zlt(icg)....Indice de area foliar "LEAF AREA INDEX" icg=1 topo da copa ! zlt(icg)....Indice de area foliar "LEAF AREA INDEX" icg=2 base da copa ! x0x.........Comprimento de rugosidade ! xd..........Deslocamento do plano zero ! z2..........Altura do topo do dossel ! xdc.........Constant related to aerodynamic resistance ! between ground and canopy air space ! xbc.........Constant related to bulk boundary layer resistance ! dtc3x.......time increment dt ! mon.........Number of month at year (1-12) ! nmax ! ityp........numero das classes de solo 13 ! imon........Numero maximo de meses no ano (12) ! icg.........Parametros da vegetacao (icg=1 topo e icg=2 base) ! iwv.........Compriment de onda iwv=1=visivel, iwv=2=infravermelho ! proximo, iwv=3 infravermelho termal ! idp.........Camadas de solo (1 a 3) ! ibd.........Estado da vegetacao ibd=1 verde / ibd=2 seco ! ncols.......Numero de ponto por faixa de latitude ! ! INTEGER, INTENT(in ) :: ncols REAL(KIND=r8) , INTENT(in ) :: dtc3x INTEGER, INTENT(in ) :: mon(ncols) INTEGER, INTENT(in ) :: nmax INTEGER, INTENT(in ) :: itype(ncols) ! ! prognostic variables ! REAL(KIND=r8), INTENT(inout) :: tc (ncols) REAL(KIND=r8), INTENT(inout) :: tg (ncols) REAL(KIND=r8), INTENT(inout) :: td (ncols) REAL(KIND=r8), INTENT(inout) :: capac(ncols,2) REAL(KIND=r8), INTENT(inout) :: w (ncols,3) ! ! variables calculated from above and ambient conditions ! REAL(KIND=r8), INTENT(inout) :: ra (ncols) REAL(KIND=r8), INTENT(inout) :: rb (ncols) REAL(KIND=r8), INTENT(inout) :: rd (ncols) REAL(KIND=r8), INTENT(inout) :: rc (ncols) REAL(KIND=r8), INTENT(inout) :: rg (ncols) REAL(KIND=r8), INTENT(inout) :: tcta (ncols) REAL(KIND=r8), INTENT(inout) :: tgta (ncols) REAL(KIND=r8), INTENT(inout) :: ta (ncols) REAL(KIND=r8), INTENT(inout) :: ea (ncols) REAL(KIND=r8), INTENT(inout) :: etc (ncols) REAL(KIND=r8), INTENT(inout) :: etg (ncols) REAL(KIND=r8), INTENT(inout) :: btc (ncols) REAL(KIND=r8), INTENT(inout) :: btg (ncols) REAL(KIND=r8), INTENT(inout) :: u2 (ncols) REAL(KIND=r8), INTENT(inout) :: radt (ncols,icg) REAL(KIND=r8), INTENT(inout) :: par (ncols,icg) REAL(KIND=r8), INTENT(inout) :: pd (ncols,icg) REAL(KIND=r8), INTENT(inout) :: rst (ncols,icg) REAL(KIND=r8), INTENT(inout) :: rsoil (ncols) REAL(KIND=r8), INTENT(inout) :: phroot(ncols,icg) REAL(KIND=r8), INTENT(inout) :: hrr (ncols) REAL(KIND=r8), INTENT(inout) :: phsoil(ncols,idp) REAL(KIND=r8), INTENT(inout) :: cc (ncols) REAL(KIND=r8), INTENT(inout) :: cg (ncols) REAL(KIND=r8), INTENT(inout) :: satcap(ncols,icg) REAL(KIND=r8), INTENT(inout) :: snow (ncols,icg) REAL(KIND=r8), INTENT(inout) :: dtc (ncols) REAL(KIND=r8), INTENT(inout) :: dtg (ncols) REAL(KIND=r8), INTENT(inout) :: dtm (ncols) REAL(KIND=r8), INTENT(inout) :: dqm (ncols) REAL(KIND=r8), INTENT(inout) :: stm (ncols,icg) REAL(KIND=r8), INTENT(inout) :: extk (ncols,icg,iwv,ibd) REAL(KIND=r8), INTENT(in ) :: radfac(ncols,icg,iwv,ibd) REAL(KIND=r8), INTENT(in ) :: closs (ncols) REAL(KIND=r8), INTENT(in ) :: gloss (ncols) REAL(KIND=r8), INTENT(inout) :: thermk(ncols) REAL(KIND=r8), INTENT(in ) :: p1f (ncols) REAL(KIND=r8), INTENT(in ) :: p2f (ncols) ! ! the size of working area is ncols*187 ! atmospheric parameters as boudary values for sib ! REAL(KIND=r8), INTENT(inout) :: qm (ncols) REAL(KIND=r8), INTENT(inout) :: tm (ncols) REAL(KIND=r8), INTENT(in ) :: um (ncols) REAL(KIND=r8), INTENT(in ) :: vm (ncols) REAL(KIND=r8), INTENT(inout) :: psur(ncols) REAL(KIND=r8), INTENT(in ) :: ppc (ncols) REAL(KIND=r8), INTENT(in ) :: ppl (ncols) REAL(KIND=r8), INTENT(in ) :: radn(ncols,3,2) REAL(KIND=r8) , INTENT(in ) :: zlt2 (ncols,icg) REAL(KIND=r8) , INTENT(in ) :: green2 (ncols,icg) REAL(KIND=r8) , INTENT(in ) :: chil2 (ncols,icg) REAL(KIND=r8) , INTENT(in ) :: rstpar2(ncols,icg,iwv) REAL(KIND=r8), INTENT(inout) :: vcover (ncols,icg) REAL(KIND=r8), INTENT(inout) :: z0x(ncols) REAL(KIND=r8), INTENT(inout) :: d (ncols) REAL(KIND=r8), INTENT(inout) :: rdc(ncols) REAL(KIND=r8), INTENT(inout) :: rbc(ncols) REAL(KIND=r8), INTENT(inout) :: z0 (ncols) REAL(KIND=r8) , INTENT(in ) :: topt2 (ncols,icg) REAL(KIND=r8) , INTENT(in ) :: tll2 (ncols,icg) REAL(KIND=r8) , INTENT(in ) :: tu2 (ncols,icg) REAL(KIND=r8) , INTENT(in ) :: defac2 (ncols,icg) REAL(KIND=r8) , INTENT(in ) :: ph12 (ncols,icg) REAL(KIND=r8) , INTENT(in ) :: ph22 (ncols,icg) ! ! this is for coupling with closure turbulence model ! REAL(KIND=r8), INTENT(in ) :: bps (ncols) REAL(KIND=r8), INTENT(in ) :: psb (ncols) REAL(KIND=r8), INTENT(in ) :: dzm (ncols) REAL(KIND=r8), INTENT(in ) :: em (ncols) REAL(KIND=r8), INTENT(inout) :: gmt (ncols,3) REAL(KIND=r8), INTENT(inout) :: gmq (ncols,3) REAL(KIND=r8), INTENT(inout) :: cu (ncols) REAL(KIND=r8), INTENT(inout) :: cuni (ncols) REAL(KIND=r8), INTENT(inout) :: ctni (ncols) REAL(KIND=r8), INTENT(inout) :: ustar (ncols) REAL(KIND=r8), INTENT(in ) :: cosz (ncols) REAL(KIND=r8), INTENT(in ) :: rhoair(ncols) REAL(KIND=r8), INTENT(in ) :: psy (ncols) REAL(KIND=r8), INTENT(inout ) :: rcp (ncols) REAL(KIND=r8), INTENT(inout) :: wc (ncols) REAL(KIND=r8), INTENT(inout) :: wg (ncols) REAL(KIND=r8), INTENT(inout) :: fc (ncols) REAL(KIND=r8), INTENT(inout) :: fg (ncols) REAL(KIND=r8), INTENT(inout) :: hr (ncols) REAL(KIND=r8), INTENT(inout) :: ect (ncols) REAL(KIND=r8), INTENT(inout) :: eci (ncols) REAL(KIND=r8), INTENT(inout) :: egt (ncols) REAL(KIND=r8), INTENT(inout) :: egi (ncols) REAL(KIND=r8), INTENT(inout) :: egs (ncols) REAL(KIND=r8), INTENT(inout ) :: ec (ncols) REAL(KIND=r8), INTENT(inout ) :: eg (ncols) REAL(KIND=r8), INTENT(inout ) :: hc (ncols) REAL(KIND=r8), INTENT(inout ) :: hg (ncols) REAL(KIND=r8), INTENT(inout ) :: ecidif(ncols) REAL(KIND=r8), INTENT(inout ) :: egidif(ncols) REAL(KIND=r8), INTENT(inout ) :: ecmass(ncols) REAL(KIND=r8), INTENT(inout ) :: egmass(ncols) REAL(KIND=r8), INTENT(inout ) :: etmass(ncols) REAL(KIND=r8), INTENT(inout ) :: hflux (ncols) REAL(KIND=r8), INTENT(inout ) :: chf (ncols) REAL(KIND=r8), INTENT(inout ) :: shf (ncols) REAL(KIND=r8), INTENT(inout) :: roff (ncols) INTEGER, INTENT(inout ) :: icheck(ncols) ! ! derivatives ! REAL(KIND=r8), INTENT(inout ) :: hgdtg (ncols) REAL(KIND=r8), INTENT(inout ) :: hgdtc (ncols) REAL(KIND=r8), INTENT(inout ) :: hgdtm (ncols) REAL(KIND=r8), INTENT(inout ) :: hcdtg (ncols) REAL(KIND=r8), INTENT(inout ) :: hcdtc (ncols) REAL(KIND=r8), INTENT(inout ) :: hcdtm (ncols) REAL(KIND=r8), INTENT(inout ) :: egdtg (ncols) REAL(KIND=r8), INTENT(inout ) :: egdtc (ncols) REAL(KIND=r8), INTENT(inout ) :: egdqm (ncols) REAL(KIND=r8), INTENT(inout ) :: ecdtg (ncols) REAL(KIND=r8), INTENT(inout ) :: ecdtc (ncols) REAL(KIND=r8), INTENT(inout ) :: ecdqm (ncols) REAL(KIND=r8), INTENT(inout ) :: deadtg(ncols) REAL(KIND=r8), INTENT(inout ) :: deadtc(ncols) REAL(KIND=r8), INTENT(inout ) :: deadqm(ncols) LOGICAL, INTENT(inout ) :: jstneu REAL(KIND=r8), INTENT(inout ) :: ct(ncols) ! CALL root(phroot,phsoil,w ,itype ,nmax ,ncols ) CALL raduse(radt ,par ,pd ,radfac,closs ,gloss ,thermk,p1f , & p2f ,radn ,vcover,nmax ,ncols ) CALL stomat(cosz ,par ,pd ,rst ,extk ,vcover,itype , & nmax ,ncols ,zlt2 ,green2,chil2 ,rstpar2) CALL interc( & roff ,cc ,cg ,satcap,snow ,extk ,tc ,tg ,td , & capac ,w ,tm ,ppc ,ppl ,vcover,itype ,dtc3x , & nmax ,ncols ,zlt2 ) ! ! surface flux ! CALL sflxes( & hgdtg ,hgdtc ,hgdtm ,hcdtg ,hcdtc ,hcdtm ,egdtg ,egdtc ,egdqm , & ecdtg ,ecdtc ,ecdqm ,deadtg,deadtc,deadqm,icheck,bps ,psb , & dzm ,em ,gmt ,gmq ,cu ,cuni ,ctni ,ustar ,rhoair, & psy ,rcp ,wc ,wg ,fc ,fg ,hr ,ect ,eci , & egt ,egi ,egs ,ec ,eg ,hc ,hg ,ecidif,egidif, & ecmass,egmass,etmass,hflux ,chf ,shf ,ra ,rb ,rd , & rc ,rg ,tcta ,tgta ,ta ,ea ,etc ,etg ,btc , & btg ,u2 ,radt ,rst ,rsoil ,hrr ,phsoil,cc ,cg , & satcap,dtc ,dtg ,dtm ,dqm ,stm ,thermk,tc ,tg , & td ,capac ,w ,qm ,tm ,um ,vm ,psur ,vcover, & z0x ,d ,rdc ,rbc ,z0 ,itype ,dtc3x ,mon ,nmax , & jstneu,ncols ,zlt2 ,topt2 ,tll2 ,tu2 , defac2,ph12 ,ph22 , & ct) END SUBROUTINE pbl SUBROUTINE snowm(& chf ,shf ,fluxef,roff ,cc ,cg ,snow ,dtc ,dtg , & tc ,tg ,td ,capac ,w ,itype ,dtc3x ,nmax ,ncols ) ! ! snowm :calculates snowmelt and modification of temperatures; ! this version deals with refreezing of water; ! version modified to use force-restore heat fluxes. ! !----------------------------------------------------------------------- ! chf.........Fluxo de calor na copa (J/m*m) ! shf.........Fluxo de calor no solo (J/m*m) ! fluxef......modified to use force-restore heat fluxes ! fluxef(i) = shf(i) - cg(i)*dtg(i)*dtc3xi " Garrat pg. 227" ! roff........runoff (escoamente superficial e drenagem)(m) ! cc..........heat capacity of the canopy ! cg..........heat capacity of the ground ! snow........snow amount ! dtc ........dtc(i)=pblsib(i,2,5)*dtc3x ! dtg ........dtg(i)=pblsib(i,1,5)*dtc3x ! tc..........Temperatura da copa "dossel"(K) ! tg..........Temperatura da superficie do solo (K) ! td..........Temperatura do solo profundo (K) ! capac(iv)...Agua interceptada iv=1 no dossel (m) ! capac(iv)...Agua interceptada iv=2 na cobertura do solo (m) ! w(id).......Grau de saturacao de umidade do solo id=1 na camada superficial ! w(id).......Grau de saturacao de umidade do solo id=2 na camada de raizes ! w(id).......Grau de saturacao de umidade do solo id=3 na camada de drenagem ! poros.......Porosidade do solo (m"3/m"3) ! zdepth(id)..Profundidade das camadas de solo id=1 superficial ! zdepth(id)..Profundidade das camadas de solo id=2 camada de raizes ! zdepth(id)..Profundidade das camadas de solo id=3 camada de drenagem ! itype.......Classe de textura do solo ! ncols.......Numero de ponto por faixa de latitude ! ityp........13 ! icg.........Parametros da vegetacao (icg=1 topo e icg=2 base) ! idp.........Camadas de solo (1 a 3) ! snomel......Calor latente de fusao(J/kg) ! tf..........Temperatura de congelamento (K) ! dtc3x.......time increment dt ! nmax........ !----------------------------------------------------------------------- INTEGER, INTENT(in ) :: ncols REAL(KIND=r8), INTENT(in ) :: dtc3x INTEGER, INTENT(in ) :: nmax INTEGER, INTENT(in ) :: itype (ncols) ! ! prognostic variables ! REAL(KIND=r8), INTENT(inout) :: tc (ncols) REAL(KIND=r8), INTENT(inout) :: tg (ncols) REAL(KIND=r8), INTENT(in ) :: td (ncols) REAL(KIND=r8), INTENT(inout) :: capac(ncols,2) REAL(KIND=r8), INTENT(inout) :: w (ncols,3) ! ! variables calculated from above and ambient conditions ! REAL(KIND=r8), INTENT(in ) :: cc (ncols) REAL(KIND=r8), INTENT(in ) :: cg (ncols) REAL(KIND=r8), INTENT(inout) :: snow (ncols,icg) REAL(KIND=r8), INTENT(in ) :: dtc (ncols) REAL(KIND=r8), INTENT(in ) :: dtg (ncols) ! ! heat fluxes : c-canopy, g-ground, t-trans, e-evap in j m-2 ! REAL(KIND=r8), INTENT(in ) :: chf (ncols) REAL(KIND=r8), INTENT(in ) :: shf (ncols) REAL(KIND=r8), INTENT(inout ) :: fluxef(ncols) REAL(KIND=r8), INTENT(inout) :: roff (ncols) REAL(KIND=r8) :: cct (ncols) REAL(KIND=r8) :: ts (ncols) REAL(KIND=r8) :: dts (ncols) REAL(KIND=r8) :: flux (ncols) REAL(KIND=r8) :: tta (ncols) REAL(KIND=r8) :: ttb (ncols) REAL(KIND=r8) :: dtf (ncols) REAL(KIND=r8) :: work (ncols) REAL(KIND=r8) :: hf (ncols) REAL(KIND=r8) :: fcap (ncols) REAL(KIND=r8) :: spwet (ncols) REAL(KIND=r8) :: dtf2 (ncols) REAL(KIND=r8) :: tn (ncols) REAL(KIND=r8) :: change(ncols) REAL(KIND=r8) :: dtime1(ncols) REAL(KIND=r8) :: dtime2(ncols) INTEGER :: i INTEGER :: iveg INTEGER :: ntyp REAL(KIND=r8) :: dtc3xi cct=0.0_r8 dtc3xi=1.0_r8 /dtc3x DO iveg = 1, 2 IF (iveg == 1) THEN DO i = 1, nmax cct (i)=cc (i) ts (i)=tc (i) dts (i)=dtc(i) flux(i)=chf(i) END DO ELSE DO i = 1, nmax cct (i)=cg (i) ts (i)=tg (i) dts (i)=dtg(i) flux(i)=cct(i)*dtg(i)*dtc3xi END DO END IF DO i = 1, nmax tta(i) = ts(i) - dts(i) ttb(i) = ts(i) END DO DO i = 1, nmax IF (tta(i) <= tf) THEN snow (i,iveg) = capac(i,iveg) capac(i,iveg) = 0.0_r8 ELSE snow (i,iveg) = 0.0_r8 END IF END DO DO i = 1, nmax work(i)=(tta(i)-tf)*(ttb(i)-tf) END DO DO i = 1, nmax IF (work(i) < 0.0_r8) THEN ntyp=itype(i) dtf (i)= tf - tta(i) dtime1(i)= cct (i)* dtf(i)/ flux(i) hf (i)= flux(i)*(dtc3x-dtime1(i)) spwet (i)= MIN ( 5.0_r8 , snow(i,iveg) ) IF (dts(i) <= 0.0_r8) THEN fcap (i) =-capac(i,iveg)* snomel ELSE fcap (i) = spwet(i) * snomel END IF dtime2(i)= fcap(i) / flux(i) dtf2 (i)= flux(i) * (dtc3x-dtime1(i)-dtime2(i))/cct(i) tn(i) = tf + dtf2(i) IF (ABS(hf(i)) < ABS(fcap(i))) THEN ts(i) = tf -0.1_r8 ELSE ts(i) = tn(i) END IF IF (ABS(hf(i)) < ABS(fcap(i))) THEN change(i) = hf (i) ELSE change(i) = fcap(i) END IF change(i) =change(i) / snomel snow (i,iveg)=snow (i,iveg) - change(i) capac (i,iveg)=capac (i,iveg) + change(i) IF (snow(i,iveg) < 1.e-10_r8) snow(i,iveg)=0.0e0_r8 IF (iveg == 1)THEN tc(i)=ts(i) ELSE tg(i)=ts(i) END IF IF (iveg == 2) THEN IF (td(i) > tf) THEN w (i,1)=w (i,1)+capac(i,iveg) & /(poros(ntyp)*zdepth(ntyp,1)) ELSE roff(i)=roff(i)+capac(i,iveg) END IF capac(i,iveg) = 0.0_r8 END IF END IF END DO DO i = 1, nmax capac(i,iveg) = capac(i,iveg) + snow(i,iveg) END DO END DO ! modified to use force-restore heat fluxes DO i = 1, nmax fluxef(i) = shf(i) - cg(i)*dtg(i)*dtc3xi END DO END SUBROUTINE snowm ! fysiks :it is a physics driver; performs the following: ! a) soil water budget prior to calling pbl ! b) planetary boundary layer (pbl) parameterization ! c) update sib variables ! d) dumping of small capac values onto soil surface store ! e) snowmelt/refreeze calculation ! f) update deep soil temperature using effective soil heat flux ! g) bare soil evaporation loss ! h) extraction of transpiration loss from root zone ! i) interflow, infiltration excess and loss to groundwater ! j) increment prognostic variables and ! adjust theta and sh to be consistent with dew formation ! k) calculates soil water budget after calling pbl ! and compares with previous budget. SUBROUTINE fysiks(vcover, z0x , d , rdc , rbc , z0 ,ndt , & latitu, bps ,psb ,dzm ,em ,gmt ,gmq , & gmu ,cu , cuni ,ctni ,ustar ,cosz ,sinclt,rhoair, & psy ,rcp , wc ,wg ,fc ,fg ,hr , ect , & eci , egt , egi , egs , ec , eg , hc , hg , & ecidif,egidif,ecmass,egmass,etmass,hflux , chf , shf , & fluxef, roff , drag ,ra , rb , rd , rc , rg , & tcta , tgta , ta , ea , etc , etg , btc , btg , & u2 , radt , par , pd , rst ,rsoil ,phroot, hrr , & phsoil, cc , cg ,satcap, snow , dtc , dtg , dtm , & dqm , stm , extk ,radfac, closs,gloss ,thermk, p1f , & p2f , tc , tg , td , capac, w , qm , tm , & um , vm , psur , ppc , ppl , radn ,itype ,dtc3x , & mon , nmax , ncols,zlt2 ,green2,chil2 ,rstpar2,topt2, & tll2 ,tu2 , defac2,ph12 ,ph22 ,bstar) ! ! !----------------------------------------------------------------------- ! ! roff.......Runoff (escoamente superficial e drenagem)(m) ! slope......Inclinacao de perda hidraulica na camada profunda do solo ! bee........Fator de retencao da umidade no solo (expoente da umidade do ! solo) ! satco......Condutividade hidraulica do solo saturado(m/s) ! zdepth(id).Profundidade das camadas de solo id=1 superficial ! zdepth(id).Profundidade das camadas de solo id=2 camada de raizes ! zdepth(id).Profundidade das camadas de solo id=3 camada de drenagem ! phsat......Potencial matricial do solo saturado(m) (tensao do solo em ! saturacao) ! poros......Porosidade do solo ! dtc3x......time increment dt ! snomel.....Calor latente de fusao(J/kg) ! w(id)......Grau de saturacao de umidade do solo id=1 na camada superficial ! w(id)......Grau de saturacao de umidade do solo id=2 na camada de raizes ! w(id)......Grau de saturacao de umidade do solo id=3 na camada de drenagem ! capac(iv)..Agua interceptada iv=1 no dossel (m) ! capac(iv)..Agua interceptada iv=2 na cobertura do solo (m) ! tg.........Temperatura da superficie do solo (K) ! td.........Temperatura do solo profundo (K) ! itype......Classe de textura do solo ! tf.........Temperatura de congelamento (K) ! idp........Parametro para as camadas de solo idp=1->3 ! nmax....... ! ncols......Number of grid points on a gaussian latitude circle ! ityp.......Numero das classes de solo 13 ! imon.......Numero maximo de meses no ano (12) ! icg........Parametros da vegetacao (icg=1 topo e icg=2 base) ! iwv........Compriment de onda iwv=1=visivel, iwv=2=infravermelho ! proximo, iwv=3 infravermelho termal ! idp........Camadas de solo (1 a 3) ! ibd........Estado da vegetacao ibd=1 verde / ibd=2 seco ! pie........Constante Pi=3.1415926e0 ! stefan.....Constante de Stefan Boltzmann ! cp.........specific heat of air (j/kg/k) ! hl ........heat of evaporation of water (j/kg) ! grav.......gravity constant (m/s**2) ! snomel.....heat of melting (j m-1) ! tf.........Temperatura de congelamento (K) ! clai.......heat capacity of foliage ! cw.........liquid water heat capacity (j/m**3) ! gasr.......Constant of dry air (j/kg/k) ! epsfac.....Constante 0.622 Razao entre as massas moleculares do vapor ! de agua e do ar seco ! athird.....Constante athird=1.0e0 /3.0e0 ! dtc3x......time increment dt ! mon........Number of month at year (1-12) ! nmax ! rstpar.....Coefficints related to par influence on ! stomatal resistance ! chil.......Leaf orientation parameter ! topt.......Temperatura ideal de funcionamento estomatico ! tll........Temperatura minima de funcionamento estomatico ! tu.........Temperatura maxima de funcionamento estomatico ! defac......Parametro de deficit de pressao de vapor d'agua ! ph1........Coeficiente para o efeito da agua no solo ! ph2........Potencial de agua no solo para ponto de Wilting ! rootd......Profundidade das raizes ! bee........Expoente da curva de retencao "expoente para o solo umido" ! phsat......Tensao do solo saturado " Potencial de agua no solo saturado" ! satco......mean soil hydraulic conductivity in the root zone ! poros......Porosity ! zdepth.....Profundidade para as tres camadas de solo ! green......Fraction of grenn leaves ! xcover(iv).Fracao de cobertura de vegetacao iv=1 Top ! xcover(iv).Fracao de cobertura de vegetacao iv=2 Bottom ! zlt(icg)...Indice de area foliar "LEAF AREA INDEX" icg=1 topo da copa ! zlt(icg)...Indice de area foliar "LEAF AREA INDEX" icg=2 base da copa ! x0x........Comprimento de rugosidade ! xd.........Deslocamento do plano zero ! z2.........Altura do topo do dossel ! xdc........Constant related to aerodynamic resistance ! between ground and canopy air space ! xbc........Constant related to bulk boundary layer resistance ! itype......Classe de textura do solo ! qm.........Reference specific humidity (fourier) ! tm.........Reference temperature (fourier) (k) ! um.........Razao entre zonal pseudo-wind (fourier) e seno da ! colatitude ! vm.........Razao entre meridional pseudo-wind (fourier) e seno da ! colatitude ! psur.......Surface pressure in mb ! ppc........Precipitation rate ( cumulus ) (mm/s) ! ppl........Precipitation rate ( large scale ) (mm/s) ! radn.......Downward sw/lw radiation at the surface ! tc.........Temperatura da copa "dossel"(K) ! tg.........Temperatura da superficie do solo (K) ! td.........Temperatura do solo profundo (K) ! capac(iv)..Agua interceptada iv=1 no dossel "water store capacity ! of leaves"(m) ! capac(iv)..Agua interceptada iv=2 na cobertura do solo (m) ! w(id)......Grau de saturacao de umidade do solo id=1 na camada superficial ! w(id)......Grau de saturacao de umidade do solo id=2 na camada de raizes ! w(id)......Grau de saturacao de umidade do solo id=3 na camada de drenagem ! ra.........Resistencia Aerodinamica (s/m) ! rb.........bulk boundary layer resistance ! rd.........Aerodynamic resistance between ground (s/m) ! and canopy air space ! rc.........Resistencia do topo da copa ! rg.........Resistencia da base da copa ! tcta.......Diferenca entre tc-ta (k) ! tgta.......Diferenca entre tg-ta (k) ! ta.........Temperatura no nivel de fonte de calor do dossel (K) ! ea.........Pressure of vapor ! etc........Pressure of vapor at top of the copa ! etg........Pressao de vapor no base da copa ! btc........btc(i)=EXP(30.25353 -5418.0 /tc(i))/(tc(i)*tc(i)). ! btg........btg(i)=EXP(30.25353 -5418.0 /tg(i))/(tg(i)*tg(i)) ! u2.........wind speed at top of canopy ! radt.......net heat received by canopy/ground vegetation ! par........par incident on canopy ! pd.........ratio of par beam to total par ! rst .......Resisttencia Estomatica "Stomatal resistence" (s/m) ! rsoil......Resistencia do solo (s/m) ! phroot.....Soil moisture potentials in root zone of each ! vegetation layer and summed soil+root resistance. ! hrr........rel. humidity in top layer ! phsoil.....soil moisture potential of the i-th soil layer ! cc.........heat capacity of the canopy ! cg.........heat capacity of the ground ! satcap.....saturation liquid water capacity (m) ! snow.......snow amount ! dtc........dtc(i)=pblsib(i,2,5)*dtc3x ! dtg........dtg(i)=pblsib(i,1,5)*dtc3x ! dtm........dtm(i)=pblsib(i,3,5)*dtc3x ! dqm .......dqm(i)=pblsib(i,4,5)*dtc3x ! stm .......Variavel utilizada mo cal. da Resisttencia ! extk.......extinction coefficient ! radfac.....Fractions of downward solar radiation at surface ! passed from subr.radalb ! closs......Radiation loss from canopy ! gloss......Radiation loss from ground ! thermk.....Canopy emissivity ! p1f ! p2f ! ect........Transpiracao no topo da copa (J/m*m) ! eci........Evaporacao da agua interceptada no topo da copa (J/m*m) ! egt........Transpiracao na base da copa (J/m*m) ! egi........Evaporacao da neve (J/m*m) ! egs........Evaporacao do solo arido (J/m*m) ! ec.........Soma da Transpiracao e Evaporacao da agua interceptada pelo ! topo da copa ec (i)=eci(i)+ect(i) ! eg.........Soma da transpiracao na base da copa + Evaporacao do solo arido ! + Evaporacao da neve " eg (i)=egt(i)+egs(i)+egi(i)" ! hc.........Total sensible heat lost of top from the veggies. ! hg.........Total sensible heat lost of base from the veggies. ! ecidif.....check if interception loss term has exceeded canopy storage ! ecidif(i)=MAX(0.0 , eci(i)-capac(i,1)*hlat3 ) ! egidif.....check if interception loss term has exceeded canopy storage ! ecidif(i)=MAX(0.0 , egi(i)-capac(i,1)*hlat3 ) ! ecmass.....Mass of water lost of top from the veggies. ! egmass.....Mass of water lost of base from the veggies. ! etmass.....Total mass of water lost from the veggies. ! hflux......Total sensible heat lost from the veggies ! chf........Heat fluxes into the canopy in w/m**2 ! shf........Heat fluxes into the ground, in w/m**2 ! fluxef.....Modified to use force-restore heat fluxes ! fluxef(i) = shf(i) - cg(i)*dtg(i)*dtc3xi " Garrat pg. 227" ! roff.......runoff (escoamente superficial e drenagem)(m) ! drag.......tensao superficial ! bps ! psb ! dzm........Altura media de referencia para o vento para o calculo ! da estabilidade do escoamento ! em.........Pressao de vapor da agua ! gmt(i,k,3).temperature related matrix virtual temperature tendency ! due to vertical diffusion ! gmq........specific humidity related matrix specific humidity of ! reference (fourier) ! gmu........wind related matrix ! cu.........Friction transfer coefficients. ! cuni.......Neutral friction transfer coefficients. ! ctni.......Neutral heat transfer coefficients. ! ustar......Surface friction velocity (m/s) ! cosz.......Cosine of zenith angle ! sinclt.....sinclt=SIN(colrad(latitu))"seno da colatitude" ! rhoair.....Desnsidade do ar ! psy........(cp/(hl*epsfac))*psur(i) ! rcp........densidade do ar vezes o calor especifico do ar ! wc.........Minimo entre 1 e a razao entre a agua interceptada pelo ! indice de area foliar no topo da copa ! wg.........Minimo entre 1 e a razao entre a agua interceptada pelo ! indice de area foliar na base da copa ! fc.........Condicao de oravalho 0 ou 1 na topo da copa ! fg.........Condicao de oravalho 0 ou 1 na base da copa ! hr.........rel. humidity in top layer ! ndt ! latitu ! jstneu.....The first call to vntlat just gets the neutral values of ustar ! and ventmf para jstneu=.TRUE.. ! hgdtg.......n.b. fluxes expressed in joules m-2 ! hgdtc.......n.b. fluxes expressed in joules m-2 ! hgdtm.......n.b. fluxes expressed in joules m-2 ! hcdtg.......n.b. fluxes expressed in joules m-2 ! hcdtc.......n.b. fluxes expressed in joules m-2 ! hcdtm.......n.b. fluxes expressed in joules m-2 ! egdtg.......partial derivative calculation for latent heat ! egdtc.......partial derivative calculation for latent heat ! egdqm.......partial derivative calculation for latent heat ! ecdtg.......partial derivative calculation for latent heat ! ecdtc.......partial derivative calculation for latent heat ! ecdqm.......partial derivative calculation for latent heat ! deadtg ! deadtc ! deadqm ! icheck......this version assumes dew-free conditions "icheck=1" to ! estimate ea for buoyancy term in vntmf or ra. ! vcover(iv)..Fracao de cobertura de vegetacao iv=1 Top ! vcover(iv)..Fracao de cobertura de vegetacao iv=2 Botto ! z0x.........roughness length ! d...........Displacement height ! rdc.........Constant related to aerodynamic resistance ! between ground and canopy air space ! rbc.........Constant related to bulk boundary layer resistance ! z0..........Roughness length !----------------------------------------------------------------------- ! INTEGER, INTENT(in ) :: ncols REAL(KIND=r8) , INTENT(in ) :: dtc3x INTEGER, INTENT(in ) :: mon(ncols) INTEGER, INTENT(in ) :: nmax INTEGER, INTENT(in ) :: itype (ncols) ! ! the size of working area is ncols*187 ! atmospheric parameters as boudary values for sib ! REAL(KIND=r8), INTENT(inout) :: qm (ncols) REAL(KIND=r8), INTENT(inout) :: tm (ncols) REAL(KIND=r8), INTENT(in ) :: um (ncols) REAL(KIND=r8), INTENT(in ) :: vm (ncols) REAL(KIND=r8), INTENT(inout) :: psur(ncols) REAL(KIND=r8), INTENT(in ) :: ppc (ncols) REAL(KIND=r8), INTENT(in ) :: ppl (ncols) REAL(KIND=r8), INTENT(in ) :: radn(ncols,3,2) ! ! prognostic variables ! REAL(KIND=r8), INTENT(inout) :: tc (ncols) REAL(KIND=r8), INTENT(inout) :: tg (ncols) REAL(KIND=r8), INTENT(inout) :: td (ncols) REAL(KIND=r8), INTENT(inout) :: capac(ncols,2) REAL(KIND=r8), INTENT(inout) :: w (ncols,3) ! ! variables calculated from above and ambient conditions ! REAL(KIND=r8), INTENT(inout) :: ra (ncols) REAL(KIND=r8), INTENT(inout ) :: rb (ncols) REAL(KIND=r8), INTENT(inout ) :: rd (ncols) REAL(KIND=r8), INTENT(inout ) :: rc (ncols) REAL(KIND=r8), INTENT(inout ) :: rg (ncols) REAL(KIND=r8), INTENT(inout ) :: tcta (ncols) REAL(KIND=r8), INTENT(inout ) :: tgta (ncols) REAL(KIND=r8), INTENT(inout ) :: ta (ncols) REAL(KIND=r8), INTENT(inout ) :: ea (ncols) REAL(KIND=r8), INTENT(inout ) :: etc (ncols) REAL(KIND=r8), INTENT(inout ) :: etg (ncols) REAL(KIND=r8), INTENT(inout ) :: btc (ncols) REAL(KIND=r8), INTENT(inout ) :: btg (ncols) REAL(KIND=r8), INTENT(inout) :: u2 (ncols) REAL(KIND=r8), INTENT(inout ) :: radt (ncols,icg) REAL(KIND=r8), INTENT(inout) :: par (ncols,icg) REAL(KIND=r8), INTENT(inout ) :: pd (ncols,icg) REAL(KIND=r8), INTENT(inout ) :: rst (ncols,icg) REAL(KIND=r8), INTENT(inout ) :: rsoil (ncols) REAL(KIND=r8), INTENT(inout ) :: phroot(ncols,icg) REAL(KIND=r8), INTENT(inout ) :: hrr (ncols) REAL(KIND=r8), INTENT(inout ) :: phsoil(ncols,idp) REAL(KIND=r8), INTENT(inout ) :: cc (ncols) REAL(KIND=r8), INTENT(inout ) :: cg (ncols) REAL(KIND=r8), INTENT(inout) :: satcap(ncols,icg) REAL(KIND=r8), INTENT(inout) :: snow (ncols,icg) REAL(KIND=r8), INTENT(inout ) :: dtc (ncols) REAL(KIND=r8), INTENT(inout ) :: dtg (ncols) REAL(KIND=r8), INTENT(inout ) :: dtm (ncols) REAL(KIND=r8), INTENT(inout ) :: dqm (ncols) REAL(KIND=r8), INTENT(inout ) :: stm (ncols,icg) REAL(KIND=r8), INTENT(inout) :: extk (ncols,icg,iwv,ibd) REAL(KIND=r8), INTENT(in ) :: radfac(ncols,icg,iwv,ibd) REAL(KIND=r8), INTENT(in ) :: closs (ncols) REAL(KIND=r8), INTENT(in ) :: gloss (ncols) REAL(KIND=r8), INTENT(inout) :: thermk(ncols) REAL(KIND=r8), INTENT(in ) :: p1f (ncols) REAL(KIND=r8), INTENT(in ) :: p2f (ncols) ! ! heat fluxes : c-canopy, g-ground, t-trans, e-evap in j m-2 ! REAL(KIND=r8), INTENT(inout) :: ect (ncols) REAL(KIND=r8), INTENT(inout) :: eci (ncols) REAL(KIND=r8), INTENT(inout) :: egt (ncols) REAL(KIND=r8), INTENT(inout) :: egi (ncols) REAL(KIND=r8), INTENT(inout) :: egs (ncols) REAL(KIND=r8), INTENT(inout ) :: ec (ncols) REAL(KIND=r8), INTENT(inout ) :: eg (ncols) REAL(KIND=r8), INTENT(inout ) :: hc (ncols) REAL(KIND=r8), INTENT(inout ) :: hg (ncols) REAL(KIND=r8), INTENT(inout ) :: ecidif(ncols) REAL(KIND=r8), INTENT(inout ) :: egidif(ncols) REAL(KIND=r8), INTENT(inout ) :: ecmass(ncols) REAL(KIND=r8), INTENT(inout ) :: egmass(ncols) REAL(KIND=r8), INTENT(inout ) :: etmass(ncols) REAL(KIND=r8), INTENT(inout ) :: hflux (ncols) REAL(KIND=r8), INTENT(inout ) :: chf (ncols) REAL(KIND=r8), INTENT(inout ) :: shf (ncols) REAL(KIND=r8), INTENT(inout ) :: fluxef(ncols) REAL(KIND=r8), INTENT(inout) :: roff (ncols) REAL(KIND=r8), INTENT(inout) :: drag (ncols) ! ! this is for coupling with closure turbulence model ! REAL(KIND=r8), INTENT(in ) :: bps (ncols) REAL(KIND=r8), INTENT(in ) :: psb (ncols) REAL(KIND=r8), INTENT(in ) :: dzm (ncols) REAL(KIND=r8), INTENT(in ) :: em (ncols) REAL(KIND=r8), INTENT(inout) :: gmt (ncols,3) REAL(KIND=r8), INTENT(inout) :: gmq (ncols,3) REAL(KIND=r8), INTENT(inout) :: gmu (ncols,4) REAL(KIND=r8), INTENT(inout) :: cu (ncols) REAL(KIND=r8), INTENT(inout) :: cuni (ncols) REAL(KIND=r8), INTENT(inout) :: ctni (ncols) REAL(KIND=r8), INTENT(inout) :: ustar (ncols) REAL(KIND=r8), INTENT(in ) :: cosz (ncols) REAL(KIND=r8), INTENT(in ) :: sinclt(ncols) REAL(KIND=r8), INTENT(in ) :: rhoair(ncols) REAL(KIND=r8), INTENT(in ) :: psy (ncols) REAL(KIND=r8), INTENT(inout ) :: rcp (ncols) REAL(KIND=r8), INTENT(inout) :: wc (ncols) REAL(KIND=r8), INTENT(inout) :: wg (ncols) REAL(KIND=r8), INTENT(inout) :: fc (ncols) REAL(KIND=r8), INTENT(inout) :: fg (ncols) REAL(KIND=r8), INTENT(inout) :: hr (ncols) INTEGER, INTENT(in ) :: ndt INTEGER, INTENT(in ) :: latitu REAL(KIND=r8) , INTENT(in ) :: rstpar2 (ncols,icg,iwv) REAL(KIND=r8) , INTENT(in ) :: zlt2 (ncols,icg) REAL(KIND=r8) , INTENT(in ) :: green2 (ncols,icg) REAL(KIND=r8) , INTENT(in ) :: chil2 (ncols,icg) REAL(KIND=r8), INTENT(inout) :: vcover (ncols,icg) REAL(KIND=r8), INTENT(inout) :: z0x(ncols) REAL(KIND=r8), INTENT(inout) :: d (ncols) REAL(KIND=r8), INTENT(inout) :: rdc(ncols) REAL(KIND=r8), INTENT(inout) :: rbc(ncols) REAL(KIND=r8), INTENT(inout) :: z0 (ncols) REAL(KIND=r8) , INTENT(in ) :: topt2 (ncols,icg) REAL(KIND=r8) , INTENT(in ) :: tll2 (ncols,icg) REAL(KIND=r8) , INTENT(in ) :: tu2 (ncols,icg) REAL(KIND=r8) , INTENT(in ) :: defac2 (ncols,icg) REAL(KIND=r8) , INTENT(in ) :: ph12 (ncols,icg) REAL(KIND=r8) , INTENT(in ) :: ph22 (ncols,icg) REAL(KIND=r8) , INTENT(out ) :: bstar(ncols) LOGICAL :: jstneu INTEGER :: icheck(ncols) ! ! derivatives ! REAL(KIND=r8) :: hgdtg (ncols) REAL(KIND=r8) :: hgdtc (ncols) REAL(KIND=r8) :: hgdtm (ncols) REAL(KIND=r8) :: hcdtg (ncols) REAL(KIND=r8) :: hcdtc (ncols) REAL(KIND=r8) :: hcdtm (ncols) REAL(KIND=r8) :: egdtg (ncols) REAL(KIND=r8) :: egdtc (ncols) REAL(KIND=r8) :: egdqm (ncols) REAL(KIND=r8) :: ecdtg (ncols) REAL(KIND=r8) :: ecdtc (ncols) REAL(KIND=r8) :: ecdqm (ncols) REAL(KIND=r8) :: deadtg(ncols) REAL(KIND=r8) :: deadtc(ncols) REAL(KIND=r8) :: deadqm(ncols) REAL(KIND=r8) :: ef (ncols,3) REAL(KIND=r8) :: absoil(ncols) REAL(KIND=r8) :: totdep(ncols) REAL(KIND=r8) :: div (ncols) REAL(KIND=r8) :: eft (ncols) REAL(KIND=r8) :: aaa (ncols) REAL(KIND=r8) :: dep (ncols) INTEGER :: i INTEGER :: il INTEGER :: ntyp INTEGER :: iveg REAL(KIND=r8) :: hlat3i REAL(KIND=r8) :: gby100 REAL(KIND=r8) :: timcon REAL(KIND=r8) :: totwb(ncols) REAL(KIND=r8) :: endwb(ncols) REAL(KIND=r8) :: cbal (ncols) REAL(KIND=r8) :: gbal (ncols) REAL(KIND=r8) :: ct(ncols) REAL(KIND=r8) :: qh(ncols) REAL(KIND=r8) :: speed(ncols) REAL(KIND=r8) :: d1 ! ! calculates soil water budget prior to calling pbl ! DO i = 1, nmax ! ! capac(1)..Agua interceptada no dossel (m) ! capac(2)..Agua interceptada na cobertura do solo (m) ! totwb(i)=w(i,1)*poros(itype(i))*zdepth(itype(i),1) & +w(i,2)*poros(itype(i))*zdepth(itype(i),2) & +w(i,3)*poros(itype(i))*zdepth(itype(i),3) & +capac(i,1) + capac(i,2) END DO ! ! planetary boundary layer parameterization ! CALL pbl(jstneu, hgdtg , hgdtc , hgdtm , hcdtg , hcdtc , hcdtm , & egdtg , egdtc , egdqm , ecdtg , ecdtc , ecdqm , deadtg, & deadtc, deadqm,icheck , ect , eci , egt , egi , & egs , ec , eg , hc , hg , ecidif, egidif, & ecmass, egmass, etmass, hflux , chf , shf , roff , & bps , psb , dzm , em , gmt , gmq , cu , & cuni , ctni , ustar , cosz , rhoair, psy , rcp , & wc , wg , fc , fg , hr , vcover, z0x , & d , rdc , rbc , z0 , qm , tm , um , & vm , psur , ppc , ppl , radn , ra , rb , & rd , rc , rg , tcta , tgta , ta , ea , & etc , etg , btc , btg , u2 , radt , par , & pd , rst , rsoil , phroot, hrr , phsoil, cc , & cg , satcap, snow , dtc , dtg , dtm , dqm , & stm , extk , radfac, closs , gloss , thermk, p1f , & p2f , tc , tg , td , capac , w , itype , & dtc3x , mon , nmax , ncols ,zlt2 ,green2,chil2 ,rstpar2,& topt2 ,tll2 ,tu2 , defac2,ph12 ,ph22 ,ct) ! ! continue to update sib variables ! DO i = 1, nmax tc(i) = tc(i) + dtc(i) tg(i) = tg(i) + dtg(i) END DO ! ! dumping of small capac values onto soil surface store ! DO iveg = 1, 2 DO i = 1, nmax ntyp =itype(i) IF (capac(i,iveg) <= 1.e-6_r8)THEN w(i,1)=w(i,1)+capac(i,iveg)/(poros(ntyp)*zdepth(ntyp,1)) capac(i,iveg)=0.0_r8 END IF END DO END DO ! ! snowmelt/refreeze calculation ! CALL snowm(& chf ,shf ,fluxef,roff ,cc ,cg ,snow ,dtc ,dtg , & tc ,tg ,td ,capac ,w ,itype ,dtc3x ,nmax ,ncols ) ! ! update deep soil temperature using effective soil heat flux ! timcon=dtc3x/(2.0_r8 *SQRT(pie*365.0_r8 )) DO i = 1, nmax td(i)=td(i)+fluxef(i)/cg(i)*timcon END DO ! ! bare soil evaporation loss ! hlat3i=1.0_r8/(hl*1000.0_r8 ) DO i = 1, nmax ntyp=itype(i) w(i,1)=w(i,1)-egs(i)*hlat3i/(poros(ntyp)*zdepth(ntyp,1)) END DO ! ! extraction of transpiration loss from root zone ! DO iveg = 1, 2 IF (iveg == 1) THEN DO i = 1, nmax absoil(i)=ect(i)*hlat3i END DO ELSE DO i = 1, nmax absoil(i)=egt(i)*hlat3i END DO END IF DO i = 1, nmax ntyp=itype(i) ef(i,2)=0.0_r8 ef(i,3)=0.0_r8 totdep(i)=zdepth(ntyp,1) END DO DO il = 2, 3 DO i = 1, nmax ntyp=itype(i) totdep(i)=totdep(i)+zdepth(ntyp,il) div(i)=rootd(ntyp,iveg) dep(i)=MAX(0.0_r8 ,rootd(ntyp,iveg)-totdep(i)+ & zdepth(ntyp,il)) dep(i)=MIN(dep(i),zdepth(ntyp,il)) ef(i,il)=dep(i)/div(i) END DO END DO DO i = 1, nmax eft(i )=ef(i,2)+ef (i,3) eft(i) = MAX(eft(i),0.1e-5_r8) ef (i,2)=ef(i,2)/eft(i) ef (i,3)=ef(i,3)/eft(i) END DO DO il = 2, 3 DO i = 1, nmax ntyp=itype(i) w(i,il)=w(i,il)-absoil(i)*ef(i,il)/ & (poros(ntyp)*zdepth(ntyp,il)) END DO END DO END DO ! ! interflow, infiltration excess and loss to ! groundwater . all losses are assigned to variable 'roff' . ! DO il = 1, 2 DO i = 1, nmax IF (w(i,il) <= 0.0_r8) THEN ntyp=itype(i) w(i,il+1)=w(i,il+1)+w(i,il)* & zdepth(ntyp,il)/zdepth(ntyp,il+1) w(i,il )=0.0_r8 END IF END DO END DO CALL runoff(& roff ,tg ,td ,capac ,w ,itype ,dtc3x ,nmax ,ncols ) DO i = 1, nmax ntyp = itype(i) IF (w(i,1) > 1.0_r8) THEN w(i,2)=w(i,2)+(w(i,1)-1.0_r8 )*zdepth(ntyp,1)/zdepth(ntyp,2) w(i,1)=1.0_r8 ENDIF IF (w(i,2) > 1.0_r8) THEN w(i,3)= w(i,3)+(w(i,2)-1.0_r8 )*zdepth(ntyp,2)/zdepth(ntyp,3) w(i,2)=1.0_r8 ENDIF IF (w(i,3) > 1.0_r8) THEN roff(i)=roff(i)+(w(i,3)-1.0_r8 )*poros(ntyp)*zdepth(ntyp,3) w(i,3)=1.0_r8 END IF END DO ! ! increment prognostic variables ! ! adjust theta and sh to be consistent with dew formation ! gby100 = 0.01_r8 * grav DO i = 1, nmax ! ! solve implicit system for winds ! ! psb(i) = psur(i) * ( si(k) - si(k+1) ) ! drag(i) =rhoair(i)*cu(i)*ustar(i) ! ! P=rho*G*Z ===> DP=rho*G*DZ ! ! D D !---- = rho * g * ---- ! DZ DP ! D ! aaa = cu * ustar * rho * g * ---- ! DP ! ! g ! aaa (i) = rhoair(i)*cu(i)*ustar(i) * ------------------------------- ! 100*psur(i) * ( si(k) - si(k+1) ) ! aaa (i) =drag (i)*gby100/psb(i) gmu (i,2) = gmu(i,2) + dtc3x*aaa(i) gmu (i,3) = (gmu(i,3) - aaa(i) * um(i)*sinclt(i) ) / gmu(i,2) gmu (i,4) = (gmu(i,4) - aaa(i) * vm(i)*sinclt(i) ) / gmu(i,2) d1 =1.0_r8/ra(i) + 1.0_r8/rb(i) + 1.0_r8/rd(i) ta(i) =( tg(i)/rd(i) + tc(i)/rb(i) + tm(i)*bps(i)/ra(i) )/d1 speed (i) = SQRT(um(i)**2 + vm(i)**2) speed (i) = MAX(2.0_r8 ,speed(i)) qh(i)=0.622e0_r8*EXP(21.65605e0_r8 -5418.0e0_r8 /ta(i))/psur(i) !THAT =effective_surface_skin_temperature [K] !BSTAR = (grav/(rhos*sqrt(CM*max(UU,1.e-30)/RHOS))) * & !(CT*(TH-TA-(MAPL_GRAV/MAPL_CP)*DZ)/TA + MAPL_VIREPS*CQ*(QH-QA)) ! ! grav !BSTAR = -------------------------------------------------------------- * ! (rho(i)*sqrt(CU(i)*max(speed(i),1.e-30_r8)/RHOS(i))) ! ! ! ! ! (CT(i)*(tsfc(i)-gt(i)-(GRAV/CP)*dzm(i))/gt(i) + MAPL_VIREPS*CT(i)*(qsfc-gq(i))) ! ! ! cuni(i)=LOG((dzm(i)-d(i))/z0(i))*vkrmni ! ! ! 0.4 T0 -T !b_star = ------------------ * G *-------- ! log(z(i)/z0(i)) T0 ! !bstar(i)=cu(i)*grav*(ct(i)*(ta(i)-tm(i)*BPS(I)-(grav/cp)*dzm(i))/tm(i)*BPS(I))!+mapl_vireps*ct(i)*(qh(i)-qm(i))) bstar(i)=cu(i)*grav*(ct(i)*(ta(i)/BPS(I)-tm(i))/tm(i)*BPS(I))!+mapl_vireps*ct(i)*(qh(i)-qm(i))) !bstar(i) = (grav/(rhoair(i)*sqrt(cu(i)*max(speed(i),1.e-30_r8)/rhoair(i)))) + & ! (ct(i)*(tg(i)-tm(i)-(grav/cp)*dzm(i))/tm(i) + mapl_vireps*ct(i)*(qh(i)-qm(i))) END DO ! ! calculates soil water budget after calling pbl ! and compares with previous budget ! DO i = 1, nmax ntyp=itype(i) endwb(i)=w(i,1)*poros(ntyp)*zdepth(ntyp,1) & +w(i,2)*poros(ntyp)*zdepth(ntyp,2) & +w(i,3)*poros(ntyp)*zdepth(ntyp,3) & +capac(i,1)+capac(i,2) & -(ppl(i)+ppc(i))/1000.0_r8 + etmass(i)/1000.0_r8 + roff(i) !IF (ABS(totwb(i)-endwb(i)) > 0.0001_r8) THEN ! WRITE(UNIT=nfprt,FMT=998) latitu,i,ntyp,ndt, & ! totwb(i),endwb(i),(totwb(i)-endwb(i)),w(i,1),w(i,2), & ! w(i,3),capac(i,1),capac(i,2),ppl(i),ppc(i),etmass(i), & ! roff(i),zlt(ntyp,12,1),zlt(ntyp,12,2), & ! tc(i),tg(i),td(i),tm(i) !END IF ! ! calculates and compares energy budgets ! cbal(i)=radt(i,1)-chf(i)-(ect(i)+hc(i)+eci(i))/dtc3x gbal(i)=radt(i,2)-shf(i)-(egt(i)+egi(i)+hg(i)+egs(i))/dtc3x !IF (ABS(cbal(i)-gbal(i)) > 5.0_r8) & ! WRITE(UNIT=nfprt,FMT=999)latitu,i,ntyp,ndt, & ! radt(i,1),radt(i,2),chf(i),shf(i),hflux(i), & ! ect(i),eci(i),egt(i),egi(i),egs(i) END DO !cdir critical DO i=1,nmax ntyp=itype(i) ! if(abs(totwb(i)-endwb(i)).gt.0.0001_r8) then IF(ABS(totwb(i)-endwb(i)).GT.0.0005_r8) THEN WRITE(UNIT=nfprt,FMT=998) latitu,i,ntyp,ndt, & totwb(i),endwb(i),(totwb(i)-endwb(i)),w(i,1),w(i,2), & w(i,3),capac(i,1),capac(i,2),ppl(i),ppc(i),etmass(i), & roff(i),zlt(ntyp,12,1),zlt(ntyp,12,2), & tc(i),tg(i),td(i),tm(i) END IF IF(ABS(cbal(i)-gbal(i)).GT.5.0_r8) & WRITE(UNIT=nfprt,FMT=999)latitu,i,ntyp,ndt, & radt(i,1),radt(i,2),chf(i),shf(i),hflux(i), & ect(i),eci(i),egt(i),egi(i),egs(i) END DO !cdir end critical 998 FORMAT(3I4,1X,'WATER BAL.',I8,/3E12.4/3E12.4/2E12.4/4E12.4/2E12.4/4E12.4) 999 FORMAT(3I4,1X,'ENERGY BAL.',I8/4E12.3/6E12.3) END SUBROUTINE fysiks SUBROUTINE sextrp & (td ,tg ,tc ,w ,capac ,td0 ,tg0 ,tc0 ,w0 , & capac0,tdm ,tgm ,tcm ,wm ,capacm,istrt ,ncols ,nmax , & epsflt,intg ,latitu,tm0 ,qm0 ,tm ,qm ,tmm ,qmm ) INTEGER, INTENT(in ) :: istrt INTEGER, INTENT(in ) :: ncols INTEGER, INTENT(in ) :: nmax REAL(KIND=r8) , INTENT(in ) :: epsflt INTEGER, INTENT(in ) :: intg INTEGER, INTENT(in ) :: latitu REAL(KIND=r8), INTENT(in ) :: tm (ncols) REAL(KIND=r8), INTENT(in ) :: qm (ncols) REAL(KIND=r8), INTENT(in ) :: td (ncols) REAL(KIND=r8), INTENT(in ) :: tg (ncols) REAL(KIND=r8), INTENT(in ) :: tc (ncols) REAL(KIND=r8), INTENT(in ) :: w (ncols,3) REAL(KIND=r8), INTENT(in ) :: capac (ncols,2) REAL(KIND=r8), INTENT(inout) :: td0 (ncols) REAL(KIND=r8), INTENT(inout) :: tg0 (ncols) REAL(KIND=r8), INTENT(inout) :: tc0 (ncols) REAL(KIND=r8), INTENT(inout) :: w0 (ncols,3) REAL(KIND=r8), INTENT(inout) :: capac0(ncols,2) REAL(KIND=r8), INTENT(inout) :: tdm (ncols) REAL(KIND=r8), INTENT(inout) :: tgm (ncols) REAL(KIND=r8), INTENT(inout) :: tcm (ncols) REAL(KIND=r8), INTENT(inout) :: wm (ncols,3) REAL(KIND=r8), INTENT(inout) :: capacm(ncols,2) REAL(KIND=r8), INTENT(inout) :: tm0 (ncols) REAL(KIND=r8), INTENT(inout) :: qm0 (ncols) REAL(KIND=r8), INTENT(inout) :: tmm (ncols) REAL(KIND=r8), INTENT(inout) :: qmm (ncols) INTEGER :: i, nc, ii ii=0 IF (intg == 2) THEN IF (istrt >= 1) THEN DO i = 1, nmax tm0 (i) =tm (i) qm0 (i) =qm (i) td0 (i) =td (i) tg0 (i) =tg (i) tc0 (i) =tc (i) w0 (i,1)=w (i,1) w0 (i,2)=w (i,2) w0 (i,3)=w (i,3) capac0(i,1)=capac(i,1) capac0(i,2)=capac(i,2) IF (capac0(i,2) > 0.0_r8 .AND. tg0(i) > 273.16_r8) THEN nc=0 ii=0 !DO ii = 1, ncols ! IF (imask(ii) >= 1) nc=nc+1 ! IF (nc == i) EXIT !END DO WRITE(UNIT=nfprt,FMT=200)ii,latitu,i,capac0(i,2),tg0(i) END IF END DO ELSE DO i = 1, nmax td0(i)=td0(i)+epsflt*(td(i)+tdm(i)-2.0_r8 *td0(i)) tg0(i)=tg0(i)+epsflt*(tg(i)+tgm(i)-2.0_r8 *tg0(i)) tc0(i)=tc0(i)+epsflt*(tc(i)+tcm(i)-2.0_r8 *tc0(i)) tm0(i)=tm0(i)+epsflt*(tm(i)+tmm(i)-2.0_r8 *tm0(i)) qm0(i)=qm0(i)+epsflt*(qm(i)+qmm(i)-2.0_r8 *qm0(i)) IF(w0 (i,1) > 0.0_r8 ) THEN w0(i,1)=w0(i,1)+epsflt*(w(i,1)+wm(i,1)-2.0_r8 *w0(i,1)) END IF IF(w0 (i,2) > 0.0_r8 ) THEN w0(i,2)=w0(i,2)+epsflt*(w(i,2)+wm(i,2)-2.0_r8 *w0(i,2)) END IF IF(w0 (i,3) > 0.0_r8 ) THEN w0(i,3)=w0(i,3)+epsflt*(w(i,3)+wm(i,3)-2.0_r8 *w0(i,3)) END IF IF(capac0(i,1) > 0.0_r8 ) THEN capac0(i,1)=capac0(i,1) & +epsflt*(capac(i,1)+capacm(i,1)-2.0_r8*capac0(i,1)) END IF IF(capac0(i,2) > 0.0_r8 ) THEN capac0(i,2)=capac0(i,2) & +epsflt*(capac(i,2)+capacm(i,2)-2.0_r8*capac0(i,2)) END IF END DO DO i = 1, nmax tdm (i) =td0 (i) tgm (i) =tg0 (i) tcm (i) =tc0 (i) tmm (i) =tm0 (i) qmm (i) =qm0 (i) wm (i,1)=w0 (i,1) wm (i,2)=w0 (i,2) wm (i,3)=w0 (i,3) capacm(i,1)=capac0(i,1) capacm(i,2)=capac0(i,2) IF (capacm(i,2) > 0.0_r8) tgm(i)=MIN(tgm(i),273.06_r8) END DO DO i = 1, nmax td0 (i) =td (i) tg0 (i) =tg (i) tc0 (i) =tc (i) tm0 (i) =tm (i) qm0 (i) =qm (i) w0 (i,1)=w (i,1) w0 (i,2)=w (i,2) w0 (i,3)=w (i,3) capac0(i,1)=capac (i,1) capac0(i,2)=capac (i,2) IF (capac0(i,2) > 0.0_r8 .AND. tg0(i) > 273.16_r8) THEN nc=0 !DO ii = 1, ncols ! IF (imask(ii) >= 1) nc=nc+1 ! IF (nc == i) EXIT !END DO WRITE(UNIT=nfprt,FMT=200)ii,latitu,i,capac0(i,2),tg0(i) END IF END DO END IF ELSE DO i = 1, nmax tdm (i) =td (i) tgm (i) =tg (i) tcm (i) =tc (i) tmm (i) =tm (i) qmm (i) =qm (i) wm (i,1)=w (i,1) wm (i,2)=w (i,2) wm (i,3)=w (i,3) capacm(i,1)=capac(i,1) capacm(i,2)=capac(i,2) IF (capacm(i,2) > 0.0_r8 .AND. tgm(i) > 273.16_r8) THEN nc=0 !DO ii = 1, ncols ! IF (imask(ii) >= 1) nc=nc+1 ! IF (nc == i) EXIT !END DO WRITE(UNIT=nfprt,FMT=650)ii,latitu,i,capacm(i,2),tgm(i) END IF END DO DO i = 1, nmax td0 (i) =td (i) tg0 (i) =tg (i) tc0 (i) =tc (i) tm0 (i) =tm (i) qm0 (i) =qm (i) w0 (i,1)=w (i,1) w0 (i,2)=w (i,2) w0 (i,3)=w (i,3) capac0(i,1)=capac(i,1) capac0(i,2)=capac(i,2) END DO END IF 200 FORMAT(' CAPAC0 AND TG0 NOT CONSISTENT AT I,J,IS=',3I4, & ' CAPAC=',G16.8,' TG=',G16.8) 650 FORMAT(' CAPACM AND TGM NOT CONSISTENT AT I,J,IS=',3I4, & ' CAPAC=',G16.8,' TG=',G16.8) END SUBROUTINE sextrp SUBROUTINE Albedo( & ! Model information ncols ,kMax ,latco ,& nmax ,nsx ,itype ,& imask , & ! Model Geometry cosz ,zenith , & ! Time info month2 ,month , & ! Microphysics taud , & ! Atmospheric fields wind ,tsea , & ! LW Radiation fields at last integer hour LwSfcDown ,& ! Radiation field (Interpolated) at time = tod xVisBeam ,xVisDiff ,xNirBeam , & xNirDiff , & ! Surface Albedo avisb ,avisd ,anirb , & anird ) IMPLICIT NONE ! Model information INTEGER , INTENT(IN ) :: ncols INTEGER , INTENT(IN ) :: kmax INTEGER , INTENT(IN ) :: latco INTEGER , INTENT(IN ) :: nmax INTEGER , INTENT(IN ) :: nsx (ncols) INTEGER , INTENT(IN ) :: itype (ncols) INTEGER(KIND=i8), INTENT(IN ) :: imask (ncols) ! Model Geometry REAL (KIND=r8), INTENT(IN ) :: cosz (ncols) REAL (KIND=r8), INTENT(IN ) :: zenith(ncols) ! Time info INTEGER , INTENT(INOUT) :: month2(ncols) INTEGER , INTENT(IN ) :: month (ncols) ! Atmospheric fields REAL(KIND=r8) , INTENT(IN ) :: wind (ncols)!wind speed in m/s REAL(KIND=r8) , INTENT(IN ) :: tsea (ncols) ! Microphysics REAL(KIND=r8) , INTENT(IN ) :: taud (ncols,kMax) ! LW Radiation fields at last integer hour REAL(KIND=r8) , INTENT(IN ) :: LwSfcDown(1:nCols) ! Radiation field (Interpolated) at time = tod REAL(KIND=r8) , INTENT(IN ) :: xVisBeam (1:nCols) REAL(KIND=r8) , INTENT(IN ) :: xVisDiff (1:nCols) REAL(KIND=r8) , INTENT(IN ) :: xNirBeam (1:nCols) REAL(KIND=r8) , INTENT(IN ) :: xNirDiff (1:nCols) ! Surface Albedo REAL(KIND=r8) , INTENT(OUT ) :: avisb (ncols) REAL(KIND=r8) , INTENT(OUT ) :: avisd (ncols) REAL(KIND=r8) , INTENT(OUT ) :: anirb (ncols) REAL(KIND=r8) , INTENT(OUT ) :: anird (ncols) REAL(KIND=r8) :: tc (ncols) REAL(KIND=r8) :: tg (ncols) REAL(KIND=r8) :: tm (ncols) REAL(KIND=r8) :: qm (ncols) REAL(KIND=r8) :: td (ncols) REAL(KIND=r8) :: capac (ncols,2) REAL(KIND=r8) :: w (ncols,3) REAL(KIND=r8) :: satcap(ncols,icg) REAL(KIND=r8) :: extk (ncols,icg,iwv,ibd) REAL(KIND=r8) :: radfac(ncols,icg,iwv,ibd) REAL(KIND=r8) :: closs (ncols) REAL(KIND=r8) :: gloss (ncols) REAL(KIND=r8) :: thermk(ncols) REAL(KIND=r8) :: p1f (ncols) REAL(KIND=r8) :: p2f (ncols) REAL(KIND=r8) :: zlwup_local (ncols) REAL(KIND=r8) :: salb (ncols,2,2) REAL(KIND=r8) :: tgeff (ncols) INTEGER :: i INTEGER :: k,m,n,ll REAL(KIND=r8) :: ocealb REAL(KIND=r8) :: IceOceanAlb (2,2) ! --------------------------- INPUT --------------------------------------- ! ! specify the parameters for albedo here: REAL(KIND=r8) :: tau !aerosol/cloud optical depth REAL(KIND=r8) :: chl !chlorophyll concentration in mg/m3 REAL(KIND=r8) :: f INTEGER :: ncount IF(nmax.GE.1) THEN DO i=1,nmax tm (i) = tmm (i,latco) qm (i) = qmm (i,latco) td (i) = tdm (i,latco) tg (i) = tgm (i,latco) tc (i) = tcm (i,latco) capac (i,1) = capacm(i,1,latco) capac (i,2) = capacm(i,2,latco) w (i,1) = wm (i,1,latco) w (i,2) = wm (i,2,latco) w (i,3) = wm (i,3,latco) closs (i) = closs_gbl(i,latco) gloss (i) = gloss_gbl(i,latco) thermk (i) = thermk_gbl(i,latco) p1f (i) = p1f_gbl (i,latco) p2f (i) = p2f_gbl (i,latco) zlwup_local (i) = zlwup_SSiB(i,latco) salb (i,1,1) = AlbGblSSiB(i,1,1,latco) salb (i,1,2) = AlbGblSSiB(i,1,2,latco) salb (i,2,1) = AlbGblSSiB(i,2,1,latco) salb (i,2,2) = AlbGblSSiB(i,2,2,latco) tgeff (i) = tgeff_gbl (i,latco) END DO DO k=1,icg DO i=1,nmax satcap(i,k) = satcap3d(i,k,latco) END DO END DO DO m=1,ibd DO n=1,iwv DO ll=1,icg DO i=1,nmax extk (i,ll,n,m) = extk_gbl (i,ll,n,m,latco) radfac(i,ll,n,m) = radfac_gbl(i,ll,n,m,latco) END DO END DO END DO END DO CALL radalb ( & nmax ,month2(1:nmax) ,nmax ,itype(1:nmax) , & tc(1:nmax) ,tg(1:nmax) ,capac(1:nmax,:) ,satcap(1:nmax,:) , & extk(1:nmax,:,:,:),radfac(1:nmax,:,:,:),closs(1:nmax) ,gloss(1:nmax) , & thermk(1:nmax) ,p1f(1:nmax) ,p2f(1:nmax) ,zlwup_local(1:nmax) , & salb(1:nmax,:,:) ,tgeff(1:nmax) ,cosz(1:nmax) ,nsx(1:nmax) , & latco ) DO k=1,icg DO i=1,nmax satcap3d(i,k,latco) =satcap(i,k) END DO END DO DO i=1,nmax closs_gbl (i,latco) = closs(i) gloss_gbl (i,latco) = gloss(i) thermk_gbl(i,latco) = thermk(i) p1f_gbl (i,latco) = p1f (i) p2f_gbl (i,latco) = p2f (i) zlwup_SSiB(i,latco) = zlwup_local(i) AlbGblSSiB(i,1,1,latco) = salb (i,1,1) AlbGblSSiB(i,1,2,latco) = salb (i,1,2) AlbGblSSiB(i,2,1,latco) = salb (i,2,1) AlbGblSSiB(i,2,2,latco) = salb (i,2,2) tgeff_gbl(i,latco) = tgeff (i) END DO DO m=1,ibd DO n=1,iwv DO ll=1,icg DO i=1,nmax extk_gbl (i,ll,n,m,latco) = extk (i,ll,n,m) radfac_gbl(i,ll,n,m,latco) = radfac(i,ll,n,m) END DO END DO END DO END DO END IF ! --------------------------- INPUT --------------------------------------- ! ! specify the parameters for albedo here: chl = 0.10 !chlorophyll concentration in mg/m3 ! Two spectral surface albedos for direct (dir) and diffuse (dif) ! incident radiation are calculated. The spectral intervals are: ! s (shortwave) = 0.2-0.7 micro-meters ! l (longwave) = 0.7-5.0 micro-meters ! IF(TRIM(SLABOCEAN) == 'SLAB')THEN ncount=0 DO i=1,ncols IF(imask(i).GE.1_i8) THEN ncount=ncount+1 avisb(i)=salb(ncount,1,1) avisd(i)=salb(ncount,1,2) anirb(i)=salb(ncount,2,1) anird(i)=salb(ncount,2,2) ELSE IF(ABS(tsea(i)).GE.271.16e0_r8 +0.01e0_r8) THEN f=MAX(zenith(i),0.0e0_r8 ) tau = SUM(taud(i,1:kMax)) !aerosol/cloud optical depth avisb(i)=GetOceanAlb(tau,f,wind(i),chl,0.2_r8,0.7_r8) ! s (shortwave) = 0.2-0.7 micro-meters avisd(i)=oceald anirb(i)=GetOceanAlb(tau,f,wind(i),chl,0.7_r8,5.0_r8) ! l (longwave) = 0.7-5.0 micro-meters anird(i)=oceald ELSE IF (TRIM(ICEMODEL)=='SSIB')THEN f=MAX(zenith(i),0.0e0_r8 ) IceOceanAlb=GetIceOceanAlb(i,latco,month(i),xVisBeam(i),xVisDiff(i),& xNirBeam(i),xNirDiff(i),f,LwSfcDown(i)) avisb(i)=IceOceanAlb(1,1) avisd(i)=IceOceanAlb(1,2) anirb(i)=IceOceanAlb(2,1) anird(i)=IceOceanAlb(2,2) ELSE IF (TRIM(ICEMODEL)=='COLA')THEN avisb(i)=icealv avisd(i)=icealv anirb(i)=icealn anird(i)=icealn ELSE STOP "ICEMODEL ->OPTIONS" END IF END IF END DO ELSE IF(TRIM(SLABOCEAN) == 'COLA')THEN ncount=0 DO i=1,ncols IF(imask(i).GE.1_i8) THEN ncount=ncount+1 avisb(i)=salb(ncount,1,1) avisd(i)=salb(ncount,1,2) anirb(i)=salb(ncount,2,1) anird(i)=salb(ncount,2,2) ELSE IF(ABS(tsea(i)).GE.271.16e0_r8 +0.01e0_r8) THEN f=MAX(zenith(i),0.0e0_r8 ) ocealb=0.12347e0_r8 +f*(0.34667e0_r8+f*(-1.7485e0_r8 + & f*(2.04630e0_r8 -0.74839e0_r8 *f))) avisb(i)=ocealb avisd(i)=oceald anirb(i)=ocealb anird(i)=oceald ELSE IF (TRIM(ICEMODEL)=='SSIB')THEN f=MAX(zenith(i),0.0e0_r8 ) IceOceanAlb=GetIceOceanAlb(i,latco,month(i),xVisBeam(i),xVisDiff(i),& xNirBeam(i),xNirDiff(i),f,LwSfcDown(i)) avisb(i)=IceOceanAlb(1,1) avisd(i)=IceOceanAlb(1,2) anirb(i)=IceOceanAlb(2,1) anird(i)=IceOceanAlb(2,2) ELSE IF (TRIM(ICEMODEL)=='COLA')THEN avisb(i)=icealv avisd(i)=icealv anirb(i)=icealn anird(i)=icealn ELSE STOP "ICEMODEL ->OPTIONS" END IF END IF END DO ELSE WRITE(0,*)"ERRO SLABOCEAN",TRIM(SLABOCEAN) STOP END IF END SUBROUTINE Albedo ! radalb :surface albedos via two stream approximation (direct and diffuse). SUBROUTINE radalb ( & ncols ,mon ,nmax ,itype , & tc ,tg ,capac ,satcap , & extk ,radfac ,closs ,gloss , & thermk ,p1f ,p2f ,zlwup , & salb ,tgeff ,cosz ,nsx , & latitu ) ! ! ! reference : a simple biosphere model (xue et al 1991) !----------------------------------------------------------------------- ! *** indices *** ! cg =1...canopy ! cg =2...ground cover ! vn =1...visible (0.0-0.7 micron) ! vn =2...near-infrared(0.7-3.0 micron) ! bd =1...beam ! bd =2...diffuse ! ld =1...live leaves ! ld =2...dead leaves ! vnt=1...visible (0.0-0.7 micron) ! vnt=2...near-infrared(0.7-3.0 micron) ! vnt=3...thermal !----------------------------------------------------------------------- ! input parameters !----------------------------------------------------------------------- ! zlt(cg)..........leaf area index ! z1...............bottom height of canopy ! z2...............top height of canopy ! ref (cg,vnt,ld)..reflectance of vegetation ! tran(cg,vnt,ld)..transmittance of vegetation ! green (cg).......fraction of green leaf area ! chil (cg).......leaf orientation factor ! vcover(cg).......fraction of vegetation cover ! soref (vnt)......ground albedo ! chil (cg).......leaf orientation factor ! cosz.............cosine of solar zenith angle ! tf...............water freezing temperature ! tg...............ground temperature ! tc...............canopy leaf temperature ! capac(cg)........water store capacity of leaves ! stefan...........stefan-boltsman constant !----------------------------------------------------------------------- ! in-subr. parameters !----------------------------------------------------------------------- ! albedo(cg,vnt,bd) !----------------------------------------------------------------------- ! output parameters !----------------------------------------------------------------------- ! extk(cg,vnt,bd)..extinction coefficient ! passed to subr.raduse through radsave ! radfac(cg,vn,bd).fractions of downward solar radiation at surface ! passed to subr.raduse ! salb(vn,bd)......surface albedo ! passed to subr.spmrad ! tgeff............effective ground temperature ! passed to subr.spmrad ! thermk...........canopy emissivity ! radsav(1)........beam extinction coefficient (par) ! radsav(2)........diffuse extinction coefficient (par) ! closs............radiation loss from canopy ! gloss............radiation loss from ground !----------------------------------------------------------------------- ! ! ityp.......Numero das classes de solo 13 ! imon.......Numero maximo de meses no ano (12) ! icg........Parametros da vegetacao (icg=1 topo e icg=2 base) ! iwv........Compriment de onda iwv=1=visivel, iwv=2=infravermelho ! proximo, iwv=3 infravermelho termal ! ibd........Estado da vegetacao ibd=1 verde / ibd=2 seco ! ncols......Number of grid points on a gaussian latitude circle ! mon........Number of month at year (1-12) ! nmax ! itype......Classe de textura do solo ! satcap.....saturation liquid water capacity (m) ! p1f........ ! p2f........ ! zlwup......zlwup(i)= stefan*( fac1(i)*tc4(i)+ & ! (1.0 -vcover(i,1)*(1.0 -thermk(i)))*fac2(i)*tg4(i)) ! nsx........ ! INTEGER, INTENT(IN ) :: ncols INTEGER, INTENT(INOUT) :: mon(ncols) INTEGER, INTENT(IN ) :: nmax INTEGER, INTENT(IN ) :: itype (ncols) REAL(KIND=r8), INTENT(IN ) :: tc (ncols) REAL(KIND=r8), INTENT(IN ) :: tg (ncols) REAL(KIND=r8), INTENT(IN ) :: capac (ncols,2) REAL(KIND=r8), INTENT(INOUT ) :: satcap(ncols,icg) REAL(KIND=r8), INTENT(INOUT ) :: extk (ncols,icg,iwv,ibd) REAL(KIND=r8), INTENT(INOUT ) :: radfac(ncols,icg,iwv,ibd) REAL(KIND=r8), INTENT(INOUT ) :: closs (ncols) REAL(KIND=r8), INTENT(INOUT ) :: gloss (ncols) REAL(KIND=r8), INTENT(INOUT ) :: thermk(ncols) REAL(KIND=r8), INTENT(INOUT ) :: p1f (ncols) REAL(KIND=r8), INTENT(INOUT ) :: p2f (ncols) REAL(KIND=r8), INTENT(INOUT ) :: zlwup (ncols) REAL(KIND=r8), INTENT(INOUT ) :: salb (ncols,2,2) REAL(KIND=r8), INTENT(INOUT ) :: tgeff (ncols) REAL(KIND=r8), INTENT(IN ) :: cosz (ncols) INTEGER, INTENT(IN ) :: nsx (ncols) INTEGER, INTENT(IN ) :: latitu REAL(KIND=r8) :: zlt2 (ncols,icg) REAL(KIND=r8) :: vcover (ncols,icg) REAL(KIND=r8) :: f (ncols) REAL(KIND=r8) :: deltg (ncols) REAL(KIND=r8) :: fmelt (ncols) REAL(KIND=r8) :: depcov(ncols) REAL(KIND=r8) :: scov (ncols) REAL(KIND=r8) :: scov2 (ncols) REAL(KIND=r8) :: tc4 (ncols) REAL(KIND=r8) :: tg4 (ncols) REAL(KIND=r8) :: fac1 (ncols) REAL(KIND=r8) :: fac2 (ncols) REAL(KIND=r8) :: zkat (ncols) INTEGER, PARAMETER :: nk=3 REAL(KIND=r8) :: temp(nmax,18) REAL(KIND=r8) :: xmi1(nmax,nk) INTEGER :: i INTEGER :: ntyp(ncols) INTEGER :: monx(ncols) INTEGER :: jj INTEGER :: i1 INTEGER :: ml(nmax) INTEGER :: k1 INTEGER :: k2 INTEGER :: ik REAL(KIND=r8) :: capaci ! REAL(KIND=r8) :: xf ! REAL(KIND=r8) :: xf2 ! REAL(KIND=r8) :: sc1 ! REAL(KIND=r8) :: sc2 REAL(KIND=r8) :: xm1 ! REAL(KIND=r8) :: xm2 REAL(KIND=r8) :: xtm1 REAL(KIND=r8) :: xtm2 REAL(KIND=r8) :: stbi LOGICAL :: flagtyp(nmax) LOGICAL :: flagscov(nmax) DO i = 1, nmax zlt2 (i,1) = zlt_gbl (i,latitu,1) !zlt (itype(i),mon(i),1) zlt2 (i,2) = zlt_gbl (i,latitu,2) !zlt (itype(i),mon(i),2) vcover (i,1) = vcover_gbl (i,latitu,1) !xcover(itype(i),mon(i),1) vcover (i,2) = vcover_gbl (i,latitu,2) !xcover(itype(i),mon(i),2) f(i)= MAX ( cosz(i), 0.01746_r8 ) END DO ! ! maximum water storage values. ! DO i = 1, nmax deltg(i)=tf-tg(i) fmelt(i)=1.0_r8 IF (ABS(deltg(i)) < 0.5_r8 .AND. deltg(i) > 0.0_r8) THEN fmelt(i)=0.6_r8 END IF END DO ntyp=itype DO i = 1, nmax !ntyp=itype(i) satcap(i,1)=zlt2(i,1)*1.0e-4_r8 satcap(i,2)=zlt2(i,2)*1.0e-4_r8 depcov(i )=MAX(0.0_r8 ,capac(i,2)*5.0_r8 -z1(ntyp(i),mon(i))) depcov(i )=MIN(depcov(i),(z2(ntyp(i),mon(i))-z1(ntyp(i),mon(i)))*0.95_r8 ) satcap(i,1)=satcap(i,1) & *(1.0_r8 -depcov(i)/(z2(ntyp(i),mon(i))-z1(ntyp(i),mon(i)))) END DO DO i = 1, nmax scov(i)=0.0_r8 IF (tc(i) <= tf) THEN scov(i)= MIN( 0.5_r8 , capac(i,1)/satcap(i,1)) END IF END DO capaci=1.0_r8 /0.004_r8 DO i = 1, nmax IF (tg(i) > tf) THEN scov2(i)=0.0_r8 ELSE scov2(i)=MIN( 1.0_r8 , capac(i,2)*capaci) END IF END DO ! ! terms which multiply incoming short wave fluxes ! to give absorption of radiation by canopy and ground ! monx = mon DO i = 1, nmax IF (fmelt(i) == 1.0_r8) THEN ml(i) = 1 ELSE ml(i) = 2 END IF END DO ntyp=itype DO i = 1, nmax mon(i) = monx(i) flagtyp(i) = .TRUE. IF (ntyp(i) == 13) ntyp(i) = 11 IF (ntyp(i) == 12 .AND. nsx(i) > 0) THEN ntyp(i) = 13 mon(i) = nsx(i) IF (nsx(i) == 1 .AND. (monx(i) >= 9 .AND. monx(i) <= 11)) mon(i) = 7 flagtyp(i) = .FALSE. END IF END DO DO jj = 1, nk DO i=1, nmax xmi1(i,jj) = xmiu(mon(i),jj) END DO END DO DO jj = 1, nk DO i=1, nmax IF (.NOT.flagtyp(i))xmi1(i,jj) = xmiw(mon(i),jj) END DO END DO ! ! snow free case ! DO i = 1, nmax flagscov(i) = scov(i) < 0.025_r8 .AND. scov2(i) < 0.025_r8 END DO DO i1 = 1, 9 DO i = 1, nmax IF (flagscov(i)) THEN temp(i,i1) = cledir(ntyp(i),mon(i),i1,1) + cledir(ntyp(i),mon(i),i1,2) & * f(i) + cledir(ntyp(i),mon(i),i1,3) * (f(i)*f(i)) temp(i,i1+9) = cledfu(ntyp(i),mon(i),i1) END IF END DO END DO flagscov = .NOT. flagscov DO i1 = 1, 9 DO i = 1, nmax IF (flagscov(i)) THEN ! ! with snow cover ! temp(i,i1) = cedir(ntyp(i),mon(i),i1,1) + f(i) * & cedir(ntyp(i),mon(i),i1,2) + cedir(ntyp(i),mon(i),i1,3) * (f(i)*f(i)) temp(i,i1+9) = cedfu(ntyp(i),mon(i),i1) END IF END DO END DO DO i1 = 1, 6 DO i = 1, nmax IF (flagscov(i) .AND. ntyp(i) == 11) THEN !sc2 = scov2(i) * scov2(i) !sc1 = scov2(i) temp(i,i1)=cedir2(ml(i),ntyp(i),mon(i),i1,nk,1)+ & cedir2(ml(i),ntyp(i),mon(i),i1,nk,2) & *scov2(i) + cedir2(ml(i),ntyp(i),mon(i),i1,nk,3) *(scov2(i) * scov2(i)) + temp(i,i1) temp(i,i1+9) = cedfu2(ml(i),ntyp(i),mon(i),i1,1) + & cedfu2(ml(i),ntyp(i),mon(i),i1,2) & * scov2(i) + cedfu2(ml(i),ntyp(i),mon(i),i1,3) * (scov2(i) * scov2(i)) + temp(i,i1+9) END IF END DO END DO DO i = 1, nmax IF (flagscov(i) .AND. ntyp(i) /= 11) THEN k2 = 1 k1 = 2 DO ik = nk, 1, -1 IF (f(i) >= xmi1(i,ik)) THEN CONTINUE ELSE k1 = ik + 1 k2 = ik EXIT END IF END DO !xm2 = xmi1(mon(i),k2) IF (k1 <= nk) xm1 = xmi1(i,k1) ! ! snow cover at 1st layer ! IF (scov(i) > 0.025_r8) THEN !sc2 = scov(i) * scov(i) !sc1 = scov(i) IF (k2 >= nk .OR. k2 <= 1) THEN DO i1 = 1, 6 temp(i,i1)=cedir1(ml(i),ntyp(i),mon(i),i1,k2,1)+ & cedir1(ml(i),ntyp(i),mon(i),i1,k2,2)*scov(i) + & cedir1(ml(i),ntyp(i),mon(i),i1,k2,3)*(scov(i) * scov(i)) + temp(i,i1) END DO ELSE DO i1 = 1, 6 xtm1=cedir1(ml(i),ntyp(i),mon(i),i1,k1,1)+ & cedir1(ml(i),ntyp(i),mon(i),i1,k1,2)*scov(i) + & cedir1(ml(i),ntyp(i),mon(i),i1,k1,3)*(scov(i) * scov(i)) xtm2=cedir1(ml(i),ntyp(i),mon(i),i1,k2,1)+ & cedir1(ml(i),ntyp(i),mon(i),i1,k2,2)*scov(i)+ & cedir1(ml(i),ntyp(i),mon(i),i1,k2,3) *(scov(i) * scov(i)) temp(i,i1) = (xtm1*((xmi1(i,k2))-f(i))+xtm2*(f(i)-xm1))/((xmi1(i,k2))-xm1) & + temp(i,i1) END DO END IF DO i1 = 1, 6 temp(i,i1+9) = cedfu1(ml(i),ntyp(i),mon(i),i1,1) + & cedfu1(ml(i),ntyp(i),mon(i),i1,2)*scov(i) + & cedfu1(ml(i),ntyp(i),mon(i),i1,3) * (scov(i) * scov(i)) + temp(i,i1+9) END DO END IF ! ! snow cover on ground ! IF (scov2(i) > 0.025_r8) THEN !sc2 = scov2(i) * scov2(i) !sc1 = scov2(i) IF (k2 >= nk .OR. k2 <= 1) THEN DO i1 = 1, 6 temp(i,i1)=cedir2(ml(i),ntyp(i),mon(i),i1,k2,1)+ & cedir2(ml(i),ntyp(i),mon(i),i1,k2,2)*scov2(i) + & cedir2(ml(i),ntyp(i),mon(i),i1,k2,3)*(scov2(i) * scov2(i)) + temp(i,i1) END DO ELSE DO i1 = 1, 6 xtm1=cedir2(ml(i),ntyp(i),mon(i),i1,k1,1)+ & cedir2(ml(i),ntyp(i),mon(i),i1,k1,2)*scov2(i) + & cedir2(ml(i),ntyp(i),mon(i),i1,k1,3) *(scov2(i) * scov2(i)) xtm2=cedir2(ml(i),ntyp(i),mon(i),i1,k2,1)+ & cedir2(ml(i),ntyp(i),mon(i),i1,k2,2)*scov2(i)+ & cedir2(ml(i),ntyp(i),mon(i),i1,k2,3) *(scov2(i) * scov2(i)) temp(i,i1) = (xtm1*((xmi1(i,k2))-f(i))+xtm2*(f(i)-xm1))/((xmi1(i,k2))-xm1) & + temp(i,i1) END DO END IF DO i1 = 1, 6 temp(i,i1+9) = cedfu2(ml(i),ntyp(i),mon(i),i1,1) + & cedfu2(ml(i),ntyp(i),mon(i),i1,2)* scov2(i) + & cedfu2(ml(i),ntyp(i),mon(i),i1,3) * (scov2(i) * scov2(i)) + temp(i,i1+9) END DO END IF END IF END DO !500 CONTINUE DO i = 1, nmax radfac(i,1,1,2) = temp(i,10) radfac(i,1,2,2) = temp(i,11) radfac(i,2,1,2) = temp(i,12) radfac(i,2,2,2) = temp(i,13) salb(i,1,2) = temp(i,14) salb(i,2,2) = temp(i,15) p2f(i) = temp(i,16) extk(i,1,1,2) = temp(i,17) extk(i,2,1,2) = temp(i,18) radfac(i,1,1,1) = temp(i,1) radfac(i,1,2,1) = temp(i,2) radfac(i,2,1,1) = temp(i,3) radfac(i,2,2,1) = temp(i,4) salb(i,1,1) = temp(i,5) salb(i,2,1) = temp(i,6) p1f(i) = temp(i,7) extk(i,1,1,1) = temp(i,8) / f(i) extk(i,2,1,1) = temp(i,9) / f(i) extk(i,1,3,1) = cether(ntyp(i),mon(i),1) extk(i,1,3,2) = cether(ntyp(i),mon(i),2) extk(i,2,3,1) = cether(ntyp(i),mon(i),1) extk(i,2,3,2) = cether(ntyp(i),mon(i),2) END DO mon = monx ! ! long-wave flux terms from canopy and ground ! stbi=1.0_r8 /stefan DO i = 1, nmax tc4(i)=tc(i)*tc(i)*tc(i)*tc(i) tg4(i)=tg(i)*tg(i)*tg(i)*tg(i) !ntyp=itype(i) zkat(i)=extk(i,1,3,2)*zlt2(i,1)/vcover(i,1) zkat(i)=MAX(expcut ,-zkat(i) ) zkat(i)=MIN(-10.0e-5_r8, zkat(i) ) thermk(i)=EXP(zkat(i)) fac1 (i)=vcover(i,1)*( 1.0_r8 -thermk(i) ) fac2 (i)=1.0_r8 closs(i)=2.0_r8 *fac1(i)*stefan*tc4(i) closs(i)=closs(i)-fac2(i)*fac1(i)*stefan*tg4(i) gloss(i)= fac2(i)*stefan*tg4(i) gloss(i)= gloss(i)-fac1(i)*fac2(i)*stefan*tc4(i) ! ! effective surface radiative temperature ( tgeff ) ! zlwup(i) = stefan*( fac1(i)*tc4(i) + (1.0_r8 - vcover(i,1) * (1.0_r8 -thermk(i)))*fac2(i)*tg4(i)) tgeff(i)=SQRT ( SQRT (( zlwup(i)*stbi ))) END DO END SUBROUTINE radalb ! ! ! SUBROUTINE Phenology(latco,nCols,nmax,itype,colrad2, month2, xday, idatec,nsx) IMPLICIT NONE INTEGER , INTENT(IN ) :: latco INTEGER , INTENT(IN ) :: nCols INTEGER , INTENT(IN ) :: nmax INTEGER , INTENT(in ) :: itype (ncols) REAL(KIND=r8), INTENT(in ) :: colrad2 (ncols) INTEGER , INTENT(in ) :: month2 (ncols) REAL(KIND=r8), INTENT(in ) :: xday INTEGER , INTENT(in ) :: idatec(4) INTEGER , INTENT(inout) :: nsx(ncols) IF(schemes==1)CALL CopySurfaceData(itype,month2,colrad2,xday,idatec,nsx,nCols,nmax,latco) IF(schemes==2) PRINT*,'ERROR schemes 2' END SUBROUTINE Phenology ! vegin :reads vegetation morphoLOGICAL and physioLOGICAL data. SUBROUTINE vegin ( si1 , sl1) REAL(KIND=r8), INTENT(in ) :: si1 REAL(KIND=r8), INTENT(in ) :: sl1 INTEGER, PARAMETER :: njj=6,nj=9, nk=3,ild=2 ! Vegetation and Soil Parameters REAL (KIND=r4) rstpar_r4(ityp,icg,iwv), & chil_r4(ityp,icg), & topt_r4(ityp,icg), & tll_r4(ityp,icg), & tu_r4(ityp,icg), & defac_r4(ityp,icg), & ph1_r4(ityp,icg), & ph2_r4(ityp,icg), & rootd_r4(ityp,icg), & bee_r4(ityp), & phsat_r4(ityp), & satco_r4(ityp), & poros_r4(ityp), & zdepth_r4(ityp,idp), & green_r4(ityp,imon,icg), & xcover_r4(ityp,imon,icg), & zlt_r4(ityp,imon,icg), & x0x_r4(ityp,imon),& xd_r4(ityp,imon), & z2_r4 (ityp,imon), & z1_r4 (ityp,imon), & xdc_r4 (ityp,imon), & xbc_r4 (ityp,imon) REAL(KIND=r4) :: cedfu_r4 (ityp,imon,nj), & cedir_r4 (ityp,imon,nj,3), & cedfu1_r4(2,ityp,imon,njj,3), & cedir1_r4(2,ityp,imon,njj,nk,3), & cedfu2_r4(2,ityp,imon,njj,3), & cedir2_r4(2,ityp,imon,njj,nk,3), & cledfu_r4(ityp,imon,nj), & cledir_r4(ityp,imon,nj,3), & cether_r4(ityp,imon,2), & xmiu_r4 (imon,nk), & xmiw_r4 (imon,nk) INTEGER :: jcg INTEGER :: jmon INTEGER :: jtyp INTEGER :: iv INTEGER :: im INTEGER :: i REAL(KIND=r8) :: f0001 REAL(KIND=r8) :: yhil (2) REAL(KIND=r8) :: dz REAL(KIND=r8) :: dzcut REAL(KIND=r8) :: tvsgm INTEGER :: ierr ! ALLOCATE(cedfu (13,12, 9) ) ALLOCATE(cedir (13,12, 9,3) ) ALLOCATE(cedfu1( 2,13,12,6,3) ) ALLOCATE(cedir1( 2,13,12,6,3,3) ) ALLOCATE(cedfu2( 2,13,12,6,3) ) ALLOCATE(cedir2( 2,13,12,6,3,3) ) ALLOCATE(cledfu(13,12, 9) ) ALLOCATE(cledir(13,12, 9,3) ) ALLOCATE(xmiu (12, 3) ) ALLOCATE(cether(13,12, 2) ) ALLOCATE(xmiw (12, 3) ) ! ALLOCATE(ystpar(2,3) ) ALLOCATE(yopt (2) ) ALLOCATE(yll (2) ) ALLOCATE(yu (2) ) ALLOCATE(yefac (2) ) ALLOCATE(yh1 (2) ) ALLOCATE(yh2 (2) ) ALLOCATE(yootd (2) ) ALLOCATE(yreen (12,2) ) ALLOCATE(ycover(12,2) ) ALLOCATE(ylt (12,2) ) ! ! vegetation and soil parameters ! ALLOCATE(rstpar_fixed(ityp,icg,iwv) ) ALLOCATE(chil_fixed (ityp,icg) ) ALLOCATE(topt_fixed (ityp,icg) ) ALLOCATE(tll_fixed (ityp,icg) ) ALLOCATE(tu_fixed (ityp,icg) ) ALLOCATE(defac_fixed (ityp,icg) ) ALLOCATE(ph1_fixed (ityp,icg) ) ALLOCATE(ph2_fixed (ityp,icg) ) ALLOCATE(rootd (ityp,icg) ) ALLOCATE(bee (ityp) ) ALLOCATE(phsat (ityp) ) ALLOCATE(satco (ityp) ) ALLOCATE(poros (ityp) ) ALLOCATE(zdepth(ityp,idp) ) ALLOCATE(green_fixed (ityp,imon,icg) ) ALLOCATE(xcover_fixed(ityp,imon,icg) ) ALLOCATE(zlt_fixed (ityp,imon,icg) ) ALLOCATE(x0x (ityp,imon) ) ALLOCATE(xd (ityp,imon) ) ALLOCATE(z2 (ityp,imon) ) ALLOCATE(z1 (ityp,imon) ) ALLOCATE(xdc (ityp,imon) ) ALLOCATE(xbc (ityp,imon) ) ALLOCATE(zlt (ityp,imon,icg) ) ALLOCATE(xcover (ityp, imon, icg)) ALLOCATE(ph2 (ityp,icg)) ALLOCATE(ph1 (ityp,icg)) ALLOCATE(green(ityp,imon,icg)) ALLOCATE(defac(ityp,icg)) ALLOCATE(tu (ityp,icg)) ALLOCATE(tll (ityp,icg)) ALLOCATE(topt (ityp,icg)) ALLOCATE(rstpar(ityp,icg,iwv)) ALLOCATE(chil (ityp,icg)) OPEN(UNIT=nfsibd, FILE=TRIM(fNameSibVeg),FORM='UNFORMATTED', ACCESS='SEQUENTIAL',& ACTION='READ',STATUS='OLD', IOSTAT=ierr) IF (ierr /= 0) THEN WRITE(UNIT=nfprt,FMT="('**(ERROR)** Open file ',a,' returned iostat=',i4)") & TRIM(fNameSibVeg), ierr STOP "**(ERROR)**" END IF OPEN (UNIT=nfalb, FILE=TRIM(fNameSibAlb),FORM='UNFORMATTED', ACCESS='SEQUENTIAL', & ACTION='READ',STATUS='OLD', IOSTAT=ierr) IF (ierr /= 0) THEN WRITE(UNIT=nfprt,FMT="('**(ERROR)** Open file ',a,' returned iostat=',i4)") & TRIM(fNameSibAlb), ierr STOP "**(ERROR)**" END IF READ (UNIT=nfsibd) rstpar_r4, chil_r4, topt_r4, tll_r4, tu_r4, defac_r4, ph1_r4, ph2_r4, & rootd_r4, bee_r4, phsat_r4, satco_r4, poros_r4, zdepth_r4 READ (UNIT=nfsibd) green_r4, xcover_r4, zlt_r4, x0x_r4, xd_r4, z2_r4, z1_r4, xdc_r4, xbc_r4 rstpar_fixed = rstpar_r4 chil_fixed = chil_r4 topt_fixed = topt_r4 tll_fixed = tll_r4 tu_fixed = tu_r4 defac_fixed = defac_r4 ph1_fixed = ph1_r4 ph2_fixed = ph2_r4 rootd = rootd_r4 bee = bee_r4 phsat = phsat_r4 satco = satco_r4 poros = poros_r4 zdepth = zdepth_r4 green_fixed = green_r4 xcover_fixed = xcover_r4 zlt_fixed = zlt_r4 x0x = x0x_r4 xd = xd_r4 z2 = z2_r4 z1 = z1_r4 xdc = xdc_r4 xbc = xbc_r4 READ(UNIT=nfalb) cedfu_r4, cedir_r4, cedfu1_r4, cedir1_r4, cedfu2_r4, cedir2_r4, & cledfu_r4, cledir_r4, xmiu_r4, cether_r4, xmiw_r4 cedfu = REAL(cedfu_r4 ,KIND=r8) cedir = REAL(cedir_r4 ,KIND=r8) cedfu1 = REAL(cedfu1_r4,KIND=r8) cedir1 = REAL(cedir1_r4,KIND=r8) cedfu2 = REAL(cedfu2_r4,KIND=r8) cedir2 = REAL(cedir2_r4,KIND=r8) cledfu = REAL(cledfu_r4,KIND=r8) cledir = REAL(cledir_r4,KIND=r8) cether = REAL(cether_r4,KIND=r8) xmiu = REAL(xmiu_r4 ,KIND=r8) xmiw = REAL(xmiw_r4 ,KIND=r8) REWIND nfsibd REWIND nfalb f0001=0.0001_r8 DO jcg =1, 2 DO jmon=1,12 DO jtyp=1,ityp green_fixed(jtyp,jmon,jcg)=MAX(f0001,green_fixed(jtyp,jmon,jcg)) END DO END DO END DO DO iv =1, 2 jtyp = 12 IF (iv.EQ.2) jtyp = 13 DO im = 1,3 ystpar(iv,im)=rstpar_fixed(jtyp,1,im) END DO yhil (iv)=chil_fixed (jtyp,1) yopt (iv)=topt_fixed (jtyp,1) yll (iv)=tll_fixed (jtyp,1) yu (iv)=tu_fixed (jtyp,1) yefac (iv)=defac_fixed (jtyp,1) yootd (iv)=rootd (jtyp,1) yh1 (iv)=ph1_fixed (jtyp,1) yh2 (iv)=ph2_fixed (jtyp,1) END DO DO jmon=1,12 DO iv = 1,2 jtyp = 12 IF (iv.EQ.2) jtyp = 13 ylt (jmon,iv)=zlt_fixed(jtyp,jmon,1) yreen (jmon,iv)=green_fixed (jtyp,jmon,1) ycover(jmon,iv)=xcover_fixed(jtyp,jmon,1) END DO END DO DO iv = 1,2 DO im = 1,3 rstpar_fixed(13,iv,im) = 1000.0_r8 END DO chil_fixed (13,iv) = 0.01_r8 topt_fixed (13,iv) = 310.0_r8 tll_fixed (13,iv) = 300.0_r8 tu_fixed (13,iv) = 320.0_r8 defac_fixed (13,iv) = 0.0_r8 ph1_fixed (13,iv) = 3.0_r8 ph2_fixed (13,iv) = 6.0_r8 rootd (13,iv) = 2.1_r8 END DO bee(13) = 4.8_r8 phsat(13) = -0.167_r8 satco(13) = 0.762e-4_r8 poros(13) = 0.4352_r8 DO i = 1, imon zlt_fixed(13,i,1) = 0.0001_r8 zlt_fixed(13,i,2) = 0.0001_r8 z2(13,i) = 0.1_r8 z1(13,i) = 0.0001_r8 xcover_fixed(13,i,1) = 0.0001_r8 xcover_fixed(13,i,2) = 0.0001_r8 x0x(13,i) = 0.01_r8 xd(13,i) = 0.0004_r8 xbc(13,i) = 35461.0_r8 xdc(13,i) = 28.5_r8 END DO zdepth(13,1) = 1.0_r8 zdepth(13,2) = 1.0_r8 zdepth(13,3) = 1.0_r8 ! tvsgm - Global Mean Surface Virtual Temperature ! dz - mean height of the first model layer tvsgm=288.16_r8 dz=(gasr*tvsgm/grav)*LOG(si1/sl1) ! Forest !dzcut=0.75_r8*dz dzcut=0.6_r8*dz xd(1,1:imon)=MIN(xd(1,1:imon),dzcut) ! Other ! SiB calibration values ! 45 m - height of the first tower level of measurements ! 27 m - maximum calibrated displacement height dzcut=(27.0_r8/45.0_r8)*dz xd(2:ityp,1:imon)=MIN(xd(2:ityp,1:imon),dzcut) END SUBROUTINE vegin ! !------------------------------------------------------------ ! SUBROUTINE re_assign_sib_soil_prop(iMax , & ! IN jMax , & ! IN npatches , & ! IN imask , & ! INOUT veg_type ) ! IN INTEGER, INTENT(IN ) :: iMax INTEGER, INTENT(IN ) :: jMax INTEGER, INTENT(IN ) :: npatches INTEGER(KIND=i8), INTENT(INOUT) :: imask (imax,jmax ) REAL(KIND=r8) , INTENT(IN ) :: veg_type (imax,jmax,npatches) REAL(KIND=r8) :: GSWP_soil_input_data(10,12 ) INTEGER :: nnn INTEGER :: i INTEGER :: j ! !-------------------------------Soil data from GSWP-2 ------------------------------------- ! DATA GSWP_soil_input_data/ & !1 2 3 4 5 6 7 8 9 10 !SAND(%) SILT CLAY QUARTZ Wfc Wwilt Wsat b PHIsat Ksat 92.0_r8, 5.0_r8, 3.0_r8,0.92_r8,0.132_r8,0.033_r8,0.373_r8, 3.30_r8,-0.05_r8,2.45E-05_r8,&!1 Sand 82.0_r8,12.0_r8, 6.0_r8,0.82_r8,0.156_r8,0.051_r8,0.386_r8, 3.80_r8,-0.07_r8,1.75E-05_r8,&!2 Loamy Sand 58.0_r8,32.0_r8,10.0_r8,0.60_r8,0.196_r8,0.086_r8,0.419_r8, 4.34_r8,-0.16_r8,8.35E-06_r8,&!3 Sandy Loam 10.0_r8,85.0_r8, 5.0_r8,0.25_r8,0.361_r8,0.045_r8,0.471_r8, 3.63_r8,-0.84_r8,1.10E-06_r8,&!4 Silt Loam 17.0_r8,70.0_r8,13.0_r8,0.40_r8,0.270_r8,0.169_r8,0.476_r8, 5.25_r8,-0.65_r8,2.36E-06_r8,&!5 Loam 58.0_r8,15.0_r8,27.0_r8,0.60_r8,0.253_r8,0.156_r8,0.412_r8, 7.32_r8,-0.12_r8,6.31E-06_r8,&!6 Sandy Clay Loam 32.0_r8,34.0_r8,34.0_r8,0.10_r8,0.301_r8,0.211_r8,0.447_r8, 8.34_r8,-0.28_r8,2.72E-06_r8,&!7 Silty Clay Loam 10.0_r8,56.0_r8,34.0_r8,0.35_r8,0.334_r8,0.249_r8,0.478_r8, 8.41_r8,-0.63_r8,1.44E-06_r8,&!8 Clay Loam 52.0_r8, 6.0_r8,42.0_r8,0.52_r8,0.288_r8,0.199_r8,0.415_r8, 9.70_r8,-0.12_r8,4.25E-06_r8,&!9 Sandy Clay 6.0_r8,47.0_r8,47.0_r8,0.10_r8,0.363_r8,0.286_r8,0.478_r8,10.78_r8,-0.58_r8,1.02E-06_r8,&!10 Silty Clay 22.0_r8,20.0_r8,58.0_r8,0.25_r8,0.353_r8,0.276_r8,0.450_r8,12.93_r8,-0.27_r8,1.33E-06_r8,&!11 Clay 43.0_r8,39.0_r8,18.0_r8,0.10_r8,0.250_r8,0.148_r8,0.437_r8, 5.96_r8,-0.24_r8,4.66E-06_r8 /!12 Silt ! !-srf: avoid this for now, only use it when all arrays above are used like: ! bee(int(soil_type(lon,lat))) and not the usual way: bee(isurf(lon,lat))), ! where isurf is the vegetation index ! !GO TO 332 DO nnn = 1,12 ! ! sslfc(nnn) = GSWP_soil_input_data(5,nnn) !not in use ! sswlts(nnn) = GSWP_soil_input_data(6,nnn) !not in use ! sswlts(nnn) = max(0.06_r8,GSWP_soil_input_data(6,n) !not in use nn) ! ! print*,nnn,'poros bee phsat satco' ! print*,poros(nnn) , GSWP_soil_input_data(7,nnn) ! print*,bee(nnn) ,GSWP_soil_input_data(8,nnn) ! print*,phsat(nnn) ,GSWP_soil_input_data(9,nnn) ! print*,satco(nnn) ,GSWP_soil_input_data(10,nnn) ! poros(nnn) = GSWP_soil_input_data(7,nnn) ! bee (nnn) = GSWP_soil_input_data(8,nnn) ! phsat(nnn) = GSWP_soil_input_data(9,nnn) ! satco(nnn) = GSWP_soil_input_data(10,nnn) END DO !332 continue ! !- for now, set isurf(:,:) as the veg data of the predominant biome: ! DO j=1,jMax DO i= 1,iMax !imask(i,j) = 0 => ocean / imask(i,j) = 13 => ice IF (imask(i,j) > 0_i8 .and. imask(i,j) < 13_i8) THEN !print*,'1',i,j,int(veg_type(i,j,2)),imask(i,j) imask(i,j) = int(veg_type(i,j,2)) END IF END DO END DO ! !stop 44433 !srf- original SSIB from MCGA requires 13 soil classes, while USDA/GSWP2 has only 12 !srf- the soil class 13 is not changed here (see vegin.f90) ! bee(13) = 4.8_r8 ! phsat(13) = -0.167_r8 ! satco(13) = 0.762e-4_r8 ! poros(13) = 0.4352_r8 ! zdepth(13,1) = 1.0_r8 ! zdepth(13,2) = 1.0_r8 ! zdepth(13,3) = 1.0_r8 ! RETURN END SUBROUTINE re_assign_sib_soil_prop ! wheat :determine wheat phenology for latitude and julian day?. SUBROUTINE wheat (latitu,itype ,nmax ,colrad ,month ,xday ,yrl , & idatec,monl ,nsx ) !========================================================================== !========================================================================== ! ityp.......Numero das classes de solo vegetacao 13 ! imon.......Number max of month at year (12) ! icg........Parameters of vagetation (icg=1 top e icg=2 bottom) ! iwv........Comprimento de onda iwv=1=visivel, iwv=2=infravermelho ! proximo, iwv=3 infravermelho termal ! nmax ! itype......Classe de textura do solo ou classe de vegetacao ! jmax.......Number of grid points on a gaussian longitude circle ! colrad.....colatitude ! month......Number of month at year (1-12) ! xday.......is julian day - 1 with fraction of day ! pie........Constante Pi=3.1415926e0 ! yrl........length of year in days ! idatec.....idatec(1)=current hour of ! idatec(2)=current day of month. ! idatec(3)=current month of year. ! idatec(4)=current year. ! monl.......length of each month in days ! ystpar.....Coefficints related to par influence on ! stomatal resistance ! yopt.......Temperatura ideal de funcionamento estomatico ! yll........Temperatura minima de funcionamento estomatico ! yu.........Temperatura maxima de funcionamento estomatico ! yefac......Parametro de deficit de pressao de vapor d'agua ! yh1........Coeficiente para o efeito da agua no solo ! yh2........Potencial de agua no solo para ponto de Wilting ! rstpar.....Coefficints related to par influence on ! stomatal resistance ! chil.......Leaf orientation parameter ! topt.......Temperatura ideal de funcionamento estomatico ! tll........Temperatura minima de funcionamento estomatico ! tu.........Temperatura maxima de funcionamento estomatico ! defac......Parametro de deficit de pressao de vapor d'agua ! ph1........Coeficiente para o efeito da agua no solo ! ph2........Potencial de agua no solo para ponto de Wilting ! green......Fraction of grenn leaves ! xcover(iv).Fracao de cobertura de vegetacao iv=1 Top ! xcover(iv).Fracao de cobertura de vegetacao iv=2 Bottom ! nsx........phenology dates to fall within one year period !========================================================================== INTEGER , PARAMETER :: itveg = 13 ! Number of Vegetation Types INTEGER , PARAMETER :: isoil = 13 ! Number of Vegetation Types INTEGER , PARAMETER :: imon = 12 ! Number of Months with Defined Vegetation Types INTEGER , PARAMETER :: icg = 2 ! Number of Vegetation Parameters INTEGER , PARAMETER :: iwv = 3 ! Number of Radiation Wavelengths INTEGER , PARAMETER :: idp = 3 ! Number of Soil Layer Parameters INTEGER , PARAMETER :: ibd = 2 ! Number of Vegetation Stage INTEGER, INTENT(in ) :: nmax INTEGER, INTENT(in ) :: latitu INTEGER, INTENT(in ) :: itype (nmax) REAL(KIND=r8), INTENT(in ) :: colrad(nmax) INTEGER, INTENT(in ) :: month (nmax) REAL(KIND=r8), INTENT(in ) :: xday REAL(KIND=r8), INTENT(in ) :: yrl INTEGER, INTENT(in ) :: idatec(4) INTEGER, INTENT(in ) :: monl (12) INTEGER, INTENT(inout) :: nsx(nmax) REAL(KIND=r8) :: rday REAL(KIND=r8) :: thrsh REAL(KIND=r8) :: phi(nmax) REAL(KIND=r8) :: flip REAL(KIND=r8) :: rootgc (nmax) REAL(KIND=r8) :: chilw (nmax) REAL(KIND=r8) :: tlai(nmax) REAL(KIND=r8) :: xcover2(nmax) REAL(KIND=r8) :: grlf (nmax) REAL(KIND=r8) :: diff1 (nmax) REAL(KIND=r8) :: diff2 (nmax) REAL(KIND=r8) :: perc REAL(KIND=r8) :: x1 REAL(KIND=r8) :: xdif1 REAL(KIND=r8) :: xdif2 INTEGER :: i INTEGER :: kold INTEGER :: i1 INTEGER :: ns INTEGER :: mind (nmax) INTEGER :: index (nmax) INTEGER :: icond INTEGER :: kk INTEGER :: mnl REAL(KIND=r8) :: pie=3.1415926e0_r8 REAL(KIND=r8) :: phenst(nmax,9) LOGICAL :: test(nmax) INTEGER, PARAMETER :: iimon=12 REAL(KIND=r8), PARAMETER :: wlai(9)=(/1.0_r8, 2.0_r8, 6.0_r8, 4.0_r8, 3.0_r8, 1.0_r8, 0.01_r8, 0.01_r8, 1.0_r8/) REAL(KIND=r8), PARAMETER :: xgren(iimon+1)=(/0.55_r8,0.68_r8,0.8_r8,0.9_r8,0.9_r8,0.9_r8,0.9_r8,0.81_r8,0.64_r8,& 0.53_r8,0.49_r8,0.48_r8,0.55_r8/) REAL(KIND=r8), PARAMETER :: vlt(iimon+1)=(/1.0_r8,6.0_r8,6.0_r8,6.0_r8,6.0_r8,6.0_r8,6.0_r8,6.0_r8,6.0_r8,3.78_r8,& 1.63_r8,1.0_r8,1.0_r8/) ! INTEGER, SAVE :: kmon(iimon+1) REAL(KIND=r8) :: xgreen(nmax,iimon+1) INTEGER :: kmon(imon+1) INTEGER, PARAMETER :: ihead = 3 INTEGER, PARAMETER :: iwheat=12 REAL(KIND=r8), PARAMETER :: syr =365.25e0_r8 REAL(KIND=r8), PARAMETER :: vcv =0.569_r8 ! ! vlt and xgren are assumed to be correct at the beginning of the ! month ! nsx = 0 index= 0 phenst=0.0_r8 ! ! xday is julian day - 1 with fraction of day ! rday=xday ! ! for standard length years, determine the offset for the year ! within the leap year period ! thrsh=-MOD(idatec(4)+3,4)*0.25e0_r8 test=.TRUE. DO i = 1, nmax !pi === 180 !y === x ! ! X = (180 * Y)/pi ! phi(i) = 90.0_r8-180.0e0_r8/pie * colrad(i) ! ! constrain latitude range ! !fixa o valor -55 ou +55 se o valor absoluto da latitude for maior que 55 IF (ABS(phi(i)) > 55.0_r8) phi(i)=SIGN(55.0_r8,phi(i)) !fixa o valor -20 ou +20 se a valor absoluto da latitude for menor que 20 IF (ABS(phi(i)) < 20.0_r8) phi(i)=SIGN(20.0_r8,phi(i)) ENDDO DO i1 = 1, iimon+1 DO i = 1, nmax xgreen(i,i1)=xgren(i1) END DO END DO ! ! search for any wheat vegetation points at this latitude ! if found, set sib parameters for latitude and time of year ! kold=0 DO i1 = 1, iimon kmon(i1)=kold ! ! add extra day for leap years if using standard length year ! IF (MOD(idatec(4),4) == 0 .AND. i1 == 2)kmon(i1)=kmon(i1)+1 kold=kold+monl(i1) END DO DO i = 1, nmax IF (itype(i) /= iwheat) CYCLE flip = 0.0_r8 IF (phi(i)< 0.0e0_r8) flip = yrl/2.0_r8 ! ! determine julian day - 1 for each wheat phenology for this ! latitude. scale by length of year and adjust for south. hem. ! phenst(i,2) = (4.50_r8 * ABS(phi(i)) - 65.0_r8) * (yrl/syr) + flip phenst(i,3) = (4.74_r8 * ABS(phi(i)) - 47.2_r8) * (yrl/syr) + flip phenst(i,4) = (4.86_r8 * ABS(phi(i)) - 31.8_r8) * (yrl/syr) + flip phenst(i,5) = (4.55_r8 * ABS(phi(i)) - 2.0_r8) * (yrl/syr) + flip phenst(i,6) = (4.35_r8 * ABS(phi(i)) + 10.5_r8) * (yrl/syr) + flip phenst(i,7) = phenst(i,6) + 3.0_r8 * (yrl/syr) phenst(i,1) = phenst(i,2) - ABS(5.21_r8 * ABS(phi(i)) - 0.3_r8)*(yrl/syr) phenst(i,9) = phenst(i,1) phenst(i,8) = phenst(i,9) - 5.0_r8*(yrl/syr) END DO DO ns = 1, 9 DO i = 1, nmax IF (itype(i) /= iwheat) CYCLE ! ! constrain phenology dates to fall within one year period ! IF (phenst(i,ns) < 0.0e0_r8) phenst(i,ns) = phenst(i,ns) + yrl IF (phenst(i,ns) > yrl) phenst(i,ns) = phenst(i,ns) - yrl END DO END DO DO i1 = 1, 12 DO i = 1, nmax IF (itype(i) /= iwheat) CYCLE ! ! find month of the head phenology stage for this latitude ! IF (phenst(i,ihead) <= kmon(i1+1)) THEN mind(i) = i1 IF (i1 <= 4) THEN xgreen(i,i1+1) = 0.9_r8 xgreen(i,i1+2) = 0.9_r8 END IF END IF END DO END DO DO ns = 1,8 DO i = 1, nmax IF (itype(i) /= iwheat) CYCLE rootgc(i) = 1.0_r8 chilw(i) =-0.02_r8 tlai(i) = 0.5_r8 grlf(i) = 0.6_r8 xcover2(i)=xcover(iwheat,month(i),1) ! ! find growth stage given latitude and day ! IF(test(i))THEN diff1(i) = phenst(i,ns+1)- phenst(i,ns) diff2(i) = rday- phenst(i,ns) IF ( phenst(i,ns) >= phenst(i,ns+1)) THEN IF ((rday < phenst(i,ns)) .OR. (rday > phenst(i,ns+1))) THEN ! ! phenology stages overlap the end of year? ! icond = 0 IF (rday >= phenst(i,ns) .AND. rday <= yrl ) icond = 1 IF (rday >= thrsh .AND. rday <= phenst(i,ns+1)) icond = 2 IF (icond /= 2) THEN diff1(i) = yrl - phenst(i,ns) + phenst(i,ns+1) diff2(i) = rday - phenst(i,ns) ELSE diff1(i) = yrl - phenst(i,ns) + phenst(i,ns+1) diff2(i) = yrl - phenst(i,ns) + rday END IF END IF IF (icond /= 0) THEN ! ! date found in phenology stage ! perc = diff2(i)/diff1(i) ! ! kk is current month number ! kk=idatec(2) mnl=monl(kk) IF (MOD(idatec(4),4) == 0 .AND. kk == 2)mnl=mnl+1 IF (rday > phenst(i,ihead)) THEN IF (kk /= mind(i)) THEN x1 = vlt(kk) xdif1 = mnl xdif2 = rday - kmon(kk) ELSE x1 = wlai(ihead) xdif1 = kmon(kk+1) - phenst(i,ihead) xdif2 = rday - phenst(i,ihead) END IF tlai(i) = x1 - (x1-vlt(kk+1)) / xdif1 * xdif2 ELSE tlai(i) = perc*(wlai(ns+1)-wlai(ns)) + wlai(ns) END IF IF (rday > phenst(i,ihead+1)) THEN xcover2(i)=vcv + (0.9_r8 - vcv) * (yrl - rday)/(yrl - phenst(i,ihead+1)) ELSE xcover2(i)=0.90_r8*(1.0_r8 - EXP(-tlai(i))) END IF grlf(i) = xgreen(i,kk)-(xgreen(i,kk)-xgreen(i,kk+1))/mnl*(rday-kmon(kk)) rootgc(i) = 2910.0_r8 * (0.5_r8 + 0.5_r8 * tlai(i)/ wlai(ihead) * grlf(i)) IF (ns /= 1 .AND. ns /= 2) chilw(i)=-0.2_r8 test(i)=.FALSE. index(i)=ns END IF END IF END IF END DO END DO DO i = 1, nmax IF (itype(i) /= iwheat) CYCLE nsx(i) = index(i) IF (nsx(i) == 9) nsx(i) = 1 IF (nsx(i) > 6) nsx(i) = 6 vcover_gbl (i,latitu,1) = xcover2(i) !xcover(itype(i),month(i),1) zlt_gbl (i,latitu,1) = tlai(i) !zlt (itype(i),month(i),1) green_gbl (i,latitu,1) = grlf(i) !green (itype(i),month(i),1) chil_gbl (i,latitu,1) = chilw(i) !chil (itype(i),1) topt_gbl (i,latitu,1) = yopt (2) !topt (itype(i),1) tll_gbl (i,latitu,1) = yll (2) !tll (itype(i),1) tu_gbl (i,latitu,1) = yu(2) !tu (itype(i),1) defac_gbl (i,latitu,1) = yefac(2) !defac (itype(i),1) ph1_gbl (i,latitu,1) = yh1 (2) !ph1 (itype(i),1) ph2_gbl (i,latitu,1) = yh2 (2) !ph2 (itype(i),1) rstpar_gbl (i,latitu,1,1)= ystpar(2,1)!rstpar(itype(i),1,1) rstpar_gbl (i,latitu,1,2)= ystpar(2,2)!rstpar(itype(i),1,2) rstpar_gbl (i,latitu,1,3)= ystpar(2,3)!rstpar(itype(i),1,3) END DO RETURN END SUBROUTINE wheat ! sibwet :transform mintz-serafini and national meteoroLOGICAL center fields ! of soil moisture into sib compatible fields of soil moisture. SUBROUTINE sibwet & (ibmax,jbmax,sinp,sinmax,imask,wsib,ssib,mxiter,ibMaxPerJB) ! ! ! piers sellers : 29 april 1987 ! ! ! input : sinp = mintz-serafini or national meteoroLOGICAL ! center soil moisture (mm) ! sinmax = maximum value of sinp (mm) ! wsinp = m-s or nmc fractional wetness ! ms = 1, mintz-serafini ! nmc = 1, national meteoroLOGICAL center ! bee = sib : soil moisture potential factor ! phsat = sib : soil potential at saturation (m) ! zdepth(3)= sib : depth of 3 soil layers (m) ! poros = Porosidade do solo (m"3/m"3) ! ! output : wsibt = sib : fractional wetness ! ssibt = sib : soil moisture content (m) ! psit = sib : soil moisture potential (m) ! factor = sib : extraction factor ! INTEGER, INTENT(in ) :: ibmax INTEGER, INTENT(in ) :: jbmax INTEGER, INTENT(in ) :: mxiter REAL(KIND=r8) , INTENT(in ) :: sinp(ibmax,jbmax) REAL(KIND=r8) , INTENT(in ) :: sinmax ! INTEGER(KIND=i8), INTENT(in ) :: imask (ibmax,jbmax) REAL(KIND=r8) , INTENT(inout ) :: wsib (ibmax,jbmax) REAL(KIND=r8) , INTENT(inout ) :: ssib (ibmax,jbmax) INTEGER , INTENT(in ) :: ibMaxPerJB(jbmax) REAL(KIND=r8) :: sm (ityp,mxiter) REAL(KIND=r8) :: time (ityp,mxiter) REAL(KIND=r8) :: fact (ityp,mxiter) REAL(KIND=r8), PARAMETER :: xph1(13,2) = RESHAPE( & (/-100.0_r8,-190.0_r8,-200.0_r8,-200.0_r8,-200.0_r8,-120.0_r8,-120.0_r8,-120.0_r8,-200.0_r8, & -200.0_r8, -10.0_r8,-190.0_r8, -10.0_r8,-100.0_r8,-190.0_r8,-200.0_r8,-200.0_r8,-200.0_r8, & -120.0_r8,-120.0_r8,-120.0_r8,-200.0_r8,-200.0_r8, -10.0_r8,-190.0_r8, -10.0_r8/), & (/13,2/)) REAL(KIND=r8), PARAMETER :: xph2(13,2) = RESHAPE( & (/-500.0_r8,-250.0_r8,-250.0_r8,-250.0_r8,-250.0_r8,-230.0_r8,-230.0_r8,-280.0_r8,-400.0_r8, & -400.0_r8,-100.0_r8,-250.0_r8,-100.0_r8,-500.0_r8,-250.0_r8,-250.0_r8,-250.0_r8,-250.0_r8, & -230.0_r8,-230.0_r8,-280.0_r8,-400.0_r8,-400.0_r8,-100.0_r8,-250.0_r8,-100.0_r8/) , & (/13,2/)) REAL(KIND=r8) :: tzdep (3) REAL(KIND=r8) :: tzltm (2) REAL(KIND=r8) :: sibmax(ityp) REAL(KIND=r8) :: tphsat REAL(KIND=r8) :: tbee REAL(KIND=r8) :: tporos INTEGER :: imm1 INTEGER :: imm2 INTEGER :: is INTEGER :: im INTEGER :: imm INTEGER :: ivegm REAL(KIND=r8) :: cover REAL(KIND=r8) :: tph1 REAL(KIND=r8) :: tph2 REAL(KIND=r8) :: sref REAL(KIND=r8) :: smin REAL(KIND=r8) :: dssib REAL(KIND=r8) :: dw REAL(KIND=r8) :: times REAL(KIND=r8) :: soilmo REAL(KIND=r8) :: w REAL(KIND=r8) :: rsoilm INTEGER :: iter INTEGER :: latmax INTEGER :: lonmax INTEGER :: lat INTEGER :: lon REAL(KIND=r8) :: tsinp REAL(KIND=r8) :: etp REAL(KIND=r8) :: facmod REAL(KIND=r8) :: ssibt REAL(KIND=r8) :: psit REAL(KIND=r8) :: factor REAL(KIND=r8) :: dt INTEGER :: itsoil INTEGER :: itfac sm =0.0_r8 time=0.0_r8 fact=0.0_r8 ssib=0.0_r8 wsib=0.0_r8 lonmax=ibmax latmax=jbmax DO is = 1,ityp !zdepth(3)= sib : depth of 3 soil layers (m) tzdep (1)= zdepth(is,1) tzdep (2)= zdepth(is,2) tzdep (3)= zdepth(is,3) tphsat = phsat (is) tbee = bee (is) tporos = poros (is) imm1=1 imm2=1 tzltm(1)=zlt_fixed(is,1,1) tzltm(2)=zlt_fixed(is,1,2) DO im=2,12 IF(tzltm(1).LE.zlt_fixed(is,im,1) ) THEN imm1=im tzltm(1)=zlt_fixed(is,im,1) END IF IF(tzltm(2).LE.zlt_fixed(is,im,2) )THEN imm2=im tzltm(2)=zlt_fixed(is,im,2) END IF END DO imm=imm1 ivegm=1 IF(tzltm(1).LE.tzltm(2)) THEN imm=imm2 ivegm=2 END IF ! ! xcover......Fracao de cobertura vegetal icg=1 topo ! xcover......Fracao de cobertura vegetal icg=2 base ! cover=xcover_fixed(is,imm,ivegm) tph1=xph1 (is,ivegm) tph2=xph2 (is,ivegm) ! ! m^3 ! sibmax(is) =(Z1 + Z2 + Z3) * poros = [m + m + m] * ----- = m = Os ! m^3 ! sibmax(is) = ( tzdep(1) + tzdep(2) + tzdep(3) ) * tporos ! IF(nfctrl(83).GE.1)WRITE(UNIT=nfprt,FMT=999)is,sibmax(is),tzdep(1), & tzdep(2),tzdep(3),tporos ! ! bee = soil moisture potential factor ! phsat = soil potential at saturation (m) ! ! -- -- ! | log ( - tphsat/1)| ! O = Os * EXP * | -----------------| ! | b | ! -- -- ! sref = sibmax(is) * EXP( LOG(tphsat /(-1.0e0_r8)) /tbee) ! -- -- ! | log ( - tphsat/(-1.0e10) ) | !Omin = Os * EXP * | -----------------------------| ! | b | ! -- -- ! smin = sibmax(is) * EXP( LOG(tphsat /(-1.0e10_r8)) / tbee) ! ! O - Omin !dssib = ------------------ ! mxiter ! dssib = (sref - smin) / REAL(mxiter,r8) ! ! O - Omin ! dw = ------------------ ! mxiter*Os ! dw = dssib / sibmax(is) ! times = 0.0e0_r8 soilmo = sref ! ! O ! w = ----- ! Os ! w = soilmo / sibmax(is) ! ! -- -- ! | 0.0027 | !rsoilm = 101840.0 * |1.0 - w | ! | | ! -- -- ! rsoilm = 101840.0_r8 * (1.0_r8 - w**0.0027_r8) DO iter = 1, mxiter CALL extrak( w ,dw ,tbee,tphsat, rsoilm, cover, & tph1,tph2,psit,factor ) ! ! dssib !dt = ---------- ! factor ! dt = dssib / factor ! soilmo = soilmo - dssib ! ! O ! w = ----- ! Os ! w = soilmo / sibmax(is) times = times + dt sm (is,iter) = soilmo time(is,iter) = times fact(is,iter) = factor END DO END DO ! ! input soil moisture map is now transformed to sib fields. ! DO lat = 1, latmax DO lon = 1, ibMaxPerJB(lat) is=INT(imask(lon,lat),kind=i4) IF(is.NE.0)THEN tsinp = sinp(lon,lat) tsinp = MAX (sinmax/100.0e3_r8 , tsinp ) tsinp = MIN (sinmax,tsinp) IF (tsinp .GT. 0.75e0_r8*sinmax ) etp = sinmax - tsinp facmod=MIN(1.0e0_r8,tsinp/(0.75e0_r8*sinmax) ) IF (tsinp .LE. 0.75e0_r8*sinmax ) THEN etp = 0.75e0_r8*sinmax*LOG(0.75e0_r8*sinmax/tsinp ) + 0.25e0_r8*sinmax END IF etp = etp / 1000.0e0_r8 DO iter = 1, mxiter itsoil=iter IF ( time(is,iter) - etp .GT. 0.0e0_r8 ) EXIT END DO DO iter=1,mxiter itfac=iter IF( fact(is,iter)-facmod-0.01e0_r8.LT.0.0e0_r8)EXIT END DO ssibt=MIN(sm(is,itsoil),sm(is,itfac)) DO iter=1,mxiter IF(ssibt.GT.sm(is,iter))EXIT END DO ssib(lon,lat) = sm(is,iter) ! ! O ! wsib = ----- ! Os ! wsib(lon,lat) = sm(is,iter) / sibmax(is) END IF END DO END DO 999 FORMAT(' IS,MAX,D1,D2,D3,POROS=',I2,1X,5E12.5) END SUBROUTINE sibwet SUBROUTINE sibwet_GLSM (ibMax , & ! IN jbMax , & ! IN imask , & ! IN wsib , & ! IN ssib , & ! IN mxiter , & ! OUT ibMaxPerJB , & ! OUT soilm , & ! in nzg , & ! in wsib3d , & ! OUT glsm_w) ! IN ! ! $Author: pkubota $ ! $Date: 2008/04/09 12:42:57 $ ! $Revision: 1.12 $ ! ! sibwet :transform mintz-serafini and national meteoroLOGICAL center fields ! of soil moisture into sib compatible fields of soil moisture. ! ! piers sellers : 29 april 1987 ! INTEGER, INTENT(IN ) :: ibMax INTEGER, INTENT(IN ) :: jbMax INTEGER, INTENT(IN ) :: mxiter REAL(KIND=r8) , INTENT(OUT ) :: soilm (ibMax,jbMax) INTEGER(KIND=i8), INTENT(IN ) :: imask (ibMax,jbMax) REAL(KIND=r8) , INTENT(OUT ) :: wsib (ibMax,jbMax) REAL(KIND=r8) , INTENT(OUT ) :: ssib (ibMax,jbMax) INTEGER, INTENT(in ) :: ibMaxPerJB (:) INTEGER, INTENT(in ) :: nzg REAL(KIND=r8) , INTENT(OUT ) :: wsib3d (ibMax,jbMax,8 ) REAL(KIND=r8) , INTENT(IN ) :: glsm_w (ibMax,jbMax,nzg ) REAL(KIND=r8) :: sm (ityp,mxiter) REAL(KIND=r8) :: time(ityp,mxiter) REAL(KIND=r8) :: fact(ityp,mxiter) ! !-srf ! INTEGER, PARAMETER :: nzgmax=20 REAL(KIND=r8) :: glsm_w1d (0:nzgmax) ! dummy 1d initial soil wetness REAL(KIND=r8) :: glsm_tzdep(0:3) ! sib soil levels REAL(KIND=r8) :: glsm_w_sib(0:3) ! SIB dummy 1d initial and interpolated soil wetness ! !-srf ! REAL(KIND=r8) :: tzdep (3) REAL(KIND=r8) :: tzltm (2) REAL(KIND=r8) :: sibmax(ityp) INTEGER :: k REAL(KIND=r8) :: fx INTEGER :: lonmax INTEGER :: latmax INTEGER :: is REAL(KIND=r8) :: tphsat REAL(KIND=r8) :: tbee REAL(KIND=r8) :: tporos INTEGER :: imm1 INTEGER :: imm2 INTEGER :: im INTEGER :: imm INTEGER :: ivegm REAL(KIND=r8) :: cover REAL(KIND=r8) :: tph1 REAL(KIND=r8) :: tph2 REAL(KIND=r8) :: sref REAL(KIND=r8) :: smin REAL(KIND=r8) :: dssib REAL(KIND=r8) :: dw REAL(KIND=r8) :: times REAL(KIND=r8) :: soilmo REAL(KIND=r8) :: w REAL(KIND=r8) :: rsoilm INTEGER :: iter REAL(KIND=r8) :: psit REAL(KIND=r8) :: factor REAL(KIND=r8) :: dt INTEGER :: lat INTEGER :: lon ! ! wsinp = m-s or nmc fractional wetness ! ms = 1, mintz-serafini ! nmc = 1, national meteoroLOGICAL center ! bee = sib : soil moisture potential factor ! phsat = sib : soil potential at saturation (m) ! zdepth(3)= sib : depth of 3 soil layers (m) ! poros = sib : soil porosity ! ph1 = sib : leaf potential, stress onset (m) ! ph2 = sib : leaf potential, no e-t (m) ! ! output : wsibt = sib : fractional wetness ! ssibt = sib : soil moisture content (m) ! psit = sib : soil moisture potential (m) ! factor = sib : extraction factor ! REAL(KIND=r8), PARAMETER :: xph1(13,2) = RESHAPE( & (/-100.0_r8,-190.0_r8,-200.0_r8,-200.0_r8,-200.0_r8,-120.0_r8,-120.0_r8,-120.0_r8,-200.0_r8, & -200.0_r8, -10.0_r8,-190.0_r8, -10.0_r8,-100.0_r8,-190.0_r8,-200.0_r8,-200.0_r8,-200.0_r8, & -120.0_r8,-120.0_r8,-120.0_r8,-200.0_r8,-200.0_r8, -10.0_r8,-190.0_r8, -10.0_r8/), & (/13,2/)) REAL(KIND=r8), PARAMETER :: xph2(13,2) = RESHAPE( & (/-500.0_r8,-250.0_r8,-250.0_r8,-250.0_r8,-250.0_r8,-230.0_r8,-230.0_r8,-280.0_r8,-400.0_r8, & -400.0_r8,-100.0_r8,-250.0_r8,-100.0_r8,-500.0_r8,-250.0_r8,-250.0_r8,-250.0_r8,-250.0_r8, & -230.0_r8,-230.0_r8,-280.0_r8,-400.0_r8,-400.0_r8,-100.0_r8,-250.0_r8,-100.0_r8/) , & (/13,2/)) !-srf !hmjb ! REAL, PARAMETER :: glsm_slz(0:nzgmax) = (/ 0., 0.1, 0.25, 0.5, 1., 2., 3.,& !7 values ! 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,& !10 values ! 0., 0., 0., 0. /) !4 values !versao para NZG=8 => 9 niveis no MCGA REAL(KIND=r8), PARAMETER :: glsm_slz(0:nzgmax) = (/ 0.0_r8, 0.05_r8, 0.13_r8, 0.25_r8, 0.5_r8, 1.0_r8, 1.75_r8,& !9 values 2.5_r8, 4.5_r8, 0.0_r8, 0.0_r8, 0.0_r8, 0.0_r8, 0.0_r8, 0.0_r8, 0.0_r8, 0.0_r8,& !10 values 0.0_r8, 0.0_r8, 0.0_r8, 0.0_r8 /) !4 values !-srf sm =0.0_r8 time =0.0_r8 fact =0.0_r8 ssib =0.0_r8 wsib =0.0_r8 lonmax=ibMax latmax=jbMax DO is = 1,ityp tzdep (1)= zdepth(is,1) tzdep (2)= zdepth(is,2) tzdep (3)= zdepth(is,3) tphsat = phsat (is) tbee = bee (is) tporos = poros (is) imm1=1 imm2=1 tzltm(1)=zlt_fixed(is,1,1) tzltm(2)=zlt_fixed(is,1,2) DO im=2,12 IF (tzltm(1).le.zlt_fixed(is,im,1) ) THEN imm1=im tzltm(1)=zlt_fixed(is,im,1) END IF IF (tzltm(2).le.zlt_fixed(is,im,2) ) THEN imm2=im tzltm(2)=zlt_fixed(is,im,2) END IF END DO imm=imm1 ivegm=1 IF (tzltm(1).le.tzltm(2)) THEN imm=imm2 ivegm=2 END IF cover=xcover_fixed(is,imm,ivegm) tph1=xph1(is,ivegm) tph2=xph2(is,ivegm) ! !srf- max water content ! sibmax(is) = ( tzdep(1) + tzdep(2) + tzdep(3) ) * tporos IF (nfctrl(83).ge.1) WRITE(UNIT=nfprt,FMT=999)is,sibmax(is),tzdep(1), & tzdep(2),tzdep(3),tporos sref = sibmax(is) * exp( log(tphsat /(-1.0e0_r8)) /tbee ) smin = sibmax(is) * exp( log(tphsat /(-1.0e10_r8)) /tbee ) dssib= (sref - smin) / REAL(mxiter,r8) dw = dssib / sibmax(is) times = 0.0e0_r8 soilmo = sref w = soilmo / sibmax(is) rsoilm = 101840.0_r8 * (1.0_r8 - w**0.0027_r8) DO iter = 1, mxiter CALL extrak ( w , & ! IN dw , & ! IN tbee , & ! IN tphsat, & ! IN rsoilm, & ! IN cover , & ! IN tph1 , & ! IN tph2 , & ! IN psit , & ! OUT factor ) ! OUT dt = dssib / factor soilmo = soilmo - dssib w = soilmo / sibmax(is) times = times + dt sm (is,iter) = soilmo time(is,iter) = times fact(is,iter) = factor END DO END DO ! ! input soil moisture map is now transformed to sib fields. ! DO lat = 1, latmax DO lon = 1, ibMaxPerJB(lat) wsib3d(lon,lat,:) = 0.e0_r8 is=INT(imask(lon,lat),kind=i4) IF (is.ne.0) THEN tzdep (1)= zdepth(is,1) tzdep (2)= zdepth(is,2) tzdep (3)= zdepth(is,3) tphsat = phsat (is) tbee = bee (is) tporos = poros (is) ! !-sib soil levels ! glsm_tzdep(0) = 0.e0_r8 glsm_w_sib(0) = 0.e0_r8 DO k=1,3 glsm_tzdep (k) = zdepth(is,k) + glsm_tzdep (k-1) glsm_w_sib (k) = 0.e0_r8 END DO ! !- copy 3d soil moisture array to 1d column array ! DO k=1,nzg glsm_w1d(k)=glsm_w(lon,lat,k) END DO ! !- performs vertical interpolation from soil moisture ! levels to sib levels ! CALL vert_interp(4 , & ! IN nzg+1 , & ! IN glsm_tzdep(0:3) , & ! IN glsm_slz(0:nzg) , & ! IN glsm_w1d(0:nzg) , & ! IN glsm_w_sib(0:3) ) ! OUT !endif ! !- stores 1d sib soil moisture at 3d array ! DO k=1,3 wsib3d(lon,lat,k) = glsm_w_sib(k) END DO ! !------------------------- remove this later--------------------------------X !- for now fix zero soil moisture inside the land !- latter fix this at soil moisture original data ! !IF (imask(lon,lat) > 0 ) THEN ! ssm=0. ! DO k=1,3 ! ssm=ssm+wsib3d(lon,lat,k) ! END DO ! ! IF (ssm < 0.15) THEN ! ! ! !print*,'SM null inside land portion', imask(lon,lat) ! !print*,'1',lon,lat,wsib3d(lon,lat,:) ! ! ! ssm1d(:) = 0. ! ncount = 0 ! DO i=max(1,lon-4),min(lonmax,lon+4) ! DO j=max(1,lat-4),min(latmax,lat+4) ! IF (imask(i,j) > 0) THEN !only points inside the land ! ssm=0. ! DO k=1,3 ! ssm=ssm+wsib3d(i,j,k) ! END DO ! ! IF (ssm > 0.15) THEN ! ncount=ncount + 1 ! ssm1d(:) = ssm1d(:) + wsib3d(i,j,:) ! END IF ! END IF ! END DO ! END DO ! ! IF (ncount > 1) THEN ! wsib3d(lon,lat,:)=ssm1d(:)/float(ncount) ! ELSE ! wsib3d(lon,lat,:)=0.5 ! END IF ! ! ! !print*,'2',lon,lat,wsib3d(lon,lat,:) ! ! ! END IF !END IF ! !-----------------------------------------------------------------------------X ! ssib(lon,lat) = 0.0_r8 wsib(lon,lat) = 0.0_r8 DO k=1,3 fx = ( glsm_tzdep(k)-glsm_tzdep(k-1) ) / glsm_tzdep(3) wsib(lon,lat) = wsib(lon,lat) + glsm_w_sib(k) * fx ssib(lon,lat) = ssib(lon,lat) + glsm_w_sib(k) * fx * tporos END DO ! ! total water in mm ! soilm(lon,lat) = ( tzdep(1)*wsib3d(lon,lat,1) + & tzdep(2)*wsib3d(lon,lat,2) + & tzdep(3)*wsib3d(lon,lat,3) ) * tporos ! END IF END DO END DO 999 FORMAT(' IS,MAX,D1,D2,D3,POROS=',I2,1X,5E12.5) END SUBROUTINE sibwet_GLSM SUBROUTINE extrak( w, dw, tbee, tphsat, rsoilm, cover, tph1, tph2, & psit, factor ) REAL(KIND=r8), INTENT(in ) :: w REAL(KIND=r8), INTENT(in ) :: dw REAL(KIND=r8), INTENT(in ) :: tbee REAL(KIND=r8), INTENT(in ) :: tphsat REAL(KIND=r8), INTENT(in ) :: rsoilm REAL(KIND=r8), INTENT(in ) :: cover REAL(KIND=r8), INTENT(in ) :: tph1 REAL(KIND=r8), INTENT(in ) :: tph2 REAL(KIND=r8), INTENT(inout ) :: psit REAL(KIND=r8), INTENT(inout ) :: factor REAL(KIND=r8) :: rsoil REAL(KIND=r8) :: argg REAL(KIND=r8) :: hr REAL(KIND=r8) :: rplant ! -- -- (-b) ! | dw | 0 ! psit = PHYs * | w - --- | where w = ----- ! | 2 | 0s ! -- -- psit = tphsat * ( w-dw/2.0e0_r8 ) ** (-tbee) ! ! -- -- ! | -- -- (0.0027) | ! | | dw | | !rsoil = 101840.0 * |1.0 - | w - --- | | ! | | 2 | | ! | -- -- | ! -- -- ! rsoil = 101840.0_r8 * (1.0_r8-( w-dw/2.0_r8) ** 0.0027_r8) ! ! 9.81 1 !argg = psit * -------- * ------- ! 461.50 310.0 ! argg = MAX ( -10.0e0_r8 , ((psit * 9.81e0_r8 / 461.5e0_r8) / 310.e0_r8)) ! ! -- -- ! | 9.81 1 | !hr = EXP |psit * -------- * ------- | ! | 461.50 310.0 | ! -- -- ! hr = EXP ( argg ) ! ! rsoilm ! rsoil =--------- * hr ! rsoil ! rsoil = rsoilm /rsoil * hr ! ! ( psit - tph2 - 50.0) !rplant = ------------------------- ! ( tph1 - tph2 ) ! rplant = ( psit - tph2 -50.0_r8) / ( tph1 - tph2 ) rplant = MAX ( 0.0e0_r8, MIN ( 1.0e0_r8, rplant ) ) ! -- -- ! -- -- | -- -- (0.0027)| ! |( psit - tph2 - 50) | | | dw | | !factor = cover * |---------------------| + (1 - cover) * 101840.0 * |1 - | w - --- | | ! | ( tph1 - tph2 ) | | | 2 | | ! -- -- | -- -- | ! -- -- factor = cover * rplant + ( 1.0e0_r8 - cover ) * rsoil factor = MAX ( 1.e-6_r8, factor ) END SUBROUTINE extrak ! !------------------------------------------------------------ ! SUBROUTINE vert_interp(nsib , & ! IN nzg , & ! IN tzdep , & ! IN glsm_slz , & ! IN gl_sm , & ! IN glsm_w_sib ) ! OUT INTEGER, INTENT(IN ) :: nsib INTEGER, INTENT(IN ) :: nzg REAL(KIND=r8) , INTENT(IN ) :: tzdep (nsib) REAL(KIND=r8) , INTENT(IN ) :: glsm_slz (: ) REAL(KIND=r8) , INTENT(IN ) :: gl_sm (: ) REAL(KIND=r8) , INTENT(OUT ) :: glsm_w_sib(nsib) REAL(KIND=r8) :: zm (nsib) REAL(KIND=r8) :: wf (nsib) REAL(KIND=r8) :: zc (nzg ) REAL(KIND=r8) :: wi (nzg ) REAL(KIND=r8) :: dzlft INTEGER :: ZDM INTEGER :: k INTEGER :: kstart INTEGER :: L DO k=1,nzg zc(k)=glsm_slz(k) END DO DO k=1,nsib zm(k)=tzdep(k) END DO zdm=nsib KSTART=3 ! ! Transfere valores da grade de MAIOR resolucao (WI) ! para a grade de MENOR resolucao (WF) ! ! OS valores de WI devem estar definidos nos pontos de grade ZCS=zc/2 ! OS valores de WF saem nos niveis ZMS = ZM/2 ! ! ! ! Dados da grade de maior resolucao ! DO K=1,NZG WI(K) = gl_sm(k) !print*,'wi=',k,wi(k) END DO ! ! Dado interpolado ! wf(:)=0.0_r8 ! ! Valor de superficie: ! WF(1)=WI(2) WF(2)=WI(2) ! ! DZLFT=0.0_r8 L=2 DO K=KSTART,ZDM ! ! if(k==4) print*,'0',l,WF(K),WI(L),DZLFT ! IF(DZLFT.NE.0.0_r8) THEN WF(K)=WF(K)+WI(L)*DZLFT ! if(k==4) print*,'1',l,WF(K),WI(L),DZLFT L=L+1 END IF 70 CONTINUE IF(ZC(L).LE.ZM(K)) THEN WF(K)=WF(K)+WI(L)*(ZC(L)-ZC(L-1)) ! if(k==4) print*,'2',l,WF(K),WI(L),ZC(L),zm(k) L=L+1 DZLFT=0.0_r8 IF (L>nzg) GO TO 1000 GO TO 70 ELSE WF(K)=WF(K)+WI(L)*(ZM(K)-ZC(L-1)) DZLFT=ZC(L)-ZM(K) ENDIF ENDDO 1000 CONTINUE DO K=KSTART,ZDM ! ! WF(K) =WF(K)/(ZM(K)-ZM(K-1)) ! if(k==4)print*,zm(k),zc(nzg),ZM(K-1),WF(K) ! IF (ZM(K) > ZC(nzg)) THEN WF(K) = WF(K)/(ZC(NZG)-ZM(K-1)) ELSE WF(K) = WF(K)/(ZM(K)-ZM(K-1)) END IF END DO ! !valores na grade do SIB ! DO k=1,nsib glsm_w_sib(k)=WF(k) !print*,'SIB',k,glsm_w_sib(k) END DO ! !check conservacao !srf - verifique se a integral de ambos calculos percorrem !srf - o mesmo intervalo ! print*,' ' ! sumf=0.0_r8 ! DO K=2,ZDM ! sumf=sumf+wf(k)*(ZM(K)-ZM(K-1)) ! print*,sumf,wf(k),zm(k),ZM(K)-ZM(K-1) ! ENDDO ! print*,'--------sumf-----',sumf ! sumi=0.0_r8 ! DO K=2,nzg ! sumi=sumi+wi(k)*(glsm_slz(K)-glsm_slz(K-1)) ! print*,k,sumi,wi(k),glsm_slz(K),(glsm_slz(K)-glsm_slz(K-1)) ! ENDDO ! print*,'--------sumi-----',sumi, 100*(sumf-sumi)/sumi ! RETURN END SUBROUTINE vert_interp !------------------------------------------------------------ SUBROUTINE read_gl_sm_bc(iMax , &! IN jMax , &! IN jbMax , &! IN nzg , &! IN npatches , & npatches_actual, & ibMaxPerJB , &! IN record_type , &! IN fNameSoilType , &! IN fNameVegType , &! IN fNameSoilMoist , & glsm_w , & soil_type , & veg_type , & frac_occ , & VegType )! IN INTEGER, INTENT(IN ) :: iMax INTEGER, INTENT(IN ) :: jMax INTEGER, INTENT(IN ) :: jbMax INTEGER, INTENT(IN ) :: nzg INTEGER, INTENT(IN ) :: npatches INTEGER, INTENT(IN ) :: npatches_actual INTEGER, INTENT(IN ) :: ibMaxPerJB(:) CHARACTER(LEN=*), INTENT(IN ) :: record_type CHARACTER(LEN=*), INTENT(IN ) :: fNameSoilType CHARACTER(LEN=*), INTENT(IN ) :: fNameVegType CHARACTER(LEN=*), INTENT(IN ) :: fNameSoilMoist REAL(KIND=r8) , INTENT(INOUT ) :: glsm_w(:,:,:) REAL(KIND=r8) , INTENT(OUT ) :: soil_type(:,:) REAL(KIND=r8) , INTENT(OUT ) :: veg_type(:,:,:) REAL(KIND=r8) , INTENT(OUT ) :: frac_occ (:,:,:) REAL(KIND=r8) , INTENT(INOUT ):: VegType(iMax,jMax,npatches) ! SIB veg type REAL(KIND=r8) :: FracOcc(iMax,jMax,npatches) ! fractional area REAL(KIND=r8) :: glsm(iMax,jMax,nzg ) ! initial soil wetness data REAL(KIND=r8) :: SoilType(iMax,jMax )! FAO/USDA soil texture ! ! Local ! INTEGER :: i INTEGER :: j INTEGER :: k INTEGER :: ipatch INTEGER :: ierr REAL(KIND=r8) :: fractx ! !------------------------- soil type initialization ------------ ! call MsgOne('**(read_gl_sm_bc)**','Opening GL soil file='//TRIM(fNameSoilType)) FracOcc=0.0_r8 glsm=0.0_r8 SoilType=0.0_r8 IF (record_type == 'seq') THEN !sequential mode OPEN(UNIT=nfsoiltp,FILE=TRIM(fNameSoilType),FORM='unformatted',ACCESS='sequential',& ACTION='read',STATUS='old',IOSTAT=ierr) IF (ierr /= 0) THEN WRITE(UNIT=nfprt,FMT="('**(ERROR)** Open file ',a,' returned iostat=',i4)") & TRIM(fNameSoilType), ierr STOP "**(ERROR)**" END IF READ(UNIT=nfsoiltp) ((SoilType(i,j),i=1,iMax),j=1,jMax) IF (reducedGrid) THEN CALL NearestIJtoIBJB(SoilType,soil_type) ELSE CALL IJtoIBJB( SoilType,soil_type) END IF CLOSE(UNIT=nfsoiltp) ELSE IF (record_type == 'vfm') THEN !vformat model OPEN(UNIT=nfsoiltp,FILE=TRIM(fNameSoilType),FORM='formatted',ACCESS='sequential',& ACTION='read',STATUS='old',IOSTAT=ierr) IF (ierr /= 0) THEN WRITE(UNIT=nfprt,FMT="('**(ERROR)** Open file ',a,' returned iostat=',i4)") & TRIM(fNameSoilType), ierr STOP "**(ERROR)**" END IF CALL vfirec(nfsoiltp,SoilType,imax*jmax,'LIN') IF (reducedGrid) THEN CALL NearestIJtoIBJB(SoilType,soil_type) ELSE CALL IJtoIBJB( SoilType,soil_type) END IF CLOSE(UNIT=nfsoiltp) END IF DO i=1,iMax DO j=1,jMax SoilType(i,j)=REAL(INT(SoilType(i,j)+0.1_r8),r8) END DO END DO DO j=1,jbMax DO i=1,ibMaxPerJB(j) soil_type(i,j)=REAL(INT(soil_type(i,j)+0.1_r8),r8) END DO END DO ! !-------------------veg type and fractional area initialization ------------ ! call MsgOne('**(read_gl_sm_bc)**','Opening GL veg file='//TRIM(fNameVegType)) IF (record_type == 'seq') THEN !sequential mode OPEN(UNIT=nfvegtp,FILE=TRIM(fNameVegType),FORM='unformatted',ACCESS='sequential',& ACTION='read',STATUS='old',IOSTAT=ierr) IF (ierr /= 0) THEN WRITE(UNIT=nfprt,FMT="('**(ERROR)** Open file ',a,' returned iostat=',i4)") & TRIM(fNameVegType), ierr STOP "**(ERROR)**" END IF DO ipatch=1,npatches_actual READ(UNIT=nfvegtp) ((VegType(i,j,ipatch),i=1,iMax),j=1,jMax) !veg dominante no patch READ(UNIT=nfvegtp) ((FracOcc(i,j,ipatch),i=1,iMax),j=1,jMax) !fracao ocupada pelo patch IF (reducedGrid) THEN CALL NearestIJtoIBJB(VegType(:,:,ipatch) ,veg_type(:,:,ipatch) ) ELSE CALL IJtoIBJB( VegType(:,:,ipatch) ,veg_type(:,:,ipatch) ) END IF IF (reducedGrid) THEN CALL NearestIJtoIBJB(FracOcc(:,:,ipatch) ,frac_occ(:,:,ipatch) ) ELSE CALL IJtoIBJB(FracOcc(:,:,ipatch) ,frac_occ(:,:,ipatch) ) END IF END DO CLOSE(UNIT=nfvegtp) ELSE IF (record_type == 'vfm') THEN !vformat model OPEN(UNIT=nfvegtp,FILE=TRIM(fNameVegType),FORM='formatted',ACCESS='sequential',& ACTION='read',STATUS='old',IOSTAT=ierr) IF (ierr /= 0) THEN WRITE(UNIT=nfprt,FMT="('**(ERROR)** Open file ',a,' returned iostat=',i4)") & TRIM(fNameVegType), ierr STOP "**(ERROR)**" END IF DO ipatch=1,npatches_actual ! !print*,'=======================VEGET =======================',ipatch ! CALL vfirec(nfvegtp,VegType(1,1,ipatch),iMax*jMax,'LIN') !veg dominante no patch ! !print*,'=======================FRACA =======================',ipatch ! CALL vfirec(nfvegtp,FracOcc(1,1,ipatch),iMax*jMax,'LIN') !fracao ocupada pelo patch IF (reducedGrid) THEN CALL NearestIJtoIBJB(VegType(:,:,ipatch) ,veg_type(:,:,ipatch)) ELSE CALL IJtoIBJB(VegType(:,:,ipatch) ,veg_type(:,:,ipatch) ) END IF IF (reducedGrid) THEN CALL NearestIJtoIBJB(FracOcc(:,:,ipatch) ,frac_occ(:,:,ipatch) ) ELSE CALL IJtoIBJB(FracOcc(:,:,ipatch) ,frac_occ(:,:,ipatch) ) END IF END DO CLOSE(UNIT=nfvegtp) END IF ! ! fractional area normalization ! DO j=1,jbMax DO i=1,ibMaxPerJB(j) IF(frac_occ(i,j,1) < 0.99999_r8) THEN fractx=0.0_r8 DO ipatch=1,npatches_actual-1 fractx=fractx+frac_occ(i,j,ipatch) END DO frac_occ(i,j,npatches_actual)= 1.0_r8 - fractx END IF END DO END DO !IF (reducedGrid) THEN ! CALL NearestIBJBtoIJ(frac_occ(:,:,npatches_actual),FracOcc(:,:,npatches_actual)) !ELSE ! CALL IBJBtoIJ(frac_occ(:,:,npatches_actual),FracOcc(:,:,npatches_actual)) !END IF !! !!- !! !DO ipatch=1,npatches_actual ! DO j=1,jbMax ! DO i=1,ibMaxPerJB(j) ! veg_type(i,j,ipatch)=REAL(INT(veg_type(i,j,ipatch)+0.1_r8),r8) ! END DO ! END DO ! ! IF (reducedGrid) THEN ! CALL NearestIBJBtoIJ(veg_type(:,:,npatches_actual),VegType(:,:,npatches_actual)) ! ELSE ! CALL IBJBtoIJ(veg_type(:,:,npatches_actual),VegType(:,:,npatches_actual)) ! END IF ! ! END DO ! !------------------------- soil moisture initialization ------------ ! call MsgOne('**(read_gl_sm_bc)**','Opening GL_SM file='//TRIM(fNameSoilMoist)) IF (record_type == 'seq') THEN !sequential mode OPEN(UNIT=nfslmtp,FILE=TRIM(fNameSoilMoist),FORM='unformatted',ACCESS='sequential',& ACTION='read',STATUS='old',IOSTAT=ierr) IF (ierr /= 0) THEN WRITE(UNIT=nfprt,FMT="('**(ERROR)** Open file ',a,' returned iostat=',i4)") & TRIM(fNameSoilMoist), ierr STOP "**(ERROR)**" END IF ! do k=1,nzg ! direct order DO k=nzg,1,-1 ! revert reading order READ(UNIT=nfslmtp) ((glsm(i,j,k),i=1,iMax),j=1,jMax) ! wetness IF (reducedGrid) THEN CALL NearestIJtoIBJB(glsm(:,:,k) ,glsm_w(:,:,k) ) ELSE CALL IJtoIBJB(glsm(:,:,k) ,glsm_w(:,:,k) ) END IF END DO CLOSE(UNIT=nfslmtp) ELSE IF (record_type == 'vfm') THEN !vformat model OPEN(UNIT=nfslmtp,FILE=TRIM(fNameSoilMoist),FORM='formatted',ACCESS='sequential',& ACTION='read',STATUS='old',IOSTAT=ierr) IF (ierr /= 0) THEN WRITE(UNIT=nfprt,FMT="('**(ERROR)** Open file ',a,' returned iostat=',i4)") & TRIM(fNameSoilMoist), ierr STOP "**(ERROR)**" END IF ! do k=1,nzg ! direct order DO k=nzg,1,-1 ! revert reading order ! !print*,'================== GLSM for k====================',k ! CALL vfirec(nfslmtp,glsm(1,1,k),iMax*jMax,'LIN') IF (reducedGrid) THEN CALL NearestIJtoIBJB(glsm(:,:,k) ,glsm_w(:,:,k) ) ELSE CALL IJtoIBJB(glsm(:,:,k) ,glsm_w(:,:,k) ) END IF END DO CLOSE(UNIT=nfslmtp) ELSE call FatalError('**(read_gl_sm_bc)** unknown record type') END IF call MsgOne('**(read_gl_sm_bc)**','DONE') RETURN END SUBROUTINE read_gl_sm_bc SUBROUTINE InitCheckSSiBFile(iMax,jMax,ibMax,& jbMax ,kMax, ifdy ,ids ,idc ,ifday , & tod ,idate ,idatec ,todsib,ibMaxPerJB ) INTEGER , INTENT(IN ) :: iMax INTEGER , INTENT(IN ) :: jMax INTEGER , INTENT(IN ) :: ibMax INTEGER , INTENT(IN ) :: jbMax INTEGER , INTENT(IN ) :: kMax INTEGER , INTENT(OUT ) :: ifdy INTEGER , INTENT(OUT ) :: ids (4) INTEGER , INTENT(OUT ) :: idc (4) INTEGER , INTENT(IN ) :: ifday REAL(KIND=r8), INTENT(IN ) :: tod INTEGER , INTENT(IN ) :: idate (4) INTEGER , INTENT(IN ) :: idatec(4) REAL(KIND=r8), INTENT(OUT ) :: todsib INTEGER , INTENT(IN ) :: ibMaxPerJB(jbMax) INTEGER :: j INTEGER :: ncount INTEGER :: i REAL(KIND=r8) :: tice =271.16e0_r8 CHARACTER(LEN=*), PARAMETER :: h="**(InitCheckSSiBFile)**" ! ! read ssib dataset for cold start ! IF( initlz < 0 )THEN CALL MsgOne(h,'Read SSib variables from warm-start file') READ(UNIT=nfsibi) ifdy,todsib,ids,idc READ(UNIT=nfsibi) tm0 ,tmm READ(UNIT=nfsibi) qm0 ,qmm READ(UNIT=nfsibi) td0 ,tdm READ(UNIT=nfsibi) tg0 ,tgm READ(UNIT=nfsibi) tc0 ,tcm READ(UNIT=nfsibi) w0 ,wm READ(UNIT=nfsibi) capac0,capacm READ(UNIT=nfsibi) ppci ,ppli,tkemyj READ(UNIT=nfsibi) gl0 ,zorl ,gtsea,tseam,qsfc0,tsfc0,qsfcm,tsfcm,HML,HUML,HVML,TSK,z0sea,& TC_SeaIce,TGS_SeaIce,TD_SeaIce,TA_SeaIce,SNOA_SeaIce,SNOB_SeaIce,PBL_CoefKm, PBL_CoefKh,tauresx,tauresy Mmlen=gl0 REWIND nfsibi CALL getsbc (iMax ,jMax ,kMax, AlbVisDiff,gtsea,gndvi,soilm,sheleg,o3mix,tracermix,wsib3d,& ifday , tod ,idate ,idatec,& ifalb,ifsst,ifndvi,ifslm ,ifslmSib2,ifsnw,ifozone,iftracer, & sstlag,intsst,intndvi,intsoilm,fint ,tice , & yrl ,monl,ibMax,jbMax,ibMaxPerJB) DO j=1,jbMax ncount=0 DO i=1,ibMaxPerJB(j) IF(imask(i,j) >= 1_i8)THEN ncount=ncount+1 ssib(ncount,j)=0.0_r8 IF(w0(ncount,1,j).LT.0.0_r8)THEN ssib(ncount, j)=ABS(w0(ncount,1,j)) w0 (ncount,1,j)=ABS(w0(ncount,1,j)) w0 (ncount,2,j)=ABS(w0(ncount,2,j)) w0 (ncount,3,j)=ABS(w0(ncount,3,j)) wm (ncount,1,j)=ABS(wm(ncount,1,j)) wm (ncount,2,j)=ABS(wm(ncount,2,j)) wm (ncount,3,j)=ABS(wm(ncount,3,j)) END IF END IF END DO END DO IF(nfctrl(5).GE.1)WRITE(UNIT=nfprt,FMT=444) ifdy,todsib,ids,idc END IF 444 FORMAT(' SIB PROGNOSTIC VARIABLES READ IN. AT FORECAST DAY', & I8,' TOD ',F8.1/' STARTING',3I3,I5,' CURRENT',3I3,I5) END SUBROUTINE InitCheckSSiBFile SUBROUTINE InitSurfTemp (jbMax ,ibMaxPerJB) INTEGER, INTENT(IN ) :: jbMax INTEGER, INTENT(IN ) :: ibMaxPerJB(jbMax) INTEGER :: i INTEGER :: j INTEGER :: ncount REAL(KIND=r8) :: zero =0.0e3_r8 REAL(KIND=r8) :: thousd=1.0e3_r8 REAL(KIND=r8) :: tf =273.16e0_r8 capacm=0.0_r8 capac0=0.0_r8 DO j=1,jbMax ncount=0 DO i=1,ibMaxPerJB(j) IF(imask(i,j) >= 1_i8) THEN ncount=ncount+1 IF(sheleg(i,j).GT.zero) THEN capac0(ncount,2,j) = sheleg(i,j)/thousd capacm(ncount,2,j) = sheleg(i,j)/thousd tg0 (ncount, j) = MIN(tg0(ncount,j),tf-0.01e0_r8) tgm (ncount, j) = MIN(tgm(ncount,j),tf-0.01e0_r8) END IF END IF END DO END DO END SUBROUTINE InitSurfTemp SUBROUTINE ReStartSSiB (jbMax,ifday,tod,idate ,idatec, & nfsibo,ibMaxPerJB) INTEGER ,INTENT(IN ) :: jbMax INTEGER ,INTENT(IN ) :: ifday REAL(KIND=r8) ,INTENT(IN ) :: tod INTEGER ,INTENT(IN ) :: idate(4) INTEGER ,INTENT(IN ) :: idatec(4) INTEGER ,INTENT(IN ) :: nfsibo INTEGER ,INTENT(IN ) :: ibMaxPerJB(jbMax) INTEGER :: i INTEGER :: j INTEGER :: ncount IF(TRIM(isimp).NE.'YES') THEN CALL MsgOne('**(restartphyscs)**','Saving physics state for restart') !$OMP DO PRIVATE(ncount, i) DO j=1,jbMax ncount=0 DO i=1,ibMaxPerJB(j) IF(imask(i,j) >= 1_i8)THEN ncount=ncount+1 IF(ssib(ncount,j).GT.0.0_r8)THEN w0 (ncount,1,j)=-ssib(ncount,j) w0 (ncount,2,j)=-ssib(ncount,j) w0 (ncount,3,j)=-ssib(ncount,j) wm (ncount,1,j)=-ssib(ncount,j) wm (ncount,2,j)=-ssib(ncount,j) wm (ncount,3,j)=-ssib(ncount,j) END IF END IF END DO END DO !$OMP SINGLE WRITE(UNIT=nfsibo) ifday,tod,idate,idatec WRITE(UNIT=nfsibo) tm0,tmm WRITE(UNIT=nfsibo) qm0,qmm WRITE(UNIT=nfsibo) td0,tdm WRITE(UNIT=nfsibo) tg0,tgm WRITE(UNIT=nfsibo) tc0,tcm WRITE(UNIT=nfsibo) w0 ,wm WRITE(UNIT=nfsibo) capac0,capacm WRITE(UNIT=nfsibo) ppci ,ppli,tkemyj WRITE(UNIT=nfsibo) gl0 ,zorl,gtsea,tseam,qsfc0,tsfc0,qsfcm,tsfcm,HML,HUML,HVML,TSK,z0sea,& TC_SeaIce,TGS_SeaIce,TD_SeaIce,TA_SeaIce,SNOA_SeaIce,SNOB_SeaIce,PBL_CoefKm, PBL_CoefKh,tauresx,tauresy !$OMP END SINGLE END IF END SUBROUTINE ReStartSSiB SUBROUTINE Finalize_SSiB() DEALLOCATE(vcover_gbl) DEALLOCATE(zlt_gbl ) DEALLOCATE(green_gbl ) DEALLOCATE(chil_gbl ) DEALLOCATE(topt_gbl ) DEALLOCATE(tll_gbl ) DEALLOCATE(tu_gbl ) DEALLOCATE(defac_gbl ) DEALLOCATE(ph2_gbl ) DEALLOCATE(ph1_gbl ) DEALLOCATE(rstpar_gbl) DEALLOCATE(satcap3d ) DEALLOCATE(extk_gbl ) DEALLOCATE(radfac_gbl) DEALLOCATE(closs_gbl ) DEALLOCATE(gloss_gbl ) DEALLOCATE(thermk_gbl) DEALLOCATE(p1f_gbl ) DEALLOCATE(p2f_gbl ) DEALLOCATE(tgeff_gbl ) DEALLOCATE(zlwup_SSiB) DEALLOCATE(AlbGblSSiB) DEALLOCATE(MskAntSSiB) DEALLOCATE(glsm_w ) DEALLOCATE(veg_type ) END SUBROUTINE Finalize_SSiB END MODULE SFC_SSiB