File:Lgm europe mpiesm treefrac 1.svg

Summary

Description
English: Tree fraction in Europe, Last Glacial Maximum, downscaled MPI-ESM
Date
Source Own work
Author Merikanto
SVG development
InfoField
 
The SVG code is valid.
Category:Large SVG files#003476
 
This oversized map was created with an unknown SVG tool.
Category:Valid SVG created with Other tools:Maps#Lgm%20europe%20mpiesm%20treefrac%201.svgCategory:SVG images with poorly traced elements

Source of data is CERA WDC lgm MPI-ESM dataset. "treeFrac_Lmon_MPI-ESM-P_lgm_r1i1p2_185001-194912.nc"

install_libraries=FALSE

if(install_libraries==TRUE) {

install.packages("raster")
install.packages("rgdal")
install.packages("sp")
install.packages("spatialEco")
install.packages("ncdf4")
install.packages("dissever")
install.packages("viridis")
install.packages("dplyr")
install.packages("lattice")
install.packages("RColorBrewer")
install.packages("rgeos")
install.packages("sp")
install.packages("reshape2")
install.packages("data.table")
install.packages("stringr")
install.packages("rlist")
install.packages("pipeR")
install.packages("maptools")
install.packages("gdata", dependencies=TRUE)
install.packages("abind")
install.packages("Cairo")
install.packages("pals")
install.packages("REdaS")
install.packages("easyNCDF")
install.packages("numbers")
install.packages("rasterVis")
install.packages("OceanView")
install.packages("rainfarmr")

}

library(raster) library(rgdal) library(ncdf4) library(lattice) library(maptools) library(rgeos) library(spatialEco) library(dissever) library(rainfarmr)

library(RColorBrewer) library(viridis) library(pals) library(data.table) library(stringr) library(rlist) library(pipeR) library(rasterVis)

  1. library(OceanView)

library(sp) library(reshape2)

library(dplyr) library(REdaS) library(easyNCDF) library(numbers)

  1. library(gdata)

library(abind)

  1. bioname_11="D:/datav3/CHELSA_PMIP_CCSM4_BIO_11.tif" # temperature of coldest 3 month
  2. bioname_19="D:/datav3/CHELSA_PMIP_CCSM4_BIO_19.tif" ## precip of coldest 3 month
  1. bioname_10="D:/datav3/CHELSA_PMIP_CCSM4_BIO_11.tif"

bioname_10="D:/data_processed/beringia_chelsa_bio_lgm/bio10.nc" bioname_5="D:/data_processed/beringia_chelsa_bio_lgm/bio5.nc"

downscale_dissever <- function (coarse_rastera, fine_stack, dismethod, samplerate) {

   print ("Dissever()")		
       names(fine_stack)


coarse_raster<-coarse_rastera


   p1<-fine_stack$Elevation


  1. plot(p1)
  1. return(0)

coarseoro<- resample(p1, coarse_raster) coarseoro_big<-resample(coarseoro, p1) orodelta<-(p1-coarseoro_big)

baset1 <- resample(coarse_raster, p1)

raster_stack <- fine_stack

min_iter <- 5 # Minimum number of iterations max_iter <- 10 # Maximum number of iterations p_train <- samplerate # Subsampling of the initial data

oma_juttu <- dissever(coarse = coarse_raster, fine = raster_stack, method = dismethod, p = p_train, min_iter = min_iter,max_iter = max_iter, verbose=1) orotemp<-oma_juttu$map

#tempiso<-baset1+oma_juttu$map+biassi

coarseorotemp<- resample(orotemp, coarse_raster) coarseorotemp_big<-resample(coarseorotemp, p1)

orotempdelta<-orotemp-coarseorotemp_big

outtemp<-baset1+orotempdelta

  1. plot(outtemp, col=rev(rainbow(256)) )
  1. outtempr<-rotate(outtemp)

#plot(outtempr)

     return(outtemp)
}

downscale_raster <- function (coarse_rastera, fine_rastera, method) { ## methods: 0 delta, 1 spatialeco, 2 dissever, 3 temperature lapse 6.5 C/1 km lm 

   print ("Downscaler()")

coarse_raster<-coarse_rastera fine_raster<-fine_rastera p1<-fine_raster p2<-fine_raster

  1. plot(fine_raster)
  2. plot(coarse_raster, col=viridis(200))

coarseoro<- resample(p1, coarse_raster) coarseoro_big<-resample(coarseoro, p1) orodelta<-(p1-coarseoro_big)

baset1 <- resample(coarse_raster, p1)

raster_stack <- stack(p1,p2)

min_iter <- 5 # Minimum number of iterations max_iter <- 20 # Maximum number of iterations p_train <- 1.0 # Subsampling of the initial data

	 if(method>9999)
	 {

method=2 }

## dissever run 

   if(method==2)

{ oma_juttu <- dissever(coarse = coarse_raster, fine = raster_stack, method = "glm", p = p_train, min_iter = min_iter,max_iter = max_iter, verbose=1) orotemp<-oma_juttu$map }

## spatialeco downscale if(method==1) { oma_juttu2 <- raster.downscale(p1, coarse_raster) orotemp<-oma_juttu2$downscale }

    1. delta regression 1,1

if(method==0) {

orotemp<-orodelta

   	}
    1. delta regression by lapse rate

if(method==3) { orotemp<-orodelta*0.0065*-1

   	}

#biassi=4

#tempiso<-baset1+oma_juttu$map+biassi

coarseorotemp<- resample(orotemp, coarse_raster) coarseorotemp_big<-resample(coarseorotemp, p1)

orotempdelta<-orotemp-coarseorotemp_big

outtemp<-baset1+orotempdelta

  1. plot(outtemp, col=rev(rainbow(256)) )
  1. outtempr<-rotate(outtemp)

#plot(outtempr)

     return(outtemp)
}


downscale_dissever <- function (coarse_rastera, fine_stack, dismethod, samplerate) {

   print ("Dissever()")		
       names(fine_stack)


coarse_raster<-coarse_rastera


   p1<-fine_stack$Elevation


  1. plot(p1)
  1. return(0)

coarseoro<- resample(p1, coarse_raster) coarseoro_big<-resample(coarseoro, p1) orodelta<-(p1-coarseoro_big)

baset1 <- resample(coarse_raster, p1)

raster_stack <- fine_stack

min_iter <- 5 # Minimum number of iterations max_iter <- 10 # Maximum number of iterations p_train <- samplerate # Subsampling of the initial data

oma_juttu <- dissever(coarse = coarse_raster, fine = raster_stack, method = dismethod, p = p_train, min_iter = min_iter,max_iter = max_iter, verbose=1) orotemp<-oma_juttu$map

#tempiso<-baset1+oma_juttu$map+biassi

coarseorotemp<- resample(orotemp, coarse_raster) coarseorotemp_big<-resample(coarseorotemp, p1)

orotempdelta<-orotemp-coarseorotemp_big

outtemp<-baset1+orotempdelta

  1. plot(outtemp, col=rev(rainbow(256)) )
  1. outtempr<-rotate(outtemp)

#plot(outtempr)

     return(outtemp)
}

writeout<-function(oras, outn, varnamex, varunitx, longnamex) {

crs(oras) <- "+proj=longlat +datum=WGS84 +no_defs +ellps=WGS84 +towgs84=0,0,0" writeRaster(oras, filename=outn, overwrite=TRUE, format="CDF", varname=varnamex, varunit=varunitx, longname=longnamex, xname="lon", yname="lat")

}

    1. snow

downscale_cmip5_variable <- function(dataname1, invarname1, instak1, posit, numyears, month1, methodi1, submethodi1, subaccuracu1) {

print("Loading data ...")

nppin1 <- nc_open(dataname1)

vext1<-c(0,360,-90,90)

lok1=posit*12+month1 mara=numyears*12

stacksnow1<-stack()

for(n in 1:mara) { # print (".") snow00 <- ncvar_get( nppin1, varid=invarname1,start=c(1,1,lok1), count=c(-1,-1,1) )

snow01=t(snow00) snow02<-apply(snow01,2,rev)

snow0=raster(snow02)

extent(snow0)<-vext1 names(snow0)<-invarname1

snow2=rotate(snow0)

crs(snow2) <- "+proj=longlat +datum=WGS84 +no_defs +ellps=WGS84 +towgs84=0,0,0"

stacksnow1 <- stack( stacksnow1 , snow2 )


lok1=lok1+12

}

   rasnow0<-mean(stacksnow1)
   
    print (rasnow0)
  
   rasnow1=rasnow0
   
    rasnow1[is.na(rasnow1)] <- 0


print("Downscaling ...")

#methodi1, submethodi1, subaccuracu1 if(methodi1==2) {

out3<-downscale_dissever(rasnow1, instak1, submethodi1, subaccuracu1) }



  return(out3)
    1. loadipslnpp
 }

rasteroi <-function() { ##rasterize ehrels gibbard lgm glaciers shapefiles

p1 <- shapefile('C:/Users/himot/aglacgis1/lgm.shp') #p1 <- shapefile('C:/Users/himot/aglacgis1/lgm_global.shp') p2 <- shapefile('C:/Users/himot/aglacgis1/lgm_alpen.shp') #p3 <- shapefile('C:/Users/himot/aglacgis1/lgm_asia_west.shp') #p4 <- shapefile('C:/Users/himot/aglacgis1/lgm_kuhle_asia.shp') p5 <- shapefile('C:/Users/himot/aglacgis1/mountain_glaciers.shp')

print("Nuk") p <- bind(p1,p2)

pgeo <- spTransform(p, CRS('+proj=longlat +datum=WGS84')) ext <- floor(extent(pgeo))


#reso2=360/43200 #reso2=0.05 reso2=0.05 rr <- raster(ext, res=reso2) #rr <- rasterize(pgeo, rr, field=1) #rr <- fasterize(pgeo, rr, field = "value", fun="sum") rr <- rasterize(pgeo, rr, field = 1) plot(rr) writeout(rr, "lgm_ice_sheet", "ice", "ice", "Ices Sheets") }

create_stack_variables_1<-function(rext1) {

   ptopet0<-raster("d:/razter/lgm_ptopet_2_5m.tif")
   annprecip0<-raster("d:/razter/bio_12.tif")

anntemp0<-raster("d:/razter/bio_1.tif") warmprecip0<-raster("d:/razter/bio_18.tif") warmtemp0<-raster("d:/razter/bio_10.tif")

 	topowet0<-raster("d:/razter/lgm_2-5arcmin_topoWet.tif")
 	gdd00<-raster("d:/razter/lgm_ccsm4_2-5arcmin_growingDegDays0.tif")
 	## WARNING TEST ONLY KOE
 	icesheet0<-raster("./lgm_ice_sheet.nc")
 	 
 	 ## bio 18 warmest precip
 	 ## bio 10 warmest temp 	
 	  	  	  	
 	ptopet1<<-crop(ptopet0, rext1) 	
 	annprecip1<<-crop(annprecip0, rext1)
   anntemp1<<-crop(anntemp0, rext1) 
   warmprecip1<<-crop(warmprecip0, rext1)
   warmtemp1<<-crop(warmtemp0, rext1)  	
 	topowet1<<-crop(topowet0, rext1)	
 	gdd01<<-crop(gdd00, rext1)
 #	icesheet10<<-crop(icesheet0, rext1)

print(dim(annprecip1)[1:2]) dimx1<-dim(annprecip1)[1] dimy1<-dim(annprecip1)[2] print (dimx1) print (dimy1)

icesheet1<<-crop(icesheet0, rext1)

icesheet2 <- raster(nrow=dimx1, ncol=dimy1) extent(icesheet2)<-extent(annprecip1) icesheet2 <- resample(icesheet1, icesheet2, method='bilinear')

    #plot(icesheet2)
   writeout(icesheet2, "europe_ice_sheets.nc", "ice", "ice", "Ices Sheets")
 
   icesheet2[is.na(icesheet2)]<-0
   icesheet2[icesheet2!=0]<-1
 
   names(ptopet1)<<-"PTOPET"
   names(annprecip1)<<-"PrecipAnn"    
   names(anntemp1)<<-"TempAnn"
   names(warmprecip1)<<-"PrecipWarm"    
   names(warmtemp1)<<-"TempWarm"
   names(topowet1)<<-"Topowet" 
   names(gdd01)<<-"GDD0"
   #names(icesheet2)<<-"ice"
    1. NOTE first raster must be nameed "Elevation" , due to subroutine implementation
    names(ptopet1)<-"Elevation"
    #dstak1<-stack(anntemp1, annprecip1, ptopet1,topowet1,icesheet2)
        
    dstak1<-stack(ptopet1,annprecip1, anntemp1,icesheet2, topowet1)


    ## note remove NA
#    dstak1[is.na(dstak1)] <- 0
    
    
 	 return(dstak1)

}

    1. program init
    1. europe
  2. lon1=-15.0
  3. lon2=40.0
  4. lat1=30.0
  5. lat2=70.0
  1. beringia
  2. lon1=-180
  3. lon2=-120
  4. lat1=50.0
  5. lat2=80.0

reurope<-c(-15,40,30,70) rberingia<-c(-180,-120,50,80)

    1. kolmas: grassfrac
  1. infilname2<-"d:/varasto_iceagesimu/grassFrac_Lmon_IPSL-CM5A-LR_lgm_r1i1p1_260101-280012.nc"
  2. infilname2<-"d:/varasto_iceagesimu/"

infilname2<-"d:/varasto_iceagesimu/treeFrac_Lmon_MPI-ESM-P_lgm_r1i1p2_185001-194912.nc"

invarname2<-"treeFrac" posit=0 numyears=8 month1=7

  1. rext3<-c(-180,-120,50,80) # beringia

rext1<-reurope

methodi1=2 submethodi1="glm" subaccuracu1=1.0 instak1<-create_stack_variables_1(rext1)

print (instak1)

rds3<-downscale_cmip5_variable(infilname2, invarname2, instak1, posit, numyears, month1, methodi1, submethodi1, subaccuracu1) rds4<-rds3 rds4[rds4<0] <- 0 writeout(rds4,"./lgm_europe_mpiesm_treefrac_1.nc","treefrac (LGM MPI-ESM)", "MPI-ESM", "Fraction of Trees, Last Glacial Maximum, Europe")

Licensing

I, the copyright holder of this work, hereby publish it under the following license:
w:en:Creative Commons
attribution share alike
This file is licensed under the Creative Commons Attribution-Share Alike 4.0 International license.
You are free:
  • to share – to copy, distribute and transmit the work
  • to remix – to adapt the work
Under the following conditions:
  • attribution – You must give appropriate credit, provide a link to the license, and indicate if changes were made. You may do so in any reasonable manner, but not in any way that suggests the licensor endorses you or your use.
  • share alike – If you remix, transform, or build upon the material, you must distribute your contributions under the same or compatible license as the original.
Category:CC-BY-SA-4.0#Lgm%20europe%20mpiesm%20treefrac%201.svg
Category:Self-published work Category:Ice age maps of Europe
Category:CC-BY-SA-4.0 Category:Ice age maps of Europe Category:Large SVG files Category:SVG images with poorly traced elements Category:Self-published work Category:Valid SVG created with Other tools:Maps