MODULE dustemission_mod IMPLICIT NONE !Parameters ! INTEGER, PARAMETER :: nbins=12 ! number of aerosol bins: original ! INTEGER, PARAMETER :: nbins=800 ! number of aerosol bins: for spla ! INTEGER, PARAMETER :: nbins=8000 ! number of aerosol bins: for spla INTEGER, PARAMETER :: flag_feff=1 ! 0: deactivate feff (drag partition scheme) INTEGER, PARAMETER :: nbins=800 ! number of aerosol bins: for spla INTEGER, PARAMETER :: nmode=3 ! number of soil-dust modes INTEGER, PARAMETER :: ntyp=5 ! number of soil types !INTEGER, PARAMETER :: nwb=12 ! number of points for the 10m wind ! speed weibull distribution (>=2) real ,parameter :: z10m=1000. !10m in cm REAL,PARAMETER :: kref=3. !weibull parameter INTEGER, PARAMETER :: nats=14 !number of mineral types (14 here for sand, ! silt, clay etc.) integer, parameter :: nclass=200000 real , parameter :: dmin=0.0001 real , parameter :: dmax=0.2 integer, parameter :: nspe=nmode*3+1 real ,parameter :: vkarm=0.41 !JE20150202 : updating scheme to chimere13b <<< ! original values ! integer, parameter :: div1=3. ! integer, parameter :: div2=3. ! integer, parameter :: div3=3. ! real , parameter :: e1=3.61/div1 ! real , parameter :: e2=3.52/div2 ! real , parameter :: e3=3.46/div3 ! real , parameter :: rop=2.65 ! particle density g/m3 ! real , parameter :: roa=0.001227 ! air density g/m3 ! real , parameter :: pi=3.14159 !! ! real , parameter :: gravity=981. !! cm!! ! real , parameter :: cd=1.*roa/gravity ! new values ! logical, parameter :: ok_splatuning=.true. ! Div=3 from S. Alfaro (Sow et al ACPD 2011) !JE 20150206 ! integer, parameter :: div1=3. ! integer, parameter :: div2=3. ! integer, parameter :: div3=3. integer, parameter :: div1=6. integer, parameter :: div2=6. integer, parameter :: div3=6. real , parameter :: e1=3.61/div1 real , parameter :: e2=3.52/div2 real , parameter :: e3=3.46/div3 real , parameter :: rop=2.65 ! particle density g/m3 real , parameter :: roa=0.001227 ! air density g/m3 real , parameter :: pi=3.14159 !! real , parameter :: gravity=981. !! cm!! ! C=2.61 from Marticorena and Bergametti 1995 instead of Gillete and Chen 2001 ! (recommended C=1.1 in supply-limited dust source area.. ) real , parameter :: cd=2.61*roa/gravity ! real , parameter :: cd=1.0*roa/gravity !JE20150202>>>> real,parameter :: beta=16300. real, parameter, dimension(3) :: diam=(/1.5,6.7,14.2/) INTEGER, PARAMETER :: ndistb=3 real, parameter, dimension(3) :: sig=(/1.7,1.6,1.5/) ! INTEGER, PARAMETER :: nbinsHR=3000 !original INTEGER, PARAMETER :: nbinsHR=30000 !min and max dust size in um REAL, PARAMETER :: sizedustmin=0.0599 ! for spla REAL, PARAMETER :: sizedustmax=63. ! REAL, PARAMETER :: sizedustmin=0.09 ! original ! REAL, PARAMETER :: sizedustmax=63. ! Calc variables REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: massfrac REAL,DIMENSION(:), ALLOCATABLE,SAVE :: binsHR REAL,DIMENSION(:), ALLOCATABLE,SAVE :: binsHRcm REAL,DIMENSION(:), ALLOCATABLE,SAVE :: itv REAL,DIMENSION(:), ALLOCATABLE,SAVE :: sizedust !size dust bin (in um) REAL,DIMENSION(:), ALLOCATABLE,SAVE :: szdcm !the same but (in cm) !soil inputs from file donnees_lisa.nc . Should be in the same grid as the !model (regridded with nearest neighborhood from surfnew.nc) REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: sol REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: P REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: zos REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: z01 REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: z02 REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: D REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: A REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: solspe INTEGER,DIMENSION(:,:),ALLOCATABLE,SAVE :: masklisa !!! INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: maskdust REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: feff REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: feffdbg REAL,DIMENSION(:), ALLOCATABLE,SAVE :: sizeclass REAL,DIMENSION(:), ALLOCATABLE,SAVE :: sizeclass2 REAL,DIMENSION(:), ALLOCATABLE,SAVE :: uth REAL,DIMENSION(:), ALLOCATABLE,SAVE :: uth2 REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: srel REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: srel2 INTEGER :: nat ! SOL data inside the loop (use as soil type index?) REAL :: ustarsalt REAL :: var3a,var3b INTEGER :: ns,nd,nsi,npi,ni ! counters INTEGER :: ncl ! outputs REAL,DIMENSION(:), ALLOCATABLE,SAVE :: m1dflux !fluxes for each soil mode REAL,DIMENSION(:), ALLOCATABLE,SAVE :: m2dflux REAL,DIMENSION(:), ALLOCATABLE,SAVE :: m3dflux !$OMP THREADPRIVATE(m1dflux) !$OMP THREADPRIVATE(m2dflux) !$OMP THREADPRIVATE(m3dflux) !$OMP THREADPRIVATE(massfrac) !$OMP THREADPRIVATE(binsHR) !$OMP THREADPRIVATE(binsHRcm) !$OMP THREADPRIVATE(itv) !$OMP THREADPRIVATE(sizedust) !$OMP THREADPRIVATE(szdcm) !$OMP THREADPRIVATE(sol) !$OMP THREADPRIVATE(P) !$OMP THREADPRIVATE(zos) !$OMP THREADPRIVATE(z01) !$OMP THREADPRIVATE(z02) !$OMP THREADPRIVATE(D) !$OMP THREADPRIVATE(A) !$OMP THREADPRIVATE(solspe) !$OMP THREADPRIVATE(masklisa) !!!!$OMP THREADPRIVATE(maskdust) !$OMP THREADPRIVATE(feff) !$OMP THREADPRIVATE(feffdbg) !$OMP THREADPRIVATE(sizeclass) !$OMP THREADPRIVATE(sizeclass2) !$OMP THREADPRIVATE(uth) !$OMP THREADPRIVATE(uth2) !$OMP THREADPRIVATE(srel) !$OMP THREADPRIVATE(srel2) CONTAINS !-------------------------------------------------------------------------------------- !====================================================================================== !************************************************************************************** !====================================================================================== !-------------------------------------------------------------------------------------- SUBROUTINE dustemis_out_init() USE dimphy !AS: moved here from subroutine initdust ALLOCATE( m1dflux(klon) ) ALLOCATE( m2dflux(klon) ) ALLOCATE( m3dflux(klon) ) END SUBROUTINE dustemis_out_init SUBROUTINE dustemission( debutphy, xlat, xlon, nsurfwind, & !Input pctsrf,zu10m,zv10m,wstar, & !Input ale_bl,ale_wake, & !Input param_wstarBL, param_wstarWAKE, & !Input wind10ms, probu, & !Input emdustacc,emdustcoa,emdustsco,maskdust) !Output USE dimphy USE infotrac_phy, ONLY: nbtr USE write_field_phy USE mod_grid_phy_lmdz USE mod_phys_lmdz_para USE indice_sol_mod IMPLICIT NONE ! input : ! output: flux_sparam_ddfine,flux_sparam_ddcoa, ! first: ! Model grid parameters INTEGER, INTENT(IN) :: nsurfwind REAL,DIMENSION(klon), INTENT(IN) :: xlat REAL,DIMENSION(klon), INTENT(IN) :: xlon REAL,DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf REAL,DIMENSION(klon),INTENT(IN) :: zu10m ! 10m zonal wind REAL,DIMENSION(klon),INTENT(IN) :: zv10m ! meridional 10m wind REAL,DIMENSION(klon),INTENT(IN) :: wstar REAL,DIMENSION(klon),INTENT(IN) :: ale_bl REAL,DIMENSION(klon),INTENT(IN) :: ale_wake !REAL,DIMENSION(klon),INTENT(IN) :: wake_s !REAL,DIMENSION(klon),INTENT(IN) :: wake_Cstar !REAL,DIMENSION(klon),INTENT(IN) :: zustar REAL,DIMENSION(klon), INTENT(IN) :: param_wstarWAKE REAL,DIMENSION(klon), INTENT(IN) :: param_wstarBL REAL,DIMENSION(klon,nsurfwind), INTENT(IN) :: wind10ms REAL,DIMENSION(klon,nsurfwind), INTENT(IN) :: probu LOGICAL :: debutphy ! First physiqs run or not ! Intermediate variable: 12 bins emissions !REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: emisbinloc ! vertical emission fluxes REAL, DIMENSION(:,:), ALLOCATABLE, SAVE :: emisbinloc !OUT variables REAL,DIMENSION(klon) :: emdustacc,emdustcoa,emdustsco ! emission in spla dust bins: ! old radio : acc=0.03-0.5 micrometers, ccoa:0.5-10 micrometers ! new acc=0.03-0.5 micrometers, coa:0.5-3 micrometers ,sco:3-15 um INTEGER,DIMENSION(klon) :: maskdust ! where the emissions were calculated ! INTEGER,DIMENSION(klon_glo) :: maskdust_glo ! auxiliar ! REAL,DIMENSION(klon_glo) :: raux_klon_glo ! auxiliar INTEGER :: nwb nwb = nsurfwind !!!$OMP THREADPRIVATE(emisbinloc) !!!!!!$OMP THREADPRIVATE(maskdust) IF (debutphy) THEN ALLOCATE( emisbinloc(klon,nbins) ) ENDIF IF( debutphy ) THEN CALL initdust(xlat,xlon,pctsrf) ENDIF !JE20141124 CALL calcdustemission(debutphy,zu10m,zv10m,wstar,ale_bl,ale_wake,emisbinloc) CALL calcdustemission(debutphy,nsurfwind,zu10m,zv10m,wstar,ale_bl,ale_wake,param_wstarBL,param_wstarWAKE, & !I wind10ms,probu,emisbinloc) !O CALL makemask(maskdust) IF( debutphy ) THEN ! call gather(maskdust,maskdust_glo) ! !$OMP MASTER ! IF (is_mpi_root .AND. is_omp_root) THEN ! CALL writefield_phy("maskdust",float(maskdust_glo),1) CALL writefield_phy("maskdust",float(maskdust),1) ! ENDIF ! !$OMP END MASTER ! !$OMP BARRIER ENDIF !CALL adaptdustemission(debutphy,emisbinloc,emdustacc,emdustcoa,emdustsco) CALL adaptdustemission(debutphy,emisbinloc,emdustacc,emdustcoa,emdustsco,maskdust,pctsrf) ! output in kg/m2/s END SUBROUTINE dustemission !-------------------------------------------------------------------------------------- !====================================================================================== !************************************************************************************** !====================================================================================== !-------------------------------------------------------------------------------------- SUBROUTINE makemask(maskdustloc) USE dimphy USE infotrac_phy, ONLY: nbtr IMPLICIT NONE !Input INTEGER,DIMENSION(klon) :: maskdustloc INTEGER :: i,j,k integer :: iaux do k=1,klon maskdustloc(k)=0 do i=1,ntyp if (masklisa(k,i)>0) then maskdustloc(k)=1 endif enddo enddo END SUBROUTINE makemask !-------------------------------------------------------------------------------------- !====================================================================================== !************************************************************************************** !====================================================================================== !-------------------------------------------------------------------------------------- SUBROUTINE adaptdustemission(debutphy,emisbinlocal, & emdustacc,emdustcoa,emdustsco,maskdust,pctsrf) ! emdustacc,emdustcoa,emdustsco) USE dimphy USE infotrac_phy, ONLY: nbtr USE write_field_phy USE mod_grid_phy_lmdz USE mod_phys_lmdz_para USE indice_sol_mod IMPLICIT NONE !Input REAL,DIMENSION(klon) :: emdustacc,emdustcoa,emdustsco REAL, DIMENSION(klon,nbins) :: emisbinlocal ! Local INTEGER :: i,j,k !!! INTEGER,DIMENSION(2) :: iminacclow,iminacchigh,imincoalow,imincoahigh ! in !case of small nbins.... not ready INTEGER,SAVE ::iminacclow,iminacchigh,imincoalow INTEGER,SAVE ::imincoahigh,iminscohigh,iminscolow INTEGER,DIMENSION(klon) :: maskdust ! where the emissions were calculated REAL,DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf ! real,parameter :: sizeacclow=0.03 ! real,parameter :: sizeacchigh=0.5 ! real,parameter :: sizecoalow=0.5 ! real,parameter :: sizecoahigh=10. ! in micrometers real,parameter :: sizeacclow=0.06 real,parameter :: sizeacchigh=1.0 real,parameter :: sizecoalow=1.0 real,parameter :: sizecoahigh=6. !20 ! diameter in micrometers real,parameter :: sizescolow=6. real,parameter :: sizescohigh=30. ! in micrometers !-------------------------------- ! real,parameter :: tuningfactorfine=0.9 ! factor for fine bins!!! important!! real,parameter :: tuningfactorfine=0.8 ! factor for fine bins!!! important!! ! real,parameter :: tuningfactorfine=4.5 ! factor for fine bins!!! important!! ! real,parameter :: tuningfactorcoa=3.6 ! factor for coarse bins!!! important!! real,parameter :: tuningfactorcoa=3.25 ! factor for coarse bins!!! important!! ! real,parameter :: tuningfactorcoa=4.5 ! factor for coarse bins!!! important!! ! real,parameter :: tuningfactorsco=3.6 ! factor for supercoarse bins!!! important!! real,parameter :: tuningfactorsco=3.25 ! factor for supercoarse bins!!! important!! ! real,parameter :: tuningfactorsco=4.5 ! factor for supercoarse bins!!! important!! real,parameter :: basesumemission= 0.0 !1.e-6 ! emissions to SUM to each land pixel FOR ASSIMILATION ONLY important!! in mg/m2/s, per bin !basesumemission = 1.e-6 increase the AOD in about 12% (0.03 of AOD) , !while 1e-8 increase in about 0.12% (0.003 of AOD) real,dimension(klon) :: basesumacc,basesumcoa,basesumsco !-------------------------------- !JE20140915 real,parameter :: sizeacclow=0.06 !JE20140915 real,parameter :: sizeacchigh=1.0 !JE20140915 real,parameter :: sizecoalow=1.0 !JE20140915 real,parameter :: sizecoahigh=10. !20 ! diameter in micrometers !JE20140915 real,parameter :: sizescolow=10. !JE20140915 real,parameter :: sizescohigh=30. ! in micrometers logical :: debutphy real :: diff, auxr1,auxr2,auxr3,auxr4 real,dimension(klon,nbins) :: itvmean real,dimension(klon,nbins+1) :: itv2 ! real,dimension(klon_glo,nbins) :: itvmean_glo ! real,dimension(:,:) , allocatable :: itvmean_glo ! real,dimension(:,:), allocatable :: itv2_glo integer, save :: counter,counter1 !dbg REAL, DIMENSION(:,:),ALLOCATABLE,SAVE :: emisbinlocalmean,emisbinlocalmean2 !dbg REAL, DIMENSION(:,:),ALLOCATABLE :: emisbinlocalmean2_glo logical :: writeaerosoldistrib !$OMP THREADPRIVATE(iminacclow,iminacchigh,imincoalow,imincoahigh) writeaerosoldistrib=.false. if (debutphy) then if (sizedustmin>sizeacclow .or. sizedustmax<sizescohigh) then call abort_physic('adaptdustemission', 'Dust range problem',1) endif print *,'FINE DUST BIN: tuning EMISSION factor= ',tuningfactorfine print *,'COA DUST BIN: tuning EMISSION factor= ',tuningfactorcoa print *,'SCO DUST BIN: tuning EMISSION factor= ',tuningfactorsco print *,'ALL DUST BIN: SUM to the emissions (mg/m2/s) = ',basesumemission auxr1=9999. auxr2=9999. auxr3=9999. auxr4=9999. do i=1,nbins+1 if (abs(sizeacclow-itv(i))<auxr1) then auxr1=abs( sizeacclow-itv(i)) iminacclow=i endif if (abs(sizeacchigh-itv(i))<auxr2) then auxr2=abs( sizeacchigh-itv(i)) iminacchigh=i imincoalow=i endif if (abs(sizecoahigh-itv(i))<auxr3) then auxr3=abs( sizecoahigh-itv(i)) imincoahigh=i iminscolow=i endif if (abs(sizescohigh-itv(i))<auxr4) then auxr4=abs( sizescohigh-itv(i)) iminscohigh=i endif enddo if (writeaerosoldistrib) then !JEdbg<< do j=1,klon do i=1,nbins itvmean(j,i)=(itv(i)+itv(i+1))/2. itv2(j,i)=itv(i) !print*, itv(i),itvmean(i),itv(i+1) !print*, sizedust(i) enddo itv2(j,nbins+1)=itv(nbins+1) enddo ! allocate(itv2_glo(klon_glo,nbins+1)) ! allocate(itvmean_glo(klon_glo,nbins)) ! ALLOCATE(emisbinlocalmean2_glo(klon_glo,nbins)) ! call gather(itv2,itv2_glo) ! call gather(itvmean,itvmean_glo) !!$OMP MASTER ! IF (is_mpi_root .AND. is_omp_root) THEN ! CALL writefield_phy("itv2",itv2_glo,nbins+1) ! CALL writefield_phy("itvmean",itvmean_glo,nbins) CALL writefield_phy("itv2",itv2,nbins+1) CALL writefield_phy("itvmean",itvmean,nbins) ! ENDIF !!$OMP END MASTER !!$OMP BARRIER ALLOCATE(emisbinlocalmean(klon,nbins)) ALLOCATE(emisbinlocalmean2(klon,nbins)) do i=1,nbins do j=1,klon emisbinlocalmean(j,i)=0.0 emisbinlocalmean2(j,i)=0.0 enddo enddo counter=1 counter1=0 !JEdbg>> endif endif !print *,'JE' !print *,iminacclow,iminacchigh,imincoalow,imincoahigh ! estimate and integrate bins into only accumulation and coarse do k=1,klon basesumacc(k)=basesumemission*(pctsrf(k,is_ter))*1.e-6 ! from mg/m2/s basesumcoa(k)=basesumemission*(pctsrf(k,is_ter))*1.e-6 basesumsco(k)=basesumemission*(pctsrf(k,is_ter))*1.e-6 enddo do k=1,klon auxr1=0.0 auxr2=0.0 auxr3=0.0 do i=iminacclow,iminacchigh-1 auxr1=auxr1+emisbinlocal(k,i) enddo emdustacc(k)=(auxr1 + basesumacc(k))*tuningfactorfine do i=imincoalow,imincoahigh-1 auxr2=auxr2+emisbinlocal(k,i) enddo emdustcoa(k)=(auxr2 + basesumcoa(k))*tuningfactorcoa do i=iminscolow,iminscohigh-1 auxr3=auxr3+emisbinlocal(k,i) enddo emdustsco(k)=(auxr3 + basesumsco(k))*tuningfactorsco enddo !do k=1,klon !auxr1=0.0 !auxr2=0.0 !auxr3=0.0 ! do i=iminacclow,iminacchigh-1 ! auxr1=auxr1+emisbinlocal(k,i) ! enddo ! emdustacc(k)= auxr1*tuningfactor ! do i=imincoalow,imincoahigh-1 ! auxr2=auxr2+emisbinlocal(k,i) ! enddo ! emdustcoa(k)=auxr2*tuningfactor ! do i=iminscolow,iminscohigh-1 ! auxr3=auxr3+emisbinlocal(k,i) ! enddo ! emdustsco(k)=auxr3*tuningfactor !enddo ! !JEdbg<< if (writeaerosoldistrib) then do i=1,nbins do j=1,klon emisbinlocalmean(j,i)=emisbinlocalmean(j,i)+emisbinlocal(j,i) enddo enddo counter1=counter1+1 ! 4 timesteps of physics=4*15min=1hour.. ! 1440 = 15 days ! 480 = 5 days if (MOD(counter,1440).eq. 0) THEN !if (MOD(counter,480).eq. 0) THEN do k = 1,klon do i=1,nbins emisbinlocalmean2(k,i)=emisbinlocalmean(k,i)/float(counter1) enddo enddo counter1=0 ! call gather(emisbinlocalmean2,emisbinlocalmean2_glo) !!$OMP MASTER ! IF (is_mpi_root .AND. is_omp_root) THEN ! CALL writefield_phy("emisbinlocalmean2",emisbinlocalmean2_glo,nbins) CALL writefield_phy("emisbinlocalmean2",emisbinlocalmean2,nbins) ! ENDIF !!$OMP END MASTER !!$OMP BARRIER do i=1,nbins do j=1,klon emisbinlocalmean(j,i)=0.0 enddo enddo endif counter=counter+1 endif !JEdbg>> !CALL abort_gcm('calcdustemission', 'OK1',1) END SUBROUTINE adaptdustemission !-------------------------------------------------------------------------------------- !====================================================================================== !************************************************************************************** !====================================================================================== !-------------------------------------------------------------------------------------- !-------------------------------------------------------- SUBROUTINE initdust(xlat,xlon,pctsrf) USE dimphy USE infotrac_phy, ONLY: nbtr USE write_field_phy USE mod_grid_phy_lmdz USE mod_phys_lmdz_para USE indice_sol_mod IMPLICIT NONE !Inputs REAL,DIMENSION(klon), INTENT(IN) :: xlat REAL,DIMENSION(klon), INTENT(IN) :: xlon ! JE20150605<< better to read ! REAL,DIMENSION(klon), INTENT(IN) :: pctsrf REAL,DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf ! JE20150605>> !Local REAL,DIMENSION(klon,ntyp) :: solini REAL,DIMENSION(klon,ntyp) :: Pini REAL,DIMENSION(klon,ntyp) :: zosini REAL,DIMENSION(klon,ntyp) :: z01ini REAL,DIMENSION(klon,ntyp) :: z02ini REAL,DIMENSION(klon,ntyp) :: Dini REAL,DIMENSION(klon,ntyp) :: Aini REAL,DIMENSION(nclass) :: newstep !TEMPORAL/ MAKE MASK!!! REAL, PARAMETER :: longmin=-20. REAL, PARAMETER :: longmax=77. !35. REAL, PARAMETER :: latmin=10. REAL, PARAMETER :: latmax=40. !TEMPORAL/ MAKE MASK!!! !Local REAL, PARAMETER :: eps=1.e-5 REAL, PARAMETER :: aeff=0.35 REAL, PARAMETER :: xeff=10. REAL, PARAMETER :: trctunt=0.310723 INTEGER :: i,j,k,nts REAL :: dp,dstep ! Parametres pour le calcul de la repartition de l energie feff(klon,ntyp) REAL :: aa,bb,cc,dd,ee,ff REAL,DIMENSION(klon,ntyp) :: tmp1 REAL :: p3t,var1,var2,et ! Parametres pour le calcul de la surface couverte par les particule de diametre ! dp srel(nats,nclass) REAL :: stotale,su,su_loc,xk,xl,xm,xn REAL,DIMENSION(nclass) :: subsoildist ! isolog and massfrac calcs INTEGER :: nbinsout,nb,miniso,nbins1,nbins2,istart,no REAL :: b1,b2,stepbin,minisograd,exden,d2min,d2max,numin,numax REAL :: delta1,delta2,ldmd ! REAL, PARAMETER :: sizedustmin=0.09 REAL,DIMENSION(nbinsHR):: binsISOGRAD REAL,DIMENSION(nbinsHR):: vdISOGRAD REAL,DIMENSION(nbinsHR):: logvdISOGRAD REAL :: curvd REAL :: avdhr REAL :: bvdhr REAL,DIMENSION(nbins) :: dmn1 REAL,DIMENSION(nbins) :: dmn2 REAL,DIMENSION(nbins) :: dmn3 REAL,DIMENSION(nbinsHR) :: vdHR REAL,DIMENSION(nbinsHR) :: vdout ! Parametres pour le calcul de la vitesse de friction seuil uth(nclass) ! calcul de la vitesse seuil selon la parametrisation de Shao and Lu ! 2000(icuth=1). ! INTEGER :: ich1 REAL :: an REAL :: gam REAL :: sigshao REAL :: x1 REAL :: x2 ! Cas de Iversen and White 1982 (icuth=0) si necessaire. REAL, PARAMETER :: adust=1331.647 REAL, PARAMETER :: bdust=0.38194 REAL, PARAMETER :: xdust=1.561228 REAL, PARAMETER :: ddust=0.006/(rop*gravity) CHARACTER(LEN=10) :: varname CHARACTER(LEN=80) :: fnsolspe CHARACTER(LEN=200) :: line ! nats: number of mineral types (14 here for sand, silt, clay etc.) ALLOCATE( binsHR(nbinsHR) ) ALLOCATE( binsHRcm(nbinsHR) ) ALLOCATE( itv(nbins+1) ) ALLOCATE( sizedust(nbins) ) ALLOCATE( szdcm(nbins) ) ALLOCATE( massfrac(ndistb,nbins) ) ALLOCATE( sol(klon,ntyp) ) ALLOCATE( P(klon,ntyp) ) ALLOCATE( zos(klon,ntyp) ) ALLOCATE( z01(klon,ntyp) ) ALLOCATE( z02(klon,ntyp) ) ALLOCATE( D(klon,ntyp) ) ALLOCATE( A(klon,ntyp) ) ALLOCATE( masklisa(klon,ntyp) ) ALLOCATE( solspe(nats,nspe) ) ALLOCATE( feff(klon,ntyp) ) ALLOCATE( feffdbg(klon,ntyp) ) ALLOCATE( sizeclass(nclass) ) ALLOCATE( sizeclass2(nclass) ) ALLOCATE( uth(nclass) ) ALLOCATE( uth2(nclass) ) ALLOCATE( srel(nats,nclass) ) ALLOCATE( srel2(nats,nclass) ) ! read input data from donnees_lisa.nc varname='SOL' CALL read_surface(varname,solini) varname='P' CALL read_surface(varname,Pini) varname='ZOS_' CALL read_surface(varname,zosini) varname='ZO1_' CALL read_surface(varname,z01ini) varname='ZO2_' CALL read_surface(varname,z02ini) varname='D' CALL read_surface(varname,Dini) varname='A' CALL read_surface(varname,Aini) !print *,'beforewritephy',mpi_rank,omp_rank CALL writefield_phy("SOLinit",solini,5) CALL writefield_phy("Pinit",Pini,5) CALL writefield_phy("ZOSinit",zosini,5) CALL writefield_phy("ZO1init",z01ini,5) CALL writefield_phy("ZO2init",z02ini,5) CALL writefield_phy("Dinit",Dini,5) CALL writefield_phy("Ainit",Aini,5) !print *,'afterwritephy',mpi_rank,omp_rank DO i=1,klon DO nts=1,ntyp masklisa(i,nts)=0 IF(Pini(i,nts)>=0.) THEN masklisa(i,nts)=1 ENDIF ENDDO ENDDO !print *,'JEOK1',mpi_rank,omp_rank DO i=1,klon !print *,Pini(i,1),Pini(i,2),Pini(i,3),Pini(i,4),Pini(i,5) DO nts=1,ntyp !IF(xlon(i).ge.longmin.and.xlon(i).le.longmax.and. & !& xlat(i).ge.latmin.and.xlat(i).le.latmax & !& .and.pctsrf(i)>0.5.and.Pini(i,nts)>0.)THEN ! JE20150605<< easier to read IF(pctsrf(i,is_ter)>0.5.and.Pini(i,nts)>0.)THEN ! JE20150605>> sol(i,nts) = solini(i,nts) P(i,nts) = Pini(i,nts) zos(i,nts) = zosini(i,nts) z01(i,nts) = z01ini(i,nts) z02(i,nts) = z02ini(i,nts) D(i,nts) = Dini(i,nts) A(i,nts) = Aini(i,nts) ! masklisa(i,nts)=1 ELSE sol(i,nts) =0.0 P(i,nts) =0.0 zos(i,nts) =0.0 z01(i,nts) =0.0 z02(i,nts) =0.0 D(i,nts) =0.0 A(i,nts) =0.0 ! masklisa(i,nts)=0 ENDIF ENDDO ENDDO ! print *,'JEOK2',mpi_rank,omp_rank if ( 1==1 ) then ! print *,'JEOK4',mpi_rank,omp_rank CALL writefield_phy("SOL",sol,5) CALL writefield_phy("P" ,P ,5) CALL writefield_phy("ZOS",zos,5) CALL writefield_phy("ZO1",z01,5) CALL writefield_phy("ZO2",z02,5) CALL writefield_phy("D" ,D ,5) CALL writefield_phy("A" ,A ,5) CALL writefield_phy("masklisa",float(masklisa),5) CALL writefield_phy("pctsrf",pctsrf,1) CALL writefield_phy("xlon",xlon,1) CALL writefield_phy("xlat",xlat,1) !print *,'JEOK5',mpi_rank,omp_rank !print *,'JEOK6',mpi_rank,omp_rank endif !CALL abort_gcm('initdustemission', 'OK1',1) ! Lecture des donnees du LISA indiquant le type de sol utilise. ! in lines: landuse ! nats: number of mineral types (14 here for sand, silt, clay etc.) ! data format in columns ! mmd1 sigma1 p1 mmd2 sigma2 p2 mmd3 ... alpha !print *,'JEOK7',mpi_rank,omp_rank !$OMP MASTER IF (is_mpi_root .AND. is_omp_root) THEN !print *,'JEOK9',mpi_rank,omp_rank fnsolspe='SOILSPEC.data' PRINT*,' o Reading ',fnsolspe(1:40) OPEN(10,file=fnsolspe) READ(10,*)line DO i=1,nats READ(10,*)line READ(10,*)(solspe(i,j),j=1,nspe) !JE alfa(i)=solspe(i,10) ! PRINT*,'i,alfa(i)',i,alfa(i) ! WRITE(18,*)i,alfa(i) END DO ! print*,'solspe(14,10)= ',solspe(14,10) CLOSE(10) ENDIF !$OMP END MASTER !$OMP BARRIER !print *,'JEOK10',mpi_rank,omp_rank call bcast(solspe) ! Calcul de la distribution en taille des particules de Dust ! Elle depend du nombre de classe des particules nclass. !c making full resolution soil diameter table dstep=0.0005 dp=dmin do i=1,nclass dp=dp*exp(dstep) sizeclass(i)=dp if(dp.ge.dmax+eps)goto 30 newstep(i)=dstep ! WRITE(18,*)i,sizeclass(i) enddo 30 continue ! print*,'IK5' ncl=i-1 ! print*,' soil size classes used ',ncl,' / ',nclass ! print*,' soil size min: ',sizeclass(1),' soil size max: ',sizeclass(ncl) if(ncl.gt.nclass)stop ! Threshold velocity: if (.false.) then !if (.true.) then !c 0: Iversen and White 1982 ! print *,'Using Iversen and White 1982 Uth' do i=1,ncl bb=adust*(sizeclass(i)**xdust)+bdust cc=sqrt(1+ddust*(sizeclass(i)**(-2.5))) xk=sqrt(abs(rop*gravity*sizeclass(i)/roa)) if (bb.lt.10.) then dd=sqrt(1.928*(bb**0.092)-1.) uth(i)=0.129*xk*cc/dd else ee=-0.0617*(bb-10.) ff=1.-0.0858*exp(ee) uth(i)=0.12*xk*cc*ff endif enddo endif if(.true.) then ! 1: Shao and Lu 2000 print *,'Using Shao and Lu 2000 Uth' an=0.0123 gam=0.3 do i=1,ncl sigshao=rop/roa x1=sigshao*gravity*sizeclass(i) x2=gam/(roa*sizeclass(i)) uth(i)=sqrt(an*(x1+x2)) enddo endif !Calcul de la surface couverte par les particules de diametre dp !srel(nats,nclass) ! OPEN(18,file='srel.dat',form='formatted',access='sequential') DO ns=1,nats stotale=0. DO i=1,ncl su=0. DO j=1,nmode nd=((j-1)*3)+1 nsi=((j-1)*3)+2 npi=((j-1)*3)+3 IF (solspe(ns,nd).EQ.0.)THEN su_loc=0. ELSE xk=solspe(ns,npi)/(sqrt(2.*pi)*log(solspe(ns,nsi))) xl=((log(sizeclass(i))-log(solspe(ns,nd)))**2) & & /(2.*(log(solspe(ns,nsi)))**2) xm=xk*exp(-xl) xn=rop*(2./3.)*(sizeclass(i)/2.) su_loc=xm*newstep(i)/xn END IF su=su+su_loc END DO subsoildist(i)=su stotale=stotale+su END DO DO i=1,ncl IF (subsoildist(i).gt.0..and.stotale.gt.0.)THEN srel(ns,i)=subsoildist(i)/stotale ELSE srel(ns,i)=0. END IF ! WRITE(18,*)i,srel(1,i) END DO ! PRINT*,'ns , srel(10000) ',ns,srel(ns,10000) END DO ! Calcul de la repartition de l energie feff(klon,ntyp) !efficient fraction for the friction velocities as a function !of z0s, Zo1 et Zo2 to retrieve the apparent threshold !wind friction velocity. ! feff(:,:)=0. do i=1,klon do k=1,ntyp ! print*,'IKKK ',i,klon,k,ntyp if (zos(i,k).eq.0..or.z01(i,k).eq.0.) then ! if (zos(i,k)<=0..or.z01(i,k)<=0.) then ! if (zos(i,k)<0..or.z01(i,k)<0.) then ! print*,'INI DUST WARNING zos ou z01<0',zos(i,k),z01(i,k) ! endif feff(i,k)=0. feffdbg(i,k)=0. ! print*,'IKKK A ',i,klon,k,ntyp else ! drag partition betzeen the erodable surface and zo1 ! print*,'IKKK B0 ',i,klon,k,ntyp,z01(i,k),zos(i,k),xeff,aeff aa=log(z01(i,k)/zos(i,k)) tmp1(i,k)=aa bb=log(aeff*(xeff/zos(i,k))**0.8) cc=1.-aa/bb feffdbg(i,k)=cc ! print*,'IKKK B1 ',i,klon,k,ntyp ! drag partition between zo1 and zo2 ! feff: total efficient fraction if(D(i,k).eq.0.)then feff(i,k)=cc ! print*,'IKKK C ',i,klon,k,ntyp else dd=log(z02(i,k)/z01(i,k)) ee=log(aeff*(D(i,k)/z01(i,k))**0.8) feff(i,k)=(1.-dd/ee)*cc ! print*,'IKKK D ',i,klon,k,ntyp endif if (feff(i,k).lt.0.)feff(i,k)=0. if (feffdbg(i,k).lt.0.)feffdbg(i,k)=0. if (feff(i,k).gt.1.)feff(i,k)=1. if (feffdbg(i,k).gt.1.)feffdbg(i,k)=1. ! print*,'IKKK E ',i,klon,k,ntyp endif enddo enddo ! JE20150120<< if (flag_feff .eq. 0) then print *,'JE_dbg FORCED deactivated feff' do i=1,klon do k=1,ntyp feff(i,k)=1. enddo enddo endif ! JE20150120>> if (1==1) then ! ! CALL writefield_phy("AA",tmp1(1:klon,1:5),5) ! CALL writefield_phy("REPART5",feff(1:klon,1:5),5) CALL writefield_phy("REPART5dbg",feffdbg(1:klon,1:5),5) endif !c---------------FOR def_prepag01modif(var3a,var3b)----------------------- p3t=0.0001 var1=e3**(1./3.) var2=(rop*pi)**(1./3.) var3a=trctunt*var1/var2 et=e1+(sqrt(p3t*(e3*e3+e1*e2-e2*e3-e1*e3))/p3t) var1=et**(1./3.) var2=(rop*pi)**(1./3.) var3b=trctunt*var1/var2 ! JE20140902: comment all isograd distributions and make own massfrac: ! if (.false.) then !!**************L718 ! !!c------------------------------------------------------------------------ !! isolog distrib and massfrac calculations. ! ! nbinsout=nbins+1 ! b1=log(sizedustmin) ! b2=log(sizedustmax) !! restricted ISOLOG bins distributions ! !! step=(b2-b1)/(nbinsout-1) !! DO ni=1,nbinsout !! itv(ni)=exp(b1+(ni-1)*step) !! ENDDO !!OPEN(18,file='vdepothrsizbin.dat',form='formatted',access='sequential') !! Restricted ISOGRADIENT bins distributions !!!!!!!Making HIGH RESOLUTION dust size distribution (in um)!!!!!! ! stepbin=(b2-b1)/(nbinsHR-1) ! DO nb=1,nbinsHR ! binsHR(nb)=exp(b1+(nb-1)*stepbin) ! END DO ! ! DO nb=1,nbinsHR ! binsHRcm(nb)=binsHR(nb)*1.e-4 ! END DO !! Making HIGH RESOLUTION dry deposition velocity ! CALL calcvd(vdout) ! ! ! DO nb=1,nbinsHR ! vdHR(nb)=vdout(nb) !! WRITE(18,*),binsHR(nb),vdHR(nb) ! END DO ! ! !searching for minimum value of dry deposition velocity ! minisograd=1.e20 ! DO nb=1,nbinsHR ! IF(vdHR(nb).le.minisograd)THEN ! minisograd=vdHR(nb) ! miniso=nb ! END IF ! END DO ! !! searching for optimal number of bins in positive slope Vd part ! ! nbins1=1 ! nbins2=nbinsout-1 ! DO k=1,1000 ! delta1=abs(log(vdHR(1))-log(vdHR(miniso)) )/nbins1 ! delta2=abs(log(vdHR(nbinsHR))-log(vdHR(miniso)))/(nbins2-1) ! IF(delta2.GE.delta1)THEN ! GOTO 50 ! ! ELSE ! nbins2=nbins2-1 ! nbins1=nbins1+1 ! END IF ! IF(nbins2.EQ.1)THEN ! PRINT*,'!! warning: lower limit was found: STOP' ! STOP ! END IF ! END DO ! 50 CONTINUE !print*,'IK10' !! building the optimized distribution ! logvdISOGRAD(1)=log(vdHR(1)) ! binsISOGRAD(1)=binsHR(1) ! DO k=2,nbins1 ! logvdISOGRAD(k)=logvdISOGRAD(1)-(k-1)*delta1 ! END DO ! ! logvdISOGRAD(nbins1+1)=log(minisograd) ! ! DO k=1,nbins2 ! logvdISOGRAD(nbins1+1+k)=logvdISOGRAD(nbins1+1)+k*delta2 ! END DO ! ! DO k=1,nbinsout ! vdISOGRAD(k)=exp(logvdISOGRAD(k)) ! END DO !! sequential search of the correspondig particle diameter ! istart=1 ! DO k=2,nbinsout-1 ! curvd=vdISOGRAD(k) ! DO nb=istart,nbinsHR ! avdhr=vdHR(nb) ! bvdhr=vdHR(nb+1) ! IF(nb.LT.(miniso-1).AND.curvd.LT.avdhr.AND. & ! curvd.GT.bvdhr)THEN ! binsISOGRAD(k)=binsHR(nb) ! istart=nb ! GOTO 60 ! END IF ! IF(nb.eq.miniso)THEN ! binsISOGRAD(k)=binsHR(nb) ! istart=nb+1 ! GOTO 60 ! END IF ! IF(nb.GT.miniso.AND.curvd.GT.avdhr.AND. & ! curvd.LT.bvdhr)THEN ! binsISOGRAD(k)=binsHR(nb) ! istart=nb ! GOTO 60 ! END IF ! END DO ! 60 CONTINUE ! END DO !print*,'IK11' ! binsISOGRAD(nbinsout)=binsHR(nbinsHR) ! vdISOGRAD(nbinsout)=vdHR(nbinsHR) ! DO nb=1,nbinsout ! itv(nb)=binsISOGRAD(nb) ! END DO ! end ! JE20140902 if false ! Making dust size distribution (in um) ! nbinsout=nbins+1 b1=log(sizedustmin) b2=log(sizedustmax) stepbin=(b2-b1)/(nbinsout-1) DO ni=1,nbinsout itv(ni)=exp(b1+(ni-1)*stepbin) ENDDO ! stepbin=(b2-b1)/(nbinsHR-1) ! DO nb=1,nbinsHR ! binsHR(nb)=exp(b1+(nb-1)*stepbin) ! END DO ! ! DO nb=1,nbinsHR ! binsHRcm(nb)=binsHR(nb)*1.e-4 ! END DO DO nb=1,nbins ldmd=(log(itv(nb+1))-log(itv(nb)))/2. sizedust(nb)=exp(log(itv(nb))+ldmd) PRINT*,nb, itv(nb),' < ',sizedust(nb),' < ',itv(nb+1) ENDDO ! Making dust size distribution (in cm) ??? DO nb=1,nbins szdcm(nb)=sizedust(nb)*1.e-4 ENDDO !c preparation of emissions reaffectation. DO k=1,ndistb exden=sqrt(2.)*log(sig(k)) DO nb=1,nbins d2min=itv(nb) d2max=itv(nb+1) numin=log(d2min/diam(k)) numax=log(d2max/diam(k)) massfrac(k,nb)=0.5*(erf(numax/exden)-erf(numin/exden)) !print *,k,nb,massfrac(k,nb) ENDDO ENDDO !$OMP MASTER IF (is_mpi_root .AND. is_omp_root) THEN OPEN (unit=15001, file='massfrac') DO k=1,ndistb DO nb=1,nbins write(15001,*) k,nb,massfrac(k,nb) ENDDO ENDDO ENDIF !$OMP END MASTER !$OMP BARRIER !CALL abort_gcm('calcdustemission', 'OK1',1) !------------ END SUBROUTINE initdust !-------------------------------------------------------------------------------------- !====================================================================================== !************************************************************************************** !====================================================================================== !-------------------------------------------------------------------------------------- SUBROUTINE calcdustemission(debutphy,nsurfwind,zu10m,zv10m,wstar, & ale_bl,ale_wake,param_wstarBL,param_wstarWAKE, & wind10ms, probu, & emisbin) ! emisions over 12 dust bin USE dimphy USE infotrac_phy, ONLY: nbtr IMPLICIT NONE ! Input LOGICAL, INTENT(IN) :: debutphy ! First physiqs run or not INTEGER, INTENT(IN) :: nsurfwind ! First physiqs run or not REAL,DIMENSION(klon),INTENT(IN) :: zu10m ! 10m zonal wind REAL,DIMENSION(klon),INTENT(IN) :: zv10m ! meridional 10m wind REAL,DIMENSION(klon),INTENT(IN) :: wstar REAL,DIMENSION(klon),INTENT(IN) :: ale_bl REAL,DIMENSION(klon),INTENT(IN) :: ale_wake REAL,DIMENSION(klon,nsurfwind),INTENT(IN) :: wind10ms REAL,DIMENSION(klon,nsurfwind),INTENT(IN) :: probu ! Local variables ! INTEGER, PARAMETER :: flag_wstar=150 ! INTEGER, PARAMETER :: flag_wstar=120 ! INTEGER, PARAMETER :: flag_wstar=125 REAL,DIMENSION(klon), INTENT(IN) :: param_wstarWAKE REAL,DIMENSION(klon), INTENT(IN) :: param_wstarBL REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: fluxdust ! horizonal emission fluxes in UNITS for the nmod soil aerosol modes !REAL,DIMENSION(:), ALLOCATABLE,SAVE :: wind10ms ! 10m wind distribution in m/s !REAL,DIMENSION(:), ALLOCATABLE,SAVE :: wind10cm ! 10m wind distribution in cm/s REAL,DIMENSION(klon) :: zwstar !REAL,DIMENSION(nwb) :: probu ! REAL, DIMENSION(nmode) :: fluxN,ftN,adN,fdpN,pN,eN ! in the original code N=1,2,3 REAL :: flux1,flux2,flux3,ft1,ft2,ft3 REAL, PARAMETER :: umin=21. REAL, PARAMETER :: woff=0.5 ! min value of 10m wind speed accepted for emissions REAL :: pdfcum,U10mMOD,pdfu,weilambda REAL :: z0salt,ceff,cerod,cpcent REAL :: cdnms,ustarns,modwm,utmin !JE20150202 REAL :: cdnms,ustarns,modwm REAL :: fdp1,fdp2,ad1,ad2,ad3,flux_diam REAL :: dfec1,dfec2,dfec3,t1,t2,t3,p1,p2,p3,dec,ec ! auxiliar counters INTEGER :: kwb, nwb INTEGER :: i,j,k,l,n INTEGER :: kfin,ideb,ifin,kfin2,istep REAL :: auxreal ! Output !REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: emisbin ! vertical emission fluxes in UNITS for the 12 bins REAL,DIMENSION(klon,nbins) :: emisbin ! vertical emission fluxes in UNITS for the 12 bins !$OMP THREADPRIVATE(fluxdust) !!!$OMP THREADPRIVATE(wind10ms) !!!$OMP THREADPRIVATE(wind10cm) !---------------------------------------------------- ! initialization !---------------------------------------------------- IF (debutphy) THEN ! ALLOCATE( emisbin(klon,nbins) ) ALLOCATE( fluxdust(klon,nmode) ) ! ALLOCATE( wind10ms(klon,nsurfwind) ) !ALLOCATE( wind10cm(nwb) ) ENDIF !debutphy DO i=1,klon DO j=1,nbins emisbin(i,j) = 0.0 ENDDO !j,nbind DO j=1,nmode fluxdust(i,j) = 0.0 ENDDO !j,nmode zwstar(i) = 0.0 ENDDO !i,klon !---------------------------------------------------- ! calculations !---------------------------------------------------- ! including BL processes.. !JE201041120 zwstar=sqrt(2.*(ale_bl+0.01*(flag_wstar-100)*ale_wake)) !JE20141124 zwstar=sqrt(2.*(flag_wstarBL*ale_bl+0.01*(flag_wstar-100)*ale_wake)) ! print !*,'zwstar=sqrt(2.*(',flag_wstarBL,'ale_bl+0.01*(',flag_wstar,'-100)*ale_wake))' ! DO i=1,klon ! main loop ! zwstar(i)=sqrt(2.*(param_wstarBL(i)*ale_bl(i)+param_wstarWAKE(i)*ale_wake(i))) zwstar(i)=sqrt(2.*(param_wstarBL(i)*ale_bl(i))) ! Wind weibull distribution: nwb = nsurfwind ! print*,'GGGGGGGGGGGGGGGGGGGGGGGGG nwb=',nwb DO kwb=1,nwb flux1=0. flux2=0. flux3=0. !JE20141205<< differences in weibull distribution: expectance of the distribution is !0.89*U10mMODD instead of U10mMOD ! now: lambda parameter of weibull ditribution is estimated as ! lambda=U10mMOD/gamma(1+1/kref) ! gamma function estimated with stirling formula DO n=1,ntyp ft1=0. ft2=0. ft3=0. !JE20150129<<<< IF(.FALSE.) THEN ! nat=int(sol(i,n)) ! print *,i,n IF(sol(i,n).gt.1..and.sol(i,n).lt.15.) nat=int(sol(i,n)) !JE20140526<< ! print *,'JE: WARNING: nat=0 forced to nat=99!! and doing nothing' IF(sol(i,n).lt.0.5) THEN nat=99 GOTO 80 ENDIF !JE20140526>> !IF(n.eq.1.and.nat.eq.99)GOTO 80 ! if(n.eq.1) print*,'nat1=',nat,'sol1=',sol(i,n) IF(n.eq.1.and.nat.eq.99)GOTO 80 ENDIF IF(.TRUE.) THEN nat=int(sol(i,n)) if(n == 1 .and. nat >= 14 .or. nat < 1 .or. nat > 19) GOTO 80 ENDIF !JE20150129>>>> z0salt=z02(i,n) ceff=feff(i,n) cerod=A(i,n) cpcent=P(i,n) ustarsalt=0. IF(ceff.le.0..or.z0salt.eq.0.)GOTO 80 IF(cerod.eq.0.or.cpcent.eq.0.)GOTO 80 ! in cm: utmin, umin, z10m, z0salt, ustarns ! in meters: modwm ! no dimension for: cdnms ! Cas ou wsta=0. cdnms=vkarm/(log(z10m/z0salt)) modwm=sqrt((wind10ms(i,kwb)**2)+(1.2*zwstar(i))**2) ustarns=cdnms*modwm*100. ustarsalt=ustarns ! print*,'LAAAAAAAAAAAAAAAAAA modwm=',modwm IF(ustarsalt.lt.umin/ceff)GOTO 80 ! print*,'ustarsalt = ',ustarsalt !---------------------------------------- CALL def_copyncl(kfin) ! CALL def_ag01(kfin,ft1,ft2,ft3) do ni=1,kfin fdp1=1.-(uth2(ni)/(ceff*ustarsalt)) if (fdp1.le.0..or.srel2(nat,ni).eq.0.) then ad1=0. ad2=0. ad3=0. else fdp2=(1.+(uth2(ni)/(ceff*ustarsalt)))**2. flux_diam=cd*srel2(nat,ni)*fdp1*fdp2*(ustarsalt**3) dec=flux_diam*beta ec=(pi/3.)*1.e+2*rop* (sizeclass2(ni)**3) *(ustarsalt**2) dfec1=(ec-e1) dfec2=(ec-e2) dfec3=(ec-e3) t1=0. t2=0. t3=0. if(ec.ge.e1)t1=1. if(ec.ge.e2)t2=1. if(ec.ge.e3)t3=1. if(dfec3.ne.0.)then p1=t1*dfec1/dfec3 p2=t2*(1.-p1)*dfec2/dfec3 else p1=0. p2=0. endif p3=t3*(1.-p1-p2) ad1=(pi/6.)*dec*rop*p1*((diam(1)*1.e-4)**3.)/e1 ad2=(pi/6.)*dec*rop*p2*((diam(2)*1.e-4)**3.)/e2 ad3=(pi/6.)*dec*rop*p3*((diam(3)*1.e-4)**3.)/e3 endif ft1=ft1+ad1 ft2=ft2+ad2 ft3=ft3+ad3 enddo ! of loop over nc !.... flux1=flux1+ft1*cpcent*cerod flux2=flux2+ft2*cpcent*cerod flux3=flux3+ft3*cpcent*cerod ! print *,'JEflux :',kwb,n,flux1,flux2,flux3 80 CONTINUE ENDDO !n=1,ntyp 70 CONTINUE fluxdust(i,1)=fluxdust(i,1)+flux1*probu(i,kwb) fluxdust(i,2)=fluxdust(i,2)+flux2*probu(i,kwb) fluxdust(i,3)=fluxdust(i,3)+flux3*probu(i,kwb) ENDDO !kwb=1,nwb m1dflux(i)=10.*fluxdust(i,1) m2dflux(i)=10.*fluxdust(i,2) ! tous en Kg/m2/s m3dflux(i)=10.*fluxdust(i,3) ENDDO ! i, klon !from horizontal to vertical fluxes for each bin DO k=1,klon DO i=1,ndistb DO j=1,nbins !JE20150202 << emisbin(k,j) = emisbin(k,j)+10*fluxdust(k,i)*massfrac(i,j) !JE20150202 >> ENDDO !j, nbind ENDDO !i, nmode ENDDO !k,klon !print *,' JE fluxdust in calcdust' ! DO k=1,klon ! DO i=1,ndistb !!print *,k,i,fluxdust(k,i) !enddo !enddo !print *,' JE emisbin in calcdust' !do k=1,klon !do j=1,nbins !!print *,k,j,emisbin(k,j) !enddo !enddo ! CALL abort_gcm('calcdustemission', 'OK1',1) END SUBROUTINE calcdustemission !-------------------------------------------------------------------------------------- !====================================================================================== !************************************************************************************** !====================================================================================== !-------------------------------------------------------------------------------------- SUBROUTINE def_copyncl(kfin) implicit none integer i,n,kfin,ideb,ifin,istep,kfin2 real dsmin,dsmax ! estimation of the reduced soil size distribution dsmin=var3a*(ustarsalt**(-2./3.)) dsmax=var3b*(ustarsalt**(-2./3.)) ! print*,'ustarsalt = ',ustarsalt,'dsmin=',dsmin,'dsmax=',dsmax ! dichotomy call def_dichotomy(sizeclass,nclass,1,ncl,dsmin,ideb) ! print*,'ideb = ',ideb call def_dichotomy(sizeclass,nclass,ideb,ncl,dsmax,ifin) ! print*,'ifin = ',ifin ! readaptation of large sizes particles kfin=0 do i=ideb,ifin kfin=kfin+1 sizeclass2(kfin)=sizeclass(i) uth2(kfin)=uth(i) srel2(nat,kfin)=srel(nat,i) enddo ! print*,'je suis la' kfin2=kfin istep=50 do i=ifin,ncl,istep kfin=kfin+1 sizeclass2(kfin)=sizeclass(i) uth2(kfin)=uth(i) srel2(nat,kfin)=srel(nat,i)*istep enddo if(kfin.ge.nclass)then ! print*,'$$$$ Tables dimension problem:',kfin,'>',nclass endif !--------------- return END SUBROUTINE def_copyncl !-------------------------------------------------------------------------------------- !====================================================================================== !************************************************************************************** !====================================================================================== !-------------------------------------------------------------------------------------- subroutine def_dichotomy(siz,nclass,i1,i2,ds,iout) !c--------------------------------------------------------------- !c 'size' is the table to scan !c of dimension 'nclass', and reduced size of interest [i1:i2] !c 'ds' is the value to find in 'size' !c 'iout' is the number in the table 'size' correspondig to 'ds' !c--------------------------------------------------------------- implicit none integer i1,i2,nclass,iout,ismin,ismax,k2,ihalf,idiff real siz(nclass),ds !c----------------------------- iout=0 ismin=i1 ismax=i2 ihalf=int((ismax+ismin)/2.) do k2=1,1000000 if(ds.gt.siz(ihalf))then ismin=ihalf else ismax=ihalf endif ihalf=int((ismax+ismin)/2.) idiff=ismax-ismin if(idiff.le.1)then iout=ismin goto 52 endif enddo 52 continue if(iout.eq.0)then print*,'$$$$ Tables dimension problem: ',iout endif end subroutine def_dichotomy !-------------------------------------------------------------------------------------- !====================================================================================== !************************************************************************************** !====================================================================================== !-------------------------------------------------------------------------------------- SUBROUTINE calcvd(vdout) IMPLICIT NONE INTEGER :: nb !JE already def in module INTEGER,PARAMETER :: nbinsHR=3000 INTEGER,PARAMETER :: idiffusi=1 INTEGER,PARAMETER :: idrydep=2 REAL :: dmn1,dmn2,dmn3,ra,rb REAL :: rhod,muair,nuair,R,airmolw REAL :: bolz,rhoair,gravity,karman,zed,z0m REAL :: ustarbin,temp,pres,rac,lambda,ccexp REAL :: Cc,rexp,pi,St REAL,DIMENSION(nbinsHR) :: setvel REAL,DIMENSION(nbinsHR) :: diffmol1 REAL,DIMENSION(nbinsHR) :: diffmol2 REAL,DIMENSION(nbinsHR) :: schmidtnumb REAL,DIMENSION(nbinsHR) :: diffmole REAL,DIMENSION(nbinsHR), INTENT(OUT) :: vdout ! users physical parameters temp=273.15+25. ! in Kelvin degrees pres=1013. ! in hPa ! calculation of Ra zed=10. z0m=0.05 karman=0.41 ustarbin=30. ! cm/s ra=log(zed/z0m)/(karman*ustarbin) !c physical constants (all must in units g / cm / s) rhod=2.65 ! g.cm-3 muair=1.72e-4 ! g.cm-1.s-1 nuair=0.1461 ! air kinematic viscosity [cm2.s-1] R=8.314 ! molar gas constant J.mol-1.K-1 airmolw=28.8 ! molar weight of air bolz=1.38e-16 ! g.cm2.s-2 rhoair=1.225e-3 ! g.cm-3 gravity=981. ! gravity [cm.s-2] pi=3.14159 rac=sqrt(8.0*airmolw/(pi*R*temp)) lambda=(2.*muair)/(pres*rac) ! c Cc and Vs ! binsHRcm=binsize*1.e-4 DO nb=1,nbinsHR ccexp=exp((-0.55*binsHRcm(nb))/lambda) Cc=1.+(2.*lambda)/binsHRcm(nb)*(1.257+0.4*ccexp) setvel(nb)=(1./18.)*((binsHRcm(nb))**2*rhod*gravity*Cc)/muair !c Molecular diffusivity (s/cm2) and Schmidt number !c Note that the molecular diffusivity uses diameter in micro-m !c to give a result directly in s/cm2 dmn1=2.38e-7/binsHR(nb) dmn2=0.163/binsHR(nb) dmn3=0.0548*exp(-6.66*binsHR(nb))/binsHR(nb) diffmol1(nb)=dmn1*(1.+dmn2+dmn3) diffmol2(nb)=bolz*temp*Cc/(3.*pi*muair*binsHRcm(nb)) IF(idiffusi.EQ.1)diffmole(nb)=diffmol1(nb) IF(idiffusi.EQ.2)diffmole(nb)=diffmol2(nb) schmidtnumb(nb)=nuair/diffmole(nb) St=setvel(nb)*ustarbin*ustarbin/(gravity*nuair) rb=1./(ustarbin*((schmidtnumb(nb))**(-2./3.)+10.**(-3./St))) !c wesely (primarily designed for gases) IF(idrydep.EQ.1)THEN vdout(nb)=1./(ra+rb+ra*rb*setvel(nb))+setvel(nb) END IF !c venkatram and pleim (more adaptated to particles but numerically unstable) IF(idrydep.EQ.2)THEN rexp=exp(-(ra+rb)*setvel(nb)) vdout(nb)=setvel(nb)/(1.-rexp) END IF END DO !c----------------- RETURN END SUBROUTINE calcvd END MODULE dustemission_mod