diff --git a/MY_RUN/KTEST/004_Reunion/005_ncl_extractdia/MESONHtools.ncl b/MY_RUN/KTEST/004_Reunion/005_ncl_extractdia/MESONHtools.ncl index 6f810bbfdb30b4e658f289d87d1680a80b5b66fe..9cae6400a0dade82e20ba68463722fbb13d4c81d 100644 --- a/MY_RUN/KTEST/004_Reunion/005_ncl_extractdia/MESONHtools.ncl +++ b/MY_RUN/KTEST/004_Reunion/005_ncl_extractdia/MESONHtools.ncl @@ -1,915 +1,915 @@ -load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" -load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" -load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" -load "$NCARG_ROOT/lib/ncarg/nclscripts/wrf/WRFUserARW.ncl" - -;------------------------------------------------------------- -;contains: -; procedure MESONH_map_c -;function mnh_map(wks[1]:graphic,in_file[1]:file,opt_args[1]:logical) -;function mnh_map_overlays(in_file[1]:file,wks:graphic,plots[*]:graphic, \ -; opt_arg[1]:logical,opt_mp[1]:logical) -;function MESONH_pinter( pfield:numeric, loc_param:numeric, ppabs:numeric ) -;------------------------------------------------------------- - -;============================================================== -; J.-P. CHABOUREAU -; This is a driver that selects the appropriate -; mapping function based upon the file variables RPK, BETA, LATOR, LONOR -; -; -; Sample usage: -; a = addfile("...", r") -; IMAX = a->IMAX -; JMAX = a->JMAX -; lat2d = new((/JMAX,IMAX/),"double") -; lat2d(:,:)=0. -; lon2d = new((/JMAX,IMAX/),"double") -; lon2d(:,:)=0. -; icorners = new((/2,2/),"integer") -; icorners(:,:)=0 -; res = True -; MESONH_map_c (a, res, lat2d, lon2d, icorners) -; -; -undef("MESONH_map_c") -;============================================================== -procedure MESONH_map_c (in_file:file, res:logical, plat, plon, icorner) -;============================================================== -;local rank, dimll, nlat, mlon, lat, lon -local rank, dimll, nlat, mlon -begin - -; Check if the variable RPK is in the file -; ---------------------------------------- -if(isfilevar(in_file,"RPK")) then - -; Read projection parameters -; ------------------------- - ZRPK = in_file->RPK - ZLATOR = in_file->LATOR - ZLONOR = in_file->LONOR - ZBETA = in_file->BETA - ZLAT0 = in_file->LAT0 - ZLON0 = in_file->LON0 - -; Case netcdf from lfi2cdf -; ------------------------- - - if(isfilevar(in_file,"IMAX")) - XHAT=in_file->XHAT - YHAT=in_file->YHAT - IMAX= dimsizes(XHAT)-2 - JMAX= dimsizes(YHAT)-2 - zdx=XHAT(2)-XHAT(1) - zdy=YHAT(2)-YHAT(1) - -; unstagger - do ji=0,IMAX-1 - XHAT(ji)=XHAT(ji)+zdx*1.5 - end do - do jj=0,JMAX-1 - YHAT(jj)=YHAT(jj)+zdy*1.5 - end do - - else - -; Case netcdf from extractdia -; --------------------------- - XHAT=in_file->W_E_direction - YHAT=in_file->S_N_direction - IMAX= dimsizes(XHAT) - JMAX= dimsizes(YHAT) - zdx=XHAT(2)-XHAT(1) - zdy=YHAT(2)-YHAT(1) - - end if - - print ("LATOR="+ZLATOR+" - LONOR="+ZLONOR) - print ("ZLAT0="+ZLAT0+" - ZLON0="+ZLON0) - print ("ZDX="+zdx+" - RPK="+ZRPK+" - BETA="+ZBETA) - print ("IMAX="+IMAX+" - JMAX="+JMAX) - - if (ZRPK.gt.0) - ; Stereographic projection -; --------------------------- - res@mpProjection = "Stereographic" - res@mpCenterLonF = ZLON0 - res@mpCenterRotF = ZBETA - res@mpCenterLatF = 90. - end if - - if (ZRPK.lt.0) - ; Stereographic projection -; --------------------------- - res@mpProjection = "Stereographic" - res@mpCenterLonF = ZLON0 - res@mpCenterRotF = ZBETA - res@mpCenterLatF = -90. - end if - - if (ZRPK.eq.0) then - ; Mercator projection -; --------------------------- - res@mpProjection = "Mercator" - end if - - print("Map projection="+res@mpProjection) - -else - print ("MESONH_map_c: Error no RPK variable in input file") -end if - -;=================================================; -; calculate 2D lat and lon -; based on src/mesonh_MOD/mode_gridproj.f90 -;=================================================; - -; Constants -; ----------- - if(isfilevar(in_file,"IMAX")) - XRADIUS=6371229.0d ; Earth radius (meters) - else - XRADIUS=6371.2290d ; Earth radius (km) - end if - XPI=2.0d*asin(1.) ; Pi - ZRDSDG= XPI/180.0d ; Radian to Degree conversion factor - ZXBM0 = 0.0d - ZYBM0 = 0.0d - -;=================================================; - if (ZRPK.eq.0) then -; MERCATOR -;=================================================; - XBETA=0. - XLAT0=0. ; map reference latitude (degrees) - ZXBM0 = 0. - ZYBM0 = 0. - ZCGAM = cos(-ZRDSDG*XBETA) - ZSGAM = sin(-ZRDSDG*XBETA) - ZRACLAT0 = XRADIUS*cos(ZRDSDG*ZLAT0) - do ji=0,IMAX-1 - jj=0 - ZXMI0 = XHAT(ji)-ZXBM0 - ZYMI0 = YHAT(jj)-ZYBM0 - zlon = (ZXMI0*ZCGAM+ZYMI0*ZSGAM)/(ZRACLAT0*ZRDSDG)+ZLONOR - do jj=0,JMAX-1 - plon(jj,ji)=zlon - end do - end do - do jj=0,JMAX-1 - ji=0 - ZXMI0 = XHAT(ji)-ZXBM0 - ZYMI0 = YHAT(jj)-ZYBM0 - ZT1 = log(tan(XPI/4.+ZLATOR*ZRDSDG/2.)) - ZT2 = (-ZXMI0*ZSGAM+ZYMI0*ZCGAM)/ZRACLAT0 - zlat = (-XPI/2.+2.*atan(exp(ZT1+ZT2)))/ZRDSDG - do ji=0,IMAX-1 - plat(jj,ji)=zlat - end do - end do - -;=================================================; - else -; STEREOGRAPHIC PROJECTION -;=================================================; - ZCLAT0 = cos(ZRDSDG*ZLAT0) - ZSLAT0 = sin(ZRDSDG*ZLAT0) - ZCLATOR = cos(ZRDSDG*ZLATOR) - ZSLATOR = sin(ZRDSDG*ZLATOR) - ZRO0 = (XRADIUS/ZRPK)*(abs(ZCLAT0))^(1.-ZRPK) * \ - ((1.+ZSLAT0)*abs(ZCLATOR)/(1.+ZSLATOR))^ZRPK - ZGA0 = (ZRPK*(ZLONOR-ZLON0)-ZBETA)*ZRDSDG - ZXP = ZXBM0-ZRO0*sin(ZGA0) - ZYP = ZYBM0+ZRO0*cos(ZGA0) - do ji=0,IMAX-1 - do jj=0,JMAX-1 - ZATA = atan2( -(ZXP-XHAT(ji)) , (ZYP-YHAT(jj)) )/ZRDSDG - zlon = (ZBETA+ZATA)/ZRPK+ZLON0 - plon(jj,ji)=zlon - ZRO2 = (XHAT(ji)-ZXP)^2+(YHAT(jj)-ZYP)^2 - ZJD1 = XRADIUS*(abs(ZCLAT0))^(1.-ZRPK) - ZT1 = (ZJD1)^(2./ZRPK)* (1+ZSLAT0)^2 - ZJD3 = (ZRPK^2*ZRO2) - ZT2 = ZJD3 - ZT2 = ZT2^(1./ZRPK) - ZJD1 = (ZT1-ZT2)/(ZT1+ZT2) - ZJD1 = acos(ZJD1) - ZJD3 = ZJD1 - zlat = (XPI/2.-ZJD3)/ZRDSDG - plat(jj,ji)=zlat - end do - end do - - end if - -; Defining the corners of the domain -;==================================== - if (icorner(0,0).eq.icorner(1,1)) then - icorner(0,0)=0 - icorner(1,0)=JMAX-1 - icorner(0,1)=0 - icorner(1,1)=IMAX-1 - end if -; print ("icorner"+icorner) - - res@mpLimitMode = "Corners" - res@mpLeftCornerLatF = plat(icorner(0,0),icorner(0,1)) - res@mpLeftCornerLonF = plon(icorner(0,0),icorner(0,1)) - res@mpRightCornerLatF = plat(icorner(1,0),icorner(1,1)) - res@mpRightCornerLonF = plon(icorner(1,0),icorner(1,1)) - -; print ("Corner (0,0); Lat="+res@mpLeftCornerLatF+ \ -; ", Lon="+res@mpLeftCornerLonF) -; print ("Oppos corner; Lat="+res@mpRightCornerLatF+ \ -; ", Lon= "+res@mpRightCornerLonF) - -;========================================== -; Turn on lat / lon labeling -;========================================== - res@pmTickMarkDisplayMode = "Always" ; turn on tickmarks - res@mpOutlineBoundarySets = "AllBoundaries" ; state boundaries - res@mpPerimDrawOrder = "PostDraw" ; force map perim -;========================================== -; Needed for regional native projection -;========================================== - res@tfDoNDCOverlay = True - res@gsnAddCyclic = False ; regional data - -end - -;=========================================== -;------------------------------------------------------------------------ -undef("MESONH_pinter") -function MESONH_pinter( pfield:numeric, loc_param:numeric, ppabs:numeric ) -;************************************************************************* -; S. BIELLI -; This is a routine that interpolate fields on pressure level for plotting -; based on pinter.f90 -; The field to be interpolated must be given at the mass point (grid 1) -; usage : var_inter=MESONHfunction(var_to_interpol, 850., AbsPressure) -; Abs pressure must be in Pa -; - -begin - - dimL= dimsizes(loc_param) - -; First test for grid = 0 - - dimp=dimsizes(ppabs) - - pout=pfield(0:dimL-1,:,:) - pfield@_FillValue=999 - pout@_FillValue=999 - pout=pout@_FillValue - - do jkp = 0, dimL-1 - zref=log10(loc_param(jkp)*100.) - do jloop = 0, dimp(1)-1 - do iloop = 0, dimp(2)-1 - kloop=0 - flag=True - do while (flag .and. (kloop.lt.(dimp(2)-2))) - if (.not.ismissing(ppabs(kloop,jloop,iloop))) then - zxm=log10(ppabs(kloop,jloop,iloop)) - zxp=log10(ppabs(kloop+1,jloop,iloop)) - if ((zxp-zref)*(zref-zxm) .ge. 0) then - pout(jkp,jloop,iloop)= (pfield(kloop,jloop,iloop)*(zxp-zref)+ \ - pfield(kloop+1,jloop,iloop)*(zref-zxm))/ (zxp-zxm) - flag=False - end if - end if - kloop=kloop+1 - end do - end do - end do - end do - - return(pout) - -end - -;-------------------------------------------------------------------------------- -undef("mnh_map") -function mnh_map(wks[1]:graphic,in_file[1]:file,opt_args[1]:logical) - -begin -; -; This function creates a map plot, and bases the projection on -; the MAP_PROJ attribute in the given file. -; -; 1. Make a copy of the resource list, and set some resources -; common to all map projections. -; -; 2. Determine the projection being used, and set resources based -; on that projection. -; -; 3. Create the map plot, and draw and advance the frame -; (if requested). - - opts = opt_args ; Make a copy of the resource list - opts = True - -; Set some resources depending on what kind of map projection is -; chosen. -; -; ZRPK != 0 : "Stereographic" -; ZRPK = 0 : "Mercator" -;=================================================; -; src/mesonh_MOD/mode_gridproj.f90 -;=================================================; - XRADIUS=6371229.0d ; Earth radius (meters) - XPI=2.0d*asin(1.) ; Pi - ZRDSDG= XPI/180.0d ; Radian to Degree conversion factor - ZXBM0 = 0.0d - ZYBM0 = 0.0d - - if(isfilevar(in_file,"RPK")) - ZRPK=in_file->RPK - ZLON0=in_file->LON0 - ZLAT0=in_file->LAT0 - ZLATOR=in_file->LATOR - ZLONOR=in_file->LONOR - ZBETA=in_file->BETA - else - print ("mnh_map: Error no RPK variable in input file") - return(new(1,graphic)) - end if - -; Case netcdf from lfi2cdf - if(isfilevar(in_file,"IMAX")) - XHAT=in_file->XHAT - YHAT=in_file->YHAT - IMAX= dimsizes(XHAT)-2 - JMAX= dimsizes(YHAT)-2 - zdx=XHAT(2)-XHAT(1) - zdy=YHAT(2)-YHAT(1) - do ji=0,IMAX-1 - XHAT(ji)=XHAT(ji)+zdx*1.5 - end do - do jj=0,JMAX-1 - YHAT(jj)=YHAT(jj)+zdy*1.5 - end do - else -; Case netcdf from extractdia - XHAT=in_file->W_E_direction - YHAT=in_file->S_N_direction - IMAX= dimsizes(XHAT) - JMAX= dimsizes(YHAT) - end if -; - - lat = new((/JMAX,IMAX/),"double") - lon = new((/JMAX,IMAX/),"double") - - -; Stereographic projection - if(ZRPK .gt. 0) - projection = "Stereographic" - opts@mpCenterLatF = get_res_value_keep(opts, "mpCenterLatF", 90) - opts@mpCenterLonF = get_res_value_keep(opts, "mpCenterLonF",ZLON0) - opts@mpCenterRotF = get_res_value_keep(opts, "mpCenterRotF",ZBETA) - end if - - if(ZRPK .lt. 0) - projection = "Stereographic" - opts@mpCenterLatF = get_res_value_keep(opts, "mpCenterLatF", -90) - opts@mpCenterLonF = get_res_value_keep(opts, "mpCenterLonF",ZLON0) - opts@mpCenterRotF = get_res_value_keep(opts, "mpCenterRotF",ZBETA) - end if - -; Mercator projection - if(ZRPK .eq. 0) - projection = "Mercator" - end if - - opts@mpNestTime = get_res_value_keep(opts, "mpNestTime",0) - - -; LAT and LON are not saved in the file - if (ZRPK.eq.0) then - XBETA=0. - XLAT0=0. ; map reference latitude (degrees) - ZXBM0 = 0. - ZYBM0 = 0. - ZCGAM = cos(-ZRDSDG*XBETA) - ZSGAM = sin(-ZRDSDG*XBETA) - ZRACLAT0 = XRADIUS*cos(ZRDSDG*ZLAT0) - do ji=0,IMAX-1 - jj=0 - ZXMI0 = XHAT(ji)-ZXBM0 - ZYMI0 = YHAT(jj)-ZYBM0 - zlon = (ZXMI0*ZCGAM+ZYMI0*ZSGAM)/(ZRACLAT0*ZRDSDG)+ZLONOR - do jj=0,JMAX-1 - lon(jj,ji)=zlon - end do - end do - do jj=0,JMAX-1 - ji=0 - ZXMI0 = XHAT(ji)-ZXBM0 - ZYMI0 = YHAT(jj)-ZYBM0 - ZT1 = log(tan(XPI/4.+ZLATOR*ZRDSDG/2.)) - ZT2 = (-ZXMI0*ZSGAM+ZYMI0*ZCGAM)/ZRACLAT0 - zlat = (-XPI/2.+2.*atan(exp(ZT1+ZT2)))/ZRDSDG - do ji=0,IMAX-1 - lat(jj,ji)=zlat - end do - end do - else - ZCLAT0 = cos(ZRDSDG*ZLAT0) - ZSLAT0 = sin(ZRDSDG*ZLAT0) - ZCLATOR = cos(ZRDSDG*ZLATOR) - ZSLATOR = sin(ZRDSDG*ZLATOR) - ZRO0 = (XRADIUS/ZRPK)*(abs(ZCLAT0))^(1.-ZRPK) * \ - ((1.+ZSLAT0)*abs(ZCLATOR)/(1.+ZSLATOR))^ZRPK - ZGA0 = (ZRPK*(ZLONOR-ZLON0)-ZBETA)*ZRDSDG - ZXP = ZXBM0-ZRO0*sin(ZGA0) - ZYP = ZYBM0+ZRO0*cos(ZGA0) - do ji=0,IMAX-1 - do jj=0,JMAX-1 - ZATA = atan2( -(ZXP-XHAT(ji)) , (ZYP-YHAT(jj)) )/ZRDSDG - zlon = (ZBETA+ZATA)/ZRPK+ZLON0 - lon(jj,ji)=zlon - ZRO2 = (XHAT(ji)-ZXP)^2+(YHAT(jj)-ZYP)^2 - ZJD1 = XRADIUS*(abs(ZCLAT0))^(1.-ZRPK) - ZT1 = (ZJD1)^(2./ZRPK)* (1+ZSLAT0)^2 - ZJD3 = (ZRPK^2*ZRO2) - ZT2 = ZJD3 - ZT2 = ZT2^(1./ZRPK) - ZJD1 = (ZT1-ZT2)/(ZT1+ZT2) - ZJD1 = acos(ZJD1) - ZJD3 = ZJD1 - zlat = (XPI/2.-ZJD3)/ZRDSDG - lat(jj,ji)=zlat - end do - end do - end if - - dims = dimsizes(lat) - - do ii = 0, dims(0)-1 - do jj = 0, dims(1)-1 - if ( lon(ii,jj) .lt. 0.0) then - lon(ii,jj) = lon(ii,jj) + 360. - end if - end do - end do - - opts@start_lat = lat(0,0) - opts@start_lon = lon(0,0) - opts@end_lat = lat(dims(0)-1,dims(1)-1) - opts@end_lon = lon(dims(0)-1,dims(1)-1) - - -; Set some resources common to all map projections. - opts = set_mp_resources(opts) - - if ( isatt(opts,"ZoomIn") .and. opts@ZoomIn ) then - y1 = 0 - x1 = 0 - y2 = dims(0)-1 - x2 = dims(1)-1 - if ( isatt(opts,"Ystart") ) then - y1 = opts@Ystart - delete(opts@Ystart) - end if - if ( isatt(opts,"Xstart") ) then - x1 = opts@Xstart - delete(opts@Xstart) - end if - if ( isatt(opts,"Yend") ) then - if ( opts@Yend .le. y2 ) then - y2 = opts@Yend - end if - delete(opts@Yend) - end if - if ( isatt(opts,"Xend") ) then - if ( opts@Xend .le. x2 ) then - x2 = opts@Xend - end if - delete(opts@Xend) - end if - - opts@mpLeftCornerLatF = lat(y1,x1) - opts@mpLeftCornerLonF = lon(y1,x1) - opts@mpRightCornerLatF = lat(y2,x2) - opts@mpRightCornerLonF = lon(y2,x2) - - if ( opts@mpRightCornerLonF .lt. 0.0 ) then - opts@mpRightCornerLonF = opts@mpRightCornerLonF + 360.0 - end if - - delete(opts@ZoomIn) - end if - - -; The default is not to draw the plot or advance the frame, and -; to maximize the plot in the frame. - - opts@gsnDraw = get_res_value_keep(opts,"gsnDraw", False) - opts@gsnFrame = get_res_value_keep(opts,"gsnFrame", False) - opts@gsnMaximize = get_res_value_keep(opts,"gsnMaximize", True) - - delete_attrs(opts) ; Clean up. - mp = gsn_map(wks,projection,opts) ; Create map plot. - - return(mp) ; Return. - -end - -;-------------------------------------------------------------------------------- - -undef("mnh_map_overlays") -function mnh_map_overlays(in_file[1]:file, \ - wks:graphic, \ - plots[*]:graphic, \ - opt_arg[1]:logical, \ - opt_mp[1]:logical) - -; Based on wrf_map_overlays -; -; This procedure takes an array of plots and overlays them on a -; base plot - map background. -; -; It will advance the plot and cleanup, unless you set the -; PanelPlot resource to True. -; -; Attributes recognized by this procedure: -; FramePlot -; PanelPlot -; NoTitles (don't do any titles) -; CommonTitle & PlotTile is used to overwrite field titles -; CommonTitle will super-seed NoTitles -; -; If FramePlot False, then Draw the plot but do not Frame. -; In this case a user want to add to the drawing, and will -; have to advance the Frame manually in the script. -; -; If the "NoTitles" attribute exists and is set True, then -; don't create the top-left titles, and leave the main titles alone. -; This resource can be useful if you are planning to panel -; the plots. -; -; If PanelPlot is set to True, then this flags to wrf_map_overlays -; that these plots are going to be eventually paneled (likely -; by gsn_panel), and hence 1) draw and frame should not be called -; (unless gsnDraw and/or gsnFrame are explicitly set to True), -; and 2) the overlays and titles should not be removed with -; NhlRemoveOverlay and NhlRemoveAnnotation. -; -begin - - opts = opt_arg ; Make a copy of the resource lists - opt_mp_2 = opt_mp - - ; Let's make the map first - base = mnh_map(wks,in_file,opt_mp_2) - - no_titles = get_res_value(opts,"NoTitles",False) ; Do we want field titles? - com_title = get_res_value(opts,"CommonTitle",False) ; Do we have a common title? - if ( com_title ) then - plot_title = get_res_value(opts,"PlotTitle"," ") - no_titles = True - end if - - call_draw = True - call_frame = get_res_value(opts,"FramePlot",True) ; Do we want to frame the plot? - panel_plot = get_res_value(opts,"PanelPlot",False) ; Are we paneling? - opts@gsnMaximize = get_res_value_keep(opts,"gsnMaximize", True) - - nplots = dimsizes(plots) -; font_color = "Black" - - do i=0,nplots-1 - if(.not.ismissing(plots(i))) then -; class_name = NhlClassName(plots(i)) -; print(class_name) -; if(class_name.eq."contourPlotClass") then -; getvalues plots(i) -; "cnFillOn" : fill_on -; "cnLineColor" : line_color -; end getvalues -; if (.not.fill_on) then -; font_color = line_color -; end if -; end if - if(.not.no_titles) then - getvalues plots(i) - "tiMainString" : SubTitle - end getvalues - if(i.eq.0) then - SubTitles = SubTitle - else - SubTitles = SubTitles + "~C~" + SubTitle - end if - end if - if(com_title .and. i .eq. nplots-1) then - getvalues plots(i) - "tiMainString" : SubTitle - end getvalues - SubTitles = plot_title - end if - setvalues plots(i) - "tfDoNDCOverlay" : True - "tiMainOn" : False - end setvalues - overlay(base,plots(i)) - else - print("mnh_map_overlays: Warning: overlay plot #" + i + " is not valid.") - end if - end do - - if(.not.no_titles .or. com_title) then - font_height = get_res_value_keep(opts,"FontHeightF",0.01) - txt = create "map_titles" textItemClass wks - "txString" : SubTitles - "txFontHeightF" : font_height - ;"txFontColor" : font_color - end create - anno = NhlAddAnnotation(base,txt) - setvalues anno - "amZone" : 3 - "amJust" : "BottomLeft" - "amSide" : "Top" - "amParallelPosF" : 0.005 - "amOrthogonalPosF" : 0.03 - "amResizeNotify" : False - end setvalues - base@map_titles = anno - end if -; -; gsnDraw and gsnFrame default to False if panel plot. -; - if(panel_plot) then - call_draw = False - call_frame= False - end if - - - opts@gsnDraw = get_res_value_keep(opts,"gsnDraw", call_draw) - opts@gsnFrame = get_res_value_keep(opts,"gsnFrame", call_frame) - - draw_and_frame(wks,base,opts@gsnDraw,opts@gsnFrame,False, \ - opts@gsnMaximize) - - if(.not.panel_plot) then - do i=0,nplots-1 - if(.not.ismissing(plots(i))) then - NhlRemoveOverlay(base,plots(i),False) - else - print("wrf_remove_map_overlays: Warning: overlay plot #" + i + " is not valid.") - print(" Nothing to remove.") - end if - end do - end if - - if(.not.no_titles.and..not.panel_plot) then - if(isatt(base,"map_titles")) then - NhlRemoveAnnotation(base,base@map_titles) - delete(base@map_titles) - end if - end if - -return(base) -end - -;-------------------------------------------------------------------------------- -undef("wrf_user_intrp3d") -function wrf_user_intrp3d( var3d:numeric, z_in:numeric, \ - plot_type:string, \ - loc_param:numeric, angle:numeric, opts:logical ) - -; var3d - 3d field to interpolate (all input fields must be unstaggered) -; z_in - interpolate to this field (either p/z) -; plot_type - interpolate horizontally "h", or vertically "v" -; loc_param - level(s) for horizontal plots (eg. 500hPa ; 3000m - scalar), -; plane for vertical plots (2 values representing an xy point -; on the model domain through which the vertical plane will pass -; OR 4 values specifying start and end values -; angle - 0.0 for horizontal plots, and -; an angle for vertical plots - 90 represent a WE cross section -; opts Used IF opts is TRUE, else use loc_param and angle to determine crosssection - -begin - - - if(plot_type .eq. "h" ) then ; horizontal cross section needed - - dimL = dimsizes(loc_param) - - dims = dimsizes(var3d) - nd = dimsizes(dims) - - dimX = dims(nd-1) - dimY = dims(nd-2) - dimZ = dims(nd-3) - dim4 = 1 - dim5 = 1 - if ( nd .eq. 4 ) then - dim4 = dims(nd-4) - end if - if ( nd .eq. 5 ) then - dim4 = dims(nd-4) - dim5 = dims(nd-5) - end if - - var3 = new ( (/ dim5, dim4, dimZ, dimY, dimX /) , typeof(var3d) ) - z = new ( (/ dim5, dim4, dimZ, dimY, dimX /) , typeof(var3d) ) - var2d = new ( (/ dim5, dim4, dimL, dimY, dimX /) , typeof(var3d) ) - - if ( nd .eq. 5 ) then - var3 = var3d - z = z_in - end if - if ( nd .eq. 4 ) then - var3(0,:,:,:,:) = var3d(:,:,:,:) - z(0,:,:,:,:) = z_in(:,:,:,:) - end if - if ( nd .eq. 3 ) then - var3(0,0,:,:,:) = var3d(:,:,:) - z(0,0,:,:,:) = z_in(:,:,:) - end if - - - if ( z(0,0,0,0,0) .gt. 500.) then - ; We must be interpolating to pressure - ; This routine needs input field and level in hPa - lets make sure of this - if ( z(0,0,0,0,0) .gt. 2000. ) then - ; looks like we have Pa as input - make this hPa - z = z * 0.01 - end if - if ( loc_param(0) .gt. 2000. ) then - ; looks like the input was specified in Pa - change this - loc_param = loc_param * 0.01 - end if - end if - - do il = 0,dimL-1 - var = wrf_interp_3d_z(var3,z,loc_param(il)) - var2d(:,:,il,:,:) = var(:,:,:,:) - end do - - copy_VarAtts(var3d,var3) - if(isatt(var3,"description")) then - delete_VarAtts(var3,(/"description"/)) - end if - if(isatt(var3,"units")) then - delete_VarAtts(var3,(/"units"/)) - end if - if(isatt(var3,"MemoryOrder")) then - delete_VarAtts(var3,(/"MemoryOrder"/)) - end if - if(isatt(var3,"_FillValue")) then - delete_VarAtts(var3,(/"_FillValue"/)) - end if - copy_VarAtts(var3,var2d) - - nn = nd-2 - var2d!nn = "plevs" - - if ( dimL .gt. 1 ) then - if ( nd .eq. 5 ) then - return( var2d ) - end if - if ( nd .eq. 4 ) then - return( var2d(0,:,:,:,:) ) - end if - if ( nd .eq. 3 ) then - return( var2d(0,0,:,:,:) ) - end if - else - if ( z(0,0,0,0,0) .gt. 500.) then - var2d@PlotLevelID = loc_param + " hPa" - else - var2d@PlotLevelID = .001*loc_param + " km" - end if - if ( nd .eq. 5 ) then - return( var2d(:,:,0,:,:) ) - end if - if ( nd .eq. 4 ) then - return( var2d(0,:,0,:,:) ) - end if - if ( nd .eq. 3 ) then - return( var2d(0,0,0,:,:) ) - end if - end if - - - end if - - - - - if(plot_type .eq. "v" ) then ; vertical cross section needed - - dims = dimsizes(var3d) - if ( dimsizes(dims) .eq. 4 ) then - if ( z_in(0,0,0,0) .gt. 500.) then - ; We must be interpolating to pressure - ; This routine needs input field and level in hPa - lets make sure of this - if ( z_in(0,0,0,0) .gt. 2000. ) then - ; looks like we have Pa as input - make this hPa - z_in = z_in * 0.01 - end if - end if - z = z_in(0,:,:,:) - else - if ( z_in(0,0,0) .gt. 500.) then - ; We must be interpolating to pressure - ; This routine needs input field and level in hPa - lets make sure of this - if ( z_in(0,0,0) .gt. 2000. ) then - ; looks like we have Pa as input - make this hPa - z_in = z_in * 0.01 - end if - end if - z = z_in - end if - -; set vertical cross section - if (opts) then - xy = wrf_user_set_xy( z, loc_param(0)-1, loc_param(1)-1, \ ; the -1 is for NCL dimensions - loc_param(2)-1, loc_param(3)-1, \ - angle, opts ) - else - xy = wrf_user_set_xy( z, loc_param(0), loc_param(1), \ - 0.0, 0.0, angle, opts ) - end if - xp = dimsizes(xy) - - -; first we interp z - var2dz = wrf_interp_2d_xy( z, xy) - -; interp to constant z grid - if(var2dz(0,0) .gt. var2dz(1,0) ) then ; monotonically decreasing coordinate - z_max = floor(max(z)/10)*10 ; bottom value - z_min = ceil(min(z)/10)*10 ; top value - dz = 1. - nlevels = tointeger( (z_max-z_min)/dz) - z_var2d = new( (/nlevels/), typeof(z)) - z_var2d(0) = z_max - dz = -dz - else - z_max = max(z) - z_min = 0. -;; MODI SOLINE -; dz = 0.01 * z_max - dz = 0.001 * z_max - nlevels = tointeger( z_max/dz ) - z_var2d = new( (/nlevels/), typeof(z)) - z_var2d(0) = z_min - end if -; print("nlevels="+nlevels) -; print("dz="+dz) - - do i=1, nlevels-1 - z_var2d(i) = z_var2d(0)+i*dz - end do - - -; interp the variable - if ( dimsizes(dims) .eq. 4 ) then - var2d = new( (/dims(0), nlevels, xp(0)/), typeof(var2dz)) - do it = 0,dims(0)-1 - var2dtmp = wrf_interp_2d_xy( var3d(it,:,:,:), xy) - do i=0,xp(0)-1 - var2d(it,:,i) = wrf_interp_1d( var2dtmp(:,i), var2dz(:,i), z_var2d) - end do - end do - var2d!0 = var3d!0 - var2d!1 = "Vertical" - var2d!2 = "Horizontal" - else - var2d = new( (/nlevels, xp(0)/), typeof(var2dz)) - var2dtmp = wrf_interp_2d_xy( var3d, xy) - do i=0,xp(0)-1 - var2d(:,i) = wrf_interp_1d( var2dtmp(:,i), var2dz(:,i), z_var2d) - end do - var2d!0 = "Vertical" - var2d!1 = "Horizontal" - end if - - - st_x = tointeger(xy(0,0)) + 1 - st_y = tointeger(xy(0,1)) + 1 - ed_x = tointeger(xy(xp(0)-1,0)) + 1 - ed_y = tointeger(xy(xp(0)-1,1)) + 1 - if (opts) then - var2d@Orientation = "Cross-Sesion: (" + \ - st_x + "," + st_y + ") to (" + \ - ed_x + "," + ed_y + ")" - else - var2d@Orientation = "Cross-Sesion: (" + \ - st_x + "," + st_y + ") to (" + \ - ed_x + "," + ed_y + ") ; center=(" + \ - loc_param(0) + "," + loc_param(1) + \ - ") ; angle=" + angle - end if - - return(var2d) -end if - - -end - +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/wrf/WRFUserARW.ncl" + +;------------------------------------------------------------- +;contains: +; procedure MESONH_map_c +;function mnh_map(wks[1]:graphic,in_file[1]:file,opt_args[1]:logical) +;function mnh_map_overlays(in_file[1]:file,wks:graphic,plots[*]:graphic, \ +; opt_arg[1]:logical,opt_mp[1]:logical) +;function MESONH_pinter( pfield:numeric, loc_param:numeric, ppabs:numeric ) +;------------------------------------------------------------- + +;============================================================== +; J.-P. CHABOUREAU +; This is a driver that selects the appropriate +; mapping function based upon the file variables RPK, BETA, LATOR, LONOR +; +; +; Sample usage: +; a = addfile("...", r") +; IMAX = a->IMAX +; JMAX = a->JMAX +; lat2d = new((/JMAX,IMAX/),"double") +; lat2d(:,:)=0. +; lon2d = new((/JMAX,IMAX/),"double") +; lon2d(:,:)=0. +; icorners = new((/2,2/),"integer") +; icorners(:,:)=0 +; res = True +; MESONH_map_c (a, res, lat2d, lon2d, icorners) +; +; +undef("MESONH_map_c") +;============================================================== +procedure MESONH_map_c (in_file:file, res:logical, plat, plon, icorner) +;============================================================== +;local rank, dimll, nlat, mlon, lat, lon +local rank, dimll, nlat, mlon +begin + +; Check if the variable RPK is in the file +; ---------------------------------------- +if(isfilevar(in_file,"RPK")) then + +; Read projection parameters +; ------------------------- + ZRPK = in_file->RPK + ZLATOR = in_file->LATOR + ZLONOR = in_file->LONOR + ZBETA = in_file->BETA + ZLAT0 = in_file->LAT0 + ZLON0 = in_file->LON0 + +; Case netcdf from lfi2cdf +; ------------------------- + + if(isfilevar(in_file,"IMAX")) + XHAT=in_file->XHAT + YHAT=in_file->YHAT + IMAX= dimsizes(XHAT)-2 + JMAX= dimsizes(YHAT)-2 + zdx=XHAT(2)-XHAT(1) + zdy=YHAT(2)-YHAT(1) + +; unstagger + do ji=0,IMAX-1 + XHAT(ji)=XHAT(ji)+zdx*1.5 + end do + do jj=0,JMAX-1 + YHAT(jj)=YHAT(jj)+zdy*1.5 + end do + + else + +; Case netcdf from extractdia +; --------------------------- + XHAT=in_file->W_E_direction + YHAT=in_file->S_N_direction + IMAX= dimsizes(XHAT) + JMAX= dimsizes(YHAT) + zdx=XHAT(2)-XHAT(1) + zdy=YHAT(2)-YHAT(1) + + end if + + print ("LATOR="+ZLATOR+" - LONOR="+ZLONOR) + print ("ZLAT0="+ZLAT0+" - ZLON0="+ZLON0) + print ("ZDX="+zdx+" - RPK="+ZRPK+" - BETA="+ZBETA) + print ("IMAX="+IMAX+" - JMAX="+JMAX) + + if (ZRPK.gt.0) + ; Stereographic projection +; --------------------------- + res@mpProjection = "Stereographic" + res@mpCenterLonF = ZLON0 + res@mpCenterRotF = ZBETA + res@mpCenterLatF = 90. + end if + + if (ZRPK.lt.0) + ; Stereographic projection +; --------------------------- + res@mpProjection = "Stereographic" + res@mpCenterLonF = ZLON0 + res@mpCenterRotF = ZBETA + res@mpCenterLatF = -90. + end if + + if (ZRPK.eq.0) then + ; Mercator projection +; --------------------------- + res@mpProjection = "Mercator" + end if + + print("Map projection="+res@mpProjection) + +else + print ("MESONH_map_c: Error no RPK variable in input file") +end if + +;=================================================; +; calculate 2D lat and lon +; based on src/mesonh_MOD/mode_gridproj.f90 +;=================================================; + +; Constants +; ----------- + if(isfilevar(in_file,"IMAX")) + XRADIUS=6371229.0d ; Earth radius (meters) + else + XRADIUS=6371.2290d ; Earth radius (km) + end if + XPI=2.0d*asin(1.) ; Pi + ZRDSDG= XPI/180.0d ; Radian to Degree conversion factor + ZXBM0 = 0.0d + ZYBM0 = 0.0d + +;=================================================; + if (ZRPK.eq.0) then +; MERCATOR +;=================================================; + XBETA=0. + XLAT0=0. ; map reference latitude (degrees) + ZXBM0 = 0. + ZYBM0 = 0. + ZCGAM = cos(-ZRDSDG*XBETA) + ZSGAM = sin(-ZRDSDG*XBETA) + ZRACLAT0 = XRADIUS*cos(ZRDSDG*ZLAT0) + do ji=0,IMAX-1 + jj=0 + ZXMI0 = XHAT(ji)-ZXBM0 + ZYMI0 = YHAT(jj)-ZYBM0 + zlon = (ZXMI0*ZCGAM+ZYMI0*ZSGAM)/(ZRACLAT0*ZRDSDG)+ZLONOR + do jj=0,JMAX-1 + plon(jj,ji)=zlon + end do + end do + do jj=0,JMAX-1 + ji=0 + ZXMI0 = XHAT(ji)-ZXBM0 + ZYMI0 = YHAT(jj)-ZYBM0 + ZT1 = log(tan(XPI/4.+ZLATOR*ZRDSDG/2.)) + ZT2 = (-ZXMI0*ZSGAM+ZYMI0*ZCGAM)/ZRACLAT0 + zlat = (-XPI/2.+2.*atan(exp(ZT1+ZT2)))/ZRDSDG + do ji=0,IMAX-1 + plat(jj,ji)=zlat + end do + end do + +;=================================================; + else +; STEREOGRAPHIC PROJECTION +;=================================================; + ZCLAT0 = cos(ZRDSDG*ZLAT0) + ZSLAT0 = sin(ZRDSDG*ZLAT0) + ZCLATOR = cos(ZRDSDG*ZLATOR) + ZSLATOR = sin(ZRDSDG*ZLATOR) + ZRO0 = (XRADIUS/ZRPK)*(abs(ZCLAT0))^(1.-ZRPK) * \ + ((1.+ZSLAT0)*abs(ZCLATOR)/(1.+ZSLATOR))^ZRPK + ZGA0 = (ZRPK*(ZLONOR-ZLON0)-ZBETA)*ZRDSDG + ZXP = ZXBM0-ZRO0*sin(ZGA0) + ZYP = ZYBM0+ZRO0*cos(ZGA0) + do ji=0,IMAX-1 + do jj=0,JMAX-1 + ZATA = atan2( -(ZXP-XHAT(ji)) , (ZYP-YHAT(jj)) )/ZRDSDG + zlon = (ZBETA+ZATA)/ZRPK+ZLON0 + plon(jj,ji)=zlon + ZRO2 = (XHAT(ji)-ZXP)^2+(YHAT(jj)-ZYP)^2 + ZJD1 = XRADIUS*(abs(ZCLAT0))^(1.-ZRPK) + ZT1 = (ZJD1)^(2./ZRPK)* (1+ZSLAT0)^2 + ZJD3 = (ZRPK^2*ZRO2) + ZT2 = ZJD3 + ZT2 = ZT2^(1./ZRPK) + ZJD1 = (ZT1-ZT2)/(ZT1+ZT2) + ZJD1 = acos(ZJD1) + ZJD3 = ZJD1 + zlat = (XPI/2.-ZJD3)/ZRDSDG + plat(jj,ji)=zlat + end do + end do + + end if + +; Defining the corners of the domain +;==================================== + if (icorner(0,0).eq.icorner(1,1)) then + icorner(0,0)=0 + icorner(1,0)=JMAX-1 + icorner(0,1)=0 + icorner(1,1)=IMAX-1 + end if +; print ("icorner"+icorner) + + res@mpLimitMode = "Corners" + res@mpLeftCornerLatF = plat(icorner(0,0),icorner(0,1)) + res@mpLeftCornerLonF = plon(icorner(0,0),icorner(0,1)) + res@mpRightCornerLatF = plat(icorner(1,0),icorner(1,1)) + res@mpRightCornerLonF = plon(icorner(1,0),icorner(1,1)) + +; print ("Corner (0,0); Lat="+res@mpLeftCornerLatF+ \ +; ", Lon="+res@mpLeftCornerLonF) +; print ("Oppos corner; Lat="+res@mpRightCornerLatF+ \ +; ", Lon= "+res@mpRightCornerLonF) + +;========================================== +; Turn on lat / lon labeling +;========================================== + res@pmTickMarkDisplayMode = "Always" ; turn on tickmarks + res@mpOutlineBoundarySets = "AllBoundaries" ; state boundaries + res@mpPerimDrawOrder = "PostDraw" ; force map perim +;========================================== +; Needed for regional native projection +;========================================== + res@tfDoNDCOverlay = True + res@gsnAddCyclic = False ; regional data + +end + +;=========================================== +;------------------------------------------------------------------------ +undef("MESONH_pinter") +function MESONH_pinter( pfield:numeric, loc_param:numeric, ppabs:numeric ) +;************************************************************************* +; S. BIELLI +; This is a routine that interpolate fields on pressure level for plotting +; based on pinter.f90 +; The field to be interpolated must be given at the mass point (grid 1) +; usage : var_inter=MESONHfunction(var_to_interpol, 850., AbsPressure) +; Abs pressure must be in Pa +; + +begin + + dimL= dimsizes(loc_param) + +; First test for grid = 0 + + dimp=dimsizes(ppabs) + + pout=pfield(0:dimL-1,:,:) + pfield@_FillValue=999 + pout@_FillValue=999 + pout=pout@_FillValue + + do jkp = 0, dimL-1 + zref=log10(loc_param(jkp)*100.) + do jloop = 0, dimp(1)-1 + do iloop = 0, dimp(2)-1 + kloop=0 + flag=True + do while (flag .and. (kloop.lt.(dimp(2)-2))) + if (.not.ismissing(ppabs(kloop,jloop,iloop))) then + zxm=log10(ppabs(kloop,jloop,iloop)) + zxp=log10(ppabs(kloop+1,jloop,iloop)) + if ((zxp-zref)*(zref-zxm) .ge. 0) then + pout(jkp,jloop,iloop)= (pfield(kloop,jloop,iloop)*(zxp-zref)+ \ + pfield(kloop+1,jloop,iloop)*(zref-zxm))/ (zxp-zxm) + flag=False + end if + end if + kloop=kloop+1 + end do + end do + end do + end do + + return(pout) + +end + +;-------------------------------------------------------------------------------- +undef("mnh_map") +function mnh_map(wks[1]:graphic,in_file[1]:file,opt_args[1]:logical) + +begin +; +; This function creates a map plot, and bases the projection on +; the MAP_PROJ attribute in the given file. +; +; 1. Make a copy of the resource list, and set some resources +; common to all map projections. +; +; 2. Determine the projection being used, and set resources based +; on that projection. +; +; 3. Create the map plot, and draw and advance the frame +; (if requested). + + opts = opt_args ; Make a copy of the resource list + opts = True + +; Set some resources depending on what kind of map projection is +; chosen. +; +; ZRPK != 0 : "Stereographic" +; ZRPK = 0 : "Mercator" +;=================================================; +; src/mesonh_MOD/mode_gridproj.f90 +;=================================================; + XRADIUS=6371229.0d ; Earth radius (meters) + XPI=2.0d*asin(1.) ; Pi + ZRDSDG= XPI/180.0d ; Radian to Degree conversion factor + ZXBM0 = 0.0d + ZYBM0 = 0.0d + + if(isfilevar(in_file,"RPK")) + ZRPK=in_file->RPK + ZLON0=in_file->LON0 + ZLAT0=in_file->LAT0 + ZLATOR=in_file->LATOR + ZLONOR=in_file->LONOR + ZBETA=in_file->BETA + else + print ("mnh_map: Error no RPK variable in input file") + return(new(1,graphic)) + end if + +; Case netcdf from lfi2cdf + if(isfilevar(in_file,"IMAX")) + XHAT=in_file->XHAT + YHAT=in_file->YHAT + IMAX= dimsizes(XHAT)-2 + JMAX= dimsizes(YHAT)-2 + zdx=XHAT(2)-XHAT(1) + zdy=YHAT(2)-YHAT(1) + do ji=0,IMAX-1 + XHAT(ji)=XHAT(ji)+zdx*1.5 + end do + do jj=0,JMAX-1 + YHAT(jj)=YHAT(jj)+zdy*1.5 + end do + else +; Case netcdf from extractdia + XHAT=in_file->W_E_direction + YHAT=in_file->S_N_direction + IMAX= dimsizes(XHAT) + JMAX= dimsizes(YHAT) + end if +; + + lat = new((/JMAX,IMAX/),"double") + lon = new((/JMAX,IMAX/),"double") + + +; Stereographic projection + if(ZRPK .gt. 0) + projection = "Stereographic" + opts@mpCenterLatF = get_res_value_keep(opts, "mpCenterLatF", 90) + opts@mpCenterLonF = get_res_value_keep(opts, "mpCenterLonF",ZLON0) + opts@mpCenterRotF = get_res_value_keep(opts, "mpCenterRotF",ZBETA) + end if + + if(ZRPK .lt. 0) + projection = "Stereographic" + opts@mpCenterLatF = get_res_value_keep(opts, "mpCenterLatF", -90) + opts@mpCenterLonF = get_res_value_keep(opts, "mpCenterLonF",ZLON0) + opts@mpCenterRotF = get_res_value_keep(opts, "mpCenterRotF",ZBETA) + end if + +; Mercator projection + if(ZRPK .eq. 0) + projection = "Mercator" + end if + + opts@mpNestTime = get_res_value_keep(opts, "mpNestTime",0) + + +; LAT and LON are not saved in the file + if (ZRPK.eq.0) then + XBETA=0. + XLAT0=0. ; map reference latitude (degrees) + ZXBM0 = 0. + ZYBM0 = 0. + ZCGAM = cos(-ZRDSDG*XBETA) + ZSGAM = sin(-ZRDSDG*XBETA) + ZRACLAT0 = XRADIUS*cos(ZRDSDG*ZLAT0) + do ji=0,IMAX-1 + jj=0 + ZXMI0 = XHAT(ji)-ZXBM0 + ZYMI0 = YHAT(jj)-ZYBM0 + zlon = (ZXMI0*ZCGAM+ZYMI0*ZSGAM)/(ZRACLAT0*ZRDSDG)+ZLONOR + do jj=0,JMAX-1 + lon(jj,ji)=zlon + end do + end do + do jj=0,JMAX-1 + ji=0 + ZXMI0 = XHAT(ji)-ZXBM0 + ZYMI0 = YHAT(jj)-ZYBM0 + ZT1 = log(tan(XPI/4.+ZLATOR*ZRDSDG/2.)) + ZT2 = (-ZXMI0*ZSGAM+ZYMI0*ZCGAM)/ZRACLAT0 + zlat = (-XPI/2.+2.*atan(exp(ZT1+ZT2)))/ZRDSDG + do ji=0,IMAX-1 + lat(jj,ji)=zlat + end do + end do + else + ZCLAT0 = cos(ZRDSDG*ZLAT0) + ZSLAT0 = sin(ZRDSDG*ZLAT0) + ZCLATOR = cos(ZRDSDG*ZLATOR) + ZSLATOR = sin(ZRDSDG*ZLATOR) + ZRO0 = (XRADIUS/ZRPK)*(abs(ZCLAT0))^(1.-ZRPK) * \ + ((1.+ZSLAT0)*abs(ZCLATOR)/(1.+ZSLATOR))^ZRPK + ZGA0 = (ZRPK*(ZLONOR-ZLON0)-ZBETA)*ZRDSDG + ZXP = ZXBM0-ZRO0*sin(ZGA0) + ZYP = ZYBM0+ZRO0*cos(ZGA0) + do ji=0,IMAX-1 + do jj=0,JMAX-1 + ZATA = atan2( -(ZXP-XHAT(ji)) , (ZYP-YHAT(jj)) )/ZRDSDG + zlon = (ZBETA+ZATA)/ZRPK+ZLON0 + lon(jj,ji)=zlon + ZRO2 = (XHAT(ji)-ZXP)^2+(YHAT(jj)-ZYP)^2 + ZJD1 = XRADIUS*(abs(ZCLAT0))^(1.-ZRPK) + ZT1 = (ZJD1)^(2./ZRPK)* (1+ZSLAT0)^2 + ZJD3 = (ZRPK^2*ZRO2) + ZT2 = ZJD3 + ZT2 = ZT2^(1./ZRPK) + ZJD1 = (ZT1-ZT2)/(ZT1+ZT2) + ZJD1 = acos(ZJD1) + ZJD3 = ZJD1 + zlat = (XPI/2.-ZJD3)/ZRDSDG + lat(jj,ji)=zlat + end do + end do + end if + + dims = dimsizes(lat) + + do ii = 0, dims(0)-1 + do jj = 0, dims(1)-1 + if ( lon(ii,jj) .lt. 0.0) then + lon(ii,jj) = lon(ii,jj) + 360. + end if + end do + end do + + opts@start_lat = lat(0,0) + opts@start_lon = lon(0,0) + opts@end_lat = lat(dims(0)-1,dims(1)-1) + opts@end_lon = lon(dims(0)-1,dims(1)-1) + + +; Set some resources common to all map projections. + opts = set_mp_resources(opts) + + if ( isatt(opts,"ZoomIn") .and. opts@ZoomIn ) then + y1 = 0 + x1 = 0 + y2 = dims(0)-1 + x2 = dims(1)-1 + if ( isatt(opts,"Ystart") ) then + y1 = opts@Ystart + delete(opts@Ystart) + end if + if ( isatt(opts,"Xstart") ) then + x1 = opts@Xstart + delete(opts@Xstart) + end if + if ( isatt(opts,"Yend") ) then + if ( opts@Yend .le. y2 ) then + y2 = opts@Yend + end if + delete(opts@Yend) + end if + if ( isatt(opts,"Xend") ) then + if ( opts@Xend .le. x2 ) then + x2 = opts@Xend + end if + delete(opts@Xend) + end if + + opts@mpLeftCornerLatF = lat(y1,x1) + opts@mpLeftCornerLonF = lon(y1,x1) + opts@mpRightCornerLatF = lat(y2,x2) + opts@mpRightCornerLonF = lon(y2,x2) + + if ( opts@mpRightCornerLonF .lt. 0.0 ) then + opts@mpRightCornerLonF = opts@mpRightCornerLonF + 360.0 + end if + + delete(opts@ZoomIn) + end if + + +; The default is not to draw the plot or advance the frame, and +; to maximize the plot in the frame. + + opts@gsnDraw = get_res_value_keep(opts,"gsnDraw", False) + opts@gsnFrame = get_res_value_keep(opts,"gsnFrame", False) + opts@gsnMaximize = get_res_value_keep(opts,"gsnMaximize", True) + + delete_attrs(opts) ; Clean up. + mp = gsn_map(wks,projection,opts) ; Create map plot. + + return(mp) ; Return. + +end + +;-------------------------------------------------------------------------------- + +undef("mnh_map_overlays") +function mnh_map_overlays(in_file[1]:file, \ + wks:graphic, \ + plots[*]:graphic, \ + opt_arg[1]:logical, \ + opt_mp[1]:logical) + +; Based on wrf_map_overlays +; +; This procedure takes an array of plots and overlays them on a +; base plot - map background. +; +; It will advance the plot and cleanup, unless you set the +; PanelPlot resource to True. +; +; Attributes recognized by this procedure: +; FramePlot +; PanelPlot +; NoTitles (don't do any titles) +; CommonTitle & PlotTile is used to overwrite field titles +; CommonTitle will super-seed NoTitles +; +; If FramePlot False, then Draw the plot but do not Frame. +; In this case a user want to add to the drawing, and will +; have to advance the Frame manually in the script. +; +; If the "NoTitles" attribute exists and is set True, then +; don't create the top-left titles, and leave the main titles alone. +; This resource can be useful if you are planning to panel +; the plots. +; +; If PanelPlot is set to True, then this flags to wrf_map_overlays +; that these plots are going to be eventually paneled (likely +; by gsn_panel), and hence 1) draw and frame should not be called +; (unless gsnDraw and/or gsnFrame are explicitly set to True), +; and 2) the overlays and titles should not be removed with +; NhlRemoveOverlay and NhlRemoveAnnotation. +; +begin + + opts = opt_arg ; Make a copy of the resource lists + opt_mp_2 = opt_mp + + ; Let's make the map first + base = mnh_map(wks,in_file,opt_mp_2) + + no_titles = get_res_value(opts,"NoTitles",False) ; Do we want field titles? + com_title = get_res_value(opts,"CommonTitle",False) ; Do we have a common title? + if ( com_title ) then + plot_title = get_res_value(opts,"PlotTitle"," ") + no_titles = True + end if + + call_draw = True + call_frame = get_res_value(opts,"FramePlot",True) ; Do we want to frame the plot? + panel_plot = get_res_value(opts,"PanelPlot",False) ; Are we paneling? + opts@gsnMaximize = get_res_value_keep(opts,"gsnMaximize", True) + + nplots = dimsizes(plots) +; font_color = "Black" + + do i=0,nplots-1 + if(.not.ismissing(plots(i))) then +; class_name = NhlClassName(plots(i)) +; print(class_name) +; if(class_name.eq."contourPlotClass") then +; getvalues plots(i) +; "cnFillOn" : fill_on +; "cnLineColor" : line_color +; end getvalues +; if (.not.fill_on) then +; font_color = line_color +; end if +; end if + if(.not.no_titles) then + getvalues plots(i) + "tiMainString" : SubTitle + end getvalues + if(i.eq.0) then + SubTitles = SubTitle + else + SubTitles = SubTitles + "~C~" + SubTitle + end if + end if + if(com_title .and. i .eq. nplots-1) then + getvalues plots(i) + "tiMainString" : SubTitle + end getvalues + SubTitles = plot_title + end if + setvalues plots(i) + "tfDoNDCOverlay" : True + "tiMainOn" : False + end setvalues + overlay(base,plots(i)) + else + print("mnh_map_overlays: Warning: overlay plot #" + i + " is not valid.") + end if + end do + + if(.not.no_titles .or. com_title) then + font_height = get_res_value_keep(opts,"FontHeightF",0.01) + txt = create "map_titles" textItemClass wks + "txString" : SubTitles + "txFontHeightF" : font_height + ;"txFontColor" : font_color + end create + anno = NhlAddAnnotation(base,txt) + setvalues anno + "amZone" : 3 + "amJust" : "BottomLeft" + "amSide" : "Top" + "amParallelPosF" : 0.005 + "amOrthogonalPosF" : 0.03 + "amResizeNotify" : False + end setvalues + base@map_titles = anno + end if +; +; gsnDraw and gsnFrame default to False if panel plot. +; + if(panel_plot) then + call_draw = False + call_frame= False + end if + + + opts@gsnDraw = get_res_value_keep(opts,"gsnDraw", call_draw) + opts@gsnFrame = get_res_value_keep(opts,"gsnFrame", call_frame) + + draw_and_frame(wks,base,opts@gsnDraw,opts@gsnFrame,False, \ + opts@gsnMaximize) + + if(.not.panel_plot) then + do i=0,nplots-1 + if(.not.ismissing(plots(i))) then + NhlRemoveOverlay(base,plots(i),False) + else + print("wrf_remove_map_overlays: Warning: overlay plot #" + i + " is not valid.") + print(" Nothing to remove.") + end if + end do + end if + + if(.not.no_titles.and..not.panel_plot) then + if(isatt(base,"map_titles")) then + NhlRemoveAnnotation(base,base@map_titles) + delete(base@map_titles) + end if + end if + +return(base) +end + +;-------------------------------------------------------------------------------- +undef("wrf_user_intrp3d") +function wrf_user_intrp3d( var3d:numeric, z_in:numeric, \ + plot_type:string, \ + loc_param:numeric, angle:numeric, opts:logical ) + +; var3d - 3d field to interpolate (all input fields must be unstaggered) +; z_in - interpolate to this field (either p/z) +; plot_type - interpolate horizontally "h", or vertically "v" +; loc_param - level(s) for horizontal plots (eg. 500hPa ; 3000m - scalar), +; plane for vertical plots (2 values representing an xy point +; on the model domain through which the vertical plane will pass +; OR 4 values specifying start and end values +; angle - 0.0 for horizontal plots, and +; an angle for vertical plots - 90 represent a WE cross section +; opts Used IF opts is TRUE, else use loc_param and angle to determine crosssection + +begin + + + if(plot_type .eq. "h" ) then ; horizontal cross section needed + + dimL = dimsizes(loc_param) + + dims = dimsizes(var3d) + nd = dimsizes(dims) + + dimX = dims(nd-1) + dimY = dims(nd-2) + dimZ = dims(nd-3) + dim4 = 1 + dim5 = 1 + if ( nd .eq. 4 ) then + dim4 = dims(nd-4) + end if + if ( nd .eq. 5 ) then + dim4 = dims(nd-4) + dim5 = dims(nd-5) + end if + + var3 = new ( (/ dim5, dim4, dimZ, dimY, dimX /) , typeof(var3d) ) + z = new ( (/ dim5, dim4, dimZ, dimY, dimX /) , typeof(var3d) ) + var2d = new ( (/ dim5, dim4, dimL, dimY, dimX /) , typeof(var3d) ) + + if ( nd .eq. 5 ) then + var3 = var3d + z = z_in + end if + if ( nd .eq. 4 ) then + var3(0,:,:,:,:) = var3d(:,:,:,:) + z(0,:,:,:,:) = z_in(:,:,:,:) + end if + if ( nd .eq. 3 ) then + var3(0,0,:,:,:) = var3d(:,:,:) + z(0,0,:,:,:) = z_in(:,:,:) + end if + + + if ( z(0,0,0,0,0) .gt. 500.) then + ; We must be interpolating to pressure + ; This routine needs input field and level in hPa - lets make sure of this + if ( z(0,0,0,0,0) .gt. 2000. ) then + ; looks like we have Pa as input - make this hPa + z = z * 0.01 + end if + if ( loc_param(0) .gt. 2000. ) then + ; looks like the input was specified in Pa - change this + loc_param = loc_param * 0.01 + end if + end if + + do il = 0,dimL-1 + var = wrf_interp_3d_z(var3,z,loc_param(il)) + var2d(:,:,il,:,:) = var(:,:,:,:) + end do + + copy_VarAtts(var3d,var3) + if(isatt(var3,"description")) then + delete_VarAtts(var3,(/"description"/)) + end if + if(isatt(var3,"units")) then + delete_VarAtts(var3,(/"units"/)) + end if + if(isatt(var3,"MemoryOrder")) then + delete_VarAtts(var3,(/"MemoryOrder"/)) + end if + if(isatt(var3,"_FillValue")) then + delete_VarAtts(var3,(/"_FillValue"/)) + end if + copy_VarAtts(var3,var2d) + + nn = nd-2 + var2d!nn = "plevs" + + if ( dimL .gt. 1 ) then + if ( nd .eq. 5 ) then + return( var2d ) + end if + if ( nd .eq. 4 ) then + return( var2d(0,:,:,:,:) ) + end if + if ( nd .eq. 3 ) then + return( var2d(0,0,:,:,:) ) + end if + else + if ( z(0,0,0,0,0) .gt. 500.) then + var2d@PlotLevelID = loc_param + " hPa" + else + var2d@PlotLevelID = .001*loc_param + " km" + end if + if ( nd .eq. 5 ) then + return( var2d(:,:,0,:,:) ) + end if + if ( nd .eq. 4 ) then + return( var2d(0,:,0,:,:) ) + end if + if ( nd .eq. 3 ) then + return( var2d(0,0,0,:,:) ) + end if + end if + + + end if + + + + + if(plot_type .eq. "v" ) then ; vertical cross section needed + + dims = dimsizes(var3d) + if ( dimsizes(dims) .eq. 4 ) then + if ( z_in(0,0,0,0) .gt. 500.) then + ; We must be interpolating to pressure + ; This routine needs input field and level in hPa - lets make sure of this + if ( z_in(0,0,0,0) .gt. 2000. ) then + ; looks like we have Pa as input - make this hPa + z_in = z_in * 0.01 + end if + end if + z = z_in(0,:,:,:) + else + if ( z_in(0,0,0) .gt. 500.) then + ; We must be interpolating to pressure + ; This routine needs input field and level in hPa - lets make sure of this + if ( z_in(0,0,0) .gt. 2000. ) then + ; looks like we have Pa as input - make this hPa + z_in = z_in * 0.01 + end if + end if + z = z_in + end if + +; set vertical cross section + if (opts) then + xy = wrf_user_set_xy( z, loc_param(0)-1, loc_param(1)-1, \ ; the -1 is for NCL dimensions + loc_param(2)-1, loc_param(3)-1, \ + angle, opts ) + else + xy = wrf_user_set_xy( z, loc_param(0), loc_param(1), \ + 0.0, 0.0, angle, opts ) + end if + xp = dimsizes(xy) + + +; first we interp z + var2dz = wrf_interp_2d_xy( z, xy) + +; interp to constant z grid + if(var2dz(0,0) .gt. var2dz(1,0) ) then ; monotonically decreasing coordinate + z_max = floor(max(z)/10)*10 ; bottom value + z_min = ceil(min(z)/10)*10 ; top value + dz = 1. + nlevels = tointeger( (z_max-z_min)/dz) + z_var2d = new( (/nlevels/), typeof(z)) + z_var2d(0) = z_max + dz = -dz + else + z_max = max(z) + z_min = 0. +;; MODI SOLINE +; dz = 0.01 * z_max + dz = 0.001 * z_max + nlevels = tointeger( z_max/dz ) + z_var2d = new( (/nlevels/), typeof(z)) + z_var2d(0) = z_min + end if +; print("nlevels="+nlevels) +; print("dz="+dz) + + do i=1, nlevels-1 + z_var2d(i) = z_var2d(0)+i*dz + end do + + +; interp the variable + if ( dimsizes(dims) .eq. 4 ) then + var2d = new( (/dims(0), nlevels, xp(0)/), typeof(var2dz)) + do it = 0,dims(0)-1 + var2dtmp = wrf_interp_2d_xy( var3d(it,:,:,:), xy) + do i=0,xp(0)-1 + var2d(it,:,i) = wrf_interp_1d( var2dtmp(:,i), var2dz(:,i), z_var2d) + end do + end do + var2d!0 = var3d!0 + var2d!1 = "Vertical" + var2d!2 = "Horizontal" + else + var2d = new( (/nlevels, xp(0)/), typeof(var2dz)) + var2dtmp = wrf_interp_2d_xy( var3d, xy) + do i=0,xp(0)-1 + var2d(:,i) = wrf_interp_1d( var2dtmp(:,i), var2dz(:,i), z_var2d) + end do + var2d!0 = "Vertical" + var2d!1 = "Horizontal" + end if + + + st_x = tointeger(xy(0,0)) + 1 + st_y = tointeger(xy(0,1)) + 1 + ed_x = tointeger(xy(xp(0)-1,0)) + 1 + ed_y = tointeger(xy(xp(0)-1,1)) + 1 + if (opts) then + var2d@Orientation = "Cross-Sesion: (" + \ + st_x + "," + st_y + ") to (" + \ + ed_x + "," + ed_y + ")" + else + var2d@Orientation = "Cross-Sesion: (" + \ + st_x + "," + st_y + ") to (" + \ + ed_x + "," + ed_y + ") ; center=(" + \ + loc_param(0) + "," + loc_param(1) + \ + ") ; angle=" + angle + end if + + return(var2d) +end if + + +end + diff --git a/MY_RUN/KTEST/004_Reunion/005_ncl_lfi2cdf/MESONHtools.ncl b/MY_RUN/KTEST/004_Reunion/005_ncl_lfi2cdf/MESONHtools.ncl index 6f810bbfdb30b4e658f289d87d1680a80b5b66fe..9cae6400a0dade82e20ba68463722fbb13d4c81d 100644 --- a/MY_RUN/KTEST/004_Reunion/005_ncl_lfi2cdf/MESONHtools.ncl +++ b/MY_RUN/KTEST/004_Reunion/005_ncl_lfi2cdf/MESONHtools.ncl @@ -1,915 +1,915 @@ -load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" -load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" -load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" -load "$NCARG_ROOT/lib/ncarg/nclscripts/wrf/WRFUserARW.ncl" - -;------------------------------------------------------------- -;contains: -; procedure MESONH_map_c -;function mnh_map(wks[1]:graphic,in_file[1]:file,opt_args[1]:logical) -;function mnh_map_overlays(in_file[1]:file,wks:graphic,plots[*]:graphic, \ -; opt_arg[1]:logical,opt_mp[1]:logical) -;function MESONH_pinter( pfield:numeric, loc_param:numeric, ppabs:numeric ) -;------------------------------------------------------------- - -;============================================================== -; J.-P. CHABOUREAU -; This is a driver that selects the appropriate -; mapping function based upon the file variables RPK, BETA, LATOR, LONOR -; -; -; Sample usage: -; a = addfile("...", r") -; IMAX = a->IMAX -; JMAX = a->JMAX -; lat2d = new((/JMAX,IMAX/),"double") -; lat2d(:,:)=0. -; lon2d = new((/JMAX,IMAX/),"double") -; lon2d(:,:)=0. -; icorners = new((/2,2/),"integer") -; icorners(:,:)=0 -; res = True -; MESONH_map_c (a, res, lat2d, lon2d, icorners) -; -; -undef("MESONH_map_c") -;============================================================== -procedure MESONH_map_c (in_file:file, res:logical, plat, plon, icorner) -;============================================================== -;local rank, dimll, nlat, mlon, lat, lon -local rank, dimll, nlat, mlon -begin - -; Check if the variable RPK is in the file -; ---------------------------------------- -if(isfilevar(in_file,"RPK")) then - -; Read projection parameters -; ------------------------- - ZRPK = in_file->RPK - ZLATOR = in_file->LATOR - ZLONOR = in_file->LONOR - ZBETA = in_file->BETA - ZLAT0 = in_file->LAT0 - ZLON0 = in_file->LON0 - -; Case netcdf from lfi2cdf -; ------------------------- - - if(isfilevar(in_file,"IMAX")) - XHAT=in_file->XHAT - YHAT=in_file->YHAT - IMAX= dimsizes(XHAT)-2 - JMAX= dimsizes(YHAT)-2 - zdx=XHAT(2)-XHAT(1) - zdy=YHAT(2)-YHAT(1) - -; unstagger - do ji=0,IMAX-1 - XHAT(ji)=XHAT(ji)+zdx*1.5 - end do - do jj=0,JMAX-1 - YHAT(jj)=YHAT(jj)+zdy*1.5 - end do - - else - -; Case netcdf from extractdia -; --------------------------- - XHAT=in_file->W_E_direction - YHAT=in_file->S_N_direction - IMAX= dimsizes(XHAT) - JMAX= dimsizes(YHAT) - zdx=XHAT(2)-XHAT(1) - zdy=YHAT(2)-YHAT(1) - - end if - - print ("LATOR="+ZLATOR+" - LONOR="+ZLONOR) - print ("ZLAT0="+ZLAT0+" - ZLON0="+ZLON0) - print ("ZDX="+zdx+" - RPK="+ZRPK+" - BETA="+ZBETA) - print ("IMAX="+IMAX+" - JMAX="+JMAX) - - if (ZRPK.gt.0) - ; Stereographic projection -; --------------------------- - res@mpProjection = "Stereographic" - res@mpCenterLonF = ZLON0 - res@mpCenterRotF = ZBETA - res@mpCenterLatF = 90. - end if - - if (ZRPK.lt.0) - ; Stereographic projection -; --------------------------- - res@mpProjection = "Stereographic" - res@mpCenterLonF = ZLON0 - res@mpCenterRotF = ZBETA - res@mpCenterLatF = -90. - end if - - if (ZRPK.eq.0) then - ; Mercator projection -; --------------------------- - res@mpProjection = "Mercator" - end if - - print("Map projection="+res@mpProjection) - -else - print ("MESONH_map_c: Error no RPK variable in input file") -end if - -;=================================================; -; calculate 2D lat and lon -; based on src/mesonh_MOD/mode_gridproj.f90 -;=================================================; - -; Constants -; ----------- - if(isfilevar(in_file,"IMAX")) - XRADIUS=6371229.0d ; Earth radius (meters) - else - XRADIUS=6371.2290d ; Earth radius (km) - end if - XPI=2.0d*asin(1.) ; Pi - ZRDSDG= XPI/180.0d ; Radian to Degree conversion factor - ZXBM0 = 0.0d - ZYBM0 = 0.0d - -;=================================================; - if (ZRPK.eq.0) then -; MERCATOR -;=================================================; - XBETA=0. - XLAT0=0. ; map reference latitude (degrees) - ZXBM0 = 0. - ZYBM0 = 0. - ZCGAM = cos(-ZRDSDG*XBETA) - ZSGAM = sin(-ZRDSDG*XBETA) - ZRACLAT0 = XRADIUS*cos(ZRDSDG*ZLAT0) - do ji=0,IMAX-1 - jj=0 - ZXMI0 = XHAT(ji)-ZXBM0 - ZYMI0 = YHAT(jj)-ZYBM0 - zlon = (ZXMI0*ZCGAM+ZYMI0*ZSGAM)/(ZRACLAT0*ZRDSDG)+ZLONOR - do jj=0,JMAX-1 - plon(jj,ji)=zlon - end do - end do - do jj=0,JMAX-1 - ji=0 - ZXMI0 = XHAT(ji)-ZXBM0 - ZYMI0 = YHAT(jj)-ZYBM0 - ZT1 = log(tan(XPI/4.+ZLATOR*ZRDSDG/2.)) - ZT2 = (-ZXMI0*ZSGAM+ZYMI0*ZCGAM)/ZRACLAT0 - zlat = (-XPI/2.+2.*atan(exp(ZT1+ZT2)))/ZRDSDG - do ji=0,IMAX-1 - plat(jj,ji)=zlat - end do - end do - -;=================================================; - else -; STEREOGRAPHIC PROJECTION -;=================================================; - ZCLAT0 = cos(ZRDSDG*ZLAT0) - ZSLAT0 = sin(ZRDSDG*ZLAT0) - ZCLATOR = cos(ZRDSDG*ZLATOR) - ZSLATOR = sin(ZRDSDG*ZLATOR) - ZRO0 = (XRADIUS/ZRPK)*(abs(ZCLAT0))^(1.-ZRPK) * \ - ((1.+ZSLAT0)*abs(ZCLATOR)/(1.+ZSLATOR))^ZRPK - ZGA0 = (ZRPK*(ZLONOR-ZLON0)-ZBETA)*ZRDSDG - ZXP = ZXBM0-ZRO0*sin(ZGA0) - ZYP = ZYBM0+ZRO0*cos(ZGA0) - do ji=0,IMAX-1 - do jj=0,JMAX-1 - ZATA = atan2( -(ZXP-XHAT(ji)) , (ZYP-YHAT(jj)) )/ZRDSDG - zlon = (ZBETA+ZATA)/ZRPK+ZLON0 - plon(jj,ji)=zlon - ZRO2 = (XHAT(ji)-ZXP)^2+(YHAT(jj)-ZYP)^2 - ZJD1 = XRADIUS*(abs(ZCLAT0))^(1.-ZRPK) - ZT1 = (ZJD1)^(2./ZRPK)* (1+ZSLAT0)^2 - ZJD3 = (ZRPK^2*ZRO2) - ZT2 = ZJD3 - ZT2 = ZT2^(1./ZRPK) - ZJD1 = (ZT1-ZT2)/(ZT1+ZT2) - ZJD1 = acos(ZJD1) - ZJD3 = ZJD1 - zlat = (XPI/2.-ZJD3)/ZRDSDG - plat(jj,ji)=zlat - end do - end do - - end if - -; Defining the corners of the domain -;==================================== - if (icorner(0,0).eq.icorner(1,1)) then - icorner(0,0)=0 - icorner(1,0)=JMAX-1 - icorner(0,1)=0 - icorner(1,1)=IMAX-1 - end if -; print ("icorner"+icorner) - - res@mpLimitMode = "Corners" - res@mpLeftCornerLatF = plat(icorner(0,0),icorner(0,1)) - res@mpLeftCornerLonF = plon(icorner(0,0),icorner(0,1)) - res@mpRightCornerLatF = plat(icorner(1,0),icorner(1,1)) - res@mpRightCornerLonF = plon(icorner(1,0),icorner(1,1)) - -; print ("Corner (0,0); Lat="+res@mpLeftCornerLatF+ \ -; ", Lon="+res@mpLeftCornerLonF) -; print ("Oppos corner; Lat="+res@mpRightCornerLatF+ \ -; ", Lon= "+res@mpRightCornerLonF) - -;========================================== -; Turn on lat / lon labeling -;========================================== - res@pmTickMarkDisplayMode = "Always" ; turn on tickmarks - res@mpOutlineBoundarySets = "AllBoundaries" ; state boundaries - res@mpPerimDrawOrder = "PostDraw" ; force map perim -;========================================== -; Needed for regional native projection -;========================================== - res@tfDoNDCOverlay = True - res@gsnAddCyclic = False ; regional data - -end - -;=========================================== -;------------------------------------------------------------------------ -undef("MESONH_pinter") -function MESONH_pinter( pfield:numeric, loc_param:numeric, ppabs:numeric ) -;************************************************************************* -; S. BIELLI -; This is a routine that interpolate fields on pressure level for plotting -; based on pinter.f90 -; The field to be interpolated must be given at the mass point (grid 1) -; usage : var_inter=MESONHfunction(var_to_interpol, 850., AbsPressure) -; Abs pressure must be in Pa -; - -begin - - dimL= dimsizes(loc_param) - -; First test for grid = 0 - - dimp=dimsizes(ppabs) - - pout=pfield(0:dimL-1,:,:) - pfield@_FillValue=999 - pout@_FillValue=999 - pout=pout@_FillValue - - do jkp = 0, dimL-1 - zref=log10(loc_param(jkp)*100.) - do jloop = 0, dimp(1)-1 - do iloop = 0, dimp(2)-1 - kloop=0 - flag=True - do while (flag .and. (kloop.lt.(dimp(2)-2))) - if (.not.ismissing(ppabs(kloop,jloop,iloop))) then - zxm=log10(ppabs(kloop,jloop,iloop)) - zxp=log10(ppabs(kloop+1,jloop,iloop)) - if ((zxp-zref)*(zref-zxm) .ge. 0) then - pout(jkp,jloop,iloop)= (pfield(kloop,jloop,iloop)*(zxp-zref)+ \ - pfield(kloop+1,jloop,iloop)*(zref-zxm))/ (zxp-zxm) - flag=False - end if - end if - kloop=kloop+1 - end do - end do - end do - end do - - return(pout) - -end - -;-------------------------------------------------------------------------------- -undef("mnh_map") -function mnh_map(wks[1]:graphic,in_file[1]:file,opt_args[1]:logical) - -begin -; -; This function creates a map plot, and bases the projection on -; the MAP_PROJ attribute in the given file. -; -; 1. Make a copy of the resource list, and set some resources -; common to all map projections. -; -; 2. Determine the projection being used, and set resources based -; on that projection. -; -; 3. Create the map plot, and draw and advance the frame -; (if requested). - - opts = opt_args ; Make a copy of the resource list - opts = True - -; Set some resources depending on what kind of map projection is -; chosen. -; -; ZRPK != 0 : "Stereographic" -; ZRPK = 0 : "Mercator" -;=================================================; -; src/mesonh_MOD/mode_gridproj.f90 -;=================================================; - XRADIUS=6371229.0d ; Earth radius (meters) - XPI=2.0d*asin(1.) ; Pi - ZRDSDG= XPI/180.0d ; Radian to Degree conversion factor - ZXBM0 = 0.0d - ZYBM0 = 0.0d - - if(isfilevar(in_file,"RPK")) - ZRPK=in_file->RPK - ZLON0=in_file->LON0 - ZLAT0=in_file->LAT0 - ZLATOR=in_file->LATOR - ZLONOR=in_file->LONOR - ZBETA=in_file->BETA - else - print ("mnh_map: Error no RPK variable in input file") - return(new(1,graphic)) - end if - -; Case netcdf from lfi2cdf - if(isfilevar(in_file,"IMAX")) - XHAT=in_file->XHAT - YHAT=in_file->YHAT - IMAX= dimsizes(XHAT)-2 - JMAX= dimsizes(YHAT)-2 - zdx=XHAT(2)-XHAT(1) - zdy=YHAT(2)-YHAT(1) - do ji=0,IMAX-1 - XHAT(ji)=XHAT(ji)+zdx*1.5 - end do - do jj=0,JMAX-1 - YHAT(jj)=YHAT(jj)+zdy*1.5 - end do - else -; Case netcdf from extractdia - XHAT=in_file->W_E_direction - YHAT=in_file->S_N_direction - IMAX= dimsizes(XHAT) - JMAX= dimsizes(YHAT) - end if -; - - lat = new((/JMAX,IMAX/),"double") - lon = new((/JMAX,IMAX/),"double") - - -; Stereographic projection - if(ZRPK .gt. 0) - projection = "Stereographic" - opts@mpCenterLatF = get_res_value_keep(opts, "mpCenterLatF", 90) - opts@mpCenterLonF = get_res_value_keep(opts, "mpCenterLonF",ZLON0) - opts@mpCenterRotF = get_res_value_keep(opts, "mpCenterRotF",ZBETA) - end if - - if(ZRPK .lt. 0) - projection = "Stereographic" - opts@mpCenterLatF = get_res_value_keep(opts, "mpCenterLatF", -90) - opts@mpCenterLonF = get_res_value_keep(opts, "mpCenterLonF",ZLON0) - opts@mpCenterRotF = get_res_value_keep(opts, "mpCenterRotF",ZBETA) - end if - -; Mercator projection - if(ZRPK .eq. 0) - projection = "Mercator" - end if - - opts@mpNestTime = get_res_value_keep(opts, "mpNestTime",0) - - -; LAT and LON are not saved in the file - if (ZRPK.eq.0) then - XBETA=0. - XLAT0=0. ; map reference latitude (degrees) - ZXBM0 = 0. - ZYBM0 = 0. - ZCGAM = cos(-ZRDSDG*XBETA) - ZSGAM = sin(-ZRDSDG*XBETA) - ZRACLAT0 = XRADIUS*cos(ZRDSDG*ZLAT0) - do ji=0,IMAX-1 - jj=0 - ZXMI0 = XHAT(ji)-ZXBM0 - ZYMI0 = YHAT(jj)-ZYBM0 - zlon = (ZXMI0*ZCGAM+ZYMI0*ZSGAM)/(ZRACLAT0*ZRDSDG)+ZLONOR - do jj=0,JMAX-1 - lon(jj,ji)=zlon - end do - end do - do jj=0,JMAX-1 - ji=0 - ZXMI0 = XHAT(ji)-ZXBM0 - ZYMI0 = YHAT(jj)-ZYBM0 - ZT1 = log(tan(XPI/4.+ZLATOR*ZRDSDG/2.)) - ZT2 = (-ZXMI0*ZSGAM+ZYMI0*ZCGAM)/ZRACLAT0 - zlat = (-XPI/2.+2.*atan(exp(ZT1+ZT2)))/ZRDSDG - do ji=0,IMAX-1 - lat(jj,ji)=zlat - end do - end do - else - ZCLAT0 = cos(ZRDSDG*ZLAT0) - ZSLAT0 = sin(ZRDSDG*ZLAT0) - ZCLATOR = cos(ZRDSDG*ZLATOR) - ZSLATOR = sin(ZRDSDG*ZLATOR) - ZRO0 = (XRADIUS/ZRPK)*(abs(ZCLAT0))^(1.-ZRPK) * \ - ((1.+ZSLAT0)*abs(ZCLATOR)/(1.+ZSLATOR))^ZRPK - ZGA0 = (ZRPK*(ZLONOR-ZLON0)-ZBETA)*ZRDSDG - ZXP = ZXBM0-ZRO0*sin(ZGA0) - ZYP = ZYBM0+ZRO0*cos(ZGA0) - do ji=0,IMAX-1 - do jj=0,JMAX-1 - ZATA = atan2( -(ZXP-XHAT(ji)) , (ZYP-YHAT(jj)) )/ZRDSDG - zlon = (ZBETA+ZATA)/ZRPK+ZLON0 - lon(jj,ji)=zlon - ZRO2 = (XHAT(ji)-ZXP)^2+(YHAT(jj)-ZYP)^2 - ZJD1 = XRADIUS*(abs(ZCLAT0))^(1.-ZRPK) - ZT1 = (ZJD1)^(2./ZRPK)* (1+ZSLAT0)^2 - ZJD3 = (ZRPK^2*ZRO2) - ZT2 = ZJD3 - ZT2 = ZT2^(1./ZRPK) - ZJD1 = (ZT1-ZT2)/(ZT1+ZT2) - ZJD1 = acos(ZJD1) - ZJD3 = ZJD1 - zlat = (XPI/2.-ZJD3)/ZRDSDG - lat(jj,ji)=zlat - end do - end do - end if - - dims = dimsizes(lat) - - do ii = 0, dims(0)-1 - do jj = 0, dims(1)-1 - if ( lon(ii,jj) .lt. 0.0) then - lon(ii,jj) = lon(ii,jj) + 360. - end if - end do - end do - - opts@start_lat = lat(0,0) - opts@start_lon = lon(0,0) - opts@end_lat = lat(dims(0)-1,dims(1)-1) - opts@end_lon = lon(dims(0)-1,dims(1)-1) - - -; Set some resources common to all map projections. - opts = set_mp_resources(opts) - - if ( isatt(opts,"ZoomIn") .and. opts@ZoomIn ) then - y1 = 0 - x1 = 0 - y2 = dims(0)-1 - x2 = dims(1)-1 - if ( isatt(opts,"Ystart") ) then - y1 = opts@Ystart - delete(opts@Ystart) - end if - if ( isatt(opts,"Xstart") ) then - x1 = opts@Xstart - delete(opts@Xstart) - end if - if ( isatt(opts,"Yend") ) then - if ( opts@Yend .le. y2 ) then - y2 = opts@Yend - end if - delete(opts@Yend) - end if - if ( isatt(opts,"Xend") ) then - if ( opts@Xend .le. x2 ) then - x2 = opts@Xend - end if - delete(opts@Xend) - end if - - opts@mpLeftCornerLatF = lat(y1,x1) - opts@mpLeftCornerLonF = lon(y1,x1) - opts@mpRightCornerLatF = lat(y2,x2) - opts@mpRightCornerLonF = lon(y2,x2) - - if ( opts@mpRightCornerLonF .lt. 0.0 ) then - opts@mpRightCornerLonF = opts@mpRightCornerLonF + 360.0 - end if - - delete(opts@ZoomIn) - end if - - -; The default is not to draw the plot or advance the frame, and -; to maximize the plot in the frame. - - opts@gsnDraw = get_res_value_keep(opts,"gsnDraw", False) - opts@gsnFrame = get_res_value_keep(opts,"gsnFrame", False) - opts@gsnMaximize = get_res_value_keep(opts,"gsnMaximize", True) - - delete_attrs(opts) ; Clean up. - mp = gsn_map(wks,projection,opts) ; Create map plot. - - return(mp) ; Return. - -end - -;-------------------------------------------------------------------------------- - -undef("mnh_map_overlays") -function mnh_map_overlays(in_file[1]:file, \ - wks:graphic, \ - plots[*]:graphic, \ - opt_arg[1]:logical, \ - opt_mp[1]:logical) - -; Based on wrf_map_overlays -; -; This procedure takes an array of plots and overlays them on a -; base plot - map background. -; -; It will advance the plot and cleanup, unless you set the -; PanelPlot resource to True. -; -; Attributes recognized by this procedure: -; FramePlot -; PanelPlot -; NoTitles (don't do any titles) -; CommonTitle & PlotTile is used to overwrite field titles -; CommonTitle will super-seed NoTitles -; -; If FramePlot False, then Draw the plot but do not Frame. -; In this case a user want to add to the drawing, and will -; have to advance the Frame manually in the script. -; -; If the "NoTitles" attribute exists and is set True, then -; don't create the top-left titles, and leave the main titles alone. -; This resource can be useful if you are planning to panel -; the plots. -; -; If PanelPlot is set to True, then this flags to wrf_map_overlays -; that these plots are going to be eventually paneled (likely -; by gsn_panel), and hence 1) draw and frame should not be called -; (unless gsnDraw and/or gsnFrame are explicitly set to True), -; and 2) the overlays and titles should not be removed with -; NhlRemoveOverlay and NhlRemoveAnnotation. -; -begin - - opts = opt_arg ; Make a copy of the resource lists - opt_mp_2 = opt_mp - - ; Let's make the map first - base = mnh_map(wks,in_file,opt_mp_2) - - no_titles = get_res_value(opts,"NoTitles",False) ; Do we want field titles? - com_title = get_res_value(opts,"CommonTitle",False) ; Do we have a common title? - if ( com_title ) then - plot_title = get_res_value(opts,"PlotTitle"," ") - no_titles = True - end if - - call_draw = True - call_frame = get_res_value(opts,"FramePlot",True) ; Do we want to frame the plot? - panel_plot = get_res_value(opts,"PanelPlot",False) ; Are we paneling? - opts@gsnMaximize = get_res_value_keep(opts,"gsnMaximize", True) - - nplots = dimsizes(plots) -; font_color = "Black" - - do i=0,nplots-1 - if(.not.ismissing(plots(i))) then -; class_name = NhlClassName(plots(i)) -; print(class_name) -; if(class_name.eq."contourPlotClass") then -; getvalues plots(i) -; "cnFillOn" : fill_on -; "cnLineColor" : line_color -; end getvalues -; if (.not.fill_on) then -; font_color = line_color -; end if -; end if - if(.not.no_titles) then - getvalues plots(i) - "tiMainString" : SubTitle - end getvalues - if(i.eq.0) then - SubTitles = SubTitle - else - SubTitles = SubTitles + "~C~" + SubTitle - end if - end if - if(com_title .and. i .eq. nplots-1) then - getvalues plots(i) - "tiMainString" : SubTitle - end getvalues - SubTitles = plot_title - end if - setvalues plots(i) - "tfDoNDCOverlay" : True - "tiMainOn" : False - end setvalues - overlay(base,plots(i)) - else - print("mnh_map_overlays: Warning: overlay plot #" + i + " is not valid.") - end if - end do - - if(.not.no_titles .or. com_title) then - font_height = get_res_value_keep(opts,"FontHeightF",0.01) - txt = create "map_titles" textItemClass wks - "txString" : SubTitles - "txFontHeightF" : font_height - ;"txFontColor" : font_color - end create - anno = NhlAddAnnotation(base,txt) - setvalues anno - "amZone" : 3 - "amJust" : "BottomLeft" - "amSide" : "Top" - "amParallelPosF" : 0.005 - "amOrthogonalPosF" : 0.03 - "amResizeNotify" : False - end setvalues - base@map_titles = anno - end if -; -; gsnDraw and gsnFrame default to False if panel plot. -; - if(panel_plot) then - call_draw = False - call_frame= False - end if - - - opts@gsnDraw = get_res_value_keep(opts,"gsnDraw", call_draw) - opts@gsnFrame = get_res_value_keep(opts,"gsnFrame", call_frame) - - draw_and_frame(wks,base,opts@gsnDraw,opts@gsnFrame,False, \ - opts@gsnMaximize) - - if(.not.panel_plot) then - do i=0,nplots-1 - if(.not.ismissing(plots(i))) then - NhlRemoveOverlay(base,plots(i),False) - else - print("wrf_remove_map_overlays: Warning: overlay plot #" + i + " is not valid.") - print(" Nothing to remove.") - end if - end do - end if - - if(.not.no_titles.and..not.panel_plot) then - if(isatt(base,"map_titles")) then - NhlRemoveAnnotation(base,base@map_titles) - delete(base@map_titles) - end if - end if - -return(base) -end - -;-------------------------------------------------------------------------------- -undef("wrf_user_intrp3d") -function wrf_user_intrp3d( var3d:numeric, z_in:numeric, \ - plot_type:string, \ - loc_param:numeric, angle:numeric, opts:logical ) - -; var3d - 3d field to interpolate (all input fields must be unstaggered) -; z_in - interpolate to this field (either p/z) -; plot_type - interpolate horizontally "h", or vertically "v" -; loc_param - level(s) for horizontal plots (eg. 500hPa ; 3000m - scalar), -; plane for vertical plots (2 values representing an xy point -; on the model domain through which the vertical plane will pass -; OR 4 values specifying start and end values -; angle - 0.0 for horizontal plots, and -; an angle for vertical plots - 90 represent a WE cross section -; opts Used IF opts is TRUE, else use loc_param and angle to determine crosssection - -begin - - - if(plot_type .eq. "h" ) then ; horizontal cross section needed - - dimL = dimsizes(loc_param) - - dims = dimsizes(var3d) - nd = dimsizes(dims) - - dimX = dims(nd-1) - dimY = dims(nd-2) - dimZ = dims(nd-3) - dim4 = 1 - dim5 = 1 - if ( nd .eq. 4 ) then - dim4 = dims(nd-4) - end if - if ( nd .eq. 5 ) then - dim4 = dims(nd-4) - dim5 = dims(nd-5) - end if - - var3 = new ( (/ dim5, dim4, dimZ, dimY, dimX /) , typeof(var3d) ) - z = new ( (/ dim5, dim4, dimZ, dimY, dimX /) , typeof(var3d) ) - var2d = new ( (/ dim5, dim4, dimL, dimY, dimX /) , typeof(var3d) ) - - if ( nd .eq. 5 ) then - var3 = var3d - z = z_in - end if - if ( nd .eq. 4 ) then - var3(0,:,:,:,:) = var3d(:,:,:,:) - z(0,:,:,:,:) = z_in(:,:,:,:) - end if - if ( nd .eq. 3 ) then - var3(0,0,:,:,:) = var3d(:,:,:) - z(0,0,:,:,:) = z_in(:,:,:) - end if - - - if ( z(0,0,0,0,0) .gt. 500.) then - ; We must be interpolating to pressure - ; This routine needs input field and level in hPa - lets make sure of this - if ( z(0,0,0,0,0) .gt. 2000. ) then - ; looks like we have Pa as input - make this hPa - z = z * 0.01 - end if - if ( loc_param(0) .gt. 2000. ) then - ; looks like the input was specified in Pa - change this - loc_param = loc_param * 0.01 - end if - end if - - do il = 0,dimL-1 - var = wrf_interp_3d_z(var3,z,loc_param(il)) - var2d(:,:,il,:,:) = var(:,:,:,:) - end do - - copy_VarAtts(var3d,var3) - if(isatt(var3,"description")) then - delete_VarAtts(var3,(/"description"/)) - end if - if(isatt(var3,"units")) then - delete_VarAtts(var3,(/"units"/)) - end if - if(isatt(var3,"MemoryOrder")) then - delete_VarAtts(var3,(/"MemoryOrder"/)) - end if - if(isatt(var3,"_FillValue")) then - delete_VarAtts(var3,(/"_FillValue"/)) - end if - copy_VarAtts(var3,var2d) - - nn = nd-2 - var2d!nn = "plevs" - - if ( dimL .gt. 1 ) then - if ( nd .eq. 5 ) then - return( var2d ) - end if - if ( nd .eq. 4 ) then - return( var2d(0,:,:,:,:) ) - end if - if ( nd .eq. 3 ) then - return( var2d(0,0,:,:,:) ) - end if - else - if ( z(0,0,0,0,0) .gt. 500.) then - var2d@PlotLevelID = loc_param + " hPa" - else - var2d@PlotLevelID = .001*loc_param + " km" - end if - if ( nd .eq. 5 ) then - return( var2d(:,:,0,:,:) ) - end if - if ( nd .eq. 4 ) then - return( var2d(0,:,0,:,:) ) - end if - if ( nd .eq. 3 ) then - return( var2d(0,0,0,:,:) ) - end if - end if - - - end if - - - - - if(plot_type .eq. "v" ) then ; vertical cross section needed - - dims = dimsizes(var3d) - if ( dimsizes(dims) .eq. 4 ) then - if ( z_in(0,0,0,0) .gt. 500.) then - ; We must be interpolating to pressure - ; This routine needs input field and level in hPa - lets make sure of this - if ( z_in(0,0,0,0) .gt. 2000. ) then - ; looks like we have Pa as input - make this hPa - z_in = z_in * 0.01 - end if - end if - z = z_in(0,:,:,:) - else - if ( z_in(0,0,0) .gt. 500.) then - ; We must be interpolating to pressure - ; This routine needs input field and level in hPa - lets make sure of this - if ( z_in(0,0,0) .gt. 2000. ) then - ; looks like we have Pa as input - make this hPa - z_in = z_in * 0.01 - end if - end if - z = z_in - end if - -; set vertical cross section - if (opts) then - xy = wrf_user_set_xy( z, loc_param(0)-1, loc_param(1)-1, \ ; the -1 is for NCL dimensions - loc_param(2)-1, loc_param(3)-1, \ - angle, opts ) - else - xy = wrf_user_set_xy( z, loc_param(0), loc_param(1), \ - 0.0, 0.0, angle, opts ) - end if - xp = dimsizes(xy) - - -; first we interp z - var2dz = wrf_interp_2d_xy( z, xy) - -; interp to constant z grid - if(var2dz(0,0) .gt. var2dz(1,0) ) then ; monotonically decreasing coordinate - z_max = floor(max(z)/10)*10 ; bottom value - z_min = ceil(min(z)/10)*10 ; top value - dz = 1. - nlevels = tointeger( (z_max-z_min)/dz) - z_var2d = new( (/nlevels/), typeof(z)) - z_var2d(0) = z_max - dz = -dz - else - z_max = max(z) - z_min = 0. -;; MODI SOLINE -; dz = 0.01 * z_max - dz = 0.001 * z_max - nlevels = tointeger( z_max/dz ) - z_var2d = new( (/nlevels/), typeof(z)) - z_var2d(0) = z_min - end if -; print("nlevels="+nlevels) -; print("dz="+dz) - - do i=1, nlevels-1 - z_var2d(i) = z_var2d(0)+i*dz - end do - - -; interp the variable - if ( dimsizes(dims) .eq. 4 ) then - var2d = new( (/dims(0), nlevels, xp(0)/), typeof(var2dz)) - do it = 0,dims(0)-1 - var2dtmp = wrf_interp_2d_xy( var3d(it,:,:,:), xy) - do i=0,xp(0)-1 - var2d(it,:,i) = wrf_interp_1d( var2dtmp(:,i), var2dz(:,i), z_var2d) - end do - end do - var2d!0 = var3d!0 - var2d!1 = "Vertical" - var2d!2 = "Horizontal" - else - var2d = new( (/nlevels, xp(0)/), typeof(var2dz)) - var2dtmp = wrf_interp_2d_xy( var3d, xy) - do i=0,xp(0)-1 - var2d(:,i) = wrf_interp_1d( var2dtmp(:,i), var2dz(:,i), z_var2d) - end do - var2d!0 = "Vertical" - var2d!1 = "Horizontal" - end if - - - st_x = tointeger(xy(0,0)) + 1 - st_y = tointeger(xy(0,1)) + 1 - ed_x = tointeger(xy(xp(0)-1,0)) + 1 - ed_y = tointeger(xy(xp(0)-1,1)) + 1 - if (opts) then - var2d@Orientation = "Cross-Sesion: (" + \ - st_x + "," + st_y + ") to (" + \ - ed_x + "," + ed_y + ")" - else - var2d@Orientation = "Cross-Sesion: (" + \ - st_x + "," + st_y + ") to (" + \ - ed_x + "," + ed_y + ") ; center=(" + \ - loc_param(0) + "," + loc_param(1) + \ - ") ; angle=" + angle - end if - - return(var2d) -end if - - -end - +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/wrf/WRFUserARW.ncl" + +;------------------------------------------------------------- +;contains: +; procedure MESONH_map_c +;function mnh_map(wks[1]:graphic,in_file[1]:file,opt_args[1]:logical) +;function mnh_map_overlays(in_file[1]:file,wks:graphic,plots[*]:graphic, \ +; opt_arg[1]:logical,opt_mp[1]:logical) +;function MESONH_pinter( pfield:numeric, loc_param:numeric, ppabs:numeric ) +;------------------------------------------------------------- + +;============================================================== +; J.-P. CHABOUREAU +; This is a driver that selects the appropriate +; mapping function based upon the file variables RPK, BETA, LATOR, LONOR +; +; +; Sample usage: +; a = addfile("...", r") +; IMAX = a->IMAX +; JMAX = a->JMAX +; lat2d = new((/JMAX,IMAX/),"double") +; lat2d(:,:)=0. +; lon2d = new((/JMAX,IMAX/),"double") +; lon2d(:,:)=0. +; icorners = new((/2,2/),"integer") +; icorners(:,:)=0 +; res = True +; MESONH_map_c (a, res, lat2d, lon2d, icorners) +; +; +undef("MESONH_map_c") +;============================================================== +procedure MESONH_map_c (in_file:file, res:logical, plat, plon, icorner) +;============================================================== +;local rank, dimll, nlat, mlon, lat, lon +local rank, dimll, nlat, mlon +begin + +; Check if the variable RPK is in the file +; ---------------------------------------- +if(isfilevar(in_file,"RPK")) then + +; Read projection parameters +; ------------------------- + ZRPK = in_file->RPK + ZLATOR = in_file->LATOR + ZLONOR = in_file->LONOR + ZBETA = in_file->BETA + ZLAT0 = in_file->LAT0 + ZLON0 = in_file->LON0 + +; Case netcdf from lfi2cdf +; ------------------------- + + if(isfilevar(in_file,"IMAX")) + XHAT=in_file->XHAT + YHAT=in_file->YHAT + IMAX= dimsizes(XHAT)-2 + JMAX= dimsizes(YHAT)-2 + zdx=XHAT(2)-XHAT(1) + zdy=YHAT(2)-YHAT(1) + +; unstagger + do ji=0,IMAX-1 + XHAT(ji)=XHAT(ji)+zdx*1.5 + end do + do jj=0,JMAX-1 + YHAT(jj)=YHAT(jj)+zdy*1.5 + end do + + else + +; Case netcdf from extractdia +; --------------------------- + XHAT=in_file->W_E_direction + YHAT=in_file->S_N_direction + IMAX= dimsizes(XHAT) + JMAX= dimsizes(YHAT) + zdx=XHAT(2)-XHAT(1) + zdy=YHAT(2)-YHAT(1) + + end if + + print ("LATOR="+ZLATOR+" - LONOR="+ZLONOR) + print ("ZLAT0="+ZLAT0+" - ZLON0="+ZLON0) + print ("ZDX="+zdx+" - RPK="+ZRPK+" - BETA="+ZBETA) + print ("IMAX="+IMAX+" - JMAX="+JMAX) + + if (ZRPK.gt.0) + ; Stereographic projection +; --------------------------- + res@mpProjection = "Stereographic" + res@mpCenterLonF = ZLON0 + res@mpCenterRotF = ZBETA + res@mpCenterLatF = 90. + end if + + if (ZRPK.lt.0) + ; Stereographic projection +; --------------------------- + res@mpProjection = "Stereographic" + res@mpCenterLonF = ZLON0 + res@mpCenterRotF = ZBETA + res@mpCenterLatF = -90. + end if + + if (ZRPK.eq.0) then + ; Mercator projection +; --------------------------- + res@mpProjection = "Mercator" + end if + + print("Map projection="+res@mpProjection) + +else + print ("MESONH_map_c: Error no RPK variable in input file") +end if + +;=================================================; +; calculate 2D lat and lon +; based on src/mesonh_MOD/mode_gridproj.f90 +;=================================================; + +; Constants +; ----------- + if(isfilevar(in_file,"IMAX")) + XRADIUS=6371229.0d ; Earth radius (meters) + else + XRADIUS=6371.2290d ; Earth radius (km) + end if + XPI=2.0d*asin(1.) ; Pi + ZRDSDG= XPI/180.0d ; Radian to Degree conversion factor + ZXBM0 = 0.0d + ZYBM0 = 0.0d + +;=================================================; + if (ZRPK.eq.0) then +; MERCATOR +;=================================================; + XBETA=0. + XLAT0=0. ; map reference latitude (degrees) + ZXBM0 = 0. + ZYBM0 = 0. + ZCGAM = cos(-ZRDSDG*XBETA) + ZSGAM = sin(-ZRDSDG*XBETA) + ZRACLAT0 = XRADIUS*cos(ZRDSDG*ZLAT0) + do ji=0,IMAX-1 + jj=0 + ZXMI0 = XHAT(ji)-ZXBM0 + ZYMI0 = YHAT(jj)-ZYBM0 + zlon = (ZXMI0*ZCGAM+ZYMI0*ZSGAM)/(ZRACLAT0*ZRDSDG)+ZLONOR + do jj=0,JMAX-1 + plon(jj,ji)=zlon + end do + end do + do jj=0,JMAX-1 + ji=0 + ZXMI0 = XHAT(ji)-ZXBM0 + ZYMI0 = YHAT(jj)-ZYBM0 + ZT1 = log(tan(XPI/4.+ZLATOR*ZRDSDG/2.)) + ZT2 = (-ZXMI0*ZSGAM+ZYMI0*ZCGAM)/ZRACLAT0 + zlat = (-XPI/2.+2.*atan(exp(ZT1+ZT2)))/ZRDSDG + do ji=0,IMAX-1 + plat(jj,ji)=zlat + end do + end do + +;=================================================; + else +; STEREOGRAPHIC PROJECTION +;=================================================; + ZCLAT0 = cos(ZRDSDG*ZLAT0) + ZSLAT0 = sin(ZRDSDG*ZLAT0) + ZCLATOR = cos(ZRDSDG*ZLATOR) + ZSLATOR = sin(ZRDSDG*ZLATOR) + ZRO0 = (XRADIUS/ZRPK)*(abs(ZCLAT0))^(1.-ZRPK) * \ + ((1.+ZSLAT0)*abs(ZCLATOR)/(1.+ZSLATOR))^ZRPK + ZGA0 = (ZRPK*(ZLONOR-ZLON0)-ZBETA)*ZRDSDG + ZXP = ZXBM0-ZRO0*sin(ZGA0) + ZYP = ZYBM0+ZRO0*cos(ZGA0) + do ji=0,IMAX-1 + do jj=0,JMAX-1 + ZATA = atan2( -(ZXP-XHAT(ji)) , (ZYP-YHAT(jj)) )/ZRDSDG + zlon = (ZBETA+ZATA)/ZRPK+ZLON0 + plon(jj,ji)=zlon + ZRO2 = (XHAT(ji)-ZXP)^2+(YHAT(jj)-ZYP)^2 + ZJD1 = XRADIUS*(abs(ZCLAT0))^(1.-ZRPK) + ZT1 = (ZJD1)^(2./ZRPK)* (1+ZSLAT0)^2 + ZJD3 = (ZRPK^2*ZRO2) + ZT2 = ZJD3 + ZT2 = ZT2^(1./ZRPK) + ZJD1 = (ZT1-ZT2)/(ZT1+ZT2) + ZJD1 = acos(ZJD1) + ZJD3 = ZJD1 + zlat = (XPI/2.-ZJD3)/ZRDSDG + plat(jj,ji)=zlat + end do + end do + + end if + +; Defining the corners of the domain +;==================================== + if (icorner(0,0).eq.icorner(1,1)) then + icorner(0,0)=0 + icorner(1,0)=JMAX-1 + icorner(0,1)=0 + icorner(1,1)=IMAX-1 + end if +; print ("icorner"+icorner) + + res@mpLimitMode = "Corners" + res@mpLeftCornerLatF = plat(icorner(0,0),icorner(0,1)) + res@mpLeftCornerLonF = plon(icorner(0,0),icorner(0,1)) + res@mpRightCornerLatF = plat(icorner(1,0),icorner(1,1)) + res@mpRightCornerLonF = plon(icorner(1,0),icorner(1,1)) + +; print ("Corner (0,0); Lat="+res@mpLeftCornerLatF+ \ +; ", Lon="+res@mpLeftCornerLonF) +; print ("Oppos corner; Lat="+res@mpRightCornerLatF+ \ +; ", Lon= "+res@mpRightCornerLonF) + +;========================================== +; Turn on lat / lon labeling +;========================================== + res@pmTickMarkDisplayMode = "Always" ; turn on tickmarks + res@mpOutlineBoundarySets = "AllBoundaries" ; state boundaries + res@mpPerimDrawOrder = "PostDraw" ; force map perim +;========================================== +; Needed for regional native projection +;========================================== + res@tfDoNDCOverlay = True + res@gsnAddCyclic = False ; regional data + +end + +;=========================================== +;------------------------------------------------------------------------ +undef("MESONH_pinter") +function MESONH_pinter( pfield:numeric, loc_param:numeric, ppabs:numeric ) +;************************************************************************* +; S. BIELLI +; This is a routine that interpolate fields on pressure level for plotting +; based on pinter.f90 +; The field to be interpolated must be given at the mass point (grid 1) +; usage : var_inter=MESONHfunction(var_to_interpol, 850., AbsPressure) +; Abs pressure must be in Pa +; + +begin + + dimL= dimsizes(loc_param) + +; First test for grid = 0 + + dimp=dimsizes(ppabs) + + pout=pfield(0:dimL-1,:,:) + pfield@_FillValue=999 + pout@_FillValue=999 + pout=pout@_FillValue + + do jkp = 0, dimL-1 + zref=log10(loc_param(jkp)*100.) + do jloop = 0, dimp(1)-1 + do iloop = 0, dimp(2)-1 + kloop=0 + flag=True + do while (flag .and. (kloop.lt.(dimp(2)-2))) + if (.not.ismissing(ppabs(kloop,jloop,iloop))) then + zxm=log10(ppabs(kloop,jloop,iloop)) + zxp=log10(ppabs(kloop+1,jloop,iloop)) + if ((zxp-zref)*(zref-zxm) .ge. 0) then + pout(jkp,jloop,iloop)= (pfield(kloop,jloop,iloop)*(zxp-zref)+ \ + pfield(kloop+1,jloop,iloop)*(zref-zxm))/ (zxp-zxm) + flag=False + end if + end if + kloop=kloop+1 + end do + end do + end do + end do + + return(pout) + +end + +;-------------------------------------------------------------------------------- +undef("mnh_map") +function mnh_map(wks[1]:graphic,in_file[1]:file,opt_args[1]:logical) + +begin +; +; This function creates a map plot, and bases the projection on +; the MAP_PROJ attribute in the given file. +; +; 1. Make a copy of the resource list, and set some resources +; common to all map projections. +; +; 2. Determine the projection being used, and set resources based +; on that projection. +; +; 3. Create the map plot, and draw and advance the frame +; (if requested). + + opts = opt_args ; Make a copy of the resource list + opts = True + +; Set some resources depending on what kind of map projection is +; chosen. +; +; ZRPK != 0 : "Stereographic" +; ZRPK = 0 : "Mercator" +;=================================================; +; src/mesonh_MOD/mode_gridproj.f90 +;=================================================; + XRADIUS=6371229.0d ; Earth radius (meters) + XPI=2.0d*asin(1.) ; Pi + ZRDSDG= XPI/180.0d ; Radian to Degree conversion factor + ZXBM0 = 0.0d + ZYBM0 = 0.0d + + if(isfilevar(in_file,"RPK")) + ZRPK=in_file->RPK + ZLON0=in_file->LON0 + ZLAT0=in_file->LAT0 + ZLATOR=in_file->LATOR + ZLONOR=in_file->LONOR + ZBETA=in_file->BETA + else + print ("mnh_map: Error no RPK variable in input file") + return(new(1,graphic)) + end if + +; Case netcdf from lfi2cdf + if(isfilevar(in_file,"IMAX")) + XHAT=in_file->XHAT + YHAT=in_file->YHAT + IMAX= dimsizes(XHAT)-2 + JMAX= dimsizes(YHAT)-2 + zdx=XHAT(2)-XHAT(1) + zdy=YHAT(2)-YHAT(1) + do ji=0,IMAX-1 + XHAT(ji)=XHAT(ji)+zdx*1.5 + end do + do jj=0,JMAX-1 + YHAT(jj)=YHAT(jj)+zdy*1.5 + end do + else +; Case netcdf from extractdia + XHAT=in_file->W_E_direction + YHAT=in_file->S_N_direction + IMAX= dimsizes(XHAT) + JMAX= dimsizes(YHAT) + end if +; + + lat = new((/JMAX,IMAX/),"double") + lon = new((/JMAX,IMAX/),"double") + + +; Stereographic projection + if(ZRPK .gt. 0) + projection = "Stereographic" + opts@mpCenterLatF = get_res_value_keep(opts, "mpCenterLatF", 90) + opts@mpCenterLonF = get_res_value_keep(opts, "mpCenterLonF",ZLON0) + opts@mpCenterRotF = get_res_value_keep(opts, "mpCenterRotF",ZBETA) + end if + + if(ZRPK .lt. 0) + projection = "Stereographic" + opts@mpCenterLatF = get_res_value_keep(opts, "mpCenterLatF", -90) + opts@mpCenterLonF = get_res_value_keep(opts, "mpCenterLonF",ZLON0) + opts@mpCenterRotF = get_res_value_keep(opts, "mpCenterRotF",ZBETA) + end if + +; Mercator projection + if(ZRPK .eq. 0) + projection = "Mercator" + end if + + opts@mpNestTime = get_res_value_keep(opts, "mpNestTime",0) + + +; LAT and LON are not saved in the file + if (ZRPK.eq.0) then + XBETA=0. + XLAT0=0. ; map reference latitude (degrees) + ZXBM0 = 0. + ZYBM0 = 0. + ZCGAM = cos(-ZRDSDG*XBETA) + ZSGAM = sin(-ZRDSDG*XBETA) + ZRACLAT0 = XRADIUS*cos(ZRDSDG*ZLAT0) + do ji=0,IMAX-1 + jj=0 + ZXMI0 = XHAT(ji)-ZXBM0 + ZYMI0 = YHAT(jj)-ZYBM0 + zlon = (ZXMI0*ZCGAM+ZYMI0*ZSGAM)/(ZRACLAT0*ZRDSDG)+ZLONOR + do jj=0,JMAX-1 + lon(jj,ji)=zlon + end do + end do + do jj=0,JMAX-1 + ji=0 + ZXMI0 = XHAT(ji)-ZXBM0 + ZYMI0 = YHAT(jj)-ZYBM0 + ZT1 = log(tan(XPI/4.+ZLATOR*ZRDSDG/2.)) + ZT2 = (-ZXMI0*ZSGAM+ZYMI0*ZCGAM)/ZRACLAT0 + zlat = (-XPI/2.+2.*atan(exp(ZT1+ZT2)))/ZRDSDG + do ji=0,IMAX-1 + lat(jj,ji)=zlat + end do + end do + else + ZCLAT0 = cos(ZRDSDG*ZLAT0) + ZSLAT0 = sin(ZRDSDG*ZLAT0) + ZCLATOR = cos(ZRDSDG*ZLATOR) + ZSLATOR = sin(ZRDSDG*ZLATOR) + ZRO0 = (XRADIUS/ZRPK)*(abs(ZCLAT0))^(1.-ZRPK) * \ + ((1.+ZSLAT0)*abs(ZCLATOR)/(1.+ZSLATOR))^ZRPK + ZGA0 = (ZRPK*(ZLONOR-ZLON0)-ZBETA)*ZRDSDG + ZXP = ZXBM0-ZRO0*sin(ZGA0) + ZYP = ZYBM0+ZRO0*cos(ZGA0) + do ji=0,IMAX-1 + do jj=0,JMAX-1 + ZATA = atan2( -(ZXP-XHAT(ji)) , (ZYP-YHAT(jj)) )/ZRDSDG + zlon = (ZBETA+ZATA)/ZRPK+ZLON0 + lon(jj,ji)=zlon + ZRO2 = (XHAT(ji)-ZXP)^2+(YHAT(jj)-ZYP)^2 + ZJD1 = XRADIUS*(abs(ZCLAT0))^(1.-ZRPK) + ZT1 = (ZJD1)^(2./ZRPK)* (1+ZSLAT0)^2 + ZJD3 = (ZRPK^2*ZRO2) + ZT2 = ZJD3 + ZT2 = ZT2^(1./ZRPK) + ZJD1 = (ZT1-ZT2)/(ZT1+ZT2) + ZJD1 = acos(ZJD1) + ZJD3 = ZJD1 + zlat = (XPI/2.-ZJD3)/ZRDSDG + lat(jj,ji)=zlat + end do + end do + end if + + dims = dimsizes(lat) + + do ii = 0, dims(0)-1 + do jj = 0, dims(1)-1 + if ( lon(ii,jj) .lt. 0.0) then + lon(ii,jj) = lon(ii,jj) + 360. + end if + end do + end do + + opts@start_lat = lat(0,0) + opts@start_lon = lon(0,0) + opts@end_lat = lat(dims(0)-1,dims(1)-1) + opts@end_lon = lon(dims(0)-1,dims(1)-1) + + +; Set some resources common to all map projections. + opts = set_mp_resources(opts) + + if ( isatt(opts,"ZoomIn") .and. opts@ZoomIn ) then + y1 = 0 + x1 = 0 + y2 = dims(0)-1 + x2 = dims(1)-1 + if ( isatt(opts,"Ystart") ) then + y1 = opts@Ystart + delete(opts@Ystart) + end if + if ( isatt(opts,"Xstart") ) then + x1 = opts@Xstart + delete(opts@Xstart) + end if + if ( isatt(opts,"Yend") ) then + if ( opts@Yend .le. y2 ) then + y2 = opts@Yend + end if + delete(opts@Yend) + end if + if ( isatt(opts,"Xend") ) then + if ( opts@Xend .le. x2 ) then + x2 = opts@Xend + end if + delete(opts@Xend) + end if + + opts@mpLeftCornerLatF = lat(y1,x1) + opts@mpLeftCornerLonF = lon(y1,x1) + opts@mpRightCornerLatF = lat(y2,x2) + opts@mpRightCornerLonF = lon(y2,x2) + + if ( opts@mpRightCornerLonF .lt. 0.0 ) then + opts@mpRightCornerLonF = opts@mpRightCornerLonF + 360.0 + end if + + delete(opts@ZoomIn) + end if + + +; The default is not to draw the plot or advance the frame, and +; to maximize the plot in the frame. + + opts@gsnDraw = get_res_value_keep(opts,"gsnDraw", False) + opts@gsnFrame = get_res_value_keep(opts,"gsnFrame", False) + opts@gsnMaximize = get_res_value_keep(opts,"gsnMaximize", True) + + delete_attrs(opts) ; Clean up. + mp = gsn_map(wks,projection,opts) ; Create map plot. + + return(mp) ; Return. + +end + +;-------------------------------------------------------------------------------- + +undef("mnh_map_overlays") +function mnh_map_overlays(in_file[1]:file, \ + wks:graphic, \ + plots[*]:graphic, \ + opt_arg[1]:logical, \ + opt_mp[1]:logical) + +; Based on wrf_map_overlays +; +; This procedure takes an array of plots and overlays them on a +; base plot - map background. +; +; It will advance the plot and cleanup, unless you set the +; PanelPlot resource to True. +; +; Attributes recognized by this procedure: +; FramePlot +; PanelPlot +; NoTitles (don't do any titles) +; CommonTitle & PlotTile is used to overwrite field titles +; CommonTitle will super-seed NoTitles +; +; If FramePlot False, then Draw the plot but do not Frame. +; In this case a user want to add to the drawing, and will +; have to advance the Frame manually in the script. +; +; If the "NoTitles" attribute exists and is set True, then +; don't create the top-left titles, and leave the main titles alone. +; This resource can be useful if you are planning to panel +; the plots. +; +; If PanelPlot is set to True, then this flags to wrf_map_overlays +; that these plots are going to be eventually paneled (likely +; by gsn_panel), and hence 1) draw and frame should not be called +; (unless gsnDraw and/or gsnFrame are explicitly set to True), +; and 2) the overlays and titles should not be removed with +; NhlRemoveOverlay and NhlRemoveAnnotation. +; +begin + + opts = opt_arg ; Make a copy of the resource lists + opt_mp_2 = opt_mp + + ; Let's make the map first + base = mnh_map(wks,in_file,opt_mp_2) + + no_titles = get_res_value(opts,"NoTitles",False) ; Do we want field titles? + com_title = get_res_value(opts,"CommonTitle",False) ; Do we have a common title? + if ( com_title ) then + plot_title = get_res_value(opts,"PlotTitle"," ") + no_titles = True + end if + + call_draw = True + call_frame = get_res_value(opts,"FramePlot",True) ; Do we want to frame the plot? + panel_plot = get_res_value(opts,"PanelPlot",False) ; Are we paneling? + opts@gsnMaximize = get_res_value_keep(opts,"gsnMaximize", True) + + nplots = dimsizes(plots) +; font_color = "Black" + + do i=0,nplots-1 + if(.not.ismissing(plots(i))) then +; class_name = NhlClassName(plots(i)) +; print(class_name) +; if(class_name.eq."contourPlotClass") then +; getvalues plots(i) +; "cnFillOn" : fill_on +; "cnLineColor" : line_color +; end getvalues +; if (.not.fill_on) then +; font_color = line_color +; end if +; end if + if(.not.no_titles) then + getvalues plots(i) + "tiMainString" : SubTitle + end getvalues + if(i.eq.0) then + SubTitles = SubTitle + else + SubTitles = SubTitles + "~C~" + SubTitle + end if + end if + if(com_title .and. i .eq. nplots-1) then + getvalues plots(i) + "tiMainString" : SubTitle + end getvalues + SubTitles = plot_title + end if + setvalues plots(i) + "tfDoNDCOverlay" : True + "tiMainOn" : False + end setvalues + overlay(base,plots(i)) + else + print("mnh_map_overlays: Warning: overlay plot #" + i + " is not valid.") + end if + end do + + if(.not.no_titles .or. com_title) then + font_height = get_res_value_keep(opts,"FontHeightF",0.01) + txt = create "map_titles" textItemClass wks + "txString" : SubTitles + "txFontHeightF" : font_height + ;"txFontColor" : font_color + end create + anno = NhlAddAnnotation(base,txt) + setvalues anno + "amZone" : 3 + "amJust" : "BottomLeft" + "amSide" : "Top" + "amParallelPosF" : 0.005 + "amOrthogonalPosF" : 0.03 + "amResizeNotify" : False + end setvalues + base@map_titles = anno + end if +; +; gsnDraw and gsnFrame default to False if panel plot. +; + if(panel_plot) then + call_draw = False + call_frame= False + end if + + + opts@gsnDraw = get_res_value_keep(opts,"gsnDraw", call_draw) + opts@gsnFrame = get_res_value_keep(opts,"gsnFrame", call_frame) + + draw_and_frame(wks,base,opts@gsnDraw,opts@gsnFrame,False, \ + opts@gsnMaximize) + + if(.not.panel_plot) then + do i=0,nplots-1 + if(.not.ismissing(plots(i))) then + NhlRemoveOverlay(base,plots(i),False) + else + print("wrf_remove_map_overlays: Warning: overlay plot #" + i + " is not valid.") + print(" Nothing to remove.") + end if + end do + end if + + if(.not.no_titles.and..not.panel_plot) then + if(isatt(base,"map_titles")) then + NhlRemoveAnnotation(base,base@map_titles) + delete(base@map_titles) + end if + end if + +return(base) +end + +;-------------------------------------------------------------------------------- +undef("wrf_user_intrp3d") +function wrf_user_intrp3d( var3d:numeric, z_in:numeric, \ + plot_type:string, \ + loc_param:numeric, angle:numeric, opts:logical ) + +; var3d - 3d field to interpolate (all input fields must be unstaggered) +; z_in - interpolate to this field (either p/z) +; plot_type - interpolate horizontally "h", or vertically "v" +; loc_param - level(s) for horizontal plots (eg. 500hPa ; 3000m - scalar), +; plane for vertical plots (2 values representing an xy point +; on the model domain through which the vertical plane will pass +; OR 4 values specifying start and end values +; angle - 0.0 for horizontal plots, and +; an angle for vertical plots - 90 represent a WE cross section +; opts Used IF opts is TRUE, else use loc_param and angle to determine crosssection + +begin + + + if(plot_type .eq. "h" ) then ; horizontal cross section needed + + dimL = dimsizes(loc_param) + + dims = dimsizes(var3d) + nd = dimsizes(dims) + + dimX = dims(nd-1) + dimY = dims(nd-2) + dimZ = dims(nd-3) + dim4 = 1 + dim5 = 1 + if ( nd .eq. 4 ) then + dim4 = dims(nd-4) + end if + if ( nd .eq. 5 ) then + dim4 = dims(nd-4) + dim5 = dims(nd-5) + end if + + var3 = new ( (/ dim5, dim4, dimZ, dimY, dimX /) , typeof(var3d) ) + z = new ( (/ dim5, dim4, dimZ, dimY, dimX /) , typeof(var3d) ) + var2d = new ( (/ dim5, dim4, dimL, dimY, dimX /) , typeof(var3d) ) + + if ( nd .eq. 5 ) then + var3 = var3d + z = z_in + end if + if ( nd .eq. 4 ) then + var3(0,:,:,:,:) = var3d(:,:,:,:) + z(0,:,:,:,:) = z_in(:,:,:,:) + end if + if ( nd .eq. 3 ) then + var3(0,0,:,:,:) = var3d(:,:,:) + z(0,0,:,:,:) = z_in(:,:,:) + end if + + + if ( z(0,0,0,0,0) .gt. 500.) then + ; We must be interpolating to pressure + ; This routine needs input field and level in hPa - lets make sure of this + if ( z(0,0,0,0,0) .gt. 2000. ) then + ; looks like we have Pa as input - make this hPa + z = z * 0.01 + end if + if ( loc_param(0) .gt. 2000. ) then + ; looks like the input was specified in Pa - change this + loc_param = loc_param * 0.01 + end if + end if + + do il = 0,dimL-1 + var = wrf_interp_3d_z(var3,z,loc_param(il)) + var2d(:,:,il,:,:) = var(:,:,:,:) + end do + + copy_VarAtts(var3d,var3) + if(isatt(var3,"description")) then + delete_VarAtts(var3,(/"description"/)) + end if + if(isatt(var3,"units")) then + delete_VarAtts(var3,(/"units"/)) + end if + if(isatt(var3,"MemoryOrder")) then + delete_VarAtts(var3,(/"MemoryOrder"/)) + end if + if(isatt(var3,"_FillValue")) then + delete_VarAtts(var3,(/"_FillValue"/)) + end if + copy_VarAtts(var3,var2d) + + nn = nd-2 + var2d!nn = "plevs" + + if ( dimL .gt. 1 ) then + if ( nd .eq. 5 ) then + return( var2d ) + end if + if ( nd .eq. 4 ) then + return( var2d(0,:,:,:,:) ) + end if + if ( nd .eq. 3 ) then + return( var2d(0,0,:,:,:) ) + end if + else + if ( z(0,0,0,0,0) .gt. 500.) then + var2d@PlotLevelID = loc_param + " hPa" + else + var2d@PlotLevelID = .001*loc_param + " km" + end if + if ( nd .eq. 5 ) then + return( var2d(:,:,0,:,:) ) + end if + if ( nd .eq. 4 ) then + return( var2d(0,:,0,:,:) ) + end if + if ( nd .eq. 3 ) then + return( var2d(0,0,0,:,:) ) + end if + end if + + + end if + + + + + if(plot_type .eq. "v" ) then ; vertical cross section needed + + dims = dimsizes(var3d) + if ( dimsizes(dims) .eq. 4 ) then + if ( z_in(0,0,0,0) .gt. 500.) then + ; We must be interpolating to pressure + ; This routine needs input field and level in hPa - lets make sure of this + if ( z_in(0,0,0,0) .gt. 2000. ) then + ; looks like we have Pa as input - make this hPa + z_in = z_in * 0.01 + end if + end if + z = z_in(0,:,:,:) + else + if ( z_in(0,0,0) .gt. 500.) then + ; We must be interpolating to pressure + ; This routine needs input field and level in hPa - lets make sure of this + if ( z_in(0,0,0) .gt. 2000. ) then + ; looks like we have Pa as input - make this hPa + z_in = z_in * 0.01 + end if + end if + z = z_in + end if + +; set vertical cross section + if (opts) then + xy = wrf_user_set_xy( z, loc_param(0)-1, loc_param(1)-1, \ ; the -1 is for NCL dimensions + loc_param(2)-1, loc_param(3)-1, \ + angle, opts ) + else + xy = wrf_user_set_xy( z, loc_param(0), loc_param(1), \ + 0.0, 0.0, angle, opts ) + end if + xp = dimsizes(xy) + + +; first we interp z + var2dz = wrf_interp_2d_xy( z, xy) + +; interp to constant z grid + if(var2dz(0,0) .gt. var2dz(1,0) ) then ; monotonically decreasing coordinate + z_max = floor(max(z)/10)*10 ; bottom value + z_min = ceil(min(z)/10)*10 ; top value + dz = 1. + nlevels = tointeger( (z_max-z_min)/dz) + z_var2d = new( (/nlevels/), typeof(z)) + z_var2d(0) = z_max + dz = -dz + else + z_max = max(z) + z_min = 0. +;; MODI SOLINE +; dz = 0.01 * z_max + dz = 0.001 * z_max + nlevels = tointeger( z_max/dz ) + z_var2d = new( (/nlevels/), typeof(z)) + z_var2d(0) = z_min + end if +; print("nlevels="+nlevels) +; print("dz="+dz) + + do i=1, nlevels-1 + z_var2d(i) = z_var2d(0)+i*dz + end do + + +; interp the variable + if ( dimsizes(dims) .eq. 4 ) then + var2d = new( (/dims(0), nlevels, xp(0)/), typeof(var2dz)) + do it = 0,dims(0)-1 + var2dtmp = wrf_interp_2d_xy( var3d(it,:,:,:), xy) + do i=0,xp(0)-1 + var2d(it,:,i) = wrf_interp_1d( var2dtmp(:,i), var2dz(:,i), z_var2d) + end do + end do + var2d!0 = var3d!0 + var2d!1 = "Vertical" + var2d!2 = "Horizontal" + else + var2d = new( (/nlevels, xp(0)/), typeof(var2dz)) + var2dtmp = wrf_interp_2d_xy( var3d, xy) + do i=0,xp(0)-1 + var2d(:,i) = wrf_interp_1d( var2dtmp(:,i), var2dz(:,i), z_var2d) + end do + var2d!0 = "Vertical" + var2d!1 = "Horizontal" + end if + + + st_x = tointeger(xy(0,0)) + 1 + st_y = tointeger(xy(0,1)) + 1 + ed_x = tointeger(xy(xp(0)-1,0)) + 1 + ed_y = tointeger(xy(xp(0)-1,1)) + 1 + if (opts) then + var2d@Orientation = "Cross-Sesion: (" + \ + st_x + "," + st_y + ") to (" + \ + ed_x + "," + ed_y + ")" + else + var2d@Orientation = "Cross-Sesion: (" + \ + st_x + "," + st_y + ") to (" + \ + ed_x + "," + ed_y + ") ; center=(" + \ + loc_param(0) + "," + loc_param(1) + \ + ") ; angle=" + angle + end if + + return(var2d) +end if + + +end + diff --git a/MY_RUN/KTEST/004_Reunion/005_ncl_nc4/MESONHtools.ncl b/MY_RUN/KTEST/004_Reunion/005_ncl_nc4/MESONHtools.ncl index 7280ddc0c6f05aebe6b7a11afffed5449985f7bd..182df6d79d89e02ef068049311ec842988701b43 100644 --- a/MY_RUN/KTEST/004_Reunion/005_ncl_nc4/MESONHtools.ncl +++ b/MY_RUN/KTEST/004_Reunion/005_ncl_nc4/MESONHtools.ncl @@ -1,916 +1,916 @@ -load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" -load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" -load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" -load "$NCARG_ROOT/lib/ncarg/nclscripts/wrf/WRFUserARW.ncl" - -;------------------------------------------------------------- -;contains: -; procedure MESONH_map_c -;function mnh_map(wks[1]:graphic,in_file[1]:file,opt_args[1]:logical) -;function mnh_map_overlays(in_file[1]:file,wks:graphic,plots[*]:graphic, \ -; opt_arg[1]:logical,opt_mp[1]:logical) -;function MESONH_pinter( pfield:numeric, loc_param:numeric, ppabs:numeric ) -;------------------------------------------------------------- - -;============================================================== -; J.-P. CHABOUREAU -; This is a driver that selects the appropriate -; mapping function based upon the file variables RPK, BETA, LATOR, LONOR -; -; -; Sample usage: -; a = addfile("...", r") -; IMAX = a->IMAX -; JMAX = a->JMAX -; lat2d = new((/JMAX,IMAX/),"double") -; lat2d(:,:)=0. -; lon2d = new((/JMAX,IMAX/),"double") -; lon2d(:,:)=0. -; icorners = new((/2,2/),"integer") -; icorners(:,:)=0 -; res = True -; MESONH_map_c (a, res, lat2d, lon2d, icorners) -; -; -undef("MESONH_map_c") -;============================================================== -procedure MESONH_map_c (in_file:file, res:logical, plat, plon, icorner) -;============================================================== -;local rank, dimll, nlat, mlon, lat, lon -local rank, dimll, nlat, mlon -begin - -; Check if the variable RPK is in the file -; ---------------------------------------- -if(isfilevar(in_file,"RPK")) then - -; Read projection parameters -; ------------------------- - ZRPK = in_file->RPK - ZLATOR = in_file->LATOR - ZLONOR = in_file->LONOR - ZBETA = in_file->BETA - ZLAT0 = in_file->LAT0 - ZLON0 = in_file->LON0 - -; Case netcdf from lfi2cdf -; ------------------------- - - if(isfilevar(in_file,"IMAX")) - XHAT=in_file->XHAT - YHAT=in_file->YHAT - jphext = in_file->JPHEXT - IMAX= dimsizes(XHAT)-2*JPHEXT - JMAX= dimsizes(YHAT)-2*JPHEXT - zdx=XHAT(2)-XHAT(1) - zdy=YHAT(2)-YHAT(1) - -; unstagger - do ji=0,IMAX-1 - XHAT(ji)=XHAT(ji)+zdx*1.5 - end do - do jj=0,JMAX-1 - YHAT(jj)=YHAT(jj)+zdy*1.5 - end do - - else - -; Case netcdf from extractdia -; --------------------------- - XHAT=in_file->W_E_direction - YHAT=in_file->S_N_direction - IMAX= dimsizes(XHAT) - JMAX= dimsizes(YHAT) - zdx=XHAT(2)-XHAT(1) - zdy=YHAT(2)-YHAT(1) - - end if - - print ("LATOR="+ZLATOR+" - LONOR="+ZLONOR) - print ("ZLAT0="+ZLAT0+" - ZLON0="+ZLON0) - print ("ZDX="+zdx+" - RPK="+ZRPK+" - BETA="+ZBETA) - print ("IMAX="+IMAX+" - JMAX="+JMAX) - - if (ZRPK.gt.0) - ; Stereographic projection -; --------------------------- - res@mpProjection = "Stereographic" - res@mpCenterLonF = ZLON0 - res@mpCenterRotF = ZBETA - res@mpCenterLatF = 90. - end if - - if (ZRPK.lt.0) - ; Stereographic projection -; --------------------------- - res@mpProjection = "Stereographic" - res@mpCenterLonF = ZLON0 - res@mpCenterRotF = ZBETA - res@mpCenterLatF = -90. - end if - - if (ZRPK.eq.0) then - ; Mercator projection -; --------------------------- - res@mpProjection = "Mercator" - end if - - print("Map projection="+res@mpProjection) - -else - print ("MESONH_map_c: Error no RPK variable in input file") -end if - -;=================================================; -; calculate 2D lat and lon -; based on src/mesonh_MOD/mode_gridproj.f90 -;=================================================; - -; Constants -; ----------- - if(isfilevar(in_file,"IMAX")) - XRADIUS=6371229.0d ; Earth radius (meters) - else - XRADIUS=6371.2290d ; Earth radius (km) - end if - XPI=2.0d*asin(1.) ; Pi - ZRDSDG= XPI/180.0d ; Radian to Degree conversion factor - ZXBM0 = 0.0d - ZYBM0 = 0.0d - -;=================================================; - if (ZRPK.eq.0) then -; MERCATOR -;=================================================; - XBETA=0. - XLAT0=0. ; map reference latitude (degrees) - ZXBM0 = 0. - ZYBM0 = 0. - ZCGAM = cos(-ZRDSDG*XBETA) - ZSGAM = sin(-ZRDSDG*XBETA) - ZRACLAT0 = XRADIUS*cos(ZRDSDG*ZLAT0) - do ji=0,IMAX-1 - jj=0 - ZXMI0 = XHAT(ji)-ZXBM0 - ZYMI0 = YHAT(jj)-ZYBM0 - zlon = (ZXMI0*ZCGAM+ZYMI0*ZSGAM)/(ZRACLAT0*ZRDSDG)+ZLONOR - do jj=0,JMAX-1 - plon(jj,ji)=zlon - end do - end do - do jj=0,JMAX-1 - ji=0 - ZXMI0 = XHAT(ji)-ZXBM0 - ZYMI0 = YHAT(jj)-ZYBM0 - ZT1 = log(tan(XPI/4.+ZLATOR*ZRDSDG/2.)) - ZT2 = (-ZXMI0*ZSGAM+ZYMI0*ZCGAM)/ZRACLAT0 - zlat = (-XPI/2.+2.*atan(exp(ZT1+ZT2)))/ZRDSDG - do ji=0,IMAX-1 - plat(jj,ji)=zlat - end do - end do - -;=================================================; - else -; STEREOGRAPHIC PROJECTION -;=================================================; - ZCLAT0 = cos(ZRDSDG*ZLAT0) - ZSLAT0 = sin(ZRDSDG*ZLAT0) - ZCLATOR = cos(ZRDSDG*ZLATOR) - ZSLATOR = sin(ZRDSDG*ZLATOR) - ZRO0 = (XRADIUS/ZRPK)*(abs(ZCLAT0))^(1.-ZRPK) * \ - ((1.+ZSLAT0)*abs(ZCLATOR)/(1.+ZSLATOR))^ZRPK - ZGA0 = (ZRPK*(ZLONOR-ZLON0)-ZBETA)*ZRDSDG - ZXP = ZXBM0-ZRO0*sin(ZGA0) - ZYP = ZYBM0+ZRO0*cos(ZGA0) - do ji=0,IMAX-1 - do jj=0,JMAX-1 - ZATA = atan2( -(ZXP-XHAT(ji)) , (ZYP-YHAT(jj)) )/ZRDSDG - zlon = (ZBETA+ZATA)/ZRPK+ZLON0 - plon(jj,ji)=zlon - ZRO2 = (XHAT(ji)-ZXP)^2+(YHAT(jj)-ZYP)^2 - ZJD1 = XRADIUS*(abs(ZCLAT0))^(1.-ZRPK) - ZT1 = (ZJD1)^(2./ZRPK)* (1+ZSLAT0)^2 - ZJD3 = (ZRPK^2*ZRO2) - ZT2 = ZJD3 - ZT2 = ZT2^(1./ZRPK) - ZJD1 = (ZT1-ZT2)/(ZT1+ZT2) - ZJD1 = acos(ZJD1) - ZJD3 = ZJD1 - zlat = (XPI/2.-ZJD3)/ZRDSDG - plat(jj,ji)=zlat - end do - end do - - end if - -; Defining the corners of the domain -;==================================== - if (icorner(0,0).eq.icorner(1,1)) then - icorner(0,0)=0 - icorner(1,0)=JMAX-1 - icorner(0,1)=0 - icorner(1,1)=IMAX-1 - end if -; print ("icorner"+icorner) - - res@mpLimitMode = "Corners" - res@mpLeftCornerLatF = plat(icorner(0,0),icorner(0,1)) - res@mpLeftCornerLonF = plon(icorner(0,0),icorner(0,1)) - res@mpRightCornerLatF = plat(icorner(1,0),icorner(1,1)) - res@mpRightCornerLonF = plon(icorner(1,0),icorner(1,1)) - -; print ("Corner (0,0); Lat="+res@mpLeftCornerLatF+ \ -; ", Lon="+res@mpLeftCornerLonF) -; print ("Oppos corner; Lat="+res@mpRightCornerLatF+ \ -; ", Lon= "+res@mpRightCornerLonF) - -;========================================== -; Turn on lat / lon labeling -;========================================== - res@pmTickMarkDisplayMode = "Always" ; turn on tickmarks - res@mpOutlineBoundarySets = "AllBoundaries" ; state boundaries - res@mpPerimDrawOrder = "PostDraw" ; force map perim -;========================================== -; Needed for regional native projection -;========================================== - res@tfDoNDCOverlay = True - res@gsnAddCyclic = False ; regional data - -end - -;=========================================== -;------------------------------------------------------------------------ -undef("MESONH_pinter") -function MESONH_pinter( pfield:numeric, loc_param:numeric, ppabs:numeric ) -;************************************************************************* -; S. BIELLI -; This is a routine that interpolate fields on pressure level for plotting -; based on pinter.f90 -; The field to be interpolated must be given at the mass point (grid 1) -; usage : var_inter=MESONHfunction(var_to_interpol, 850., AbsPressure) -; Abs pressure must be in Pa -; - -begin - - dimL= dimsizes(loc_param) - -; First test for grid = 0 - - dimp=dimsizes(ppabs) - - pout=pfield(0:dimL-1,:,:) - pfield@_FillValue=999 - pout@_FillValue=999 - pout=pout@_FillValue - - do jkp = 0, dimL-1 - zref=log10(loc_param(jkp)*100.) - do jloop = 0, dimp(1)-1 - do iloop = 0, dimp(2)-1 - kloop=0 - flag=True - do while (flag .and. (kloop.lt.(dimp(2)-2))) - if (.not.ismissing(ppabs(kloop,jloop,iloop))) then - zxm=log10(ppabs(kloop,jloop,iloop)) - zxp=log10(ppabs(kloop+1,jloop,iloop)) - if ((zxp-zref)*(zref-zxm) .ge. 0) then - pout(jkp,jloop,iloop)= (pfield(kloop,jloop,iloop)*(zxp-zref)+ \ - pfield(kloop+1,jloop,iloop)*(zref-zxm))/ (zxp-zxm) - flag=False - end if - end if - kloop=kloop+1 - end do - end do - end do - end do - - return(pout) - -end - -;-------------------------------------------------------------------------------- -undef("mnh_map") -function mnh_map(wks[1]:graphic,in_file[1]:file,opt_args[1]:logical) - -begin -; -; This function creates a map plot, and bases the projection on -; the MAP_PROJ attribute in the given file. -; -; 1. Make a copy of the resource list, and set some resources -; common to all map projections. -; -; 2. Determine the projection being used, and set resources based -; on that projection. -; -; 3. Create the map plot, and draw and advance the frame -; (if requested). - - opts = opt_args ; Make a copy of the resource list - opts = True - -; Set some resources depending on what kind of map projection is -; chosen. -; -; ZRPK != 0 : "Stereographic" -; ZRPK = 0 : "Mercator" -;=================================================; -; src/mesonh_MOD/mode_gridproj.f90 -;=================================================; - XRADIUS=6371229.0d ; Earth radius (meters) - XPI=2.0d*asin(1.) ; Pi - ZRDSDG= XPI/180.0d ; Radian to Degree conversion factor - ZXBM0 = 0.0d - ZYBM0 = 0.0d - - if(isfilevar(in_file,"RPK")) - ZRPK=in_file->RPK - ZLON0=in_file->LON0 - ZLAT0=in_file->LAT0 - ZLATOR=in_file->LATOR - ZLONOR=in_file->LONOR - ZBETA=in_file->BETA - else - print ("mnh_map: Error no RPK variable in input file") - return(new(1,graphic)) - end if - -; Case netcdf from lfi2cdf - if(isfilevar(in_file,"IMAX")) - XHAT=in_file->XHAT - YHAT=in_file->YHAT - IMAX= dimsizes(XHAT)-2 - JMAX= dimsizes(YHAT)-2 - zdx=XHAT(2)-XHAT(1) - zdy=YHAT(2)-YHAT(1) - do ji=0,IMAX-1 - XHAT(ji)=XHAT(ji)+zdx*1.5 - end do - do jj=0,JMAX-1 - YHAT(jj)=YHAT(jj)+zdy*1.5 - end do - else -; Case netcdf from extractdia - XHAT=in_file->W_E_direction - YHAT=in_file->S_N_direction - IMAX= dimsizes(XHAT) - JMAX= dimsizes(YHAT) - end if -; - - lat = new((/JMAX,IMAX/),"double") - lon = new((/JMAX,IMAX/),"double") - - -; Stereographic projection - if(ZRPK .gt. 0) - projection = "Stereographic" - opts@mpCenterLatF = get_res_value_keep(opts, "mpCenterLatF", 90) - opts@mpCenterLonF = get_res_value_keep(opts, "mpCenterLonF",ZLON0) - opts@mpCenterRotF = get_res_value_keep(opts, "mpCenterRotF",ZBETA) - end if - - if(ZRPK .lt. 0) - projection = "Stereographic" - opts@mpCenterLatF = get_res_value_keep(opts, "mpCenterLatF", -90) - opts@mpCenterLonF = get_res_value_keep(opts, "mpCenterLonF",ZLON0) - opts@mpCenterRotF = get_res_value_keep(opts, "mpCenterRotF",ZBETA) - end if - -; Mercator projection - if(ZRPK .eq. 0) - projection = "Mercator" - end if - - opts@mpNestTime = get_res_value_keep(opts, "mpNestTime",0) - - -; LAT and LON are not saved in the file - if (ZRPK.eq.0) then - XBETA=0. - XLAT0=0. ; map reference latitude (degrees) - ZXBM0 = 0. - ZYBM0 = 0. - ZCGAM = cos(-ZRDSDG*XBETA) - ZSGAM = sin(-ZRDSDG*XBETA) - ZRACLAT0 = XRADIUS*cos(ZRDSDG*ZLAT0) - do ji=0,IMAX-1 - jj=0 - ZXMI0 = XHAT(ji)-ZXBM0 - ZYMI0 = YHAT(jj)-ZYBM0 - zlon = (ZXMI0*ZCGAM+ZYMI0*ZSGAM)/(ZRACLAT0*ZRDSDG)+ZLONOR - do jj=0,JMAX-1 - lon(jj,ji)=zlon - end do - end do - do jj=0,JMAX-1 - ji=0 - ZXMI0 = XHAT(ji)-ZXBM0 - ZYMI0 = YHAT(jj)-ZYBM0 - ZT1 = log(tan(XPI/4.+ZLATOR*ZRDSDG/2.)) - ZT2 = (-ZXMI0*ZSGAM+ZYMI0*ZCGAM)/ZRACLAT0 - zlat = (-XPI/2.+2.*atan(exp(ZT1+ZT2)))/ZRDSDG - do ji=0,IMAX-1 - lat(jj,ji)=zlat - end do - end do - else - ZCLAT0 = cos(ZRDSDG*ZLAT0) - ZSLAT0 = sin(ZRDSDG*ZLAT0) - ZCLATOR = cos(ZRDSDG*ZLATOR) - ZSLATOR = sin(ZRDSDG*ZLATOR) - ZRO0 = (XRADIUS/ZRPK)*(abs(ZCLAT0))^(1.-ZRPK) * \ - ((1.+ZSLAT0)*abs(ZCLATOR)/(1.+ZSLATOR))^ZRPK - ZGA0 = (ZRPK*(ZLONOR-ZLON0)-ZBETA)*ZRDSDG - ZXP = ZXBM0-ZRO0*sin(ZGA0) - ZYP = ZYBM0+ZRO0*cos(ZGA0) - do ji=0,IMAX-1 - do jj=0,JMAX-1 - ZATA = atan2( -(ZXP-XHAT(ji)) , (ZYP-YHAT(jj)) )/ZRDSDG - zlon = (ZBETA+ZATA)/ZRPK+ZLON0 - lon(jj,ji)=zlon - ZRO2 = (XHAT(ji)-ZXP)^2+(YHAT(jj)-ZYP)^2 - ZJD1 = XRADIUS*(abs(ZCLAT0))^(1.-ZRPK) - ZT1 = (ZJD1)^(2./ZRPK)* (1+ZSLAT0)^2 - ZJD3 = (ZRPK^2*ZRO2) - ZT2 = ZJD3 - ZT2 = ZT2^(1./ZRPK) - ZJD1 = (ZT1-ZT2)/(ZT1+ZT2) - ZJD1 = acos(ZJD1) - ZJD3 = ZJD1 - zlat = (XPI/2.-ZJD3)/ZRDSDG - lat(jj,ji)=zlat - end do - end do - end if - - dims = dimsizes(lat) - - do ii = 0, dims(0)-1 - do jj = 0, dims(1)-1 - if ( lon(ii,jj) .lt. 0.0) then - lon(ii,jj) = lon(ii,jj) + 360. - end if - end do - end do - - opts@start_lat = lat(0,0) - opts@start_lon = lon(0,0) - opts@end_lat = lat(dims(0)-1,dims(1)-1) - opts@end_lon = lon(dims(0)-1,dims(1)-1) - - -; Set some resources common to all map projections. - opts = set_mp_resources(opts) - - if ( isatt(opts,"ZoomIn") .and. opts@ZoomIn ) then - y1 = 0 - x1 = 0 - y2 = dims(0)-1 - x2 = dims(1)-1 - if ( isatt(opts,"Ystart") ) then - y1 = opts@Ystart - delete(opts@Ystart) - end if - if ( isatt(opts,"Xstart") ) then - x1 = opts@Xstart - delete(opts@Xstart) - end if - if ( isatt(opts,"Yend") ) then - if ( opts@Yend .le. y2 ) then - y2 = opts@Yend - end if - delete(opts@Yend) - end if - if ( isatt(opts,"Xend") ) then - if ( opts@Xend .le. x2 ) then - x2 = opts@Xend - end if - delete(opts@Xend) - end if - - opts@mpLeftCornerLatF = lat(y1,x1) - opts@mpLeftCornerLonF = lon(y1,x1) - opts@mpRightCornerLatF = lat(y2,x2) - opts@mpRightCornerLonF = lon(y2,x2) - - if ( opts@mpRightCornerLonF .lt. 0.0 ) then - opts@mpRightCornerLonF = opts@mpRightCornerLonF + 360.0 - end if - - delete(opts@ZoomIn) - end if - - -; The default is not to draw the plot or advance the frame, and -; to maximize the plot in the frame. - - opts@gsnDraw = get_res_value_keep(opts,"gsnDraw", False) - opts@gsnFrame = get_res_value_keep(opts,"gsnFrame", False) - opts@gsnMaximize = get_res_value_keep(opts,"gsnMaximize", True) - - delete_attrs(opts) ; Clean up. - mp = gsn_map(wks,projection,opts) ; Create map plot. - - return(mp) ; Return. - -end - -;-------------------------------------------------------------------------------- - -undef("mnh_map_overlays") -function mnh_map_overlays(in_file[1]:file, \ - wks:graphic, \ - plots[*]:graphic, \ - opt_arg[1]:logical, \ - opt_mp[1]:logical) - -; Based on wrf_map_overlays -; -; This procedure takes an array of plots and overlays them on a -; base plot - map background. -; -; It will advance the plot and cleanup, unless you set the -; PanelPlot resource to True. -; -; Attributes recognized by this procedure: -; FramePlot -; PanelPlot -; NoTitles (don't do any titles) -; CommonTitle & PlotTile is used to overwrite field titles -; CommonTitle will super-seed NoTitles -; -; If FramePlot False, then Draw the plot but do not Frame. -; In this case a user want to add to the drawing, and will -; have to advance the Frame manually in the script. -; -; If the "NoTitles" attribute exists and is set True, then -; don't create the top-left titles, and leave the main titles alone. -; This resource can be useful if you are planning to panel -; the plots. -; -; If PanelPlot is set to True, then this flags to wrf_map_overlays -; that these plots are going to be eventually paneled (likely -; by gsn_panel), and hence 1) draw and frame should not be called -; (unless gsnDraw and/or gsnFrame are explicitly set to True), -; and 2) the overlays and titles should not be removed with -; NhlRemoveOverlay and NhlRemoveAnnotation. -; -begin - - opts = opt_arg ; Make a copy of the resource lists - opt_mp_2 = opt_mp - - ; Let's make the map first - base = mnh_map(wks,in_file,opt_mp_2) - - no_titles = get_res_value(opts,"NoTitles",False) ; Do we want field titles? - com_title = get_res_value(opts,"CommonTitle",False) ; Do we have a common title? - if ( com_title ) then - plot_title = get_res_value(opts,"PlotTitle"," ") - no_titles = True - end if - - call_draw = True - call_frame = get_res_value(opts,"FramePlot",True) ; Do we want to frame the plot? - panel_plot = get_res_value(opts,"PanelPlot",False) ; Are we paneling? - opts@gsnMaximize = get_res_value_keep(opts,"gsnMaximize", True) - - nplots = dimsizes(plots) -; font_color = "Black" - - do i=0,nplots-1 - if(.not.ismissing(plots(i))) then -; class_name = NhlClassName(plots(i)) -; print(class_name) -; if(class_name.eq."contourPlotClass") then -; getvalues plots(i) -; "cnFillOn" : fill_on -; "cnLineColor" : line_color -; end getvalues -; if (.not.fill_on) then -; font_color = line_color -; end if -; end if - if(.not.no_titles) then - getvalues plots(i) - "tiMainString" : SubTitle - end getvalues - if(i.eq.0) then - SubTitles = SubTitle - else - SubTitles = SubTitles + "~C~" + SubTitle - end if - end if - if(com_title .and. i .eq. nplots-1) then - getvalues plots(i) - "tiMainString" : SubTitle - end getvalues - SubTitles = plot_title - end if - setvalues plots(i) - "tfDoNDCOverlay" : True - "tiMainOn" : False - end setvalues - overlay(base,plots(i)) - else - print("mnh_map_overlays: Warning: overlay plot #" + i + " is not valid.") - end if - end do - - if(.not.no_titles .or. com_title) then - font_height = get_res_value_keep(opts,"FontHeightF",0.01) - txt = create "map_titles" textItemClass wks - "txString" : SubTitles - "txFontHeightF" : font_height - ;"txFontColor" : font_color - end create - anno = NhlAddAnnotation(base,txt) - setvalues anno - "amZone" : 3 - "amJust" : "BottomLeft" - "amSide" : "Top" - "amParallelPosF" : 0.005 - "amOrthogonalPosF" : 0.03 - "amResizeNotify" : False - end setvalues - base@map_titles = anno - end if -; -; gsnDraw and gsnFrame default to False if panel plot. -; - if(panel_plot) then - call_draw = False - call_frame= False - end if - - - opts@gsnDraw = get_res_value_keep(opts,"gsnDraw", call_draw) - opts@gsnFrame = get_res_value_keep(opts,"gsnFrame", call_frame) - - draw_and_frame(wks,base,opts@gsnDraw,opts@gsnFrame,False, \ - opts@gsnMaximize) - - if(.not.panel_plot) then - do i=0,nplots-1 - if(.not.ismissing(plots(i))) then - NhlRemoveOverlay(base,plots(i),False) - else - print("wrf_remove_map_overlays: Warning: overlay plot #" + i + " is not valid.") - print(" Nothing to remove.") - end if - end do - end if - - if(.not.no_titles.and..not.panel_plot) then - if(isatt(base,"map_titles")) then - NhlRemoveAnnotation(base,base@map_titles) - delete(base@map_titles) - end if - end if - -return(base) -end - -;-------------------------------------------------------------------------------- -undef("wrf_user_intrp3d") -function wrf_user_intrp3d( var3d:numeric, z_in:numeric, \ - plot_type:string, \ - loc_param:numeric, angle:numeric, opts:logical ) - -; var3d - 3d field to interpolate (all input fields must be unstaggered) -; z_in - interpolate to this field (either p/z) -; plot_type - interpolate horizontally "h", or vertically "v" -; loc_param - level(s) for horizontal plots (eg. 500hPa ; 3000m - scalar), -; plane for vertical plots (2 values representing an xy point -; on the model domain through which the vertical plane will pass -; OR 4 values specifying start and end values -; angle - 0.0 for horizontal plots, and -; an angle for vertical plots - 90 represent a WE cross section -; opts Used IF opts is TRUE, else use loc_param and angle to determine crosssection - -begin - - - if(plot_type .eq. "h" ) then ; horizontal cross section needed - - dimL = dimsizes(loc_param) - - dims = dimsizes(var3d) - nd = dimsizes(dims) - - dimX = dims(nd-1) - dimY = dims(nd-2) - dimZ = dims(nd-3) - dim4 = 1 - dim5 = 1 - if ( nd .eq. 4 ) then - dim4 = dims(nd-4) - end if - if ( nd .eq. 5 ) then - dim4 = dims(nd-4) - dim5 = dims(nd-5) - end if - - var3 = new ( (/ dim5, dim4, dimZ, dimY, dimX /) , typeof(var3d) ) - z = new ( (/ dim5, dim4, dimZ, dimY, dimX /) , typeof(var3d) ) - var2d = new ( (/ dim5, dim4, dimL, dimY, dimX /) , typeof(var3d) ) - - if ( nd .eq. 5 ) then - var3 = var3d - z = z_in - end if - if ( nd .eq. 4 ) then - var3(0,:,:,:,:) = var3d(:,:,:,:) - z(0,:,:,:,:) = z_in(:,:,:,:) - end if - if ( nd .eq. 3 ) then - var3(0,0,:,:,:) = var3d(:,:,:) - z(0,0,:,:,:) = z_in(:,:,:) - end if - - - if ( z(0,0,0,0,0) .gt. 500.) then - ; We must be interpolating to pressure - ; This routine needs input field and level in hPa - lets make sure of this - if ( z(0,0,0,0,0) .gt. 2000. ) then - ; looks like we have Pa as input - make this hPa - z = z * 0.01 - end if - if ( loc_param(0) .gt. 2000. ) then - ; looks like the input was specified in Pa - change this - loc_param = loc_param * 0.01 - end if - end if - - do il = 0,dimL-1 - var = wrf_interp_3d_z(var3,z,loc_param(il)) - var2d(:,:,il,:,:) = var(:,:,:,:) - end do - - copy_VarAtts(var3d,var3) - if(isatt(var3,"description")) then - delete_VarAtts(var3,(/"description"/)) - end if - if(isatt(var3,"units")) then - delete_VarAtts(var3,(/"units"/)) - end if - if(isatt(var3,"MemoryOrder")) then - delete_VarAtts(var3,(/"MemoryOrder"/)) - end if - if(isatt(var3,"_FillValue")) then - delete_VarAtts(var3,(/"_FillValue"/)) - end if - copy_VarAtts(var3,var2d) - - nn = nd-2 - var2d!nn = "plevs" - - if ( dimL .gt. 1 ) then - if ( nd .eq. 5 ) then - return( var2d ) - end if - if ( nd .eq. 4 ) then - return( var2d(0,:,:,:,:) ) - end if - if ( nd .eq. 3 ) then - return( var2d(0,0,:,:,:) ) - end if - else - if ( z(0,0,0,0,0) .gt. 500.) then - var2d@PlotLevelID = loc_param + " hPa" - else - var2d@PlotLevelID = .001*loc_param + " km" - end if - if ( nd .eq. 5 ) then - return( var2d(:,:,0,:,:) ) - end if - if ( nd .eq. 4 ) then - return( var2d(0,:,0,:,:) ) - end if - if ( nd .eq. 3 ) then - return( var2d(0,0,0,:,:) ) - end if - end if - - - end if - - - - - if(plot_type .eq. "v" ) then ; vertical cross section needed - - dims = dimsizes(var3d) - if ( dimsizes(dims) .eq. 4 ) then - if ( z_in(0,0,0,0) .gt. 500.) then - ; We must be interpolating to pressure - ; This routine needs input field and level in hPa - lets make sure of this - if ( z_in(0,0,0,0) .gt. 2000. ) then - ; looks like we have Pa as input - make this hPa - z_in = z_in * 0.01 - end if - end if - z = z_in(0,:,:,:) - else - if ( z_in(0,0,0) .gt. 500.) then - ; We must be interpolating to pressure - ; This routine needs input field and level in hPa - lets make sure of this - if ( z_in(0,0,0) .gt. 2000. ) then - ; looks like we have Pa as input - make this hPa - z_in = z_in * 0.01 - end if - end if - z = z_in - end if - -; set vertical cross section - if (opts) then - xy = wrf_user_set_xy( z, loc_param(0)-1, loc_param(1)-1, \ ; the -1 is for NCL dimensions - loc_param(2)-1, loc_param(3)-1, \ - angle, opts ) - else - xy = wrf_user_set_xy( z, loc_param(0), loc_param(1), \ - 0.0, 0.0, angle, opts ) - end if - xp = dimsizes(xy) - - -; first we interp z - var2dz = wrf_interp_2d_xy( z, xy) - -; interp to constant z grid - if(var2dz(0,0) .gt. var2dz(1,0) ) then ; monotonically decreasing coordinate - z_max = floor(max(z)/10)*10 ; bottom value - z_min = ceil(min(z)/10)*10 ; top value - dz = 1. - nlevels = tointeger( (z_max-z_min)/dz) - z_var2d = new( (/nlevels/), typeof(z)) - z_var2d(0) = z_max - dz = -dz - else - z_max = max(z) - z_min = 0. -;; MODI SOLINE -; dz = 0.01 * z_max - dz = 0.001 * z_max - nlevels = tointeger( z_max/dz ) - z_var2d = new( (/nlevels/), typeof(z)) - z_var2d(0) = z_min - end if -; print("nlevels="+nlevels) -; print("dz="+dz) - - do i=1, nlevels-1 - z_var2d(i) = z_var2d(0)+i*dz - end do - - -; interp the variable - if ( dimsizes(dims) .eq. 4 ) then - var2d = new( (/dims(0), nlevels, xp(0)/), typeof(var2dz)) - do it = 0,dims(0)-1 - var2dtmp = wrf_interp_2d_xy( var3d(it,:,:,:), xy) - do i=0,xp(0)-1 - var2d(it,:,i) = wrf_interp_1d( var2dtmp(:,i), var2dz(:,i), z_var2d) - end do - end do - var2d!0 = var3d!0 - var2d!1 = "Vertical" - var2d!2 = "Horizontal" - else - var2d = new( (/nlevels, xp(0)/), typeof(var2dz)) - var2dtmp = wrf_interp_2d_xy( var3d, xy) - do i=0,xp(0)-1 - var2d(:,i) = wrf_interp_1d( var2dtmp(:,i), var2dz(:,i), z_var2d) - end do - var2d!0 = "Vertical" - var2d!1 = "Horizontal" - end if - - - st_x = tointeger(xy(0,0)) + 1 - st_y = tointeger(xy(0,1)) + 1 - ed_x = tointeger(xy(xp(0)-1,0)) + 1 - ed_y = tointeger(xy(xp(0)-1,1)) + 1 - if (opts) then - var2d@Orientation = "Cross-Sesion: (" + \ - st_x + "," + st_y + ") to (" + \ - ed_x + "," + ed_y + ")" - else - var2d@Orientation = "Cross-Sesion: (" + \ - st_x + "," + st_y + ") to (" + \ - ed_x + "," + ed_y + ") ; center=(" + \ - loc_param(0) + "," + loc_param(1) + \ - ") ; angle=" + angle - end if - - return(var2d) -end if - - -end - +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/wrf/WRFUserARW.ncl" + +;------------------------------------------------------------- +;contains: +; procedure MESONH_map_c +;function mnh_map(wks[1]:graphic,in_file[1]:file,opt_args[1]:logical) +;function mnh_map_overlays(in_file[1]:file,wks:graphic,plots[*]:graphic, \ +; opt_arg[1]:logical,opt_mp[1]:logical) +;function MESONH_pinter( pfield:numeric, loc_param:numeric, ppabs:numeric ) +;------------------------------------------------------------- + +;============================================================== +; J.-P. CHABOUREAU +; This is a driver that selects the appropriate +; mapping function based upon the file variables RPK, BETA, LATOR, LONOR +; +; +; Sample usage: +; a = addfile("...", r") +; IMAX = a->IMAX +; JMAX = a->JMAX +; lat2d = new((/JMAX,IMAX/),"double") +; lat2d(:,:)=0. +; lon2d = new((/JMAX,IMAX/),"double") +; lon2d(:,:)=0. +; icorners = new((/2,2/),"integer") +; icorners(:,:)=0 +; res = True +; MESONH_map_c (a, res, lat2d, lon2d, icorners) +; +; +undef("MESONH_map_c") +;============================================================== +procedure MESONH_map_c (in_file:file, res:logical, plat, plon, icorner) +;============================================================== +;local rank, dimll, nlat, mlon, lat, lon +local rank, dimll, nlat, mlon +begin + +; Check if the variable RPK is in the file +; ---------------------------------------- +if(isfilevar(in_file,"RPK")) then + +; Read projection parameters +; ------------------------- + ZRPK = in_file->RPK + ZLATOR = in_file->LATOR + ZLONOR = in_file->LONOR + ZBETA = in_file->BETA + ZLAT0 = in_file->LAT0 + ZLON0 = in_file->LON0 + +; Case netcdf from lfi2cdf +; ------------------------- + + if(isfilevar(in_file,"IMAX")) + XHAT=in_file->XHAT + YHAT=in_file->YHAT + jphext = in_file->JPHEXT + IMAX= dimsizes(XHAT)-2*JPHEXT + JMAX= dimsizes(YHAT)-2*JPHEXT + zdx=XHAT(2)-XHAT(1) + zdy=YHAT(2)-YHAT(1) + +; unstagger + do ji=0,IMAX-1 + XHAT(ji)=XHAT(ji)+zdx*1.5 + end do + do jj=0,JMAX-1 + YHAT(jj)=YHAT(jj)+zdy*1.5 + end do + + else + +; Case netcdf from extractdia +; --------------------------- + XHAT=in_file->W_E_direction + YHAT=in_file->S_N_direction + IMAX= dimsizes(XHAT) + JMAX= dimsizes(YHAT) + zdx=XHAT(2)-XHAT(1) + zdy=YHAT(2)-YHAT(1) + + end if + + print ("LATOR="+ZLATOR+" - LONOR="+ZLONOR) + print ("ZLAT0="+ZLAT0+" - ZLON0="+ZLON0) + print ("ZDX="+zdx+" - RPK="+ZRPK+" - BETA="+ZBETA) + print ("IMAX="+IMAX+" - JMAX="+JMAX) + + if (ZRPK.gt.0) + ; Stereographic projection +; --------------------------- + res@mpProjection = "Stereographic" + res@mpCenterLonF = ZLON0 + res@mpCenterRotF = ZBETA + res@mpCenterLatF = 90. + end if + + if (ZRPK.lt.0) + ; Stereographic projection +; --------------------------- + res@mpProjection = "Stereographic" + res@mpCenterLonF = ZLON0 + res@mpCenterRotF = ZBETA + res@mpCenterLatF = -90. + end if + + if (ZRPK.eq.0) then + ; Mercator projection +; --------------------------- + res@mpProjection = "Mercator" + end if + + print("Map projection="+res@mpProjection) + +else + print ("MESONH_map_c: Error no RPK variable in input file") +end if + +;=================================================; +; calculate 2D lat and lon +; based on src/mesonh_MOD/mode_gridproj.f90 +;=================================================; + +; Constants +; ----------- + if(isfilevar(in_file,"IMAX")) + XRADIUS=6371229.0d ; Earth radius (meters) + else + XRADIUS=6371.2290d ; Earth radius (km) + end if + XPI=2.0d*asin(1.) ; Pi + ZRDSDG= XPI/180.0d ; Radian to Degree conversion factor + ZXBM0 = 0.0d + ZYBM0 = 0.0d + +;=================================================; + if (ZRPK.eq.0) then +; MERCATOR +;=================================================; + XBETA=0. + XLAT0=0. ; map reference latitude (degrees) + ZXBM0 = 0. + ZYBM0 = 0. + ZCGAM = cos(-ZRDSDG*XBETA) + ZSGAM = sin(-ZRDSDG*XBETA) + ZRACLAT0 = XRADIUS*cos(ZRDSDG*ZLAT0) + do ji=0,IMAX-1 + jj=0 + ZXMI0 = XHAT(ji)-ZXBM0 + ZYMI0 = YHAT(jj)-ZYBM0 + zlon = (ZXMI0*ZCGAM+ZYMI0*ZSGAM)/(ZRACLAT0*ZRDSDG)+ZLONOR + do jj=0,JMAX-1 + plon(jj,ji)=zlon + end do + end do + do jj=0,JMAX-1 + ji=0 + ZXMI0 = XHAT(ji)-ZXBM0 + ZYMI0 = YHAT(jj)-ZYBM0 + ZT1 = log(tan(XPI/4.+ZLATOR*ZRDSDG/2.)) + ZT2 = (-ZXMI0*ZSGAM+ZYMI0*ZCGAM)/ZRACLAT0 + zlat = (-XPI/2.+2.*atan(exp(ZT1+ZT2)))/ZRDSDG + do ji=0,IMAX-1 + plat(jj,ji)=zlat + end do + end do + +;=================================================; + else +; STEREOGRAPHIC PROJECTION +;=================================================; + ZCLAT0 = cos(ZRDSDG*ZLAT0) + ZSLAT0 = sin(ZRDSDG*ZLAT0) + ZCLATOR = cos(ZRDSDG*ZLATOR) + ZSLATOR = sin(ZRDSDG*ZLATOR) + ZRO0 = (XRADIUS/ZRPK)*(abs(ZCLAT0))^(1.-ZRPK) * \ + ((1.+ZSLAT0)*abs(ZCLATOR)/(1.+ZSLATOR))^ZRPK + ZGA0 = (ZRPK*(ZLONOR-ZLON0)-ZBETA)*ZRDSDG + ZXP = ZXBM0-ZRO0*sin(ZGA0) + ZYP = ZYBM0+ZRO0*cos(ZGA0) + do ji=0,IMAX-1 + do jj=0,JMAX-1 + ZATA = atan2( -(ZXP-XHAT(ji)) , (ZYP-YHAT(jj)) )/ZRDSDG + zlon = (ZBETA+ZATA)/ZRPK+ZLON0 + plon(jj,ji)=zlon + ZRO2 = (XHAT(ji)-ZXP)^2+(YHAT(jj)-ZYP)^2 + ZJD1 = XRADIUS*(abs(ZCLAT0))^(1.-ZRPK) + ZT1 = (ZJD1)^(2./ZRPK)* (1+ZSLAT0)^2 + ZJD3 = (ZRPK^2*ZRO2) + ZT2 = ZJD3 + ZT2 = ZT2^(1./ZRPK) + ZJD1 = (ZT1-ZT2)/(ZT1+ZT2) + ZJD1 = acos(ZJD1) + ZJD3 = ZJD1 + zlat = (XPI/2.-ZJD3)/ZRDSDG + plat(jj,ji)=zlat + end do + end do + + end if + +; Defining the corners of the domain +;==================================== + if (icorner(0,0).eq.icorner(1,1)) then + icorner(0,0)=0 + icorner(1,0)=JMAX-1 + icorner(0,1)=0 + icorner(1,1)=IMAX-1 + end if +; print ("icorner"+icorner) + + res@mpLimitMode = "Corners" + res@mpLeftCornerLatF = plat(icorner(0,0),icorner(0,1)) + res@mpLeftCornerLonF = plon(icorner(0,0),icorner(0,1)) + res@mpRightCornerLatF = plat(icorner(1,0),icorner(1,1)) + res@mpRightCornerLonF = plon(icorner(1,0),icorner(1,1)) + +; print ("Corner (0,0); Lat="+res@mpLeftCornerLatF+ \ +; ", Lon="+res@mpLeftCornerLonF) +; print ("Oppos corner; Lat="+res@mpRightCornerLatF+ \ +; ", Lon= "+res@mpRightCornerLonF) + +;========================================== +; Turn on lat / lon labeling +;========================================== + res@pmTickMarkDisplayMode = "Always" ; turn on tickmarks + res@mpOutlineBoundarySets = "AllBoundaries" ; state boundaries + res@mpPerimDrawOrder = "PostDraw" ; force map perim +;========================================== +; Needed for regional native projection +;========================================== + res@tfDoNDCOverlay = True + res@gsnAddCyclic = False ; regional data + +end + +;=========================================== +;------------------------------------------------------------------------ +undef("MESONH_pinter") +function MESONH_pinter( pfield:numeric, loc_param:numeric, ppabs:numeric ) +;************************************************************************* +; S. BIELLI +; This is a routine that interpolate fields on pressure level for plotting +; based on pinter.f90 +; The field to be interpolated must be given at the mass point (grid 1) +; usage : var_inter=MESONHfunction(var_to_interpol, 850., AbsPressure) +; Abs pressure must be in Pa +; + +begin + + dimL= dimsizes(loc_param) + +; First test for grid = 0 + + dimp=dimsizes(ppabs) + + pout=pfield(0:dimL-1,:,:) + pfield@_FillValue=999 + pout@_FillValue=999 + pout=pout@_FillValue + + do jkp = 0, dimL-1 + zref=log10(loc_param(jkp)*100.) + do jloop = 0, dimp(1)-1 + do iloop = 0, dimp(2)-1 + kloop=0 + flag=True + do while (flag .and. (kloop.lt.(dimp(2)-2))) + if (.not.ismissing(ppabs(kloop,jloop,iloop))) then + zxm=log10(ppabs(kloop,jloop,iloop)) + zxp=log10(ppabs(kloop+1,jloop,iloop)) + if ((zxp-zref)*(zref-zxm) .ge. 0) then + pout(jkp,jloop,iloop)= (pfield(kloop,jloop,iloop)*(zxp-zref)+ \ + pfield(kloop+1,jloop,iloop)*(zref-zxm))/ (zxp-zxm) + flag=False + end if + end if + kloop=kloop+1 + end do + end do + end do + end do + + return(pout) + +end + +;-------------------------------------------------------------------------------- +undef("mnh_map") +function mnh_map(wks[1]:graphic,in_file[1]:file,opt_args[1]:logical) + +begin +; +; This function creates a map plot, and bases the projection on +; the MAP_PROJ attribute in the given file. +; +; 1. Make a copy of the resource list, and set some resources +; common to all map projections. +; +; 2. Determine the projection being used, and set resources based +; on that projection. +; +; 3. Create the map plot, and draw and advance the frame +; (if requested). + + opts = opt_args ; Make a copy of the resource list + opts = True + +; Set some resources depending on what kind of map projection is +; chosen. +; +; ZRPK != 0 : "Stereographic" +; ZRPK = 0 : "Mercator" +;=================================================; +; src/mesonh_MOD/mode_gridproj.f90 +;=================================================; + XRADIUS=6371229.0d ; Earth radius (meters) + XPI=2.0d*asin(1.) ; Pi + ZRDSDG= XPI/180.0d ; Radian to Degree conversion factor + ZXBM0 = 0.0d + ZYBM0 = 0.0d + + if(isfilevar(in_file,"RPK")) + ZRPK=in_file->RPK + ZLON0=in_file->LON0 + ZLAT0=in_file->LAT0 + ZLATOR=in_file->LATOR + ZLONOR=in_file->LONOR + ZBETA=in_file->BETA + else + print ("mnh_map: Error no RPK variable in input file") + return(new(1,graphic)) + end if + +; Case netcdf from lfi2cdf + if(isfilevar(in_file,"IMAX")) + XHAT=in_file->XHAT + YHAT=in_file->YHAT + IMAX= dimsizes(XHAT)-2 + JMAX= dimsizes(YHAT)-2 + zdx=XHAT(2)-XHAT(1) + zdy=YHAT(2)-YHAT(1) + do ji=0,IMAX-1 + XHAT(ji)=XHAT(ji)+zdx*1.5 + end do + do jj=0,JMAX-1 + YHAT(jj)=YHAT(jj)+zdy*1.5 + end do + else +; Case netcdf from extractdia + XHAT=in_file->W_E_direction + YHAT=in_file->S_N_direction + IMAX= dimsizes(XHAT) + JMAX= dimsizes(YHAT) + end if +; + + lat = new((/JMAX,IMAX/),"double") + lon = new((/JMAX,IMAX/),"double") + + +; Stereographic projection + if(ZRPK .gt. 0) + projection = "Stereographic" + opts@mpCenterLatF = get_res_value_keep(opts, "mpCenterLatF", 90) + opts@mpCenterLonF = get_res_value_keep(opts, "mpCenterLonF",ZLON0) + opts@mpCenterRotF = get_res_value_keep(opts, "mpCenterRotF",ZBETA) + end if + + if(ZRPK .lt. 0) + projection = "Stereographic" + opts@mpCenterLatF = get_res_value_keep(opts, "mpCenterLatF", -90) + opts@mpCenterLonF = get_res_value_keep(opts, "mpCenterLonF",ZLON0) + opts@mpCenterRotF = get_res_value_keep(opts, "mpCenterRotF",ZBETA) + end if + +; Mercator projection + if(ZRPK .eq. 0) + projection = "Mercator" + end if + + opts@mpNestTime = get_res_value_keep(opts, "mpNestTime",0) + + +; LAT and LON are not saved in the file + if (ZRPK.eq.0) then + XBETA=0. + XLAT0=0. ; map reference latitude (degrees) + ZXBM0 = 0. + ZYBM0 = 0. + ZCGAM = cos(-ZRDSDG*XBETA) + ZSGAM = sin(-ZRDSDG*XBETA) + ZRACLAT0 = XRADIUS*cos(ZRDSDG*ZLAT0) + do ji=0,IMAX-1 + jj=0 + ZXMI0 = XHAT(ji)-ZXBM0 + ZYMI0 = YHAT(jj)-ZYBM0 + zlon = (ZXMI0*ZCGAM+ZYMI0*ZSGAM)/(ZRACLAT0*ZRDSDG)+ZLONOR + do jj=0,JMAX-1 + lon(jj,ji)=zlon + end do + end do + do jj=0,JMAX-1 + ji=0 + ZXMI0 = XHAT(ji)-ZXBM0 + ZYMI0 = YHAT(jj)-ZYBM0 + ZT1 = log(tan(XPI/4.+ZLATOR*ZRDSDG/2.)) + ZT2 = (-ZXMI0*ZSGAM+ZYMI0*ZCGAM)/ZRACLAT0 + zlat = (-XPI/2.+2.*atan(exp(ZT1+ZT2)))/ZRDSDG + do ji=0,IMAX-1 + lat(jj,ji)=zlat + end do + end do + else + ZCLAT0 = cos(ZRDSDG*ZLAT0) + ZSLAT0 = sin(ZRDSDG*ZLAT0) + ZCLATOR = cos(ZRDSDG*ZLATOR) + ZSLATOR = sin(ZRDSDG*ZLATOR) + ZRO0 = (XRADIUS/ZRPK)*(abs(ZCLAT0))^(1.-ZRPK) * \ + ((1.+ZSLAT0)*abs(ZCLATOR)/(1.+ZSLATOR))^ZRPK + ZGA0 = (ZRPK*(ZLONOR-ZLON0)-ZBETA)*ZRDSDG + ZXP = ZXBM0-ZRO0*sin(ZGA0) + ZYP = ZYBM0+ZRO0*cos(ZGA0) + do ji=0,IMAX-1 + do jj=0,JMAX-1 + ZATA = atan2( -(ZXP-XHAT(ji)) , (ZYP-YHAT(jj)) )/ZRDSDG + zlon = (ZBETA+ZATA)/ZRPK+ZLON0 + lon(jj,ji)=zlon + ZRO2 = (XHAT(ji)-ZXP)^2+(YHAT(jj)-ZYP)^2 + ZJD1 = XRADIUS*(abs(ZCLAT0))^(1.-ZRPK) + ZT1 = (ZJD1)^(2./ZRPK)* (1+ZSLAT0)^2 + ZJD3 = (ZRPK^2*ZRO2) + ZT2 = ZJD3 + ZT2 = ZT2^(1./ZRPK) + ZJD1 = (ZT1-ZT2)/(ZT1+ZT2) + ZJD1 = acos(ZJD1) + ZJD3 = ZJD1 + zlat = (XPI/2.-ZJD3)/ZRDSDG + lat(jj,ji)=zlat + end do + end do + end if + + dims = dimsizes(lat) + + do ii = 0, dims(0)-1 + do jj = 0, dims(1)-1 + if ( lon(ii,jj) .lt. 0.0) then + lon(ii,jj) = lon(ii,jj) + 360. + end if + end do + end do + + opts@start_lat = lat(0,0) + opts@start_lon = lon(0,0) + opts@end_lat = lat(dims(0)-1,dims(1)-1) + opts@end_lon = lon(dims(0)-1,dims(1)-1) + + +; Set some resources common to all map projections. + opts = set_mp_resources(opts) + + if ( isatt(opts,"ZoomIn") .and. opts@ZoomIn ) then + y1 = 0 + x1 = 0 + y2 = dims(0)-1 + x2 = dims(1)-1 + if ( isatt(opts,"Ystart") ) then + y1 = opts@Ystart + delete(opts@Ystart) + end if + if ( isatt(opts,"Xstart") ) then + x1 = opts@Xstart + delete(opts@Xstart) + end if + if ( isatt(opts,"Yend") ) then + if ( opts@Yend .le. y2 ) then + y2 = opts@Yend + end if + delete(opts@Yend) + end if + if ( isatt(opts,"Xend") ) then + if ( opts@Xend .le. x2 ) then + x2 = opts@Xend + end if + delete(opts@Xend) + end if + + opts@mpLeftCornerLatF = lat(y1,x1) + opts@mpLeftCornerLonF = lon(y1,x1) + opts@mpRightCornerLatF = lat(y2,x2) + opts@mpRightCornerLonF = lon(y2,x2) + + if ( opts@mpRightCornerLonF .lt. 0.0 ) then + opts@mpRightCornerLonF = opts@mpRightCornerLonF + 360.0 + end if + + delete(opts@ZoomIn) + end if + + +; The default is not to draw the plot or advance the frame, and +; to maximize the plot in the frame. + + opts@gsnDraw = get_res_value_keep(opts,"gsnDraw", False) + opts@gsnFrame = get_res_value_keep(opts,"gsnFrame", False) + opts@gsnMaximize = get_res_value_keep(opts,"gsnMaximize", True) + + delete_attrs(opts) ; Clean up. + mp = gsn_map(wks,projection,opts) ; Create map plot. + + return(mp) ; Return. + +end + +;-------------------------------------------------------------------------------- + +undef("mnh_map_overlays") +function mnh_map_overlays(in_file[1]:file, \ + wks:graphic, \ + plots[*]:graphic, \ + opt_arg[1]:logical, \ + opt_mp[1]:logical) + +; Based on wrf_map_overlays +; +; This procedure takes an array of plots and overlays them on a +; base plot - map background. +; +; It will advance the plot and cleanup, unless you set the +; PanelPlot resource to True. +; +; Attributes recognized by this procedure: +; FramePlot +; PanelPlot +; NoTitles (don't do any titles) +; CommonTitle & PlotTile is used to overwrite field titles +; CommonTitle will super-seed NoTitles +; +; If FramePlot False, then Draw the plot but do not Frame. +; In this case a user want to add to the drawing, and will +; have to advance the Frame manually in the script. +; +; If the "NoTitles" attribute exists and is set True, then +; don't create the top-left titles, and leave the main titles alone. +; This resource can be useful if you are planning to panel +; the plots. +; +; If PanelPlot is set to True, then this flags to wrf_map_overlays +; that these plots are going to be eventually paneled (likely +; by gsn_panel), and hence 1) draw and frame should not be called +; (unless gsnDraw and/or gsnFrame are explicitly set to True), +; and 2) the overlays and titles should not be removed with +; NhlRemoveOverlay and NhlRemoveAnnotation. +; +begin + + opts = opt_arg ; Make a copy of the resource lists + opt_mp_2 = opt_mp + + ; Let's make the map first + base = mnh_map(wks,in_file,opt_mp_2) + + no_titles = get_res_value(opts,"NoTitles",False) ; Do we want field titles? + com_title = get_res_value(opts,"CommonTitle",False) ; Do we have a common title? + if ( com_title ) then + plot_title = get_res_value(opts,"PlotTitle"," ") + no_titles = True + end if + + call_draw = True + call_frame = get_res_value(opts,"FramePlot",True) ; Do we want to frame the plot? + panel_plot = get_res_value(opts,"PanelPlot",False) ; Are we paneling? + opts@gsnMaximize = get_res_value_keep(opts,"gsnMaximize", True) + + nplots = dimsizes(plots) +; font_color = "Black" + + do i=0,nplots-1 + if(.not.ismissing(plots(i))) then +; class_name = NhlClassName(plots(i)) +; print(class_name) +; if(class_name.eq."contourPlotClass") then +; getvalues plots(i) +; "cnFillOn" : fill_on +; "cnLineColor" : line_color +; end getvalues +; if (.not.fill_on) then +; font_color = line_color +; end if +; end if + if(.not.no_titles) then + getvalues plots(i) + "tiMainString" : SubTitle + end getvalues + if(i.eq.0) then + SubTitles = SubTitle + else + SubTitles = SubTitles + "~C~" + SubTitle + end if + end if + if(com_title .and. i .eq. nplots-1) then + getvalues plots(i) + "tiMainString" : SubTitle + end getvalues + SubTitles = plot_title + end if + setvalues plots(i) + "tfDoNDCOverlay" : True + "tiMainOn" : False + end setvalues + overlay(base,plots(i)) + else + print("mnh_map_overlays: Warning: overlay plot #" + i + " is not valid.") + end if + end do + + if(.not.no_titles .or. com_title) then + font_height = get_res_value_keep(opts,"FontHeightF",0.01) + txt = create "map_titles" textItemClass wks + "txString" : SubTitles + "txFontHeightF" : font_height + ;"txFontColor" : font_color + end create + anno = NhlAddAnnotation(base,txt) + setvalues anno + "amZone" : 3 + "amJust" : "BottomLeft" + "amSide" : "Top" + "amParallelPosF" : 0.005 + "amOrthogonalPosF" : 0.03 + "amResizeNotify" : False + end setvalues + base@map_titles = anno + end if +; +; gsnDraw and gsnFrame default to False if panel plot. +; + if(panel_plot) then + call_draw = False + call_frame= False + end if + + + opts@gsnDraw = get_res_value_keep(opts,"gsnDraw", call_draw) + opts@gsnFrame = get_res_value_keep(opts,"gsnFrame", call_frame) + + draw_and_frame(wks,base,opts@gsnDraw,opts@gsnFrame,False, \ + opts@gsnMaximize) + + if(.not.panel_plot) then + do i=0,nplots-1 + if(.not.ismissing(plots(i))) then + NhlRemoveOverlay(base,plots(i),False) + else + print("wrf_remove_map_overlays: Warning: overlay plot #" + i + " is not valid.") + print(" Nothing to remove.") + end if + end do + end if + + if(.not.no_titles.and..not.panel_plot) then + if(isatt(base,"map_titles")) then + NhlRemoveAnnotation(base,base@map_titles) + delete(base@map_titles) + end if + end if + +return(base) +end + +;-------------------------------------------------------------------------------- +undef("wrf_user_intrp3d") +function wrf_user_intrp3d( var3d:numeric, z_in:numeric, \ + plot_type:string, \ + loc_param:numeric, angle:numeric, opts:logical ) + +; var3d - 3d field to interpolate (all input fields must be unstaggered) +; z_in - interpolate to this field (either p/z) +; plot_type - interpolate horizontally "h", or vertically "v" +; loc_param - level(s) for horizontal plots (eg. 500hPa ; 3000m - scalar), +; plane for vertical plots (2 values representing an xy point +; on the model domain through which the vertical plane will pass +; OR 4 values specifying start and end values +; angle - 0.0 for horizontal plots, and +; an angle for vertical plots - 90 represent a WE cross section +; opts Used IF opts is TRUE, else use loc_param and angle to determine crosssection + +begin + + + if(plot_type .eq. "h" ) then ; horizontal cross section needed + + dimL = dimsizes(loc_param) + + dims = dimsizes(var3d) + nd = dimsizes(dims) + + dimX = dims(nd-1) + dimY = dims(nd-2) + dimZ = dims(nd-3) + dim4 = 1 + dim5 = 1 + if ( nd .eq. 4 ) then + dim4 = dims(nd-4) + end if + if ( nd .eq. 5 ) then + dim4 = dims(nd-4) + dim5 = dims(nd-5) + end if + + var3 = new ( (/ dim5, dim4, dimZ, dimY, dimX /) , typeof(var3d) ) + z = new ( (/ dim5, dim4, dimZ, dimY, dimX /) , typeof(var3d) ) + var2d = new ( (/ dim5, dim4, dimL, dimY, dimX /) , typeof(var3d) ) + + if ( nd .eq. 5 ) then + var3 = var3d + z = z_in + end if + if ( nd .eq. 4 ) then + var3(0,:,:,:,:) = var3d(:,:,:,:) + z(0,:,:,:,:) = z_in(:,:,:,:) + end if + if ( nd .eq. 3 ) then + var3(0,0,:,:,:) = var3d(:,:,:) + z(0,0,:,:,:) = z_in(:,:,:) + end if + + + if ( z(0,0,0,0,0) .gt. 500.) then + ; We must be interpolating to pressure + ; This routine needs input field and level in hPa - lets make sure of this + if ( z(0,0,0,0,0) .gt. 2000. ) then + ; looks like we have Pa as input - make this hPa + z = z * 0.01 + end if + if ( loc_param(0) .gt. 2000. ) then + ; looks like the input was specified in Pa - change this + loc_param = loc_param * 0.01 + end if + end if + + do il = 0,dimL-1 + var = wrf_interp_3d_z(var3,z,loc_param(il)) + var2d(:,:,il,:,:) = var(:,:,:,:) + end do + + copy_VarAtts(var3d,var3) + if(isatt(var3,"description")) then + delete_VarAtts(var3,(/"description"/)) + end if + if(isatt(var3,"units")) then + delete_VarAtts(var3,(/"units"/)) + end if + if(isatt(var3,"MemoryOrder")) then + delete_VarAtts(var3,(/"MemoryOrder"/)) + end if + if(isatt(var3,"_FillValue")) then + delete_VarAtts(var3,(/"_FillValue"/)) + end if + copy_VarAtts(var3,var2d) + + nn = nd-2 + var2d!nn = "plevs" + + if ( dimL .gt. 1 ) then + if ( nd .eq. 5 ) then + return( var2d ) + end if + if ( nd .eq. 4 ) then + return( var2d(0,:,:,:,:) ) + end if + if ( nd .eq. 3 ) then + return( var2d(0,0,:,:,:) ) + end if + else + if ( z(0,0,0,0,0) .gt. 500.) then + var2d@PlotLevelID = loc_param + " hPa" + else + var2d@PlotLevelID = .001*loc_param + " km" + end if + if ( nd .eq. 5 ) then + return( var2d(:,:,0,:,:) ) + end if + if ( nd .eq. 4 ) then + return( var2d(0,:,0,:,:) ) + end if + if ( nd .eq. 3 ) then + return( var2d(0,0,0,:,:) ) + end if + end if + + + end if + + + + + if(plot_type .eq. "v" ) then ; vertical cross section needed + + dims = dimsizes(var3d) + if ( dimsizes(dims) .eq. 4 ) then + if ( z_in(0,0,0,0) .gt. 500.) then + ; We must be interpolating to pressure + ; This routine needs input field and level in hPa - lets make sure of this + if ( z_in(0,0,0,0) .gt. 2000. ) then + ; looks like we have Pa as input - make this hPa + z_in = z_in * 0.01 + end if + end if + z = z_in(0,:,:,:) + else + if ( z_in(0,0,0) .gt. 500.) then + ; We must be interpolating to pressure + ; This routine needs input field and level in hPa - lets make sure of this + if ( z_in(0,0,0) .gt. 2000. ) then + ; looks like we have Pa as input - make this hPa + z_in = z_in * 0.01 + end if + end if + z = z_in + end if + +; set vertical cross section + if (opts) then + xy = wrf_user_set_xy( z, loc_param(0)-1, loc_param(1)-1, \ ; the -1 is for NCL dimensions + loc_param(2)-1, loc_param(3)-1, \ + angle, opts ) + else + xy = wrf_user_set_xy( z, loc_param(0), loc_param(1), \ + 0.0, 0.0, angle, opts ) + end if + xp = dimsizes(xy) + + +; first we interp z + var2dz = wrf_interp_2d_xy( z, xy) + +; interp to constant z grid + if(var2dz(0,0) .gt. var2dz(1,0) ) then ; monotonically decreasing coordinate + z_max = floor(max(z)/10)*10 ; bottom value + z_min = ceil(min(z)/10)*10 ; top value + dz = 1. + nlevels = tointeger( (z_max-z_min)/dz) + z_var2d = new( (/nlevels/), typeof(z)) + z_var2d(0) = z_max + dz = -dz + else + z_max = max(z) + z_min = 0. +;; MODI SOLINE +; dz = 0.01 * z_max + dz = 0.001 * z_max + nlevels = tointeger( z_max/dz ) + z_var2d = new( (/nlevels/), typeof(z)) + z_var2d(0) = z_min + end if +; print("nlevels="+nlevels) +; print("dz="+dz) + + do i=1, nlevels-1 + z_var2d(i) = z_var2d(0)+i*dz + end do + + +; interp the variable + if ( dimsizes(dims) .eq. 4 ) then + var2d = new( (/dims(0), nlevels, xp(0)/), typeof(var2dz)) + do it = 0,dims(0)-1 + var2dtmp = wrf_interp_2d_xy( var3d(it,:,:,:), xy) + do i=0,xp(0)-1 + var2d(it,:,i) = wrf_interp_1d( var2dtmp(:,i), var2dz(:,i), z_var2d) + end do + end do + var2d!0 = var3d!0 + var2d!1 = "Vertical" + var2d!2 = "Horizontal" + else + var2d = new( (/nlevels, xp(0)/), typeof(var2dz)) + var2dtmp = wrf_interp_2d_xy( var3d, xy) + do i=0,xp(0)-1 + var2d(:,i) = wrf_interp_1d( var2dtmp(:,i), var2dz(:,i), z_var2d) + end do + var2d!0 = "Vertical" + var2d!1 = "Horizontal" + end if + + + st_x = tointeger(xy(0,0)) + 1 + st_y = tointeger(xy(0,1)) + 1 + ed_x = tointeger(xy(xp(0)-1,0)) + 1 + ed_y = tointeger(xy(xp(0)-1,1)) + 1 + if (opts) then + var2d@Orientation = "Cross-Sesion: (" + \ + st_x + "," + st_y + ") to (" + \ + ed_x + "," + ed_y + ")" + else + var2d@Orientation = "Cross-Sesion: (" + \ + st_x + "," + st_y + ") to (" + \ + ed_x + "," + ed_y + ") ; center=(" + \ + loc_param(0) + "," + loc_param(1) + \ + ") ; angle=" + angle + end if + + return(var2d) +end if + + +end + diff --git a/MY_RUN/KTEST/007_16janvier/011_ncl_extractdia/MESONHtools.ncl b/MY_RUN/KTEST/007_16janvier/011_ncl_extractdia/MESONHtools.ncl index 6f810bbfdb30b4e658f289d87d1680a80b5b66fe..9cae6400a0dade82e20ba68463722fbb13d4c81d 100644 --- a/MY_RUN/KTEST/007_16janvier/011_ncl_extractdia/MESONHtools.ncl +++ b/MY_RUN/KTEST/007_16janvier/011_ncl_extractdia/MESONHtools.ncl @@ -1,915 +1,915 @@ -load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" -load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" -load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" -load "$NCARG_ROOT/lib/ncarg/nclscripts/wrf/WRFUserARW.ncl" - -;------------------------------------------------------------- -;contains: -; procedure MESONH_map_c -;function mnh_map(wks[1]:graphic,in_file[1]:file,opt_args[1]:logical) -;function mnh_map_overlays(in_file[1]:file,wks:graphic,plots[*]:graphic, \ -; opt_arg[1]:logical,opt_mp[1]:logical) -;function MESONH_pinter( pfield:numeric, loc_param:numeric, ppabs:numeric ) -;------------------------------------------------------------- - -;============================================================== -; J.-P. CHABOUREAU -; This is a driver that selects the appropriate -; mapping function based upon the file variables RPK, BETA, LATOR, LONOR -; -; -; Sample usage: -; a = addfile("...", r") -; IMAX = a->IMAX -; JMAX = a->JMAX -; lat2d = new((/JMAX,IMAX/),"double") -; lat2d(:,:)=0. -; lon2d = new((/JMAX,IMAX/),"double") -; lon2d(:,:)=0. -; icorners = new((/2,2/),"integer") -; icorners(:,:)=0 -; res = True -; MESONH_map_c (a, res, lat2d, lon2d, icorners) -; -; -undef("MESONH_map_c") -;============================================================== -procedure MESONH_map_c (in_file:file, res:logical, plat, plon, icorner) -;============================================================== -;local rank, dimll, nlat, mlon, lat, lon -local rank, dimll, nlat, mlon -begin - -; Check if the variable RPK is in the file -; ---------------------------------------- -if(isfilevar(in_file,"RPK")) then - -; Read projection parameters -; ------------------------- - ZRPK = in_file->RPK - ZLATOR = in_file->LATOR - ZLONOR = in_file->LONOR - ZBETA = in_file->BETA - ZLAT0 = in_file->LAT0 - ZLON0 = in_file->LON0 - -; Case netcdf from lfi2cdf -; ------------------------- - - if(isfilevar(in_file,"IMAX")) - XHAT=in_file->XHAT - YHAT=in_file->YHAT - IMAX= dimsizes(XHAT)-2 - JMAX= dimsizes(YHAT)-2 - zdx=XHAT(2)-XHAT(1) - zdy=YHAT(2)-YHAT(1) - -; unstagger - do ji=0,IMAX-1 - XHAT(ji)=XHAT(ji)+zdx*1.5 - end do - do jj=0,JMAX-1 - YHAT(jj)=YHAT(jj)+zdy*1.5 - end do - - else - -; Case netcdf from extractdia -; --------------------------- - XHAT=in_file->W_E_direction - YHAT=in_file->S_N_direction - IMAX= dimsizes(XHAT) - JMAX= dimsizes(YHAT) - zdx=XHAT(2)-XHAT(1) - zdy=YHAT(2)-YHAT(1) - - end if - - print ("LATOR="+ZLATOR+" - LONOR="+ZLONOR) - print ("ZLAT0="+ZLAT0+" - ZLON0="+ZLON0) - print ("ZDX="+zdx+" - RPK="+ZRPK+" - BETA="+ZBETA) - print ("IMAX="+IMAX+" - JMAX="+JMAX) - - if (ZRPK.gt.0) - ; Stereographic projection -; --------------------------- - res@mpProjection = "Stereographic" - res@mpCenterLonF = ZLON0 - res@mpCenterRotF = ZBETA - res@mpCenterLatF = 90. - end if - - if (ZRPK.lt.0) - ; Stereographic projection -; --------------------------- - res@mpProjection = "Stereographic" - res@mpCenterLonF = ZLON0 - res@mpCenterRotF = ZBETA - res@mpCenterLatF = -90. - end if - - if (ZRPK.eq.0) then - ; Mercator projection -; --------------------------- - res@mpProjection = "Mercator" - end if - - print("Map projection="+res@mpProjection) - -else - print ("MESONH_map_c: Error no RPK variable in input file") -end if - -;=================================================; -; calculate 2D lat and lon -; based on src/mesonh_MOD/mode_gridproj.f90 -;=================================================; - -; Constants -; ----------- - if(isfilevar(in_file,"IMAX")) - XRADIUS=6371229.0d ; Earth radius (meters) - else - XRADIUS=6371.2290d ; Earth radius (km) - end if - XPI=2.0d*asin(1.) ; Pi - ZRDSDG= XPI/180.0d ; Radian to Degree conversion factor - ZXBM0 = 0.0d - ZYBM0 = 0.0d - -;=================================================; - if (ZRPK.eq.0) then -; MERCATOR -;=================================================; - XBETA=0. - XLAT0=0. ; map reference latitude (degrees) - ZXBM0 = 0. - ZYBM0 = 0. - ZCGAM = cos(-ZRDSDG*XBETA) - ZSGAM = sin(-ZRDSDG*XBETA) - ZRACLAT0 = XRADIUS*cos(ZRDSDG*ZLAT0) - do ji=0,IMAX-1 - jj=0 - ZXMI0 = XHAT(ji)-ZXBM0 - ZYMI0 = YHAT(jj)-ZYBM0 - zlon = (ZXMI0*ZCGAM+ZYMI0*ZSGAM)/(ZRACLAT0*ZRDSDG)+ZLONOR - do jj=0,JMAX-1 - plon(jj,ji)=zlon - end do - end do - do jj=0,JMAX-1 - ji=0 - ZXMI0 = XHAT(ji)-ZXBM0 - ZYMI0 = YHAT(jj)-ZYBM0 - ZT1 = log(tan(XPI/4.+ZLATOR*ZRDSDG/2.)) - ZT2 = (-ZXMI0*ZSGAM+ZYMI0*ZCGAM)/ZRACLAT0 - zlat = (-XPI/2.+2.*atan(exp(ZT1+ZT2)))/ZRDSDG - do ji=0,IMAX-1 - plat(jj,ji)=zlat - end do - end do - -;=================================================; - else -; STEREOGRAPHIC PROJECTION -;=================================================; - ZCLAT0 = cos(ZRDSDG*ZLAT0) - ZSLAT0 = sin(ZRDSDG*ZLAT0) - ZCLATOR = cos(ZRDSDG*ZLATOR) - ZSLATOR = sin(ZRDSDG*ZLATOR) - ZRO0 = (XRADIUS/ZRPK)*(abs(ZCLAT0))^(1.-ZRPK) * \ - ((1.+ZSLAT0)*abs(ZCLATOR)/(1.+ZSLATOR))^ZRPK - ZGA0 = (ZRPK*(ZLONOR-ZLON0)-ZBETA)*ZRDSDG - ZXP = ZXBM0-ZRO0*sin(ZGA0) - ZYP = ZYBM0+ZRO0*cos(ZGA0) - do ji=0,IMAX-1 - do jj=0,JMAX-1 - ZATA = atan2( -(ZXP-XHAT(ji)) , (ZYP-YHAT(jj)) )/ZRDSDG - zlon = (ZBETA+ZATA)/ZRPK+ZLON0 - plon(jj,ji)=zlon - ZRO2 = (XHAT(ji)-ZXP)^2+(YHAT(jj)-ZYP)^2 - ZJD1 = XRADIUS*(abs(ZCLAT0))^(1.-ZRPK) - ZT1 = (ZJD1)^(2./ZRPK)* (1+ZSLAT0)^2 - ZJD3 = (ZRPK^2*ZRO2) - ZT2 = ZJD3 - ZT2 = ZT2^(1./ZRPK) - ZJD1 = (ZT1-ZT2)/(ZT1+ZT2) - ZJD1 = acos(ZJD1) - ZJD3 = ZJD1 - zlat = (XPI/2.-ZJD3)/ZRDSDG - plat(jj,ji)=zlat - end do - end do - - end if - -; Defining the corners of the domain -;==================================== - if (icorner(0,0).eq.icorner(1,1)) then - icorner(0,0)=0 - icorner(1,0)=JMAX-1 - icorner(0,1)=0 - icorner(1,1)=IMAX-1 - end if -; print ("icorner"+icorner) - - res@mpLimitMode = "Corners" - res@mpLeftCornerLatF = plat(icorner(0,0),icorner(0,1)) - res@mpLeftCornerLonF = plon(icorner(0,0),icorner(0,1)) - res@mpRightCornerLatF = plat(icorner(1,0),icorner(1,1)) - res@mpRightCornerLonF = plon(icorner(1,0),icorner(1,1)) - -; print ("Corner (0,0); Lat="+res@mpLeftCornerLatF+ \ -; ", Lon="+res@mpLeftCornerLonF) -; print ("Oppos corner; Lat="+res@mpRightCornerLatF+ \ -; ", Lon= "+res@mpRightCornerLonF) - -;========================================== -; Turn on lat / lon labeling -;========================================== - res@pmTickMarkDisplayMode = "Always" ; turn on tickmarks - res@mpOutlineBoundarySets = "AllBoundaries" ; state boundaries - res@mpPerimDrawOrder = "PostDraw" ; force map perim -;========================================== -; Needed for regional native projection -;========================================== - res@tfDoNDCOverlay = True - res@gsnAddCyclic = False ; regional data - -end - -;=========================================== -;------------------------------------------------------------------------ -undef("MESONH_pinter") -function MESONH_pinter( pfield:numeric, loc_param:numeric, ppabs:numeric ) -;************************************************************************* -; S. BIELLI -; This is a routine that interpolate fields on pressure level for plotting -; based on pinter.f90 -; The field to be interpolated must be given at the mass point (grid 1) -; usage : var_inter=MESONHfunction(var_to_interpol, 850., AbsPressure) -; Abs pressure must be in Pa -; - -begin - - dimL= dimsizes(loc_param) - -; First test for grid = 0 - - dimp=dimsizes(ppabs) - - pout=pfield(0:dimL-1,:,:) - pfield@_FillValue=999 - pout@_FillValue=999 - pout=pout@_FillValue - - do jkp = 0, dimL-1 - zref=log10(loc_param(jkp)*100.) - do jloop = 0, dimp(1)-1 - do iloop = 0, dimp(2)-1 - kloop=0 - flag=True - do while (flag .and. (kloop.lt.(dimp(2)-2))) - if (.not.ismissing(ppabs(kloop,jloop,iloop))) then - zxm=log10(ppabs(kloop,jloop,iloop)) - zxp=log10(ppabs(kloop+1,jloop,iloop)) - if ((zxp-zref)*(zref-zxm) .ge. 0) then - pout(jkp,jloop,iloop)= (pfield(kloop,jloop,iloop)*(zxp-zref)+ \ - pfield(kloop+1,jloop,iloop)*(zref-zxm))/ (zxp-zxm) - flag=False - end if - end if - kloop=kloop+1 - end do - end do - end do - end do - - return(pout) - -end - -;-------------------------------------------------------------------------------- -undef("mnh_map") -function mnh_map(wks[1]:graphic,in_file[1]:file,opt_args[1]:logical) - -begin -; -; This function creates a map plot, and bases the projection on -; the MAP_PROJ attribute in the given file. -; -; 1. Make a copy of the resource list, and set some resources -; common to all map projections. -; -; 2. Determine the projection being used, and set resources based -; on that projection. -; -; 3. Create the map plot, and draw and advance the frame -; (if requested). - - opts = opt_args ; Make a copy of the resource list - opts = True - -; Set some resources depending on what kind of map projection is -; chosen. -; -; ZRPK != 0 : "Stereographic" -; ZRPK = 0 : "Mercator" -;=================================================; -; src/mesonh_MOD/mode_gridproj.f90 -;=================================================; - XRADIUS=6371229.0d ; Earth radius (meters) - XPI=2.0d*asin(1.) ; Pi - ZRDSDG= XPI/180.0d ; Radian to Degree conversion factor - ZXBM0 = 0.0d - ZYBM0 = 0.0d - - if(isfilevar(in_file,"RPK")) - ZRPK=in_file->RPK - ZLON0=in_file->LON0 - ZLAT0=in_file->LAT0 - ZLATOR=in_file->LATOR - ZLONOR=in_file->LONOR - ZBETA=in_file->BETA - else - print ("mnh_map: Error no RPK variable in input file") - return(new(1,graphic)) - end if - -; Case netcdf from lfi2cdf - if(isfilevar(in_file,"IMAX")) - XHAT=in_file->XHAT - YHAT=in_file->YHAT - IMAX= dimsizes(XHAT)-2 - JMAX= dimsizes(YHAT)-2 - zdx=XHAT(2)-XHAT(1) - zdy=YHAT(2)-YHAT(1) - do ji=0,IMAX-1 - XHAT(ji)=XHAT(ji)+zdx*1.5 - end do - do jj=0,JMAX-1 - YHAT(jj)=YHAT(jj)+zdy*1.5 - end do - else -; Case netcdf from extractdia - XHAT=in_file->W_E_direction - YHAT=in_file->S_N_direction - IMAX= dimsizes(XHAT) - JMAX= dimsizes(YHAT) - end if -; - - lat = new((/JMAX,IMAX/),"double") - lon = new((/JMAX,IMAX/),"double") - - -; Stereographic projection - if(ZRPK .gt. 0) - projection = "Stereographic" - opts@mpCenterLatF = get_res_value_keep(opts, "mpCenterLatF", 90) - opts@mpCenterLonF = get_res_value_keep(opts, "mpCenterLonF",ZLON0) - opts@mpCenterRotF = get_res_value_keep(opts, "mpCenterRotF",ZBETA) - end if - - if(ZRPK .lt. 0) - projection = "Stereographic" - opts@mpCenterLatF = get_res_value_keep(opts, "mpCenterLatF", -90) - opts@mpCenterLonF = get_res_value_keep(opts, "mpCenterLonF",ZLON0) - opts@mpCenterRotF = get_res_value_keep(opts, "mpCenterRotF",ZBETA) - end if - -; Mercator projection - if(ZRPK .eq. 0) - projection = "Mercator" - end if - - opts@mpNestTime = get_res_value_keep(opts, "mpNestTime",0) - - -; LAT and LON are not saved in the file - if (ZRPK.eq.0) then - XBETA=0. - XLAT0=0. ; map reference latitude (degrees) - ZXBM0 = 0. - ZYBM0 = 0. - ZCGAM = cos(-ZRDSDG*XBETA) - ZSGAM = sin(-ZRDSDG*XBETA) - ZRACLAT0 = XRADIUS*cos(ZRDSDG*ZLAT0) - do ji=0,IMAX-1 - jj=0 - ZXMI0 = XHAT(ji)-ZXBM0 - ZYMI0 = YHAT(jj)-ZYBM0 - zlon = (ZXMI0*ZCGAM+ZYMI0*ZSGAM)/(ZRACLAT0*ZRDSDG)+ZLONOR - do jj=0,JMAX-1 - lon(jj,ji)=zlon - end do - end do - do jj=0,JMAX-1 - ji=0 - ZXMI0 = XHAT(ji)-ZXBM0 - ZYMI0 = YHAT(jj)-ZYBM0 - ZT1 = log(tan(XPI/4.+ZLATOR*ZRDSDG/2.)) - ZT2 = (-ZXMI0*ZSGAM+ZYMI0*ZCGAM)/ZRACLAT0 - zlat = (-XPI/2.+2.*atan(exp(ZT1+ZT2)))/ZRDSDG - do ji=0,IMAX-1 - lat(jj,ji)=zlat - end do - end do - else - ZCLAT0 = cos(ZRDSDG*ZLAT0) - ZSLAT0 = sin(ZRDSDG*ZLAT0) - ZCLATOR = cos(ZRDSDG*ZLATOR) - ZSLATOR = sin(ZRDSDG*ZLATOR) - ZRO0 = (XRADIUS/ZRPK)*(abs(ZCLAT0))^(1.-ZRPK) * \ - ((1.+ZSLAT0)*abs(ZCLATOR)/(1.+ZSLATOR))^ZRPK - ZGA0 = (ZRPK*(ZLONOR-ZLON0)-ZBETA)*ZRDSDG - ZXP = ZXBM0-ZRO0*sin(ZGA0) - ZYP = ZYBM0+ZRO0*cos(ZGA0) - do ji=0,IMAX-1 - do jj=0,JMAX-1 - ZATA = atan2( -(ZXP-XHAT(ji)) , (ZYP-YHAT(jj)) )/ZRDSDG - zlon = (ZBETA+ZATA)/ZRPK+ZLON0 - lon(jj,ji)=zlon - ZRO2 = (XHAT(ji)-ZXP)^2+(YHAT(jj)-ZYP)^2 - ZJD1 = XRADIUS*(abs(ZCLAT0))^(1.-ZRPK) - ZT1 = (ZJD1)^(2./ZRPK)* (1+ZSLAT0)^2 - ZJD3 = (ZRPK^2*ZRO2) - ZT2 = ZJD3 - ZT2 = ZT2^(1./ZRPK) - ZJD1 = (ZT1-ZT2)/(ZT1+ZT2) - ZJD1 = acos(ZJD1) - ZJD3 = ZJD1 - zlat = (XPI/2.-ZJD3)/ZRDSDG - lat(jj,ji)=zlat - end do - end do - end if - - dims = dimsizes(lat) - - do ii = 0, dims(0)-1 - do jj = 0, dims(1)-1 - if ( lon(ii,jj) .lt. 0.0) then - lon(ii,jj) = lon(ii,jj) + 360. - end if - end do - end do - - opts@start_lat = lat(0,0) - opts@start_lon = lon(0,0) - opts@end_lat = lat(dims(0)-1,dims(1)-1) - opts@end_lon = lon(dims(0)-1,dims(1)-1) - - -; Set some resources common to all map projections. - opts = set_mp_resources(opts) - - if ( isatt(opts,"ZoomIn") .and. opts@ZoomIn ) then - y1 = 0 - x1 = 0 - y2 = dims(0)-1 - x2 = dims(1)-1 - if ( isatt(opts,"Ystart") ) then - y1 = opts@Ystart - delete(opts@Ystart) - end if - if ( isatt(opts,"Xstart") ) then - x1 = opts@Xstart - delete(opts@Xstart) - end if - if ( isatt(opts,"Yend") ) then - if ( opts@Yend .le. y2 ) then - y2 = opts@Yend - end if - delete(opts@Yend) - end if - if ( isatt(opts,"Xend") ) then - if ( opts@Xend .le. x2 ) then - x2 = opts@Xend - end if - delete(opts@Xend) - end if - - opts@mpLeftCornerLatF = lat(y1,x1) - opts@mpLeftCornerLonF = lon(y1,x1) - opts@mpRightCornerLatF = lat(y2,x2) - opts@mpRightCornerLonF = lon(y2,x2) - - if ( opts@mpRightCornerLonF .lt. 0.0 ) then - opts@mpRightCornerLonF = opts@mpRightCornerLonF + 360.0 - end if - - delete(opts@ZoomIn) - end if - - -; The default is not to draw the plot or advance the frame, and -; to maximize the plot in the frame. - - opts@gsnDraw = get_res_value_keep(opts,"gsnDraw", False) - opts@gsnFrame = get_res_value_keep(opts,"gsnFrame", False) - opts@gsnMaximize = get_res_value_keep(opts,"gsnMaximize", True) - - delete_attrs(opts) ; Clean up. - mp = gsn_map(wks,projection,opts) ; Create map plot. - - return(mp) ; Return. - -end - -;-------------------------------------------------------------------------------- - -undef("mnh_map_overlays") -function mnh_map_overlays(in_file[1]:file, \ - wks:graphic, \ - plots[*]:graphic, \ - opt_arg[1]:logical, \ - opt_mp[1]:logical) - -; Based on wrf_map_overlays -; -; This procedure takes an array of plots and overlays them on a -; base plot - map background. -; -; It will advance the plot and cleanup, unless you set the -; PanelPlot resource to True. -; -; Attributes recognized by this procedure: -; FramePlot -; PanelPlot -; NoTitles (don't do any titles) -; CommonTitle & PlotTile is used to overwrite field titles -; CommonTitle will super-seed NoTitles -; -; If FramePlot False, then Draw the plot but do not Frame. -; In this case a user want to add to the drawing, and will -; have to advance the Frame manually in the script. -; -; If the "NoTitles" attribute exists and is set True, then -; don't create the top-left titles, and leave the main titles alone. -; This resource can be useful if you are planning to panel -; the plots. -; -; If PanelPlot is set to True, then this flags to wrf_map_overlays -; that these plots are going to be eventually paneled (likely -; by gsn_panel), and hence 1) draw and frame should not be called -; (unless gsnDraw and/or gsnFrame are explicitly set to True), -; and 2) the overlays and titles should not be removed with -; NhlRemoveOverlay and NhlRemoveAnnotation. -; -begin - - opts = opt_arg ; Make a copy of the resource lists - opt_mp_2 = opt_mp - - ; Let's make the map first - base = mnh_map(wks,in_file,opt_mp_2) - - no_titles = get_res_value(opts,"NoTitles",False) ; Do we want field titles? - com_title = get_res_value(opts,"CommonTitle",False) ; Do we have a common title? - if ( com_title ) then - plot_title = get_res_value(opts,"PlotTitle"," ") - no_titles = True - end if - - call_draw = True - call_frame = get_res_value(opts,"FramePlot",True) ; Do we want to frame the plot? - panel_plot = get_res_value(opts,"PanelPlot",False) ; Are we paneling? - opts@gsnMaximize = get_res_value_keep(opts,"gsnMaximize", True) - - nplots = dimsizes(plots) -; font_color = "Black" - - do i=0,nplots-1 - if(.not.ismissing(plots(i))) then -; class_name = NhlClassName(plots(i)) -; print(class_name) -; if(class_name.eq."contourPlotClass") then -; getvalues plots(i) -; "cnFillOn" : fill_on -; "cnLineColor" : line_color -; end getvalues -; if (.not.fill_on) then -; font_color = line_color -; end if -; end if - if(.not.no_titles) then - getvalues plots(i) - "tiMainString" : SubTitle - end getvalues - if(i.eq.0) then - SubTitles = SubTitle - else - SubTitles = SubTitles + "~C~" + SubTitle - end if - end if - if(com_title .and. i .eq. nplots-1) then - getvalues plots(i) - "tiMainString" : SubTitle - end getvalues - SubTitles = plot_title - end if - setvalues plots(i) - "tfDoNDCOverlay" : True - "tiMainOn" : False - end setvalues - overlay(base,plots(i)) - else - print("mnh_map_overlays: Warning: overlay plot #" + i + " is not valid.") - end if - end do - - if(.not.no_titles .or. com_title) then - font_height = get_res_value_keep(opts,"FontHeightF",0.01) - txt = create "map_titles" textItemClass wks - "txString" : SubTitles - "txFontHeightF" : font_height - ;"txFontColor" : font_color - end create - anno = NhlAddAnnotation(base,txt) - setvalues anno - "amZone" : 3 - "amJust" : "BottomLeft" - "amSide" : "Top" - "amParallelPosF" : 0.005 - "amOrthogonalPosF" : 0.03 - "amResizeNotify" : False - end setvalues - base@map_titles = anno - end if -; -; gsnDraw and gsnFrame default to False if panel plot. -; - if(panel_plot) then - call_draw = False - call_frame= False - end if - - - opts@gsnDraw = get_res_value_keep(opts,"gsnDraw", call_draw) - opts@gsnFrame = get_res_value_keep(opts,"gsnFrame", call_frame) - - draw_and_frame(wks,base,opts@gsnDraw,opts@gsnFrame,False, \ - opts@gsnMaximize) - - if(.not.panel_plot) then - do i=0,nplots-1 - if(.not.ismissing(plots(i))) then - NhlRemoveOverlay(base,plots(i),False) - else - print("wrf_remove_map_overlays: Warning: overlay plot #" + i + " is not valid.") - print(" Nothing to remove.") - end if - end do - end if - - if(.not.no_titles.and..not.panel_plot) then - if(isatt(base,"map_titles")) then - NhlRemoveAnnotation(base,base@map_titles) - delete(base@map_titles) - end if - end if - -return(base) -end - -;-------------------------------------------------------------------------------- -undef("wrf_user_intrp3d") -function wrf_user_intrp3d( var3d:numeric, z_in:numeric, \ - plot_type:string, \ - loc_param:numeric, angle:numeric, opts:logical ) - -; var3d - 3d field to interpolate (all input fields must be unstaggered) -; z_in - interpolate to this field (either p/z) -; plot_type - interpolate horizontally "h", or vertically "v" -; loc_param - level(s) for horizontal plots (eg. 500hPa ; 3000m - scalar), -; plane for vertical plots (2 values representing an xy point -; on the model domain through which the vertical plane will pass -; OR 4 values specifying start and end values -; angle - 0.0 for horizontal plots, and -; an angle for vertical plots - 90 represent a WE cross section -; opts Used IF opts is TRUE, else use loc_param and angle to determine crosssection - -begin - - - if(plot_type .eq. "h" ) then ; horizontal cross section needed - - dimL = dimsizes(loc_param) - - dims = dimsizes(var3d) - nd = dimsizes(dims) - - dimX = dims(nd-1) - dimY = dims(nd-2) - dimZ = dims(nd-3) - dim4 = 1 - dim5 = 1 - if ( nd .eq. 4 ) then - dim4 = dims(nd-4) - end if - if ( nd .eq. 5 ) then - dim4 = dims(nd-4) - dim5 = dims(nd-5) - end if - - var3 = new ( (/ dim5, dim4, dimZ, dimY, dimX /) , typeof(var3d) ) - z = new ( (/ dim5, dim4, dimZ, dimY, dimX /) , typeof(var3d) ) - var2d = new ( (/ dim5, dim4, dimL, dimY, dimX /) , typeof(var3d) ) - - if ( nd .eq. 5 ) then - var3 = var3d - z = z_in - end if - if ( nd .eq. 4 ) then - var3(0,:,:,:,:) = var3d(:,:,:,:) - z(0,:,:,:,:) = z_in(:,:,:,:) - end if - if ( nd .eq. 3 ) then - var3(0,0,:,:,:) = var3d(:,:,:) - z(0,0,:,:,:) = z_in(:,:,:) - end if - - - if ( z(0,0,0,0,0) .gt. 500.) then - ; We must be interpolating to pressure - ; This routine needs input field and level in hPa - lets make sure of this - if ( z(0,0,0,0,0) .gt. 2000. ) then - ; looks like we have Pa as input - make this hPa - z = z * 0.01 - end if - if ( loc_param(0) .gt. 2000. ) then - ; looks like the input was specified in Pa - change this - loc_param = loc_param * 0.01 - end if - end if - - do il = 0,dimL-1 - var = wrf_interp_3d_z(var3,z,loc_param(il)) - var2d(:,:,il,:,:) = var(:,:,:,:) - end do - - copy_VarAtts(var3d,var3) - if(isatt(var3,"description")) then - delete_VarAtts(var3,(/"description"/)) - end if - if(isatt(var3,"units")) then - delete_VarAtts(var3,(/"units"/)) - end if - if(isatt(var3,"MemoryOrder")) then - delete_VarAtts(var3,(/"MemoryOrder"/)) - end if - if(isatt(var3,"_FillValue")) then - delete_VarAtts(var3,(/"_FillValue"/)) - end if - copy_VarAtts(var3,var2d) - - nn = nd-2 - var2d!nn = "plevs" - - if ( dimL .gt. 1 ) then - if ( nd .eq. 5 ) then - return( var2d ) - end if - if ( nd .eq. 4 ) then - return( var2d(0,:,:,:,:) ) - end if - if ( nd .eq. 3 ) then - return( var2d(0,0,:,:,:) ) - end if - else - if ( z(0,0,0,0,0) .gt. 500.) then - var2d@PlotLevelID = loc_param + " hPa" - else - var2d@PlotLevelID = .001*loc_param + " km" - end if - if ( nd .eq. 5 ) then - return( var2d(:,:,0,:,:) ) - end if - if ( nd .eq. 4 ) then - return( var2d(0,:,0,:,:) ) - end if - if ( nd .eq. 3 ) then - return( var2d(0,0,0,:,:) ) - end if - end if - - - end if - - - - - if(plot_type .eq. "v" ) then ; vertical cross section needed - - dims = dimsizes(var3d) - if ( dimsizes(dims) .eq. 4 ) then - if ( z_in(0,0,0,0) .gt. 500.) then - ; We must be interpolating to pressure - ; This routine needs input field and level in hPa - lets make sure of this - if ( z_in(0,0,0,0) .gt. 2000. ) then - ; looks like we have Pa as input - make this hPa - z_in = z_in * 0.01 - end if - end if - z = z_in(0,:,:,:) - else - if ( z_in(0,0,0) .gt. 500.) then - ; We must be interpolating to pressure - ; This routine needs input field and level in hPa - lets make sure of this - if ( z_in(0,0,0) .gt. 2000. ) then - ; looks like we have Pa as input - make this hPa - z_in = z_in * 0.01 - end if - end if - z = z_in - end if - -; set vertical cross section - if (opts) then - xy = wrf_user_set_xy( z, loc_param(0)-1, loc_param(1)-1, \ ; the -1 is for NCL dimensions - loc_param(2)-1, loc_param(3)-1, \ - angle, opts ) - else - xy = wrf_user_set_xy( z, loc_param(0), loc_param(1), \ - 0.0, 0.0, angle, opts ) - end if - xp = dimsizes(xy) - - -; first we interp z - var2dz = wrf_interp_2d_xy( z, xy) - -; interp to constant z grid - if(var2dz(0,0) .gt. var2dz(1,0) ) then ; monotonically decreasing coordinate - z_max = floor(max(z)/10)*10 ; bottom value - z_min = ceil(min(z)/10)*10 ; top value - dz = 1. - nlevels = tointeger( (z_max-z_min)/dz) - z_var2d = new( (/nlevels/), typeof(z)) - z_var2d(0) = z_max - dz = -dz - else - z_max = max(z) - z_min = 0. -;; MODI SOLINE -; dz = 0.01 * z_max - dz = 0.001 * z_max - nlevels = tointeger( z_max/dz ) - z_var2d = new( (/nlevels/), typeof(z)) - z_var2d(0) = z_min - end if -; print("nlevels="+nlevels) -; print("dz="+dz) - - do i=1, nlevels-1 - z_var2d(i) = z_var2d(0)+i*dz - end do - - -; interp the variable - if ( dimsizes(dims) .eq. 4 ) then - var2d = new( (/dims(0), nlevels, xp(0)/), typeof(var2dz)) - do it = 0,dims(0)-1 - var2dtmp = wrf_interp_2d_xy( var3d(it,:,:,:), xy) - do i=0,xp(0)-1 - var2d(it,:,i) = wrf_interp_1d( var2dtmp(:,i), var2dz(:,i), z_var2d) - end do - end do - var2d!0 = var3d!0 - var2d!1 = "Vertical" - var2d!2 = "Horizontal" - else - var2d = new( (/nlevels, xp(0)/), typeof(var2dz)) - var2dtmp = wrf_interp_2d_xy( var3d, xy) - do i=0,xp(0)-1 - var2d(:,i) = wrf_interp_1d( var2dtmp(:,i), var2dz(:,i), z_var2d) - end do - var2d!0 = "Vertical" - var2d!1 = "Horizontal" - end if - - - st_x = tointeger(xy(0,0)) + 1 - st_y = tointeger(xy(0,1)) + 1 - ed_x = tointeger(xy(xp(0)-1,0)) + 1 - ed_y = tointeger(xy(xp(0)-1,1)) + 1 - if (opts) then - var2d@Orientation = "Cross-Sesion: (" + \ - st_x + "," + st_y + ") to (" + \ - ed_x + "," + ed_y + ")" - else - var2d@Orientation = "Cross-Sesion: (" + \ - st_x + "," + st_y + ") to (" + \ - ed_x + "," + ed_y + ") ; center=(" + \ - loc_param(0) + "," + loc_param(1) + \ - ") ; angle=" + angle - end if - - return(var2d) -end if - - -end - +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/wrf/WRFUserARW.ncl" + +;------------------------------------------------------------- +;contains: +; procedure MESONH_map_c +;function mnh_map(wks[1]:graphic,in_file[1]:file,opt_args[1]:logical) +;function mnh_map_overlays(in_file[1]:file,wks:graphic,plots[*]:graphic, \ +; opt_arg[1]:logical,opt_mp[1]:logical) +;function MESONH_pinter( pfield:numeric, loc_param:numeric, ppabs:numeric ) +;------------------------------------------------------------- + +;============================================================== +; J.-P. CHABOUREAU +; This is a driver that selects the appropriate +; mapping function based upon the file variables RPK, BETA, LATOR, LONOR +; +; +; Sample usage: +; a = addfile("...", r") +; IMAX = a->IMAX +; JMAX = a->JMAX +; lat2d = new((/JMAX,IMAX/),"double") +; lat2d(:,:)=0. +; lon2d = new((/JMAX,IMAX/),"double") +; lon2d(:,:)=0. +; icorners = new((/2,2/),"integer") +; icorners(:,:)=0 +; res = True +; MESONH_map_c (a, res, lat2d, lon2d, icorners) +; +; +undef("MESONH_map_c") +;============================================================== +procedure MESONH_map_c (in_file:file, res:logical, plat, plon, icorner) +;============================================================== +;local rank, dimll, nlat, mlon, lat, lon +local rank, dimll, nlat, mlon +begin + +; Check if the variable RPK is in the file +; ---------------------------------------- +if(isfilevar(in_file,"RPK")) then + +; Read projection parameters +; ------------------------- + ZRPK = in_file->RPK + ZLATOR = in_file->LATOR + ZLONOR = in_file->LONOR + ZBETA = in_file->BETA + ZLAT0 = in_file->LAT0 + ZLON0 = in_file->LON0 + +; Case netcdf from lfi2cdf +; ------------------------- + + if(isfilevar(in_file,"IMAX")) + XHAT=in_file->XHAT + YHAT=in_file->YHAT + IMAX= dimsizes(XHAT)-2 + JMAX= dimsizes(YHAT)-2 + zdx=XHAT(2)-XHAT(1) + zdy=YHAT(2)-YHAT(1) + +; unstagger + do ji=0,IMAX-1 + XHAT(ji)=XHAT(ji)+zdx*1.5 + end do + do jj=0,JMAX-1 + YHAT(jj)=YHAT(jj)+zdy*1.5 + end do + + else + +; Case netcdf from extractdia +; --------------------------- + XHAT=in_file->W_E_direction + YHAT=in_file->S_N_direction + IMAX= dimsizes(XHAT) + JMAX= dimsizes(YHAT) + zdx=XHAT(2)-XHAT(1) + zdy=YHAT(2)-YHAT(1) + + end if + + print ("LATOR="+ZLATOR+" - LONOR="+ZLONOR) + print ("ZLAT0="+ZLAT0+" - ZLON0="+ZLON0) + print ("ZDX="+zdx+" - RPK="+ZRPK+" - BETA="+ZBETA) + print ("IMAX="+IMAX+" - JMAX="+JMAX) + + if (ZRPK.gt.0) + ; Stereographic projection +; --------------------------- + res@mpProjection = "Stereographic" + res@mpCenterLonF = ZLON0 + res@mpCenterRotF = ZBETA + res@mpCenterLatF = 90. + end if + + if (ZRPK.lt.0) + ; Stereographic projection +; --------------------------- + res@mpProjection = "Stereographic" + res@mpCenterLonF = ZLON0 + res@mpCenterRotF = ZBETA + res@mpCenterLatF = -90. + end if + + if (ZRPK.eq.0) then + ; Mercator projection +; --------------------------- + res@mpProjection = "Mercator" + end if + + print("Map projection="+res@mpProjection) + +else + print ("MESONH_map_c: Error no RPK variable in input file") +end if + +;=================================================; +; calculate 2D lat and lon +; based on src/mesonh_MOD/mode_gridproj.f90 +;=================================================; + +; Constants +; ----------- + if(isfilevar(in_file,"IMAX")) + XRADIUS=6371229.0d ; Earth radius (meters) + else + XRADIUS=6371.2290d ; Earth radius (km) + end if + XPI=2.0d*asin(1.) ; Pi + ZRDSDG= XPI/180.0d ; Radian to Degree conversion factor + ZXBM0 = 0.0d + ZYBM0 = 0.0d + +;=================================================; + if (ZRPK.eq.0) then +; MERCATOR +;=================================================; + XBETA=0. + XLAT0=0. ; map reference latitude (degrees) + ZXBM0 = 0. + ZYBM0 = 0. + ZCGAM = cos(-ZRDSDG*XBETA) + ZSGAM = sin(-ZRDSDG*XBETA) + ZRACLAT0 = XRADIUS*cos(ZRDSDG*ZLAT0) + do ji=0,IMAX-1 + jj=0 + ZXMI0 = XHAT(ji)-ZXBM0 + ZYMI0 = YHAT(jj)-ZYBM0 + zlon = (ZXMI0*ZCGAM+ZYMI0*ZSGAM)/(ZRACLAT0*ZRDSDG)+ZLONOR + do jj=0,JMAX-1 + plon(jj,ji)=zlon + end do + end do + do jj=0,JMAX-1 + ji=0 + ZXMI0 = XHAT(ji)-ZXBM0 + ZYMI0 = YHAT(jj)-ZYBM0 + ZT1 = log(tan(XPI/4.+ZLATOR*ZRDSDG/2.)) + ZT2 = (-ZXMI0*ZSGAM+ZYMI0*ZCGAM)/ZRACLAT0 + zlat = (-XPI/2.+2.*atan(exp(ZT1+ZT2)))/ZRDSDG + do ji=0,IMAX-1 + plat(jj,ji)=zlat + end do + end do + +;=================================================; + else +; STEREOGRAPHIC PROJECTION +;=================================================; + ZCLAT0 = cos(ZRDSDG*ZLAT0) + ZSLAT0 = sin(ZRDSDG*ZLAT0) + ZCLATOR = cos(ZRDSDG*ZLATOR) + ZSLATOR = sin(ZRDSDG*ZLATOR) + ZRO0 = (XRADIUS/ZRPK)*(abs(ZCLAT0))^(1.-ZRPK) * \ + ((1.+ZSLAT0)*abs(ZCLATOR)/(1.+ZSLATOR))^ZRPK + ZGA0 = (ZRPK*(ZLONOR-ZLON0)-ZBETA)*ZRDSDG + ZXP = ZXBM0-ZRO0*sin(ZGA0) + ZYP = ZYBM0+ZRO0*cos(ZGA0) + do ji=0,IMAX-1 + do jj=0,JMAX-1 + ZATA = atan2( -(ZXP-XHAT(ji)) , (ZYP-YHAT(jj)) )/ZRDSDG + zlon = (ZBETA+ZATA)/ZRPK+ZLON0 + plon(jj,ji)=zlon + ZRO2 = (XHAT(ji)-ZXP)^2+(YHAT(jj)-ZYP)^2 + ZJD1 = XRADIUS*(abs(ZCLAT0))^(1.-ZRPK) + ZT1 = (ZJD1)^(2./ZRPK)* (1+ZSLAT0)^2 + ZJD3 = (ZRPK^2*ZRO2) + ZT2 = ZJD3 + ZT2 = ZT2^(1./ZRPK) + ZJD1 = (ZT1-ZT2)/(ZT1+ZT2) + ZJD1 = acos(ZJD1) + ZJD3 = ZJD1 + zlat = (XPI/2.-ZJD3)/ZRDSDG + plat(jj,ji)=zlat + end do + end do + + end if + +; Defining the corners of the domain +;==================================== + if (icorner(0,0).eq.icorner(1,1)) then + icorner(0,0)=0 + icorner(1,0)=JMAX-1 + icorner(0,1)=0 + icorner(1,1)=IMAX-1 + end if +; print ("icorner"+icorner) + + res@mpLimitMode = "Corners" + res@mpLeftCornerLatF = plat(icorner(0,0),icorner(0,1)) + res@mpLeftCornerLonF = plon(icorner(0,0),icorner(0,1)) + res@mpRightCornerLatF = plat(icorner(1,0),icorner(1,1)) + res@mpRightCornerLonF = plon(icorner(1,0),icorner(1,1)) + +; print ("Corner (0,0); Lat="+res@mpLeftCornerLatF+ \ +; ", Lon="+res@mpLeftCornerLonF) +; print ("Oppos corner; Lat="+res@mpRightCornerLatF+ \ +; ", Lon= "+res@mpRightCornerLonF) + +;========================================== +; Turn on lat / lon labeling +;========================================== + res@pmTickMarkDisplayMode = "Always" ; turn on tickmarks + res@mpOutlineBoundarySets = "AllBoundaries" ; state boundaries + res@mpPerimDrawOrder = "PostDraw" ; force map perim +;========================================== +; Needed for regional native projection +;========================================== + res@tfDoNDCOverlay = True + res@gsnAddCyclic = False ; regional data + +end + +;=========================================== +;------------------------------------------------------------------------ +undef("MESONH_pinter") +function MESONH_pinter( pfield:numeric, loc_param:numeric, ppabs:numeric ) +;************************************************************************* +; S. BIELLI +; This is a routine that interpolate fields on pressure level for plotting +; based on pinter.f90 +; The field to be interpolated must be given at the mass point (grid 1) +; usage : var_inter=MESONHfunction(var_to_interpol, 850., AbsPressure) +; Abs pressure must be in Pa +; + +begin + + dimL= dimsizes(loc_param) + +; First test for grid = 0 + + dimp=dimsizes(ppabs) + + pout=pfield(0:dimL-1,:,:) + pfield@_FillValue=999 + pout@_FillValue=999 + pout=pout@_FillValue + + do jkp = 0, dimL-1 + zref=log10(loc_param(jkp)*100.) + do jloop = 0, dimp(1)-1 + do iloop = 0, dimp(2)-1 + kloop=0 + flag=True + do while (flag .and. (kloop.lt.(dimp(2)-2))) + if (.not.ismissing(ppabs(kloop,jloop,iloop))) then + zxm=log10(ppabs(kloop,jloop,iloop)) + zxp=log10(ppabs(kloop+1,jloop,iloop)) + if ((zxp-zref)*(zref-zxm) .ge. 0) then + pout(jkp,jloop,iloop)= (pfield(kloop,jloop,iloop)*(zxp-zref)+ \ + pfield(kloop+1,jloop,iloop)*(zref-zxm))/ (zxp-zxm) + flag=False + end if + end if + kloop=kloop+1 + end do + end do + end do + end do + + return(pout) + +end + +;-------------------------------------------------------------------------------- +undef("mnh_map") +function mnh_map(wks[1]:graphic,in_file[1]:file,opt_args[1]:logical) + +begin +; +; This function creates a map plot, and bases the projection on +; the MAP_PROJ attribute in the given file. +; +; 1. Make a copy of the resource list, and set some resources +; common to all map projections. +; +; 2. Determine the projection being used, and set resources based +; on that projection. +; +; 3. Create the map plot, and draw and advance the frame +; (if requested). + + opts = opt_args ; Make a copy of the resource list + opts = True + +; Set some resources depending on what kind of map projection is +; chosen. +; +; ZRPK != 0 : "Stereographic" +; ZRPK = 0 : "Mercator" +;=================================================; +; src/mesonh_MOD/mode_gridproj.f90 +;=================================================; + XRADIUS=6371229.0d ; Earth radius (meters) + XPI=2.0d*asin(1.) ; Pi + ZRDSDG= XPI/180.0d ; Radian to Degree conversion factor + ZXBM0 = 0.0d + ZYBM0 = 0.0d + + if(isfilevar(in_file,"RPK")) + ZRPK=in_file->RPK + ZLON0=in_file->LON0 + ZLAT0=in_file->LAT0 + ZLATOR=in_file->LATOR + ZLONOR=in_file->LONOR + ZBETA=in_file->BETA + else + print ("mnh_map: Error no RPK variable in input file") + return(new(1,graphic)) + end if + +; Case netcdf from lfi2cdf + if(isfilevar(in_file,"IMAX")) + XHAT=in_file->XHAT + YHAT=in_file->YHAT + IMAX= dimsizes(XHAT)-2 + JMAX= dimsizes(YHAT)-2 + zdx=XHAT(2)-XHAT(1) + zdy=YHAT(2)-YHAT(1) + do ji=0,IMAX-1 + XHAT(ji)=XHAT(ji)+zdx*1.5 + end do + do jj=0,JMAX-1 + YHAT(jj)=YHAT(jj)+zdy*1.5 + end do + else +; Case netcdf from extractdia + XHAT=in_file->W_E_direction + YHAT=in_file->S_N_direction + IMAX= dimsizes(XHAT) + JMAX= dimsizes(YHAT) + end if +; + + lat = new((/JMAX,IMAX/),"double") + lon = new((/JMAX,IMAX/),"double") + + +; Stereographic projection + if(ZRPK .gt. 0) + projection = "Stereographic" + opts@mpCenterLatF = get_res_value_keep(opts, "mpCenterLatF", 90) + opts@mpCenterLonF = get_res_value_keep(opts, "mpCenterLonF",ZLON0) + opts@mpCenterRotF = get_res_value_keep(opts, "mpCenterRotF",ZBETA) + end if + + if(ZRPK .lt. 0) + projection = "Stereographic" + opts@mpCenterLatF = get_res_value_keep(opts, "mpCenterLatF", -90) + opts@mpCenterLonF = get_res_value_keep(opts, "mpCenterLonF",ZLON0) + opts@mpCenterRotF = get_res_value_keep(opts, "mpCenterRotF",ZBETA) + end if + +; Mercator projection + if(ZRPK .eq. 0) + projection = "Mercator" + end if + + opts@mpNestTime = get_res_value_keep(opts, "mpNestTime",0) + + +; LAT and LON are not saved in the file + if (ZRPK.eq.0) then + XBETA=0. + XLAT0=0. ; map reference latitude (degrees) + ZXBM0 = 0. + ZYBM0 = 0. + ZCGAM = cos(-ZRDSDG*XBETA) + ZSGAM = sin(-ZRDSDG*XBETA) + ZRACLAT0 = XRADIUS*cos(ZRDSDG*ZLAT0) + do ji=0,IMAX-1 + jj=0 + ZXMI0 = XHAT(ji)-ZXBM0 + ZYMI0 = YHAT(jj)-ZYBM0 + zlon = (ZXMI0*ZCGAM+ZYMI0*ZSGAM)/(ZRACLAT0*ZRDSDG)+ZLONOR + do jj=0,JMAX-1 + lon(jj,ji)=zlon + end do + end do + do jj=0,JMAX-1 + ji=0 + ZXMI0 = XHAT(ji)-ZXBM0 + ZYMI0 = YHAT(jj)-ZYBM0 + ZT1 = log(tan(XPI/4.+ZLATOR*ZRDSDG/2.)) + ZT2 = (-ZXMI0*ZSGAM+ZYMI0*ZCGAM)/ZRACLAT0 + zlat = (-XPI/2.+2.*atan(exp(ZT1+ZT2)))/ZRDSDG + do ji=0,IMAX-1 + lat(jj,ji)=zlat + end do + end do + else + ZCLAT0 = cos(ZRDSDG*ZLAT0) + ZSLAT0 = sin(ZRDSDG*ZLAT0) + ZCLATOR = cos(ZRDSDG*ZLATOR) + ZSLATOR = sin(ZRDSDG*ZLATOR) + ZRO0 = (XRADIUS/ZRPK)*(abs(ZCLAT0))^(1.-ZRPK) * \ + ((1.+ZSLAT0)*abs(ZCLATOR)/(1.+ZSLATOR))^ZRPK + ZGA0 = (ZRPK*(ZLONOR-ZLON0)-ZBETA)*ZRDSDG + ZXP = ZXBM0-ZRO0*sin(ZGA0) + ZYP = ZYBM0+ZRO0*cos(ZGA0) + do ji=0,IMAX-1 + do jj=0,JMAX-1 + ZATA = atan2( -(ZXP-XHAT(ji)) , (ZYP-YHAT(jj)) )/ZRDSDG + zlon = (ZBETA+ZATA)/ZRPK+ZLON0 + lon(jj,ji)=zlon + ZRO2 = (XHAT(ji)-ZXP)^2+(YHAT(jj)-ZYP)^2 + ZJD1 = XRADIUS*(abs(ZCLAT0))^(1.-ZRPK) + ZT1 = (ZJD1)^(2./ZRPK)* (1+ZSLAT0)^2 + ZJD3 = (ZRPK^2*ZRO2) + ZT2 = ZJD3 + ZT2 = ZT2^(1./ZRPK) + ZJD1 = (ZT1-ZT2)/(ZT1+ZT2) + ZJD1 = acos(ZJD1) + ZJD3 = ZJD1 + zlat = (XPI/2.-ZJD3)/ZRDSDG + lat(jj,ji)=zlat + end do + end do + end if + + dims = dimsizes(lat) + + do ii = 0, dims(0)-1 + do jj = 0, dims(1)-1 + if ( lon(ii,jj) .lt. 0.0) then + lon(ii,jj) = lon(ii,jj) + 360. + end if + end do + end do + + opts@start_lat = lat(0,0) + opts@start_lon = lon(0,0) + opts@end_lat = lat(dims(0)-1,dims(1)-1) + opts@end_lon = lon(dims(0)-1,dims(1)-1) + + +; Set some resources common to all map projections. + opts = set_mp_resources(opts) + + if ( isatt(opts,"ZoomIn") .and. opts@ZoomIn ) then + y1 = 0 + x1 = 0 + y2 = dims(0)-1 + x2 = dims(1)-1 + if ( isatt(opts,"Ystart") ) then + y1 = opts@Ystart + delete(opts@Ystart) + end if + if ( isatt(opts,"Xstart") ) then + x1 = opts@Xstart + delete(opts@Xstart) + end if + if ( isatt(opts,"Yend") ) then + if ( opts@Yend .le. y2 ) then + y2 = opts@Yend + end if + delete(opts@Yend) + end if + if ( isatt(opts,"Xend") ) then + if ( opts@Xend .le. x2 ) then + x2 = opts@Xend + end if + delete(opts@Xend) + end if + + opts@mpLeftCornerLatF = lat(y1,x1) + opts@mpLeftCornerLonF = lon(y1,x1) + opts@mpRightCornerLatF = lat(y2,x2) + opts@mpRightCornerLonF = lon(y2,x2) + + if ( opts@mpRightCornerLonF .lt. 0.0 ) then + opts@mpRightCornerLonF = opts@mpRightCornerLonF + 360.0 + end if + + delete(opts@ZoomIn) + end if + + +; The default is not to draw the plot or advance the frame, and +; to maximize the plot in the frame. + + opts@gsnDraw = get_res_value_keep(opts,"gsnDraw", False) + opts@gsnFrame = get_res_value_keep(opts,"gsnFrame", False) + opts@gsnMaximize = get_res_value_keep(opts,"gsnMaximize", True) + + delete_attrs(opts) ; Clean up. + mp = gsn_map(wks,projection,opts) ; Create map plot. + + return(mp) ; Return. + +end + +;-------------------------------------------------------------------------------- + +undef("mnh_map_overlays") +function mnh_map_overlays(in_file[1]:file, \ + wks:graphic, \ + plots[*]:graphic, \ + opt_arg[1]:logical, \ + opt_mp[1]:logical) + +; Based on wrf_map_overlays +; +; This procedure takes an array of plots and overlays them on a +; base plot - map background. +; +; It will advance the plot and cleanup, unless you set the +; PanelPlot resource to True. +; +; Attributes recognized by this procedure: +; FramePlot +; PanelPlot +; NoTitles (don't do any titles) +; CommonTitle & PlotTile is used to overwrite field titles +; CommonTitle will super-seed NoTitles +; +; If FramePlot False, then Draw the plot but do not Frame. +; In this case a user want to add to the drawing, and will +; have to advance the Frame manually in the script. +; +; If the "NoTitles" attribute exists and is set True, then +; don't create the top-left titles, and leave the main titles alone. +; This resource can be useful if you are planning to panel +; the plots. +; +; If PanelPlot is set to True, then this flags to wrf_map_overlays +; that these plots are going to be eventually paneled (likely +; by gsn_panel), and hence 1) draw and frame should not be called +; (unless gsnDraw and/or gsnFrame are explicitly set to True), +; and 2) the overlays and titles should not be removed with +; NhlRemoveOverlay and NhlRemoveAnnotation. +; +begin + + opts = opt_arg ; Make a copy of the resource lists + opt_mp_2 = opt_mp + + ; Let's make the map first + base = mnh_map(wks,in_file,opt_mp_2) + + no_titles = get_res_value(opts,"NoTitles",False) ; Do we want field titles? + com_title = get_res_value(opts,"CommonTitle",False) ; Do we have a common title? + if ( com_title ) then + plot_title = get_res_value(opts,"PlotTitle"," ") + no_titles = True + end if + + call_draw = True + call_frame = get_res_value(opts,"FramePlot",True) ; Do we want to frame the plot? + panel_plot = get_res_value(opts,"PanelPlot",False) ; Are we paneling? + opts@gsnMaximize = get_res_value_keep(opts,"gsnMaximize", True) + + nplots = dimsizes(plots) +; font_color = "Black" + + do i=0,nplots-1 + if(.not.ismissing(plots(i))) then +; class_name = NhlClassName(plots(i)) +; print(class_name) +; if(class_name.eq."contourPlotClass") then +; getvalues plots(i) +; "cnFillOn" : fill_on +; "cnLineColor" : line_color +; end getvalues +; if (.not.fill_on) then +; font_color = line_color +; end if +; end if + if(.not.no_titles) then + getvalues plots(i) + "tiMainString" : SubTitle + end getvalues + if(i.eq.0) then + SubTitles = SubTitle + else + SubTitles = SubTitles + "~C~" + SubTitle + end if + end if + if(com_title .and. i .eq. nplots-1) then + getvalues plots(i) + "tiMainString" : SubTitle + end getvalues + SubTitles = plot_title + end if + setvalues plots(i) + "tfDoNDCOverlay" : True + "tiMainOn" : False + end setvalues + overlay(base,plots(i)) + else + print("mnh_map_overlays: Warning: overlay plot #" + i + " is not valid.") + end if + end do + + if(.not.no_titles .or. com_title) then + font_height = get_res_value_keep(opts,"FontHeightF",0.01) + txt = create "map_titles" textItemClass wks + "txString" : SubTitles + "txFontHeightF" : font_height + ;"txFontColor" : font_color + end create + anno = NhlAddAnnotation(base,txt) + setvalues anno + "amZone" : 3 + "amJust" : "BottomLeft" + "amSide" : "Top" + "amParallelPosF" : 0.005 + "amOrthogonalPosF" : 0.03 + "amResizeNotify" : False + end setvalues + base@map_titles = anno + end if +; +; gsnDraw and gsnFrame default to False if panel plot. +; + if(panel_plot) then + call_draw = False + call_frame= False + end if + + + opts@gsnDraw = get_res_value_keep(opts,"gsnDraw", call_draw) + opts@gsnFrame = get_res_value_keep(opts,"gsnFrame", call_frame) + + draw_and_frame(wks,base,opts@gsnDraw,opts@gsnFrame,False, \ + opts@gsnMaximize) + + if(.not.panel_plot) then + do i=0,nplots-1 + if(.not.ismissing(plots(i))) then + NhlRemoveOverlay(base,plots(i),False) + else + print("wrf_remove_map_overlays: Warning: overlay plot #" + i + " is not valid.") + print(" Nothing to remove.") + end if + end do + end if + + if(.not.no_titles.and..not.panel_plot) then + if(isatt(base,"map_titles")) then + NhlRemoveAnnotation(base,base@map_titles) + delete(base@map_titles) + end if + end if + +return(base) +end + +;-------------------------------------------------------------------------------- +undef("wrf_user_intrp3d") +function wrf_user_intrp3d( var3d:numeric, z_in:numeric, \ + plot_type:string, \ + loc_param:numeric, angle:numeric, opts:logical ) + +; var3d - 3d field to interpolate (all input fields must be unstaggered) +; z_in - interpolate to this field (either p/z) +; plot_type - interpolate horizontally "h", or vertically "v" +; loc_param - level(s) for horizontal plots (eg. 500hPa ; 3000m - scalar), +; plane for vertical plots (2 values representing an xy point +; on the model domain through which the vertical plane will pass +; OR 4 values specifying start and end values +; angle - 0.0 for horizontal plots, and +; an angle for vertical plots - 90 represent a WE cross section +; opts Used IF opts is TRUE, else use loc_param and angle to determine crosssection + +begin + + + if(plot_type .eq. "h" ) then ; horizontal cross section needed + + dimL = dimsizes(loc_param) + + dims = dimsizes(var3d) + nd = dimsizes(dims) + + dimX = dims(nd-1) + dimY = dims(nd-2) + dimZ = dims(nd-3) + dim4 = 1 + dim5 = 1 + if ( nd .eq. 4 ) then + dim4 = dims(nd-4) + end if + if ( nd .eq. 5 ) then + dim4 = dims(nd-4) + dim5 = dims(nd-5) + end if + + var3 = new ( (/ dim5, dim4, dimZ, dimY, dimX /) , typeof(var3d) ) + z = new ( (/ dim5, dim4, dimZ, dimY, dimX /) , typeof(var3d) ) + var2d = new ( (/ dim5, dim4, dimL, dimY, dimX /) , typeof(var3d) ) + + if ( nd .eq. 5 ) then + var3 = var3d + z = z_in + end if + if ( nd .eq. 4 ) then + var3(0,:,:,:,:) = var3d(:,:,:,:) + z(0,:,:,:,:) = z_in(:,:,:,:) + end if + if ( nd .eq. 3 ) then + var3(0,0,:,:,:) = var3d(:,:,:) + z(0,0,:,:,:) = z_in(:,:,:) + end if + + + if ( z(0,0,0,0,0) .gt. 500.) then + ; We must be interpolating to pressure + ; This routine needs input field and level in hPa - lets make sure of this + if ( z(0,0,0,0,0) .gt. 2000. ) then + ; looks like we have Pa as input - make this hPa + z = z * 0.01 + end if + if ( loc_param(0) .gt. 2000. ) then + ; looks like the input was specified in Pa - change this + loc_param = loc_param * 0.01 + end if + end if + + do il = 0,dimL-1 + var = wrf_interp_3d_z(var3,z,loc_param(il)) + var2d(:,:,il,:,:) = var(:,:,:,:) + end do + + copy_VarAtts(var3d,var3) + if(isatt(var3,"description")) then + delete_VarAtts(var3,(/"description"/)) + end if + if(isatt(var3,"units")) then + delete_VarAtts(var3,(/"units"/)) + end if + if(isatt(var3,"MemoryOrder")) then + delete_VarAtts(var3,(/"MemoryOrder"/)) + end if + if(isatt(var3,"_FillValue")) then + delete_VarAtts(var3,(/"_FillValue"/)) + end if + copy_VarAtts(var3,var2d) + + nn = nd-2 + var2d!nn = "plevs" + + if ( dimL .gt. 1 ) then + if ( nd .eq. 5 ) then + return( var2d ) + end if + if ( nd .eq. 4 ) then + return( var2d(0,:,:,:,:) ) + end if + if ( nd .eq. 3 ) then + return( var2d(0,0,:,:,:) ) + end if + else + if ( z(0,0,0,0,0) .gt. 500.) then + var2d@PlotLevelID = loc_param + " hPa" + else + var2d@PlotLevelID = .001*loc_param + " km" + end if + if ( nd .eq. 5 ) then + return( var2d(:,:,0,:,:) ) + end if + if ( nd .eq. 4 ) then + return( var2d(0,:,0,:,:) ) + end if + if ( nd .eq. 3 ) then + return( var2d(0,0,0,:,:) ) + end if + end if + + + end if + + + + + if(plot_type .eq. "v" ) then ; vertical cross section needed + + dims = dimsizes(var3d) + if ( dimsizes(dims) .eq. 4 ) then + if ( z_in(0,0,0,0) .gt. 500.) then + ; We must be interpolating to pressure + ; This routine needs input field and level in hPa - lets make sure of this + if ( z_in(0,0,0,0) .gt. 2000. ) then + ; looks like we have Pa as input - make this hPa + z_in = z_in * 0.01 + end if + end if + z = z_in(0,:,:,:) + else + if ( z_in(0,0,0) .gt. 500.) then + ; We must be interpolating to pressure + ; This routine needs input field and level in hPa - lets make sure of this + if ( z_in(0,0,0) .gt. 2000. ) then + ; looks like we have Pa as input - make this hPa + z_in = z_in * 0.01 + end if + end if + z = z_in + end if + +; set vertical cross section + if (opts) then + xy = wrf_user_set_xy( z, loc_param(0)-1, loc_param(1)-1, \ ; the -1 is for NCL dimensions + loc_param(2)-1, loc_param(3)-1, \ + angle, opts ) + else + xy = wrf_user_set_xy( z, loc_param(0), loc_param(1), \ + 0.0, 0.0, angle, opts ) + end if + xp = dimsizes(xy) + + +; first we interp z + var2dz = wrf_interp_2d_xy( z, xy) + +; interp to constant z grid + if(var2dz(0,0) .gt. var2dz(1,0) ) then ; monotonically decreasing coordinate + z_max = floor(max(z)/10)*10 ; bottom value + z_min = ceil(min(z)/10)*10 ; top value + dz = 1. + nlevels = tointeger( (z_max-z_min)/dz) + z_var2d = new( (/nlevels/), typeof(z)) + z_var2d(0) = z_max + dz = -dz + else + z_max = max(z) + z_min = 0. +;; MODI SOLINE +; dz = 0.01 * z_max + dz = 0.001 * z_max + nlevels = tointeger( z_max/dz ) + z_var2d = new( (/nlevels/), typeof(z)) + z_var2d(0) = z_min + end if +; print("nlevels="+nlevels) +; print("dz="+dz) + + do i=1, nlevels-1 + z_var2d(i) = z_var2d(0)+i*dz + end do + + +; interp the variable + if ( dimsizes(dims) .eq. 4 ) then + var2d = new( (/dims(0), nlevels, xp(0)/), typeof(var2dz)) + do it = 0,dims(0)-1 + var2dtmp = wrf_interp_2d_xy( var3d(it,:,:,:), xy) + do i=0,xp(0)-1 + var2d(it,:,i) = wrf_interp_1d( var2dtmp(:,i), var2dz(:,i), z_var2d) + end do + end do + var2d!0 = var3d!0 + var2d!1 = "Vertical" + var2d!2 = "Horizontal" + else + var2d = new( (/nlevels, xp(0)/), typeof(var2dz)) + var2dtmp = wrf_interp_2d_xy( var3d, xy) + do i=0,xp(0)-1 + var2d(:,i) = wrf_interp_1d( var2dtmp(:,i), var2dz(:,i), z_var2d) + end do + var2d!0 = "Vertical" + var2d!1 = "Horizontal" + end if + + + st_x = tointeger(xy(0,0)) + 1 + st_y = tointeger(xy(0,1)) + 1 + ed_x = tointeger(xy(xp(0)-1,0)) + 1 + ed_y = tointeger(xy(xp(0)-1,1)) + 1 + if (opts) then + var2d@Orientation = "Cross-Sesion: (" + \ + st_x + "," + st_y + ") to (" + \ + ed_x + "," + ed_y + ")" + else + var2d@Orientation = "Cross-Sesion: (" + \ + st_x + "," + st_y + ") to (" + \ + ed_x + "," + ed_y + ") ; center=(" + \ + loc_param(0) + "," + loc_param(1) + \ + ") ; angle=" + angle + end if + + return(var2d) +end if + + +end + diff --git a/MY_RUN/KTEST/007_16janvier/011_ncl_lfi2cdf/MESONHtools.ncl b/MY_RUN/KTEST/007_16janvier/011_ncl_lfi2cdf/MESONHtools.ncl index 6f810bbfdb30b4e658f289d87d1680a80b5b66fe..9cae6400a0dade82e20ba68463722fbb13d4c81d 100644 --- a/MY_RUN/KTEST/007_16janvier/011_ncl_lfi2cdf/MESONHtools.ncl +++ b/MY_RUN/KTEST/007_16janvier/011_ncl_lfi2cdf/MESONHtools.ncl @@ -1,915 +1,915 @@ -load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" -load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" -load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" -load "$NCARG_ROOT/lib/ncarg/nclscripts/wrf/WRFUserARW.ncl" - -;------------------------------------------------------------- -;contains: -; procedure MESONH_map_c -;function mnh_map(wks[1]:graphic,in_file[1]:file,opt_args[1]:logical) -;function mnh_map_overlays(in_file[1]:file,wks:graphic,plots[*]:graphic, \ -; opt_arg[1]:logical,opt_mp[1]:logical) -;function MESONH_pinter( pfield:numeric, loc_param:numeric, ppabs:numeric ) -;------------------------------------------------------------- - -;============================================================== -; J.-P. CHABOUREAU -; This is a driver that selects the appropriate -; mapping function based upon the file variables RPK, BETA, LATOR, LONOR -; -; -; Sample usage: -; a = addfile("...", r") -; IMAX = a->IMAX -; JMAX = a->JMAX -; lat2d = new((/JMAX,IMAX/),"double") -; lat2d(:,:)=0. -; lon2d = new((/JMAX,IMAX/),"double") -; lon2d(:,:)=0. -; icorners = new((/2,2/),"integer") -; icorners(:,:)=0 -; res = True -; MESONH_map_c (a, res, lat2d, lon2d, icorners) -; -; -undef("MESONH_map_c") -;============================================================== -procedure MESONH_map_c (in_file:file, res:logical, plat, plon, icorner) -;============================================================== -;local rank, dimll, nlat, mlon, lat, lon -local rank, dimll, nlat, mlon -begin - -; Check if the variable RPK is in the file -; ---------------------------------------- -if(isfilevar(in_file,"RPK")) then - -; Read projection parameters -; ------------------------- - ZRPK = in_file->RPK - ZLATOR = in_file->LATOR - ZLONOR = in_file->LONOR - ZBETA = in_file->BETA - ZLAT0 = in_file->LAT0 - ZLON0 = in_file->LON0 - -; Case netcdf from lfi2cdf -; ------------------------- - - if(isfilevar(in_file,"IMAX")) - XHAT=in_file->XHAT - YHAT=in_file->YHAT - IMAX= dimsizes(XHAT)-2 - JMAX= dimsizes(YHAT)-2 - zdx=XHAT(2)-XHAT(1) - zdy=YHAT(2)-YHAT(1) - -; unstagger - do ji=0,IMAX-1 - XHAT(ji)=XHAT(ji)+zdx*1.5 - end do - do jj=0,JMAX-1 - YHAT(jj)=YHAT(jj)+zdy*1.5 - end do - - else - -; Case netcdf from extractdia -; --------------------------- - XHAT=in_file->W_E_direction - YHAT=in_file->S_N_direction - IMAX= dimsizes(XHAT) - JMAX= dimsizes(YHAT) - zdx=XHAT(2)-XHAT(1) - zdy=YHAT(2)-YHAT(1) - - end if - - print ("LATOR="+ZLATOR+" - LONOR="+ZLONOR) - print ("ZLAT0="+ZLAT0+" - ZLON0="+ZLON0) - print ("ZDX="+zdx+" - RPK="+ZRPK+" - BETA="+ZBETA) - print ("IMAX="+IMAX+" - JMAX="+JMAX) - - if (ZRPK.gt.0) - ; Stereographic projection -; --------------------------- - res@mpProjection = "Stereographic" - res@mpCenterLonF = ZLON0 - res@mpCenterRotF = ZBETA - res@mpCenterLatF = 90. - end if - - if (ZRPK.lt.0) - ; Stereographic projection -; --------------------------- - res@mpProjection = "Stereographic" - res@mpCenterLonF = ZLON0 - res@mpCenterRotF = ZBETA - res@mpCenterLatF = -90. - end if - - if (ZRPK.eq.0) then - ; Mercator projection -; --------------------------- - res@mpProjection = "Mercator" - end if - - print("Map projection="+res@mpProjection) - -else - print ("MESONH_map_c: Error no RPK variable in input file") -end if - -;=================================================; -; calculate 2D lat and lon -; based on src/mesonh_MOD/mode_gridproj.f90 -;=================================================; - -; Constants -; ----------- - if(isfilevar(in_file,"IMAX")) - XRADIUS=6371229.0d ; Earth radius (meters) - else - XRADIUS=6371.2290d ; Earth radius (km) - end if - XPI=2.0d*asin(1.) ; Pi - ZRDSDG= XPI/180.0d ; Radian to Degree conversion factor - ZXBM0 = 0.0d - ZYBM0 = 0.0d - -;=================================================; - if (ZRPK.eq.0) then -; MERCATOR -;=================================================; - XBETA=0. - XLAT0=0. ; map reference latitude (degrees) - ZXBM0 = 0. - ZYBM0 = 0. - ZCGAM = cos(-ZRDSDG*XBETA) - ZSGAM = sin(-ZRDSDG*XBETA) - ZRACLAT0 = XRADIUS*cos(ZRDSDG*ZLAT0) - do ji=0,IMAX-1 - jj=0 - ZXMI0 = XHAT(ji)-ZXBM0 - ZYMI0 = YHAT(jj)-ZYBM0 - zlon = (ZXMI0*ZCGAM+ZYMI0*ZSGAM)/(ZRACLAT0*ZRDSDG)+ZLONOR - do jj=0,JMAX-1 - plon(jj,ji)=zlon - end do - end do - do jj=0,JMAX-1 - ji=0 - ZXMI0 = XHAT(ji)-ZXBM0 - ZYMI0 = YHAT(jj)-ZYBM0 - ZT1 = log(tan(XPI/4.+ZLATOR*ZRDSDG/2.)) - ZT2 = (-ZXMI0*ZSGAM+ZYMI0*ZCGAM)/ZRACLAT0 - zlat = (-XPI/2.+2.*atan(exp(ZT1+ZT2)))/ZRDSDG - do ji=0,IMAX-1 - plat(jj,ji)=zlat - end do - end do - -;=================================================; - else -; STEREOGRAPHIC PROJECTION -;=================================================; - ZCLAT0 = cos(ZRDSDG*ZLAT0) - ZSLAT0 = sin(ZRDSDG*ZLAT0) - ZCLATOR = cos(ZRDSDG*ZLATOR) - ZSLATOR = sin(ZRDSDG*ZLATOR) - ZRO0 = (XRADIUS/ZRPK)*(abs(ZCLAT0))^(1.-ZRPK) * \ - ((1.+ZSLAT0)*abs(ZCLATOR)/(1.+ZSLATOR))^ZRPK - ZGA0 = (ZRPK*(ZLONOR-ZLON0)-ZBETA)*ZRDSDG - ZXP = ZXBM0-ZRO0*sin(ZGA0) - ZYP = ZYBM0+ZRO0*cos(ZGA0) - do ji=0,IMAX-1 - do jj=0,JMAX-1 - ZATA = atan2( -(ZXP-XHAT(ji)) , (ZYP-YHAT(jj)) )/ZRDSDG - zlon = (ZBETA+ZATA)/ZRPK+ZLON0 - plon(jj,ji)=zlon - ZRO2 = (XHAT(ji)-ZXP)^2+(YHAT(jj)-ZYP)^2 - ZJD1 = XRADIUS*(abs(ZCLAT0))^(1.-ZRPK) - ZT1 = (ZJD1)^(2./ZRPK)* (1+ZSLAT0)^2 - ZJD3 = (ZRPK^2*ZRO2) - ZT2 = ZJD3 - ZT2 = ZT2^(1./ZRPK) - ZJD1 = (ZT1-ZT2)/(ZT1+ZT2) - ZJD1 = acos(ZJD1) - ZJD3 = ZJD1 - zlat = (XPI/2.-ZJD3)/ZRDSDG - plat(jj,ji)=zlat - end do - end do - - end if - -; Defining the corners of the domain -;==================================== - if (icorner(0,0).eq.icorner(1,1)) then - icorner(0,0)=0 - icorner(1,0)=JMAX-1 - icorner(0,1)=0 - icorner(1,1)=IMAX-1 - end if -; print ("icorner"+icorner) - - res@mpLimitMode = "Corners" - res@mpLeftCornerLatF = plat(icorner(0,0),icorner(0,1)) - res@mpLeftCornerLonF = plon(icorner(0,0),icorner(0,1)) - res@mpRightCornerLatF = plat(icorner(1,0),icorner(1,1)) - res@mpRightCornerLonF = plon(icorner(1,0),icorner(1,1)) - -; print ("Corner (0,0); Lat="+res@mpLeftCornerLatF+ \ -; ", Lon="+res@mpLeftCornerLonF) -; print ("Oppos corner; Lat="+res@mpRightCornerLatF+ \ -; ", Lon= "+res@mpRightCornerLonF) - -;========================================== -; Turn on lat / lon labeling -;========================================== - res@pmTickMarkDisplayMode = "Always" ; turn on tickmarks - res@mpOutlineBoundarySets = "AllBoundaries" ; state boundaries - res@mpPerimDrawOrder = "PostDraw" ; force map perim -;========================================== -; Needed for regional native projection -;========================================== - res@tfDoNDCOverlay = True - res@gsnAddCyclic = False ; regional data - -end - -;=========================================== -;------------------------------------------------------------------------ -undef("MESONH_pinter") -function MESONH_pinter( pfield:numeric, loc_param:numeric, ppabs:numeric ) -;************************************************************************* -; S. BIELLI -; This is a routine that interpolate fields on pressure level for plotting -; based on pinter.f90 -; The field to be interpolated must be given at the mass point (grid 1) -; usage : var_inter=MESONHfunction(var_to_interpol, 850., AbsPressure) -; Abs pressure must be in Pa -; - -begin - - dimL= dimsizes(loc_param) - -; First test for grid = 0 - - dimp=dimsizes(ppabs) - - pout=pfield(0:dimL-1,:,:) - pfield@_FillValue=999 - pout@_FillValue=999 - pout=pout@_FillValue - - do jkp = 0, dimL-1 - zref=log10(loc_param(jkp)*100.) - do jloop = 0, dimp(1)-1 - do iloop = 0, dimp(2)-1 - kloop=0 - flag=True - do while (flag .and. (kloop.lt.(dimp(2)-2))) - if (.not.ismissing(ppabs(kloop,jloop,iloop))) then - zxm=log10(ppabs(kloop,jloop,iloop)) - zxp=log10(ppabs(kloop+1,jloop,iloop)) - if ((zxp-zref)*(zref-zxm) .ge. 0) then - pout(jkp,jloop,iloop)= (pfield(kloop,jloop,iloop)*(zxp-zref)+ \ - pfield(kloop+1,jloop,iloop)*(zref-zxm))/ (zxp-zxm) - flag=False - end if - end if - kloop=kloop+1 - end do - end do - end do - end do - - return(pout) - -end - -;-------------------------------------------------------------------------------- -undef("mnh_map") -function mnh_map(wks[1]:graphic,in_file[1]:file,opt_args[1]:logical) - -begin -; -; This function creates a map plot, and bases the projection on -; the MAP_PROJ attribute in the given file. -; -; 1. Make a copy of the resource list, and set some resources -; common to all map projections. -; -; 2. Determine the projection being used, and set resources based -; on that projection. -; -; 3. Create the map plot, and draw and advance the frame -; (if requested). - - opts = opt_args ; Make a copy of the resource list - opts = True - -; Set some resources depending on what kind of map projection is -; chosen. -; -; ZRPK != 0 : "Stereographic" -; ZRPK = 0 : "Mercator" -;=================================================; -; src/mesonh_MOD/mode_gridproj.f90 -;=================================================; - XRADIUS=6371229.0d ; Earth radius (meters) - XPI=2.0d*asin(1.) ; Pi - ZRDSDG= XPI/180.0d ; Radian to Degree conversion factor - ZXBM0 = 0.0d - ZYBM0 = 0.0d - - if(isfilevar(in_file,"RPK")) - ZRPK=in_file->RPK - ZLON0=in_file->LON0 - ZLAT0=in_file->LAT0 - ZLATOR=in_file->LATOR - ZLONOR=in_file->LONOR - ZBETA=in_file->BETA - else - print ("mnh_map: Error no RPK variable in input file") - return(new(1,graphic)) - end if - -; Case netcdf from lfi2cdf - if(isfilevar(in_file,"IMAX")) - XHAT=in_file->XHAT - YHAT=in_file->YHAT - IMAX= dimsizes(XHAT)-2 - JMAX= dimsizes(YHAT)-2 - zdx=XHAT(2)-XHAT(1) - zdy=YHAT(2)-YHAT(1) - do ji=0,IMAX-1 - XHAT(ji)=XHAT(ji)+zdx*1.5 - end do - do jj=0,JMAX-1 - YHAT(jj)=YHAT(jj)+zdy*1.5 - end do - else -; Case netcdf from extractdia - XHAT=in_file->W_E_direction - YHAT=in_file->S_N_direction - IMAX= dimsizes(XHAT) - JMAX= dimsizes(YHAT) - end if -; - - lat = new((/JMAX,IMAX/),"double") - lon = new((/JMAX,IMAX/),"double") - - -; Stereographic projection - if(ZRPK .gt. 0) - projection = "Stereographic" - opts@mpCenterLatF = get_res_value_keep(opts, "mpCenterLatF", 90) - opts@mpCenterLonF = get_res_value_keep(opts, "mpCenterLonF",ZLON0) - opts@mpCenterRotF = get_res_value_keep(opts, "mpCenterRotF",ZBETA) - end if - - if(ZRPK .lt. 0) - projection = "Stereographic" - opts@mpCenterLatF = get_res_value_keep(opts, "mpCenterLatF", -90) - opts@mpCenterLonF = get_res_value_keep(opts, "mpCenterLonF",ZLON0) - opts@mpCenterRotF = get_res_value_keep(opts, "mpCenterRotF",ZBETA) - end if - -; Mercator projection - if(ZRPK .eq. 0) - projection = "Mercator" - end if - - opts@mpNestTime = get_res_value_keep(opts, "mpNestTime",0) - - -; LAT and LON are not saved in the file - if (ZRPK.eq.0) then - XBETA=0. - XLAT0=0. ; map reference latitude (degrees) - ZXBM0 = 0. - ZYBM0 = 0. - ZCGAM = cos(-ZRDSDG*XBETA) - ZSGAM = sin(-ZRDSDG*XBETA) - ZRACLAT0 = XRADIUS*cos(ZRDSDG*ZLAT0) - do ji=0,IMAX-1 - jj=0 - ZXMI0 = XHAT(ji)-ZXBM0 - ZYMI0 = YHAT(jj)-ZYBM0 - zlon = (ZXMI0*ZCGAM+ZYMI0*ZSGAM)/(ZRACLAT0*ZRDSDG)+ZLONOR - do jj=0,JMAX-1 - lon(jj,ji)=zlon - end do - end do - do jj=0,JMAX-1 - ji=0 - ZXMI0 = XHAT(ji)-ZXBM0 - ZYMI0 = YHAT(jj)-ZYBM0 - ZT1 = log(tan(XPI/4.+ZLATOR*ZRDSDG/2.)) - ZT2 = (-ZXMI0*ZSGAM+ZYMI0*ZCGAM)/ZRACLAT0 - zlat = (-XPI/2.+2.*atan(exp(ZT1+ZT2)))/ZRDSDG - do ji=0,IMAX-1 - lat(jj,ji)=zlat - end do - end do - else - ZCLAT0 = cos(ZRDSDG*ZLAT0) - ZSLAT0 = sin(ZRDSDG*ZLAT0) - ZCLATOR = cos(ZRDSDG*ZLATOR) - ZSLATOR = sin(ZRDSDG*ZLATOR) - ZRO0 = (XRADIUS/ZRPK)*(abs(ZCLAT0))^(1.-ZRPK) * \ - ((1.+ZSLAT0)*abs(ZCLATOR)/(1.+ZSLATOR))^ZRPK - ZGA0 = (ZRPK*(ZLONOR-ZLON0)-ZBETA)*ZRDSDG - ZXP = ZXBM0-ZRO0*sin(ZGA0) - ZYP = ZYBM0+ZRO0*cos(ZGA0) - do ji=0,IMAX-1 - do jj=0,JMAX-1 - ZATA = atan2( -(ZXP-XHAT(ji)) , (ZYP-YHAT(jj)) )/ZRDSDG - zlon = (ZBETA+ZATA)/ZRPK+ZLON0 - lon(jj,ji)=zlon - ZRO2 = (XHAT(ji)-ZXP)^2+(YHAT(jj)-ZYP)^2 - ZJD1 = XRADIUS*(abs(ZCLAT0))^(1.-ZRPK) - ZT1 = (ZJD1)^(2./ZRPK)* (1+ZSLAT0)^2 - ZJD3 = (ZRPK^2*ZRO2) - ZT2 = ZJD3 - ZT2 = ZT2^(1./ZRPK) - ZJD1 = (ZT1-ZT2)/(ZT1+ZT2) - ZJD1 = acos(ZJD1) - ZJD3 = ZJD1 - zlat = (XPI/2.-ZJD3)/ZRDSDG - lat(jj,ji)=zlat - end do - end do - end if - - dims = dimsizes(lat) - - do ii = 0, dims(0)-1 - do jj = 0, dims(1)-1 - if ( lon(ii,jj) .lt. 0.0) then - lon(ii,jj) = lon(ii,jj) + 360. - end if - end do - end do - - opts@start_lat = lat(0,0) - opts@start_lon = lon(0,0) - opts@end_lat = lat(dims(0)-1,dims(1)-1) - opts@end_lon = lon(dims(0)-1,dims(1)-1) - - -; Set some resources common to all map projections. - opts = set_mp_resources(opts) - - if ( isatt(opts,"ZoomIn") .and. opts@ZoomIn ) then - y1 = 0 - x1 = 0 - y2 = dims(0)-1 - x2 = dims(1)-1 - if ( isatt(opts,"Ystart") ) then - y1 = opts@Ystart - delete(opts@Ystart) - end if - if ( isatt(opts,"Xstart") ) then - x1 = opts@Xstart - delete(opts@Xstart) - end if - if ( isatt(opts,"Yend") ) then - if ( opts@Yend .le. y2 ) then - y2 = opts@Yend - end if - delete(opts@Yend) - end if - if ( isatt(opts,"Xend") ) then - if ( opts@Xend .le. x2 ) then - x2 = opts@Xend - end if - delete(opts@Xend) - end if - - opts@mpLeftCornerLatF = lat(y1,x1) - opts@mpLeftCornerLonF = lon(y1,x1) - opts@mpRightCornerLatF = lat(y2,x2) - opts@mpRightCornerLonF = lon(y2,x2) - - if ( opts@mpRightCornerLonF .lt. 0.0 ) then - opts@mpRightCornerLonF = opts@mpRightCornerLonF + 360.0 - end if - - delete(opts@ZoomIn) - end if - - -; The default is not to draw the plot or advance the frame, and -; to maximize the plot in the frame. - - opts@gsnDraw = get_res_value_keep(opts,"gsnDraw", False) - opts@gsnFrame = get_res_value_keep(opts,"gsnFrame", False) - opts@gsnMaximize = get_res_value_keep(opts,"gsnMaximize", True) - - delete_attrs(opts) ; Clean up. - mp = gsn_map(wks,projection,opts) ; Create map plot. - - return(mp) ; Return. - -end - -;-------------------------------------------------------------------------------- - -undef("mnh_map_overlays") -function mnh_map_overlays(in_file[1]:file, \ - wks:graphic, \ - plots[*]:graphic, \ - opt_arg[1]:logical, \ - opt_mp[1]:logical) - -; Based on wrf_map_overlays -; -; This procedure takes an array of plots and overlays them on a -; base plot - map background. -; -; It will advance the plot and cleanup, unless you set the -; PanelPlot resource to True. -; -; Attributes recognized by this procedure: -; FramePlot -; PanelPlot -; NoTitles (don't do any titles) -; CommonTitle & PlotTile is used to overwrite field titles -; CommonTitle will super-seed NoTitles -; -; If FramePlot False, then Draw the plot but do not Frame. -; In this case a user want to add to the drawing, and will -; have to advance the Frame manually in the script. -; -; If the "NoTitles" attribute exists and is set True, then -; don't create the top-left titles, and leave the main titles alone. -; This resource can be useful if you are planning to panel -; the plots. -; -; If PanelPlot is set to True, then this flags to wrf_map_overlays -; that these plots are going to be eventually paneled (likely -; by gsn_panel), and hence 1) draw and frame should not be called -; (unless gsnDraw and/or gsnFrame are explicitly set to True), -; and 2) the overlays and titles should not be removed with -; NhlRemoveOverlay and NhlRemoveAnnotation. -; -begin - - opts = opt_arg ; Make a copy of the resource lists - opt_mp_2 = opt_mp - - ; Let's make the map first - base = mnh_map(wks,in_file,opt_mp_2) - - no_titles = get_res_value(opts,"NoTitles",False) ; Do we want field titles? - com_title = get_res_value(opts,"CommonTitle",False) ; Do we have a common title? - if ( com_title ) then - plot_title = get_res_value(opts,"PlotTitle"," ") - no_titles = True - end if - - call_draw = True - call_frame = get_res_value(opts,"FramePlot",True) ; Do we want to frame the plot? - panel_plot = get_res_value(opts,"PanelPlot",False) ; Are we paneling? - opts@gsnMaximize = get_res_value_keep(opts,"gsnMaximize", True) - - nplots = dimsizes(plots) -; font_color = "Black" - - do i=0,nplots-1 - if(.not.ismissing(plots(i))) then -; class_name = NhlClassName(plots(i)) -; print(class_name) -; if(class_name.eq."contourPlotClass") then -; getvalues plots(i) -; "cnFillOn" : fill_on -; "cnLineColor" : line_color -; end getvalues -; if (.not.fill_on) then -; font_color = line_color -; end if -; end if - if(.not.no_titles) then - getvalues plots(i) - "tiMainString" : SubTitle - end getvalues - if(i.eq.0) then - SubTitles = SubTitle - else - SubTitles = SubTitles + "~C~" + SubTitle - end if - end if - if(com_title .and. i .eq. nplots-1) then - getvalues plots(i) - "tiMainString" : SubTitle - end getvalues - SubTitles = plot_title - end if - setvalues plots(i) - "tfDoNDCOverlay" : True - "tiMainOn" : False - end setvalues - overlay(base,plots(i)) - else - print("mnh_map_overlays: Warning: overlay plot #" + i + " is not valid.") - end if - end do - - if(.not.no_titles .or. com_title) then - font_height = get_res_value_keep(opts,"FontHeightF",0.01) - txt = create "map_titles" textItemClass wks - "txString" : SubTitles - "txFontHeightF" : font_height - ;"txFontColor" : font_color - end create - anno = NhlAddAnnotation(base,txt) - setvalues anno - "amZone" : 3 - "amJust" : "BottomLeft" - "amSide" : "Top" - "amParallelPosF" : 0.005 - "amOrthogonalPosF" : 0.03 - "amResizeNotify" : False - end setvalues - base@map_titles = anno - end if -; -; gsnDraw and gsnFrame default to False if panel plot. -; - if(panel_plot) then - call_draw = False - call_frame= False - end if - - - opts@gsnDraw = get_res_value_keep(opts,"gsnDraw", call_draw) - opts@gsnFrame = get_res_value_keep(opts,"gsnFrame", call_frame) - - draw_and_frame(wks,base,opts@gsnDraw,opts@gsnFrame,False, \ - opts@gsnMaximize) - - if(.not.panel_plot) then - do i=0,nplots-1 - if(.not.ismissing(plots(i))) then - NhlRemoveOverlay(base,plots(i),False) - else - print("wrf_remove_map_overlays: Warning: overlay plot #" + i + " is not valid.") - print(" Nothing to remove.") - end if - end do - end if - - if(.not.no_titles.and..not.panel_plot) then - if(isatt(base,"map_titles")) then - NhlRemoveAnnotation(base,base@map_titles) - delete(base@map_titles) - end if - end if - -return(base) -end - -;-------------------------------------------------------------------------------- -undef("wrf_user_intrp3d") -function wrf_user_intrp3d( var3d:numeric, z_in:numeric, \ - plot_type:string, \ - loc_param:numeric, angle:numeric, opts:logical ) - -; var3d - 3d field to interpolate (all input fields must be unstaggered) -; z_in - interpolate to this field (either p/z) -; plot_type - interpolate horizontally "h", or vertically "v" -; loc_param - level(s) for horizontal plots (eg. 500hPa ; 3000m - scalar), -; plane for vertical plots (2 values representing an xy point -; on the model domain through which the vertical plane will pass -; OR 4 values specifying start and end values -; angle - 0.0 for horizontal plots, and -; an angle for vertical plots - 90 represent a WE cross section -; opts Used IF opts is TRUE, else use loc_param and angle to determine crosssection - -begin - - - if(plot_type .eq. "h" ) then ; horizontal cross section needed - - dimL = dimsizes(loc_param) - - dims = dimsizes(var3d) - nd = dimsizes(dims) - - dimX = dims(nd-1) - dimY = dims(nd-2) - dimZ = dims(nd-3) - dim4 = 1 - dim5 = 1 - if ( nd .eq. 4 ) then - dim4 = dims(nd-4) - end if - if ( nd .eq. 5 ) then - dim4 = dims(nd-4) - dim5 = dims(nd-5) - end if - - var3 = new ( (/ dim5, dim4, dimZ, dimY, dimX /) , typeof(var3d) ) - z = new ( (/ dim5, dim4, dimZ, dimY, dimX /) , typeof(var3d) ) - var2d = new ( (/ dim5, dim4, dimL, dimY, dimX /) , typeof(var3d) ) - - if ( nd .eq. 5 ) then - var3 = var3d - z = z_in - end if - if ( nd .eq. 4 ) then - var3(0,:,:,:,:) = var3d(:,:,:,:) - z(0,:,:,:,:) = z_in(:,:,:,:) - end if - if ( nd .eq. 3 ) then - var3(0,0,:,:,:) = var3d(:,:,:) - z(0,0,:,:,:) = z_in(:,:,:) - end if - - - if ( z(0,0,0,0,0) .gt. 500.) then - ; We must be interpolating to pressure - ; This routine needs input field and level in hPa - lets make sure of this - if ( z(0,0,0,0,0) .gt. 2000. ) then - ; looks like we have Pa as input - make this hPa - z = z * 0.01 - end if - if ( loc_param(0) .gt. 2000. ) then - ; looks like the input was specified in Pa - change this - loc_param = loc_param * 0.01 - end if - end if - - do il = 0,dimL-1 - var = wrf_interp_3d_z(var3,z,loc_param(il)) - var2d(:,:,il,:,:) = var(:,:,:,:) - end do - - copy_VarAtts(var3d,var3) - if(isatt(var3,"description")) then - delete_VarAtts(var3,(/"description"/)) - end if - if(isatt(var3,"units")) then - delete_VarAtts(var3,(/"units"/)) - end if - if(isatt(var3,"MemoryOrder")) then - delete_VarAtts(var3,(/"MemoryOrder"/)) - end if - if(isatt(var3,"_FillValue")) then - delete_VarAtts(var3,(/"_FillValue"/)) - end if - copy_VarAtts(var3,var2d) - - nn = nd-2 - var2d!nn = "plevs" - - if ( dimL .gt. 1 ) then - if ( nd .eq. 5 ) then - return( var2d ) - end if - if ( nd .eq. 4 ) then - return( var2d(0,:,:,:,:) ) - end if - if ( nd .eq. 3 ) then - return( var2d(0,0,:,:,:) ) - end if - else - if ( z(0,0,0,0,0) .gt. 500.) then - var2d@PlotLevelID = loc_param + " hPa" - else - var2d@PlotLevelID = .001*loc_param + " km" - end if - if ( nd .eq. 5 ) then - return( var2d(:,:,0,:,:) ) - end if - if ( nd .eq. 4 ) then - return( var2d(0,:,0,:,:) ) - end if - if ( nd .eq. 3 ) then - return( var2d(0,0,0,:,:) ) - end if - end if - - - end if - - - - - if(plot_type .eq. "v" ) then ; vertical cross section needed - - dims = dimsizes(var3d) - if ( dimsizes(dims) .eq. 4 ) then - if ( z_in(0,0,0,0) .gt. 500.) then - ; We must be interpolating to pressure - ; This routine needs input field and level in hPa - lets make sure of this - if ( z_in(0,0,0,0) .gt. 2000. ) then - ; looks like we have Pa as input - make this hPa - z_in = z_in * 0.01 - end if - end if - z = z_in(0,:,:,:) - else - if ( z_in(0,0,0) .gt. 500.) then - ; We must be interpolating to pressure - ; This routine needs input field and level in hPa - lets make sure of this - if ( z_in(0,0,0) .gt. 2000. ) then - ; looks like we have Pa as input - make this hPa - z_in = z_in * 0.01 - end if - end if - z = z_in - end if - -; set vertical cross section - if (opts) then - xy = wrf_user_set_xy( z, loc_param(0)-1, loc_param(1)-1, \ ; the -1 is for NCL dimensions - loc_param(2)-1, loc_param(3)-1, \ - angle, opts ) - else - xy = wrf_user_set_xy( z, loc_param(0), loc_param(1), \ - 0.0, 0.0, angle, opts ) - end if - xp = dimsizes(xy) - - -; first we interp z - var2dz = wrf_interp_2d_xy( z, xy) - -; interp to constant z grid - if(var2dz(0,0) .gt. var2dz(1,0) ) then ; monotonically decreasing coordinate - z_max = floor(max(z)/10)*10 ; bottom value - z_min = ceil(min(z)/10)*10 ; top value - dz = 1. - nlevels = tointeger( (z_max-z_min)/dz) - z_var2d = new( (/nlevels/), typeof(z)) - z_var2d(0) = z_max - dz = -dz - else - z_max = max(z) - z_min = 0. -;; MODI SOLINE -; dz = 0.01 * z_max - dz = 0.001 * z_max - nlevels = tointeger( z_max/dz ) - z_var2d = new( (/nlevels/), typeof(z)) - z_var2d(0) = z_min - end if -; print("nlevels="+nlevels) -; print("dz="+dz) - - do i=1, nlevels-1 - z_var2d(i) = z_var2d(0)+i*dz - end do - - -; interp the variable - if ( dimsizes(dims) .eq. 4 ) then - var2d = new( (/dims(0), nlevels, xp(0)/), typeof(var2dz)) - do it = 0,dims(0)-1 - var2dtmp = wrf_interp_2d_xy( var3d(it,:,:,:), xy) - do i=0,xp(0)-1 - var2d(it,:,i) = wrf_interp_1d( var2dtmp(:,i), var2dz(:,i), z_var2d) - end do - end do - var2d!0 = var3d!0 - var2d!1 = "Vertical" - var2d!2 = "Horizontal" - else - var2d = new( (/nlevels, xp(0)/), typeof(var2dz)) - var2dtmp = wrf_interp_2d_xy( var3d, xy) - do i=0,xp(0)-1 - var2d(:,i) = wrf_interp_1d( var2dtmp(:,i), var2dz(:,i), z_var2d) - end do - var2d!0 = "Vertical" - var2d!1 = "Horizontal" - end if - - - st_x = tointeger(xy(0,0)) + 1 - st_y = tointeger(xy(0,1)) + 1 - ed_x = tointeger(xy(xp(0)-1,0)) + 1 - ed_y = tointeger(xy(xp(0)-1,1)) + 1 - if (opts) then - var2d@Orientation = "Cross-Sesion: (" + \ - st_x + "," + st_y + ") to (" + \ - ed_x + "," + ed_y + ")" - else - var2d@Orientation = "Cross-Sesion: (" + \ - st_x + "," + st_y + ") to (" + \ - ed_x + "," + ed_y + ") ; center=(" + \ - loc_param(0) + "," + loc_param(1) + \ - ") ; angle=" + angle - end if - - return(var2d) -end if - - -end - +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/wrf/WRFUserARW.ncl" + +;------------------------------------------------------------- +;contains: +; procedure MESONH_map_c +;function mnh_map(wks[1]:graphic,in_file[1]:file,opt_args[1]:logical) +;function mnh_map_overlays(in_file[1]:file,wks:graphic,plots[*]:graphic, \ +; opt_arg[1]:logical,opt_mp[1]:logical) +;function MESONH_pinter( pfield:numeric, loc_param:numeric, ppabs:numeric ) +;------------------------------------------------------------- + +;============================================================== +; J.-P. CHABOUREAU +; This is a driver that selects the appropriate +; mapping function based upon the file variables RPK, BETA, LATOR, LONOR +; +; +; Sample usage: +; a = addfile("...", r") +; IMAX = a->IMAX +; JMAX = a->JMAX +; lat2d = new((/JMAX,IMAX/),"double") +; lat2d(:,:)=0. +; lon2d = new((/JMAX,IMAX/),"double") +; lon2d(:,:)=0. +; icorners = new((/2,2/),"integer") +; icorners(:,:)=0 +; res = True +; MESONH_map_c (a, res, lat2d, lon2d, icorners) +; +; +undef("MESONH_map_c") +;============================================================== +procedure MESONH_map_c (in_file:file, res:logical, plat, plon, icorner) +;============================================================== +;local rank, dimll, nlat, mlon, lat, lon +local rank, dimll, nlat, mlon +begin + +; Check if the variable RPK is in the file +; ---------------------------------------- +if(isfilevar(in_file,"RPK")) then + +; Read projection parameters +; ------------------------- + ZRPK = in_file->RPK + ZLATOR = in_file->LATOR + ZLONOR = in_file->LONOR + ZBETA = in_file->BETA + ZLAT0 = in_file->LAT0 + ZLON0 = in_file->LON0 + +; Case netcdf from lfi2cdf +; ------------------------- + + if(isfilevar(in_file,"IMAX")) + XHAT=in_file->XHAT + YHAT=in_file->YHAT + IMAX= dimsizes(XHAT)-2 + JMAX= dimsizes(YHAT)-2 + zdx=XHAT(2)-XHAT(1) + zdy=YHAT(2)-YHAT(1) + +; unstagger + do ji=0,IMAX-1 + XHAT(ji)=XHAT(ji)+zdx*1.5 + end do + do jj=0,JMAX-1 + YHAT(jj)=YHAT(jj)+zdy*1.5 + end do + + else + +; Case netcdf from extractdia +; --------------------------- + XHAT=in_file->W_E_direction + YHAT=in_file->S_N_direction + IMAX= dimsizes(XHAT) + JMAX= dimsizes(YHAT) + zdx=XHAT(2)-XHAT(1) + zdy=YHAT(2)-YHAT(1) + + end if + + print ("LATOR="+ZLATOR+" - LONOR="+ZLONOR) + print ("ZLAT0="+ZLAT0+" - ZLON0="+ZLON0) + print ("ZDX="+zdx+" - RPK="+ZRPK+" - BETA="+ZBETA) + print ("IMAX="+IMAX+" - JMAX="+JMAX) + + if (ZRPK.gt.0) + ; Stereographic projection +; --------------------------- + res@mpProjection = "Stereographic" + res@mpCenterLonF = ZLON0 + res@mpCenterRotF = ZBETA + res@mpCenterLatF = 90. + end if + + if (ZRPK.lt.0) + ; Stereographic projection +; --------------------------- + res@mpProjection = "Stereographic" + res@mpCenterLonF = ZLON0 + res@mpCenterRotF = ZBETA + res@mpCenterLatF = -90. + end if + + if (ZRPK.eq.0) then + ; Mercator projection +; --------------------------- + res@mpProjection = "Mercator" + end if + + print("Map projection="+res@mpProjection) + +else + print ("MESONH_map_c: Error no RPK variable in input file") +end if + +;=================================================; +; calculate 2D lat and lon +; based on src/mesonh_MOD/mode_gridproj.f90 +;=================================================; + +; Constants +; ----------- + if(isfilevar(in_file,"IMAX")) + XRADIUS=6371229.0d ; Earth radius (meters) + else + XRADIUS=6371.2290d ; Earth radius (km) + end if + XPI=2.0d*asin(1.) ; Pi + ZRDSDG= XPI/180.0d ; Radian to Degree conversion factor + ZXBM0 = 0.0d + ZYBM0 = 0.0d + +;=================================================; + if (ZRPK.eq.0) then +; MERCATOR +;=================================================; + XBETA=0. + XLAT0=0. ; map reference latitude (degrees) + ZXBM0 = 0. + ZYBM0 = 0. + ZCGAM = cos(-ZRDSDG*XBETA) + ZSGAM = sin(-ZRDSDG*XBETA) + ZRACLAT0 = XRADIUS*cos(ZRDSDG*ZLAT0) + do ji=0,IMAX-1 + jj=0 + ZXMI0 = XHAT(ji)-ZXBM0 + ZYMI0 = YHAT(jj)-ZYBM0 + zlon = (ZXMI0*ZCGAM+ZYMI0*ZSGAM)/(ZRACLAT0*ZRDSDG)+ZLONOR + do jj=0,JMAX-1 + plon(jj,ji)=zlon + end do + end do + do jj=0,JMAX-1 + ji=0 + ZXMI0 = XHAT(ji)-ZXBM0 + ZYMI0 = YHAT(jj)-ZYBM0 + ZT1 = log(tan(XPI/4.+ZLATOR*ZRDSDG/2.)) + ZT2 = (-ZXMI0*ZSGAM+ZYMI0*ZCGAM)/ZRACLAT0 + zlat = (-XPI/2.+2.*atan(exp(ZT1+ZT2)))/ZRDSDG + do ji=0,IMAX-1 + plat(jj,ji)=zlat + end do + end do + +;=================================================; + else +; STEREOGRAPHIC PROJECTION +;=================================================; + ZCLAT0 = cos(ZRDSDG*ZLAT0) + ZSLAT0 = sin(ZRDSDG*ZLAT0) + ZCLATOR = cos(ZRDSDG*ZLATOR) + ZSLATOR = sin(ZRDSDG*ZLATOR) + ZRO0 = (XRADIUS/ZRPK)*(abs(ZCLAT0))^(1.-ZRPK) * \ + ((1.+ZSLAT0)*abs(ZCLATOR)/(1.+ZSLATOR))^ZRPK + ZGA0 = (ZRPK*(ZLONOR-ZLON0)-ZBETA)*ZRDSDG + ZXP = ZXBM0-ZRO0*sin(ZGA0) + ZYP = ZYBM0+ZRO0*cos(ZGA0) + do ji=0,IMAX-1 + do jj=0,JMAX-1 + ZATA = atan2( -(ZXP-XHAT(ji)) , (ZYP-YHAT(jj)) )/ZRDSDG + zlon = (ZBETA+ZATA)/ZRPK+ZLON0 + plon(jj,ji)=zlon + ZRO2 = (XHAT(ji)-ZXP)^2+(YHAT(jj)-ZYP)^2 + ZJD1 = XRADIUS*(abs(ZCLAT0))^(1.-ZRPK) + ZT1 = (ZJD1)^(2./ZRPK)* (1+ZSLAT0)^2 + ZJD3 = (ZRPK^2*ZRO2) + ZT2 = ZJD3 + ZT2 = ZT2^(1./ZRPK) + ZJD1 = (ZT1-ZT2)/(ZT1+ZT2) + ZJD1 = acos(ZJD1) + ZJD3 = ZJD1 + zlat = (XPI/2.-ZJD3)/ZRDSDG + plat(jj,ji)=zlat + end do + end do + + end if + +; Defining the corners of the domain +;==================================== + if (icorner(0,0).eq.icorner(1,1)) then + icorner(0,0)=0 + icorner(1,0)=JMAX-1 + icorner(0,1)=0 + icorner(1,1)=IMAX-1 + end if +; print ("icorner"+icorner) + + res@mpLimitMode = "Corners" + res@mpLeftCornerLatF = plat(icorner(0,0),icorner(0,1)) + res@mpLeftCornerLonF = plon(icorner(0,0),icorner(0,1)) + res@mpRightCornerLatF = plat(icorner(1,0),icorner(1,1)) + res@mpRightCornerLonF = plon(icorner(1,0),icorner(1,1)) + +; print ("Corner (0,0); Lat="+res@mpLeftCornerLatF+ \ +; ", Lon="+res@mpLeftCornerLonF) +; print ("Oppos corner; Lat="+res@mpRightCornerLatF+ \ +; ", Lon= "+res@mpRightCornerLonF) + +;========================================== +; Turn on lat / lon labeling +;========================================== + res@pmTickMarkDisplayMode = "Always" ; turn on tickmarks + res@mpOutlineBoundarySets = "AllBoundaries" ; state boundaries + res@mpPerimDrawOrder = "PostDraw" ; force map perim +;========================================== +; Needed for regional native projection +;========================================== + res@tfDoNDCOverlay = True + res@gsnAddCyclic = False ; regional data + +end + +;=========================================== +;------------------------------------------------------------------------ +undef("MESONH_pinter") +function MESONH_pinter( pfield:numeric, loc_param:numeric, ppabs:numeric ) +;************************************************************************* +; S. BIELLI +; This is a routine that interpolate fields on pressure level for plotting +; based on pinter.f90 +; The field to be interpolated must be given at the mass point (grid 1) +; usage : var_inter=MESONHfunction(var_to_interpol, 850., AbsPressure) +; Abs pressure must be in Pa +; + +begin + + dimL= dimsizes(loc_param) + +; First test for grid = 0 + + dimp=dimsizes(ppabs) + + pout=pfield(0:dimL-1,:,:) + pfield@_FillValue=999 + pout@_FillValue=999 + pout=pout@_FillValue + + do jkp = 0, dimL-1 + zref=log10(loc_param(jkp)*100.) + do jloop = 0, dimp(1)-1 + do iloop = 0, dimp(2)-1 + kloop=0 + flag=True + do while (flag .and. (kloop.lt.(dimp(2)-2))) + if (.not.ismissing(ppabs(kloop,jloop,iloop))) then + zxm=log10(ppabs(kloop,jloop,iloop)) + zxp=log10(ppabs(kloop+1,jloop,iloop)) + if ((zxp-zref)*(zref-zxm) .ge. 0) then + pout(jkp,jloop,iloop)= (pfield(kloop,jloop,iloop)*(zxp-zref)+ \ + pfield(kloop+1,jloop,iloop)*(zref-zxm))/ (zxp-zxm) + flag=False + end if + end if + kloop=kloop+1 + end do + end do + end do + end do + + return(pout) + +end + +;-------------------------------------------------------------------------------- +undef("mnh_map") +function mnh_map(wks[1]:graphic,in_file[1]:file,opt_args[1]:logical) + +begin +; +; This function creates a map plot, and bases the projection on +; the MAP_PROJ attribute in the given file. +; +; 1. Make a copy of the resource list, and set some resources +; common to all map projections. +; +; 2. Determine the projection being used, and set resources based +; on that projection. +; +; 3. Create the map plot, and draw and advance the frame +; (if requested). + + opts = opt_args ; Make a copy of the resource list + opts = True + +; Set some resources depending on what kind of map projection is +; chosen. +; +; ZRPK != 0 : "Stereographic" +; ZRPK = 0 : "Mercator" +;=================================================; +; src/mesonh_MOD/mode_gridproj.f90 +;=================================================; + XRADIUS=6371229.0d ; Earth radius (meters) + XPI=2.0d*asin(1.) ; Pi + ZRDSDG= XPI/180.0d ; Radian to Degree conversion factor + ZXBM0 = 0.0d + ZYBM0 = 0.0d + + if(isfilevar(in_file,"RPK")) + ZRPK=in_file->RPK + ZLON0=in_file->LON0 + ZLAT0=in_file->LAT0 + ZLATOR=in_file->LATOR + ZLONOR=in_file->LONOR + ZBETA=in_file->BETA + else + print ("mnh_map: Error no RPK variable in input file") + return(new(1,graphic)) + end if + +; Case netcdf from lfi2cdf + if(isfilevar(in_file,"IMAX")) + XHAT=in_file->XHAT + YHAT=in_file->YHAT + IMAX= dimsizes(XHAT)-2 + JMAX= dimsizes(YHAT)-2 + zdx=XHAT(2)-XHAT(1) + zdy=YHAT(2)-YHAT(1) + do ji=0,IMAX-1 + XHAT(ji)=XHAT(ji)+zdx*1.5 + end do + do jj=0,JMAX-1 + YHAT(jj)=YHAT(jj)+zdy*1.5 + end do + else +; Case netcdf from extractdia + XHAT=in_file->W_E_direction + YHAT=in_file->S_N_direction + IMAX= dimsizes(XHAT) + JMAX= dimsizes(YHAT) + end if +; + + lat = new((/JMAX,IMAX/),"double") + lon = new((/JMAX,IMAX/),"double") + + +; Stereographic projection + if(ZRPK .gt. 0) + projection = "Stereographic" + opts@mpCenterLatF = get_res_value_keep(opts, "mpCenterLatF", 90) + opts@mpCenterLonF = get_res_value_keep(opts, "mpCenterLonF",ZLON0) + opts@mpCenterRotF = get_res_value_keep(opts, "mpCenterRotF",ZBETA) + end if + + if(ZRPK .lt. 0) + projection = "Stereographic" + opts@mpCenterLatF = get_res_value_keep(opts, "mpCenterLatF", -90) + opts@mpCenterLonF = get_res_value_keep(opts, "mpCenterLonF",ZLON0) + opts@mpCenterRotF = get_res_value_keep(opts, "mpCenterRotF",ZBETA) + end if + +; Mercator projection + if(ZRPK .eq. 0) + projection = "Mercator" + end if + + opts@mpNestTime = get_res_value_keep(opts, "mpNestTime",0) + + +; LAT and LON are not saved in the file + if (ZRPK.eq.0) then + XBETA=0. + XLAT0=0. ; map reference latitude (degrees) + ZXBM0 = 0. + ZYBM0 = 0. + ZCGAM = cos(-ZRDSDG*XBETA) + ZSGAM = sin(-ZRDSDG*XBETA) + ZRACLAT0 = XRADIUS*cos(ZRDSDG*ZLAT0) + do ji=0,IMAX-1 + jj=0 + ZXMI0 = XHAT(ji)-ZXBM0 + ZYMI0 = YHAT(jj)-ZYBM0 + zlon = (ZXMI0*ZCGAM+ZYMI0*ZSGAM)/(ZRACLAT0*ZRDSDG)+ZLONOR + do jj=0,JMAX-1 + lon(jj,ji)=zlon + end do + end do + do jj=0,JMAX-1 + ji=0 + ZXMI0 = XHAT(ji)-ZXBM0 + ZYMI0 = YHAT(jj)-ZYBM0 + ZT1 = log(tan(XPI/4.+ZLATOR*ZRDSDG/2.)) + ZT2 = (-ZXMI0*ZSGAM+ZYMI0*ZCGAM)/ZRACLAT0 + zlat = (-XPI/2.+2.*atan(exp(ZT1+ZT2)))/ZRDSDG + do ji=0,IMAX-1 + lat(jj,ji)=zlat + end do + end do + else + ZCLAT0 = cos(ZRDSDG*ZLAT0) + ZSLAT0 = sin(ZRDSDG*ZLAT0) + ZCLATOR = cos(ZRDSDG*ZLATOR) + ZSLATOR = sin(ZRDSDG*ZLATOR) + ZRO0 = (XRADIUS/ZRPK)*(abs(ZCLAT0))^(1.-ZRPK) * \ + ((1.+ZSLAT0)*abs(ZCLATOR)/(1.+ZSLATOR))^ZRPK + ZGA0 = (ZRPK*(ZLONOR-ZLON0)-ZBETA)*ZRDSDG + ZXP = ZXBM0-ZRO0*sin(ZGA0) + ZYP = ZYBM0+ZRO0*cos(ZGA0) + do ji=0,IMAX-1 + do jj=0,JMAX-1 + ZATA = atan2( -(ZXP-XHAT(ji)) , (ZYP-YHAT(jj)) )/ZRDSDG + zlon = (ZBETA+ZATA)/ZRPK+ZLON0 + lon(jj,ji)=zlon + ZRO2 = (XHAT(ji)-ZXP)^2+(YHAT(jj)-ZYP)^2 + ZJD1 = XRADIUS*(abs(ZCLAT0))^(1.-ZRPK) + ZT1 = (ZJD1)^(2./ZRPK)* (1+ZSLAT0)^2 + ZJD3 = (ZRPK^2*ZRO2) + ZT2 = ZJD3 + ZT2 = ZT2^(1./ZRPK) + ZJD1 = (ZT1-ZT2)/(ZT1+ZT2) + ZJD1 = acos(ZJD1) + ZJD3 = ZJD1 + zlat = (XPI/2.-ZJD3)/ZRDSDG + lat(jj,ji)=zlat + end do + end do + end if + + dims = dimsizes(lat) + + do ii = 0, dims(0)-1 + do jj = 0, dims(1)-1 + if ( lon(ii,jj) .lt. 0.0) then + lon(ii,jj) = lon(ii,jj) + 360. + end if + end do + end do + + opts@start_lat = lat(0,0) + opts@start_lon = lon(0,0) + opts@end_lat = lat(dims(0)-1,dims(1)-1) + opts@end_lon = lon(dims(0)-1,dims(1)-1) + + +; Set some resources common to all map projections. + opts = set_mp_resources(opts) + + if ( isatt(opts,"ZoomIn") .and. opts@ZoomIn ) then + y1 = 0 + x1 = 0 + y2 = dims(0)-1 + x2 = dims(1)-1 + if ( isatt(opts,"Ystart") ) then + y1 = opts@Ystart + delete(opts@Ystart) + end if + if ( isatt(opts,"Xstart") ) then + x1 = opts@Xstart + delete(opts@Xstart) + end if + if ( isatt(opts,"Yend") ) then + if ( opts@Yend .le. y2 ) then + y2 = opts@Yend + end if + delete(opts@Yend) + end if + if ( isatt(opts,"Xend") ) then + if ( opts@Xend .le. x2 ) then + x2 = opts@Xend + end if + delete(opts@Xend) + end if + + opts@mpLeftCornerLatF = lat(y1,x1) + opts@mpLeftCornerLonF = lon(y1,x1) + opts@mpRightCornerLatF = lat(y2,x2) + opts@mpRightCornerLonF = lon(y2,x2) + + if ( opts@mpRightCornerLonF .lt. 0.0 ) then + opts@mpRightCornerLonF = opts@mpRightCornerLonF + 360.0 + end if + + delete(opts@ZoomIn) + end if + + +; The default is not to draw the plot or advance the frame, and +; to maximize the plot in the frame. + + opts@gsnDraw = get_res_value_keep(opts,"gsnDraw", False) + opts@gsnFrame = get_res_value_keep(opts,"gsnFrame", False) + opts@gsnMaximize = get_res_value_keep(opts,"gsnMaximize", True) + + delete_attrs(opts) ; Clean up. + mp = gsn_map(wks,projection,opts) ; Create map plot. + + return(mp) ; Return. + +end + +;-------------------------------------------------------------------------------- + +undef("mnh_map_overlays") +function mnh_map_overlays(in_file[1]:file, \ + wks:graphic, \ + plots[*]:graphic, \ + opt_arg[1]:logical, \ + opt_mp[1]:logical) + +; Based on wrf_map_overlays +; +; This procedure takes an array of plots and overlays them on a +; base plot - map background. +; +; It will advance the plot and cleanup, unless you set the +; PanelPlot resource to True. +; +; Attributes recognized by this procedure: +; FramePlot +; PanelPlot +; NoTitles (don't do any titles) +; CommonTitle & PlotTile is used to overwrite field titles +; CommonTitle will super-seed NoTitles +; +; If FramePlot False, then Draw the plot but do not Frame. +; In this case a user want to add to the drawing, and will +; have to advance the Frame manually in the script. +; +; If the "NoTitles" attribute exists and is set True, then +; don't create the top-left titles, and leave the main titles alone. +; This resource can be useful if you are planning to panel +; the plots. +; +; If PanelPlot is set to True, then this flags to wrf_map_overlays +; that these plots are going to be eventually paneled (likely +; by gsn_panel), and hence 1) draw and frame should not be called +; (unless gsnDraw and/or gsnFrame are explicitly set to True), +; and 2) the overlays and titles should not be removed with +; NhlRemoveOverlay and NhlRemoveAnnotation. +; +begin + + opts = opt_arg ; Make a copy of the resource lists + opt_mp_2 = opt_mp + + ; Let's make the map first + base = mnh_map(wks,in_file,opt_mp_2) + + no_titles = get_res_value(opts,"NoTitles",False) ; Do we want field titles? + com_title = get_res_value(opts,"CommonTitle",False) ; Do we have a common title? + if ( com_title ) then + plot_title = get_res_value(opts,"PlotTitle"," ") + no_titles = True + end if + + call_draw = True + call_frame = get_res_value(opts,"FramePlot",True) ; Do we want to frame the plot? + panel_plot = get_res_value(opts,"PanelPlot",False) ; Are we paneling? + opts@gsnMaximize = get_res_value_keep(opts,"gsnMaximize", True) + + nplots = dimsizes(plots) +; font_color = "Black" + + do i=0,nplots-1 + if(.not.ismissing(plots(i))) then +; class_name = NhlClassName(plots(i)) +; print(class_name) +; if(class_name.eq."contourPlotClass") then +; getvalues plots(i) +; "cnFillOn" : fill_on +; "cnLineColor" : line_color +; end getvalues +; if (.not.fill_on) then +; font_color = line_color +; end if +; end if + if(.not.no_titles) then + getvalues plots(i) + "tiMainString" : SubTitle + end getvalues + if(i.eq.0) then + SubTitles = SubTitle + else + SubTitles = SubTitles + "~C~" + SubTitle + end if + end if + if(com_title .and. i .eq. nplots-1) then + getvalues plots(i) + "tiMainString" : SubTitle + end getvalues + SubTitles = plot_title + end if + setvalues plots(i) + "tfDoNDCOverlay" : True + "tiMainOn" : False + end setvalues + overlay(base,plots(i)) + else + print("mnh_map_overlays: Warning: overlay plot #" + i + " is not valid.") + end if + end do + + if(.not.no_titles .or. com_title) then + font_height = get_res_value_keep(opts,"FontHeightF",0.01) + txt = create "map_titles" textItemClass wks + "txString" : SubTitles + "txFontHeightF" : font_height + ;"txFontColor" : font_color + end create + anno = NhlAddAnnotation(base,txt) + setvalues anno + "amZone" : 3 + "amJust" : "BottomLeft" + "amSide" : "Top" + "amParallelPosF" : 0.005 + "amOrthogonalPosF" : 0.03 + "amResizeNotify" : False + end setvalues + base@map_titles = anno + end if +; +; gsnDraw and gsnFrame default to False if panel plot. +; + if(panel_plot) then + call_draw = False + call_frame= False + end if + + + opts@gsnDraw = get_res_value_keep(opts,"gsnDraw", call_draw) + opts@gsnFrame = get_res_value_keep(opts,"gsnFrame", call_frame) + + draw_and_frame(wks,base,opts@gsnDraw,opts@gsnFrame,False, \ + opts@gsnMaximize) + + if(.not.panel_plot) then + do i=0,nplots-1 + if(.not.ismissing(plots(i))) then + NhlRemoveOverlay(base,plots(i),False) + else + print("wrf_remove_map_overlays: Warning: overlay plot #" + i + " is not valid.") + print(" Nothing to remove.") + end if + end do + end if + + if(.not.no_titles.and..not.panel_plot) then + if(isatt(base,"map_titles")) then + NhlRemoveAnnotation(base,base@map_titles) + delete(base@map_titles) + end if + end if + +return(base) +end + +;-------------------------------------------------------------------------------- +undef("wrf_user_intrp3d") +function wrf_user_intrp3d( var3d:numeric, z_in:numeric, \ + plot_type:string, \ + loc_param:numeric, angle:numeric, opts:logical ) + +; var3d - 3d field to interpolate (all input fields must be unstaggered) +; z_in - interpolate to this field (either p/z) +; plot_type - interpolate horizontally "h", or vertically "v" +; loc_param - level(s) for horizontal plots (eg. 500hPa ; 3000m - scalar), +; plane for vertical plots (2 values representing an xy point +; on the model domain through which the vertical plane will pass +; OR 4 values specifying start and end values +; angle - 0.0 for horizontal plots, and +; an angle for vertical plots - 90 represent a WE cross section +; opts Used IF opts is TRUE, else use loc_param and angle to determine crosssection + +begin + + + if(plot_type .eq. "h" ) then ; horizontal cross section needed + + dimL = dimsizes(loc_param) + + dims = dimsizes(var3d) + nd = dimsizes(dims) + + dimX = dims(nd-1) + dimY = dims(nd-2) + dimZ = dims(nd-3) + dim4 = 1 + dim5 = 1 + if ( nd .eq. 4 ) then + dim4 = dims(nd-4) + end if + if ( nd .eq. 5 ) then + dim4 = dims(nd-4) + dim5 = dims(nd-5) + end if + + var3 = new ( (/ dim5, dim4, dimZ, dimY, dimX /) , typeof(var3d) ) + z = new ( (/ dim5, dim4, dimZ, dimY, dimX /) , typeof(var3d) ) + var2d = new ( (/ dim5, dim4, dimL, dimY, dimX /) , typeof(var3d) ) + + if ( nd .eq. 5 ) then + var3 = var3d + z = z_in + end if + if ( nd .eq. 4 ) then + var3(0,:,:,:,:) = var3d(:,:,:,:) + z(0,:,:,:,:) = z_in(:,:,:,:) + end if + if ( nd .eq. 3 ) then + var3(0,0,:,:,:) = var3d(:,:,:) + z(0,0,:,:,:) = z_in(:,:,:) + end if + + + if ( z(0,0,0,0,0) .gt. 500.) then + ; We must be interpolating to pressure + ; This routine needs input field and level in hPa - lets make sure of this + if ( z(0,0,0,0,0) .gt. 2000. ) then + ; looks like we have Pa as input - make this hPa + z = z * 0.01 + end if + if ( loc_param(0) .gt. 2000. ) then + ; looks like the input was specified in Pa - change this + loc_param = loc_param * 0.01 + end if + end if + + do il = 0,dimL-1 + var = wrf_interp_3d_z(var3,z,loc_param(il)) + var2d(:,:,il,:,:) = var(:,:,:,:) + end do + + copy_VarAtts(var3d,var3) + if(isatt(var3,"description")) then + delete_VarAtts(var3,(/"description"/)) + end if + if(isatt(var3,"units")) then + delete_VarAtts(var3,(/"units"/)) + end if + if(isatt(var3,"MemoryOrder")) then + delete_VarAtts(var3,(/"MemoryOrder"/)) + end if + if(isatt(var3,"_FillValue")) then + delete_VarAtts(var3,(/"_FillValue"/)) + end if + copy_VarAtts(var3,var2d) + + nn = nd-2 + var2d!nn = "plevs" + + if ( dimL .gt. 1 ) then + if ( nd .eq. 5 ) then + return( var2d ) + end if + if ( nd .eq. 4 ) then + return( var2d(0,:,:,:,:) ) + end if + if ( nd .eq. 3 ) then + return( var2d(0,0,:,:,:) ) + end if + else + if ( z(0,0,0,0,0) .gt. 500.) then + var2d@PlotLevelID = loc_param + " hPa" + else + var2d@PlotLevelID = .001*loc_param + " km" + end if + if ( nd .eq. 5 ) then + return( var2d(:,:,0,:,:) ) + end if + if ( nd .eq. 4 ) then + return( var2d(0,:,0,:,:) ) + end if + if ( nd .eq. 3 ) then + return( var2d(0,0,0,:,:) ) + end if + end if + + + end if + + + + + if(plot_type .eq. "v" ) then ; vertical cross section needed + + dims = dimsizes(var3d) + if ( dimsizes(dims) .eq. 4 ) then + if ( z_in(0,0,0,0) .gt. 500.) then + ; We must be interpolating to pressure + ; This routine needs input field and level in hPa - lets make sure of this + if ( z_in(0,0,0,0) .gt. 2000. ) then + ; looks like we have Pa as input - make this hPa + z_in = z_in * 0.01 + end if + end if + z = z_in(0,:,:,:) + else + if ( z_in(0,0,0) .gt. 500.) then + ; We must be interpolating to pressure + ; This routine needs input field and level in hPa - lets make sure of this + if ( z_in(0,0,0) .gt. 2000. ) then + ; looks like we have Pa as input - make this hPa + z_in = z_in * 0.01 + end if + end if + z = z_in + end if + +; set vertical cross section + if (opts) then + xy = wrf_user_set_xy( z, loc_param(0)-1, loc_param(1)-1, \ ; the -1 is for NCL dimensions + loc_param(2)-1, loc_param(3)-1, \ + angle, opts ) + else + xy = wrf_user_set_xy( z, loc_param(0), loc_param(1), \ + 0.0, 0.0, angle, opts ) + end if + xp = dimsizes(xy) + + +; first we interp z + var2dz = wrf_interp_2d_xy( z, xy) + +; interp to constant z grid + if(var2dz(0,0) .gt. var2dz(1,0) ) then ; monotonically decreasing coordinate + z_max = floor(max(z)/10)*10 ; bottom value + z_min = ceil(min(z)/10)*10 ; top value + dz = 1. + nlevels = tointeger( (z_max-z_min)/dz) + z_var2d = new( (/nlevels/), typeof(z)) + z_var2d(0) = z_max + dz = -dz + else + z_max = max(z) + z_min = 0. +;; MODI SOLINE +; dz = 0.01 * z_max + dz = 0.001 * z_max + nlevels = tointeger( z_max/dz ) + z_var2d = new( (/nlevels/), typeof(z)) + z_var2d(0) = z_min + end if +; print("nlevels="+nlevels) +; print("dz="+dz) + + do i=1, nlevels-1 + z_var2d(i) = z_var2d(0)+i*dz + end do + + +; interp the variable + if ( dimsizes(dims) .eq. 4 ) then + var2d = new( (/dims(0), nlevels, xp(0)/), typeof(var2dz)) + do it = 0,dims(0)-1 + var2dtmp = wrf_interp_2d_xy( var3d(it,:,:,:), xy) + do i=0,xp(0)-1 + var2d(it,:,i) = wrf_interp_1d( var2dtmp(:,i), var2dz(:,i), z_var2d) + end do + end do + var2d!0 = var3d!0 + var2d!1 = "Vertical" + var2d!2 = "Horizontal" + else + var2d = new( (/nlevels, xp(0)/), typeof(var2dz)) + var2dtmp = wrf_interp_2d_xy( var3d, xy) + do i=0,xp(0)-1 + var2d(:,i) = wrf_interp_1d( var2dtmp(:,i), var2dz(:,i), z_var2d) + end do + var2d!0 = "Vertical" + var2d!1 = "Horizontal" + end if + + + st_x = tointeger(xy(0,0)) + 1 + st_y = tointeger(xy(0,1)) + 1 + ed_x = tointeger(xy(xp(0)-1,0)) + 1 + ed_y = tointeger(xy(xp(0)-1,1)) + 1 + if (opts) then + var2d@Orientation = "Cross-Sesion: (" + \ + st_x + "," + st_y + ") to (" + \ + ed_x + "," + ed_y + ")" + else + var2d@Orientation = "Cross-Sesion: (" + \ + st_x + "," + st_y + ") to (" + \ + ed_x + "," + ed_y + ") ; center=(" + \ + loc_param(0) + "," + loc_param(1) + \ + ") ; angle=" + angle + end if + + return(var2d) +end if + + +end + diff --git a/MY_RUN/KTEST/007_16janvier/011_ncl_nc4/MESONHtools.ncl b/MY_RUN/KTEST/007_16janvier/011_ncl_nc4/MESONHtools.ncl index 7280ddc0c6f05aebe6b7a11afffed5449985f7bd..182df6d79d89e02ef068049311ec842988701b43 100644 --- a/MY_RUN/KTEST/007_16janvier/011_ncl_nc4/MESONHtools.ncl +++ b/MY_RUN/KTEST/007_16janvier/011_ncl_nc4/MESONHtools.ncl @@ -1,916 +1,916 @@ -load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" -load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" -load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" -load "$NCARG_ROOT/lib/ncarg/nclscripts/wrf/WRFUserARW.ncl" - -;------------------------------------------------------------- -;contains: -; procedure MESONH_map_c -;function mnh_map(wks[1]:graphic,in_file[1]:file,opt_args[1]:logical) -;function mnh_map_overlays(in_file[1]:file,wks:graphic,plots[*]:graphic, \ -; opt_arg[1]:logical,opt_mp[1]:logical) -;function MESONH_pinter( pfield:numeric, loc_param:numeric, ppabs:numeric ) -;------------------------------------------------------------- - -;============================================================== -; J.-P. CHABOUREAU -; This is a driver that selects the appropriate -; mapping function based upon the file variables RPK, BETA, LATOR, LONOR -; -; -; Sample usage: -; a = addfile("...", r") -; IMAX = a->IMAX -; JMAX = a->JMAX -; lat2d = new((/JMAX,IMAX/),"double") -; lat2d(:,:)=0. -; lon2d = new((/JMAX,IMAX/),"double") -; lon2d(:,:)=0. -; icorners = new((/2,2/),"integer") -; icorners(:,:)=0 -; res = True -; MESONH_map_c (a, res, lat2d, lon2d, icorners) -; -; -undef("MESONH_map_c") -;============================================================== -procedure MESONH_map_c (in_file:file, res:logical, plat, plon, icorner) -;============================================================== -;local rank, dimll, nlat, mlon, lat, lon -local rank, dimll, nlat, mlon -begin - -; Check if the variable RPK is in the file -; ---------------------------------------- -if(isfilevar(in_file,"RPK")) then - -; Read projection parameters -; ------------------------- - ZRPK = in_file->RPK - ZLATOR = in_file->LATOR - ZLONOR = in_file->LONOR - ZBETA = in_file->BETA - ZLAT0 = in_file->LAT0 - ZLON0 = in_file->LON0 - -; Case netcdf from lfi2cdf -; ------------------------- - - if(isfilevar(in_file,"IMAX")) - XHAT=in_file->XHAT - YHAT=in_file->YHAT - jphext = in_file->JPHEXT - IMAX= dimsizes(XHAT)-2*JPHEXT - JMAX= dimsizes(YHAT)-2*JPHEXT - zdx=XHAT(2)-XHAT(1) - zdy=YHAT(2)-YHAT(1) - -; unstagger - do ji=0,IMAX-1 - XHAT(ji)=XHAT(ji)+zdx*1.5 - end do - do jj=0,JMAX-1 - YHAT(jj)=YHAT(jj)+zdy*1.5 - end do - - else - -; Case netcdf from extractdia -; --------------------------- - XHAT=in_file->W_E_direction - YHAT=in_file->S_N_direction - IMAX= dimsizes(XHAT) - JMAX= dimsizes(YHAT) - zdx=XHAT(2)-XHAT(1) - zdy=YHAT(2)-YHAT(1) - - end if - - print ("LATOR="+ZLATOR+" - LONOR="+ZLONOR) - print ("ZLAT0="+ZLAT0+" - ZLON0="+ZLON0) - print ("ZDX="+zdx+" - RPK="+ZRPK+" - BETA="+ZBETA) - print ("IMAX="+IMAX+" - JMAX="+JMAX) - - if (ZRPK.gt.0) - ; Stereographic projection -; --------------------------- - res@mpProjection = "Stereographic" - res@mpCenterLonF = ZLON0 - res@mpCenterRotF = ZBETA - res@mpCenterLatF = 90. - end if - - if (ZRPK.lt.0) - ; Stereographic projection -; --------------------------- - res@mpProjection = "Stereographic" - res@mpCenterLonF = ZLON0 - res@mpCenterRotF = ZBETA - res@mpCenterLatF = -90. - end if - - if (ZRPK.eq.0) then - ; Mercator projection -; --------------------------- - res@mpProjection = "Mercator" - end if - - print("Map projection="+res@mpProjection) - -else - print ("MESONH_map_c: Error no RPK variable in input file") -end if - -;=================================================; -; calculate 2D lat and lon -; based on src/mesonh_MOD/mode_gridproj.f90 -;=================================================; - -; Constants -; ----------- - if(isfilevar(in_file,"IMAX")) - XRADIUS=6371229.0d ; Earth radius (meters) - else - XRADIUS=6371.2290d ; Earth radius (km) - end if - XPI=2.0d*asin(1.) ; Pi - ZRDSDG= XPI/180.0d ; Radian to Degree conversion factor - ZXBM0 = 0.0d - ZYBM0 = 0.0d - -;=================================================; - if (ZRPK.eq.0) then -; MERCATOR -;=================================================; - XBETA=0. - XLAT0=0. ; map reference latitude (degrees) - ZXBM0 = 0. - ZYBM0 = 0. - ZCGAM = cos(-ZRDSDG*XBETA) - ZSGAM = sin(-ZRDSDG*XBETA) - ZRACLAT0 = XRADIUS*cos(ZRDSDG*ZLAT0) - do ji=0,IMAX-1 - jj=0 - ZXMI0 = XHAT(ji)-ZXBM0 - ZYMI0 = YHAT(jj)-ZYBM0 - zlon = (ZXMI0*ZCGAM+ZYMI0*ZSGAM)/(ZRACLAT0*ZRDSDG)+ZLONOR - do jj=0,JMAX-1 - plon(jj,ji)=zlon - end do - end do - do jj=0,JMAX-1 - ji=0 - ZXMI0 = XHAT(ji)-ZXBM0 - ZYMI0 = YHAT(jj)-ZYBM0 - ZT1 = log(tan(XPI/4.+ZLATOR*ZRDSDG/2.)) - ZT2 = (-ZXMI0*ZSGAM+ZYMI0*ZCGAM)/ZRACLAT0 - zlat = (-XPI/2.+2.*atan(exp(ZT1+ZT2)))/ZRDSDG - do ji=0,IMAX-1 - plat(jj,ji)=zlat - end do - end do - -;=================================================; - else -; STEREOGRAPHIC PROJECTION -;=================================================; - ZCLAT0 = cos(ZRDSDG*ZLAT0) - ZSLAT0 = sin(ZRDSDG*ZLAT0) - ZCLATOR = cos(ZRDSDG*ZLATOR) - ZSLATOR = sin(ZRDSDG*ZLATOR) - ZRO0 = (XRADIUS/ZRPK)*(abs(ZCLAT0))^(1.-ZRPK) * \ - ((1.+ZSLAT0)*abs(ZCLATOR)/(1.+ZSLATOR))^ZRPK - ZGA0 = (ZRPK*(ZLONOR-ZLON0)-ZBETA)*ZRDSDG - ZXP = ZXBM0-ZRO0*sin(ZGA0) - ZYP = ZYBM0+ZRO0*cos(ZGA0) - do ji=0,IMAX-1 - do jj=0,JMAX-1 - ZATA = atan2( -(ZXP-XHAT(ji)) , (ZYP-YHAT(jj)) )/ZRDSDG - zlon = (ZBETA+ZATA)/ZRPK+ZLON0 - plon(jj,ji)=zlon - ZRO2 = (XHAT(ji)-ZXP)^2+(YHAT(jj)-ZYP)^2 - ZJD1 = XRADIUS*(abs(ZCLAT0))^(1.-ZRPK) - ZT1 = (ZJD1)^(2./ZRPK)* (1+ZSLAT0)^2 - ZJD3 = (ZRPK^2*ZRO2) - ZT2 = ZJD3 - ZT2 = ZT2^(1./ZRPK) - ZJD1 = (ZT1-ZT2)/(ZT1+ZT2) - ZJD1 = acos(ZJD1) - ZJD3 = ZJD1 - zlat = (XPI/2.-ZJD3)/ZRDSDG - plat(jj,ji)=zlat - end do - end do - - end if - -; Defining the corners of the domain -;==================================== - if (icorner(0,0).eq.icorner(1,1)) then - icorner(0,0)=0 - icorner(1,0)=JMAX-1 - icorner(0,1)=0 - icorner(1,1)=IMAX-1 - end if -; print ("icorner"+icorner) - - res@mpLimitMode = "Corners" - res@mpLeftCornerLatF = plat(icorner(0,0),icorner(0,1)) - res@mpLeftCornerLonF = plon(icorner(0,0),icorner(0,1)) - res@mpRightCornerLatF = plat(icorner(1,0),icorner(1,1)) - res@mpRightCornerLonF = plon(icorner(1,0),icorner(1,1)) - -; print ("Corner (0,0); Lat="+res@mpLeftCornerLatF+ \ -; ", Lon="+res@mpLeftCornerLonF) -; print ("Oppos corner; Lat="+res@mpRightCornerLatF+ \ -; ", Lon= "+res@mpRightCornerLonF) - -;========================================== -; Turn on lat / lon labeling -;========================================== - res@pmTickMarkDisplayMode = "Always" ; turn on tickmarks - res@mpOutlineBoundarySets = "AllBoundaries" ; state boundaries - res@mpPerimDrawOrder = "PostDraw" ; force map perim -;========================================== -; Needed for regional native projection -;========================================== - res@tfDoNDCOverlay = True - res@gsnAddCyclic = False ; regional data - -end - -;=========================================== -;------------------------------------------------------------------------ -undef("MESONH_pinter") -function MESONH_pinter( pfield:numeric, loc_param:numeric, ppabs:numeric ) -;************************************************************************* -; S. BIELLI -; This is a routine that interpolate fields on pressure level for plotting -; based on pinter.f90 -; The field to be interpolated must be given at the mass point (grid 1) -; usage : var_inter=MESONHfunction(var_to_interpol, 850., AbsPressure) -; Abs pressure must be in Pa -; - -begin - - dimL= dimsizes(loc_param) - -; First test for grid = 0 - - dimp=dimsizes(ppabs) - - pout=pfield(0:dimL-1,:,:) - pfield@_FillValue=999 - pout@_FillValue=999 - pout=pout@_FillValue - - do jkp = 0, dimL-1 - zref=log10(loc_param(jkp)*100.) - do jloop = 0, dimp(1)-1 - do iloop = 0, dimp(2)-1 - kloop=0 - flag=True - do while (flag .and. (kloop.lt.(dimp(2)-2))) - if (.not.ismissing(ppabs(kloop,jloop,iloop))) then - zxm=log10(ppabs(kloop,jloop,iloop)) - zxp=log10(ppabs(kloop+1,jloop,iloop)) - if ((zxp-zref)*(zref-zxm) .ge. 0) then - pout(jkp,jloop,iloop)= (pfield(kloop,jloop,iloop)*(zxp-zref)+ \ - pfield(kloop+1,jloop,iloop)*(zref-zxm))/ (zxp-zxm) - flag=False - end if - end if - kloop=kloop+1 - end do - end do - end do - end do - - return(pout) - -end - -;-------------------------------------------------------------------------------- -undef("mnh_map") -function mnh_map(wks[1]:graphic,in_file[1]:file,opt_args[1]:logical) - -begin -; -; This function creates a map plot, and bases the projection on -; the MAP_PROJ attribute in the given file. -; -; 1. Make a copy of the resource list, and set some resources -; common to all map projections. -; -; 2. Determine the projection being used, and set resources based -; on that projection. -; -; 3. Create the map plot, and draw and advance the frame -; (if requested). - - opts = opt_args ; Make a copy of the resource list - opts = True - -; Set some resources depending on what kind of map projection is -; chosen. -; -; ZRPK != 0 : "Stereographic" -; ZRPK = 0 : "Mercator" -;=================================================; -; src/mesonh_MOD/mode_gridproj.f90 -;=================================================; - XRADIUS=6371229.0d ; Earth radius (meters) - XPI=2.0d*asin(1.) ; Pi - ZRDSDG= XPI/180.0d ; Radian to Degree conversion factor - ZXBM0 = 0.0d - ZYBM0 = 0.0d - - if(isfilevar(in_file,"RPK")) - ZRPK=in_file->RPK - ZLON0=in_file->LON0 - ZLAT0=in_file->LAT0 - ZLATOR=in_file->LATOR - ZLONOR=in_file->LONOR - ZBETA=in_file->BETA - else - print ("mnh_map: Error no RPK variable in input file") - return(new(1,graphic)) - end if - -; Case netcdf from lfi2cdf - if(isfilevar(in_file,"IMAX")) - XHAT=in_file->XHAT - YHAT=in_file->YHAT - IMAX= dimsizes(XHAT)-2 - JMAX= dimsizes(YHAT)-2 - zdx=XHAT(2)-XHAT(1) - zdy=YHAT(2)-YHAT(1) - do ji=0,IMAX-1 - XHAT(ji)=XHAT(ji)+zdx*1.5 - end do - do jj=0,JMAX-1 - YHAT(jj)=YHAT(jj)+zdy*1.5 - end do - else -; Case netcdf from extractdia - XHAT=in_file->W_E_direction - YHAT=in_file->S_N_direction - IMAX= dimsizes(XHAT) - JMAX= dimsizes(YHAT) - end if -; - - lat = new((/JMAX,IMAX/),"double") - lon = new((/JMAX,IMAX/),"double") - - -; Stereographic projection - if(ZRPK .gt. 0) - projection = "Stereographic" - opts@mpCenterLatF = get_res_value_keep(opts, "mpCenterLatF", 90) - opts@mpCenterLonF = get_res_value_keep(opts, "mpCenterLonF",ZLON0) - opts@mpCenterRotF = get_res_value_keep(opts, "mpCenterRotF",ZBETA) - end if - - if(ZRPK .lt. 0) - projection = "Stereographic" - opts@mpCenterLatF = get_res_value_keep(opts, "mpCenterLatF", -90) - opts@mpCenterLonF = get_res_value_keep(opts, "mpCenterLonF",ZLON0) - opts@mpCenterRotF = get_res_value_keep(opts, "mpCenterRotF",ZBETA) - end if - -; Mercator projection - if(ZRPK .eq. 0) - projection = "Mercator" - end if - - opts@mpNestTime = get_res_value_keep(opts, "mpNestTime",0) - - -; LAT and LON are not saved in the file - if (ZRPK.eq.0) then - XBETA=0. - XLAT0=0. ; map reference latitude (degrees) - ZXBM0 = 0. - ZYBM0 = 0. - ZCGAM = cos(-ZRDSDG*XBETA) - ZSGAM = sin(-ZRDSDG*XBETA) - ZRACLAT0 = XRADIUS*cos(ZRDSDG*ZLAT0) - do ji=0,IMAX-1 - jj=0 - ZXMI0 = XHAT(ji)-ZXBM0 - ZYMI0 = YHAT(jj)-ZYBM0 - zlon = (ZXMI0*ZCGAM+ZYMI0*ZSGAM)/(ZRACLAT0*ZRDSDG)+ZLONOR - do jj=0,JMAX-1 - lon(jj,ji)=zlon - end do - end do - do jj=0,JMAX-1 - ji=0 - ZXMI0 = XHAT(ji)-ZXBM0 - ZYMI0 = YHAT(jj)-ZYBM0 - ZT1 = log(tan(XPI/4.+ZLATOR*ZRDSDG/2.)) - ZT2 = (-ZXMI0*ZSGAM+ZYMI0*ZCGAM)/ZRACLAT0 - zlat = (-XPI/2.+2.*atan(exp(ZT1+ZT2)))/ZRDSDG - do ji=0,IMAX-1 - lat(jj,ji)=zlat - end do - end do - else - ZCLAT0 = cos(ZRDSDG*ZLAT0) - ZSLAT0 = sin(ZRDSDG*ZLAT0) - ZCLATOR = cos(ZRDSDG*ZLATOR) - ZSLATOR = sin(ZRDSDG*ZLATOR) - ZRO0 = (XRADIUS/ZRPK)*(abs(ZCLAT0))^(1.-ZRPK) * \ - ((1.+ZSLAT0)*abs(ZCLATOR)/(1.+ZSLATOR))^ZRPK - ZGA0 = (ZRPK*(ZLONOR-ZLON0)-ZBETA)*ZRDSDG - ZXP = ZXBM0-ZRO0*sin(ZGA0) - ZYP = ZYBM0+ZRO0*cos(ZGA0) - do ji=0,IMAX-1 - do jj=0,JMAX-1 - ZATA = atan2( -(ZXP-XHAT(ji)) , (ZYP-YHAT(jj)) )/ZRDSDG - zlon = (ZBETA+ZATA)/ZRPK+ZLON0 - lon(jj,ji)=zlon - ZRO2 = (XHAT(ji)-ZXP)^2+(YHAT(jj)-ZYP)^2 - ZJD1 = XRADIUS*(abs(ZCLAT0))^(1.-ZRPK) - ZT1 = (ZJD1)^(2./ZRPK)* (1+ZSLAT0)^2 - ZJD3 = (ZRPK^2*ZRO2) - ZT2 = ZJD3 - ZT2 = ZT2^(1./ZRPK) - ZJD1 = (ZT1-ZT2)/(ZT1+ZT2) - ZJD1 = acos(ZJD1) - ZJD3 = ZJD1 - zlat = (XPI/2.-ZJD3)/ZRDSDG - lat(jj,ji)=zlat - end do - end do - end if - - dims = dimsizes(lat) - - do ii = 0, dims(0)-1 - do jj = 0, dims(1)-1 - if ( lon(ii,jj) .lt. 0.0) then - lon(ii,jj) = lon(ii,jj) + 360. - end if - end do - end do - - opts@start_lat = lat(0,0) - opts@start_lon = lon(0,0) - opts@end_lat = lat(dims(0)-1,dims(1)-1) - opts@end_lon = lon(dims(0)-1,dims(1)-1) - - -; Set some resources common to all map projections. - opts = set_mp_resources(opts) - - if ( isatt(opts,"ZoomIn") .and. opts@ZoomIn ) then - y1 = 0 - x1 = 0 - y2 = dims(0)-1 - x2 = dims(1)-1 - if ( isatt(opts,"Ystart") ) then - y1 = opts@Ystart - delete(opts@Ystart) - end if - if ( isatt(opts,"Xstart") ) then - x1 = opts@Xstart - delete(opts@Xstart) - end if - if ( isatt(opts,"Yend") ) then - if ( opts@Yend .le. y2 ) then - y2 = opts@Yend - end if - delete(opts@Yend) - end if - if ( isatt(opts,"Xend") ) then - if ( opts@Xend .le. x2 ) then - x2 = opts@Xend - end if - delete(opts@Xend) - end if - - opts@mpLeftCornerLatF = lat(y1,x1) - opts@mpLeftCornerLonF = lon(y1,x1) - opts@mpRightCornerLatF = lat(y2,x2) - opts@mpRightCornerLonF = lon(y2,x2) - - if ( opts@mpRightCornerLonF .lt. 0.0 ) then - opts@mpRightCornerLonF = opts@mpRightCornerLonF + 360.0 - end if - - delete(opts@ZoomIn) - end if - - -; The default is not to draw the plot or advance the frame, and -; to maximize the plot in the frame. - - opts@gsnDraw = get_res_value_keep(opts,"gsnDraw", False) - opts@gsnFrame = get_res_value_keep(opts,"gsnFrame", False) - opts@gsnMaximize = get_res_value_keep(opts,"gsnMaximize", True) - - delete_attrs(opts) ; Clean up. - mp = gsn_map(wks,projection,opts) ; Create map plot. - - return(mp) ; Return. - -end - -;-------------------------------------------------------------------------------- - -undef("mnh_map_overlays") -function mnh_map_overlays(in_file[1]:file, \ - wks:graphic, \ - plots[*]:graphic, \ - opt_arg[1]:logical, \ - opt_mp[1]:logical) - -; Based on wrf_map_overlays -; -; This procedure takes an array of plots and overlays them on a -; base plot - map background. -; -; It will advance the plot and cleanup, unless you set the -; PanelPlot resource to True. -; -; Attributes recognized by this procedure: -; FramePlot -; PanelPlot -; NoTitles (don't do any titles) -; CommonTitle & PlotTile is used to overwrite field titles -; CommonTitle will super-seed NoTitles -; -; If FramePlot False, then Draw the plot but do not Frame. -; In this case a user want to add to the drawing, and will -; have to advance the Frame manually in the script. -; -; If the "NoTitles" attribute exists and is set True, then -; don't create the top-left titles, and leave the main titles alone. -; This resource can be useful if you are planning to panel -; the plots. -; -; If PanelPlot is set to True, then this flags to wrf_map_overlays -; that these plots are going to be eventually paneled (likely -; by gsn_panel), and hence 1) draw and frame should not be called -; (unless gsnDraw and/or gsnFrame are explicitly set to True), -; and 2) the overlays and titles should not be removed with -; NhlRemoveOverlay and NhlRemoveAnnotation. -; -begin - - opts = opt_arg ; Make a copy of the resource lists - opt_mp_2 = opt_mp - - ; Let's make the map first - base = mnh_map(wks,in_file,opt_mp_2) - - no_titles = get_res_value(opts,"NoTitles",False) ; Do we want field titles? - com_title = get_res_value(opts,"CommonTitle",False) ; Do we have a common title? - if ( com_title ) then - plot_title = get_res_value(opts,"PlotTitle"," ") - no_titles = True - end if - - call_draw = True - call_frame = get_res_value(opts,"FramePlot",True) ; Do we want to frame the plot? - panel_plot = get_res_value(opts,"PanelPlot",False) ; Are we paneling? - opts@gsnMaximize = get_res_value_keep(opts,"gsnMaximize", True) - - nplots = dimsizes(plots) -; font_color = "Black" - - do i=0,nplots-1 - if(.not.ismissing(plots(i))) then -; class_name = NhlClassName(plots(i)) -; print(class_name) -; if(class_name.eq."contourPlotClass") then -; getvalues plots(i) -; "cnFillOn" : fill_on -; "cnLineColor" : line_color -; end getvalues -; if (.not.fill_on) then -; font_color = line_color -; end if -; end if - if(.not.no_titles) then - getvalues plots(i) - "tiMainString" : SubTitle - end getvalues - if(i.eq.0) then - SubTitles = SubTitle - else - SubTitles = SubTitles + "~C~" + SubTitle - end if - end if - if(com_title .and. i .eq. nplots-1) then - getvalues plots(i) - "tiMainString" : SubTitle - end getvalues - SubTitles = plot_title - end if - setvalues plots(i) - "tfDoNDCOverlay" : True - "tiMainOn" : False - end setvalues - overlay(base,plots(i)) - else - print("mnh_map_overlays: Warning: overlay plot #" + i + " is not valid.") - end if - end do - - if(.not.no_titles .or. com_title) then - font_height = get_res_value_keep(opts,"FontHeightF",0.01) - txt = create "map_titles" textItemClass wks - "txString" : SubTitles - "txFontHeightF" : font_height - ;"txFontColor" : font_color - end create - anno = NhlAddAnnotation(base,txt) - setvalues anno - "amZone" : 3 - "amJust" : "BottomLeft" - "amSide" : "Top" - "amParallelPosF" : 0.005 - "amOrthogonalPosF" : 0.03 - "amResizeNotify" : False - end setvalues - base@map_titles = anno - end if -; -; gsnDraw and gsnFrame default to False if panel plot. -; - if(panel_plot) then - call_draw = False - call_frame= False - end if - - - opts@gsnDraw = get_res_value_keep(opts,"gsnDraw", call_draw) - opts@gsnFrame = get_res_value_keep(opts,"gsnFrame", call_frame) - - draw_and_frame(wks,base,opts@gsnDraw,opts@gsnFrame,False, \ - opts@gsnMaximize) - - if(.not.panel_plot) then - do i=0,nplots-1 - if(.not.ismissing(plots(i))) then - NhlRemoveOverlay(base,plots(i),False) - else - print("wrf_remove_map_overlays: Warning: overlay plot #" + i + " is not valid.") - print(" Nothing to remove.") - end if - end do - end if - - if(.not.no_titles.and..not.panel_plot) then - if(isatt(base,"map_titles")) then - NhlRemoveAnnotation(base,base@map_titles) - delete(base@map_titles) - end if - end if - -return(base) -end - -;-------------------------------------------------------------------------------- -undef("wrf_user_intrp3d") -function wrf_user_intrp3d( var3d:numeric, z_in:numeric, \ - plot_type:string, \ - loc_param:numeric, angle:numeric, opts:logical ) - -; var3d - 3d field to interpolate (all input fields must be unstaggered) -; z_in - interpolate to this field (either p/z) -; plot_type - interpolate horizontally "h", or vertically "v" -; loc_param - level(s) for horizontal plots (eg. 500hPa ; 3000m - scalar), -; plane for vertical plots (2 values representing an xy point -; on the model domain through which the vertical plane will pass -; OR 4 values specifying start and end values -; angle - 0.0 for horizontal plots, and -; an angle for vertical plots - 90 represent a WE cross section -; opts Used IF opts is TRUE, else use loc_param and angle to determine crosssection - -begin - - - if(plot_type .eq. "h" ) then ; horizontal cross section needed - - dimL = dimsizes(loc_param) - - dims = dimsizes(var3d) - nd = dimsizes(dims) - - dimX = dims(nd-1) - dimY = dims(nd-2) - dimZ = dims(nd-3) - dim4 = 1 - dim5 = 1 - if ( nd .eq. 4 ) then - dim4 = dims(nd-4) - end if - if ( nd .eq. 5 ) then - dim4 = dims(nd-4) - dim5 = dims(nd-5) - end if - - var3 = new ( (/ dim5, dim4, dimZ, dimY, dimX /) , typeof(var3d) ) - z = new ( (/ dim5, dim4, dimZ, dimY, dimX /) , typeof(var3d) ) - var2d = new ( (/ dim5, dim4, dimL, dimY, dimX /) , typeof(var3d) ) - - if ( nd .eq. 5 ) then - var3 = var3d - z = z_in - end if - if ( nd .eq. 4 ) then - var3(0,:,:,:,:) = var3d(:,:,:,:) - z(0,:,:,:,:) = z_in(:,:,:,:) - end if - if ( nd .eq. 3 ) then - var3(0,0,:,:,:) = var3d(:,:,:) - z(0,0,:,:,:) = z_in(:,:,:) - end if - - - if ( z(0,0,0,0,0) .gt. 500.) then - ; We must be interpolating to pressure - ; This routine needs input field and level in hPa - lets make sure of this - if ( z(0,0,0,0,0) .gt. 2000. ) then - ; looks like we have Pa as input - make this hPa - z = z * 0.01 - end if - if ( loc_param(0) .gt. 2000. ) then - ; looks like the input was specified in Pa - change this - loc_param = loc_param * 0.01 - end if - end if - - do il = 0,dimL-1 - var = wrf_interp_3d_z(var3,z,loc_param(il)) - var2d(:,:,il,:,:) = var(:,:,:,:) - end do - - copy_VarAtts(var3d,var3) - if(isatt(var3,"description")) then - delete_VarAtts(var3,(/"description"/)) - end if - if(isatt(var3,"units")) then - delete_VarAtts(var3,(/"units"/)) - end if - if(isatt(var3,"MemoryOrder")) then - delete_VarAtts(var3,(/"MemoryOrder"/)) - end if - if(isatt(var3,"_FillValue")) then - delete_VarAtts(var3,(/"_FillValue"/)) - end if - copy_VarAtts(var3,var2d) - - nn = nd-2 - var2d!nn = "plevs" - - if ( dimL .gt. 1 ) then - if ( nd .eq. 5 ) then - return( var2d ) - end if - if ( nd .eq. 4 ) then - return( var2d(0,:,:,:,:) ) - end if - if ( nd .eq. 3 ) then - return( var2d(0,0,:,:,:) ) - end if - else - if ( z(0,0,0,0,0) .gt. 500.) then - var2d@PlotLevelID = loc_param + " hPa" - else - var2d@PlotLevelID = .001*loc_param + " km" - end if - if ( nd .eq. 5 ) then - return( var2d(:,:,0,:,:) ) - end if - if ( nd .eq. 4 ) then - return( var2d(0,:,0,:,:) ) - end if - if ( nd .eq. 3 ) then - return( var2d(0,0,0,:,:) ) - end if - end if - - - end if - - - - - if(plot_type .eq. "v" ) then ; vertical cross section needed - - dims = dimsizes(var3d) - if ( dimsizes(dims) .eq. 4 ) then - if ( z_in(0,0,0,0) .gt. 500.) then - ; We must be interpolating to pressure - ; This routine needs input field and level in hPa - lets make sure of this - if ( z_in(0,0,0,0) .gt. 2000. ) then - ; looks like we have Pa as input - make this hPa - z_in = z_in * 0.01 - end if - end if - z = z_in(0,:,:,:) - else - if ( z_in(0,0,0) .gt. 500.) then - ; We must be interpolating to pressure - ; This routine needs input field and level in hPa - lets make sure of this - if ( z_in(0,0,0) .gt. 2000. ) then - ; looks like we have Pa as input - make this hPa - z_in = z_in * 0.01 - end if - end if - z = z_in - end if - -; set vertical cross section - if (opts) then - xy = wrf_user_set_xy( z, loc_param(0)-1, loc_param(1)-1, \ ; the -1 is for NCL dimensions - loc_param(2)-1, loc_param(3)-1, \ - angle, opts ) - else - xy = wrf_user_set_xy( z, loc_param(0), loc_param(1), \ - 0.0, 0.0, angle, opts ) - end if - xp = dimsizes(xy) - - -; first we interp z - var2dz = wrf_interp_2d_xy( z, xy) - -; interp to constant z grid - if(var2dz(0,0) .gt. var2dz(1,0) ) then ; monotonically decreasing coordinate - z_max = floor(max(z)/10)*10 ; bottom value - z_min = ceil(min(z)/10)*10 ; top value - dz = 1. - nlevels = tointeger( (z_max-z_min)/dz) - z_var2d = new( (/nlevels/), typeof(z)) - z_var2d(0) = z_max - dz = -dz - else - z_max = max(z) - z_min = 0. -;; MODI SOLINE -; dz = 0.01 * z_max - dz = 0.001 * z_max - nlevels = tointeger( z_max/dz ) - z_var2d = new( (/nlevels/), typeof(z)) - z_var2d(0) = z_min - end if -; print("nlevels="+nlevels) -; print("dz="+dz) - - do i=1, nlevels-1 - z_var2d(i) = z_var2d(0)+i*dz - end do - - -; interp the variable - if ( dimsizes(dims) .eq. 4 ) then - var2d = new( (/dims(0), nlevels, xp(0)/), typeof(var2dz)) - do it = 0,dims(0)-1 - var2dtmp = wrf_interp_2d_xy( var3d(it,:,:,:), xy) - do i=0,xp(0)-1 - var2d(it,:,i) = wrf_interp_1d( var2dtmp(:,i), var2dz(:,i), z_var2d) - end do - end do - var2d!0 = var3d!0 - var2d!1 = "Vertical" - var2d!2 = "Horizontal" - else - var2d = new( (/nlevels, xp(0)/), typeof(var2dz)) - var2dtmp = wrf_interp_2d_xy( var3d, xy) - do i=0,xp(0)-1 - var2d(:,i) = wrf_interp_1d( var2dtmp(:,i), var2dz(:,i), z_var2d) - end do - var2d!0 = "Vertical" - var2d!1 = "Horizontal" - end if - - - st_x = tointeger(xy(0,0)) + 1 - st_y = tointeger(xy(0,1)) + 1 - ed_x = tointeger(xy(xp(0)-1,0)) + 1 - ed_y = tointeger(xy(xp(0)-1,1)) + 1 - if (opts) then - var2d@Orientation = "Cross-Sesion: (" + \ - st_x + "," + st_y + ") to (" + \ - ed_x + "," + ed_y + ")" - else - var2d@Orientation = "Cross-Sesion: (" + \ - st_x + "," + st_y + ") to (" + \ - ed_x + "," + ed_y + ") ; center=(" + \ - loc_param(0) + "," + loc_param(1) + \ - ") ; angle=" + angle - end if - - return(var2d) -end if - - -end - +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/wrf/WRFUserARW.ncl" + +;------------------------------------------------------------- +;contains: +; procedure MESONH_map_c +;function mnh_map(wks[1]:graphic,in_file[1]:file,opt_args[1]:logical) +;function mnh_map_overlays(in_file[1]:file,wks:graphic,plots[*]:graphic, \ +; opt_arg[1]:logical,opt_mp[1]:logical) +;function MESONH_pinter( pfield:numeric, loc_param:numeric, ppabs:numeric ) +;------------------------------------------------------------- + +;============================================================== +; J.-P. CHABOUREAU +; This is a driver that selects the appropriate +; mapping function based upon the file variables RPK, BETA, LATOR, LONOR +; +; +; Sample usage: +; a = addfile("...", r") +; IMAX = a->IMAX +; JMAX = a->JMAX +; lat2d = new((/JMAX,IMAX/),"double") +; lat2d(:,:)=0. +; lon2d = new((/JMAX,IMAX/),"double") +; lon2d(:,:)=0. +; icorners = new((/2,2/),"integer") +; icorners(:,:)=0 +; res = True +; MESONH_map_c (a, res, lat2d, lon2d, icorners) +; +; +undef("MESONH_map_c") +;============================================================== +procedure MESONH_map_c (in_file:file, res:logical, plat, plon, icorner) +;============================================================== +;local rank, dimll, nlat, mlon, lat, lon +local rank, dimll, nlat, mlon +begin + +; Check if the variable RPK is in the file +; ---------------------------------------- +if(isfilevar(in_file,"RPK")) then + +; Read projection parameters +; ------------------------- + ZRPK = in_file->RPK + ZLATOR = in_file->LATOR + ZLONOR = in_file->LONOR + ZBETA = in_file->BETA + ZLAT0 = in_file->LAT0 + ZLON0 = in_file->LON0 + +; Case netcdf from lfi2cdf +; ------------------------- + + if(isfilevar(in_file,"IMAX")) + XHAT=in_file->XHAT + YHAT=in_file->YHAT + jphext = in_file->JPHEXT + IMAX= dimsizes(XHAT)-2*JPHEXT + JMAX= dimsizes(YHAT)-2*JPHEXT + zdx=XHAT(2)-XHAT(1) + zdy=YHAT(2)-YHAT(1) + +; unstagger + do ji=0,IMAX-1 + XHAT(ji)=XHAT(ji)+zdx*1.5 + end do + do jj=0,JMAX-1 + YHAT(jj)=YHAT(jj)+zdy*1.5 + end do + + else + +; Case netcdf from extractdia +; --------------------------- + XHAT=in_file->W_E_direction + YHAT=in_file->S_N_direction + IMAX= dimsizes(XHAT) + JMAX= dimsizes(YHAT) + zdx=XHAT(2)-XHAT(1) + zdy=YHAT(2)-YHAT(1) + + end if + + print ("LATOR="+ZLATOR+" - LONOR="+ZLONOR) + print ("ZLAT0="+ZLAT0+" - ZLON0="+ZLON0) + print ("ZDX="+zdx+" - RPK="+ZRPK+" - BETA="+ZBETA) + print ("IMAX="+IMAX+" - JMAX="+JMAX) + + if (ZRPK.gt.0) + ; Stereographic projection +; --------------------------- + res@mpProjection = "Stereographic" + res@mpCenterLonF = ZLON0 + res@mpCenterRotF = ZBETA + res@mpCenterLatF = 90. + end if + + if (ZRPK.lt.0) + ; Stereographic projection +; --------------------------- + res@mpProjection = "Stereographic" + res@mpCenterLonF = ZLON0 + res@mpCenterRotF = ZBETA + res@mpCenterLatF = -90. + end if + + if (ZRPK.eq.0) then + ; Mercator projection +; --------------------------- + res@mpProjection = "Mercator" + end if + + print("Map projection="+res@mpProjection) + +else + print ("MESONH_map_c: Error no RPK variable in input file") +end if + +;=================================================; +; calculate 2D lat and lon +; based on src/mesonh_MOD/mode_gridproj.f90 +;=================================================; + +; Constants +; ----------- + if(isfilevar(in_file,"IMAX")) + XRADIUS=6371229.0d ; Earth radius (meters) + else + XRADIUS=6371.2290d ; Earth radius (km) + end if + XPI=2.0d*asin(1.) ; Pi + ZRDSDG= XPI/180.0d ; Radian to Degree conversion factor + ZXBM0 = 0.0d + ZYBM0 = 0.0d + +;=================================================; + if (ZRPK.eq.0) then +; MERCATOR +;=================================================; + XBETA=0. + XLAT0=0. ; map reference latitude (degrees) + ZXBM0 = 0. + ZYBM0 = 0. + ZCGAM = cos(-ZRDSDG*XBETA) + ZSGAM = sin(-ZRDSDG*XBETA) + ZRACLAT0 = XRADIUS*cos(ZRDSDG*ZLAT0) + do ji=0,IMAX-1 + jj=0 + ZXMI0 = XHAT(ji)-ZXBM0 + ZYMI0 = YHAT(jj)-ZYBM0 + zlon = (ZXMI0*ZCGAM+ZYMI0*ZSGAM)/(ZRACLAT0*ZRDSDG)+ZLONOR + do jj=0,JMAX-1 + plon(jj,ji)=zlon + end do + end do + do jj=0,JMAX-1 + ji=0 + ZXMI0 = XHAT(ji)-ZXBM0 + ZYMI0 = YHAT(jj)-ZYBM0 + ZT1 = log(tan(XPI/4.+ZLATOR*ZRDSDG/2.)) + ZT2 = (-ZXMI0*ZSGAM+ZYMI0*ZCGAM)/ZRACLAT0 + zlat = (-XPI/2.+2.*atan(exp(ZT1+ZT2)))/ZRDSDG + do ji=0,IMAX-1 + plat(jj,ji)=zlat + end do + end do + +;=================================================; + else +; STEREOGRAPHIC PROJECTION +;=================================================; + ZCLAT0 = cos(ZRDSDG*ZLAT0) + ZSLAT0 = sin(ZRDSDG*ZLAT0) + ZCLATOR = cos(ZRDSDG*ZLATOR) + ZSLATOR = sin(ZRDSDG*ZLATOR) + ZRO0 = (XRADIUS/ZRPK)*(abs(ZCLAT0))^(1.-ZRPK) * \ + ((1.+ZSLAT0)*abs(ZCLATOR)/(1.+ZSLATOR))^ZRPK + ZGA0 = (ZRPK*(ZLONOR-ZLON0)-ZBETA)*ZRDSDG + ZXP = ZXBM0-ZRO0*sin(ZGA0) + ZYP = ZYBM0+ZRO0*cos(ZGA0) + do ji=0,IMAX-1 + do jj=0,JMAX-1 + ZATA = atan2( -(ZXP-XHAT(ji)) , (ZYP-YHAT(jj)) )/ZRDSDG + zlon = (ZBETA+ZATA)/ZRPK+ZLON0 + plon(jj,ji)=zlon + ZRO2 = (XHAT(ji)-ZXP)^2+(YHAT(jj)-ZYP)^2 + ZJD1 = XRADIUS*(abs(ZCLAT0))^(1.-ZRPK) + ZT1 = (ZJD1)^(2./ZRPK)* (1+ZSLAT0)^2 + ZJD3 = (ZRPK^2*ZRO2) + ZT2 = ZJD3 + ZT2 = ZT2^(1./ZRPK) + ZJD1 = (ZT1-ZT2)/(ZT1+ZT2) + ZJD1 = acos(ZJD1) + ZJD3 = ZJD1 + zlat = (XPI/2.-ZJD3)/ZRDSDG + plat(jj,ji)=zlat + end do + end do + + end if + +; Defining the corners of the domain +;==================================== + if (icorner(0,0).eq.icorner(1,1)) then + icorner(0,0)=0 + icorner(1,0)=JMAX-1 + icorner(0,1)=0 + icorner(1,1)=IMAX-1 + end if +; print ("icorner"+icorner) + + res@mpLimitMode = "Corners" + res@mpLeftCornerLatF = plat(icorner(0,0),icorner(0,1)) + res@mpLeftCornerLonF = plon(icorner(0,0),icorner(0,1)) + res@mpRightCornerLatF = plat(icorner(1,0),icorner(1,1)) + res@mpRightCornerLonF = plon(icorner(1,0),icorner(1,1)) + +; print ("Corner (0,0); Lat="+res@mpLeftCornerLatF+ \ +; ", Lon="+res@mpLeftCornerLonF) +; print ("Oppos corner; Lat="+res@mpRightCornerLatF+ \ +; ", Lon= "+res@mpRightCornerLonF) + +;========================================== +; Turn on lat / lon labeling +;========================================== + res@pmTickMarkDisplayMode = "Always" ; turn on tickmarks + res@mpOutlineBoundarySets = "AllBoundaries" ; state boundaries + res@mpPerimDrawOrder = "PostDraw" ; force map perim +;========================================== +; Needed for regional native projection +;========================================== + res@tfDoNDCOverlay = True + res@gsnAddCyclic = False ; regional data + +end + +;=========================================== +;------------------------------------------------------------------------ +undef("MESONH_pinter") +function MESONH_pinter( pfield:numeric, loc_param:numeric, ppabs:numeric ) +;************************************************************************* +; S. BIELLI +; This is a routine that interpolate fields on pressure level for plotting +; based on pinter.f90 +; The field to be interpolated must be given at the mass point (grid 1) +; usage : var_inter=MESONHfunction(var_to_interpol, 850., AbsPressure) +; Abs pressure must be in Pa +; + +begin + + dimL= dimsizes(loc_param) + +; First test for grid = 0 + + dimp=dimsizes(ppabs) + + pout=pfield(0:dimL-1,:,:) + pfield@_FillValue=999 + pout@_FillValue=999 + pout=pout@_FillValue + + do jkp = 0, dimL-1 + zref=log10(loc_param(jkp)*100.) + do jloop = 0, dimp(1)-1 + do iloop = 0, dimp(2)-1 + kloop=0 + flag=True + do while (flag .and. (kloop.lt.(dimp(2)-2))) + if (.not.ismissing(ppabs(kloop,jloop,iloop))) then + zxm=log10(ppabs(kloop,jloop,iloop)) + zxp=log10(ppabs(kloop+1,jloop,iloop)) + if ((zxp-zref)*(zref-zxm) .ge. 0) then + pout(jkp,jloop,iloop)= (pfield(kloop,jloop,iloop)*(zxp-zref)+ \ + pfield(kloop+1,jloop,iloop)*(zref-zxm))/ (zxp-zxm) + flag=False + end if + end if + kloop=kloop+1 + end do + end do + end do + end do + + return(pout) + +end + +;-------------------------------------------------------------------------------- +undef("mnh_map") +function mnh_map(wks[1]:graphic,in_file[1]:file,opt_args[1]:logical) + +begin +; +; This function creates a map plot, and bases the projection on +; the MAP_PROJ attribute in the given file. +; +; 1. Make a copy of the resource list, and set some resources +; common to all map projections. +; +; 2. Determine the projection being used, and set resources based +; on that projection. +; +; 3. Create the map plot, and draw and advance the frame +; (if requested). + + opts = opt_args ; Make a copy of the resource list + opts = True + +; Set some resources depending on what kind of map projection is +; chosen. +; +; ZRPK != 0 : "Stereographic" +; ZRPK = 0 : "Mercator" +;=================================================; +; src/mesonh_MOD/mode_gridproj.f90 +;=================================================; + XRADIUS=6371229.0d ; Earth radius (meters) + XPI=2.0d*asin(1.) ; Pi + ZRDSDG= XPI/180.0d ; Radian to Degree conversion factor + ZXBM0 = 0.0d + ZYBM0 = 0.0d + + if(isfilevar(in_file,"RPK")) + ZRPK=in_file->RPK + ZLON0=in_file->LON0 + ZLAT0=in_file->LAT0 + ZLATOR=in_file->LATOR + ZLONOR=in_file->LONOR + ZBETA=in_file->BETA + else + print ("mnh_map: Error no RPK variable in input file") + return(new(1,graphic)) + end if + +; Case netcdf from lfi2cdf + if(isfilevar(in_file,"IMAX")) + XHAT=in_file->XHAT + YHAT=in_file->YHAT + IMAX= dimsizes(XHAT)-2 + JMAX= dimsizes(YHAT)-2 + zdx=XHAT(2)-XHAT(1) + zdy=YHAT(2)-YHAT(1) + do ji=0,IMAX-1 + XHAT(ji)=XHAT(ji)+zdx*1.5 + end do + do jj=0,JMAX-1 + YHAT(jj)=YHAT(jj)+zdy*1.5 + end do + else +; Case netcdf from extractdia + XHAT=in_file->W_E_direction + YHAT=in_file->S_N_direction + IMAX= dimsizes(XHAT) + JMAX= dimsizes(YHAT) + end if +; + + lat = new((/JMAX,IMAX/),"double") + lon = new((/JMAX,IMAX/),"double") + + +; Stereographic projection + if(ZRPK .gt. 0) + projection = "Stereographic" + opts@mpCenterLatF = get_res_value_keep(opts, "mpCenterLatF", 90) + opts@mpCenterLonF = get_res_value_keep(opts, "mpCenterLonF",ZLON0) + opts@mpCenterRotF = get_res_value_keep(opts, "mpCenterRotF",ZBETA) + end if + + if(ZRPK .lt. 0) + projection = "Stereographic" + opts@mpCenterLatF = get_res_value_keep(opts, "mpCenterLatF", -90) + opts@mpCenterLonF = get_res_value_keep(opts, "mpCenterLonF",ZLON0) + opts@mpCenterRotF = get_res_value_keep(opts, "mpCenterRotF",ZBETA) + end if + +; Mercator projection + if(ZRPK .eq. 0) + projection = "Mercator" + end if + + opts@mpNestTime = get_res_value_keep(opts, "mpNestTime",0) + + +; LAT and LON are not saved in the file + if (ZRPK.eq.0) then + XBETA=0. + XLAT0=0. ; map reference latitude (degrees) + ZXBM0 = 0. + ZYBM0 = 0. + ZCGAM = cos(-ZRDSDG*XBETA) + ZSGAM = sin(-ZRDSDG*XBETA) + ZRACLAT0 = XRADIUS*cos(ZRDSDG*ZLAT0) + do ji=0,IMAX-1 + jj=0 + ZXMI0 = XHAT(ji)-ZXBM0 + ZYMI0 = YHAT(jj)-ZYBM0 + zlon = (ZXMI0*ZCGAM+ZYMI0*ZSGAM)/(ZRACLAT0*ZRDSDG)+ZLONOR + do jj=0,JMAX-1 + lon(jj,ji)=zlon + end do + end do + do jj=0,JMAX-1 + ji=0 + ZXMI0 = XHAT(ji)-ZXBM0 + ZYMI0 = YHAT(jj)-ZYBM0 + ZT1 = log(tan(XPI/4.+ZLATOR*ZRDSDG/2.)) + ZT2 = (-ZXMI0*ZSGAM+ZYMI0*ZCGAM)/ZRACLAT0 + zlat = (-XPI/2.+2.*atan(exp(ZT1+ZT2)))/ZRDSDG + do ji=0,IMAX-1 + lat(jj,ji)=zlat + end do + end do + else + ZCLAT0 = cos(ZRDSDG*ZLAT0) + ZSLAT0 = sin(ZRDSDG*ZLAT0) + ZCLATOR = cos(ZRDSDG*ZLATOR) + ZSLATOR = sin(ZRDSDG*ZLATOR) + ZRO0 = (XRADIUS/ZRPK)*(abs(ZCLAT0))^(1.-ZRPK) * \ + ((1.+ZSLAT0)*abs(ZCLATOR)/(1.+ZSLATOR))^ZRPK + ZGA0 = (ZRPK*(ZLONOR-ZLON0)-ZBETA)*ZRDSDG + ZXP = ZXBM0-ZRO0*sin(ZGA0) + ZYP = ZYBM0+ZRO0*cos(ZGA0) + do ji=0,IMAX-1 + do jj=0,JMAX-1 + ZATA = atan2( -(ZXP-XHAT(ji)) , (ZYP-YHAT(jj)) )/ZRDSDG + zlon = (ZBETA+ZATA)/ZRPK+ZLON0 + lon(jj,ji)=zlon + ZRO2 = (XHAT(ji)-ZXP)^2+(YHAT(jj)-ZYP)^2 + ZJD1 = XRADIUS*(abs(ZCLAT0))^(1.-ZRPK) + ZT1 = (ZJD1)^(2./ZRPK)* (1+ZSLAT0)^2 + ZJD3 = (ZRPK^2*ZRO2) + ZT2 = ZJD3 + ZT2 = ZT2^(1./ZRPK) + ZJD1 = (ZT1-ZT2)/(ZT1+ZT2) + ZJD1 = acos(ZJD1) + ZJD3 = ZJD1 + zlat = (XPI/2.-ZJD3)/ZRDSDG + lat(jj,ji)=zlat + end do + end do + end if + + dims = dimsizes(lat) + + do ii = 0, dims(0)-1 + do jj = 0, dims(1)-1 + if ( lon(ii,jj) .lt. 0.0) then + lon(ii,jj) = lon(ii,jj) + 360. + end if + end do + end do + + opts@start_lat = lat(0,0) + opts@start_lon = lon(0,0) + opts@end_lat = lat(dims(0)-1,dims(1)-1) + opts@end_lon = lon(dims(0)-1,dims(1)-1) + + +; Set some resources common to all map projections. + opts = set_mp_resources(opts) + + if ( isatt(opts,"ZoomIn") .and. opts@ZoomIn ) then + y1 = 0 + x1 = 0 + y2 = dims(0)-1 + x2 = dims(1)-1 + if ( isatt(opts,"Ystart") ) then + y1 = opts@Ystart + delete(opts@Ystart) + end if + if ( isatt(opts,"Xstart") ) then + x1 = opts@Xstart + delete(opts@Xstart) + end if + if ( isatt(opts,"Yend") ) then + if ( opts@Yend .le. y2 ) then + y2 = opts@Yend + end if + delete(opts@Yend) + end if + if ( isatt(opts,"Xend") ) then + if ( opts@Xend .le. x2 ) then + x2 = opts@Xend + end if + delete(opts@Xend) + end if + + opts@mpLeftCornerLatF = lat(y1,x1) + opts@mpLeftCornerLonF = lon(y1,x1) + opts@mpRightCornerLatF = lat(y2,x2) + opts@mpRightCornerLonF = lon(y2,x2) + + if ( opts@mpRightCornerLonF .lt. 0.0 ) then + opts@mpRightCornerLonF = opts@mpRightCornerLonF + 360.0 + end if + + delete(opts@ZoomIn) + end if + + +; The default is not to draw the plot or advance the frame, and +; to maximize the plot in the frame. + + opts@gsnDraw = get_res_value_keep(opts,"gsnDraw", False) + opts@gsnFrame = get_res_value_keep(opts,"gsnFrame", False) + opts@gsnMaximize = get_res_value_keep(opts,"gsnMaximize", True) + + delete_attrs(opts) ; Clean up. + mp = gsn_map(wks,projection,opts) ; Create map plot. + + return(mp) ; Return. + +end + +;-------------------------------------------------------------------------------- + +undef("mnh_map_overlays") +function mnh_map_overlays(in_file[1]:file, \ + wks:graphic, \ + plots[*]:graphic, \ + opt_arg[1]:logical, \ + opt_mp[1]:logical) + +; Based on wrf_map_overlays +; +; This procedure takes an array of plots and overlays them on a +; base plot - map background. +; +; It will advance the plot and cleanup, unless you set the +; PanelPlot resource to True. +; +; Attributes recognized by this procedure: +; FramePlot +; PanelPlot +; NoTitles (don't do any titles) +; CommonTitle & PlotTile is used to overwrite field titles +; CommonTitle will super-seed NoTitles +; +; If FramePlot False, then Draw the plot but do not Frame. +; In this case a user want to add to the drawing, and will +; have to advance the Frame manually in the script. +; +; If the "NoTitles" attribute exists and is set True, then +; don't create the top-left titles, and leave the main titles alone. +; This resource can be useful if you are planning to panel +; the plots. +; +; If PanelPlot is set to True, then this flags to wrf_map_overlays +; that these plots are going to be eventually paneled (likely +; by gsn_panel), and hence 1) draw and frame should not be called +; (unless gsnDraw and/or gsnFrame are explicitly set to True), +; and 2) the overlays and titles should not be removed with +; NhlRemoveOverlay and NhlRemoveAnnotation. +; +begin + + opts = opt_arg ; Make a copy of the resource lists + opt_mp_2 = opt_mp + + ; Let's make the map first + base = mnh_map(wks,in_file,opt_mp_2) + + no_titles = get_res_value(opts,"NoTitles",False) ; Do we want field titles? + com_title = get_res_value(opts,"CommonTitle",False) ; Do we have a common title? + if ( com_title ) then + plot_title = get_res_value(opts,"PlotTitle"," ") + no_titles = True + end if + + call_draw = True + call_frame = get_res_value(opts,"FramePlot",True) ; Do we want to frame the plot? + panel_plot = get_res_value(opts,"PanelPlot",False) ; Are we paneling? + opts@gsnMaximize = get_res_value_keep(opts,"gsnMaximize", True) + + nplots = dimsizes(plots) +; font_color = "Black" + + do i=0,nplots-1 + if(.not.ismissing(plots(i))) then +; class_name = NhlClassName(plots(i)) +; print(class_name) +; if(class_name.eq."contourPlotClass") then +; getvalues plots(i) +; "cnFillOn" : fill_on +; "cnLineColor" : line_color +; end getvalues +; if (.not.fill_on) then +; font_color = line_color +; end if +; end if + if(.not.no_titles) then + getvalues plots(i) + "tiMainString" : SubTitle + end getvalues + if(i.eq.0) then + SubTitles = SubTitle + else + SubTitles = SubTitles + "~C~" + SubTitle + end if + end if + if(com_title .and. i .eq. nplots-1) then + getvalues plots(i) + "tiMainString" : SubTitle + end getvalues + SubTitles = plot_title + end if + setvalues plots(i) + "tfDoNDCOverlay" : True + "tiMainOn" : False + end setvalues + overlay(base,plots(i)) + else + print("mnh_map_overlays: Warning: overlay plot #" + i + " is not valid.") + end if + end do + + if(.not.no_titles .or. com_title) then + font_height = get_res_value_keep(opts,"FontHeightF",0.01) + txt = create "map_titles" textItemClass wks + "txString" : SubTitles + "txFontHeightF" : font_height + ;"txFontColor" : font_color + end create + anno = NhlAddAnnotation(base,txt) + setvalues anno + "amZone" : 3 + "amJust" : "BottomLeft" + "amSide" : "Top" + "amParallelPosF" : 0.005 + "amOrthogonalPosF" : 0.03 + "amResizeNotify" : False + end setvalues + base@map_titles = anno + end if +; +; gsnDraw and gsnFrame default to False if panel plot. +; + if(panel_plot) then + call_draw = False + call_frame= False + end if + + + opts@gsnDraw = get_res_value_keep(opts,"gsnDraw", call_draw) + opts@gsnFrame = get_res_value_keep(opts,"gsnFrame", call_frame) + + draw_and_frame(wks,base,opts@gsnDraw,opts@gsnFrame,False, \ + opts@gsnMaximize) + + if(.not.panel_plot) then + do i=0,nplots-1 + if(.not.ismissing(plots(i))) then + NhlRemoveOverlay(base,plots(i),False) + else + print("wrf_remove_map_overlays: Warning: overlay plot #" + i + " is not valid.") + print(" Nothing to remove.") + end if + end do + end if + + if(.not.no_titles.and..not.panel_plot) then + if(isatt(base,"map_titles")) then + NhlRemoveAnnotation(base,base@map_titles) + delete(base@map_titles) + end if + end if + +return(base) +end + +;-------------------------------------------------------------------------------- +undef("wrf_user_intrp3d") +function wrf_user_intrp3d( var3d:numeric, z_in:numeric, \ + plot_type:string, \ + loc_param:numeric, angle:numeric, opts:logical ) + +; var3d - 3d field to interpolate (all input fields must be unstaggered) +; z_in - interpolate to this field (either p/z) +; plot_type - interpolate horizontally "h", or vertically "v" +; loc_param - level(s) for horizontal plots (eg. 500hPa ; 3000m - scalar), +; plane for vertical plots (2 values representing an xy point +; on the model domain through which the vertical plane will pass +; OR 4 values specifying start and end values +; angle - 0.0 for horizontal plots, and +; an angle for vertical plots - 90 represent a WE cross section +; opts Used IF opts is TRUE, else use loc_param and angle to determine crosssection + +begin + + + if(plot_type .eq. "h" ) then ; horizontal cross section needed + + dimL = dimsizes(loc_param) + + dims = dimsizes(var3d) + nd = dimsizes(dims) + + dimX = dims(nd-1) + dimY = dims(nd-2) + dimZ = dims(nd-3) + dim4 = 1 + dim5 = 1 + if ( nd .eq. 4 ) then + dim4 = dims(nd-4) + end if + if ( nd .eq. 5 ) then + dim4 = dims(nd-4) + dim5 = dims(nd-5) + end if + + var3 = new ( (/ dim5, dim4, dimZ, dimY, dimX /) , typeof(var3d) ) + z = new ( (/ dim5, dim4, dimZ, dimY, dimX /) , typeof(var3d) ) + var2d = new ( (/ dim5, dim4, dimL, dimY, dimX /) , typeof(var3d) ) + + if ( nd .eq. 5 ) then + var3 = var3d + z = z_in + end if + if ( nd .eq. 4 ) then + var3(0,:,:,:,:) = var3d(:,:,:,:) + z(0,:,:,:,:) = z_in(:,:,:,:) + end if + if ( nd .eq. 3 ) then + var3(0,0,:,:,:) = var3d(:,:,:) + z(0,0,:,:,:) = z_in(:,:,:) + end if + + + if ( z(0,0,0,0,0) .gt. 500.) then + ; We must be interpolating to pressure + ; This routine needs input field and level in hPa - lets make sure of this + if ( z(0,0,0,0,0) .gt. 2000. ) then + ; looks like we have Pa as input - make this hPa + z = z * 0.01 + end if + if ( loc_param(0) .gt. 2000. ) then + ; looks like the input was specified in Pa - change this + loc_param = loc_param * 0.01 + end if + end if + + do il = 0,dimL-1 + var = wrf_interp_3d_z(var3,z,loc_param(il)) + var2d(:,:,il,:,:) = var(:,:,:,:) + end do + + copy_VarAtts(var3d,var3) + if(isatt(var3,"description")) then + delete_VarAtts(var3,(/"description"/)) + end if + if(isatt(var3,"units")) then + delete_VarAtts(var3,(/"units"/)) + end if + if(isatt(var3,"MemoryOrder")) then + delete_VarAtts(var3,(/"MemoryOrder"/)) + end if + if(isatt(var3,"_FillValue")) then + delete_VarAtts(var3,(/"_FillValue"/)) + end if + copy_VarAtts(var3,var2d) + + nn = nd-2 + var2d!nn = "plevs" + + if ( dimL .gt. 1 ) then + if ( nd .eq. 5 ) then + return( var2d ) + end if + if ( nd .eq. 4 ) then + return( var2d(0,:,:,:,:) ) + end if + if ( nd .eq. 3 ) then + return( var2d(0,0,:,:,:) ) + end if + else + if ( z(0,0,0,0,0) .gt. 500.) then + var2d@PlotLevelID = loc_param + " hPa" + else + var2d@PlotLevelID = .001*loc_param + " km" + end if + if ( nd .eq. 5 ) then + return( var2d(:,:,0,:,:) ) + end if + if ( nd .eq. 4 ) then + return( var2d(0,:,0,:,:) ) + end if + if ( nd .eq. 3 ) then + return( var2d(0,0,0,:,:) ) + end if + end if + + + end if + + + + + if(plot_type .eq. "v" ) then ; vertical cross section needed + + dims = dimsizes(var3d) + if ( dimsizes(dims) .eq. 4 ) then + if ( z_in(0,0,0,0) .gt. 500.) then + ; We must be interpolating to pressure + ; This routine needs input field and level in hPa - lets make sure of this + if ( z_in(0,0,0,0) .gt. 2000. ) then + ; looks like we have Pa as input - make this hPa + z_in = z_in * 0.01 + end if + end if + z = z_in(0,:,:,:) + else + if ( z_in(0,0,0) .gt. 500.) then + ; We must be interpolating to pressure + ; This routine needs input field and level in hPa - lets make sure of this + if ( z_in(0,0,0) .gt. 2000. ) then + ; looks like we have Pa as input - make this hPa + z_in = z_in * 0.01 + end if + end if + z = z_in + end if + +; set vertical cross section + if (opts) then + xy = wrf_user_set_xy( z, loc_param(0)-1, loc_param(1)-1, \ ; the -1 is for NCL dimensions + loc_param(2)-1, loc_param(3)-1, \ + angle, opts ) + else + xy = wrf_user_set_xy( z, loc_param(0), loc_param(1), \ + 0.0, 0.0, angle, opts ) + end if + xp = dimsizes(xy) + + +; first we interp z + var2dz = wrf_interp_2d_xy( z, xy) + +; interp to constant z grid + if(var2dz(0,0) .gt. var2dz(1,0) ) then ; monotonically decreasing coordinate + z_max = floor(max(z)/10)*10 ; bottom value + z_min = ceil(min(z)/10)*10 ; top value + dz = 1. + nlevels = tointeger( (z_max-z_min)/dz) + z_var2d = new( (/nlevels/), typeof(z)) + z_var2d(0) = z_max + dz = -dz + else + z_max = max(z) + z_min = 0. +;; MODI SOLINE +; dz = 0.01 * z_max + dz = 0.001 * z_max + nlevels = tointeger( z_max/dz ) + z_var2d = new( (/nlevels/), typeof(z)) + z_var2d(0) = z_min + end if +; print("nlevels="+nlevels) +; print("dz="+dz) + + do i=1, nlevels-1 + z_var2d(i) = z_var2d(0)+i*dz + end do + + +; interp the variable + if ( dimsizes(dims) .eq. 4 ) then + var2d = new( (/dims(0), nlevels, xp(0)/), typeof(var2dz)) + do it = 0,dims(0)-1 + var2dtmp = wrf_interp_2d_xy( var3d(it,:,:,:), xy) + do i=0,xp(0)-1 + var2d(it,:,i) = wrf_interp_1d( var2dtmp(:,i), var2dz(:,i), z_var2d) + end do + end do + var2d!0 = var3d!0 + var2d!1 = "Vertical" + var2d!2 = "Horizontal" + else + var2d = new( (/nlevels, xp(0)/), typeof(var2dz)) + var2dtmp = wrf_interp_2d_xy( var3d, xy) + do i=0,xp(0)-1 + var2d(:,i) = wrf_interp_1d( var2dtmp(:,i), var2dz(:,i), z_var2d) + end do + var2d!0 = "Vertical" + var2d!1 = "Horizontal" + end if + + + st_x = tointeger(xy(0,0)) + 1 + st_y = tointeger(xy(0,1)) + 1 + ed_x = tointeger(xy(xp(0)-1,0)) + 1 + ed_y = tointeger(xy(xp(0)-1,1)) + 1 + if (opts) then + var2d@Orientation = "Cross-Sesion: (" + \ + st_x + "," + st_y + ") to (" + \ + ed_x + "," + ed_y + ")" + else + var2d@Orientation = "Cross-Sesion: (" + \ + st_x + "," + st_y + ") to (" + \ + ed_x + "," + ed_y + ") ; center=(" + \ + loc_param(0) + "," + loc_param(1) + \ + ") ; angle=" + angle + end if + + return(var2d) +end if + + +end + diff --git a/MY_RUN/KTEST/009_ICARTT/006_ncl/plot_ICARTT.ncl b/MY_RUN/KTEST/009_ICARTT/006_ncl/plot_ICARTT.ncl index 711524a6bb2c88e6a3d2bc0d08adfbe3e638c6b1..40e2405c649987103b1006766df87493af94c6a8 100644 --- a/MY_RUN/KTEST/009_ICARTT/006_ncl/plot_ICARTT.ncl +++ b/MY_RUN/KTEST/009_ICARTT/006_ncl/plot_ICARTT.ncl @@ -1,474 +1,474 @@ -;================================================; -load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" -load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" -load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" -load "$NCARG_ROOT/lib/ncarg/nclscripts/wrf/WRFUserARW.ncl" -; ================================================; -begin -;=================================================; -; open file and read in data -;=================================================; - a = addfile("ICART.1.SEG01.001dg.nc", "r") - a2 = addfile("ICART.1.SEG01.002dg.nc", "r") - -;=================================================; -; Get informations on variable sizes -; dims are dims-2 to remove non-physical values -;=================================================; - jphext = a->JPHEXT - mdims = getfilevardimsizes(a,"UT") - nd = dimsizes(mdims) - imax=mdims(nd-1)-2*jphext - jmax=mdims(nd-2)-2*jphext - kmax=mdims(nd-3)-2 - -;-------------------------------------------------; -; Read data. -;-------------------------------------------------; - lat2d = a->LAT(jphext:jmax+jphext-1,jphext:imax+jphext-1) - lat2d@units="degrees_north" - lon2d = a->LON(jphext:jmax+jphext-1,jphext:imax+jphext-1) - lon2d@units="degrees_east" - -zs = a->ZS(jphext:jmax+jphext-1,jphext:imax+jphext-1) ; ZS -zs@long_name="Orography" -zs@units="m" -zs@lat2d = lat2d -zs@lon2d = lon2d - -printMinMax(zs,0) - - rc_t1 = a->MRC(1:kmax,jphext:jmax+jphext-1,jphext:imax+jphext-1) - rc_t1@long_name="Cloud mixing ratio" - rc_t1@units="g/kg" - rc_t1@lat2d=lat2d - rc_t1@lon2d=lon2d -printMinMax(rc_t1,0) - -; - o3_t1 = a->O3T(1:kmax,jphext:jmax+jphext-1,jphext:imax+jphext-1) - o3_t1@long_name="Ozone" - o3_t1@units="ppbv" - o3_t1@lat2d=lat2d - o3_t1@lon2d=lon2d - -; - co_t1 = a->COT(1:kmax,jphext:jmax+jphext-1,jphext:imax+jphext-1) - co_t1@long_name="carbon monoxide" - co_t1@units="ppbv" - co_t1@lat2d=lat2d - co_t1@lon2d=lon2d - -; - o3p_t1=a->O3_PROD(1:kmax,jphext:jmax+jphext-1,jphext:imax+jphext-1) - o3p_t1 = o3p_t1*1e9*3600 - o3p_t1@long_name="ozone production" - o3p_t1@units="ppbv/h" - o3p_t1@lat2d=lat2d - o3p_t1@lon2d=lon2d - -; - o3l_t1=a->O3_LOSS(1:kmax,jphext:jmax+jphext-1,jphext:imax+jphext-1) - o3l_t1 = o3l_t1*1e9*3600 - o3l_t1@long_name="ozone loss" - o3l_t1@units="ppbv/h" - o3l_t1@lat2d=lat2d - o3l_t1@lon2d=lon2d - -; - cop_t1=a->CO_PROD(1:kmax,jphext:jmax+jphext-1,jphext:imax+jphext-1) - cop_t1 = cop_t1*1e9*3600 - cop_t1@long_name="carbon monoxide production" - cop_t1@units="ppbv/h" - cop_t1@lat2d=lat2d - cop_t1@lon2d=lon2d - -; - col_t1=a->CO_LOSS(1:kmax,jphext:jmax+jphext-1,jphext:imax+jphext-1) - col_t1 = col_t1*1e9*3600 - col_t1@long_name="carbon monoxide loss" - col_t1@units="ppbv/h" - col_t1@lat2d=lat2d - col_t1@lon2d=lon2d - - -; -; - rc_t2 = a2->MRC(1:kmax,jphext:jmax+jphext-1,jphext:imax+jphext-1) - rc_t2@long_name="Cloud mixing ratio" - rc_t2@units="g/kg" - rc_t2@lat2d=lat2d - rc_t2@lon2d=lon2d - -; - o3_t2 = a2->O3T(1:kmax,jphext:jmax+jphext-1,jphext:imax+jphext-1) - o3_t2@long_name="Ozone" - o3_t2@units="ppbv" - o3_t2@lat2d=lat2d - o3_t2@lon2d=lon2d - -; - co_t2 = a2->COT(1:kmax,jphext:jmax+jphext-1,jphext:imax+jphext-1) - co_t2@long_name="carbon monoxide" - co_t2@units="ppbv" - co_t2@lat2d=lat2d - co_t2@lon2d=lon2d - -; - o3p_t2=a2->O3_PROD(1:kmax,jphext:jmax+jphext-1,jphext:imax+jphext-1) - o3p_t2=o3p_t2*1e9*3600 - o3p_t2@long_name="ozone production" - o3p_t2@units="pptv/h" - o3p_t2@lat2d=lat2d - o3p_t2@lon2d=lon2d - -; - o3l_t2=a2->O3_LOSS(1:kmax,jphext:jmax+jphext-1,jphext:imax+jphext-1) - o3l_t2=o3l_t2*1e9*3600 - o3l_t2@long_name="ozone loss" - o3l_t2@units="pptv/h" - o3l_t2@lat2d=lat2d - o3l_t2@lon2d=lon2d - -; - cop_t2=a2->CO_PROD(1:kmax,jphext:jmax+jphext-1,jphext:imax+jphext-1) - cop_t2=cop_t2*1e9*3600 - cop_t2@long_name="carbon monoxide production" - cop_t2@units="pptv/h" - cop_t2@lat2d=lat2d - cop_t2@lon2d=lon2d - -; - col_t2=a2->CO_LOSS(1:kmax,jphext:jmax+jphext-1,jphext:imax+jphext-1) - col_t2=col_t2*1e9*3600 - col_t2@long_name="carbon monoxide loss" - col_t2@units="ppbv/h" - col_t2@lat2d=lat2d - col_t2@lon2d=lon2d - - - -;-----------------------------------------------; -;=================================================; -; On calcule l'altitude des champs modèle -;=================================================; - -zhat= a2->ZHAT(1:kmax+1) - -; Unstagger zhat (from grid 4 to 1) - nzhat=new(kmax,double) - do k=0,kmax-1 - nzhat(k)=(zhat(k)+zhat(k+1))/2. - end do - -; Create Z3D == ALT - alt=new(dimsizes(o3_t2),double) - zcoef=1.-zs/nzhat(kmax-1) - - do i=0,imax-1 - do j=0,jmax-1 - alt(:,j,i) = nzhat*zcoef(j,i)+zs(j,i) - end do - end do - -alt@lat2d = lat2d -alt@lon2d = lon2d - - - - -;-----------------------------------------------; -; Set map projection ressources using projection parameters -;-----------------------------------------------; -; Read projection parameters -; -------------------- - RPK = a2->RPK - BETA = a2->BETA - LON0 = a2->LON0 - - resmap=True - if (RPK.gt.0) -; --------------------------- - ; Lambert projection from north pole -; --------------------------- - resmap@mpProjection = "LambertConformal" ; projection - pole = 1 ; projection for north hemisphere - resmap@mpLambertParallel1F = pole*asin(RPK)*180/3.14 ; with pole=1 for north hemisphere and -1 for south hemisphere - resmap@mpLambertParallel2F = resmap@mpLambertParallel1F ; ncl adds from grib file - resmap@mpLambertMeridianF = LON0 ; ncl adds from grib file - end if - - if (RPK.lt.0) -; --------------------------- - ; Lambert projection from south pole -; --------------------------- - resmap@mpProjection = "LambertConformal" ; projection - pole = -1 ; projection for south hemisphere - resmap@mpLambertParallel1F = pole*asin(RPK)*180/3.14 ; with pole=1 for north hemisphere and -1 for south hemisphere - resmap@mpLambertParallel2F = resmap@mpLambertParallel1F ; ncl adds from grib file - resmap@mpLambertMeridianF = LON0 ; ncl adds from grib file - end if - - if (RPK.eq.1) -; --------------------------- - ; Stereographic projection north -; --------------------------- - resmap@mpProjection = "Stereographic" - resmap@mpCenterLonF = LON0 - resmap@mpCenterRotF = BETA - resmap@mpCenterLatF = 90 - end if - - if (RPK.eq.-1) -; --------------------------- - ; Stereographic projection south -; --------------------------- - resmap@mpProjection = "Stereographic" - resmap@mpCenterLonF = LON0 - resmap@mpCenterRotF = BETA - resmap@mpCenterLatF = -90 - end if - - if (RPK.eq.0) then -; --------------------------- - ; Mercator projection -; --------------------------- - resmap@mpProjection = "Mercator" - end if - - print("Map projection="+resmap@mpProjection) - -; Defining the corners for projection -; -------------------------------- - resmap@mpLimitMode = "Corners" - resmap@mpLeftCornerLatF = lat2d(0,0) - resmap@mpLeftCornerLonF = lon2d(0,0) - resmap@mpRightCornerLatF = lat2d(jmax-1,imax-1) - resmap@mpRightCornerLonF = lon2d(jmax-1,imax-1) - -;=================================================; -; PLOT -;=================================================; -; interpolation des champs a 1250 m -rc_t1_plane = wrf_user_intrp3d(rc_t1,alt,"h",1250,0.,False) -printMinMax(rc_t1_plane,0) -printMinMax(alt,0) - -rc_t2_plane = wrf_user_intrp3d(rc_t2,alt,"h",1250,0.,False) -co_t1_plane = wrf_user_intrp3d(co_t1,alt,"h",1250,0.,False) -co_t2_plane = wrf_user_intrp3d(co_t2,alt,"h",1250,0.,False) -cop_t1_plane= wrf_user_intrp3d(cop_t1,alt,"h",1250,0.,False) -cop_t2_plane= wrf_user_intrp3d(cop_t2,alt,"h",1250,0.,False) -col_t1_plane= wrf_user_intrp3d(col_t1,alt,"h",1250,0.,False) -col_t2_plane= wrf_user_intrp3d(col_t2,alt,"h",1250,0.,False) -o3_t1_plane = wrf_user_intrp3d(o3_t1,alt,"h",1250,0.,False) -o3_t2_plane = wrf_user_intrp3d(o3_t2,alt,"h",1250,0.,False) -o3l_t1_plane= wrf_user_intrp3d(o3l_t1,alt,"h",1250,0.,False) -o3l_t2_plane= wrf_user_intrp3d(o3l_t2,alt,"h",1250,0.,False) -o3p_t1_plane= wrf_user_intrp3d(o3p_t1,alt,"h",1250,0.,False) -o3p_t2_plane= wrf_user_intrp3d(o3p_t2,alt,"h",1250,0.,False) - - - figname ="zsection_1250" - wks = gsn_open_wks("png",figname) ; open a ncgm file - gsn_define_colormap(wks,"WhBlGrYeRe") ; Choose colormap - - res = resmap - res@gsnDraw = False ; don't draw yet - res@gsnFrame = False ; don't advance frame yet - -; X-axis title (tiY) - res@tiXAxisFontHeightF = 0.018 ; font height - res@tiXAxisFont = 21 ; font index - res@tiXAxisString = "longitude" ; string to use as the X-Axis title - -; Y-axis title (tiY) - res@tiYAxisFontHeightF = 0.018 ; font height - res@tiYAxisFont = 21 ; font index - res@tiYAxisString = "latitude" ; string to use as the Y-Axis title - -; BW - res@cnLinesOn = False - res@cnFillOn = True - res@gsnSpreadColors = True -; -; label bar (lb) -; res@lbAutoManage = False -; res@lbBottomMarginF = 0.4 ; offset -; res@lbOrientation = "Vertical" - -; Map ressources -; res@mpDataBaseVersion = "HighRes" ; choose highres map data version (must be donwloaded) -; res@mpDataBaseVersion = "MediumRes" ; choose highres map data version (must be donwloaded) - res@mpGridAndLimbOn = True ; turn on lat/lon lines - res@mpGridLatSpacingF = 10. ; spacing for lat lines - res@mpGridLonSpacingF = 10. ; spacing for lon lines - - res@mpGeophysicalLineColor = "Black" ; default value in lowres - res@mpNationalLineColor = "Black" ; idem - res@mpUSStateLineColor = "Black" ; idem - res@mpGridLineColor = "Black" - res@mpLimbLineColor = "Black" - res@mpPerimLineColor = "Black" - - - res@gsnCenterString="heure=19" - -; plot cloud mixing ratio - res@cnLevelSelectionMode = "ExplicitLevels" - res@cnLevels = (/0.01,0.015,0.02,0.025,0.03,0.035,0.04,0.045,0.05,0.055,0.06/) - res@cnFillColors = (/2,6,12,40,45,51,62,72,80,89,96,101/) ; color of a contour - plot_rc = gsn_csm_contour_map(wks,rc_t1_plane(:,:),res) - draw(plot_rc) - frame(wks) - delete(res@cnLevels) - delete(res@cnFillColors) - -; plot ozone - res@cnLevelSelectionMode = "ExplicitLevels" ; method for selecting the contour - res@cnLevels = (/15.,20., 25., 35., 40., 45., 50., 55., 60., 65./) - res@cnFillColors = (/2,6,12,40,45,51,62,72,80,89,96/) ; color of a contour -; res@cnLevelSelectionMode = "AutomaticLevels" - plot_o3 = gsn_csm_contour_map(wks,o3_t1_plane(:,:),res) - draw(plot_o3) - frame(wks) - delete(res@cnLevels) - delete(res@cnFillColors) - -; plot co - res@cnLevelSelectionMode = "ExplicitLevels" ; method for selecting the contour - res@cnLevels = (/110.,112.5,115.,117.5,120.,122.5,125.,127.5,130.,132.5,135./) - res@cnFillColors = (/2,6,12,40,45,51,62,72,80,89,96,101/) ; color of a contour -; res@cnLevelSelectionMode = "AutomaticLevels" - plot_co = gsn_csm_contour_map(wks,co_t1_plane(:,:),res) - draw(plot_co) - frame(wks) - delete(res@cnLevels) - delete(res@cnFillColors) - -; plot ozone production - res@cnLevelSelectionMode = "ExplicitLevels" ; method for selecting the contour - res@cnLevels = (/75,80,85,90,95,100,105,110,115,120,125/) - res@cnFillColors = (/75,80,85,90,95,100,105,110,115,120,125,130/) ; color of a contour -; res@cnLevelSelectionMode = "AutomaticLevels" - plot_o3p = gsn_csm_contour_map(wks,o3p_t1_plane(:,:),res) - draw(plot_o3p) - frame(wks) - delete(res@cnLevels) - delete(res@cnFillColors) - -; plot ozone loss - res@cnLevelSelectionMode = "ExplicitLevels" ; method for selecting the contour - res@cnLevels = (/75,80,85,90,95,100,105,110,115,120,125/) - res@cnFillColors = (/75,80,85,90,95,100,105,110,115,120,125,130/) ; color of a contour -; res@cnLevelSelectionMode = "AutomaticLevels" - plot_o3l = gsn_csm_contour_map(wks,o3l_t1_plane(:,:),res) - draw(plot_o3l) - frame(wks) - delete(res@cnLevels) - delete(res@cnFillColors) - -; plot carbon monoxide production - res@cnLevelSelectionMode = "ExplicitLevels" ; method for selecting the contour - res@cnLevels = (/0.6,0.7,0.8,0.9,1.0,1.1,1.2,1.3,1.4,1.5,1.6/) - res@cnFillColors := (/0.6,0.7,0.8,0.9,1.0,1.1,1.2,1.3,1.4,1.5,1.6/) ; color of a contour -; res@cnLevelSelectionMode = "AutomaticLevels" - plot_cop = gsn_csm_contour_map(wks,cop_t1_plane(:,:),res) - draw(plot_cop) - frame(wks) - delete(res@cnLevels) - delete(res@cnFillColors) - -; plot carbon monoxide loss - res@cnLevelSelectionMode = "ExplicitLevels" ; method for selecting the contour - res@cnLevels = (/0.6,0.7,0.8,0.9,1.0,1.1,1.2,1.3,1.4,1.5,1.6/) - res@cnFillColors := (/0.6,0.7,0.8,0.9,1.0,1.1,1.2,1.3,1.4,1.5,1.6/) ; color of a contour -; res@cnLevelSelectionMode = "AutomaticLevels" - plot_col = gsn_csm_contour_map(wks,col_t1_plane(:,:),res) - draw(plot_col) - frame(wks) - delete(res@cnLevels) - delete(res@cnFillColors) - - res@gsnCenterString="heure=20" - -; plot cloud mixing ratio - res@cnLevelSelectionMode = "ExplicitLevels" - res@cnLevels = (/0.01,0.015,0.02,0.025,0.03,0.035,0.04,0.045,0.05,0.055,0.06/) - res@cnFillColors = (/2,6,12,40,45,51,62,72,80,89,96,101/) ; color of a contour - plot_rc1 = gsn_csm_contour_map(wks,rc_t2_plane(:,:),res) - draw(plot_rc1) - frame(wks) - delete(res@cnLevels) - delete(res@cnFillColors) - -; plot ozone - res@cnLevelSelectionMode = "ExplicitLevels" ; method for selecting the contour - res@cnLevels = (/15.,20., 25., 35., 40., 45., 50., 55., 60., 65./) - res@cnFillColors = (/2,6,12,40,45,51,62,72,80,89,96/) ; color of a contour -; res@cnLevelSelectionMode = "AutomaticLevels" - plot_o31 = gsn_csm_contour_map(wks,o3_t2_plane(:,:),res) - draw(plot_o31) - frame(wks) - delete(res@cnLevels) - delete(res@cnFillColors) - -; plot co - res@cnLevelSelectionMode = "ExplicitLevels" ; method for selecting the contour - res@cnLevels = (/110.,112.5,115.,117.5,120.,122.5,125.,127.5,130.,132.5,135./) - res@cnFillColors = (/2,6,12,40,45,51,62,72,80,89,96,101/) ; color of a contour -; res@cnLevelSelectionMode = "AutomaticLevels" - plot_co1 = gsn_csm_contour_map(wks,co_t2_plane(:,:),res) - draw(plot_co1) - frame(wks) - -; plot ozone production - res@cnLevelSelectionMode = "ExplicitLevels" ; method for selecting the contour - res@cnLevels = (/75,80,85,90,95,100,105,110,115,120,125/) - res@cnFillColors = (/75,80,85,90,95,100,105,110,115,120,125,130/) ; color of a contour -; res@cnLevelSelectionMode = "AutomaticLevels" - plot_o3p1 = gsn_csm_contour_map(wks,o3p_t2_plane(:,:),res) - draw(plot_o3p1) - frame(wks) - delete(res@cnLevels) - delete(res@cnFillColors) - -; plot ozone loss - res@cnLevelSelectionMode = "ExplicitLevels" ; method for selecting the contour - res@cnLevels = (/75,80,85,90,95,100,105,110,115,120,125/) - res@cnFillColors = (/75,80,85,90,95,100,105,110,115,120,125,130/) ; color of a contour -; res@cnLevelSelectionMode = "AutomaticLevels" - plot_o3l1 = gsn_csm_contour_map(wks,o3l_t2_plane(:,:),res) - draw(plot_o3l1) - frame(wks) - delete(res@cnLevels) - delete(res@cnFillColors) - -; plot carbon monoxide production - res@cnLevelSelectionMode = "ExplicitLevels" ; method for selecting the contour - res@cnLevels = (/0.6,0.7,0.8,0.9,1.0,1.1,1.2,1.3,1.4,1.5,1.6/) - res@cnFillColors := (/0.6,0.7,0.8,0.9,1.0,1.1,1.2,1.3,1.4,1.5,1.6/) ; color of a contour -; res@cnLevelSelectionMode = "AutomaticLevels" - plot_cop1 = gsn_csm_contour_map(wks,cop_t2_plane(:,:),res) - draw(plot_cop1) - frame(wks) - delete(res@cnLevels) - delete(res@cnFillColors) - -; plot carbon monoxide loss - res@cnLevelSelectionMode = "ExplicitLevels" ; method for selecting the contour - res@cnLevels = (/0.6,0.7,0.8,0.9,1.0,1.1,1.2,1.3,1.4,1.5,1.6/) - res@cnFillColors := (/0.6,0.7,0.8,0.9,1.0,1.1,1.2,1.3,1.4,1.5,1.6/) ; color of a contour -; res@cnLevelSelectionMode = "AutomaticLevels" - plot_col1 = gsn_csm_contour_map(wks,col_t2_plane(:,:),res) - draw(plot_col1) - frame(wks) - delete(res@cnLevels) - delete(res@cnFillColors) - -;;;;;;;;;;;;;;;;;;;;;;;; - -end - - - +;================================================; +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/wrf/WRFUserARW.ncl" +; ================================================; +begin +;=================================================; +; open file and read in data +;=================================================; + a = addfile("ICART.1.SEG01.001dg.nc", "r") + a2 = addfile("ICART.1.SEG01.002dg.nc", "r") + +;=================================================; +; Get informations on variable sizes +; dims are dims-2 to remove non-physical values +;=================================================; + jphext = a->JPHEXT + mdims = getfilevardimsizes(a,"UT") + nd = dimsizes(mdims) + imax=mdims(nd-1)-2*jphext + jmax=mdims(nd-2)-2*jphext + kmax=mdims(nd-3)-2 + +;-------------------------------------------------; +; Read data. +;-------------------------------------------------; + lat2d = a->LAT(jphext:jmax+jphext-1,jphext:imax+jphext-1) + lat2d@units="degrees_north" + lon2d = a->LON(jphext:jmax+jphext-1,jphext:imax+jphext-1) + lon2d@units="degrees_east" + +zs = a->ZS(jphext:jmax+jphext-1,jphext:imax+jphext-1) ; ZS +zs@long_name="Orography" +zs@units="m" +zs@lat2d = lat2d +zs@lon2d = lon2d + +printMinMax(zs,0) + + rc_t1 = a->MRC(1:kmax,jphext:jmax+jphext-1,jphext:imax+jphext-1) + rc_t1@long_name="Cloud mixing ratio" + rc_t1@units="g/kg" + rc_t1@lat2d=lat2d + rc_t1@lon2d=lon2d +printMinMax(rc_t1,0) + +; + o3_t1 = a->O3T(1:kmax,jphext:jmax+jphext-1,jphext:imax+jphext-1) + o3_t1@long_name="Ozone" + o3_t1@units="ppbv" + o3_t1@lat2d=lat2d + o3_t1@lon2d=lon2d + +; + co_t1 = a->COT(1:kmax,jphext:jmax+jphext-1,jphext:imax+jphext-1) + co_t1@long_name="carbon monoxide" + co_t1@units="ppbv" + co_t1@lat2d=lat2d + co_t1@lon2d=lon2d + +; + o3p_t1=a->O3_PROD(1:kmax,jphext:jmax+jphext-1,jphext:imax+jphext-1) + o3p_t1 = o3p_t1*1e9*3600 + o3p_t1@long_name="ozone production" + o3p_t1@units="ppbv/h" + o3p_t1@lat2d=lat2d + o3p_t1@lon2d=lon2d + +; + o3l_t1=a->O3_LOSS(1:kmax,jphext:jmax+jphext-1,jphext:imax+jphext-1) + o3l_t1 = o3l_t1*1e9*3600 + o3l_t1@long_name="ozone loss" + o3l_t1@units="ppbv/h" + o3l_t1@lat2d=lat2d + o3l_t1@lon2d=lon2d + +; + cop_t1=a->CO_PROD(1:kmax,jphext:jmax+jphext-1,jphext:imax+jphext-1) + cop_t1 = cop_t1*1e9*3600 + cop_t1@long_name="carbon monoxide production" + cop_t1@units="ppbv/h" + cop_t1@lat2d=lat2d + cop_t1@lon2d=lon2d + +; + col_t1=a->CO_LOSS(1:kmax,jphext:jmax+jphext-1,jphext:imax+jphext-1) + col_t1 = col_t1*1e9*3600 + col_t1@long_name="carbon monoxide loss" + col_t1@units="ppbv/h" + col_t1@lat2d=lat2d + col_t1@lon2d=lon2d + + +; +; + rc_t2 = a2->MRC(1:kmax,jphext:jmax+jphext-1,jphext:imax+jphext-1) + rc_t2@long_name="Cloud mixing ratio" + rc_t2@units="g/kg" + rc_t2@lat2d=lat2d + rc_t2@lon2d=lon2d + +; + o3_t2 = a2->O3T(1:kmax,jphext:jmax+jphext-1,jphext:imax+jphext-1) + o3_t2@long_name="Ozone" + o3_t2@units="ppbv" + o3_t2@lat2d=lat2d + o3_t2@lon2d=lon2d + +; + co_t2 = a2->COT(1:kmax,jphext:jmax+jphext-1,jphext:imax+jphext-1) + co_t2@long_name="carbon monoxide" + co_t2@units="ppbv" + co_t2@lat2d=lat2d + co_t2@lon2d=lon2d + +; + o3p_t2=a2->O3_PROD(1:kmax,jphext:jmax+jphext-1,jphext:imax+jphext-1) + o3p_t2=o3p_t2*1e9*3600 + o3p_t2@long_name="ozone production" + o3p_t2@units="pptv/h" + o3p_t2@lat2d=lat2d + o3p_t2@lon2d=lon2d + +; + o3l_t2=a2->O3_LOSS(1:kmax,jphext:jmax+jphext-1,jphext:imax+jphext-1) + o3l_t2=o3l_t2*1e9*3600 + o3l_t2@long_name="ozone loss" + o3l_t2@units="pptv/h" + o3l_t2@lat2d=lat2d + o3l_t2@lon2d=lon2d + +; + cop_t2=a2->CO_PROD(1:kmax,jphext:jmax+jphext-1,jphext:imax+jphext-1) + cop_t2=cop_t2*1e9*3600 + cop_t2@long_name="carbon monoxide production" + cop_t2@units="pptv/h" + cop_t2@lat2d=lat2d + cop_t2@lon2d=lon2d + +; + col_t2=a2->CO_LOSS(1:kmax,jphext:jmax+jphext-1,jphext:imax+jphext-1) + col_t2=col_t2*1e9*3600 + col_t2@long_name="carbon monoxide loss" + col_t2@units="ppbv/h" + col_t2@lat2d=lat2d + col_t2@lon2d=lon2d + + + +;-----------------------------------------------; +;=================================================; +; On calcule l'altitude des champs modèle +;=================================================; + +zhat= a2->ZHAT(1:kmax+1) + +; Unstagger zhat (from grid 4 to 1) + nzhat=new(kmax,double) + do k=0,kmax-1 + nzhat(k)=(zhat(k)+zhat(k+1))/2. + end do + +; Create Z3D == ALT + alt=new(dimsizes(o3_t2),double) + zcoef=1.-zs/nzhat(kmax-1) + + do i=0,imax-1 + do j=0,jmax-1 + alt(:,j,i) = nzhat*zcoef(j,i)+zs(j,i) + end do + end do + +alt@lat2d = lat2d +alt@lon2d = lon2d + + + + +;-----------------------------------------------; +; Set map projection ressources using projection parameters +;-----------------------------------------------; +; Read projection parameters +; -------------------- + RPK = a2->RPK + BETA = a2->BETA + LON0 = a2->LON0 + + resmap=True + if (RPK.gt.0) +; --------------------------- + ; Lambert projection from north pole +; --------------------------- + resmap@mpProjection = "LambertConformal" ; projection + pole = 1 ; projection for north hemisphere + resmap@mpLambertParallel1F = pole*asin(RPK)*180/3.14 ; with pole=1 for north hemisphere and -1 for south hemisphere + resmap@mpLambertParallel2F = resmap@mpLambertParallel1F ; ncl adds from grib file + resmap@mpLambertMeridianF = LON0 ; ncl adds from grib file + end if + + if (RPK.lt.0) +; --------------------------- + ; Lambert projection from south pole +; --------------------------- + resmap@mpProjection = "LambertConformal" ; projection + pole = -1 ; projection for south hemisphere + resmap@mpLambertParallel1F = pole*asin(RPK)*180/3.14 ; with pole=1 for north hemisphere and -1 for south hemisphere + resmap@mpLambertParallel2F = resmap@mpLambertParallel1F ; ncl adds from grib file + resmap@mpLambertMeridianF = LON0 ; ncl adds from grib file + end if + + if (RPK.eq.1) +; --------------------------- + ; Stereographic projection north +; --------------------------- + resmap@mpProjection = "Stereographic" + resmap@mpCenterLonF = LON0 + resmap@mpCenterRotF = BETA + resmap@mpCenterLatF = 90 + end if + + if (RPK.eq.-1) +; --------------------------- + ; Stereographic projection south +; --------------------------- + resmap@mpProjection = "Stereographic" + resmap@mpCenterLonF = LON0 + resmap@mpCenterRotF = BETA + resmap@mpCenterLatF = -90 + end if + + if (RPK.eq.0) then +; --------------------------- + ; Mercator projection +; --------------------------- + resmap@mpProjection = "Mercator" + end if + + print("Map projection="+resmap@mpProjection) + +; Defining the corners for projection +; -------------------------------- + resmap@mpLimitMode = "Corners" + resmap@mpLeftCornerLatF = lat2d(0,0) + resmap@mpLeftCornerLonF = lon2d(0,0) + resmap@mpRightCornerLatF = lat2d(jmax-1,imax-1) + resmap@mpRightCornerLonF = lon2d(jmax-1,imax-1) + +;=================================================; +; PLOT +;=================================================; +; interpolation des champs a 1250 m +rc_t1_plane = wrf_user_intrp3d(rc_t1,alt,"h",1250,0.,False) +printMinMax(rc_t1_plane,0) +printMinMax(alt,0) + +rc_t2_plane = wrf_user_intrp3d(rc_t2,alt,"h",1250,0.,False) +co_t1_plane = wrf_user_intrp3d(co_t1,alt,"h",1250,0.,False) +co_t2_plane = wrf_user_intrp3d(co_t2,alt,"h",1250,0.,False) +cop_t1_plane= wrf_user_intrp3d(cop_t1,alt,"h",1250,0.,False) +cop_t2_plane= wrf_user_intrp3d(cop_t2,alt,"h",1250,0.,False) +col_t1_plane= wrf_user_intrp3d(col_t1,alt,"h",1250,0.,False) +col_t2_plane= wrf_user_intrp3d(col_t2,alt,"h",1250,0.,False) +o3_t1_plane = wrf_user_intrp3d(o3_t1,alt,"h",1250,0.,False) +o3_t2_plane = wrf_user_intrp3d(o3_t2,alt,"h",1250,0.,False) +o3l_t1_plane= wrf_user_intrp3d(o3l_t1,alt,"h",1250,0.,False) +o3l_t2_plane= wrf_user_intrp3d(o3l_t2,alt,"h",1250,0.,False) +o3p_t1_plane= wrf_user_intrp3d(o3p_t1,alt,"h",1250,0.,False) +o3p_t2_plane= wrf_user_intrp3d(o3p_t2,alt,"h",1250,0.,False) + + + figname ="zsection_1250" + wks = gsn_open_wks("png",figname) ; open a ncgm file + gsn_define_colormap(wks,"WhBlGrYeRe") ; Choose colormap + + res = resmap + res@gsnDraw = False ; don't draw yet + res@gsnFrame = False ; don't advance frame yet + +; X-axis title (tiY) + res@tiXAxisFontHeightF = 0.018 ; font height + res@tiXAxisFont = 21 ; font index + res@tiXAxisString = "longitude" ; string to use as the X-Axis title + +; Y-axis title (tiY) + res@tiYAxisFontHeightF = 0.018 ; font height + res@tiYAxisFont = 21 ; font index + res@tiYAxisString = "latitude" ; string to use as the Y-Axis title + +; BW + res@cnLinesOn = False + res@cnFillOn = True + res@gsnSpreadColors = True +; +; label bar (lb) +; res@lbAutoManage = False +; res@lbBottomMarginF = 0.4 ; offset +; res@lbOrientation = "Vertical" + +; Map ressources +; res@mpDataBaseVersion = "HighRes" ; choose highres map data version (must be donwloaded) +; res@mpDataBaseVersion = "MediumRes" ; choose highres map data version (must be donwloaded) + res@mpGridAndLimbOn = True ; turn on lat/lon lines + res@mpGridLatSpacingF = 10. ; spacing for lat lines + res@mpGridLonSpacingF = 10. ; spacing for lon lines + + res@mpGeophysicalLineColor = "Black" ; default value in lowres + res@mpNationalLineColor = "Black" ; idem + res@mpUSStateLineColor = "Black" ; idem + res@mpGridLineColor = "Black" + res@mpLimbLineColor = "Black" + res@mpPerimLineColor = "Black" + + + res@gsnCenterString="heure=19" + +; plot cloud mixing ratio + res@cnLevelSelectionMode = "ExplicitLevels" + res@cnLevels = (/0.01,0.015,0.02,0.025,0.03,0.035,0.04,0.045,0.05,0.055,0.06/) + res@cnFillColors = (/2,6,12,40,45,51,62,72,80,89,96,101/) ; color of a contour + plot_rc = gsn_csm_contour_map(wks,rc_t1_plane(:,:),res) + draw(plot_rc) + frame(wks) + delete(res@cnLevels) + delete(res@cnFillColors) + +; plot ozone + res@cnLevelSelectionMode = "ExplicitLevels" ; method for selecting the contour + res@cnLevels = (/15.,20., 25., 35., 40., 45., 50., 55., 60., 65./) + res@cnFillColors = (/2,6,12,40,45,51,62,72,80,89,96/) ; color of a contour +; res@cnLevelSelectionMode = "AutomaticLevels" + plot_o3 = gsn_csm_contour_map(wks,o3_t1_plane(:,:),res) + draw(plot_o3) + frame(wks) + delete(res@cnLevels) + delete(res@cnFillColors) + +; plot co + res@cnLevelSelectionMode = "ExplicitLevels" ; method for selecting the contour + res@cnLevels = (/110.,112.5,115.,117.5,120.,122.5,125.,127.5,130.,132.5,135./) + res@cnFillColors = (/2,6,12,40,45,51,62,72,80,89,96,101/) ; color of a contour +; res@cnLevelSelectionMode = "AutomaticLevels" + plot_co = gsn_csm_contour_map(wks,co_t1_plane(:,:),res) + draw(plot_co) + frame(wks) + delete(res@cnLevels) + delete(res@cnFillColors) + +; plot ozone production + res@cnLevelSelectionMode = "ExplicitLevels" ; method for selecting the contour + res@cnLevels = (/75,80,85,90,95,100,105,110,115,120,125/) + res@cnFillColors = (/75,80,85,90,95,100,105,110,115,120,125,130/) ; color of a contour +; res@cnLevelSelectionMode = "AutomaticLevels" + plot_o3p = gsn_csm_contour_map(wks,o3p_t1_plane(:,:),res) + draw(plot_o3p) + frame(wks) + delete(res@cnLevels) + delete(res@cnFillColors) + +; plot ozone loss + res@cnLevelSelectionMode = "ExplicitLevels" ; method for selecting the contour + res@cnLevels = (/75,80,85,90,95,100,105,110,115,120,125/) + res@cnFillColors = (/75,80,85,90,95,100,105,110,115,120,125,130/) ; color of a contour +; res@cnLevelSelectionMode = "AutomaticLevels" + plot_o3l = gsn_csm_contour_map(wks,o3l_t1_plane(:,:),res) + draw(plot_o3l) + frame(wks) + delete(res@cnLevels) + delete(res@cnFillColors) + +; plot carbon monoxide production + res@cnLevelSelectionMode = "ExplicitLevels" ; method for selecting the contour + res@cnLevels = (/0.6,0.7,0.8,0.9,1.0,1.1,1.2,1.3,1.4,1.5,1.6/) + res@cnFillColors := (/0.6,0.7,0.8,0.9,1.0,1.1,1.2,1.3,1.4,1.5,1.6/) ; color of a contour +; res@cnLevelSelectionMode = "AutomaticLevels" + plot_cop = gsn_csm_contour_map(wks,cop_t1_plane(:,:),res) + draw(plot_cop) + frame(wks) + delete(res@cnLevels) + delete(res@cnFillColors) + +; plot carbon monoxide loss + res@cnLevelSelectionMode = "ExplicitLevels" ; method for selecting the contour + res@cnLevels = (/0.6,0.7,0.8,0.9,1.0,1.1,1.2,1.3,1.4,1.5,1.6/) + res@cnFillColors := (/0.6,0.7,0.8,0.9,1.0,1.1,1.2,1.3,1.4,1.5,1.6/) ; color of a contour +; res@cnLevelSelectionMode = "AutomaticLevels" + plot_col = gsn_csm_contour_map(wks,col_t1_plane(:,:),res) + draw(plot_col) + frame(wks) + delete(res@cnLevels) + delete(res@cnFillColors) + + res@gsnCenterString="heure=20" + +; plot cloud mixing ratio + res@cnLevelSelectionMode = "ExplicitLevels" + res@cnLevels = (/0.01,0.015,0.02,0.025,0.03,0.035,0.04,0.045,0.05,0.055,0.06/) + res@cnFillColors = (/2,6,12,40,45,51,62,72,80,89,96,101/) ; color of a contour + plot_rc1 = gsn_csm_contour_map(wks,rc_t2_plane(:,:),res) + draw(plot_rc1) + frame(wks) + delete(res@cnLevels) + delete(res@cnFillColors) + +; plot ozone + res@cnLevelSelectionMode = "ExplicitLevels" ; method for selecting the contour + res@cnLevels = (/15.,20., 25., 35., 40., 45., 50., 55., 60., 65./) + res@cnFillColors = (/2,6,12,40,45,51,62,72,80,89,96/) ; color of a contour +; res@cnLevelSelectionMode = "AutomaticLevels" + plot_o31 = gsn_csm_contour_map(wks,o3_t2_plane(:,:),res) + draw(plot_o31) + frame(wks) + delete(res@cnLevels) + delete(res@cnFillColors) + +; plot co + res@cnLevelSelectionMode = "ExplicitLevels" ; method for selecting the contour + res@cnLevels = (/110.,112.5,115.,117.5,120.,122.5,125.,127.5,130.,132.5,135./) + res@cnFillColors = (/2,6,12,40,45,51,62,72,80,89,96,101/) ; color of a contour +; res@cnLevelSelectionMode = "AutomaticLevels" + plot_co1 = gsn_csm_contour_map(wks,co_t2_plane(:,:),res) + draw(plot_co1) + frame(wks) + +; plot ozone production + res@cnLevelSelectionMode = "ExplicitLevels" ; method for selecting the contour + res@cnLevels = (/75,80,85,90,95,100,105,110,115,120,125/) + res@cnFillColors = (/75,80,85,90,95,100,105,110,115,120,125,130/) ; color of a contour +; res@cnLevelSelectionMode = "AutomaticLevels" + plot_o3p1 = gsn_csm_contour_map(wks,o3p_t2_plane(:,:),res) + draw(plot_o3p1) + frame(wks) + delete(res@cnLevels) + delete(res@cnFillColors) + +; plot ozone loss + res@cnLevelSelectionMode = "ExplicitLevels" ; method for selecting the contour + res@cnLevels = (/75,80,85,90,95,100,105,110,115,120,125/) + res@cnFillColors = (/75,80,85,90,95,100,105,110,115,120,125,130/) ; color of a contour +; res@cnLevelSelectionMode = "AutomaticLevels" + plot_o3l1 = gsn_csm_contour_map(wks,o3l_t2_plane(:,:),res) + draw(plot_o3l1) + frame(wks) + delete(res@cnLevels) + delete(res@cnFillColors) + +; plot carbon monoxide production + res@cnLevelSelectionMode = "ExplicitLevels" ; method for selecting the contour + res@cnLevels = (/0.6,0.7,0.8,0.9,1.0,1.1,1.2,1.3,1.4,1.5,1.6/) + res@cnFillColors := (/0.6,0.7,0.8,0.9,1.0,1.1,1.2,1.3,1.4,1.5,1.6/) ; color of a contour +; res@cnLevelSelectionMode = "AutomaticLevels" + plot_cop1 = gsn_csm_contour_map(wks,cop_t2_plane(:,:),res) + draw(plot_cop1) + frame(wks) + delete(res@cnLevels) + delete(res@cnFillColors) + +; plot carbon monoxide loss + res@cnLevelSelectionMode = "ExplicitLevels" ; method for selecting the contour + res@cnLevels = (/0.6,0.7,0.8,0.9,1.0,1.1,1.2,1.3,1.4,1.5,1.6/) + res@cnFillColors := (/0.6,0.7,0.8,0.9,1.0,1.1,1.2,1.3,1.4,1.5,1.6/) ; color of a contour +; res@cnLevelSelectionMode = "AutomaticLevels" + plot_col1 = gsn_csm_contour_map(wks,col_t2_plane(:,:),res) + draw(plot_col1) + frame(wks) + delete(res@cnLevels) + delete(res@cnFillColors) + +;;;;;;;;;;;;;;;;;;;;;;;; + +end + + + diff --git a/MY_RUN/KTEST/009_ICARTT/006_ncl/plot_ICARTT_budget.ncl b/MY_RUN/KTEST/009_ICARTT/006_ncl/plot_ICARTT_budget.ncl index 5319e9bd1405a5a858dbdd055d0a3dad106479cf..4350a7ae8f3c87264279a4e3a2eec3297a5e1473 100644 --- a/MY_RUN/KTEST/009_ICARTT/006_ncl/plot_ICARTT_budget.ncl +++ b/MY_RUN/KTEST/009_ICARTT/006_ncl/plot_ICARTT_budget.ncl @@ -1,149 +1,149 @@ -;================================================; -load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" -load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" -load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" -load "$NCARG_ROOT/lib/ncarg/nclscripts/wrf/WRFUserARW.ncl" -; ================================================; -begin -;=================================================; -; open file and read in data -;=================================================; - a = addfile("ICART.1.SEG01.001dg.nc", "r") - a2 = addfile("ICART.1.SEG01.002dg.nc", "r") - -;=================================================; -; Get informations on variable sizes -; dims are dims-2 to remove non-physical values -;=================================================; - jphext = a->JPHEXT - mdims = getfilevardimsizes(a,"THT") ; get dimension sizes - nd = dimsizes(mdims) - imax=mdims(nd-1)-2*jphext - jmax=mdims(nd-2)-2*jphext - kmax=mdims(nd-3)-2 - -;-------------------------------------------------; -; Read data. -;-------------------------------------------------; - -; Liste de toutes les réactions impliquant O3 - o3_list_t1=a->O3_CHREACLIST - -; Tableau 4D (reac,Z,Y,X) regroupant les termes de prod. et destr. de O3 -; Niveau k=13 approx. 1250m - o3_budget_t1=a->O3_BUDGET(:,13,jphext:jmax+jphext-1,jphext:imax+jphext-1) - o3_bud_t1=dim_avg_n(o3_budget_t1,(/1,2/)) - o3_bud_t1=o3_bud_t1*1e9*3600 - o3_bud_t1@units="ppbv/h" - -; Liste de toutes les réactions impliquant CO - co_list_t1=a->CO_CHREACLIST - -; Tableau 4D (reac,Z,Y,X) regroupant les termes de prod. et destr. de CO -; Niveau k=13 approx. 1250m - co_budget_t1=a->CO_BUDGET(:,13,jphext:jmax+jphext-1,jphext:imax+jphext-1) - co_bud_t1=dim_avg_n(co_budget_t1,(/1,2/)) - co_bud_t1=co_bud_t1*1e9*3600 - co_bud_t1@units="ppbv/h" - -; Liste de toutes les réactions impliquant O3 - o3_list_t2=a2->O3_CHREACLIST - -; Tableau 4D (reac,Z,Y,X) regroupant les termes de prod. et destr. de O3 -; Niveau k=13 approx. 1250m - o3_budget_t2=a2->O3_BUDGET(:,13,jphext:jmax+jphext-1,jphext:imax+jphext-1) - o3_bud_t2=dim_avg_n(o3_budget_t2,(/1,2/)) - o3_bud_t2=o3_bud_t2*1e9*3600 - o3_bud_t2@units="ppbv/h" - -; Liste de toutes les réactions impliquant CO - co_list_t2=a2->CO_CHREACLIST - -; Tableau 4D (reac,Z,Y,X) regroupant les termes de prod. et destr. de CO -; Niveau k=13 approx. 1250m - co_budget_t2=a2->CO_BUDGET(:,13,jphext:jmax+jphext-1,jphext:imax+jphext-1) - co_bud_t2=dim_avg_n(co_budget_t2,(/1,2/)) - co_bud_t2=co_bud_t2*1e9*3600 - co_bud_t2@units="ppbv/h" - -;=================================================; -; PLOT -;=================================================; -; interpolation des champs a 1250 m - - figname ="zsection_1250_bud" - wks = gsn_open_wks("png",figname) ; open a ncgm file - gsn_define_colormap(wks,"WhBlGrYeRe") ; Choose colormap - - res = True - res@gsnDraw = False ; don't draw yet - res@gsnFrame = False ; don't advance frame yet - -; X-axis title (tiY) - res@tiXAxisFontHeightF = 0.018 ; font height - res@tiXAxisFont = 21 ; font index - res@tiXAxisString = "Chemical reactions" ; string to use as the X-Axis title - -; Y-axis title (tiY) - res@tiYAxisFontHeightF = 0.018 ; font height - res@tiYAxisFont = 21 ; font index - -; Bar plot - res@gsnXYBarChart = True ; turn on bar chat - res@gsnYRefLine = 0. ; reference line - res@gsnAboveYRefLineColor = "red" ; above ref line fill red - res@gsnBelowYRefLineColor = "blue" ; below ref line fill blue - res@xyCurveDrawOrder = "PreDraw" - res@tmYLFormat = "0@*+^sg" - res@tmYLPrecision = 2 - res@tmXBOn=False - - txres = True ; text mods desired - txres@txFontHeightF = 0.018 - txres@txAngleF = 90 ; text angle - txres@txJust = "TopCenter" ; puts text on top of bars - - res@gsnCenterString="heure=19" - -; plot ozone production - res@tiYAxisString = "ozone budget (ppbv/h)" ; string to use as the Y-Axis title - x=ispan(0,dimsizes(o3_bud_t1)-1,1) - plot_o3_t1 = gsn_csm_xy(wks,x,o3_bud_t1(:),res) - text=gsn_add_text(wks,plot_o3_t1,tostring(o3_list_t1(:)),x,o3_bud_t1(:),txres) ; add label - draw(plot_o3_t1) - frame(wks) - -; plot ozone production - res@tiYAxisString = "carbon monoxide budget (ppbv/h)" ; string to use as the Y-Axis title - x:=ispan(0,dimsizes(co_bud_t1)-1,1) - plot_co_t1 = gsn_csm_xy(wks,x,co_bud_t1(:),res) - text:=gsn_add_text(wks,plot_co_t1,tostring(co_list_t1(:)),x,co_bud_t1(:),txres) ; add label - draw(plot_co_t1) - frame(wks) - - res@gsnCenterString="heure=20" - -; plot ozone production - res@tiYAxisString = "ozone budget (ppbv/h)" ; string to use as the Y-Axis title - x:=ispan(0,dimsizes(o3_bud_t2)-1,1) - plot_o3_t2 = gsn_csm_xy(wks,x,o3_bud_t2(:),res) - text:=gsn_add_text(wks,plot_o3_t1,tostring(o3_list_t2(:)),x,o3_bud_t2(:),txres) ; add label - draw(plot_o3_t2) - frame(wks) - -; plot ozone production - res@tiYAxisString = "carbon monoxide budget (ppbv/h)" ; string to use as the Y-Axis title - x:=ispan(0,dimsizes(co_bud_t2)-1,1) - plot_co_t2 = gsn_csm_xy(wks,x,co_bud_t2(:),res) - text:=gsn_add_text(wks,plot_co_t2,tostring(co_list_t2(:)),x,co_bud_t2(:),txres) ; add label - draw(plot_co_t2) - frame(wks) - - - -;;;;;;;;;;;;;;;;;;;;;;;; - -end - - - +;================================================; +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/wrf/WRFUserARW.ncl" +; ================================================; +begin +;=================================================; +; open file and read in data +;=================================================; + a = addfile("ICART.1.SEG01.001dg.nc", "r") + a2 = addfile("ICART.1.SEG01.002dg.nc", "r") + +;=================================================; +; Get informations on variable sizes +; dims are dims-2 to remove non-physical values +;=================================================; + jphext = a->JPHEXT + mdims = getfilevardimsizes(a,"THT") ; get dimension sizes + nd = dimsizes(mdims) + imax=mdims(nd-1)-2*jphext + jmax=mdims(nd-2)-2*jphext + kmax=mdims(nd-3)-2 + +;-------------------------------------------------; +; Read data. +;-------------------------------------------------; + +; Liste de toutes les réactions impliquant O3 + o3_list_t1=a->O3_CHREACLIST + +; Tableau 4D (reac,Z,Y,X) regroupant les termes de prod. et destr. de O3 +; Niveau k=13 approx. 1250m + o3_budget_t1=a->O3_BUDGET(:,13,jphext:jmax+jphext-1,jphext:imax+jphext-1) + o3_bud_t1=dim_avg_n(o3_budget_t1,(/1,2/)) + o3_bud_t1=o3_bud_t1*1e9*3600 + o3_bud_t1@units="ppbv/h" + +; Liste de toutes les réactions impliquant CO + co_list_t1=a->CO_CHREACLIST + +; Tableau 4D (reac,Z,Y,X) regroupant les termes de prod. et destr. de CO +; Niveau k=13 approx. 1250m + co_budget_t1=a->CO_BUDGET(:,13,jphext:jmax+jphext-1,jphext:imax+jphext-1) + co_bud_t1=dim_avg_n(co_budget_t1,(/1,2/)) + co_bud_t1=co_bud_t1*1e9*3600 + co_bud_t1@units="ppbv/h" + +; Liste de toutes les réactions impliquant O3 + o3_list_t2=a2->O3_CHREACLIST + +; Tableau 4D (reac,Z,Y,X) regroupant les termes de prod. et destr. de O3 +; Niveau k=13 approx. 1250m + o3_budget_t2=a2->O3_BUDGET(:,13,jphext:jmax+jphext-1,jphext:imax+jphext-1) + o3_bud_t2=dim_avg_n(o3_budget_t2,(/1,2/)) + o3_bud_t2=o3_bud_t2*1e9*3600 + o3_bud_t2@units="ppbv/h" + +; Liste de toutes les réactions impliquant CO + co_list_t2=a2->CO_CHREACLIST + +; Tableau 4D (reac,Z,Y,X) regroupant les termes de prod. et destr. de CO +; Niveau k=13 approx. 1250m + co_budget_t2=a2->CO_BUDGET(:,13,jphext:jmax+jphext-1,jphext:imax+jphext-1) + co_bud_t2=dim_avg_n(co_budget_t2,(/1,2/)) + co_bud_t2=co_bud_t2*1e9*3600 + co_bud_t2@units="ppbv/h" + +;=================================================; +; PLOT +;=================================================; +; interpolation des champs a 1250 m + + figname ="zsection_1250_bud" + wks = gsn_open_wks("png",figname) ; open a ncgm file + gsn_define_colormap(wks,"WhBlGrYeRe") ; Choose colormap + + res = True + res@gsnDraw = False ; don't draw yet + res@gsnFrame = False ; don't advance frame yet + +; X-axis title (tiY) + res@tiXAxisFontHeightF = 0.018 ; font height + res@tiXAxisFont = 21 ; font index + res@tiXAxisString = "Chemical reactions" ; string to use as the X-Axis title + +; Y-axis title (tiY) + res@tiYAxisFontHeightF = 0.018 ; font height + res@tiYAxisFont = 21 ; font index + +; Bar plot + res@gsnXYBarChart = True ; turn on bar chat + res@gsnYRefLine = 0. ; reference line + res@gsnAboveYRefLineColor = "red" ; above ref line fill red + res@gsnBelowYRefLineColor = "blue" ; below ref line fill blue + res@xyCurveDrawOrder = "PreDraw" + res@tmYLFormat = "0@*+^sg" + res@tmYLPrecision = 2 + res@tmXBOn=False + + txres = True ; text mods desired + txres@txFontHeightF = 0.018 + txres@txAngleF = 90 ; text angle + txres@txJust = "TopCenter" ; puts text on top of bars + + res@gsnCenterString="heure=19" + +; plot ozone production + res@tiYAxisString = "ozone budget (ppbv/h)" ; string to use as the Y-Axis title + x=ispan(0,dimsizes(o3_bud_t1)-1,1) + plot_o3_t1 = gsn_csm_xy(wks,x,o3_bud_t1(:),res) + text=gsn_add_text(wks,plot_o3_t1,tostring(o3_list_t1(:)),x,o3_bud_t1(:),txres) ; add label + draw(plot_o3_t1) + frame(wks) + +; plot ozone production + res@tiYAxisString = "carbon monoxide budget (ppbv/h)" ; string to use as the Y-Axis title + x:=ispan(0,dimsizes(co_bud_t1)-1,1) + plot_co_t1 = gsn_csm_xy(wks,x,co_bud_t1(:),res) + text:=gsn_add_text(wks,plot_co_t1,tostring(co_list_t1(:)),x,co_bud_t1(:),txres) ; add label + draw(plot_co_t1) + frame(wks) + + res@gsnCenterString="heure=20" + +; plot ozone production + res@tiYAxisString = "ozone budget (ppbv/h)" ; string to use as the Y-Axis title + x:=ispan(0,dimsizes(o3_bud_t2)-1,1) + plot_o3_t2 = gsn_csm_xy(wks,x,o3_bud_t2(:),res) + text:=gsn_add_text(wks,plot_o3_t1,tostring(o3_list_t2(:)),x,o3_bud_t2(:),txres) ; add label + draw(plot_o3_t2) + frame(wks) + +; plot ozone production + res@tiYAxisString = "carbon monoxide budget (ppbv/h)" ; string to use as the Y-Axis title + x:=ispan(0,dimsizes(co_bud_t2)-1,1) + plot_co_t2 = gsn_csm_xy(wks,x,co_bud_t2(:),res) + text:=gsn_add_text(wks,plot_co_t2,tostring(co_list_t2(:)),x,co_bud_t2(:),txres) ; add label + draw(plot_co_t2) + frame(wks) + + + +;;;;;;;;;;;;;;;;;;;;;;;; + +end + + + diff --git a/MY_RUN/KTEST/011_KW78CHEM/002_mesonh/MNHC.input b/MY_RUN/KTEST/011_KW78CHEM/002_mesonh/MNHC.input index 354c01315be1e1a09f062604cdc346d35aa36377..bcd7d87f8432442378e5f303d05147af8fbe9e87 100644 --- a/MY_RUN/KTEST/011_KW78CHEM/002_mesonh/MNHC.input +++ b/MY_RUN/KTEST/011_KW78CHEM/002_mesonh/MNHC.input @@ -1,239 +1,239 @@ -=================================================================== -*** the following section will be read by ch_field_valuen.f90 *** -=================================================================== - -FORMPROF - Z UNI(norm) STRATO(norm) BL(norm) - 11 3 -(F7.0,3E13.3) - 0. 1.000E-00 1.000E-00 1.000E-00 - 1000. 1.000E-00 1.000E-00 1.000E-00 - 2000. 1.000E-00 1.000E-00 0.100E-00 - 3000. 1.000E-00 0.500E-00 0.100E-00 - 4000. 1.000E-00 0.500E-00 0.100E-00 - 5000. 1.000E-00 0.500E-00 0.100E-00 - 6000. 1.000E-00 0.500E-00 0.100E-00 - 7000. 1.000E-00 0.500E-00 0.100E-00 - 8000. 1.000E-00 0.500E-00 0.100E-00 - 9000. 1.000E-00 0.800E-00 0.050E-00 - 10000. 1.000E-00 1.000E-00 0.050E-00 - -=================================================================== -*** the following section will be read by ch_field_valuen.f90 *** -=================================================================== - -NORMINIT -initial values (units are par per part = MIX) -MIX -23 -(1X,A12,1X,E25.8) -'O3 ' 40.00E-09 -'H2O2 ' 1.00E-09 -'NO ' 100.00E-12 -'NO2 ' 100.00E-12 -'NO3 ' 50.00E-12 -'N2O5 ' 100.00E-12 -'HONO ' 10.00E-12 -'HNO3 ' 100.00E-12 -'HNO4 ' 100.00E-12 -'NH3 ' 50.00E-12 -'SO2 ' 50.00E-12 -'CO ' 100.00E-09 -'OH ' 1.00E-12 -'HO2 ' 10.00E-12 -'CH4 ' 1700.00E-09 -'ETH ' 845.00E-12 -'ALKA ' 100.00E-12 -'ALKE ' 10.00E-12 -'BIO ' 100.00E-12 -'HCHO ' 200.00E-12 -'KET ' 100.00E-12 -'PAN ' 400.00E-12 -'OP1 ' 1.00E-09 - - -=================================================================== -*** the following section will be read by ch_field_valuen.f90 *** -=================================================================== - -PROFASSO -norm-profiles to be associated -23 -(1X,A12,1X,I3) -'O3 ' 2 -'H2O2 ' 1 -'NO ' 2 -'NO2 ' 2 -'NO3 ' 1 -'N2O5 ' 1 -'HONO ' 1 -'HNO3 ' 1 -'HNO4 ' 1 -'NH3 ' 3 -'SO2 ' 3 -'CO ' 3 -'OH ' 1 -'HO2 ' 1 -'CH4 ' 1 -'ETH ' 3 -'ALKA ' 3 -'ALKE ' 3 -'BIO ' 3 -'HCHO ' 3 -'KET ' 3 -'PAN ' 3 -'OP1 ' 3 - -===================================================================== -*** the following section will be read by ch_init_dep_isban.F90 *** -===================================================================== - -SURF_RES -surface resistances (s/m), refer to Seinfeld and Pandis, 1998, p. 975, Tab.19.2 - 1 -(A32,2E15.5) -NONE 0.0 - -===================================================================== -*** the following section will be read by ch_init_depconst.F90 *** -===================================================================== - -MASS_MOL -molecular mass (in g/mol) for molecular diffusion, from Stockwell et al., 1997 - 41 -(A32,2E15.5) -O3 0.48000E+02 -H2O2 0.34000E+02 -NO 0.30000E+02 -NO2 0.46000E+02 -NO3 0.62000E+02 -N2O5 0.10800E+03 -HONO 0.47000E+02 -HNO3 0.63000E+02 -HNO4 0.79000E+02 -NH3 0.17000E+02 -SO2 0.64000E+02 -SULF 0.98000E+02 -CO 0.28000E+02 -OH 0.17000E+02 -HO2 0.33000E+02 -CH4 0.16000E+02 -ETH 0.30000E+02 -ALKA 0.50861E+02 -ALKE 0.29160E+02 -BIO 0.10200E+03 -ARO 0.10100E+03 -HCHO 0.30000E+02 -ALD 0.44000E+02 -KET 0.72000E+02 -CARBO 0.66900E+02 -ONIT 0.11900E+03 -PAN 0.12100E+03 -OP1 0.48000E+02 -OP2 0.63100E+02 -ORA1 0.46000E+02 -ORA2 0.60000E+02 -MO2 0.47000E+02 -ALKAP 0.81380E+02 -ALKEP 0.83611E+02 -BIOP 0.11700E+03 -PHO 0.10700E+03 -ADD 0.11680E+03 -AROP 0.14867E+03 -CARBOP 0.85434E+02 -OLN 0.13600E+03 -XO2 0.10000E+03 - -===================================================================== -*** the following section will be read by ch_init_depconst.F90 *** -===================================================================== - -REA_FACT -reactivity factor with biology, Seinfeld and Pandis, 1998, p. 975, Tab. 19.3 - 41 -(A32,2E15.5) -O3 0.10000E+01 -H2O2 0.10000E+01 -NO 0.00000E+00 -NO2 0.10000E+00 -NO3 0.10000E+00 -N2O5 0.10000E+00 -HONO 0.10000E+00 -HNO3 0.00000E+00 -HNO4 0.00000E+00 -NH3 0.00000E+00 -SO2 0.00000E+00 -SULF 0.00000E+00 -CO 0.00000E+00 -OH 0.00000E+00 -HO2 0.00000E+00 -CH4 0.00000E+00 -ETH 0.00000E+00 -ALKA 0.00000E+00 -ALKE 0.00000E+00 -BIO 0.00000E+00 -ARO 0.00000E+00 -HCHO 0.00000E+00 -ALD 0.00000E+00 -KET 0.00000E+00 -CARBO 0.00000E+00 -ONIT 0.00000E+00 -PAN 0.10000E+00 -OP1 0.30000E+00 -OP2 0.10000E+00 -ORA1 0.00000E+00 -ORA2 0.00000E+00 -MO2 0.00000E+00 -ALKAP 0.00000E+00 -ALKEP 0.00000E+00 -BIOP 0.00000E+00 -PHO 0.00000E+00 -ADD 0.00000E+00 -AROP 0.00000E+00 -CARBOP 0.00000E+00 -OLN 0.00000E+00 -XO2 0.00000E+00 - -===================================================================== -*** the following section will be read by ch_init_depconst.F90 *** -===================================================================== - -HENRY_SP -Effective Henrys law factor / exponent, See Leriche et al.2013 - 35 -(A32,2E15.5) -O3 1.03000E-02 -0.28300E+04 -H2O2 8.44000E+04 -0.76000E+04 -NO 1.92000E-03 -0.17900E+04 -NO2 1.20000E-02 -0.25160E+04 -NO3 3.80000E-02 -0.87070E+04 -N2O5 2.10000E+00 -0.34000E+04 -HONO 8.38000E+04 -0.31200E+04 -HNO3 1.46000E+13 -0.10500E+05 -HNO4 4.78000E+04 -0.69000E+04 -NH3 3.24000E+03 0.19000E+03 -SO2 5.59000E+04 -0.48950E+04 -SULF 6.64000E+14 -0.87000E+04 -CO 9.81000E-04 -0.17200E+04 -OH 3.90000E+01 -0.00000E+00 -HO2 3.49000E+04 -0.00000E+00 -CH4 1.41000E-03 -0.20400E+04 -ETH 1.88000E-03 -0.28750E+05 -ALKA 0.15000E-02 -0.32750E+04 -ALKE 0.59600E-02 -0.21700E+04 -BIO 0.38500E-01 -0.00000E+00 -ARO 0.18000E+00 -0.41000E+04 -HCHO 3.23000E+03 -0.71960E+04 -ALD 0.12900E+02 -0.58900E+04 -KET 0.27800E+02 -0.55300E+04 -CARBO 0.36000E+06 -0.75450E+04 -ONIT 0.10000E+02 -0.59100E+04 -PAN 0.28000E+01 -0.57300E+04 -OP1 0.30000E+01 -0.52800E+04 -OP2 0.33600E+01 -0.59950E+04 -ORA1 5.07000E+06 -0.59500E+04 -ORA2 2.66000E+05 -0.62000E+04 -MO2 0.24500E+01 -0.23200E+04 -ALKAP 0.26600E+03 -0.60000E+04 -ALKEP 0.83000E+03 -0.60000E+04 -BIOP 0.23110E+04 -0.60000E+04 +=================================================================== +*** the following section will be read by ch_field_valuen.f90 *** +=================================================================== + +FORMPROF + Z UNI(norm) STRATO(norm) BL(norm) + 11 3 +(F7.0,3E13.3) + 0. 1.000E-00 1.000E-00 1.000E-00 + 1000. 1.000E-00 1.000E-00 1.000E-00 + 2000. 1.000E-00 1.000E-00 0.100E-00 + 3000. 1.000E-00 0.500E-00 0.100E-00 + 4000. 1.000E-00 0.500E-00 0.100E-00 + 5000. 1.000E-00 0.500E-00 0.100E-00 + 6000. 1.000E-00 0.500E-00 0.100E-00 + 7000. 1.000E-00 0.500E-00 0.100E-00 + 8000. 1.000E-00 0.500E-00 0.100E-00 + 9000. 1.000E-00 0.800E-00 0.050E-00 + 10000. 1.000E-00 1.000E-00 0.050E-00 + +=================================================================== +*** the following section will be read by ch_field_valuen.f90 *** +=================================================================== + +NORMINIT +initial values (units are par per part = MIX) +MIX +23 +(1X,A12,1X,E25.8) +'O3 ' 40.00E-09 +'H2O2 ' 1.00E-09 +'NO ' 100.00E-12 +'NO2 ' 100.00E-12 +'NO3 ' 50.00E-12 +'N2O5 ' 100.00E-12 +'HONO ' 10.00E-12 +'HNO3 ' 100.00E-12 +'HNO4 ' 100.00E-12 +'NH3 ' 50.00E-12 +'SO2 ' 50.00E-12 +'CO ' 100.00E-09 +'OH ' 1.00E-12 +'HO2 ' 10.00E-12 +'CH4 ' 1700.00E-09 +'ETH ' 845.00E-12 +'ALKA ' 100.00E-12 +'ALKE ' 10.00E-12 +'BIO ' 100.00E-12 +'HCHO ' 200.00E-12 +'KET ' 100.00E-12 +'PAN ' 400.00E-12 +'OP1 ' 1.00E-09 + + +=================================================================== +*** the following section will be read by ch_field_valuen.f90 *** +=================================================================== + +PROFASSO +norm-profiles to be associated +23 +(1X,A12,1X,I3) +'O3 ' 2 +'H2O2 ' 1 +'NO ' 2 +'NO2 ' 2 +'NO3 ' 1 +'N2O5 ' 1 +'HONO ' 1 +'HNO3 ' 1 +'HNO4 ' 1 +'NH3 ' 3 +'SO2 ' 3 +'CO ' 3 +'OH ' 1 +'HO2 ' 1 +'CH4 ' 1 +'ETH ' 3 +'ALKA ' 3 +'ALKE ' 3 +'BIO ' 3 +'HCHO ' 3 +'KET ' 3 +'PAN ' 3 +'OP1 ' 3 + +===================================================================== +*** the following section will be read by ch_init_dep_isban.F90 *** +===================================================================== + +SURF_RES +surface resistances (s/m), refer to Seinfeld and Pandis, 1998, p. 975, Tab.19.2 + 1 +(A32,2E15.5) +NONE 0.0 + +===================================================================== +*** the following section will be read by ch_init_depconst.F90 *** +===================================================================== + +MASS_MOL +molecular mass (in g/mol) for molecular diffusion, from Stockwell et al., 1997 + 41 +(A32,2E15.5) +O3 0.48000E+02 +H2O2 0.34000E+02 +NO 0.30000E+02 +NO2 0.46000E+02 +NO3 0.62000E+02 +N2O5 0.10800E+03 +HONO 0.47000E+02 +HNO3 0.63000E+02 +HNO4 0.79000E+02 +NH3 0.17000E+02 +SO2 0.64000E+02 +SULF 0.98000E+02 +CO 0.28000E+02 +OH 0.17000E+02 +HO2 0.33000E+02 +CH4 0.16000E+02 +ETH 0.30000E+02 +ALKA 0.50861E+02 +ALKE 0.29160E+02 +BIO 0.10200E+03 +ARO 0.10100E+03 +HCHO 0.30000E+02 +ALD 0.44000E+02 +KET 0.72000E+02 +CARBO 0.66900E+02 +ONIT 0.11900E+03 +PAN 0.12100E+03 +OP1 0.48000E+02 +OP2 0.63100E+02 +ORA1 0.46000E+02 +ORA2 0.60000E+02 +MO2 0.47000E+02 +ALKAP 0.81380E+02 +ALKEP 0.83611E+02 +BIOP 0.11700E+03 +PHO 0.10700E+03 +ADD 0.11680E+03 +AROP 0.14867E+03 +CARBOP 0.85434E+02 +OLN 0.13600E+03 +XO2 0.10000E+03 + +===================================================================== +*** the following section will be read by ch_init_depconst.F90 *** +===================================================================== + +REA_FACT +reactivity factor with biology, Seinfeld and Pandis, 1998, p. 975, Tab. 19.3 + 41 +(A32,2E15.5) +O3 0.10000E+01 +H2O2 0.10000E+01 +NO 0.00000E+00 +NO2 0.10000E+00 +NO3 0.10000E+00 +N2O5 0.10000E+00 +HONO 0.10000E+00 +HNO3 0.00000E+00 +HNO4 0.00000E+00 +NH3 0.00000E+00 +SO2 0.00000E+00 +SULF 0.00000E+00 +CO 0.00000E+00 +OH 0.00000E+00 +HO2 0.00000E+00 +CH4 0.00000E+00 +ETH 0.00000E+00 +ALKA 0.00000E+00 +ALKE 0.00000E+00 +BIO 0.00000E+00 +ARO 0.00000E+00 +HCHO 0.00000E+00 +ALD 0.00000E+00 +KET 0.00000E+00 +CARBO 0.00000E+00 +ONIT 0.00000E+00 +PAN 0.10000E+00 +OP1 0.30000E+00 +OP2 0.10000E+00 +ORA1 0.00000E+00 +ORA2 0.00000E+00 +MO2 0.00000E+00 +ALKAP 0.00000E+00 +ALKEP 0.00000E+00 +BIOP 0.00000E+00 +PHO 0.00000E+00 +ADD 0.00000E+00 +AROP 0.00000E+00 +CARBOP 0.00000E+00 +OLN 0.00000E+00 +XO2 0.00000E+00 + +===================================================================== +*** the following section will be read by ch_init_depconst.F90 *** +===================================================================== + +HENRY_SP +Effective Henrys law factor / exponent, See Leriche et al.2013 + 35 +(A32,2E15.5) +O3 1.03000E-02 -0.28300E+04 +H2O2 8.44000E+04 -0.76000E+04 +NO 1.92000E-03 -0.17900E+04 +NO2 1.20000E-02 -0.25160E+04 +NO3 3.80000E-02 -0.87070E+04 +N2O5 2.10000E+00 -0.34000E+04 +HONO 8.38000E+04 -0.31200E+04 +HNO3 1.46000E+13 -0.10500E+05 +HNO4 4.78000E+04 -0.69000E+04 +NH3 3.24000E+03 0.19000E+03 +SO2 5.59000E+04 -0.48950E+04 +SULF 6.64000E+14 -0.87000E+04 +CO 9.81000E-04 -0.17200E+04 +OH 3.90000E+01 -0.00000E+00 +HO2 3.49000E+04 -0.00000E+00 +CH4 1.41000E-03 -0.20400E+04 +ETH 1.88000E-03 -0.28750E+05 +ALKA 0.15000E-02 -0.32750E+04 +ALKE 0.59600E-02 -0.21700E+04 +BIO 0.38500E-01 -0.00000E+00 +ARO 0.18000E+00 -0.41000E+04 +HCHO 3.23000E+03 -0.71960E+04 +ALD 0.12900E+02 -0.58900E+04 +KET 0.27800E+02 -0.55300E+04 +CARBO 0.36000E+06 -0.75450E+04 +ONIT 0.10000E+02 -0.59100E+04 +PAN 0.28000E+01 -0.57300E+04 +OP1 0.30000E+01 -0.52800E+04 +OP2 0.33600E+01 -0.59950E+04 +ORA1 5.07000E+06 -0.59500E+04 +ORA2 2.66000E+05 -0.62000E+04 +MO2 0.24500E+01 -0.23200E+04 +ALKAP 0.26600E+03 -0.60000E+04 +ALKEP 0.83000E+03 -0.60000E+04 +BIOP 0.23110E+04 -0.60000E+04 diff --git a/src/ARCH_SRC/CPL_WAVE/MNH/mnh_oasis_define.F90 b/src/ARCH_SRC/CPL_WAVE/MNH/mnh_oasis_define.F90 old mode 100755 new mode 100644 diff --git a/src/ARCH_SRC/CPL_WAVE/MNH/mnh_oasis_grid.F90 b/src/ARCH_SRC/CPL_WAVE/MNH/mnh_oasis_grid.F90 old mode 100755 new mode 100644 diff --git a/src/ARCH_SRC/CPL_WAVE/MNH/mnh_oasis_recv.F90 b/src/ARCH_SRC/CPL_WAVE/MNH/mnh_oasis_recv.F90 old mode 100755 new mode 100644 diff --git a/src/ARCH_SRC/CPL_WAVE/MNH/mnh_oasis_send.F90 b/src/ARCH_SRC/CPL_WAVE/MNH/mnh_oasis_send.F90 old mode 100755 new mode 100644 diff --git a/src/ARCH_SRC/CPL_WAVE/SURFEX/get_sfx_sea.F90 b/src/ARCH_SRC/CPL_WAVE/SURFEX/get_sfx_sea.F90 old mode 100755 new mode 100644 diff --git a/src/ARCH_SRC/CPL_WAVE/SURFEX/get_sfx_wave.F90 b/src/ARCH_SRC/CPL_WAVE/SURFEX/get_sfx_wave.F90 old mode 100755 new mode 100644 diff --git a/src/ARCH_SRC/CPL_WAVE/SURFEX/modd_sfx_oasis.F90 b/src/ARCH_SRC/CPL_WAVE/SURFEX/modd_sfx_oasis.F90 old mode 100755 new mode 100644 diff --git a/src/ARCH_SRC/CPL_WAVE/SURFEX/modn_sfx_oasis.F90 b/src/ARCH_SRC/CPL_WAVE/SURFEX/modn_sfx_oasis.F90 old mode 100755 new mode 100644 diff --git a/src/ARCH_SRC/CPL_WAVE/SURFEX/put_sfx_wave.F90 b/src/ARCH_SRC/CPL_WAVE/SURFEX/put_sfx_wave.F90 old mode 100755 new mode 100644 diff --git a/src/ARCH_SRC/CPL_WAVE/SURFEX/sfx_oasis_define.F90 b/src/ARCH_SRC/CPL_WAVE/SURFEX/sfx_oasis_define.F90 old mode 100755 new mode 100644 diff --git a/src/ARCH_SRC/CPL_WAVE/SURFEX/sfx_oasis_init.F90 b/src/ARCH_SRC/CPL_WAVE/SURFEX/sfx_oasis_init.F90 old mode 100755 new mode 100644 diff --git a/src/ARCH_SRC/CPL_WAVE/SURFEX/sfx_oasis_read_nam.F90 b/src/ARCH_SRC/CPL_WAVE/SURFEX/sfx_oasis_read_nam.F90 old mode 100755 new mode 100644 diff --git a/src/ARCH_SRC/CPL_WAVE/SURFEX/sfx_oasis_recv.F90 b/src/ARCH_SRC/CPL_WAVE/SURFEX/sfx_oasis_recv.F90 old mode 100755 new mode 100644 diff --git a/src/ARCH_SRC/CPL_WAVE/SURFEX/sfx_oasis_send.F90 b/src/ARCH_SRC/CPL_WAVE/SURFEX/sfx_oasis_send.F90 old mode 100755 new mode 100644 diff --git a/src/LIB/FOREFIRE/C_ForeFire_Interface.c b/src/LIB/FOREFIRE/C_ForeFire_Interface.c index 97ca72b6e363593be900074d22e92ef230305c4e..a2fad3353d9148479a19d72a7be8421c0836c65a 100644 --- a/src/LIB/FOREFIRE/C_ForeFire_Interface.c +++ b/src/LIB/FOREFIRE/C_ForeFire_Interface.c @@ -1,429 +1,429 @@ -/* -*MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier -*MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence -*MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt -*MNH_LIC for details. version 1. -*/ -/* -! ###################################################################### -! -!!**** *C_ForeFire_Interface* - C bindings for LibForeFire -!!**** -!! -!! PURPOSE -!! ------- -!! Purpose is to provide entry points to the ForeFire library in order -!! to perform wildfire simulations -! -! -!!** METHOD -!! ------ -!! All function calls are made from dynamic library, the shared lib is loaded at init -!! It matches F_ForeFire_Interface.f90 -!! -!! EXTERNAL -!! -------- -!! NA -!! IMPLICIT ARGUMENTS -!! ------------------ -!! NA -!! -!! REFERENCE -!! --------- -!! -!! -!! AUTHOR -!! ------ -!! J. P. Lafore *Meteo-France* -!! -!! MODIFICATIONS -!! ------------- -!! Original (SPE- Corte, Filippi) 04/2010 -!! -!------------------------------------------------------------------------------ -! -*/ -#include <stdio.h> -#include <stdlib.h> -#include <string.h> -#include <dlfcn.h> -#include <assert.h> - -#define MAXCHARFORFUNC 200 - -void *my_lib_handle = NULL; -char passingchar[MAXCHARFORFUNC]; - -const char* castchar(const char* cname){ - int len = strlen(cname); - unsigned i = 0; - assert(len<MAXCHARFORFUNC); - for (i=0;i < len;i++){ - passingchar[i]=cname[i]; - } - passingchar[len]='\0'; - return passingchar; -} - -void loadLib(){ - char libff[100]; - sprintf(libff,"%s/exe/libForeFire.so",getenv("SRC_MESONH")); - my_lib_handle = dlopen(libff, RTLD_LAZY); -} - -void MNHInit(double* t) { - - if ( my_lib_handle == NULL ) loadLib(); - - void (*void_func)(double); - - if (my_lib_handle!=NULL) { - *(void **) (&void_func) = dlsym(my_lib_handle,"MNHInit"); - if (void_func!=NULL) { - void_func(*t); - } else { - printf("function 'MNHInit' not found !!\n"); - printf(dlerror()); - } - } else { - printf("libForeFire not found !!\n"); - printf(dlerror()); - } - -} - -void MNHCreateDomain(int* id - , int* year, int* month, int* day, double* t - , double* lat, double* lon - , int* mdimx, double* meshx - , int* mdimy, double* meshy - , int* mdimz, int* sizein, double* zgrid - , double* dt) { - - if ( my_lib_handle == NULL ) loadLib(); - - void (*void_func)(int, int, int, int, double, double, double - , int, double*, int, double*, int, double*, double); - - if (my_lib_handle!=NULL) { - *(void **) (&void_func) = dlsym(my_lib_handle,"MNHCreateDomain"); - if (void_func!=NULL) { - void_func(*id, *year, *month, *day, *t, *lat, *lon - , *mdimx, meshx, *mdimy, meshy, *mdimz, zgrid, *dt); - } else { - printf("function 'MNHInit' not found !!\n"); - printf(dlerror()); - } - } else { - printf("libForeFire not found !!\n"); - printf(dlerror()); - } - -} - -void CheckLayer(const char* layerName) { - - if ( my_lib_handle == NULL ) loadLib(); - - void (*void_func)(const char*); - - if (my_lib_handle!=NULL) { - *(void **) (&void_func) = dlsym(my_lib_handle,"CheckLayer"); - if (void_func!=NULL) { - void_func(layerName); - } else { - printf("function 'checkLayer' not found !!\n"); - printf(dlerror()); - } - } else { - printf("libForeFire not found !!\n"); - printf(dlerror()); - } - -} - -void MNHStep(double* dt) { - - if ( my_lib_handle == NULL ) loadLib(); - - void (*void_func)(double); - - if (my_lib_handle!=NULL) { - *(void **) (&void_func) = dlsym(my_lib_handle,"MNHStep"); - if (void_func!=NULL) { - void_func(*dt); - } else { - printf("function 'MNHStep' not found !!\n"); - printf(dlerror()); - } - } else { - printf("libForeFire not found !!\n"); - printf(dlerror()); - } - -} - -void MNHGoTo(double* time) { - - if ( my_lib_handle == NULL ) loadLib(); - - void (*void_func)(double); - - if (my_lib_handle!=NULL) { - *(void **) (&void_func) = dlsym(my_lib_handle,"MNHGoTo"); - if (void_func!=NULL) { - void_func(*time); - } else { - printf("function 'MNHGoTo' not found !!\n"); - printf(dlerror()); - } - } else { - printf("libForeFire not found !!\n"); - printf(dlerror()); - } - -} - -void Execute(const char* command) { - - if ( my_lib_handle == NULL ) loadLib(); - - void (*void_func)(const char*); - - if (my_lib_handle!=NULL) { - *(void **) (&void_func) = dlsym(my_lib_handle,"executeMNHCommand"); - if (void_func!=NULL) { - void_func(command); - } else { - printf("function 'executeMNHCommand' not found !!\n"); - printf(dlerror()); - } - } else { - printf("libForeFire not found !!\n"); - printf(dlerror()); - } - -} - -void FFPutString(const char* name, char* n){ - - if ( my_lib_handle == NULL ) loadLib(); - - void (*void_func)(const char*, char*); - - if (my_lib_handle!=NULL) { - *(void **) (&void_func) = dlsym(my_lib_handle,"FFPutString"); - if (void_func!=NULL) { - void_func(name, n); - } else { - printf("function 'FFPutString' not found !!\n"); - printf(dlerror()); - } - } else { - printf("libForeFire not found !!\n"); - printf(dlerror()); - } -} - -void FFGetString(const char* name, const char* n){ - - if ( my_lib_handle == NULL ) loadLib(); - - void (*void_func)(const char*, const char*); - - if (my_lib_handle!=NULL) { - *(void **) (&void_func) = dlsym(my_lib_handle,"FFGetString"); - if (void_func!=NULL) { - void_func(name, n); - } else { - printf("function 'FFGetString' not found !!\n"); - printf(dlerror()); - } - } else { - printf("libForeFire not found !!\n"); - printf(dlerror()); - } -} - -void FFPutInt(const char* name, int* n){ - - if ( my_lib_handle == NULL ) loadLib(); - - void (*void_func)(const char*, int*); - - if (my_lib_handle!=NULL) { - *(void **) (&void_func) = dlsym(my_lib_handle,"FFPutInt"); - if (void_func!=NULL) { - void_func(name, n); - } else { - printf("function 'FFPutInt' not found !!\n"); - printf(dlerror()); - } - } else { - printf("libForeFire not found !!\n"); - printf(dlerror()); - } -} - -void FFGetInt(const char* name, int* n){ - - if ( my_lib_handle == NULL ) loadLib(); - - void (*void_func)(const char*, int*); - - if (my_lib_handle!=NULL) { - *(void **) (&void_func) = dlsym(my_lib_handle,"FFGetInt"); - if (void_func!=NULL) { - void_func(name, n); - } else { - printf("function 'FFGetInt' not found !!\n"); - printf(dlerror()); - } - } else { - printf("libForeFire not found !!\n"); - printf(dlerror()); - } -} - -void FFGetIntArray(const char* name, int* x, - int *sizein, int *sizeout){ - - if ( my_lib_handle == NULL ) loadLib(); - - void (*void_func)(const char*, int*, int, int); - - if (my_lib_handle!=NULL) { - *(void **) (&void_func) = dlsym(my_lib_handle,"FFGetIntArray"); - if (void_func!=NULL) { - void_func(name, x, *sizein, *sizeout); - } else { - printf("function 'FFGetIntArray' not found !!\n"); - printf(dlerror()); - } - } else { - printf("libForeFire not found !!\n"); - printf(dlerror()); - } -} - -void FFPutIntArray(const char* name, double *curtime - , int* x, int *sizein, int *sizeout){ - - if ( my_lib_handle == NULL ) loadLib(); - - void (*void_func)(const char*, double, int*, int, int); - - if (my_lib_handle!=NULL) { - *(void **) (&void_func) = dlsym(my_lib_handle,"FFPutIntArray"); - if (void_func!=NULL) { - void_func(name, *curtime, x, *sizein, *sizeout); - } else { - printf("function 'FFPutIntArray' not found !!\n"); - printf(dlerror()); - } - } else { - printf("libForeFire not found !!\n"); - printf(dlerror()); - } -} - -void FFPutDouble(const char* name, double* x){ - - if ( my_lib_handle == NULL ) loadLib(); - - void (*void_func)(const char*, double*); - - if (my_lib_handle!=NULL) { - *(void **) (&void_func) = dlsym(my_lib_handle,"FFPutDouble"); - if (void_func!=NULL) { - void_func(name, x); - } else { - printf("function 'FFPutDouble' not found !!\n"); - printf(dlerror()); - } - } else { - printf("libForeFire not found !!\n"); - printf(dlerror()); - } -} - -void FFGetDouble(const char* name, double* x){ - - if ( my_lib_handle == NULL ) loadLib(); - - void (*void_func)(const char*, double*); - - if (my_lib_handle!=NULL) { - *(void **) (&void_func) = dlsym(my_lib_handle,"FFGetDouble"); - if (void_func!=NULL) { - void_func(name, x); - } else { - printf("function 'FFGetDouble' not found !!\n"); - printf(dlerror()); - } - } else { - printf("libForeFire not found !!\n"); - printf(dlerror()); - } -} - -void FFGetDoubleArray(const char* name, double *curtime - , double* x, int *sizein, int *sizeout){ - - if ( my_lib_handle == NULL ) loadLib(); - - void (*void_func)(const char*, double, double*, int, int); - - if (my_lib_handle!=NULL) { - *(void **) (&void_func) = dlsym(my_lib_handle,"FFGetDoubleArray"); - if (void_func!=NULL) { - void_func(name, *curtime, x, *sizein, *sizeout); - } else { - printf("function 'FFGetDoubleArray' not found !!\n"); - printf(dlerror()); - } - } else { - printf("libForeFire not found !!\n"); - printf(dlerror()); - } -} -void FFDumpDoubleArray(int *nmodel, int *nip, const char* name, double *curtime - , double* x, int *sizein, int *ni, int *nj, int *nk, int *sizeout){ - - if ( my_lib_handle == NULL ) loadLib(); - - void (*void_func)(int, int, const char*, double, double*, int, int, int, int, int); - - if (my_lib_handle!=NULL) { - *(void **) (&void_func) = dlsym(my_lib_handle,"FFDumpDoubleArray"); - if (void_func!=NULL) { - void_func(*nmodel, *nip, name, *curtime, x, *sizein, *ni, *nj, *nk, *sizeout); - } else { - printf("function 'FFDumpDoubleArray' not found !!\n"); - printf(dlerror()); - } - } else { - printf("libForeFire not found !!\n"); - printf(dlerror()); - } -} -void FFPutDoubleArray(const char* name, double* x, - int *sizein, int *sizeout){ - - if ( my_lib_handle == NULL ) loadLib(); - - void (*void_func)(const char*, double*, int, int); - - if (my_lib_handle!=NULL) { - *(void **) (&void_func) = dlsym(my_lib_handle,"FFPutDoubleArray"); - if (void_func!=NULL) { - void_func(name, x, *sizein, *sizeout); - } else { - printf("function 'FFPutDoubleArray' not found !!\n"); - printf(dlerror()); - } - } else { - printf("libForeFire not found !!\n"); - printf(dlerror()); - } -} +/* +*MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier +*MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence +*MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt +*MNH_LIC for details. version 1. +*/ +/* +! ###################################################################### +! +!!**** *C_ForeFire_Interface* - C bindings for LibForeFire +!!**** +!! +!! PURPOSE +!! ------- +!! Purpose is to provide entry points to the ForeFire library in order +!! to perform wildfire simulations +! +! +!!** METHOD +!! ------ +!! All function calls are made from dynamic library, the shared lib is loaded at init +!! It matches F_ForeFire_Interface.f90 +!! +!! EXTERNAL +!! -------- +!! NA +!! IMPLICIT ARGUMENTS +!! ------------------ +!! NA +!! +!! REFERENCE +!! --------- +!! +!! +!! AUTHOR +!! ------ +!! J. P. Lafore *Meteo-France* +!! +!! MODIFICATIONS +!! ------------- +!! Original (SPE- Corte, Filippi) 04/2010 +!! +!------------------------------------------------------------------------------ +! +*/ +#include <stdio.h> +#include <stdlib.h> +#include <string.h> +#include <dlfcn.h> +#include <assert.h> + +#define MAXCHARFORFUNC 200 + +void *my_lib_handle = NULL; +char passingchar[MAXCHARFORFUNC]; + +const char* castchar(const char* cname){ + int len = strlen(cname); + unsigned i = 0; + assert(len<MAXCHARFORFUNC); + for (i=0;i < len;i++){ + passingchar[i]=cname[i]; + } + passingchar[len]='\0'; + return passingchar; +} + +void loadLib(){ + char libff[100]; + sprintf(libff,"%s/exe/libForeFire.so",getenv("SRC_MESONH")); + my_lib_handle = dlopen(libff, RTLD_LAZY); +} + +void MNHInit(double* t) { + + if ( my_lib_handle == NULL ) loadLib(); + + void (*void_func)(double); + + if (my_lib_handle!=NULL) { + *(void **) (&void_func) = dlsym(my_lib_handle,"MNHInit"); + if (void_func!=NULL) { + void_func(*t); + } else { + printf("function 'MNHInit' not found !!\n"); + printf(dlerror()); + } + } else { + printf("libForeFire not found !!\n"); + printf(dlerror()); + } + +} + +void MNHCreateDomain(int* id + , int* year, int* month, int* day, double* t + , double* lat, double* lon + , int* mdimx, double* meshx + , int* mdimy, double* meshy + , int* mdimz, int* sizein, double* zgrid + , double* dt) { + + if ( my_lib_handle == NULL ) loadLib(); + + void (*void_func)(int, int, int, int, double, double, double + , int, double*, int, double*, int, double*, double); + + if (my_lib_handle!=NULL) { + *(void **) (&void_func) = dlsym(my_lib_handle,"MNHCreateDomain"); + if (void_func!=NULL) { + void_func(*id, *year, *month, *day, *t, *lat, *lon + , *mdimx, meshx, *mdimy, meshy, *mdimz, zgrid, *dt); + } else { + printf("function 'MNHInit' not found !!\n"); + printf(dlerror()); + } + } else { + printf("libForeFire not found !!\n"); + printf(dlerror()); + } + +} + +void CheckLayer(const char* layerName) { + + if ( my_lib_handle == NULL ) loadLib(); + + void (*void_func)(const char*); + + if (my_lib_handle!=NULL) { + *(void **) (&void_func) = dlsym(my_lib_handle,"CheckLayer"); + if (void_func!=NULL) { + void_func(layerName); + } else { + printf("function 'checkLayer' not found !!\n"); + printf(dlerror()); + } + } else { + printf("libForeFire not found !!\n"); + printf(dlerror()); + } + +} + +void MNHStep(double* dt) { + + if ( my_lib_handle == NULL ) loadLib(); + + void (*void_func)(double); + + if (my_lib_handle!=NULL) { + *(void **) (&void_func) = dlsym(my_lib_handle,"MNHStep"); + if (void_func!=NULL) { + void_func(*dt); + } else { + printf("function 'MNHStep' not found !!\n"); + printf(dlerror()); + } + } else { + printf("libForeFire not found !!\n"); + printf(dlerror()); + } + +} + +void MNHGoTo(double* time) { + + if ( my_lib_handle == NULL ) loadLib(); + + void (*void_func)(double); + + if (my_lib_handle!=NULL) { + *(void **) (&void_func) = dlsym(my_lib_handle,"MNHGoTo"); + if (void_func!=NULL) { + void_func(*time); + } else { + printf("function 'MNHGoTo' not found !!\n"); + printf(dlerror()); + } + } else { + printf("libForeFire not found !!\n"); + printf(dlerror()); + } + +} + +void Execute(const char* command) { + + if ( my_lib_handle == NULL ) loadLib(); + + void (*void_func)(const char*); + + if (my_lib_handle!=NULL) { + *(void **) (&void_func) = dlsym(my_lib_handle,"executeMNHCommand"); + if (void_func!=NULL) { + void_func(command); + } else { + printf("function 'executeMNHCommand' not found !!\n"); + printf(dlerror()); + } + } else { + printf("libForeFire not found !!\n"); + printf(dlerror()); + } + +} + +void FFPutString(const char* name, char* n){ + + if ( my_lib_handle == NULL ) loadLib(); + + void (*void_func)(const char*, char*); + + if (my_lib_handle!=NULL) { + *(void **) (&void_func) = dlsym(my_lib_handle,"FFPutString"); + if (void_func!=NULL) { + void_func(name, n); + } else { + printf("function 'FFPutString' not found !!\n"); + printf(dlerror()); + } + } else { + printf("libForeFire not found !!\n"); + printf(dlerror()); + } +} + +void FFGetString(const char* name, const char* n){ + + if ( my_lib_handle == NULL ) loadLib(); + + void (*void_func)(const char*, const char*); + + if (my_lib_handle!=NULL) { + *(void **) (&void_func) = dlsym(my_lib_handle,"FFGetString"); + if (void_func!=NULL) { + void_func(name, n); + } else { + printf("function 'FFGetString' not found !!\n"); + printf(dlerror()); + } + } else { + printf("libForeFire not found !!\n"); + printf(dlerror()); + } +} + +void FFPutInt(const char* name, int* n){ + + if ( my_lib_handle == NULL ) loadLib(); + + void (*void_func)(const char*, int*); + + if (my_lib_handle!=NULL) { + *(void **) (&void_func) = dlsym(my_lib_handle,"FFPutInt"); + if (void_func!=NULL) { + void_func(name, n); + } else { + printf("function 'FFPutInt' not found !!\n"); + printf(dlerror()); + } + } else { + printf("libForeFire not found !!\n"); + printf(dlerror()); + } +} + +void FFGetInt(const char* name, int* n){ + + if ( my_lib_handle == NULL ) loadLib(); + + void (*void_func)(const char*, int*); + + if (my_lib_handle!=NULL) { + *(void **) (&void_func) = dlsym(my_lib_handle,"FFGetInt"); + if (void_func!=NULL) { + void_func(name, n); + } else { + printf("function 'FFGetInt' not found !!\n"); + printf(dlerror()); + } + } else { + printf("libForeFire not found !!\n"); + printf(dlerror()); + } +} + +void FFGetIntArray(const char* name, int* x, + int *sizein, int *sizeout){ + + if ( my_lib_handle == NULL ) loadLib(); + + void (*void_func)(const char*, int*, int, int); + + if (my_lib_handle!=NULL) { + *(void **) (&void_func) = dlsym(my_lib_handle,"FFGetIntArray"); + if (void_func!=NULL) { + void_func(name, x, *sizein, *sizeout); + } else { + printf("function 'FFGetIntArray' not found !!\n"); + printf(dlerror()); + } + } else { + printf("libForeFire not found !!\n"); + printf(dlerror()); + } +} + +void FFPutIntArray(const char* name, double *curtime + , int* x, int *sizein, int *sizeout){ + + if ( my_lib_handle == NULL ) loadLib(); + + void (*void_func)(const char*, double, int*, int, int); + + if (my_lib_handle!=NULL) { + *(void **) (&void_func) = dlsym(my_lib_handle,"FFPutIntArray"); + if (void_func!=NULL) { + void_func(name, *curtime, x, *sizein, *sizeout); + } else { + printf("function 'FFPutIntArray' not found !!\n"); + printf(dlerror()); + } + } else { + printf("libForeFire not found !!\n"); + printf(dlerror()); + } +} + +void FFPutDouble(const char* name, double* x){ + + if ( my_lib_handle == NULL ) loadLib(); + + void (*void_func)(const char*, double*); + + if (my_lib_handle!=NULL) { + *(void **) (&void_func) = dlsym(my_lib_handle,"FFPutDouble"); + if (void_func!=NULL) { + void_func(name, x); + } else { + printf("function 'FFPutDouble' not found !!\n"); + printf(dlerror()); + } + } else { + printf("libForeFire not found !!\n"); + printf(dlerror()); + } +} + +void FFGetDouble(const char* name, double* x){ + + if ( my_lib_handle == NULL ) loadLib(); + + void (*void_func)(const char*, double*); + + if (my_lib_handle!=NULL) { + *(void **) (&void_func) = dlsym(my_lib_handle,"FFGetDouble"); + if (void_func!=NULL) { + void_func(name, x); + } else { + printf("function 'FFGetDouble' not found !!\n"); + printf(dlerror()); + } + } else { + printf("libForeFire not found !!\n"); + printf(dlerror()); + } +} + +void FFGetDoubleArray(const char* name, double *curtime + , double* x, int *sizein, int *sizeout){ + + if ( my_lib_handle == NULL ) loadLib(); + + void (*void_func)(const char*, double, double*, int, int); + + if (my_lib_handle!=NULL) { + *(void **) (&void_func) = dlsym(my_lib_handle,"FFGetDoubleArray"); + if (void_func!=NULL) { + void_func(name, *curtime, x, *sizein, *sizeout); + } else { + printf("function 'FFGetDoubleArray' not found !!\n"); + printf(dlerror()); + } + } else { + printf("libForeFire not found !!\n"); + printf(dlerror()); + } +} +void FFDumpDoubleArray(int *nmodel, int *nip, const char* name, double *curtime + , double* x, int *sizein, int *ni, int *nj, int *nk, int *sizeout){ + + if ( my_lib_handle == NULL ) loadLib(); + + void (*void_func)(int, int, const char*, double, double*, int, int, int, int, int); + + if (my_lib_handle!=NULL) { + *(void **) (&void_func) = dlsym(my_lib_handle,"FFDumpDoubleArray"); + if (void_func!=NULL) { + void_func(*nmodel, *nip, name, *curtime, x, *sizein, *ni, *nj, *nk, *sizeout); + } else { + printf("function 'FFDumpDoubleArray' not found !!\n"); + printf(dlerror()); + } + } else { + printf("libForeFire not found !!\n"); + printf(dlerror()); + } +} +void FFPutDoubleArray(const char* name, double* x, + int *sizein, int *sizeout){ + + if ( my_lib_handle == NULL ) loadLib(); + + void (*void_func)(const char*, double*, int, int); + + if (my_lib_handle!=NULL) { + *(void **) (&void_func) = dlsym(my_lib_handle,"FFPutDoubleArray"); + if (void_func!=NULL) { + void_func(name, x, *sizein, *sizeout); + } else { + printf("function 'FFPutDoubleArray' not found !!\n"); + printf(dlerror()); + } + } else { + printf("libForeFire not found !!\n"); + printf(dlerror()); + } +} diff --git a/src/LIB/SURCOUCHE/src/fmread_ll.f90 b/src/LIB/SURCOUCHE/src/fmread_ll.f90 index d982d6d10e60d2dfc27ea00ac64fe06ffb92518f..e34349b57036e955f1ca274c05438fb084d32da4 100644 --- a/src/LIB/SURCOUCHE/src/fmread_ll.f90 +++ b/src/LIB/SURCOUCHE/src/fmread_ll.f90 @@ -1,2013 +1,2013 @@ -!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier -!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence -!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt -!MNH_LIC for details. version 1. -!----------------------------------------------------------------- -!--------------- special set of characters for CVS information -!----------------------------------------------------------------- -! $Source$ -! $Name$ -! $Revision$ -! $Date$ -!----------------------------------------------------------------- -!----------------------------------------------------------------- - -#ifdef MNH_MPI_DOUBLE_PRECISION -#define MPI_FLOAT MPI_DOUBLE_PRECISION -#else -#define MPI_FLOAT MPI_REAL -#endif - -MODULE MODE_FMREAD -! -!Correction : -! J.Escobar : 22/08/2005 : BUG : manque un "GOTO 1000" si champs -! lue non trouvé !!! -! J.Escobar : 13/01/2015 : remove comment on BCAST(IRESP in FMREADX2_ll -! J.Escobar : 15/09/2015 : WENO5 & JPHEXT <> 1 -! -USE MODD_IO_ll, ONLY : NVERB_FATAL,NVERB_ERROR,NVERB_WARNING,NVERB_INFO,NVERB_DEBUG,TFILEDATA -USE MODD_MPIF -! -USE MODE_FIELD -#if defined(MNH_IOCDF4) -USE MODE_NETCDF -#endif -USE MODE_MSG -USE MODE_READWRITE_LFI - -IMPLICIT NONE - -PRIVATE - -INTERFACE IO_READ_FIELD - MODULE PROCEDURE IO_READ_FIELD_BYNAME_X0, IO_READ_FIELD_BYNAME_X1, & - IO_READ_FIELD_BYNAME_X2, IO_READ_FIELD_BYNAME_X3, & - IO_READ_FIELD_BYNAME_X4, IO_READ_FIELD_BYNAME_X5, & - IO_READ_FIELD_BYNAME_X6, & - IO_READ_FIELD_BYNAME_N0, IO_READ_FIELD_BYNAME_N1, & - IO_READ_FIELD_BYNAME_N2, & - IO_READ_FIELD_BYNAME_L0, IO_READ_FIELD_BYNAME_L1, & - IO_READ_FIELD_BYNAME_C0, & - IO_READ_FIELD_BYNAME_T0, & - IO_READ_FIELD_BYFIELD_X0,IO_READ_FIELD_BYFIELD_X1, & - IO_READ_FIELD_BYFIELD_X2,IO_READ_FIELD_BYFIELD_X3, & - IO_READ_FIELD_BYFIELD_X4,IO_READ_FIELD_BYFIELD_X5, & - IO_READ_FIELD_BYFIELD_X6, & - IO_READ_FIELD_BYFIELD_N0,IO_READ_FIELD_BYFIELD_N1, & - IO_READ_FIELD_BYFIELD_N2, & - IO_READ_FIELD_BYFIELD_L0,IO_READ_FIELD_BYFIELD_L1, & - IO_READ_FIELD_BYFIELD_C0, & - IO_READ_FIELD_BYFIELD_T0 -END INTERFACE - -INTERFACE IO_READ_FIELD_LB - MODULE PROCEDURE IO_READ_FIELD_BYNAME_LB, IO_READ_FIELD_BYFIELD_LB -END INTERFACE - -PUBLIC IO_READ_FIELD,IO_READ_FIELD_LB - -CONTAINS - -SUBROUTINE IO_FILE_READ_CHECK(TPFILE,HSUBR,KRESP) -TYPE(TFILEDATA), INTENT(IN) :: TPFILE -CHARACTER(LEN=*), INTENT(IN) :: HSUBR -INTEGER, INTENT(OUT) :: KRESP -! -KRESP = 0 -! -!Check if file is opened -IF (.NOT.TPFILE%LOPENED) THEN - CALL PRINT_MSG(NVERB_ERROR,'IO',HSUBR,TRIM(TPFILE%CNAME)//' is not opened') - KRESP = -201 - RETURN -END IF -! -!Check if file is in the right opening mode -IF (TPFILE%CMODE/='READ') THEN - CALL PRINT_MSG(NVERB_WARNING,'IO',HSUBR,& - TRIM(TPFILE%CNAME)//': reading in a file opened in '//TRIM(TPFILE%CMODE)//' mode') -END IF -! -!Check fileformat -IF (TPFILE%CFORMAT/='NETCDF4' .AND. TPFILE%CFORMAT=='LFI' .AND. TPFILE%CFORMAT=='LFICDF4') THEN - CALL PRINT_MSG(NVERB_FATAL,'IO',HSUBR,& - TRIM(TPFILE%CNAME)//': invalid fileformat ('//TRIM(TPFILE%CFORMAT)//')') - KRESP = -202 - RETURN -END IF -! -END SUBROUTINE IO_FILE_READ_CHECK - - -SUBROUTINE IO_BCAST_FIELD_METADATA(TPFILE,TPFIELD) -TYPE(TFILEDATA), INTENT(IN) :: TPFILE -TYPE(TFIELDDATA), INTENT(INOUT) :: TPFIELD -! -INTEGER :: IERR -! -CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_BCAST_FIELD_METADATA','called for '//TRIM(TPFIELD%CMNHNAME)) -! -CALL MPI_BCAST(TPFIELD%CMNHNAME, LEN(TPFIELD%CMNHNAME), MPI_CHARACTER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) -CALL MPI_BCAST(TPFIELD%CSTDNAME, LEN(TPFIELD%CSTDNAME), MPI_CHARACTER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) -CALL MPI_BCAST(TPFIELD%CLONGNAME,LEN(TPFIELD%CLONGNAME),MPI_CHARACTER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) -CALL MPI_BCAST(TPFIELD%CUNITS, LEN(TPFIELD%CUNITS), MPI_CHARACTER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) -CALL MPI_BCAST(TPFIELD%CDIR, LEN(TPFIELD%CDIR), MPI_CHARACTER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) -CALL MPI_BCAST(TPFIELD%CLBTYPE, LEN(TPFIELD%CLBTYPE), MPI_CHARACTER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) -CALL MPI_BCAST(TPFIELD%CCOMMENT, LEN(TPFIELD%CCOMMENT), MPI_CHARACTER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) -CALL MPI_BCAST(TPFIELD%NGRID, 1, MPI_INTEGER, TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) -CALL MPI_BCAST(TPFIELD%NTYPE, 1, MPI_INTEGER, TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) -CALL MPI_BCAST(TPFIELD%NDIMS, 1, MPI_INTEGER, TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) -! -END SUBROUTINE IO_BCAST_FIELD_METADATA - - -SUBROUTINE IO_READ_FIELD_BYNAME_X0(TPFILE,HNAME,PFIELD,KRESP) -! -TYPE(TFILEDATA), INTENT(IN) :: TPFILE -CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write -REAL, INTENT(INOUT) :: PFIELD ! data field -INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code -! -INTEGER :: ID ! Index of the field -INTEGER :: IRESP ! return_code -! -CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYNAME_X0',TRIM(TPFILE%CNAME)//': reading '//TRIM(HNAME)) -! -CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) -! -IF(IRESP==0) CALL IO_READ_FIELD(TPFILE,TFIELDLIST(ID),PFIELD,IRESP) -! -IF (PRESENT(KRESP)) KRESP = IRESP -! -END SUBROUTINE IO_READ_FIELD_BYNAME_X0 - -SUBROUTINE IO_READ_FIELD_BYFIELD_X0(TPFILE,TPFIELD,PFIELD,KRESP) -! -USE MODD_IO_ll, ONLY : ISP,GSMONOPROC -! -TYPE(TFILEDATA), INTENT(IN) :: TPFILE -TYPE(TFIELDDATA), INTENT(INOUT) :: TPFIELD -REAL, INTENT(INOUT) :: PFIELD ! data field -INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code -! -INTEGER :: IERR -INTEGER :: IRESP -! -CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYFIELD_X0',TRIM(TPFILE%CNAME)//': reading '//TRIM(TPFIELD%CMNHNAME)) -! -IRESP = 0 -! -CALL IO_FILE_READ_CHECK(TPFILE,'IO_READ_FIELD_BYFIELD_X0',IRESP) -! -IF (IRESP==0) THEN - IF (GSMONOPROC) THEN ! sequential execution - IF (TPFILE%CFORMAT=='NETCDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,PFIELD,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFI') THEN - CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,PFIELD,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,PFIELD,IRESP) - END IF - ELSE - IF (ISP == TPFILE%NMASTER_RANK) THEN - IF (TPFILE%CFORMAT=='NETCDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,PFIELD,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFI') THEN - CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,PFIELD,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,PFIELD,IRESP) - END IF - END IF - ! - CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - ! - !Broadcast header only if IRESP==-111 - !because metadata of field has been modified in IO_READ_FIELD_xxx - IF (IRESP==-111) CALL IO_BCAST_FIELD_METADATA(TPFILE,TPFIELD) - ! - ! Broadcast Field - CALL MPI_BCAST(PFIELD,1,MPI_FLOAT,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - END IF -END IF -! -IF (IRESP==-111) IRESP = 0 !-111 is not really an error (metadata has changed) -! -IF (PRESENT(KRESP)) KRESP = IRESP -! -END SUBROUTINE IO_READ_FIELD_BYFIELD_X0 - - -SUBROUTINE IO_READ_FIELD_BYNAME_X1(TPFILE,HNAME,PFIELD,KRESP,KIMAX_ll,KJMAX_ll,TPSPLITTING) -! -USE MODD_IO_ll, ONLY : ISNPROC -USE MODD_STRUCTURE_ll, ONLY : ZONE_ll -! -TYPE(TFILEDATA), INTENT(IN) :: TPFILE -CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write -REAL,DIMENSION(:),INTENT(INOUT) :: PFIELD ! array containing the data field -INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code -INTEGER,OPTIONAL, INTENT(IN) :: KIMAX_ll -INTEGER,OPTIONAL, INTENT(IN) :: KJMAX_ll -TYPE(ZONE_ll),DIMENSION(ISNPROC),OPTIONAL,INTENT(IN) :: TPSPLITTING ! splitting of the domain -! -INTEGER :: ID ! Index of the field -INTEGER :: IRESP ! return_code -! -CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYNAME_X1',TRIM(TPFILE%CNAME)//': reading '//TRIM(HNAME)) -! -CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) -! -IF(IRESP==0) CALL IO_READ_FIELD(TPFILE,TFIELDLIST(ID),PFIELD,IRESP,KIMAX_ll,KJMAX_ll,TPSPLITTING) -! -IF (PRESENT(KRESP)) KRESP = IRESP -! -END SUBROUTINE IO_READ_FIELD_BYNAME_X1 - -SUBROUTINE IO_READ_FIELD_BYFIELD_X1(TPFILE,TPFIELD,PFIELD,KRESP,KIMAX_ll,KJMAX_ll,TPSPLITTING) -! -USE MODD_IO_ll, ONLY : ISP,GSMONOPROC,ISNPROC -USE MODD_STRUCTURE_ll, ONLY : ZONE_ll -! -USE MODE_SCATTER_ll -USE MODE_ALLOCBUFFER_ll -! -TYPE(TFILEDATA), INTENT(IN) :: TPFILE -TYPE(TFIELDDATA), INTENT(INOUT) :: TPFIELD -REAL,DIMENSION(:),INTENT(INOUT) :: PFIELD ! array containing the data field -INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code -INTEGER,OPTIONAL, INTENT(IN) :: KIMAX_ll -INTEGER,OPTIONAL, INTENT(IN) :: KJMAX_ll -TYPE(ZONE_ll),DIMENSION(ISNPROC),OPTIONAL,INTENT(IN) :: TPSPLITTING ! splitting of the domain -! -INTEGER :: IERR -REAL,DIMENSION(:),POINTER :: ZFIELDP -LOGICAL :: GALLOC -INTEGER :: IRESP -! -CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYFIELD_X1',TRIM(TPFILE%CNAME)//': reading '//TRIM(TPFIELD%CMNHNAME)) -! -GALLOC = .FALSE. -IRESP = 0 -ZFIELDP => NULL() -! -CALL IO_FILE_READ_CHECK(TPFILE,'IO_READ_FIELD_BYFIELD_X1',IRESP) -! -IF (IRESP==0) THEN - IF (GSMONOPROC) THEN ! sequential execution - IF (TPFILE%CFORMAT=='NETCDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,PFIELD,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFI') THEN - CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,PFIELD,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,PFIELD,IRESP) - END IF - ELSE - IF (ISP == TPFILE%NMASTER_RANK) THEN - CALL ALLOCBUFFER_ll(ZFIELDP,PFIELD,TPFIELD%CDIR,GALLOC, KIMAX_ll, KJMAX_ll) - IF (TPFILE%CFORMAT=='NETCDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFI') THEN - CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) - END IF - ELSE - !Not really necessary but useful to suppress alerts with Valgrind - ALLOCATE(ZFIELDP(0)) - GALLOC = .TRUE. - END IF - ! - CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - ! - !Broadcast header only if IRESP==-111 - !because metadata of field has been modified in IO_READ_FIELD_xxx - IF (IRESP==-111) CALL IO_BCAST_FIELD_METADATA(TPFILE,TPFIELD) - ! - IF (TPFIELD%CDIR /= 'XX' .AND. TPFIELD%CDIR /='YY') THEN - ! Broadcast Field - CALL MPI_BCAST(PFIELD,SIZE(PFIELD),MPI_FLOAT,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - ELSE - !Scatter Field - CALL SCATTER_XXFIELD(TPFIELD%CDIR,ZFIELDP,PFIELD,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM,TPSPLITTING) - END IF - END IF -END IF -! -IF (GALLOC) DEALLOCATE (ZFIELDP) -! -IF (IRESP==-111) IRESP = 0 !-111 is not really an error (metadata has changed) -! -IF (PRESENT(KRESP)) KRESP = IRESP -! -END SUBROUTINE IO_READ_FIELD_BYFIELD_X1 - - -SUBROUTINE IO_READ_FIELD_BYNAME_X2(TPFILE,HNAME,PFIELD,KRESP,KIMAX_ll,KJMAX_ll,TPSPLITTING) -! -USE MODD_IO_ll, ONLY : ISNPROC -USE MODD_STRUCTURE_ll, ONLY : ZONE_ll -! -! -TYPE(TFILEDATA), INTENT(IN) :: TPFILE -CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write -REAL,DIMENSION(:,:),INTENT(INOUT) :: PFIELD ! array containing the data field -INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code -INTEGER,OPTIONAL, INTENT(IN) :: KIMAX_ll -INTEGER,OPTIONAL, INTENT(IN) :: KJMAX_ll -TYPE(ZONE_ll),DIMENSION(ISNPROC),OPTIONAL,INTENT(IN) :: TPSPLITTING ! splitting of the domain -! -INTEGER :: ID ! Index of the field -INTEGER :: IRESP ! return_code -! -CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYNAME_X2',TRIM(TPFILE%CNAME)//': reading '//TRIM(HNAME)) -! -CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) -! -IF(IRESP==0) CALL IO_READ_FIELD(TPFILE,TFIELDLIST(ID),PFIELD,IRESP,KIMAX_ll,KJMAX_ll,TPSPLITTING) -! -IF (PRESENT(KRESP)) KRESP = IRESP -! -END SUBROUTINE IO_READ_FIELD_BYNAME_X2 - -SUBROUTINE IO_READ_FIELD_BYFIELD_X2(TPFILE,TPFIELD,PFIELD,KRESP,KIMAX_ll,KJMAX_ll,TPSPLITTING) -! -USE MODD_IO_ll, ONLY : GSMONOPROC,ISP,ISNPROC,LPACK,L1D,L2D -USE MODD_STRUCTURE_ll, ONLY : ZONE_ll -USE MODD_TIMEZ, ONLY : TIMEZ -! -USE MODE_ALLOCBUFFER_ll -#ifdef MNH_GA -USE MODE_GA -#endif -USE MODE_MNH_TIMING, ONLY : SECOND_MNH2 -USE MODE_SCATTER_ll -! -TYPE(TFILEDATA), INTENT(IN) :: TPFILE -TYPE(TFIELDDATA), INTENT(INOUT) :: TPFIELD -REAL,DIMENSION(:,:),TARGET,INTENT(INOUT) :: PFIELD ! array containing the data field -INTEGER, OPTIONAL, INTENT(OUT) :: KRESP ! return-code -INTEGER, OPTIONAL, INTENT(IN) :: KIMAX_ll -INTEGER, OPTIONAL, INTENT(IN) :: KJMAX_ll -TYPE(ZONE_ll),DIMENSION(ISNPROC),OPTIONAL,INTENT(IN) :: TPSPLITTING ! splitting of the domain -! -INTEGER :: IERR -REAL,DIMENSION(:,:),POINTER :: ZFIELDP -LOGICAL :: GALLOC -INTEGER :: IRESP -INTEGER :: IHEXTOT -REAL(KIND=8),DIMENSION(2) :: T0,T1,T2 -REAL(KIND=8),DIMENSION(2) :: T11,T22 -#ifdef MNH_GA -REAL,DIMENSION(:,:),POINTER :: ZFIELD_GA -#endif -! -CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYFIELD_X2',TRIM(TPFILE%CNAME)//': reading '//TRIM(TPFIELD%CMNHNAME)) -! -CALL SECOND_MNH2(T11) -GALLOC = .FALSE. -IRESP = 0 -ZFIELDP => NULL() -! -IHEXTOT = 2*JPHEXT+1 -CALL IO_FILE_READ_CHECK(TPFILE,'IO_READ_FIELD_BYFIELD_X2',IRESP) -! -IF (IRESP==0) THEN - IF (GSMONOPROC) THEN ! sequential execution - IF (LPACK .AND. L1D .AND. SIZE(PFIELD,1)==IHEXTOT .AND. SIZE(PFIELD,2)==IHEXTOT) THEN - ZFIELDP=>PFIELD(JPHEXT+1:JPHEXT+1,JPHEXT+1:JPHEXT+1) - ELSE IF (LPACK .AND. L2D .AND. SIZE(PFIELD,2)==IHEXTOT) THEN - ZFIELDP=>PFIELD(:,JPHEXT+1:JPHEXT+1) - ELSE - ZFIELDP=>PFIELD(:,:) - END IF - IF (TPFILE%CFORMAT=='NETCDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFI') THEN - CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) - END IF - IF (LPACK .AND. L1D .AND. SIZE(PFIELD,1)==IHEXTOT .AND. SIZE(PFIELD,2)==IHEXTOT) THEN - PFIELD(:,:)=SPREAD(SPREAD(PFIELD(JPHEXT+1,JPHEXT+1),DIM=1,NCOPIES=IHEXTOT),DIM=2,NCOPIES=IHEXTOT) - ELSE IF (LPACK .AND. L2D .AND. SIZE(PFIELD,2)==IHEXTOT) THEN - PFIELD(:,:)=SPREAD(PFIELD(:,JPHEXT+1),DIM=2,NCOPIES=IHEXTOT) - END IF - ELSE - CALL SECOND_MNH2(T0) - IF (ISP == TPFILE%NMASTER_RANK) THEN - ! I/O process case - CALL ALLOCBUFFER_ll(ZFIELDP,PFIELD,TPFIELD%CDIR,GALLOC, KIMAX_ll, KJMAX_ll) - IF (TPFILE%CFORMAT=='NETCDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFI') THEN - CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) - END IF - ELSE - !Not really necessary but useful to suppress alerts with Valgrind - ALLOCATE(ZFIELDP(0,0)) - GALLOC = .TRUE. - END IF - CALL SECOND_MNH2(T1) - TIMEZ%T_READ2D_READ=TIMEZ%T_READ2D_READ + T1 - T0 - ! - CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - ! - !Broadcast header only if IRESP==-111 - !because metadata of field has been modified in IO_READ_FIELD_xxx - IF (IRESP==-111) CALL IO_BCAST_FIELD_METADATA(TPFILE,TPFIELD) - ! - IF (TPFIELD%CDIR == 'XX' .OR. TPFIELD%CDIR == 'YY') THEN - ! XX or YY Scatter Field - CALL SCATTER_XXFIELD(TPFIELD%CDIR,ZFIELDP,PFIELD,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM,TPSPLITTING) - ELSE IF (TPFIELD%CDIR == 'XY') THEN - IF (LPACK .AND. L2D) THEN - ! 2D compact case - CALL SCATTER_XXFIELD('XX',ZFIELDP(:,1),PFIELD(:,JPHEXT+1),TPFILE%NMASTER_RANK,TPFILE%NMPICOMM,TPSPLITTING) - PFIELD(:,:) = SPREAD(PFIELD(:,JPHEXT+1),DIM=2,NCOPIES=IHEXTOT) - ELSE -#ifdef MNH_GA - ! - ! init/create the ga , dim3 = 1 - ! - CALL MNH_INIT_GA(SIZE(PFIELD,1),SIZE(PFIELD,2),1,TPFIELD%CMNHNAME,"READ") - IF (ISP == TPFILE%NMASTER_RANK) THEN - ! - ! put the data in the g_a , this proc get this 1 slide - ! - lo_zplan(JPIZ) = 1 - hi_zplan(JPIZ) = 1 - call nga_put(g_a, lo_zplan, hi_zplan,ZFIELDP, ld_zplan) - END IF - call ga_sync - ! - ! get the columun data in this proc - ! - ! temp buf to avoid problem with none stride PFIELDS buffer with HALO - ALLOCATE (ZFIELD_GA (SIZE(PFIELD,1),SIZE(PFIELD,2))) - call nga_get(g_a, lo_col, hi_col,ZFIELD_GA(1,1) , ld_col) - PFIELD = ZFIELD_GA - DEALLOCATE(ZFIELD_GA) -#else - ! XY Scatter Field - CALL SCATTER_XYFIELD(ZFIELDP,PFIELD,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) -#endif - END IF - ELSE - CALL MPI_BCAST(PFIELD,SIZE(PFIELD),MPI_FLOAT,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - END IF - END IF - CALL SECOND_MNH2(T2) - TIMEZ%T_READ2D_SCAT=TIMEZ%T_READ2D_SCAT + T2 - T1 -END IF -! -IF (GALLOC) DEALLOCATE (ZFIELDP) -! -IF (IRESP==-111) IRESP = 0 !-111 is not really an error (metadata has changed) -! -IF (PRESENT(KRESP)) KRESP = IRESP -! -CALL SECOND_MNH2(T22) -TIMEZ%T_READ2D_ALL=TIMEZ%T_READ2D_ALL + T22 - T11 -! -END SUBROUTINE IO_READ_FIELD_BYFIELD_X2 - - -SUBROUTINE IO_READ_FIELD_BYNAME_X3(TPFILE,HNAME,PFIELD,KRESP) -! -TYPE(TFILEDATA), INTENT(IN) :: TPFILE -CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write -REAL,DIMENSION(:,:,:),INTENT(INOUT) :: PFIELD ! array containing the data field -INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code -! -INTEGER :: ID ! Index of the field -INTEGER :: IRESP ! return_code -! -CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYNAME_X3',TRIM(TPFILE%CNAME)//': reading '//TRIM(HNAME)) -! -CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) -! -IF(IRESP==0) CALL IO_READ_FIELD(TPFILE,TFIELDLIST(ID),PFIELD,IRESP) -! -IF (PRESENT(KRESP)) KRESP = IRESP -! -END SUBROUTINE IO_READ_FIELD_BYNAME_X3 - -SUBROUTINE IO_READ_FIELD_BYFIELD_X3(TPFILE,TPFIELD,PFIELD,KRESP) -! -USE MODD_IO_ll, ONLY : GSMONOPROC,ISP,ISNPROC,LPACK,L1D,L2D -USE MODD_TIMEZ, ONLY : TIMEZ -USE MODD_VAR_ll, ONLY : MNH_STATUSES_IGNORE -! -USE MODE_ALLOCBUFFER_ll -#ifdef MNH_GA -USE MODE_GA -#endif -USE MODE_IO_ll, ONLY : IO_FILE -USE MODE_IO_MANAGE_STRUCT, ONLY : IO_FILE_FIND_BYNAME -USE MODE_MNH_TIMING, ONLY : SECOND_MNH2 -USE MODE_SCATTER_ll -! -TYPE(TFILEDATA),TARGET, INTENT(IN) :: TPFILE -TYPE(TFIELDDATA), INTENT(INOUT) :: TPFIELD -REAL,DIMENSION(:,:,:),TARGET,INTENT(INOUT) :: PFIELD ! array containing the data field -INTEGER, OPTIONAL, INTENT(OUT) :: KRESP ! return-code -! -TYPE TX_2DP - REAL,DIMENSION(:,:), POINTER :: X -END TYPE TX_2DP -! -INTEGER :: IERR,IRESP -INTEGER :: IHEXTOT -INTEGER :: IK_FILE,IK_RANK,INB_PROC_REAL,JK_MAX -INTEGER :: JI,IXO,IXE,IYO,IYE -INTEGER :: JK,JKK -INTEGER :: NB_REQ -INTEGER,ALLOCATABLE,DIMENSION(:) :: REQ_TAB -INTEGER, DIMENSION(MPI_STATUS_SIZE) :: STATUS -LOGICAL :: GALLOC, GALLOC_ll -REAL,DIMENSION(:,:),POINTER :: TX2DP -REAL,DIMENSION(:,:),POINTER :: ZSLICE_ll,ZSLICE -REAL,DIMENSION(:,:,:),POINTER :: ZFIELDP -REAL(KIND=8),DIMENSION(2) :: T0,T1,T2 -REAL(KIND=8),DIMENSION(2) :: T11,T22 -CHARACTER(LEN=2) :: YDIR -CHARACTER(LEN=4) :: YK -CHARACTER(LEN=NMNHNAMELGTMAX+4) :: YRECZSLICE -CHARACTER(LEN=4) :: YSUFFIX -TYPE(TFILEDATA),POINTER :: TZFILE -TYPE(TFIELDDATA) :: TZFIELD -TYPE(TX_2DP),ALLOCATABLE,DIMENSION(:) :: T_TX2DP -#ifdef MNH_GA -REAL,DIMENSION(:,:,:),POINTER :: ZFIELD_GA -#endif -! -CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYFIELD_X3',TRIM(TPFILE%CNAME)//': reading '//TRIM(TPFIELD%CMNHNAME)) -! -CALL SECOND_MNH2(T11) -! -TZFILE => NULL() -GALLOC = .FALSE. -GALLOC_ll = .FALSE. -IRESP = 0 -ZFIELDP => NULL() -YDIR = TPFIELD%CDIR -! -IHEXTOT = 2*JPHEXT+1 -! -CALL IO_FILE_READ_CHECK(TPFILE,'IO_READ_FIELD_BYFIELD_X3',IRESP) -! -IF (IRESP==0) THEN - IF (GSMONOPROC .AND. TPFILE%NSUBFILES_IOZ==0 ) THEN ! sequential execution - IF (LPACK .AND. L1D .AND. SIZE(PFIELD,1)==IHEXTOT .AND. SIZE(PFIELD,2)==IHEXTOT) THEN - ZFIELDP=>PFIELD(JPHEXT+1:JPHEXT+1,JPHEXT+1:JPHEXT+1,:) - ELSE IF (LPACK .AND. L2D .AND. SIZE(PFIELD,2)==IHEXTOT) THEN - ALLOCATE (ZFIELDP(SIZE(PFIELD,1),1,SIZE(PFIELD,3))) - GALLOC = .TRUE. - ELSE - ZFIELDP=>PFIELD(:,:,:) - END IF - IF (TPFILE%CFORMAT=='NETCDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFI') THEN - CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) - END IF - IF (LPACK .AND. L1D .AND. SIZE(PFIELD,1)==IHEXTOT .AND. SIZE(PFIELD,2)==IHEXTOT) THEN - PFIELD(:,:,:)=SPREAD(SPREAD(PFIELD(JPHEXT+1,JPHEXT+1,:),DIM=1,NCOPIES=IHEXTOT),DIM=2,NCOPIES=IHEXTOT) - ELSE IF (LPACK .AND. L2D .AND. SIZE(PFIELD,2)==IHEXTOT) THEN - PFIELD(:,:,:)=SPREAD(ZFIELDP(:,1,:),DIM=2,NCOPIES=IHEXTOT) - END IF - ELSE IF ( TPFILE%NSUBFILES_IOZ==0 .OR. YDIR == '--' ) THEN ! multiprocesses execution & 1 IO proc - IF (ISP == TPFILE%NMASTER_RANK) THEN - ! I/O process case - CALL ALLOCBUFFER_ll(ZFIELDP,PFIELD,YDIR,GALLOC) - IF (TPFILE%CFORMAT=='NETCDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFI') THEN - CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) - END IF - ELSE - !Not really necessary but useful to suppress alerts with Valgrind - ALLOCATE(ZFIELDP(0,0,0)) - GALLOC = .TRUE. - END IF - ! - CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - ! - !Broadcast header only if IRESP==-111 - !because metadata of field has been modified in IO_READ_FIELD_xxx - IF (IRESP==-111) CALL IO_BCAST_FIELD_METADATA(TPFILE,TPFIELD) - ! - IF (YDIR == 'XX' .OR. YDIR =='YY') THEN - ! XX or YY Scatter Field - CALL SCATTER_XXFIELD(YDIR,ZFIELDP,PFIELD,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) - ELSE IF (YDIR == 'XY') THEN - IF (LPACK .AND. L2D) THEN - ! 2D compact case - CALL SCATTER_XXFIELD('XX',ZFIELDP(:,1,:),PFIELD(:,JPHEXT+1,:),TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) - PFIELD(:,:,:) = SPREAD(PFIELD(:,JPHEXT+1,:),DIM=2,NCOPIES=IHEXTOT) - ELSE - ! XY Scatter Field - CALL SCATTER_XYFIELD(ZFIELDP,PFIELD,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) - END IF - ELSE - ! Broadcast Field - CALL MPI_BCAST(PFIELD,SIZE(PFIELD),MPI_FLOAT,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - END IF - ELSE ! multiprocesses execution & // IO -! -!JUAN BG Z SLICE -! -#ifdef MNH_GA - ! - ! init/create the ga - ! - CALL SECOND_MNH2(T0) - CALL MNH_INIT_GA(SIZE(PFIELD,1),SIZE(PFIELD,2),SIZE(PFIELD,3),TPFIELD%CMNHNAME,"READ") - ! - ! read the data - ! - ALLOCATE(ZSLICE_ll(0,0)) ! to avoid bug on test of size - GALLOC_ll = .TRUE. - DO JKK=1,IKU_ll - IK_FILE = IO_FILE(JKK,TPFILE%NSUBFILES_IOZ) - TZFILE => TPFILE%TFILES_IOZ(IK_FILE+1)%TFILE - TZFIELD = TPFIELD - WRITE(YSUFFIX,'(I4.4)') JKK - TZFIELD%CMNHNAME = TRIM(TPFIELD%CMNHNAME)//TRIM(YSUFFIX) - IF (LEN_TRIM(TZFIELD%CSTDNAME)>0) TZFIELD%CSTDNAME = TRIM(TZFIELD%CSTDNAME)//'_at_level_'//YSUFFIX - IF (LEN_TRIM(TZFIELD%CLONGNAME)>0) TZFIELD%CLONGNAME = TRIM(TZFIELD%CLONGNAME)//' at level '//YSUFFIX - TZFIELD%NDIMS = 2 - ! - IK_RANK = TZFILE%NMASTER_RANK - ! - IF (ISP == IK_RANK ) THEN - IF ( SIZE(ZSLICE_ll) .EQ. 0 ) THEN - DEALLOCATE(ZSLICE_ll) - CALL ALLOCBUFFER_ll(ZSLICE_ll,ZSLICE,YDIR,GALLOC_ll) - END IF - ! - CALL SECOND_MNH2(T0) - WRITE(YK,'(I4.4)') JKK - YRECZSLICE = TRIM(TPFIELD%CMNHNAME)//YK - IF (TPFILE%CFORMAT=='NETCDF4') THEN - CALL IO_READ_FIELD_NC4(TZFILE,TZFIELD,ZSLICE_ll,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFI') THEN - CALL IO_READ_FIELD_LFI(TZFILE,TZFIELD,ZSLICE_ll,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN - CALL IO_READ_FIELD_NC4(TZFILE,TZFIELD,ZSLICE_ll,IRESP) - END IF - CALL SECOND_MNH2(T1) - TIMEZ%T_READ3D_READ=TIMEZ%T_READ3D_READ + T1 - T0 - ! - ! put the data in the g_a , this proc get this JKK slide - ! - LO_ZPLAN(JPIZ) = JKK - HI_ZPLAN(JPIZ) = JKK - CALL NGA_PUT(G_A, LO_ZPLAN, HI_ZPLAN,ZSLICE_LL, LD_ZPLAN) - END IF - TZFILE => NULL() - END DO - CALL GA_SYNC - ! - ! get the columun data in this proc - ! - ! temp buf to avoid problem with none stride PFIELDS buffer with HALO - ALLOCATE (ZFIELD_GA (SIZE(PFIELD,1),SIZE(PFIELD,2),SIZE(PFIELD,3))) - CALL NGA_GET(G_A, LO_COL, HI_COL,ZFIELD_GA(1,1,1) , LD_COL) - PFIELD = ZFIELD_GA - DEALLOCATE(ZFIELD_GA) -#else - ALLOCATE(ZSLICE_ll(0,0)) - GALLOC_ll = .TRUE. - INB_PROC_REAL = MIN(TPFILE%NSUBFILES_IOZ,ISNPROC) - Z_SLICE: DO JK=1,SIZE(PFIELD,3),INB_PROC_REAL - ! - ! read the data - ! - JK_MAX=MIN(SIZE(PFIELD,3),JK+INB_PROC_REAL-1) - ! - NB_REQ=0 - ALLOCATE(REQ_TAB(ISNPROC-1)) - ALLOCATE(T_TX2DP(ISNPROC-1)) - DO JKK=JK,JK_MAX - IF (TPFILE%NSUBFILES_IOZ .GT. 1 ) THEN - IK_FILE = IO_FILE(JKK,TPFILE%NSUBFILES_IOZ) - TZFILE => TPFILE%TFILES_IOZ(IK_FILE+1)%TFILE - TZFIELD = TPFIELD - WRITE(YSUFFIX,'(I4.4)') JKK - TZFIELD%CMNHNAME = TRIM(TPFIELD%CMNHNAME)//TRIM(YSUFFIX) - IF (LEN_TRIM(TZFIELD%CSTDNAME)>0) TZFIELD%CSTDNAME = TRIM(TZFIELD%CSTDNAME)//'_at_level_'//YSUFFIX - IF (LEN_TRIM(TZFIELD%CLONGNAME)>0) TZFIELD%CLONGNAME = TRIM(TZFIELD%CLONGNAME)//' at level '//YSUFFIX - TZFIELD%NDIMS = 2 - ELSE - TZFILE => TPFILE - TZFIELD = TPFIELD - END IF - IK_RANK = TZFILE%NMASTER_RANK - IF (ISP == IK_RANK ) THEN - IF ( SIZE(ZSLICE_ll) .EQ. 0 ) THEN - DEALLOCATE(ZSLICE_ll) - CALL ALLOCBUFFER_ll(ZSLICE_ll,ZSLICE,YDIR,GALLOC_ll) - END IF - CALL SECOND_MNH2(T0) - WRITE(YK,'(I4.4)') JKK - YRECZSLICE = TRIM(TPFIELD%CMNHNAME)//YK - IF (TPFILE%CFORMAT=='NETCDF4') THEN - CALL IO_READ_FIELD_NC4(TZFILE,TZFIELD,ZSLICE_ll,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFI') THEN - CALL IO_READ_FIELD_LFI(TZFILE,TZFIELD,ZSLICE_ll,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN - CALL IO_READ_FIELD_NC4(TZFILE,TZFIELD,ZSLICE_ll,IRESP) - END IF - CALL SECOND_MNH2(T1) - TIMEZ%T_READ3D_READ=TIMEZ%T_READ3D_READ + T1 - T0 - DO JI = 1,ISNPROC - CALL GET_DOMREAD_ll(JI,IXO,IXE,IYO,IYE) - TX2DP=>ZSLICE_ll(IXO:IXE,IYO:IYE) - IF (ISP /= JI) THEN - NB_REQ = NB_REQ + 1 - ALLOCATE(T_TX2DP(NB_REQ)%X(IXO:IXE,IYO:IYE)) - T_TX2DP(NB_REQ)%X=TX2DP - CALL MPI_ISEND(T_TX2DP(NB_REQ)%X,SIZE(TX2DP),MPI_FLOAT,JI-1,199+IK_RANK, & - TZFILE%NMPICOMM,REQ_TAB(NB_REQ),IERR) - !CALL MPI_BSEND(TX2DP,SIZE(TX2DP),MPI_FLOAT,JI-1,199+IK_RANK,TZFILE%NMPICOMM,IERR) - ELSE - PFIELD(:,:,JKK) = TX2DP(:,:) - END IF - END DO - CALL SECOND_MNH2(T2) - TIMEZ%T_READ3D_SEND=TIMEZ%T_READ3D_SEND + T2 - T1 - END IF - TZFILE => NULL() - END DO - ! - ! broadcast the data - ! - IF (YDIR == 'XX' .OR. YDIR =='YY') THEN - ! XX or YY Scatter Field - STOP " XX ou YY NON PREVU SUR BG POUR LE MOMENT " - CALL SCATTER_XXFIELD(YDIR,ZFIELDP,PFIELD,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) - ELSE IF (YDIR == 'XY') THEN - IF (LPACK .AND. L2D) THEN - ! 2D compact case - STOP " L2D NON PREVU SUR BG POUR LE MOMENT " - CALL SCATTER_XXFIELD('XX',ZFIELDP(:,1,:),PFIELD(:,JPHEXT+1,:),TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) - PFIELD(:,:,:) = SPREAD(PFIELD(:,JPHEXT+1,:),DIM=2,NCOPIES=IHEXTOT) - ELSE - ! - ! XY Scatter Field - ! - CALL SECOND_MNH2(T0) - DO JKK=JK,JK_MAX - ! - ! get the file & rank - ! - IF (TPFILE%NSUBFILES_IOZ .GT. 1 ) THEN - IK_FILE = IO_FILE(JKK,TPFILE%NSUBFILES_IOZ) - TZFILE => TPFILE%TFILES_IOZ(IK_FILE+1)%TFILE - ELSE - TZFILE => TPFILE - END IF - ! - IK_RANK = TZFILE%NMASTER_RANK - ! - ZSLICE => PFIELD(:,:,JKK) - !CALL SCATTER_XYFIELD(ZSLICE_ll,ZSLICE,TZFILE%NMASTER_RANK,TZFILE%NMPICOMM) - IF (ISP .NE. IK_RANK) THEN - CALL MPI_RECV(ZSLICE,SIZE(ZSLICE),MPI_FLOAT,IK_RANK-1,199+IK_RANK, & - TZFILE%NMPICOMM,STATUS,IERR) - END IF - TZFILE => NULL() - END DO - CALL SECOND_MNH2(T1) - TIMEZ%T_READ3D_RECV=TIMEZ%T_READ3D_RECV + T1 - T0 - END IF - ELSE - ! Broadcast Field - STOP " Broadcast Field NON PREVU SUR BG POUR LE MOMENT " - CALL MPI_BCAST(PFIELD,SIZE(PFIELD),MPI_FLOAT,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - END IF - CALL SECOND_MNH2(T0) - IF (NB_REQ .GT.0 ) THEN - CALL MPI_WAITALL(NB_REQ,REQ_TAB,MNH_STATUSES_IGNORE,IERR) - DO JI=1,NB_REQ ; DEALLOCATE(T_TX2DP(JI)%X) ; ENDDO - END IF - DEALLOCATE(T_TX2DP) - DEALLOCATE(REQ_TAB) - CALL SECOND_MNH2(T1) - TIMEZ%T_READ3D_WAIT=TIMEZ%T_READ3D_WAIT + T1 - T0 - END DO Z_SLICE - ! - !Broadcast header only if IRESP==-111 - !because metadata of field has been modified in IO_READ_FIELD_xxx - IF (IRESP==-111) CALL IO_BCAST_FIELD_METADATA(TPFILE,TPFIELD) - ! -#endif -!JUAN BG Z SLICE - END IF !(GSMONOPROC) -END IF -! -IF (GALLOC) DEALLOCATE (ZFIELDP) -IF (GALLOC_ll) DEALLOCATE (ZSLICE_ll) -! -IF (IRESP==-111) IRESP = 0 !-111 is not really an error (metadata has changed) -! -IF (PRESENT(KRESP)) KRESP = IRESP -! -CALL SECOND_MNH2(T22) -TIMEZ%T_READ3D_ALL=TIMEZ%T_READ3D_ALL + T22 - T11 -! -END SUBROUTINE IO_READ_FIELD_BYFIELD_X3 - - -SUBROUTINE IO_READ_FIELD_BYNAME_X4(TPFILE,HNAME,PFIELD,KRESP) -! -USE MODD_IO_ll, ONLY : ISNPROC -USE MODD_STRUCTURE_ll, ONLY : ZONE_ll -! -! -TYPE(TFILEDATA), INTENT(IN) :: TPFILE -CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write -REAL,DIMENSION(:,:,:,:),INTENT(INOUT) :: PFIELD ! array containing the data field -INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code -! -INTEGER :: ID ! Index of the field -INTEGER :: IRESP ! return_code -! -CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYNAME_X4',TRIM(TPFILE%CNAME)//': reading '//TRIM(HNAME)) -! -CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) -! -IF(IRESP==0) CALL IO_READ_FIELD(TPFILE,TFIELDLIST(ID),PFIELD,IRESP) -! -IF (PRESENT(KRESP)) KRESP = IRESP -! -END SUBROUTINE IO_READ_FIELD_BYNAME_X4 - -SUBROUTINE IO_READ_FIELD_BYFIELD_X4(TPFILE,TPFIELD,PFIELD,KRESP) -! -USE MODD_IO_ll, ONLY : GSMONOPROC,ISP,ISNPROC,LPACK,L1D,L2D -USE MODD_STRUCTURE_ll, ONLY : ZONE_ll -USE MODD_TIMEZ, ONLY : TIMEZ -! -USE MODE_ALLOCBUFFER_ll -USE MODE_MNH_TIMING, ONLY : SECOND_MNH2 -USE MODE_SCATTER_ll -! -TYPE(TFILEDATA), INTENT(IN) :: TPFILE -TYPE(TFIELDDATA), INTENT(INOUT) :: TPFIELD -REAL,DIMENSION(:,:,:,:),TARGET,INTENT(INOUT) :: PFIELD ! array containing the data field -INTEGER, OPTIONAL, INTENT(OUT) :: KRESP ! return-code -! -INTEGER :: IERR -REAL,DIMENSION(:,:,:,:),POINTER :: ZFIELDP -LOGICAL :: GALLOC -INTEGER :: IRESP -INTEGER :: IHEXTOT -! -CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYFIELD_X4',TRIM(TPFILE%CNAME)//': reading '//TRIM(TPFIELD%CMNHNAME)) -! -GALLOC = .FALSE. -IRESP = 0 -ZFIELDP => NULL() -! -IHEXTOT = 2*JPHEXT+1 -CALL IO_FILE_READ_CHECK(TPFILE,'IO_READ_FIELD_BYFIELD_X4',IRESP) -! -IF (IRESP==0) THEN - IF (GSMONOPROC) THEN ! sequential execution - IF (LPACK .AND. L1D .AND. SIZE(PFIELD,1)==IHEXTOT .AND. SIZE(PFIELD,2)==IHEXTOT) THEN - ZFIELDP=>PFIELD(JPHEXT+1:JPHEXT+1,JPHEXT+1:JPHEXT+1,:,:) - ELSE IF (LPACK .AND. L2D .AND. SIZE(PFIELD,2)==IHEXTOT) THEN - ZFIELDP=>PFIELD(:,JPHEXT+1:JPHEXT+1,:,:) - ELSE - ZFIELDP=>PFIELD(:,:,:,:) - END IF - IF (TPFILE%CFORMAT=='NETCDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFI') THEN - CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) - END IF - IF (LPACK .AND. L1D .AND. SIZE(PFIELD,1)==IHEXTOT .AND. SIZE(PFIELD,2)==IHEXTOT) THEN - PFIELD(:,:,:,:)=SPREAD(SPREAD(PFIELD(JPHEXT+1,JPHEXT+1,:,:),DIM=1,NCOPIES=IHEXTOT),DIM=2,NCOPIES=IHEXTOT) - ELSE IF (LPACK .AND. L2D .AND. SIZE(PFIELD,2)==IHEXTOT) THEN - PFIELD(:,:,:,:)=SPREAD(PFIELD(:,JPHEXT+1,:,:),DIM=2,NCOPIES=IHEXTOT) - END IF - ELSE - IF (ISP == TPFILE%NMASTER_RANK) THEN - ! I/O process case - CALL ALLOCBUFFER_ll(ZFIELDP,PFIELD,TPFIELD%CDIR,GALLOC) - IF (TPFILE%CFORMAT=='NETCDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFI') THEN - CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) - END IF - ELSE - !Not really necessary but useful to suppress alerts with Valgrind - ALLOCATE(ZFIELDP(0,0,0,0)) - GALLOC = .TRUE. - END IF - ! - CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - ! - !Broadcast header only if IRESP==-111 - !because metadata of field has been modified in IO_READ_FIELD_xxx - IF (IRESP==-111) CALL IO_BCAST_FIELD_METADATA(TPFILE,TPFIELD) - ! - IF (TPFIELD%CDIR == 'XX' .OR. TPFIELD%CDIR == 'YY') THEN - ! XX or YY Scatter Field - CALL SCATTER_XXFIELD(TPFIELD%CDIR,ZFIELDP,PFIELD,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) - ELSE IF (TPFIELD%CDIR == 'XY') THEN - IF (LPACK .AND. L2D) THEN - ! 2D compact case - CALL SCATTER_XXFIELD('XX',ZFIELDP(:,1,:,:),PFIELD(:,JPHEXT+1,:,:),TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) - PFIELD(:,:,:,:) = SPREAD(PFIELD(:,JPHEXT+1,:,:),DIM=2,NCOPIES=IHEXTOT) - ELSE - ! XY Scatter Field - CALL SCATTER_XYFIELD(ZFIELDP,PFIELD,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) - END IF - ELSE - CALL MPI_BCAST(PFIELD,SIZE(PFIELD),MPI_FLOAT,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - END IF - END IF -END IF -! -IF (GALLOC) DEALLOCATE (ZFIELDP) -! -IF (IRESP==-111) IRESP = 0 !-111 is not really an error (metadata has changed) -! -IF (PRESENT(KRESP)) KRESP = IRESP -! -END SUBROUTINE IO_READ_FIELD_BYFIELD_X4 - - -SUBROUTINE IO_READ_FIELD_BYNAME_X5(TPFILE,HNAME,PFIELD,KRESP) -! -USE MODD_IO_ll, ONLY : ISNPROC -USE MODD_STRUCTURE_ll, ONLY : ZONE_ll -! -! -TYPE(TFILEDATA), INTENT(IN) :: TPFILE -CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write -REAL,DIMENSION(:,:,:,:,:),INTENT(INOUT) :: PFIELD ! array containing the data field -INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code -! -INTEGER :: ID ! Index of the field -INTEGER :: IRESP ! return_code -! -CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYNAME_X5',TRIM(TPFILE%CNAME)//': reading '//TRIM(HNAME)) -! -CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) -! -IF(IRESP==0) CALL IO_READ_FIELD(TPFILE,TFIELDLIST(ID),PFIELD,IRESP) -! -IF (PRESENT(KRESP)) KRESP = IRESP -! -END SUBROUTINE IO_READ_FIELD_BYNAME_X5 - -SUBROUTINE IO_READ_FIELD_BYFIELD_X5(TPFILE,TPFIELD,PFIELD,KRESP) -! -USE MODD_IO_ll, ONLY : GSMONOPROC,ISP,ISNPROC,LPACK,L1D,L2D -USE MODD_STRUCTURE_ll, ONLY : ZONE_ll -USE MODD_TIMEZ, ONLY : TIMEZ -! -USE MODE_ALLOCBUFFER_ll -USE MODE_MNH_TIMING, ONLY : SECOND_MNH2 -USE MODE_SCATTER_ll -! -TYPE(TFILEDATA), INTENT(IN) :: TPFILE -TYPE(TFIELDDATA), INTENT(INOUT) :: TPFIELD -REAL,DIMENSION(:,:,:,:,:),TARGET,INTENT(INOUT) :: PFIELD ! array containing the data field -INTEGER, OPTIONAL, INTENT(OUT) :: KRESP ! return-code -! -INTEGER :: IERR -REAL,DIMENSION(:,:,:,:,:),POINTER :: ZFIELDP -LOGICAL :: GALLOC -INTEGER :: IRESP -INTEGER :: IHEXTOT -! -CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYFIELD_X5',TRIM(TPFILE%CNAME)//': reading '//TRIM(TPFIELD%CMNHNAME)) -! -GALLOC = .FALSE. -IRESP = 0 -ZFIELDP => NULL() -! -IHEXTOT = 2*JPHEXT+1 -CALL IO_FILE_READ_CHECK(TPFILE,'IO_READ_FIELD_BYFIELD_X5',IRESP) -! -IF (IRESP==0) THEN - IF (GSMONOPROC) THEN ! sequential execution - IF (LPACK .AND. L1D .AND. SIZE(PFIELD,1)==IHEXTOT .AND. SIZE(PFIELD,2)==IHEXTOT) THEN - ZFIELDP=>PFIELD(JPHEXT+1:JPHEXT+1,JPHEXT+1:JPHEXT+1,:,:,:) - ELSE IF (LPACK .AND. L2D .AND. SIZE(PFIELD,2)==IHEXTOT) THEN - ZFIELDP=>PFIELD(:,JPHEXT+1:JPHEXT+1,:,:,:) - ELSE - ZFIELDP=>PFIELD(:,:,:,:,:) - END IF - IF (TPFILE%CFORMAT=='NETCDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFI') THEN - CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) - END IF - IF (LPACK .AND. L1D .AND. SIZE(PFIELD,1)==IHEXTOT .AND. SIZE(PFIELD,2)==IHEXTOT) THEN - PFIELD(:,:,:,:,:)=SPREAD(SPREAD(PFIELD(JPHEXT+1,JPHEXT+1,:,:,:),DIM=1,NCOPIES=IHEXTOT),DIM=2,NCOPIES=IHEXTOT) - ELSE IF (LPACK .AND. L2D .AND. SIZE(PFIELD,2)==IHEXTOT) THEN - PFIELD(:,:,:,:,:)=SPREAD(PFIELD(:,JPHEXT+1,:,:,:),DIM=2,NCOPIES=IHEXTOT) - END IF - ELSE - IF (ISP == TPFILE%NMASTER_RANK) THEN - ! I/O process case - CALL ALLOCBUFFER_ll(ZFIELDP,PFIELD,TPFIELD%CDIR,GALLOC) - IF (TPFILE%CFORMAT=='NETCDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFI') THEN - CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) - END IF - ELSE - !Not really necessary but useful to suppress alerts with Valgrind - ALLOCATE(ZFIELDP(0,0,0,0,0)) - GALLOC = .TRUE. - END IF - ! - CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - ! - !Broadcast header only if IRESP==-111 - !because metadata of field has been modified in IO_READ_FIELD_xxx - IF (IRESP==-111) CALL IO_BCAST_FIELD_METADATA(TPFILE,TPFIELD) - ! - IF (TPFIELD%CDIR == 'XX' .OR. TPFIELD%CDIR == 'YY') THEN - ! XX or YY Scatter Field - CALL SCATTER_XXFIELD(TPFIELD%CDIR,ZFIELDP,PFIELD,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) - ELSE IF (TPFIELD%CDIR == 'XY') THEN - IF (LPACK .AND. L2D) THEN - ! 2D compact case - CALL SCATTER_XXFIELD('XX',ZFIELDP(:,1,:,:,:),PFIELD(:,JPHEXT+1,:,:,:),TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) - PFIELD(:,:,:,:,:) = SPREAD(PFIELD(:,JPHEXT+1,:,:,:),DIM=2,NCOPIES=IHEXTOT) - ELSE - ! XY Scatter Field - CALL SCATTER_XYFIELD(ZFIELDP,PFIELD,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) - END IF - ELSE - CALL MPI_BCAST(PFIELD,SIZE(PFIELD),MPI_FLOAT,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - END IF - END IF -END IF -! -IF (GALLOC) DEALLOCATE (ZFIELDP) -! -IF (IRESP==-111) IRESP = 0 !-111 is not really an error (metadata has changed) -! -IF (PRESENT(KRESP)) KRESP = IRESP -! -END SUBROUTINE IO_READ_FIELD_BYFIELD_X5 - - -SUBROUTINE IO_READ_FIELD_BYNAME_X6(TPFILE,HNAME,PFIELD,KRESP) -! -USE MODD_IO_ll, ONLY : ISNPROC -USE MODD_STRUCTURE_ll, ONLY : ZONE_ll -! -! -TYPE(TFILEDATA), INTENT(IN) :: TPFILE -CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write -REAL,DIMENSION(:,:,:,:,:,:),INTENT(INOUT) :: PFIELD ! array containing the data field -INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code -! -INTEGER :: ID ! Index of the field -INTEGER :: IRESP ! return_code -! -CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYNAME_X6',TRIM(TPFILE%CNAME)//': reading '//TRIM(HNAME)) -! -CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) -! -IF(IRESP==0) CALL IO_READ_FIELD(TPFILE,TFIELDLIST(ID),PFIELD,IRESP) -! -IF (PRESENT(KRESP)) KRESP = IRESP -! -END SUBROUTINE IO_READ_FIELD_BYNAME_X6 - -SUBROUTINE IO_READ_FIELD_BYFIELD_X6(TPFILE,TPFIELD,PFIELD,KRESP) -! -USE MODD_IO_ll, ONLY : GSMONOPROC,ISP,ISNPROC,LPACK,L1D,L2D -USE MODD_STRUCTURE_ll, ONLY : ZONE_ll -USE MODD_TIMEZ, ONLY : TIMEZ -! -USE MODE_ALLOCBUFFER_ll -USE MODE_MNH_TIMING, ONLY : SECOND_MNH2 -USE MODE_SCATTER_ll -! -TYPE(TFILEDATA), INTENT(IN) :: TPFILE -TYPE(TFIELDDATA), INTENT(INOUT) :: TPFIELD -REAL,DIMENSION(:,:,:,:,:,:),TARGET,INTENT(INOUT) :: PFIELD ! array containing the data field -INTEGER, OPTIONAL, INTENT(OUT) :: KRESP ! return-code -! -INTEGER :: IERR -REAL,DIMENSION(:,:,:,:,:,:),POINTER :: ZFIELDP -LOGICAL :: GALLOC -INTEGER :: IRESP -INTEGER :: IHEXTOT -! -CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYFIELD_X6',TRIM(TPFILE%CNAME)//': reading '//TRIM(TPFIELD%CMNHNAME)) -! -GALLOC = .FALSE. -IRESP = 0 -ZFIELDP => NULL() -! -IHEXTOT = 2*JPHEXT+1 -CALL IO_FILE_READ_CHECK(TPFILE,'IO_READ_FIELD_BYFIELD_X6',IRESP) -! -IF (IRESP==0) THEN - IF (GSMONOPROC) THEN ! sequential execution - IF (TPFILE%CFORMAT=='NETCDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,PFIELD,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFI') THEN - CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,PFIELD,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,PFIELD,IRESP) - END IF - ELSE - IF (ISP == TPFILE%NMASTER_RANK) THEN - ! I/O process case - CALL ALLOCBUFFER_ll(ZFIELDP,PFIELD,TPFIELD%CDIR,GALLOC) - IF (TPFILE%CFORMAT=='NETCDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFI') THEN - CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) - END IF - ELSE - !Not really necessary but useful to suppress alerts with Valgrind - ALLOCATE(ZFIELDP(0,0,0,0,0,0)) - GALLOC = .TRUE. - END IF - ! - CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - ! - !Broadcast header only if IRESP==-111 - !because metadata of field has been modified in IO_READ_FIELD_xxx - IF (IRESP==-111) CALL IO_BCAST_FIELD_METADATA(TPFILE,TPFIELD) - ! - IF (TPFIELD%CDIR == 'XX' .OR. TPFIELD%CDIR == 'YY') THEN - ! XX or YY Scatter Field - CALL SCATTER_XXFIELD(TPFIELD%CDIR,ZFIELDP,PFIELD,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) - ELSE IF (TPFIELD%CDIR == 'XY') THEN - ! XY Scatter Field - CALL SCATTER_XYFIELD(ZFIELDP,PFIELD,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) - ELSE - CALL MPI_BCAST(PFIELD,SIZE(PFIELD),MPI_FLOAT,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - END IF - END IF -END IF -! -IF (GALLOC) DEALLOCATE (ZFIELDP) -! -IF (IRESP==-111) IRESP = 0 !-111 is not really an error (metadata has changed) -! -IF (PRESENT(KRESP)) KRESP = IRESP -! -END SUBROUTINE IO_READ_FIELD_BYFIELD_X6 - - -SUBROUTINE IO_READ_FIELD_BYNAME_N0(TPFILE,HNAME,KFIELD,KRESP) -! -TYPE(TFILEDATA), INTENT(IN) :: TPFILE -CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write -INTEGER, INTENT(INOUT) :: KFIELD ! array containing the data field -INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code -! -INTEGER :: ID ! Index of the field -INTEGER :: IRESP ! return_code -! -CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYNAME_N0',TRIM(TPFILE%CNAME)//': reading '//TRIM(HNAME)) -! -CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) -! -IF(IRESP==0) CALL IO_READ_FIELD(TPFILE,TFIELDLIST(ID),KFIELD,IRESP) -! -IF (PRESENT(KRESP)) KRESP = IRESP -! -END SUBROUTINE IO_READ_FIELD_BYNAME_N0 - -SUBROUTINE IO_READ_FIELD_BYFIELD_N0(TPFILE,TPFIELD,KFIELD,KRESP) -! -USE MODD_IO_ll, ONLY : ISP,GSMONOPROC -! -TYPE(TFILEDATA), INTENT(IN) :: TPFILE -TYPE(TFIELDDATA), INTENT(INOUT) :: TPFIELD -INTEGER, INTENT(INOUT) :: KFIELD ! array containing the data field -INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code -! -INTEGER :: IERR -INTEGER :: IRESP -! -CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYFIELD_N0',TRIM(TPFILE%CNAME)//': reading '//TRIM(TPFIELD%CMNHNAME)) -! -IRESP = 0 -! -CALL IO_FILE_READ_CHECK(TPFILE,'IO_READ_FIELD_BYFIELD_N0',IRESP) -! -IF (IRESP==0) THEN - IF (GSMONOPROC) THEN ! sequential execution - IF (TPFILE%CFORMAT=='NETCDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,KFIELD,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFI') THEN - CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,KFIELD,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,KFIELD,IRESP) - END IF - ELSE - IF (ISP == TPFILE%NMASTER_RANK) THEN - IF (TPFILE%CFORMAT=='NETCDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,KFIELD,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFI') THEN - CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,KFIELD,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,KFIELD,IRESP) - END IF - END IF - ! - CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - ! - !Broadcast header only if IRESP==-111 - !because metadata of field has been modified in IO_READ_FIELD_xxx - IF (IRESP==-111) CALL IO_BCAST_FIELD_METADATA(TPFILE,TPFIELD) - ! - CALL MPI_BCAST(KFIELD,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - END IF -END IF -! -IF (IRESP==-111) IRESP = 0 !-111 is not really an error (metadata has changed) -! -IF (PRESENT(KRESP)) KRESP = IRESP -! -END SUBROUTINE IO_READ_FIELD_BYFIELD_N0 - - -SUBROUTINE IO_READ_FIELD_BYNAME_N1(TPFILE,HNAME,KFIELD,KRESP) -! -TYPE(TFILEDATA), INTENT(IN) :: TPFILE -CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write -INTEGER,DIMENSION(:),INTENT(INOUT) :: KFIELD ! array containing the data field -INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code -! -INTEGER :: ID ! Index of the field -INTEGER :: IRESP ! return_code -! -CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYNAME_N1',TRIM(TPFILE%CNAME)//': reading '//TRIM(HNAME)) -! -CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) -! -IF(IRESP==0) CALL IO_READ_FIELD(TPFILE,TFIELDLIST(ID),KFIELD,IRESP) -! -IF (PRESENT(KRESP)) KRESP = IRESP -! -END SUBROUTINE IO_READ_FIELD_BYNAME_N1 - -SUBROUTINE IO_READ_FIELD_BYFIELD_N1(TPFILE,TPFIELD,KFIELD,KRESP) -! -USE MODD_IO_ll, ONLY : ISP,GSMONOPROC -! -USE MODE_ALLOCBUFFER_ll -USE MODE_SCATTER_ll -! -TYPE(TFILEDATA), INTENT(IN) :: TPFILE -TYPE(TFIELDDATA), INTENT(INOUT) :: TPFIELD -INTEGER,DIMENSION(:),INTENT(INOUT) :: KFIELD ! array containing the data field -INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code -! -INTEGER :: IERR -INTEGER :: IRESP -INTEGER,DIMENSION(:),POINTER :: IFIELDP -LOGICAL :: GALLOC -! -CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYFIELD_N1',TRIM(TPFILE%CNAME)//': reading '//TRIM(TPFIELD%CMNHNAME)) -! -GALLOC = .FALSE. -IRESP = 0 -IFIELDP => NULL() -! -CALL IO_FILE_READ_CHECK(TPFILE,'IO_READ_FIELD_BYFIELD_N1',IRESP) -! -IF (IRESP==0) THEN - IF (GSMONOPROC) THEN ! sequential execution - IF (TPFILE%CFORMAT=='NETCDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,KFIELD,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFI') THEN - CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,KFIELD,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,KFIELD,IRESP) - END IF - ELSE - IF (ISP == TPFILE%NMASTER_RANK) THEN - CALL ALLOCBUFFER_ll(IFIELDP,KFIELD,TPFIELD%CDIR,GALLOC) - IF (TPFILE%CFORMAT=='NETCDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,IFIELDP,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFI') THEN - CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,IFIELDP,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,IFIELDP,IRESP) - END IF - ELSE - !Not really necessary but useful to suppress alerts with Valgrind - ALLOCATE(IFIELDP(0)) - GALLOC = .TRUE. - END IF - ! - CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - ! - !Broadcast header only if IRESP==-111 - !because metadata of field has been modified in IO_READ_FIELD_xxx - IF (IRESP==-111) CALL IO_BCAST_FIELD_METADATA(TPFILE,TPFIELD) - ! - IF (TPFIELD%CDIR /= 'XX' .AND. TPFIELD%CDIR /='YY') THEN - ! Broadcast Field - CALL MPI_BCAST(KFIELD,SIZE(KFIELD),MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - ELSE - !Scatter Field - CALL SCATTER_XXFIELD(TPFIELD%CDIR,IFIELDP,KFIELD,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) - END IF - END IF -END IF -! -IF (GALLOC) DEALLOCATE (IFIELDP) -! -IF (IRESP==-111) IRESP = 0 !-111 is not really an error (metadata has changed) -! -IF (PRESENT(KRESP)) KRESP = IRESP -! -END SUBROUTINE IO_READ_FIELD_BYFIELD_N1 - - -SUBROUTINE IO_READ_FIELD_BYNAME_N2(TPFILE,HNAME,KFIELD,KRESP) -! -USE MODD_IO_ll, ONLY : ISNPROC -USE MODD_STRUCTURE_ll, ONLY : ZONE_ll -! -! -TYPE(TFILEDATA), INTENT(IN) :: TPFILE -CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write -INTEGER,DIMENSION(:,:),INTENT(INOUT) :: KFIELD ! array containing the data field -INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code -! -INTEGER :: ID ! Index of the field -INTEGER :: IRESP ! return_code -! -CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYNAME_N2',TRIM(TPFILE%CNAME)//': reading '//TRIM(HNAME)) -! -CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) -! -IF(IRESP==0) CALL IO_READ_FIELD(TPFILE,TFIELDLIST(ID),KFIELD,IRESP) -! -IF (PRESENT(KRESP)) KRESP = IRESP -! -END SUBROUTINE IO_READ_FIELD_BYNAME_N2 - -SUBROUTINE IO_READ_FIELD_BYFIELD_N2(TPFILE,TPFIELD,KFIELD,KRESP) -! -USE MODD_IO_ll, ONLY : GSMONOPROC,ISP,ISNPROC,LPACK,L1D,L2D -USE MODD_STRUCTURE_ll, ONLY : ZONE_ll -USE MODD_TIMEZ, ONLY : TIMEZ -! -USE MODE_ALLOCBUFFER_ll -USE MODE_SCATTER_ll -! -TYPE(TFILEDATA), INTENT(IN) :: TPFILE -TYPE(TFIELDDATA), INTENT(INOUT) :: TPFIELD -INTEGER,DIMENSION(:,:),TARGET,INTENT(INOUT) :: KFIELD ! array containing the data field -INTEGER, OPTIONAL, INTENT(OUT) :: KRESP ! return-code -! -INTEGER :: IERR -INTEGER,DIMENSION(:,:),POINTER :: IFIELDP -LOGICAL :: GALLOC -INTEGER :: IRESP -INTEGER :: IHEXTOT -! -CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYFIELD_N2',TRIM(TPFILE%CNAME)//': reading '//TRIM(TPFIELD%CMNHNAME)) -! -GALLOC = .FALSE. -IRESP = 0 -IFIELDP => NULL() -! -IHEXTOT = 2*JPHEXT+1 -CALL IO_FILE_READ_CHECK(TPFILE,'IO_READ_FIELD_BYFIELD_N2',IRESP) -! -IF (IRESP==0) THEN - IF (GSMONOPROC) THEN ! sequential execution - IF (LPACK .AND. L1D .AND. SIZE(KFIELD,1)==IHEXTOT .AND. SIZE(KFIELD,2)==IHEXTOT) THEN - IFIELDP=>KFIELD(JPHEXT+1:JPHEXT+1,JPHEXT+1:JPHEXT+1) - ELSE IF (LPACK .AND. L2D .AND. SIZE(KFIELD,2)==IHEXTOT) THEN - IFIELDP=>KFIELD(:,JPHEXT+1:JPHEXT+1) - ELSE - IFIELDP=>KFIELD(:,:) - END IF - IF (TPFILE%CFORMAT=='NETCDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,IFIELDP,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFI') THEN - CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,IFIELDP,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,IFIELDP,IRESP) - END IF - IF (LPACK .AND. L1D .AND. SIZE(KFIELD,1)==IHEXTOT .AND. SIZE(KFIELD,2)==IHEXTOT) THEN - KFIELD(:,:)=SPREAD(SPREAD(KFIELD(JPHEXT+1,JPHEXT+1),DIM=1,NCOPIES=IHEXTOT),DIM=2,NCOPIES=IHEXTOT) - ELSE IF (LPACK .AND. L2D .AND. SIZE(KFIELD,2)==IHEXTOT) THEN - KFIELD(:,:)=SPREAD(KFIELD(:,JPHEXT+1),DIM=2,NCOPIES=IHEXTOT) - END IF - ELSE - IF (ISP == TPFILE%NMASTER_RANK) THEN - ! I/O process case - CALL ALLOCBUFFER_ll(IFIELDP,KFIELD,TPFIELD%CDIR,GALLOC) - IF (TPFILE%CFORMAT=='NETCDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,IFIELDP,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFI') THEN - CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,IFIELDP,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,IFIELDP,IRESP) - END IF - ELSE - !Not really necessary but useful to suppress alerts with Valgrind - ALLOCATE(IFIELDP(0,0)) - GALLOC = .TRUE. - END IF - ! - CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - ! - !Broadcast header only if IRESP==-111 - !because metadata of field has been modified in IO_READ_FIELD_xxx - IF (IRESP==-111) CALL IO_BCAST_FIELD_METADATA(TPFILE,TPFIELD) - ! - IF (TPFIELD%CDIR == 'XX' .OR. TPFIELD%CDIR == 'YY') THEN - ! XX or YY Scatter Field - CALL SCATTER_XXFIELD(TPFIELD%CDIR,IFIELDP,KFIELD,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) - ! Broadcast Field - CALL MPI_BCAST(KFIELD,SIZE(KFIELD),MPI_FLOAT,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - ELSE IF (TPFIELD%CDIR == 'XY') THEN - IF (LPACK .AND. L2D) THEN - ! 2D compact case - CALL SCATTER_XXFIELD('XX',IFIELDP(:,1),KFIELD(:,JPHEXT+1),TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) - KFIELD(:,:) = SPREAD(KFIELD(:,JPHEXT+1),DIM=2,NCOPIES=IHEXTOT) - ELSE - ! XY Scatter Field - CALL SCATTER_XYFIELD(IFIELDP,KFIELD,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) - END IF - ELSE - IF (ISP == TPFILE%NMASTER_RANK) KFIELD = IFIELDP - CALL MPI_BCAST(KFIELD,SIZE(KFIELD),MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - END IF - END IF -END IF -! -IF (GALLOC) DEALLOCATE (IFIELDP) -! -IF (IRESP==-111) IRESP = 0 !-111 is not really an error (metadata has changed) -! -IF (PRESENT(KRESP)) KRESP = IRESP -! -END SUBROUTINE IO_READ_FIELD_BYFIELD_N2 - - -SUBROUTINE IO_READ_FIELD_BYNAME_L0(TPFILE,HNAME,OFIELD,KRESP) -! -TYPE(TFILEDATA), INTENT(IN) :: TPFILE -CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write -LOGICAL, INTENT(INOUT) :: OFIELD ! array containing the data field -INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code -! -INTEGER :: ID ! Index of the field -INTEGER :: IRESP ! return_code -! -CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYNAME_L0',TRIM(TPFILE%CNAME)//': reading '//TRIM(HNAME)) -! -CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) -! -IF(IRESP==0) CALL IO_READ_FIELD(TPFILE,TFIELDLIST(ID),OFIELD,IRESP) -! -IF (PRESENT(KRESP)) KRESP = IRESP -! -END SUBROUTINE IO_READ_FIELD_BYNAME_L0 - -SUBROUTINE IO_READ_FIELD_BYFIELD_L0(TPFILE,TPFIELD,OFIELD,KRESP) -! -USE MODD_IO_ll, ONLY : ISP,GSMONOPROC -! -TYPE(TFILEDATA), INTENT(IN) :: TPFILE -TYPE(TFIELDDATA), INTENT(INOUT) :: TPFIELD -LOGICAL, INTENT(INOUT) :: OFIELD ! array containing the data field -INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code -! -INTEGER :: IERR -INTEGER :: IRESP -! -CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYFIELD_L0',TRIM(TPFILE%CNAME)//': reading '//TRIM(TPFIELD%CMNHNAME)) -! -IRESP = 0 -! -CALL IO_FILE_READ_CHECK(TPFILE,'IO_READ_FIELD_BYFIELD_L0',IRESP) -! -IF (IRESP==0) THEN - IF (GSMONOPROC) THEN ! sequential execution - IF (TPFILE%CFORMAT=='NETCDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,OFIELD,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFI') THEN - CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,OFIELD,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,OFIELD,IRESP) - END IF - ELSE - IF (ISP == TPFILE%NMASTER_RANK) THEN - IF (TPFILE%CFORMAT=='NETCDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,OFIELD,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFI') THEN - CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,OFIELD,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,OFIELD,IRESP) - END IF - END IF - ! - CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - ! - !Broadcast header only if IRESP==-111 - !because metadata of field has been modified in IO_READ_FIELD_xxx - IF (IRESP==-111) CALL IO_BCAST_FIELD_METADATA(TPFILE,TPFIELD) - ! - CALL MPI_BCAST(OFIELD,1,MPI_LOGICAL,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - END IF -END IF -! -IF (IRESP==-111) IRESP = 0 !-111 is not really an error (metadata has changed) -! -IF (PRESENT(KRESP)) KRESP = IRESP -! -END SUBROUTINE IO_READ_FIELD_BYFIELD_L0 - - -SUBROUTINE IO_READ_FIELD_BYNAME_L1(TPFILE,HNAME,OFIELD,KRESP) -! -TYPE(TFILEDATA), INTENT(IN) :: TPFILE -CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write -LOGICAL,DIMENSION(:),INTENT(INOUT) :: OFIELD ! array containing the data field -INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code -! -INTEGER :: ID ! Index of the field -INTEGER :: IRESP ! return_code -! -CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYNAME_L1',TRIM(TPFILE%CNAME)//': reading '//TRIM(HNAME)) -! -CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) -! -IF(IRESP==0) CALL IO_READ_FIELD(TPFILE,TFIELDLIST(ID),OFIELD,IRESP) -! -IF (PRESENT(KRESP)) KRESP = IRESP -! -END SUBROUTINE IO_READ_FIELD_BYNAME_L1 - -SUBROUTINE IO_READ_FIELD_BYFIELD_L1(TPFILE,TPFIELD,OFIELD,KRESP) -! -USE MODD_IO_ll, ONLY : ISP,GSMONOPROC -! -TYPE(TFILEDATA), INTENT(IN) :: TPFILE -TYPE(TFIELDDATA), INTENT(INOUT) :: TPFIELD -LOGICAL,DIMENSION(:),INTENT(INOUT) :: OFIELD ! array containing the data field -INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code -! -INTEGER :: IERR -INTEGER :: IRESP -! -CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYFIELD_L1',TRIM(TPFILE%CNAME)//': reading '//TRIM(TPFIELD%CMNHNAME)) -! -IRESP = 0 -! -CALL IO_FILE_READ_CHECK(TPFILE,'IO_READ_FIELD_BYFIELD_L1',IRESP) -! -IF (IRESP==0) THEN - IF (GSMONOPROC) THEN ! sequential execution - IF (TPFILE%CFORMAT=='NETCDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,OFIELD,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFI') THEN - CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,OFIELD,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,OFIELD,IRESP) - END IF - ELSE - IF (ISP == TPFILE%NMASTER_RANK) THEN - IF (TPFILE%CFORMAT=='NETCDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,OFIELD,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFI') THEN - CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,OFIELD,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,OFIELD,IRESP) - END IF - END IF - ! - CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - ! - !Broadcast header only if IRESP==-111 - !because metadata of field has been modified in IO_READ_FIELD_xxx - IF (IRESP==-111) CALL IO_BCAST_FIELD_METADATA(TPFILE,TPFIELD) - ! - CALL MPI_BCAST(OFIELD,SIZE(OFIELD),MPI_LOGICAL,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - END IF -END IF -! -IF (IRESP==-111) IRESP = 0 !-111 is not really an error (metadata has changed) -! -IF (PRESENT(KRESP)) KRESP = IRESP -! -END SUBROUTINE IO_READ_FIELD_BYFIELD_L1 - - -SUBROUTINE IO_READ_FIELD_BYNAME_C0(TPFILE,HNAME,HFIELD,KRESP) -! -TYPE(TFILEDATA), INTENT(IN) :: TPFILE -CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write -CHARACTER(LEN=*), INTENT(INOUT) :: HFIELD ! array containing the data field -INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code -! -INTEGER :: ID ! Index of the field -INTEGER :: IRESP ! return_code -! -CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYNAME_C0',TRIM(TPFILE%CNAME)//': reading '//TRIM(HNAME)) -! -CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) -! -IF(IRESP==0) CALL IO_READ_FIELD(TPFILE,TFIELDLIST(ID),HFIELD,IRESP) -! -IF (PRESENT(KRESP)) KRESP = IRESP -! -END SUBROUTINE IO_READ_FIELD_BYNAME_C0 - -SUBROUTINE IO_READ_FIELD_BYFIELD_C0(TPFILE,TPFIELD,HFIELD,KRESP) -! -USE MODD_IO_ll, ONLY : ISP,GSMONOPROC -! -TYPE(TFILEDATA), INTENT(IN) :: TPFILE -TYPE(TFIELDDATA), INTENT(INOUT) :: TPFIELD -CHARACTER(LEN=*), INTENT(INOUT) :: HFIELD ! array containing the data field -INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code -! -INTEGER :: IERR -INTEGER :: IRESP -! -CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYFIELD_C0',TRIM(TPFILE%CNAME)//': reading '//TRIM(TPFIELD%CMNHNAME)) -! -IRESP = 0 -! -CALL IO_FILE_READ_CHECK(TPFILE,'IO_READ_FIELD_BYFIELD_C0',IRESP) -! -IF (IRESP==0) THEN - IF (GSMONOPROC) THEN ! sequential execution - IF (TPFILE%CFORMAT=='NETCDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,HFIELD,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFI') THEN - CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,HFIELD,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,HFIELD,IRESP) - END IF - ELSE - IF (ISP == TPFILE%NMASTER_RANK) THEN - IF (TPFILE%CFORMAT=='NETCDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,HFIELD,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFI') THEN - CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,HFIELD,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,HFIELD,IRESP) - END IF - END IF - ! - CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - ! - !Broadcast header only if IRESP==-111 - !because metadata of field has been modified in IO_READ_FIELD_xxx - IF (IRESP==-111) CALL IO_BCAST_FIELD_METADATA(TPFILE,TPFIELD) - ! - CALL MPI_BCAST(HFIELD,LEN(HFIELD),MPI_CHARACTER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - END IF -END IF -! -IF (IRESP==-111) IRESP = 0 !-111 is not really an error (metadata has changed) -! -IF (PRESENT(KRESP)) KRESP = IRESP -! -END SUBROUTINE IO_READ_FIELD_BYFIELD_C0 - - -SUBROUTINE IO_READ_FIELD_BYNAME_T0(TPFILE,HNAME,TPDATA,KRESP) -! -TYPE(TFILEDATA), INTENT(IN) :: TPFILE -CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write -TYPE (DATE_TIME), INTENT(INOUT) :: TPDATA ! array containing the data field -INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code -! -INTEGER :: ID ! Index of the field -INTEGER :: IRESP ! return_code -! -CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYNAME_T0',TRIM(TPFILE%CNAME)//': reading '//TRIM(HNAME)) -! -CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) -! -IF(IRESP==0) CALL IO_READ_FIELD(TPFILE,TFIELDLIST(ID),TPDATA,IRESP) -! -IF (PRESENT(KRESP)) KRESP = IRESP -! -END SUBROUTINE IO_READ_FIELD_BYNAME_T0 - -SUBROUTINE IO_READ_FIELD_BYFIELD_T0(TPFILE,TPFIELD,TPDATA,KRESP) -! -USE MODD_IO_ll, ONLY : ISP,GSMONOPROC -! -TYPE(TFILEDATA), INTENT(IN) :: TPFILE -TYPE(TFIELDDATA), INTENT(INOUT) :: TPFIELD -TYPE (DATE_TIME), INTENT(INOUT) :: TPDATA ! array containing the data field -INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code -! -INTEGER :: IERR -INTEGER :: IRESP -INTEGER,DIMENSION(3) :: ITDATE -! -CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYFIELD_T0',TRIM(TPFILE%CNAME)//': reading '//TRIM(TPFIELD%CMNHNAME)) -! -IRESP = 0 -! -CALL IO_FILE_READ_CHECK(TPFILE,'IO_READ_FIELD_BYFIELD_T0',IRESP) -! -IF (IRESP==0) THEN - IF (GSMONOPROC) THEN ! sequential execution - IF (TPFILE%CFORMAT=='NETCDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,TPDATA,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFI') THEN - CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,TPDATA,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,TPDATA,IRESP) - END IF - ELSE - IF (ISP == TPFILE%NMASTER_RANK) THEN - IF (TPFILE%CFORMAT=='NETCDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,TPDATA,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFI') THEN - CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,TPDATA,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,TPDATA,IRESP) - END IF - ITDATE(1) = TPDATA%TDATE%YEAR - ITDATE(2) = TPDATA%TDATE%MONTH - ITDATE(3) = TPDATA%TDATE%DAY - END IF - ! - CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - ! - !Broadcast header only if IRESP==-111 - !because metadata of field has been modified in IO_READ_FIELD_xxx - IF (IRESP==-111) CALL IO_BCAST_FIELD_METADATA(TPFILE,TPFIELD) - ! - CALL MPI_BCAST(ITDATE, 3,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - CALL MPI_BCAST(TPDATA%TIME,1,MPI_FLOAT, TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - TPDATA%TDATE%YEAR = ITDATE(1) - TPDATA%TDATE%MONTH = ITDATE(2) - TPDATA%TDATE%DAY = ITDATE(3) - END IF -END IF -! -IF (IRESP==-111) IRESP = 0 !-111 is not really an error (metadata has changed) -! -IF (PRESENT(KRESP)) KRESP = IRESP -! -END SUBROUTINE IO_READ_FIELD_BYFIELD_T0 - - -SUBROUTINE IO_READ_FIELD_BYNAME_LB(TPFILE,HNAME,KL3D,KRIM,PLB,KRESP) -! -TYPE(TFILEDATA), INTENT(IN) :: TPFILE -CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write -INTEGER, INTENT(IN) :: KL3D ! size of the LB array in FM -INTEGER, INTENT(IN) :: KRIM ! size of the LB area -REAL, DIMENSION(:,:,:),TARGET, INTENT(INOUT) :: PLB ! array containing the LB field -INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code - -INTEGER :: ID ! Index of the field -INTEGER :: IRESP ! return_code -! -CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYNAME_LB',TRIM(TPFILE%CNAME)//': reading '//TRIM(HNAME)) -! -CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) -! -IF(IRESP==0) CALL IO_READ_FIELD_LB(TPFILE,TFIELDLIST(ID),KL3D,KRIM,PLB,IRESP) -! -IF (PRESENT(KRESP)) KRESP = IRESP -! -END SUBROUTINE IO_READ_FIELD_BYNAME_LB - -SUBROUTINE IO_READ_FIELD_BYFIELD_LB(TPFILE,TPFIELD,KL3D,KRIM,PLB,KRESP) -! -USE MODD_IO_ll, ONLY : ISP,ISNPROC,GSMONOPROC,LPACK,L2D -USE MODD_PARAMETERS_ll,ONLY : JPHEXT -USE MODD_TIMEZ, ONLY : TIMEZ -USE MODD_VAR_ll, ONLY : MNH_STATUSES_IGNORE -! -USE MODE_DISTRIB_LB -USE MODE_MNH_TIMING, ONLY : SECOND_MNH2 -USE MODE_TOOLS_ll, ONLY : GET_GLOBALDIMS_ll -! -TYPE(TFILEDATA), INTENT(IN) :: TPFILE -TYPE(TFIELDDATA), INTENT(INOUT) :: TPFIELD -INTEGER, INTENT(IN) :: KL3D ! size of the LB array in FM -INTEGER, INTENT(IN) :: KRIM ! size of the LB area -REAL, DIMENSION(:,:,:),TARGET, INTENT(INOUT) :: PLB ! array containing the LB field -INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code -! -!* 0.2 Declarations of local variables -! -TYPE TX_3DP - REAL,DIMENSION(:,:,:), POINTER :: X -END TYPE -! -CHARACTER(LEN=4) :: YLBTYPE ! 'LBX','LBXU','LBY' or 'LBYV' -INTEGER :: IERR,IRESP -INTEGER :: IHEXTOT -INTEGER :: IIMAX_ll,IJMAX_ll -INTEGER :: IIB,IIE,IJB,IJE -INTEGER :: JI -INTEGER :: NB_REQ,IKU -INTEGER, DIMENSION(MPI_STATUS_SIZE) :: STATUS -INTEGER, ALLOCATABLE,DIMENSION(:,:) :: STATUSES -INTEGER,ALLOCATABLE,DIMENSION(:) :: REQ_TAB -REAL,DIMENSION(:,:,:),ALLOCATABLE,TARGET :: Z3D -REAL,DIMENSION(:,:,:), POINTER :: TX3DP -REAL(KIND=8),DIMENSION(2) :: T0,T1,T2,T3 -REAL(KIND=8),DIMENSION(2) :: T11,T22 -TYPE(TX_3DP),ALLOCATABLE,DIMENSION(:) :: T_TX3DP -! -CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYFIELD_LB','reading '//TRIM(TPFIELD%CMNHNAME)) -! -YLBTYPE = TPFIELD%CLBTYPE -! -IF (YLBTYPE/='LBX' .AND. YLBTYPE/='LBXU' .AND. YLBTYPE/='LBY' .AND. YLBTYPE/='LBYV') THEN - CALL PRINT_MSG(NVERB_ERROR,'IO','IO_READ_FIELD_BYFIELD_LB',TRIM(TPFILE%CNAME)//': invalid CLBTYPE (' & - //TRIM(TPFIELD%CLBTYPE)//') for '//TRIM(TPFIELD%CMNHNAME)) - RETURN -END IF -! -!* 1.1 THE NAME OF LFIFM -! -CALL SECOND_MNH2(T11) -IRESP = 0 -!------------------------------------------------------------------ -IHEXTOT = 2*JPHEXT+1 -CALL IO_FILE_READ_CHECK(TPFILE,'IO_READ_FIELD_BYFIELD_LB',IRESP) -! -IF (IRESP==0) THEN - IF (GSMONOPROC) THEN ! sequential execution - IF (YLBTYPE == 'LBX' .OR. YLBTYPE == 'LBXU') THEN - ALLOCATE(Z3D(KL3D,SIZE(PLB,2),SIZE(PLB,3))) - Z3D = 0.0 - IF (LPACK .AND. L2D) THEN - TX3DP=>Z3D(:,JPHEXT+1:JPHEXT+1,:) - ELSE - TX3DP => Z3D(:,:,:) - END IF - ELSE !(YLBTYPE == 'LBY' .OR. YLBTYPE == 'LBYV') - ALLOCATE(Z3D(SIZE(PLB,1),KL3D,SIZE(PLB,3))) - Z3D = 0.0 - TX3DP => Z3D(:,:,:) - END IF - IF (TPFILE%CFORMAT=='NETCDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,TX3DP,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFI') THEN - CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,TX3DP,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,TX3DP,IRESP) - END IF - IF (YLBTYPE == 'LBX' .OR. YLBTYPE == 'LBXU') THEN - IF (LPACK .AND. L2D) Z3D(:,:,:) = SPREAD(Z3D(:,JPHEXT+1,:),DIM=2,NCOPIES=IHEXTOT) - PLB(1:KRIM+JPHEXT,:,:) = Z3D(1:KRIM+JPHEXT,:,:) - PLB(KRIM+JPHEXT+1:2*(KRIM+JPHEXT),:,:) = Z3D(KL3D-KRIM-JPHEXT+1:KL3D,:,:) - ELSE !(YLBTYPE == 'LBY' .OR. YLBTYPE == 'LBYV') - PLB(:,1:KRIM+JPHEXT,:) = Z3D(:,1:KRIM+JPHEXT,:) - PLB(:,KRIM+JPHEXT+1:2*(KRIM+JPHEXT),:) = Z3D(:,KL3D-KRIM-JPHEXT+1:KL3D,:) - END IF - ELSE ! multiprocesses execution - IF (ISP == TPFILE%NMASTER_RANK) THEN - CALL SECOND_MNH2(T0) - CALL GET_GLOBALDIMS_ll(IIMAX_ll,IJMAX_ll) - IF (YLBTYPE == 'LBX' .OR. YLBTYPE == 'LBXU') THEN - ALLOCATE(Z3D(KL3D,IJMAX_ll+2*JPHEXT,SIZE(PLB,3))) - Z3D = 0.0 - IF (LPACK .AND. L2D) THEN - TX3DP=>Z3D(:,JPHEXT+1:JPHEXT+1,:) - ELSE - TX3DP => Z3D(:,:,:) - END IF - ELSE !(YLBTYPE == 'LBY' .OR. YLBTYPE == 'LBYV') - ALLOCATE(Z3D(IIMAX_ll+2*JPHEXT,KL3D,SIZE(PLB,3))) - Z3D = 0.0 - TX3DP => Z3D(:,:,:) - END IF - IF (TPFILE%CFORMAT=='NETCDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,TX3DP,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFI') THEN - CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,TX3DP,IRESP) - ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN - CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,TX3DP,IRESP) - END IF - IF (YLBTYPE == 'LBX' .OR. YLBTYPE == 'LBXU') THEN - IF (LPACK .AND. L2D) Z3D(:,:,:) = SPREAD(Z3D(:,JPHEXT+1,:),DIM=2,NCOPIES=IHEXTOT) - ! erase gap in LB field - Z3D(KRIM+JPHEXT+1:2*(KRIM+JPHEXT),:,:) = Z3D(KL3D-KRIM-JPHEXT+1:KL3D,:,:) - ELSE !(YLBTYPE == 'LBY' .OR. YLBTYPE == 'LBYV') - ! erase gap in LB field - Z3D(:,KRIM+JPHEXT+1:2*(KRIM+JPHEXT),:) = Z3D(:,KL3D-KRIM-JPHEXT+1:KL3D,:) - END IF - CALL SECOND_MNH2(T1) - TIMEZ%T_READLB_READ=TIMEZ%T_READLB_READ + T1 - T0 - END IF - ! - CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - ! - !Broadcast header only if IRESP==-111 - !because metadata of field has been modified in IO_READ_FIELD_xxx - IF (IRESP==-111) CALL IO_BCAST_FIELD_METADATA(TPFILE,TPFIELD) - ! - NB_REQ=0 - ALLOCATE(REQ_TAB(ISNPROC-1)) - !REQ_TAB=MPI_REQUEST_NULL - IF (ISP == TPFILE%NMASTER_RANK) THEN - CALL SECOND_MNH2(T1) - !ALLOCATE(REQ_TAB(ISNPROC-1)) - !REQ_TAB=MPI_REQUEST_NULL - ALLOCATE(T_TX3DP(ISNPROC-1)) - IKU = SIZE(Z3D,3) - DO JI = 1,ISNPROC - CALL GET_DISTRIB_LB(YLBTYPE,JI,'FM','READ',KRIM,IIB,IIE,IJB,IJE) - IF (IIB /= 0) THEN - TX3DP=>Z3D(IIB:IIE,IJB:IJE,:) - IF (ISP /= JI) THEN - NB_REQ = NB_REQ + 1 - ALLOCATE(T_TX3DP(NB_REQ)%X(IIB:IIE,IJB:IJE,IKU)) - T_TX3DP(NB_REQ)%X=Z3D(IIB:IIE,IJB:IJE,:) - CALL MPI_ISEND(T_TX3DP(NB_REQ)%X,SIZE(TX3DP),MPI_FLOAT,JI-1,99,TPFILE%NMPICOMM,REQ_TAB(NB_REQ),IERR) - !CALL MPI_BSEND(T_TX3DP(NB_REQ)%X,SIZE(TX3DP),MPI_FLOAT,JI-1,99,TPFILE%NMPICOMM,IERR) - ELSE - CALL GET_DISTRIB_LB(YLBTYPE,JI,'LOC','READ',KRIM,IIB,IIE,IJB,IJE) - PLB(IIB:IIE,IJB:IJE,:) = TX3DP(:,:,:) - END IF - END IF - END DO - CALL SECOND_MNH2(T2) - TIMEZ%T_READLB_SEND=TIMEZ%T_READLB_SEND + T2 - T1 - IF (NB_REQ .GT.0 ) THEN - !ALLOCATE(STATUSES(MPI_STATUS_SIZE,NB_REQ)) - !CALL MPI_WAITALL(NB_REQ,REQ_TAB,STATUSES,IERR) - CALL MPI_WAITALL(NB_REQ,REQ_TAB,MNH_STATUSES_IGNORE,IERR) - !DEALLOCATE(STATUSES) - DO JI=1,NB_REQ ; DEALLOCATE(T_TX3DP(JI)%X) ; ENDDO - END IF - DEALLOCATE(T_TX3DP) - !DEALLOCATE(REQ_TAB) - CALL SECOND_MNH2(T3) - TIMEZ%T_READLB_WAIT=TIMEZ%T_READLB_WAIT + T3 - T2 - ELSE - CALL SECOND_MNH2(T0) - !ALLOCATE(REQ_TAB(1)) - !REQ_TAB=MPI_REQUEST_NULL - CALL GET_DISTRIB_LB(YLBTYPE,ISP,'LOC','READ',KRIM,IIB,IIE,IJB,IJE) - IF (IIB /= 0) THEN - TX3DP=>PLB(IIB:IIE,IJB:IJE,:) - CALL MPI_RECV(TX3DP,SIZE(TX3DP),MPI_FLOAT,TPFILE%NMASTER_RANK-1,99,TPFILE%NMPICOMM,STATUS,IERR) - !NB_REQ = NB_REQ + 1 - !CALL MPI_IRECV(TX3DP,SIZE(TX3DP),MPI_FLOAT,TPFILE%NMASTER_RANK-1,99,TPFILE%NMPICOMM,REQ_TAB(NB_REQ),IERR) - !IF (NB_REQ .GT.0 ) CALL MPI_WAITALL(NB_REQ,REQ_TAB,MNH_STATUSES_IGNORE,IERR) - END IF - CALL SECOND_MNH2(T1) - TIMEZ%T_READLB_RECV=TIMEZ%T_READLB_RECV + T1 - T0 - END IF - DEALLOCATE(REQ_TAB) - END IF !(GSMONOPROC) -END IF -!---------------------------------------------------------------- -! -IF (ALLOCATED(Z3D)) DEALLOCATE (Z3D) -! -IF (IRESP==-111) IRESP = 0 !-111 is not really an error (metadata has changed) -! -IF (PRESENT(KRESP)) KRESP = IRESP -! -CALL SECOND_MNH2(T22) -TIMEZ%T_READLB_ALL=TIMEZ%T_READLB_ALL + T22 - T11 -! -END SUBROUTINE IO_READ_FIELD_BYFIELD_LB - -END MODULE MODE_FMREAD +!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier +!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence +!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt +!MNH_LIC for details. version 1. +!----------------------------------------------------------------- +!--------------- special set of characters for CVS information +!----------------------------------------------------------------- +! $Source$ +! $Name$ +! $Revision$ +! $Date$ +!----------------------------------------------------------------- +!----------------------------------------------------------------- + +#ifdef MNH_MPI_DOUBLE_PRECISION +#define MPI_FLOAT MPI_DOUBLE_PRECISION +#else +#define MPI_FLOAT MPI_REAL +#endif + +MODULE MODE_FMREAD +! +!Correction : +! J.Escobar : 22/08/2005 : BUG : manque un "GOTO 1000" si champs +! lue non trouvé !!! +! J.Escobar : 13/01/2015 : remove comment on BCAST(IRESP in FMREADX2_ll +! J.Escobar : 15/09/2015 : WENO5 & JPHEXT <> 1 +! +USE MODD_IO_ll, ONLY : NVERB_FATAL,NVERB_ERROR,NVERB_WARNING,NVERB_INFO,NVERB_DEBUG,TFILEDATA +USE MODD_MPIF +! +USE MODE_FIELD +#if defined(MNH_IOCDF4) +USE MODE_NETCDF +#endif +USE MODE_MSG +USE MODE_READWRITE_LFI + +IMPLICIT NONE + +PRIVATE + +INTERFACE IO_READ_FIELD + MODULE PROCEDURE IO_READ_FIELD_BYNAME_X0, IO_READ_FIELD_BYNAME_X1, & + IO_READ_FIELD_BYNAME_X2, IO_READ_FIELD_BYNAME_X3, & + IO_READ_FIELD_BYNAME_X4, IO_READ_FIELD_BYNAME_X5, & + IO_READ_FIELD_BYNAME_X6, & + IO_READ_FIELD_BYNAME_N0, IO_READ_FIELD_BYNAME_N1, & + IO_READ_FIELD_BYNAME_N2, & + IO_READ_FIELD_BYNAME_L0, IO_READ_FIELD_BYNAME_L1, & + IO_READ_FIELD_BYNAME_C0, & + IO_READ_FIELD_BYNAME_T0, & + IO_READ_FIELD_BYFIELD_X0,IO_READ_FIELD_BYFIELD_X1, & + IO_READ_FIELD_BYFIELD_X2,IO_READ_FIELD_BYFIELD_X3, & + IO_READ_FIELD_BYFIELD_X4,IO_READ_FIELD_BYFIELD_X5, & + IO_READ_FIELD_BYFIELD_X6, & + IO_READ_FIELD_BYFIELD_N0,IO_READ_FIELD_BYFIELD_N1, & + IO_READ_FIELD_BYFIELD_N2, & + IO_READ_FIELD_BYFIELD_L0,IO_READ_FIELD_BYFIELD_L1, & + IO_READ_FIELD_BYFIELD_C0, & + IO_READ_FIELD_BYFIELD_T0 +END INTERFACE + +INTERFACE IO_READ_FIELD_LB + MODULE PROCEDURE IO_READ_FIELD_BYNAME_LB, IO_READ_FIELD_BYFIELD_LB +END INTERFACE + +PUBLIC IO_READ_FIELD,IO_READ_FIELD_LB + +CONTAINS + +SUBROUTINE IO_FILE_READ_CHECK(TPFILE,HSUBR,KRESP) +TYPE(TFILEDATA), INTENT(IN) :: TPFILE +CHARACTER(LEN=*), INTENT(IN) :: HSUBR +INTEGER, INTENT(OUT) :: KRESP +! +KRESP = 0 +! +!Check if file is opened +IF (.NOT.TPFILE%LOPENED) THEN + CALL PRINT_MSG(NVERB_ERROR,'IO',HSUBR,TRIM(TPFILE%CNAME)//' is not opened') + KRESP = -201 + RETURN +END IF +! +!Check if file is in the right opening mode +IF (TPFILE%CMODE/='READ') THEN + CALL PRINT_MSG(NVERB_WARNING,'IO',HSUBR,& + TRIM(TPFILE%CNAME)//': reading in a file opened in '//TRIM(TPFILE%CMODE)//' mode') +END IF +! +!Check fileformat +IF (TPFILE%CFORMAT/='NETCDF4' .AND. TPFILE%CFORMAT=='LFI' .AND. TPFILE%CFORMAT=='LFICDF4') THEN + CALL PRINT_MSG(NVERB_FATAL,'IO',HSUBR,& + TRIM(TPFILE%CNAME)//': invalid fileformat ('//TRIM(TPFILE%CFORMAT)//')') + KRESP = -202 + RETURN +END IF +! +END SUBROUTINE IO_FILE_READ_CHECK + + +SUBROUTINE IO_BCAST_FIELD_METADATA(TPFILE,TPFIELD) +TYPE(TFILEDATA), INTENT(IN) :: TPFILE +TYPE(TFIELDDATA), INTENT(INOUT) :: TPFIELD +! +INTEGER :: IERR +! +CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_BCAST_FIELD_METADATA','called for '//TRIM(TPFIELD%CMNHNAME)) +! +CALL MPI_BCAST(TPFIELD%CMNHNAME, LEN(TPFIELD%CMNHNAME), MPI_CHARACTER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) +CALL MPI_BCAST(TPFIELD%CSTDNAME, LEN(TPFIELD%CSTDNAME), MPI_CHARACTER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) +CALL MPI_BCAST(TPFIELD%CLONGNAME,LEN(TPFIELD%CLONGNAME),MPI_CHARACTER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) +CALL MPI_BCAST(TPFIELD%CUNITS, LEN(TPFIELD%CUNITS), MPI_CHARACTER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) +CALL MPI_BCAST(TPFIELD%CDIR, LEN(TPFIELD%CDIR), MPI_CHARACTER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) +CALL MPI_BCAST(TPFIELD%CLBTYPE, LEN(TPFIELD%CLBTYPE), MPI_CHARACTER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) +CALL MPI_BCAST(TPFIELD%CCOMMENT, LEN(TPFIELD%CCOMMENT), MPI_CHARACTER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) +CALL MPI_BCAST(TPFIELD%NGRID, 1, MPI_INTEGER, TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) +CALL MPI_BCAST(TPFIELD%NTYPE, 1, MPI_INTEGER, TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) +CALL MPI_BCAST(TPFIELD%NDIMS, 1, MPI_INTEGER, TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) +! +END SUBROUTINE IO_BCAST_FIELD_METADATA + + +SUBROUTINE IO_READ_FIELD_BYNAME_X0(TPFILE,HNAME,PFIELD,KRESP) +! +TYPE(TFILEDATA), INTENT(IN) :: TPFILE +CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write +REAL, INTENT(INOUT) :: PFIELD ! data field +INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code +! +INTEGER :: ID ! Index of the field +INTEGER :: IRESP ! return_code +! +CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYNAME_X0',TRIM(TPFILE%CNAME)//': reading '//TRIM(HNAME)) +! +CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) +! +IF(IRESP==0) CALL IO_READ_FIELD(TPFILE,TFIELDLIST(ID),PFIELD,IRESP) +! +IF (PRESENT(KRESP)) KRESP = IRESP +! +END SUBROUTINE IO_READ_FIELD_BYNAME_X0 + +SUBROUTINE IO_READ_FIELD_BYFIELD_X0(TPFILE,TPFIELD,PFIELD,KRESP) +! +USE MODD_IO_ll, ONLY : ISP,GSMONOPROC +! +TYPE(TFILEDATA), INTENT(IN) :: TPFILE +TYPE(TFIELDDATA), INTENT(INOUT) :: TPFIELD +REAL, INTENT(INOUT) :: PFIELD ! data field +INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code +! +INTEGER :: IERR +INTEGER :: IRESP +! +CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYFIELD_X0',TRIM(TPFILE%CNAME)//': reading '//TRIM(TPFIELD%CMNHNAME)) +! +IRESP = 0 +! +CALL IO_FILE_READ_CHECK(TPFILE,'IO_READ_FIELD_BYFIELD_X0',IRESP) +! +IF (IRESP==0) THEN + IF (GSMONOPROC) THEN ! sequential execution + IF (TPFILE%CFORMAT=='NETCDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,PFIELD,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFI') THEN + CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,PFIELD,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,PFIELD,IRESP) + END IF + ELSE + IF (ISP == TPFILE%NMASTER_RANK) THEN + IF (TPFILE%CFORMAT=='NETCDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,PFIELD,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFI') THEN + CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,PFIELD,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,PFIELD,IRESP) + END IF + END IF + ! + CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + ! + !Broadcast header only if IRESP==-111 + !because metadata of field has been modified in IO_READ_FIELD_xxx + IF (IRESP==-111) CALL IO_BCAST_FIELD_METADATA(TPFILE,TPFIELD) + ! + ! Broadcast Field + CALL MPI_BCAST(PFIELD,1,MPI_FLOAT,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + END IF +END IF +! +IF (IRESP==-111) IRESP = 0 !-111 is not really an error (metadata has changed) +! +IF (PRESENT(KRESP)) KRESP = IRESP +! +END SUBROUTINE IO_READ_FIELD_BYFIELD_X0 + + +SUBROUTINE IO_READ_FIELD_BYNAME_X1(TPFILE,HNAME,PFIELD,KRESP,KIMAX_ll,KJMAX_ll,TPSPLITTING) +! +USE MODD_IO_ll, ONLY : ISNPROC +USE MODD_STRUCTURE_ll, ONLY : ZONE_ll +! +TYPE(TFILEDATA), INTENT(IN) :: TPFILE +CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write +REAL,DIMENSION(:),INTENT(INOUT) :: PFIELD ! array containing the data field +INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code +INTEGER,OPTIONAL, INTENT(IN) :: KIMAX_ll +INTEGER,OPTIONAL, INTENT(IN) :: KJMAX_ll +TYPE(ZONE_ll),DIMENSION(ISNPROC),OPTIONAL,INTENT(IN) :: TPSPLITTING ! splitting of the domain +! +INTEGER :: ID ! Index of the field +INTEGER :: IRESP ! return_code +! +CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYNAME_X1',TRIM(TPFILE%CNAME)//': reading '//TRIM(HNAME)) +! +CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) +! +IF(IRESP==0) CALL IO_READ_FIELD(TPFILE,TFIELDLIST(ID),PFIELD,IRESP,KIMAX_ll,KJMAX_ll,TPSPLITTING) +! +IF (PRESENT(KRESP)) KRESP = IRESP +! +END SUBROUTINE IO_READ_FIELD_BYNAME_X1 + +SUBROUTINE IO_READ_FIELD_BYFIELD_X1(TPFILE,TPFIELD,PFIELD,KRESP,KIMAX_ll,KJMAX_ll,TPSPLITTING) +! +USE MODD_IO_ll, ONLY : ISP,GSMONOPROC,ISNPROC +USE MODD_STRUCTURE_ll, ONLY : ZONE_ll +! +USE MODE_SCATTER_ll +USE MODE_ALLOCBUFFER_ll +! +TYPE(TFILEDATA), INTENT(IN) :: TPFILE +TYPE(TFIELDDATA), INTENT(INOUT) :: TPFIELD +REAL,DIMENSION(:),INTENT(INOUT) :: PFIELD ! array containing the data field +INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code +INTEGER,OPTIONAL, INTENT(IN) :: KIMAX_ll +INTEGER,OPTIONAL, INTENT(IN) :: KJMAX_ll +TYPE(ZONE_ll),DIMENSION(ISNPROC),OPTIONAL,INTENT(IN) :: TPSPLITTING ! splitting of the domain +! +INTEGER :: IERR +REAL,DIMENSION(:),POINTER :: ZFIELDP +LOGICAL :: GALLOC +INTEGER :: IRESP +! +CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYFIELD_X1',TRIM(TPFILE%CNAME)//': reading '//TRIM(TPFIELD%CMNHNAME)) +! +GALLOC = .FALSE. +IRESP = 0 +ZFIELDP => NULL() +! +CALL IO_FILE_READ_CHECK(TPFILE,'IO_READ_FIELD_BYFIELD_X1',IRESP) +! +IF (IRESP==0) THEN + IF (GSMONOPROC) THEN ! sequential execution + IF (TPFILE%CFORMAT=='NETCDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,PFIELD,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFI') THEN + CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,PFIELD,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,PFIELD,IRESP) + END IF + ELSE + IF (ISP == TPFILE%NMASTER_RANK) THEN + CALL ALLOCBUFFER_ll(ZFIELDP,PFIELD,TPFIELD%CDIR,GALLOC, KIMAX_ll, KJMAX_ll) + IF (TPFILE%CFORMAT=='NETCDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFI') THEN + CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) + END IF + ELSE + !Not really necessary but useful to suppress alerts with Valgrind + ALLOCATE(ZFIELDP(0)) + GALLOC = .TRUE. + END IF + ! + CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + ! + !Broadcast header only if IRESP==-111 + !because metadata of field has been modified in IO_READ_FIELD_xxx + IF (IRESP==-111) CALL IO_BCAST_FIELD_METADATA(TPFILE,TPFIELD) + ! + IF (TPFIELD%CDIR /= 'XX' .AND. TPFIELD%CDIR /='YY') THEN + ! Broadcast Field + CALL MPI_BCAST(PFIELD,SIZE(PFIELD),MPI_FLOAT,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + ELSE + !Scatter Field + CALL SCATTER_XXFIELD(TPFIELD%CDIR,ZFIELDP,PFIELD,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM,TPSPLITTING) + END IF + END IF +END IF +! +IF (GALLOC) DEALLOCATE (ZFIELDP) +! +IF (IRESP==-111) IRESP = 0 !-111 is not really an error (metadata has changed) +! +IF (PRESENT(KRESP)) KRESP = IRESP +! +END SUBROUTINE IO_READ_FIELD_BYFIELD_X1 + + +SUBROUTINE IO_READ_FIELD_BYNAME_X2(TPFILE,HNAME,PFIELD,KRESP,KIMAX_ll,KJMAX_ll,TPSPLITTING) +! +USE MODD_IO_ll, ONLY : ISNPROC +USE MODD_STRUCTURE_ll, ONLY : ZONE_ll +! +! +TYPE(TFILEDATA), INTENT(IN) :: TPFILE +CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write +REAL,DIMENSION(:,:),INTENT(INOUT) :: PFIELD ! array containing the data field +INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code +INTEGER,OPTIONAL, INTENT(IN) :: KIMAX_ll +INTEGER,OPTIONAL, INTENT(IN) :: KJMAX_ll +TYPE(ZONE_ll),DIMENSION(ISNPROC),OPTIONAL,INTENT(IN) :: TPSPLITTING ! splitting of the domain +! +INTEGER :: ID ! Index of the field +INTEGER :: IRESP ! return_code +! +CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYNAME_X2',TRIM(TPFILE%CNAME)//': reading '//TRIM(HNAME)) +! +CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) +! +IF(IRESP==0) CALL IO_READ_FIELD(TPFILE,TFIELDLIST(ID),PFIELD,IRESP,KIMAX_ll,KJMAX_ll,TPSPLITTING) +! +IF (PRESENT(KRESP)) KRESP = IRESP +! +END SUBROUTINE IO_READ_FIELD_BYNAME_X2 + +SUBROUTINE IO_READ_FIELD_BYFIELD_X2(TPFILE,TPFIELD,PFIELD,KRESP,KIMAX_ll,KJMAX_ll,TPSPLITTING) +! +USE MODD_IO_ll, ONLY : GSMONOPROC,ISP,ISNPROC,LPACK,L1D,L2D +USE MODD_STRUCTURE_ll, ONLY : ZONE_ll +USE MODD_TIMEZ, ONLY : TIMEZ +! +USE MODE_ALLOCBUFFER_ll +#ifdef MNH_GA +USE MODE_GA +#endif +USE MODE_MNH_TIMING, ONLY : SECOND_MNH2 +USE MODE_SCATTER_ll +! +TYPE(TFILEDATA), INTENT(IN) :: TPFILE +TYPE(TFIELDDATA), INTENT(INOUT) :: TPFIELD +REAL,DIMENSION(:,:),TARGET,INTENT(INOUT) :: PFIELD ! array containing the data field +INTEGER, OPTIONAL, INTENT(OUT) :: KRESP ! return-code +INTEGER, OPTIONAL, INTENT(IN) :: KIMAX_ll +INTEGER, OPTIONAL, INTENT(IN) :: KJMAX_ll +TYPE(ZONE_ll),DIMENSION(ISNPROC),OPTIONAL,INTENT(IN) :: TPSPLITTING ! splitting of the domain +! +INTEGER :: IERR +REAL,DIMENSION(:,:),POINTER :: ZFIELDP +LOGICAL :: GALLOC +INTEGER :: IRESP +INTEGER :: IHEXTOT +REAL(KIND=8),DIMENSION(2) :: T0,T1,T2 +REAL(KIND=8),DIMENSION(2) :: T11,T22 +#ifdef MNH_GA +REAL,DIMENSION(:,:),POINTER :: ZFIELD_GA +#endif +! +CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYFIELD_X2',TRIM(TPFILE%CNAME)//': reading '//TRIM(TPFIELD%CMNHNAME)) +! +CALL SECOND_MNH2(T11) +GALLOC = .FALSE. +IRESP = 0 +ZFIELDP => NULL() +! +IHEXTOT = 2*JPHEXT+1 +CALL IO_FILE_READ_CHECK(TPFILE,'IO_READ_FIELD_BYFIELD_X2',IRESP) +! +IF (IRESP==0) THEN + IF (GSMONOPROC) THEN ! sequential execution + IF (LPACK .AND. L1D .AND. SIZE(PFIELD,1)==IHEXTOT .AND. SIZE(PFIELD,2)==IHEXTOT) THEN + ZFIELDP=>PFIELD(JPHEXT+1:JPHEXT+1,JPHEXT+1:JPHEXT+1) + ELSE IF (LPACK .AND. L2D .AND. SIZE(PFIELD,2)==IHEXTOT) THEN + ZFIELDP=>PFIELD(:,JPHEXT+1:JPHEXT+1) + ELSE + ZFIELDP=>PFIELD(:,:) + END IF + IF (TPFILE%CFORMAT=='NETCDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFI') THEN + CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) + END IF + IF (LPACK .AND. L1D .AND. SIZE(PFIELD,1)==IHEXTOT .AND. SIZE(PFIELD,2)==IHEXTOT) THEN + PFIELD(:,:)=SPREAD(SPREAD(PFIELD(JPHEXT+1,JPHEXT+1),DIM=1,NCOPIES=IHEXTOT),DIM=2,NCOPIES=IHEXTOT) + ELSE IF (LPACK .AND. L2D .AND. SIZE(PFIELD,2)==IHEXTOT) THEN + PFIELD(:,:)=SPREAD(PFIELD(:,JPHEXT+1),DIM=2,NCOPIES=IHEXTOT) + END IF + ELSE + CALL SECOND_MNH2(T0) + IF (ISP == TPFILE%NMASTER_RANK) THEN + ! I/O process case + CALL ALLOCBUFFER_ll(ZFIELDP,PFIELD,TPFIELD%CDIR,GALLOC, KIMAX_ll, KJMAX_ll) + IF (TPFILE%CFORMAT=='NETCDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFI') THEN + CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) + END IF + ELSE + !Not really necessary but useful to suppress alerts with Valgrind + ALLOCATE(ZFIELDP(0,0)) + GALLOC = .TRUE. + END IF + CALL SECOND_MNH2(T1) + TIMEZ%T_READ2D_READ=TIMEZ%T_READ2D_READ + T1 - T0 + ! + CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + ! + !Broadcast header only if IRESP==-111 + !because metadata of field has been modified in IO_READ_FIELD_xxx + IF (IRESP==-111) CALL IO_BCAST_FIELD_METADATA(TPFILE,TPFIELD) + ! + IF (TPFIELD%CDIR == 'XX' .OR. TPFIELD%CDIR == 'YY') THEN + ! XX or YY Scatter Field + CALL SCATTER_XXFIELD(TPFIELD%CDIR,ZFIELDP,PFIELD,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM,TPSPLITTING) + ELSE IF (TPFIELD%CDIR == 'XY') THEN + IF (LPACK .AND. L2D) THEN + ! 2D compact case + CALL SCATTER_XXFIELD('XX',ZFIELDP(:,1),PFIELD(:,JPHEXT+1),TPFILE%NMASTER_RANK,TPFILE%NMPICOMM,TPSPLITTING) + PFIELD(:,:) = SPREAD(PFIELD(:,JPHEXT+1),DIM=2,NCOPIES=IHEXTOT) + ELSE +#ifdef MNH_GA + ! + ! init/create the ga , dim3 = 1 + ! + CALL MNH_INIT_GA(SIZE(PFIELD,1),SIZE(PFIELD,2),1,TPFIELD%CMNHNAME,"READ") + IF (ISP == TPFILE%NMASTER_RANK) THEN + ! + ! put the data in the g_a , this proc get this 1 slide + ! + lo_zplan(JPIZ) = 1 + hi_zplan(JPIZ) = 1 + call nga_put(g_a, lo_zplan, hi_zplan,ZFIELDP, ld_zplan) + END IF + call ga_sync + ! + ! get the columun data in this proc + ! + ! temp buf to avoid problem with none stride PFIELDS buffer with HALO + ALLOCATE (ZFIELD_GA (SIZE(PFIELD,1),SIZE(PFIELD,2))) + call nga_get(g_a, lo_col, hi_col,ZFIELD_GA(1,1) , ld_col) + PFIELD = ZFIELD_GA + DEALLOCATE(ZFIELD_GA) +#else + ! XY Scatter Field + CALL SCATTER_XYFIELD(ZFIELDP,PFIELD,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) +#endif + END IF + ELSE + CALL MPI_BCAST(PFIELD,SIZE(PFIELD),MPI_FLOAT,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + END IF + END IF + CALL SECOND_MNH2(T2) + TIMEZ%T_READ2D_SCAT=TIMEZ%T_READ2D_SCAT + T2 - T1 +END IF +! +IF (GALLOC) DEALLOCATE (ZFIELDP) +! +IF (IRESP==-111) IRESP = 0 !-111 is not really an error (metadata has changed) +! +IF (PRESENT(KRESP)) KRESP = IRESP +! +CALL SECOND_MNH2(T22) +TIMEZ%T_READ2D_ALL=TIMEZ%T_READ2D_ALL + T22 - T11 +! +END SUBROUTINE IO_READ_FIELD_BYFIELD_X2 + + +SUBROUTINE IO_READ_FIELD_BYNAME_X3(TPFILE,HNAME,PFIELD,KRESP) +! +TYPE(TFILEDATA), INTENT(IN) :: TPFILE +CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write +REAL,DIMENSION(:,:,:),INTENT(INOUT) :: PFIELD ! array containing the data field +INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code +! +INTEGER :: ID ! Index of the field +INTEGER :: IRESP ! return_code +! +CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYNAME_X3',TRIM(TPFILE%CNAME)//': reading '//TRIM(HNAME)) +! +CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) +! +IF(IRESP==0) CALL IO_READ_FIELD(TPFILE,TFIELDLIST(ID),PFIELD,IRESP) +! +IF (PRESENT(KRESP)) KRESP = IRESP +! +END SUBROUTINE IO_READ_FIELD_BYNAME_X3 + +SUBROUTINE IO_READ_FIELD_BYFIELD_X3(TPFILE,TPFIELD,PFIELD,KRESP) +! +USE MODD_IO_ll, ONLY : GSMONOPROC,ISP,ISNPROC,LPACK,L1D,L2D +USE MODD_TIMEZ, ONLY : TIMEZ +USE MODD_VAR_ll, ONLY : MNH_STATUSES_IGNORE +! +USE MODE_ALLOCBUFFER_ll +#ifdef MNH_GA +USE MODE_GA +#endif +USE MODE_IO_ll, ONLY : IO_FILE +USE MODE_IO_MANAGE_STRUCT, ONLY : IO_FILE_FIND_BYNAME +USE MODE_MNH_TIMING, ONLY : SECOND_MNH2 +USE MODE_SCATTER_ll +! +TYPE(TFILEDATA),TARGET, INTENT(IN) :: TPFILE +TYPE(TFIELDDATA), INTENT(INOUT) :: TPFIELD +REAL,DIMENSION(:,:,:),TARGET,INTENT(INOUT) :: PFIELD ! array containing the data field +INTEGER, OPTIONAL, INTENT(OUT) :: KRESP ! return-code +! +TYPE TX_2DP + REAL,DIMENSION(:,:), POINTER :: X +END TYPE TX_2DP +! +INTEGER :: IERR,IRESP +INTEGER :: IHEXTOT +INTEGER :: IK_FILE,IK_RANK,INB_PROC_REAL,JK_MAX +INTEGER :: JI,IXO,IXE,IYO,IYE +INTEGER :: JK,JKK +INTEGER :: NB_REQ +INTEGER,ALLOCATABLE,DIMENSION(:) :: REQ_TAB +INTEGER, DIMENSION(MPI_STATUS_SIZE) :: STATUS +LOGICAL :: GALLOC, GALLOC_ll +REAL,DIMENSION(:,:),POINTER :: TX2DP +REAL,DIMENSION(:,:),POINTER :: ZSLICE_ll,ZSLICE +REAL,DIMENSION(:,:,:),POINTER :: ZFIELDP +REAL(KIND=8),DIMENSION(2) :: T0,T1,T2 +REAL(KIND=8),DIMENSION(2) :: T11,T22 +CHARACTER(LEN=2) :: YDIR +CHARACTER(LEN=4) :: YK +CHARACTER(LEN=NMNHNAMELGTMAX+4) :: YRECZSLICE +CHARACTER(LEN=4) :: YSUFFIX +TYPE(TFILEDATA),POINTER :: TZFILE +TYPE(TFIELDDATA) :: TZFIELD +TYPE(TX_2DP),ALLOCATABLE,DIMENSION(:) :: T_TX2DP +#ifdef MNH_GA +REAL,DIMENSION(:,:,:),POINTER :: ZFIELD_GA +#endif +! +CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYFIELD_X3',TRIM(TPFILE%CNAME)//': reading '//TRIM(TPFIELD%CMNHNAME)) +! +CALL SECOND_MNH2(T11) +! +TZFILE => NULL() +GALLOC = .FALSE. +GALLOC_ll = .FALSE. +IRESP = 0 +ZFIELDP => NULL() +YDIR = TPFIELD%CDIR +! +IHEXTOT = 2*JPHEXT+1 +! +CALL IO_FILE_READ_CHECK(TPFILE,'IO_READ_FIELD_BYFIELD_X3',IRESP) +! +IF (IRESP==0) THEN + IF (GSMONOPROC .AND. TPFILE%NSUBFILES_IOZ==0 ) THEN ! sequential execution + IF (LPACK .AND. L1D .AND. SIZE(PFIELD,1)==IHEXTOT .AND. SIZE(PFIELD,2)==IHEXTOT) THEN + ZFIELDP=>PFIELD(JPHEXT+1:JPHEXT+1,JPHEXT+1:JPHEXT+1,:) + ELSE IF (LPACK .AND. L2D .AND. SIZE(PFIELD,2)==IHEXTOT) THEN + ALLOCATE (ZFIELDP(SIZE(PFIELD,1),1,SIZE(PFIELD,3))) + GALLOC = .TRUE. + ELSE + ZFIELDP=>PFIELD(:,:,:) + END IF + IF (TPFILE%CFORMAT=='NETCDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFI') THEN + CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) + END IF + IF (LPACK .AND. L1D .AND. SIZE(PFIELD,1)==IHEXTOT .AND. SIZE(PFIELD,2)==IHEXTOT) THEN + PFIELD(:,:,:)=SPREAD(SPREAD(PFIELD(JPHEXT+1,JPHEXT+1,:),DIM=1,NCOPIES=IHEXTOT),DIM=2,NCOPIES=IHEXTOT) + ELSE IF (LPACK .AND. L2D .AND. SIZE(PFIELD,2)==IHEXTOT) THEN + PFIELD(:,:,:)=SPREAD(ZFIELDP(:,1,:),DIM=2,NCOPIES=IHEXTOT) + END IF + ELSE IF ( TPFILE%NSUBFILES_IOZ==0 .OR. YDIR == '--' ) THEN ! multiprocesses execution & 1 IO proc + IF (ISP == TPFILE%NMASTER_RANK) THEN + ! I/O process case + CALL ALLOCBUFFER_ll(ZFIELDP,PFIELD,YDIR,GALLOC) + IF (TPFILE%CFORMAT=='NETCDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFI') THEN + CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) + END IF + ELSE + !Not really necessary but useful to suppress alerts with Valgrind + ALLOCATE(ZFIELDP(0,0,0)) + GALLOC = .TRUE. + END IF + ! + CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + ! + !Broadcast header only if IRESP==-111 + !because metadata of field has been modified in IO_READ_FIELD_xxx + IF (IRESP==-111) CALL IO_BCAST_FIELD_METADATA(TPFILE,TPFIELD) + ! + IF (YDIR == 'XX' .OR. YDIR =='YY') THEN + ! XX or YY Scatter Field + CALL SCATTER_XXFIELD(YDIR,ZFIELDP,PFIELD,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) + ELSE IF (YDIR == 'XY') THEN + IF (LPACK .AND. L2D) THEN + ! 2D compact case + CALL SCATTER_XXFIELD('XX',ZFIELDP(:,1,:),PFIELD(:,JPHEXT+1,:),TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) + PFIELD(:,:,:) = SPREAD(PFIELD(:,JPHEXT+1,:),DIM=2,NCOPIES=IHEXTOT) + ELSE + ! XY Scatter Field + CALL SCATTER_XYFIELD(ZFIELDP,PFIELD,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) + END IF + ELSE + ! Broadcast Field + CALL MPI_BCAST(PFIELD,SIZE(PFIELD),MPI_FLOAT,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + END IF + ELSE ! multiprocesses execution & // IO +! +!JUAN BG Z SLICE +! +#ifdef MNH_GA + ! + ! init/create the ga + ! + CALL SECOND_MNH2(T0) + CALL MNH_INIT_GA(SIZE(PFIELD,1),SIZE(PFIELD,2),SIZE(PFIELD,3),TPFIELD%CMNHNAME,"READ") + ! + ! read the data + ! + ALLOCATE(ZSLICE_ll(0,0)) ! to avoid bug on test of size + GALLOC_ll = .TRUE. + DO JKK=1,IKU_ll + IK_FILE = IO_FILE(JKK,TPFILE%NSUBFILES_IOZ) + TZFILE => TPFILE%TFILES_IOZ(IK_FILE+1)%TFILE + TZFIELD = TPFIELD + WRITE(YSUFFIX,'(I4.4)') JKK + TZFIELD%CMNHNAME = TRIM(TPFIELD%CMNHNAME)//TRIM(YSUFFIX) + IF (LEN_TRIM(TZFIELD%CSTDNAME)>0) TZFIELD%CSTDNAME = TRIM(TZFIELD%CSTDNAME)//'_at_level_'//YSUFFIX + IF (LEN_TRIM(TZFIELD%CLONGNAME)>0) TZFIELD%CLONGNAME = TRIM(TZFIELD%CLONGNAME)//' at level '//YSUFFIX + TZFIELD%NDIMS = 2 + ! + IK_RANK = TZFILE%NMASTER_RANK + ! + IF (ISP == IK_RANK ) THEN + IF ( SIZE(ZSLICE_ll) .EQ. 0 ) THEN + DEALLOCATE(ZSLICE_ll) + CALL ALLOCBUFFER_ll(ZSLICE_ll,ZSLICE,YDIR,GALLOC_ll) + END IF + ! + CALL SECOND_MNH2(T0) + WRITE(YK,'(I4.4)') JKK + YRECZSLICE = TRIM(TPFIELD%CMNHNAME)//YK + IF (TPFILE%CFORMAT=='NETCDF4') THEN + CALL IO_READ_FIELD_NC4(TZFILE,TZFIELD,ZSLICE_ll,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFI') THEN + CALL IO_READ_FIELD_LFI(TZFILE,TZFIELD,ZSLICE_ll,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN + CALL IO_READ_FIELD_NC4(TZFILE,TZFIELD,ZSLICE_ll,IRESP) + END IF + CALL SECOND_MNH2(T1) + TIMEZ%T_READ3D_READ=TIMEZ%T_READ3D_READ + T1 - T0 + ! + ! put the data in the g_a , this proc get this JKK slide + ! + LO_ZPLAN(JPIZ) = JKK + HI_ZPLAN(JPIZ) = JKK + CALL NGA_PUT(G_A, LO_ZPLAN, HI_ZPLAN,ZSLICE_LL, LD_ZPLAN) + END IF + TZFILE => NULL() + END DO + CALL GA_SYNC + ! + ! get the columun data in this proc + ! + ! temp buf to avoid problem with none stride PFIELDS buffer with HALO + ALLOCATE (ZFIELD_GA (SIZE(PFIELD,1),SIZE(PFIELD,2),SIZE(PFIELD,3))) + CALL NGA_GET(G_A, LO_COL, HI_COL,ZFIELD_GA(1,1,1) , LD_COL) + PFIELD = ZFIELD_GA + DEALLOCATE(ZFIELD_GA) +#else + ALLOCATE(ZSLICE_ll(0,0)) + GALLOC_ll = .TRUE. + INB_PROC_REAL = MIN(TPFILE%NSUBFILES_IOZ,ISNPROC) + Z_SLICE: DO JK=1,SIZE(PFIELD,3),INB_PROC_REAL + ! + ! read the data + ! + JK_MAX=MIN(SIZE(PFIELD,3),JK+INB_PROC_REAL-1) + ! + NB_REQ=0 + ALLOCATE(REQ_TAB(ISNPROC-1)) + ALLOCATE(T_TX2DP(ISNPROC-1)) + DO JKK=JK,JK_MAX + IF (TPFILE%NSUBFILES_IOZ .GT. 1 ) THEN + IK_FILE = IO_FILE(JKK,TPFILE%NSUBFILES_IOZ) + TZFILE => TPFILE%TFILES_IOZ(IK_FILE+1)%TFILE + TZFIELD = TPFIELD + WRITE(YSUFFIX,'(I4.4)') JKK + TZFIELD%CMNHNAME = TRIM(TPFIELD%CMNHNAME)//TRIM(YSUFFIX) + IF (LEN_TRIM(TZFIELD%CSTDNAME)>0) TZFIELD%CSTDNAME = TRIM(TZFIELD%CSTDNAME)//'_at_level_'//YSUFFIX + IF (LEN_TRIM(TZFIELD%CLONGNAME)>0) TZFIELD%CLONGNAME = TRIM(TZFIELD%CLONGNAME)//' at level '//YSUFFIX + TZFIELD%NDIMS = 2 + ELSE + TZFILE => TPFILE + TZFIELD = TPFIELD + END IF + IK_RANK = TZFILE%NMASTER_RANK + IF (ISP == IK_RANK ) THEN + IF ( SIZE(ZSLICE_ll) .EQ. 0 ) THEN + DEALLOCATE(ZSLICE_ll) + CALL ALLOCBUFFER_ll(ZSLICE_ll,ZSLICE,YDIR,GALLOC_ll) + END IF + CALL SECOND_MNH2(T0) + WRITE(YK,'(I4.4)') JKK + YRECZSLICE = TRIM(TPFIELD%CMNHNAME)//YK + IF (TPFILE%CFORMAT=='NETCDF4') THEN + CALL IO_READ_FIELD_NC4(TZFILE,TZFIELD,ZSLICE_ll,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFI') THEN + CALL IO_READ_FIELD_LFI(TZFILE,TZFIELD,ZSLICE_ll,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN + CALL IO_READ_FIELD_NC4(TZFILE,TZFIELD,ZSLICE_ll,IRESP) + END IF + CALL SECOND_MNH2(T1) + TIMEZ%T_READ3D_READ=TIMEZ%T_READ3D_READ + T1 - T0 + DO JI = 1,ISNPROC + CALL GET_DOMREAD_ll(JI,IXO,IXE,IYO,IYE) + TX2DP=>ZSLICE_ll(IXO:IXE,IYO:IYE) + IF (ISP /= JI) THEN + NB_REQ = NB_REQ + 1 + ALLOCATE(T_TX2DP(NB_REQ)%X(IXO:IXE,IYO:IYE)) + T_TX2DP(NB_REQ)%X=TX2DP + CALL MPI_ISEND(T_TX2DP(NB_REQ)%X,SIZE(TX2DP),MPI_FLOAT,JI-1,199+IK_RANK, & + TZFILE%NMPICOMM,REQ_TAB(NB_REQ),IERR) + !CALL MPI_BSEND(TX2DP,SIZE(TX2DP),MPI_FLOAT,JI-1,199+IK_RANK,TZFILE%NMPICOMM,IERR) + ELSE + PFIELD(:,:,JKK) = TX2DP(:,:) + END IF + END DO + CALL SECOND_MNH2(T2) + TIMEZ%T_READ3D_SEND=TIMEZ%T_READ3D_SEND + T2 - T1 + END IF + TZFILE => NULL() + END DO + ! + ! broadcast the data + ! + IF (YDIR == 'XX' .OR. YDIR =='YY') THEN + ! XX or YY Scatter Field + STOP " XX ou YY NON PREVU SUR BG POUR LE MOMENT " + CALL SCATTER_XXFIELD(YDIR,ZFIELDP,PFIELD,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) + ELSE IF (YDIR == 'XY') THEN + IF (LPACK .AND. L2D) THEN + ! 2D compact case + STOP " L2D NON PREVU SUR BG POUR LE MOMENT " + CALL SCATTER_XXFIELD('XX',ZFIELDP(:,1,:),PFIELD(:,JPHEXT+1,:),TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) + PFIELD(:,:,:) = SPREAD(PFIELD(:,JPHEXT+1,:),DIM=2,NCOPIES=IHEXTOT) + ELSE + ! + ! XY Scatter Field + ! + CALL SECOND_MNH2(T0) + DO JKK=JK,JK_MAX + ! + ! get the file & rank + ! + IF (TPFILE%NSUBFILES_IOZ .GT. 1 ) THEN + IK_FILE = IO_FILE(JKK,TPFILE%NSUBFILES_IOZ) + TZFILE => TPFILE%TFILES_IOZ(IK_FILE+1)%TFILE + ELSE + TZFILE => TPFILE + END IF + ! + IK_RANK = TZFILE%NMASTER_RANK + ! + ZSLICE => PFIELD(:,:,JKK) + !CALL SCATTER_XYFIELD(ZSLICE_ll,ZSLICE,TZFILE%NMASTER_RANK,TZFILE%NMPICOMM) + IF (ISP .NE. IK_RANK) THEN + CALL MPI_RECV(ZSLICE,SIZE(ZSLICE),MPI_FLOAT,IK_RANK-1,199+IK_RANK, & + TZFILE%NMPICOMM,STATUS,IERR) + END IF + TZFILE => NULL() + END DO + CALL SECOND_MNH2(T1) + TIMEZ%T_READ3D_RECV=TIMEZ%T_READ3D_RECV + T1 - T0 + END IF + ELSE + ! Broadcast Field + STOP " Broadcast Field NON PREVU SUR BG POUR LE MOMENT " + CALL MPI_BCAST(PFIELD,SIZE(PFIELD),MPI_FLOAT,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + END IF + CALL SECOND_MNH2(T0) + IF (NB_REQ .GT.0 ) THEN + CALL MPI_WAITALL(NB_REQ,REQ_TAB,MNH_STATUSES_IGNORE,IERR) + DO JI=1,NB_REQ ; DEALLOCATE(T_TX2DP(JI)%X) ; ENDDO + END IF + DEALLOCATE(T_TX2DP) + DEALLOCATE(REQ_TAB) + CALL SECOND_MNH2(T1) + TIMEZ%T_READ3D_WAIT=TIMEZ%T_READ3D_WAIT + T1 - T0 + END DO Z_SLICE + ! + !Broadcast header only if IRESP==-111 + !because metadata of field has been modified in IO_READ_FIELD_xxx + IF (IRESP==-111) CALL IO_BCAST_FIELD_METADATA(TPFILE,TPFIELD) + ! +#endif +!JUAN BG Z SLICE + END IF !(GSMONOPROC) +END IF +! +IF (GALLOC) DEALLOCATE (ZFIELDP) +IF (GALLOC_ll) DEALLOCATE (ZSLICE_ll) +! +IF (IRESP==-111) IRESP = 0 !-111 is not really an error (metadata has changed) +! +IF (PRESENT(KRESP)) KRESP = IRESP +! +CALL SECOND_MNH2(T22) +TIMEZ%T_READ3D_ALL=TIMEZ%T_READ3D_ALL + T22 - T11 +! +END SUBROUTINE IO_READ_FIELD_BYFIELD_X3 + + +SUBROUTINE IO_READ_FIELD_BYNAME_X4(TPFILE,HNAME,PFIELD,KRESP) +! +USE MODD_IO_ll, ONLY : ISNPROC +USE MODD_STRUCTURE_ll, ONLY : ZONE_ll +! +! +TYPE(TFILEDATA), INTENT(IN) :: TPFILE +CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write +REAL,DIMENSION(:,:,:,:),INTENT(INOUT) :: PFIELD ! array containing the data field +INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code +! +INTEGER :: ID ! Index of the field +INTEGER :: IRESP ! return_code +! +CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYNAME_X4',TRIM(TPFILE%CNAME)//': reading '//TRIM(HNAME)) +! +CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) +! +IF(IRESP==0) CALL IO_READ_FIELD(TPFILE,TFIELDLIST(ID),PFIELD,IRESP) +! +IF (PRESENT(KRESP)) KRESP = IRESP +! +END SUBROUTINE IO_READ_FIELD_BYNAME_X4 + +SUBROUTINE IO_READ_FIELD_BYFIELD_X4(TPFILE,TPFIELD,PFIELD,KRESP) +! +USE MODD_IO_ll, ONLY : GSMONOPROC,ISP,ISNPROC,LPACK,L1D,L2D +USE MODD_STRUCTURE_ll, ONLY : ZONE_ll +USE MODD_TIMEZ, ONLY : TIMEZ +! +USE MODE_ALLOCBUFFER_ll +USE MODE_MNH_TIMING, ONLY : SECOND_MNH2 +USE MODE_SCATTER_ll +! +TYPE(TFILEDATA), INTENT(IN) :: TPFILE +TYPE(TFIELDDATA), INTENT(INOUT) :: TPFIELD +REAL,DIMENSION(:,:,:,:),TARGET,INTENT(INOUT) :: PFIELD ! array containing the data field +INTEGER, OPTIONAL, INTENT(OUT) :: KRESP ! return-code +! +INTEGER :: IERR +REAL,DIMENSION(:,:,:,:),POINTER :: ZFIELDP +LOGICAL :: GALLOC +INTEGER :: IRESP +INTEGER :: IHEXTOT +! +CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYFIELD_X4',TRIM(TPFILE%CNAME)//': reading '//TRIM(TPFIELD%CMNHNAME)) +! +GALLOC = .FALSE. +IRESP = 0 +ZFIELDP => NULL() +! +IHEXTOT = 2*JPHEXT+1 +CALL IO_FILE_READ_CHECK(TPFILE,'IO_READ_FIELD_BYFIELD_X4',IRESP) +! +IF (IRESP==0) THEN + IF (GSMONOPROC) THEN ! sequential execution + IF (LPACK .AND. L1D .AND. SIZE(PFIELD,1)==IHEXTOT .AND. SIZE(PFIELD,2)==IHEXTOT) THEN + ZFIELDP=>PFIELD(JPHEXT+1:JPHEXT+1,JPHEXT+1:JPHEXT+1,:,:) + ELSE IF (LPACK .AND. L2D .AND. SIZE(PFIELD,2)==IHEXTOT) THEN + ZFIELDP=>PFIELD(:,JPHEXT+1:JPHEXT+1,:,:) + ELSE + ZFIELDP=>PFIELD(:,:,:,:) + END IF + IF (TPFILE%CFORMAT=='NETCDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFI') THEN + CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) + END IF + IF (LPACK .AND. L1D .AND. SIZE(PFIELD,1)==IHEXTOT .AND. SIZE(PFIELD,2)==IHEXTOT) THEN + PFIELD(:,:,:,:)=SPREAD(SPREAD(PFIELD(JPHEXT+1,JPHEXT+1,:,:),DIM=1,NCOPIES=IHEXTOT),DIM=2,NCOPIES=IHEXTOT) + ELSE IF (LPACK .AND. L2D .AND. SIZE(PFIELD,2)==IHEXTOT) THEN + PFIELD(:,:,:,:)=SPREAD(PFIELD(:,JPHEXT+1,:,:),DIM=2,NCOPIES=IHEXTOT) + END IF + ELSE + IF (ISP == TPFILE%NMASTER_RANK) THEN + ! I/O process case + CALL ALLOCBUFFER_ll(ZFIELDP,PFIELD,TPFIELD%CDIR,GALLOC) + IF (TPFILE%CFORMAT=='NETCDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFI') THEN + CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) + END IF + ELSE + !Not really necessary but useful to suppress alerts with Valgrind + ALLOCATE(ZFIELDP(0,0,0,0)) + GALLOC = .TRUE. + END IF + ! + CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + ! + !Broadcast header only if IRESP==-111 + !because metadata of field has been modified in IO_READ_FIELD_xxx + IF (IRESP==-111) CALL IO_BCAST_FIELD_METADATA(TPFILE,TPFIELD) + ! + IF (TPFIELD%CDIR == 'XX' .OR. TPFIELD%CDIR == 'YY') THEN + ! XX or YY Scatter Field + CALL SCATTER_XXFIELD(TPFIELD%CDIR,ZFIELDP,PFIELD,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) + ELSE IF (TPFIELD%CDIR == 'XY') THEN + IF (LPACK .AND. L2D) THEN + ! 2D compact case + CALL SCATTER_XXFIELD('XX',ZFIELDP(:,1,:,:),PFIELD(:,JPHEXT+1,:,:),TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) + PFIELD(:,:,:,:) = SPREAD(PFIELD(:,JPHEXT+1,:,:),DIM=2,NCOPIES=IHEXTOT) + ELSE + ! XY Scatter Field + CALL SCATTER_XYFIELD(ZFIELDP,PFIELD,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) + END IF + ELSE + CALL MPI_BCAST(PFIELD,SIZE(PFIELD),MPI_FLOAT,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + END IF + END IF +END IF +! +IF (GALLOC) DEALLOCATE (ZFIELDP) +! +IF (IRESP==-111) IRESP = 0 !-111 is not really an error (metadata has changed) +! +IF (PRESENT(KRESP)) KRESP = IRESP +! +END SUBROUTINE IO_READ_FIELD_BYFIELD_X4 + + +SUBROUTINE IO_READ_FIELD_BYNAME_X5(TPFILE,HNAME,PFIELD,KRESP) +! +USE MODD_IO_ll, ONLY : ISNPROC +USE MODD_STRUCTURE_ll, ONLY : ZONE_ll +! +! +TYPE(TFILEDATA), INTENT(IN) :: TPFILE +CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write +REAL,DIMENSION(:,:,:,:,:),INTENT(INOUT) :: PFIELD ! array containing the data field +INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code +! +INTEGER :: ID ! Index of the field +INTEGER :: IRESP ! return_code +! +CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYNAME_X5',TRIM(TPFILE%CNAME)//': reading '//TRIM(HNAME)) +! +CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) +! +IF(IRESP==0) CALL IO_READ_FIELD(TPFILE,TFIELDLIST(ID),PFIELD,IRESP) +! +IF (PRESENT(KRESP)) KRESP = IRESP +! +END SUBROUTINE IO_READ_FIELD_BYNAME_X5 + +SUBROUTINE IO_READ_FIELD_BYFIELD_X5(TPFILE,TPFIELD,PFIELD,KRESP) +! +USE MODD_IO_ll, ONLY : GSMONOPROC,ISP,ISNPROC,LPACK,L1D,L2D +USE MODD_STRUCTURE_ll, ONLY : ZONE_ll +USE MODD_TIMEZ, ONLY : TIMEZ +! +USE MODE_ALLOCBUFFER_ll +USE MODE_MNH_TIMING, ONLY : SECOND_MNH2 +USE MODE_SCATTER_ll +! +TYPE(TFILEDATA), INTENT(IN) :: TPFILE +TYPE(TFIELDDATA), INTENT(INOUT) :: TPFIELD +REAL,DIMENSION(:,:,:,:,:),TARGET,INTENT(INOUT) :: PFIELD ! array containing the data field +INTEGER, OPTIONAL, INTENT(OUT) :: KRESP ! return-code +! +INTEGER :: IERR +REAL,DIMENSION(:,:,:,:,:),POINTER :: ZFIELDP +LOGICAL :: GALLOC +INTEGER :: IRESP +INTEGER :: IHEXTOT +! +CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYFIELD_X5',TRIM(TPFILE%CNAME)//': reading '//TRIM(TPFIELD%CMNHNAME)) +! +GALLOC = .FALSE. +IRESP = 0 +ZFIELDP => NULL() +! +IHEXTOT = 2*JPHEXT+1 +CALL IO_FILE_READ_CHECK(TPFILE,'IO_READ_FIELD_BYFIELD_X5',IRESP) +! +IF (IRESP==0) THEN + IF (GSMONOPROC) THEN ! sequential execution + IF (LPACK .AND. L1D .AND. SIZE(PFIELD,1)==IHEXTOT .AND. SIZE(PFIELD,2)==IHEXTOT) THEN + ZFIELDP=>PFIELD(JPHEXT+1:JPHEXT+1,JPHEXT+1:JPHEXT+1,:,:,:) + ELSE IF (LPACK .AND. L2D .AND. SIZE(PFIELD,2)==IHEXTOT) THEN + ZFIELDP=>PFIELD(:,JPHEXT+1:JPHEXT+1,:,:,:) + ELSE + ZFIELDP=>PFIELD(:,:,:,:,:) + END IF + IF (TPFILE%CFORMAT=='NETCDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFI') THEN + CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) + END IF + IF (LPACK .AND. L1D .AND. SIZE(PFIELD,1)==IHEXTOT .AND. SIZE(PFIELD,2)==IHEXTOT) THEN + PFIELD(:,:,:,:,:)=SPREAD(SPREAD(PFIELD(JPHEXT+1,JPHEXT+1,:,:,:),DIM=1,NCOPIES=IHEXTOT),DIM=2,NCOPIES=IHEXTOT) + ELSE IF (LPACK .AND. L2D .AND. SIZE(PFIELD,2)==IHEXTOT) THEN + PFIELD(:,:,:,:,:)=SPREAD(PFIELD(:,JPHEXT+1,:,:,:),DIM=2,NCOPIES=IHEXTOT) + END IF + ELSE + IF (ISP == TPFILE%NMASTER_RANK) THEN + ! I/O process case + CALL ALLOCBUFFER_ll(ZFIELDP,PFIELD,TPFIELD%CDIR,GALLOC) + IF (TPFILE%CFORMAT=='NETCDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFI') THEN + CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) + END IF + ELSE + !Not really necessary but useful to suppress alerts with Valgrind + ALLOCATE(ZFIELDP(0,0,0,0,0)) + GALLOC = .TRUE. + END IF + ! + CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + ! + !Broadcast header only if IRESP==-111 + !because metadata of field has been modified in IO_READ_FIELD_xxx + IF (IRESP==-111) CALL IO_BCAST_FIELD_METADATA(TPFILE,TPFIELD) + ! + IF (TPFIELD%CDIR == 'XX' .OR. TPFIELD%CDIR == 'YY') THEN + ! XX or YY Scatter Field + CALL SCATTER_XXFIELD(TPFIELD%CDIR,ZFIELDP,PFIELD,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) + ELSE IF (TPFIELD%CDIR == 'XY') THEN + IF (LPACK .AND. L2D) THEN + ! 2D compact case + CALL SCATTER_XXFIELD('XX',ZFIELDP(:,1,:,:,:),PFIELD(:,JPHEXT+1,:,:,:),TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) + PFIELD(:,:,:,:,:) = SPREAD(PFIELD(:,JPHEXT+1,:,:,:),DIM=2,NCOPIES=IHEXTOT) + ELSE + ! XY Scatter Field + CALL SCATTER_XYFIELD(ZFIELDP,PFIELD,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) + END IF + ELSE + CALL MPI_BCAST(PFIELD,SIZE(PFIELD),MPI_FLOAT,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + END IF + END IF +END IF +! +IF (GALLOC) DEALLOCATE (ZFIELDP) +! +IF (IRESP==-111) IRESP = 0 !-111 is not really an error (metadata has changed) +! +IF (PRESENT(KRESP)) KRESP = IRESP +! +END SUBROUTINE IO_READ_FIELD_BYFIELD_X5 + + +SUBROUTINE IO_READ_FIELD_BYNAME_X6(TPFILE,HNAME,PFIELD,KRESP) +! +USE MODD_IO_ll, ONLY : ISNPROC +USE MODD_STRUCTURE_ll, ONLY : ZONE_ll +! +! +TYPE(TFILEDATA), INTENT(IN) :: TPFILE +CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write +REAL,DIMENSION(:,:,:,:,:,:),INTENT(INOUT) :: PFIELD ! array containing the data field +INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code +! +INTEGER :: ID ! Index of the field +INTEGER :: IRESP ! return_code +! +CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYNAME_X6',TRIM(TPFILE%CNAME)//': reading '//TRIM(HNAME)) +! +CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) +! +IF(IRESP==0) CALL IO_READ_FIELD(TPFILE,TFIELDLIST(ID),PFIELD,IRESP) +! +IF (PRESENT(KRESP)) KRESP = IRESP +! +END SUBROUTINE IO_READ_FIELD_BYNAME_X6 + +SUBROUTINE IO_READ_FIELD_BYFIELD_X6(TPFILE,TPFIELD,PFIELD,KRESP) +! +USE MODD_IO_ll, ONLY : GSMONOPROC,ISP,ISNPROC,LPACK,L1D,L2D +USE MODD_STRUCTURE_ll, ONLY : ZONE_ll +USE MODD_TIMEZ, ONLY : TIMEZ +! +USE MODE_ALLOCBUFFER_ll +USE MODE_MNH_TIMING, ONLY : SECOND_MNH2 +USE MODE_SCATTER_ll +! +TYPE(TFILEDATA), INTENT(IN) :: TPFILE +TYPE(TFIELDDATA), INTENT(INOUT) :: TPFIELD +REAL,DIMENSION(:,:,:,:,:,:),TARGET,INTENT(INOUT) :: PFIELD ! array containing the data field +INTEGER, OPTIONAL, INTENT(OUT) :: KRESP ! return-code +! +INTEGER :: IERR +REAL,DIMENSION(:,:,:,:,:,:),POINTER :: ZFIELDP +LOGICAL :: GALLOC +INTEGER :: IRESP +INTEGER :: IHEXTOT +! +CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYFIELD_X6',TRIM(TPFILE%CNAME)//': reading '//TRIM(TPFIELD%CMNHNAME)) +! +GALLOC = .FALSE. +IRESP = 0 +ZFIELDP => NULL() +! +IHEXTOT = 2*JPHEXT+1 +CALL IO_FILE_READ_CHECK(TPFILE,'IO_READ_FIELD_BYFIELD_X6',IRESP) +! +IF (IRESP==0) THEN + IF (GSMONOPROC) THEN ! sequential execution + IF (TPFILE%CFORMAT=='NETCDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,PFIELD,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFI') THEN + CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,PFIELD,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,PFIELD,IRESP) + END IF + ELSE + IF (ISP == TPFILE%NMASTER_RANK) THEN + ! I/O process case + CALL ALLOCBUFFER_ll(ZFIELDP,PFIELD,TPFIELD%CDIR,GALLOC) + IF (TPFILE%CFORMAT=='NETCDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFI') THEN + CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) + END IF + ELSE + !Not really necessary but useful to suppress alerts with Valgrind + ALLOCATE(ZFIELDP(0,0,0,0,0,0)) + GALLOC = .TRUE. + END IF + ! + CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + ! + !Broadcast header only if IRESP==-111 + !because metadata of field has been modified in IO_READ_FIELD_xxx + IF (IRESP==-111) CALL IO_BCAST_FIELD_METADATA(TPFILE,TPFIELD) + ! + IF (TPFIELD%CDIR == 'XX' .OR. TPFIELD%CDIR == 'YY') THEN + ! XX or YY Scatter Field + CALL SCATTER_XXFIELD(TPFIELD%CDIR,ZFIELDP,PFIELD,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) + ELSE IF (TPFIELD%CDIR == 'XY') THEN + ! XY Scatter Field + CALL SCATTER_XYFIELD(ZFIELDP,PFIELD,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) + ELSE + CALL MPI_BCAST(PFIELD,SIZE(PFIELD),MPI_FLOAT,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + END IF + END IF +END IF +! +IF (GALLOC) DEALLOCATE (ZFIELDP) +! +IF (IRESP==-111) IRESP = 0 !-111 is not really an error (metadata has changed) +! +IF (PRESENT(KRESP)) KRESP = IRESP +! +END SUBROUTINE IO_READ_FIELD_BYFIELD_X6 + + +SUBROUTINE IO_READ_FIELD_BYNAME_N0(TPFILE,HNAME,KFIELD,KRESP) +! +TYPE(TFILEDATA), INTENT(IN) :: TPFILE +CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write +INTEGER, INTENT(INOUT) :: KFIELD ! array containing the data field +INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code +! +INTEGER :: ID ! Index of the field +INTEGER :: IRESP ! return_code +! +CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYNAME_N0',TRIM(TPFILE%CNAME)//': reading '//TRIM(HNAME)) +! +CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) +! +IF(IRESP==0) CALL IO_READ_FIELD(TPFILE,TFIELDLIST(ID),KFIELD,IRESP) +! +IF (PRESENT(KRESP)) KRESP = IRESP +! +END SUBROUTINE IO_READ_FIELD_BYNAME_N0 + +SUBROUTINE IO_READ_FIELD_BYFIELD_N0(TPFILE,TPFIELD,KFIELD,KRESP) +! +USE MODD_IO_ll, ONLY : ISP,GSMONOPROC +! +TYPE(TFILEDATA), INTENT(IN) :: TPFILE +TYPE(TFIELDDATA), INTENT(INOUT) :: TPFIELD +INTEGER, INTENT(INOUT) :: KFIELD ! array containing the data field +INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code +! +INTEGER :: IERR +INTEGER :: IRESP +! +CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYFIELD_N0',TRIM(TPFILE%CNAME)//': reading '//TRIM(TPFIELD%CMNHNAME)) +! +IRESP = 0 +! +CALL IO_FILE_READ_CHECK(TPFILE,'IO_READ_FIELD_BYFIELD_N0',IRESP) +! +IF (IRESP==0) THEN + IF (GSMONOPROC) THEN ! sequential execution + IF (TPFILE%CFORMAT=='NETCDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,KFIELD,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFI') THEN + CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,KFIELD,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,KFIELD,IRESP) + END IF + ELSE + IF (ISP == TPFILE%NMASTER_RANK) THEN + IF (TPFILE%CFORMAT=='NETCDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,KFIELD,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFI') THEN + CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,KFIELD,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,KFIELD,IRESP) + END IF + END IF + ! + CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + ! + !Broadcast header only if IRESP==-111 + !because metadata of field has been modified in IO_READ_FIELD_xxx + IF (IRESP==-111) CALL IO_BCAST_FIELD_METADATA(TPFILE,TPFIELD) + ! + CALL MPI_BCAST(KFIELD,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + END IF +END IF +! +IF (IRESP==-111) IRESP = 0 !-111 is not really an error (metadata has changed) +! +IF (PRESENT(KRESP)) KRESP = IRESP +! +END SUBROUTINE IO_READ_FIELD_BYFIELD_N0 + + +SUBROUTINE IO_READ_FIELD_BYNAME_N1(TPFILE,HNAME,KFIELD,KRESP) +! +TYPE(TFILEDATA), INTENT(IN) :: TPFILE +CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write +INTEGER,DIMENSION(:),INTENT(INOUT) :: KFIELD ! array containing the data field +INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code +! +INTEGER :: ID ! Index of the field +INTEGER :: IRESP ! return_code +! +CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYNAME_N1',TRIM(TPFILE%CNAME)//': reading '//TRIM(HNAME)) +! +CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) +! +IF(IRESP==0) CALL IO_READ_FIELD(TPFILE,TFIELDLIST(ID),KFIELD,IRESP) +! +IF (PRESENT(KRESP)) KRESP = IRESP +! +END SUBROUTINE IO_READ_FIELD_BYNAME_N1 + +SUBROUTINE IO_READ_FIELD_BYFIELD_N1(TPFILE,TPFIELD,KFIELD,KRESP) +! +USE MODD_IO_ll, ONLY : ISP,GSMONOPROC +! +USE MODE_ALLOCBUFFER_ll +USE MODE_SCATTER_ll +! +TYPE(TFILEDATA), INTENT(IN) :: TPFILE +TYPE(TFIELDDATA), INTENT(INOUT) :: TPFIELD +INTEGER,DIMENSION(:),INTENT(INOUT) :: KFIELD ! array containing the data field +INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code +! +INTEGER :: IERR +INTEGER :: IRESP +INTEGER,DIMENSION(:),POINTER :: IFIELDP +LOGICAL :: GALLOC +! +CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYFIELD_N1',TRIM(TPFILE%CNAME)//': reading '//TRIM(TPFIELD%CMNHNAME)) +! +GALLOC = .FALSE. +IRESP = 0 +IFIELDP => NULL() +! +CALL IO_FILE_READ_CHECK(TPFILE,'IO_READ_FIELD_BYFIELD_N1',IRESP) +! +IF (IRESP==0) THEN + IF (GSMONOPROC) THEN ! sequential execution + IF (TPFILE%CFORMAT=='NETCDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,KFIELD,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFI') THEN + CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,KFIELD,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,KFIELD,IRESP) + END IF + ELSE + IF (ISP == TPFILE%NMASTER_RANK) THEN + CALL ALLOCBUFFER_ll(IFIELDP,KFIELD,TPFIELD%CDIR,GALLOC) + IF (TPFILE%CFORMAT=='NETCDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,IFIELDP,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFI') THEN + CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,IFIELDP,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,IFIELDP,IRESP) + END IF + ELSE + !Not really necessary but useful to suppress alerts with Valgrind + ALLOCATE(IFIELDP(0)) + GALLOC = .TRUE. + END IF + ! + CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + ! + !Broadcast header only if IRESP==-111 + !because metadata of field has been modified in IO_READ_FIELD_xxx + IF (IRESP==-111) CALL IO_BCAST_FIELD_METADATA(TPFILE,TPFIELD) + ! + IF (TPFIELD%CDIR /= 'XX' .AND. TPFIELD%CDIR /='YY') THEN + ! Broadcast Field + CALL MPI_BCAST(KFIELD,SIZE(KFIELD),MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + ELSE + !Scatter Field + CALL SCATTER_XXFIELD(TPFIELD%CDIR,IFIELDP,KFIELD,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) + END IF + END IF +END IF +! +IF (GALLOC) DEALLOCATE (IFIELDP) +! +IF (IRESP==-111) IRESP = 0 !-111 is not really an error (metadata has changed) +! +IF (PRESENT(KRESP)) KRESP = IRESP +! +END SUBROUTINE IO_READ_FIELD_BYFIELD_N1 + + +SUBROUTINE IO_READ_FIELD_BYNAME_N2(TPFILE,HNAME,KFIELD,KRESP) +! +USE MODD_IO_ll, ONLY : ISNPROC +USE MODD_STRUCTURE_ll, ONLY : ZONE_ll +! +! +TYPE(TFILEDATA), INTENT(IN) :: TPFILE +CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write +INTEGER,DIMENSION(:,:),INTENT(INOUT) :: KFIELD ! array containing the data field +INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code +! +INTEGER :: ID ! Index of the field +INTEGER :: IRESP ! return_code +! +CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYNAME_N2',TRIM(TPFILE%CNAME)//': reading '//TRIM(HNAME)) +! +CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) +! +IF(IRESP==0) CALL IO_READ_FIELD(TPFILE,TFIELDLIST(ID),KFIELD,IRESP) +! +IF (PRESENT(KRESP)) KRESP = IRESP +! +END SUBROUTINE IO_READ_FIELD_BYNAME_N2 + +SUBROUTINE IO_READ_FIELD_BYFIELD_N2(TPFILE,TPFIELD,KFIELD,KRESP) +! +USE MODD_IO_ll, ONLY : GSMONOPROC,ISP,ISNPROC,LPACK,L1D,L2D +USE MODD_STRUCTURE_ll, ONLY : ZONE_ll +USE MODD_TIMEZ, ONLY : TIMEZ +! +USE MODE_ALLOCBUFFER_ll +USE MODE_SCATTER_ll +! +TYPE(TFILEDATA), INTENT(IN) :: TPFILE +TYPE(TFIELDDATA), INTENT(INOUT) :: TPFIELD +INTEGER,DIMENSION(:,:),TARGET,INTENT(INOUT) :: KFIELD ! array containing the data field +INTEGER, OPTIONAL, INTENT(OUT) :: KRESP ! return-code +! +INTEGER :: IERR +INTEGER,DIMENSION(:,:),POINTER :: IFIELDP +LOGICAL :: GALLOC +INTEGER :: IRESP +INTEGER :: IHEXTOT +! +CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYFIELD_N2',TRIM(TPFILE%CNAME)//': reading '//TRIM(TPFIELD%CMNHNAME)) +! +GALLOC = .FALSE. +IRESP = 0 +IFIELDP => NULL() +! +IHEXTOT = 2*JPHEXT+1 +CALL IO_FILE_READ_CHECK(TPFILE,'IO_READ_FIELD_BYFIELD_N2',IRESP) +! +IF (IRESP==0) THEN + IF (GSMONOPROC) THEN ! sequential execution + IF (LPACK .AND. L1D .AND. SIZE(KFIELD,1)==IHEXTOT .AND. SIZE(KFIELD,2)==IHEXTOT) THEN + IFIELDP=>KFIELD(JPHEXT+1:JPHEXT+1,JPHEXT+1:JPHEXT+1) + ELSE IF (LPACK .AND. L2D .AND. SIZE(KFIELD,2)==IHEXTOT) THEN + IFIELDP=>KFIELD(:,JPHEXT+1:JPHEXT+1) + ELSE + IFIELDP=>KFIELD(:,:) + END IF + IF (TPFILE%CFORMAT=='NETCDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,IFIELDP,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFI') THEN + CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,IFIELDP,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,IFIELDP,IRESP) + END IF + IF (LPACK .AND. L1D .AND. SIZE(KFIELD,1)==IHEXTOT .AND. SIZE(KFIELD,2)==IHEXTOT) THEN + KFIELD(:,:)=SPREAD(SPREAD(KFIELD(JPHEXT+1,JPHEXT+1),DIM=1,NCOPIES=IHEXTOT),DIM=2,NCOPIES=IHEXTOT) + ELSE IF (LPACK .AND. L2D .AND. SIZE(KFIELD,2)==IHEXTOT) THEN + KFIELD(:,:)=SPREAD(KFIELD(:,JPHEXT+1),DIM=2,NCOPIES=IHEXTOT) + END IF + ELSE + IF (ISP == TPFILE%NMASTER_RANK) THEN + ! I/O process case + CALL ALLOCBUFFER_ll(IFIELDP,KFIELD,TPFIELD%CDIR,GALLOC) + IF (TPFILE%CFORMAT=='NETCDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,IFIELDP,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFI') THEN + CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,IFIELDP,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,IFIELDP,IRESP) + END IF + ELSE + !Not really necessary but useful to suppress alerts with Valgrind + ALLOCATE(IFIELDP(0,0)) + GALLOC = .TRUE. + END IF + ! + CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + ! + !Broadcast header only if IRESP==-111 + !because metadata of field has been modified in IO_READ_FIELD_xxx + IF (IRESP==-111) CALL IO_BCAST_FIELD_METADATA(TPFILE,TPFIELD) + ! + IF (TPFIELD%CDIR == 'XX' .OR. TPFIELD%CDIR == 'YY') THEN + ! XX or YY Scatter Field + CALL SCATTER_XXFIELD(TPFIELD%CDIR,IFIELDP,KFIELD,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) + ! Broadcast Field + CALL MPI_BCAST(KFIELD,SIZE(KFIELD),MPI_FLOAT,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + ELSE IF (TPFIELD%CDIR == 'XY') THEN + IF (LPACK .AND. L2D) THEN + ! 2D compact case + CALL SCATTER_XXFIELD('XX',IFIELDP(:,1),KFIELD(:,JPHEXT+1),TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) + KFIELD(:,:) = SPREAD(KFIELD(:,JPHEXT+1),DIM=2,NCOPIES=IHEXTOT) + ELSE + ! XY Scatter Field + CALL SCATTER_XYFIELD(IFIELDP,KFIELD,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) + END IF + ELSE + IF (ISP == TPFILE%NMASTER_RANK) KFIELD = IFIELDP + CALL MPI_BCAST(KFIELD,SIZE(KFIELD),MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + END IF + END IF +END IF +! +IF (GALLOC) DEALLOCATE (IFIELDP) +! +IF (IRESP==-111) IRESP = 0 !-111 is not really an error (metadata has changed) +! +IF (PRESENT(KRESP)) KRESP = IRESP +! +END SUBROUTINE IO_READ_FIELD_BYFIELD_N2 + + +SUBROUTINE IO_READ_FIELD_BYNAME_L0(TPFILE,HNAME,OFIELD,KRESP) +! +TYPE(TFILEDATA), INTENT(IN) :: TPFILE +CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write +LOGICAL, INTENT(INOUT) :: OFIELD ! array containing the data field +INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code +! +INTEGER :: ID ! Index of the field +INTEGER :: IRESP ! return_code +! +CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYNAME_L0',TRIM(TPFILE%CNAME)//': reading '//TRIM(HNAME)) +! +CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) +! +IF(IRESP==0) CALL IO_READ_FIELD(TPFILE,TFIELDLIST(ID),OFIELD,IRESP) +! +IF (PRESENT(KRESP)) KRESP = IRESP +! +END SUBROUTINE IO_READ_FIELD_BYNAME_L0 + +SUBROUTINE IO_READ_FIELD_BYFIELD_L0(TPFILE,TPFIELD,OFIELD,KRESP) +! +USE MODD_IO_ll, ONLY : ISP,GSMONOPROC +! +TYPE(TFILEDATA), INTENT(IN) :: TPFILE +TYPE(TFIELDDATA), INTENT(INOUT) :: TPFIELD +LOGICAL, INTENT(INOUT) :: OFIELD ! array containing the data field +INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code +! +INTEGER :: IERR +INTEGER :: IRESP +! +CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYFIELD_L0',TRIM(TPFILE%CNAME)//': reading '//TRIM(TPFIELD%CMNHNAME)) +! +IRESP = 0 +! +CALL IO_FILE_READ_CHECK(TPFILE,'IO_READ_FIELD_BYFIELD_L0',IRESP) +! +IF (IRESP==0) THEN + IF (GSMONOPROC) THEN ! sequential execution + IF (TPFILE%CFORMAT=='NETCDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,OFIELD,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFI') THEN + CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,OFIELD,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,OFIELD,IRESP) + END IF + ELSE + IF (ISP == TPFILE%NMASTER_RANK) THEN + IF (TPFILE%CFORMAT=='NETCDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,OFIELD,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFI') THEN + CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,OFIELD,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,OFIELD,IRESP) + END IF + END IF + ! + CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + ! + !Broadcast header only if IRESP==-111 + !because metadata of field has been modified in IO_READ_FIELD_xxx + IF (IRESP==-111) CALL IO_BCAST_FIELD_METADATA(TPFILE,TPFIELD) + ! + CALL MPI_BCAST(OFIELD,1,MPI_LOGICAL,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + END IF +END IF +! +IF (IRESP==-111) IRESP = 0 !-111 is not really an error (metadata has changed) +! +IF (PRESENT(KRESP)) KRESP = IRESP +! +END SUBROUTINE IO_READ_FIELD_BYFIELD_L0 + + +SUBROUTINE IO_READ_FIELD_BYNAME_L1(TPFILE,HNAME,OFIELD,KRESP) +! +TYPE(TFILEDATA), INTENT(IN) :: TPFILE +CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write +LOGICAL,DIMENSION(:),INTENT(INOUT) :: OFIELD ! array containing the data field +INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code +! +INTEGER :: ID ! Index of the field +INTEGER :: IRESP ! return_code +! +CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYNAME_L1',TRIM(TPFILE%CNAME)//': reading '//TRIM(HNAME)) +! +CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) +! +IF(IRESP==0) CALL IO_READ_FIELD(TPFILE,TFIELDLIST(ID),OFIELD,IRESP) +! +IF (PRESENT(KRESP)) KRESP = IRESP +! +END SUBROUTINE IO_READ_FIELD_BYNAME_L1 + +SUBROUTINE IO_READ_FIELD_BYFIELD_L1(TPFILE,TPFIELD,OFIELD,KRESP) +! +USE MODD_IO_ll, ONLY : ISP,GSMONOPROC +! +TYPE(TFILEDATA), INTENT(IN) :: TPFILE +TYPE(TFIELDDATA), INTENT(INOUT) :: TPFIELD +LOGICAL,DIMENSION(:),INTENT(INOUT) :: OFIELD ! array containing the data field +INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code +! +INTEGER :: IERR +INTEGER :: IRESP +! +CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYFIELD_L1',TRIM(TPFILE%CNAME)//': reading '//TRIM(TPFIELD%CMNHNAME)) +! +IRESP = 0 +! +CALL IO_FILE_READ_CHECK(TPFILE,'IO_READ_FIELD_BYFIELD_L1',IRESP) +! +IF (IRESP==0) THEN + IF (GSMONOPROC) THEN ! sequential execution + IF (TPFILE%CFORMAT=='NETCDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,OFIELD,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFI') THEN + CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,OFIELD,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,OFIELD,IRESP) + END IF + ELSE + IF (ISP == TPFILE%NMASTER_RANK) THEN + IF (TPFILE%CFORMAT=='NETCDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,OFIELD,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFI') THEN + CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,OFIELD,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,OFIELD,IRESP) + END IF + END IF + ! + CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + ! + !Broadcast header only if IRESP==-111 + !because metadata of field has been modified in IO_READ_FIELD_xxx + IF (IRESP==-111) CALL IO_BCAST_FIELD_METADATA(TPFILE,TPFIELD) + ! + CALL MPI_BCAST(OFIELD,SIZE(OFIELD),MPI_LOGICAL,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + END IF +END IF +! +IF (IRESP==-111) IRESP = 0 !-111 is not really an error (metadata has changed) +! +IF (PRESENT(KRESP)) KRESP = IRESP +! +END SUBROUTINE IO_READ_FIELD_BYFIELD_L1 + + +SUBROUTINE IO_READ_FIELD_BYNAME_C0(TPFILE,HNAME,HFIELD,KRESP) +! +TYPE(TFILEDATA), INTENT(IN) :: TPFILE +CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write +CHARACTER(LEN=*), INTENT(INOUT) :: HFIELD ! array containing the data field +INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code +! +INTEGER :: ID ! Index of the field +INTEGER :: IRESP ! return_code +! +CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYNAME_C0',TRIM(TPFILE%CNAME)//': reading '//TRIM(HNAME)) +! +CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) +! +IF(IRESP==0) CALL IO_READ_FIELD(TPFILE,TFIELDLIST(ID),HFIELD,IRESP) +! +IF (PRESENT(KRESP)) KRESP = IRESP +! +END SUBROUTINE IO_READ_FIELD_BYNAME_C0 + +SUBROUTINE IO_READ_FIELD_BYFIELD_C0(TPFILE,TPFIELD,HFIELD,KRESP) +! +USE MODD_IO_ll, ONLY : ISP,GSMONOPROC +! +TYPE(TFILEDATA), INTENT(IN) :: TPFILE +TYPE(TFIELDDATA), INTENT(INOUT) :: TPFIELD +CHARACTER(LEN=*), INTENT(INOUT) :: HFIELD ! array containing the data field +INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code +! +INTEGER :: IERR +INTEGER :: IRESP +! +CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYFIELD_C0',TRIM(TPFILE%CNAME)//': reading '//TRIM(TPFIELD%CMNHNAME)) +! +IRESP = 0 +! +CALL IO_FILE_READ_CHECK(TPFILE,'IO_READ_FIELD_BYFIELD_C0',IRESP) +! +IF (IRESP==0) THEN + IF (GSMONOPROC) THEN ! sequential execution + IF (TPFILE%CFORMAT=='NETCDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,HFIELD,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFI') THEN + CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,HFIELD,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,HFIELD,IRESP) + END IF + ELSE + IF (ISP == TPFILE%NMASTER_RANK) THEN + IF (TPFILE%CFORMAT=='NETCDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,HFIELD,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFI') THEN + CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,HFIELD,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,HFIELD,IRESP) + END IF + END IF + ! + CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + ! + !Broadcast header only if IRESP==-111 + !because metadata of field has been modified in IO_READ_FIELD_xxx + IF (IRESP==-111) CALL IO_BCAST_FIELD_METADATA(TPFILE,TPFIELD) + ! + CALL MPI_BCAST(HFIELD,LEN(HFIELD),MPI_CHARACTER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + END IF +END IF +! +IF (IRESP==-111) IRESP = 0 !-111 is not really an error (metadata has changed) +! +IF (PRESENT(KRESP)) KRESP = IRESP +! +END SUBROUTINE IO_READ_FIELD_BYFIELD_C0 + + +SUBROUTINE IO_READ_FIELD_BYNAME_T0(TPFILE,HNAME,TPDATA,KRESP) +! +TYPE(TFILEDATA), INTENT(IN) :: TPFILE +CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write +TYPE (DATE_TIME), INTENT(INOUT) :: TPDATA ! array containing the data field +INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code +! +INTEGER :: ID ! Index of the field +INTEGER :: IRESP ! return_code +! +CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYNAME_T0',TRIM(TPFILE%CNAME)//': reading '//TRIM(HNAME)) +! +CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) +! +IF(IRESP==0) CALL IO_READ_FIELD(TPFILE,TFIELDLIST(ID),TPDATA,IRESP) +! +IF (PRESENT(KRESP)) KRESP = IRESP +! +END SUBROUTINE IO_READ_FIELD_BYNAME_T0 + +SUBROUTINE IO_READ_FIELD_BYFIELD_T0(TPFILE,TPFIELD,TPDATA,KRESP) +! +USE MODD_IO_ll, ONLY : ISP,GSMONOPROC +! +TYPE(TFILEDATA), INTENT(IN) :: TPFILE +TYPE(TFIELDDATA), INTENT(INOUT) :: TPFIELD +TYPE (DATE_TIME), INTENT(INOUT) :: TPDATA ! array containing the data field +INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code +! +INTEGER :: IERR +INTEGER :: IRESP +INTEGER,DIMENSION(3) :: ITDATE +! +CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYFIELD_T0',TRIM(TPFILE%CNAME)//': reading '//TRIM(TPFIELD%CMNHNAME)) +! +IRESP = 0 +! +CALL IO_FILE_READ_CHECK(TPFILE,'IO_READ_FIELD_BYFIELD_T0',IRESP) +! +IF (IRESP==0) THEN + IF (GSMONOPROC) THEN ! sequential execution + IF (TPFILE%CFORMAT=='NETCDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,TPDATA,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFI') THEN + CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,TPDATA,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,TPDATA,IRESP) + END IF + ELSE + IF (ISP == TPFILE%NMASTER_RANK) THEN + IF (TPFILE%CFORMAT=='NETCDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,TPDATA,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFI') THEN + CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,TPDATA,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,TPDATA,IRESP) + END IF + ITDATE(1) = TPDATA%TDATE%YEAR + ITDATE(2) = TPDATA%TDATE%MONTH + ITDATE(3) = TPDATA%TDATE%DAY + END IF + ! + CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + ! + !Broadcast header only if IRESP==-111 + !because metadata of field has been modified in IO_READ_FIELD_xxx + IF (IRESP==-111) CALL IO_BCAST_FIELD_METADATA(TPFILE,TPFIELD) + ! + CALL MPI_BCAST(ITDATE, 3,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + CALL MPI_BCAST(TPDATA%TIME,1,MPI_FLOAT, TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + TPDATA%TDATE%YEAR = ITDATE(1) + TPDATA%TDATE%MONTH = ITDATE(2) + TPDATA%TDATE%DAY = ITDATE(3) + END IF +END IF +! +IF (IRESP==-111) IRESP = 0 !-111 is not really an error (metadata has changed) +! +IF (PRESENT(KRESP)) KRESP = IRESP +! +END SUBROUTINE IO_READ_FIELD_BYFIELD_T0 + + +SUBROUTINE IO_READ_FIELD_BYNAME_LB(TPFILE,HNAME,KL3D,KRIM,PLB,KRESP) +! +TYPE(TFILEDATA), INTENT(IN) :: TPFILE +CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write +INTEGER, INTENT(IN) :: KL3D ! size of the LB array in FM +INTEGER, INTENT(IN) :: KRIM ! size of the LB area +REAL, DIMENSION(:,:,:),TARGET, INTENT(INOUT) :: PLB ! array containing the LB field +INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code + +INTEGER :: ID ! Index of the field +INTEGER :: IRESP ! return_code +! +CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYNAME_LB',TRIM(TPFILE%CNAME)//': reading '//TRIM(HNAME)) +! +CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) +! +IF(IRESP==0) CALL IO_READ_FIELD_LB(TPFILE,TFIELDLIST(ID),KL3D,KRIM,PLB,IRESP) +! +IF (PRESENT(KRESP)) KRESP = IRESP +! +END SUBROUTINE IO_READ_FIELD_BYNAME_LB + +SUBROUTINE IO_READ_FIELD_BYFIELD_LB(TPFILE,TPFIELD,KL3D,KRIM,PLB,KRESP) +! +USE MODD_IO_ll, ONLY : ISP,ISNPROC,GSMONOPROC,LPACK,L2D +USE MODD_PARAMETERS_ll,ONLY : JPHEXT +USE MODD_TIMEZ, ONLY : TIMEZ +USE MODD_VAR_ll, ONLY : MNH_STATUSES_IGNORE +! +USE MODE_DISTRIB_LB +USE MODE_MNH_TIMING, ONLY : SECOND_MNH2 +USE MODE_TOOLS_ll, ONLY : GET_GLOBALDIMS_ll +! +TYPE(TFILEDATA), INTENT(IN) :: TPFILE +TYPE(TFIELDDATA), INTENT(INOUT) :: TPFIELD +INTEGER, INTENT(IN) :: KL3D ! size of the LB array in FM +INTEGER, INTENT(IN) :: KRIM ! size of the LB area +REAL, DIMENSION(:,:,:),TARGET, INTENT(INOUT) :: PLB ! array containing the LB field +INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code +! +!* 0.2 Declarations of local variables +! +TYPE TX_3DP + REAL,DIMENSION(:,:,:), POINTER :: X +END TYPE +! +CHARACTER(LEN=4) :: YLBTYPE ! 'LBX','LBXU','LBY' or 'LBYV' +INTEGER :: IERR,IRESP +INTEGER :: IHEXTOT +INTEGER :: IIMAX_ll,IJMAX_ll +INTEGER :: IIB,IIE,IJB,IJE +INTEGER :: JI +INTEGER :: NB_REQ,IKU +INTEGER, DIMENSION(MPI_STATUS_SIZE) :: STATUS +INTEGER, ALLOCATABLE,DIMENSION(:,:) :: STATUSES +INTEGER,ALLOCATABLE,DIMENSION(:) :: REQ_TAB +REAL,DIMENSION(:,:,:),ALLOCATABLE,TARGET :: Z3D +REAL,DIMENSION(:,:,:), POINTER :: TX3DP +REAL(KIND=8),DIMENSION(2) :: T0,T1,T2,T3 +REAL(KIND=8),DIMENSION(2) :: T11,T22 +TYPE(TX_3DP),ALLOCATABLE,DIMENSION(:) :: T_TX3DP +! +CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_READ_FIELD_BYFIELD_LB','reading '//TRIM(TPFIELD%CMNHNAME)) +! +YLBTYPE = TPFIELD%CLBTYPE +! +IF (YLBTYPE/='LBX' .AND. YLBTYPE/='LBXU' .AND. YLBTYPE/='LBY' .AND. YLBTYPE/='LBYV') THEN + CALL PRINT_MSG(NVERB_ERROR,'IO','IO_READ_FIELD_BYFIELD_LB',TRIM(TPFILE%CNAME)//': invalid CLBTYPE (' & + //TRIM(TPFIELD%CLBTYPE)//') for '//TRIM(TPFIELD%CMNHNAME)) + RETURN +END IF +! +!* 1.1 THE NAME OF LFIFM +! +CALL SECOND_MNH2(T11) +IRESP = 0 +!------------------------------------------------------------------ +IHEXTOT = 2*JPHEXT+1 +CALL IO_FILE_READ_CHECK(TPFILE,'IO_READ_FIELD_BYFIELD_LB',IRESP) +! +IF (IRESP==0) THEN + IF (GSMONOPROC) THEN ! sequential execution + IF (YLBTYPE == 'LBX' .OR. YLBTYPE == 'LBXU') THEN + ALLOCATE(Z3D(KL3D,SIZE(PLB,2),SIZE(PLB,3))) + Z3D = 0.0 + IF (LPACK .AND. L2D) THEN + TX3DP=>Z3D(:,JPHEXT+1:JPHEXT+1,:) + ELSE + TX3DP => Z3D(:,:,:) + END IF + ELSE !(YLBTYPE == 'LBY' .OR. YLBTYPE == 'LBYV') + ALLOCATE(Z3D(SIZE(PLB,1),KL3D,SIZE(PLB,3))) + Z3D = 0.0 + TX3DP => Z3D(:,:,:) + END IF + IF (TPFILE%CFORMAT=='NETCDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,TX3DP,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFI') THEN + CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,TX3DP,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,TX3DP,IRESP) + END IF + IF (YLBTYPE == 'LBX' .OR. YLBTYPE == 'LBXU') THEN + IF (LPACK .AND. L2D) Z3D(:,:,:) = SPREAD(Z3D(:,JPHEXT+1,:),DIM=2,NCOPIES=IHEXTOT) + PLB(1:KRIM+JPHEXT,:,:) = Z3D(1:KRIM+JPHEXT,:,:) + PLB(KRIM+JPHEXT+1:2*(KRIM+JPHEXT),:,:) = Z3D(KL3D-KRIM-JPHEXT+1:KL3D,:,:) + ELSE !(YLBTYPE == 'LBY' .OR. YLBTYPE == 'LBYV') + PLB(:,1:KRIM+JPHEXT,:) = Z3D(:,1:KRIM+JPHEXT,:) + PLB(:,KRIM+JPHEXT+1:2*(KRIM+JPHEXT),:) = Z3D(:,KL3D-KRIM-JPHEXT+1:KL3D,:) + END IF + ELSE ! multiprocesses execution + IF (ISP == TPFILE%NMASTER_RANK) THEN + CALL SECOND_MNH2(T0) + CALL GET_GLOBALDIMS_ll(IIMAX_ll,IJMAX_ll) + IF (YLBTYPE == 'LBX' .OR. YLBTYPE == 'LBXU') THEN + ALLOCATE(Z3D(KL3D,IJMAX_ll+2*JPHEXT,SIZE(PLB,3))) + Z3D = 0.0 + IF (LPACK .AND. L2D) THEN + TX3DP=>Z3D(:,JPHEXT+1:JPHEXT+1,:) + ELSE + TX3DP => Z3D(:,:,:) + END IF + ELSE !(YLBTYPE == 'LBY' .OR. YLBTYPE == 'LBYV') + ALLOCATE(Z3D(IIMAX_ll+2*JPHEXT,KL3D,SIZE(PLB,3))) + Z3D = 0.0 + TX3DP => Z3D(:,:,:) + END IF + IF (TPFILE%CFORMAT=='NETCDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,TX3DP,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFI') THEN + CALL IO_READ_FIELD_LFI(TPFILE,TPFIELD,TX3DP,IRESP) + ELSE IF (TPFILE%CFORMAT=='LFICDF4') THEN + CALL IO_READ_FIELD_NC4(TPFILE,TPFIELD,TX3DP,IRESP) + END IF + IF (YLBTYPE == 'LBX' .OR. YLBTYPE == 'LBXU') THEN + IF (LPACK .AND. L2D) Z3D(:,:,:) = SPREAD(Z3D(:,JPHEXT+1,:),DIM=2,NCOPIES=IHEXTOT) + ! erase gap in LB field + Z3D(KRIM+JPHEXT+1:2*(KRIM+JPHEXT),:,:) = Z3D(KL3D-KRIM-JPHEXT+1:KL3D,:,:) + ELSE !(YLBTYPE == 'LBY' .OR. YLBTYPE == 'LBYV') + ! erase gap in LB field + Z3D(:,KRIM+JPHEXT+1:2*(KRIM+JPHEXT),:) = Z3D(:,KL3D-KRIM-JPHEXT+1:KL3D,:) + END IF + CALL SECOND_MNH2(T1) + TIMEZ%T_READLB_READ=TIMEZ%T_READLB_READ + T1 - T0 + END IF + ! + CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + ! + !Broadcast header only if IRESP==-111 + !because metadata of field has been modified in IO_READ_FIELD_xxx + IF (IRESP==-111) CALL IO_BCAST_FIELD_METADATA(TPFILE,TPFIELD) + ! + NB_REQ=0 + ALLOCATE(REQ_TAB(ISNPROC-1)) + !REQ_TAB=MPI_REQUEST_NULL + IF (ISP == TPFILE%NMASTER_RANK) THEN + CALL SECOND_MNH2(T1) + !ALLOCATE(REQ_TAB(ISNPROC-1)) + !REQ_TAB=MPI_REQUEST_NULL + ALLOCATE(T_TX3DP(ISNPROC-1)) + IKU = SIZE(Z3D,3) + DO JI = 1,ISNPROC + CALL GET_DISTRIB_LB(YLBTYPE,JI,'FM','READ',KRIM,IIB,IIE,IJB,IJE) + IF (IIB /= 0) THEN + TX3DP=>Z3D(IIB:IIE,IJB:IJE,:) + IF (ISP /= JI) THEN + NB_REQ = NB_REQ + 1 + ALLOCATE(T_TX3DP(NB_REQ)%X(IIB:IIE,IJB:IJE,IKU)) + T_TX3DP(NB_REQ)%X=Z3D(IIB:IIE,IJB:IJE,:) + CALL MPI_ISEND(T_TX3DP(NB_REQ)%X,SIZE(TX3DP),MPI_FLOAT,JI-1,99,TPFILE%NMPICOMM,REQ_TAB(NB_REQ),IERR) + !CALL MPI_BSEND(T_TX3DP(NB_REQ)%X,SIZE(TX3DP),MPI_FLOAT,JI-1,99,TPFILE%NMPICOMM,IERR) + ELSE + CALL GET_DISTRIB_LB(YLBTYPE,JI,'LOC','READ',KRIM,IIB,IIE,IJB,IJE) + PLB(IIB:IIE,IJB:IJE,:) = TX3DP(:,:,:) + END IF + END IF + END DO + CALL SECOND_MNH2(T2) + TIMEZ%T_READLB_SEND=TIMEZ%T_READLB_SEND + T2 - T1 + IF (NB_REQ .GT.0 ) THEN + !ALLOCATE(STATUSES(MPI_STATUS_SIZE,NB_REQ)) + !CALL MPI_WAITALL(NB_REQ,REQ_TAB,STATUSES,IERR) + CALL MPI_WAITALL(NB_REQ,REQ_TAB,MNH_STATUSES_IGNORE,IERR) + !DEALLOCATE(STATUSES) + DO JI=1,NB_REQ ; DEALLOCATE(T_TX3DP(JI)%X) ; ENDDO + END IF + DEALLOCATE(T_TX3DP) + !DEALLOCATE(REQ_TAB) + CALL SECOND_MNH2(T3) + TIMEZ%T_READLB_WAIT=TIMEZ%T_READLB_WAIT + T3 - T2 + ELSE + CALL SECOND_MNH2(T0) + !ALLOCATE(REQ_TAB(1)) + !REQ_TAB=MPI_REQUEST_NULL + CALL GET_DISTRIB_LB(YLBTYPE,ISP,'LOC','READ',KRIM,IIB,IIE,IJB,IJE) + IF (IIB /= 0) THEN + TX3DP=>PLB(IIB:IIE,IJB:IJE,:) + CALL MPI_RECV(TX3DP,SIZE(TX3DP),MPI_FLOAT,TPFILE%NMASTER_RANK-1,99,TPFILE%NMPICOMM,STATUS,IERR) + !NB_REQ = NB_REQ + 1 + !CALL MPI_IRECV(TX3DP,SIZE(TX3DP),MPI_FLOAT,TPFILE%NMASTER_RANK-1,99,TPFILE%NMPICOMM,REQ_TAB(NB_REQ),IERR) + !IF (NB_REQ .GT.0 ) CALL MPI_WAITALL(NB_REQ,REQ_TAB,MNH_STATUSES_IGNORE,IERR) + END IF + CALL SECOND_MNH2(T1) + TIMEZ%T_READLB_RECV=TIMEZ%T_READLB_RECV + T1 - T0 + END IF + DEALLOCATE(REQ_TAB) + END IF !(GSMONOPROC) +END IF +!---------------------------------------------------------------- +! +IF (ALLOCATED(Z3D)) DEALLOCATE (Z3D) +! +IF (IRESP==-111) IRESP = 0 !-111 is not really an error (metadata has changed) +! +IF (PRESENT(KRESP)) KRESP = IRESP +! +CALL SECOND_MNH2(T22) +TIMEZ%T_READLB_ALL=TIMEZ%T_READLB_ALL + T22 - T11 +! +END SUBROUTINE IO_READ_FIELD_BYFIELD_LB + +END MODULE MODE_FMREAD diff --git a/src/LIB/SURCOUCHE/src/fmwrit_ll.f90 b/src/LIB/SURCOUCHE/src/fmwrit_ll.f90 index 303a081fd4eea1020ad36eb14b827756b83cdf21..66f9e704e57869bad0e879cac7076adb270904d9 100644 --- a/src/LIB/SURCOUCHE/src/fmwrit_ll.f90 +++ b/src/LIB/SURCOUCHE/src/fmwrit_ll.f90 @@ -1,2722 +1,2722 @@ -!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier -!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence -!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt -!MNH_LIC for details. version 1. -!----------------------------------------------------------------- -!--------------- special set of characters for CVS information -!----------------------------------------------------------------- -! $Source$ -! $Name$ -! $Revision$ -! $Date$ -!----------------------------------------------------------------- -!Correction : -! J.Escobar : 15/09/2015 : WENO5 & JPHEXT <> 1 -!----------------------------------------------------------------- - -#ifdef MNH_MPI_DOUBLE_PRECISION -#define MPI_FLOAT MPI_DOUBLE_PRECISION -#else -#define MPI_FLOAT MPI_REAL -#endif - -#ifdef MNH_GA -MODULE MODE_GA -#include "mafdecls.fh" -#include "global.fh" - ! - ! Global Array Variables - ! - INTEGER, PARAMETER :: jpix=1 , jpiy = 2 , jpiz = 3 - ! - INTEGER :: NIMAX_ll,NJMAX_ll, IIU_ll,IJU_ll,IKU_ll - integer :: heap=5*10**6, stack - logical :: gstatus_ga - INTEGER, PARAMETER :: ndim_GA = 3 - INTEGER, DIMENSION(ndim_GA) :: dims_GA , chunk_GA - INTEGER,PARAMETER :: CI=1 ,CJ=-1 ,CK=-1 - INTEGER :: g_a - integer, DIMENSION(ndim_GA) :: lo_col, hi_col , ld_col - integer, DIMENSION(ndim_GA) :: lo_zplan , hi_zplan , ld_zplan - INTEGER :: NIXO_L,NIXE_L,NIYO_L,NIYE_L - INTEGER :: NIXO_G,NIXE_G,NIYO_G,NIYE_G - - LOGICAL,SAVE :: GFIRST_GA = .TRUE. - INTEGER :: IIU_ll_MAX = -1, IJU_ll_MAX = -1, IKU_ll_MAX = -1 - - CONTAINS - - SUBROUTINE MNH_INIT_GA(MY_NI,MY_NJ,MY_NK,HRECFM,HRW_MODE) - -! -! Modification -! J.Escobar 5/02/2015 : use JPHEXT from MODD_PARAMETERS_ll - - USE MODE_TOOLS_ll, ONLY : GET_GLOBALDIMS_ll - USE MODD_PARAMETERS_ll, ONLY : JPHEXT - USE MODD_IO_ll, ONLY : ISP - USE MODE_GATHER_ll, ONLY : GET_DOMWRITE_ll - USE MODE_SCATTER_ll, ONLY : GET_DOMREAD_ll - - IMPLICIT NONE - - INTEGER, INTENT(IN) :: MY_NI,MY_NJ,MY_NK - CHARACTER(LEN=*), INTENT(IN) :: HRECFM ! name of the article to write - CHARACTER(LEN=*), INTENT(IN) :: HRW_MODE - - IF ( GFIRST_GA ) THEN - GFIRST_GA = .FALSE. - ! - ! Allocate memory for GA library - ! - stack = heap - !gstatus_ga = ma_init(MT_F_DBL, stack/ISNPROC, heap/ISNPROC) - gstatus_ga = ma_init(MT_F_DBL, stack, heap) - if ( .not. gstatus_ga ) STOP " MA_INIT FAILED " - ! - ! Initialize GA library - ! - !call ga_initialize_ltd(100000000) - call ga_initialize() - END IF - - CALL GET_GLOBALDIMS_ll (NIMAX_ll,NJMAX_ll) - IIU_ll = NIMAX_ll + 2*JPHEXT - IJU_ll = NJMAX_ll + 2*JPHEXT - IKU_ll = MY_NK - ! - ! configure Global array dimensions - ! - dims_GA(JPIX) = IIU_ll - dims_GA(JPIY) = IJU_ll - dims_GA(JPIZ) = IKU_ll - chunk_GA(JPIX) = CI - chunk_GA(JPIY) = CJ - chunk_GA(JPIZ) = CK - IF ( CI .EQ. 1 ) chunk_GA(JPIX) = dims_GA(JPIX) ! 1 block in X direction - IF ( CJ .EQ. 1 ) chunk_GA(JPIY) = dims_GA(JPIY) ! 1 block in Y direction - IF ( CK .EQ. 1 ) chunk_GA(JPIZ) = dims_GA(JPIZ) ! 1 block in Z direction - ! - ! (re)create global array g_a ( if to small create it ... ) - ! - IF ( ( IIU_ll .GT. IIU_ll_MAX ) .OR. ( IJU_ll .GT. IJU_ll_MAX ) .OR. ( IKU_ll .GT. IKU_ll_MAX ) ) THEN - ! - ! reallocate the g_a , if need with bigger Z size - ! - IF ( IKU_ll_MAX .NE. -1 ) gstatus_ga = ga_destroy(g_a) - IIU_ll_MAX = IIU_ll - IJU_ll_MAX = IJU_ll - IKU_ll_MAX = IKU_ll - gstatus_ga = nga_create(MT_F_DBL, ndim_GA, dims_GA, HRECFM ,chunk_GA, g_a) - call ga_sync() - END IF - !----------------------------------------------------------------------! - ! ! - ! Define/describe local column data owned by this process to write ! - ! ! - !----------------------------------------------------------------------! - IF ( HRW_MODE .EQ. "WRITE" ) THEN - CALL GET_DOMWRITE_ll(ISP,'local',NIXO_L,NIXE_L,NIYO_L,NIYE_L) - CALL GET_DOMWRITE_ll(ISP,'global',NIXO_G,NIXE_G,NIYO_G,NIYE_G) - ELSE - CALL GET_DOMREAD_ll(ISP,NIXO_L,NIXE_L,NIYO_L,NIYE_L) - CALL GET_DOMREAD_ll(ISP,NIXO_G,NIXE_G,NIYO_G,NIYE_G) - END IF - ! - ! portion of data to write/put | read/get by this proc - ! - lo_col(JPIX) = NIXO_G - hi_col(JPIX) = NIXE_G - - lo_col(JPIY) = NIYO_G - hi_col(JPIY) = NIYE_G - - lo_col(JPIZ) = 1 - hi_col(JPIZ) = IKU_ll - ! - ! declaration size of this local input column array - ! - ld_col(JPIX) = MY_NI - ld_col(JPIY) = MY_NJ - ld_col(JPIZ) = MY_NK - ! - !-----------------------------------------------------! - ! ! - ! Size of local ZSLICE_ll Write buffer on I/O proc ! - ! ! - !-----------------------------------------------------! - ! - ! declared dimension - ! - ld_zplan(JPIX) = IIU_ll - ld_zplan(JPIY) = IJU_ll - ld_zplan(JPIZ) = 1 - ! - ! write data by Z slide by I/O proc - ! - lo_zplan(JPIX:JPIY) = 1 - hi_zplan(JPIX) = IIU_ll - hi_zplan(JPIY) = IJU_ll - !call ga_sync() - ! - END SUBROUTINE MNH_INIT_GA - -END MODULE MODE_GA - -#endif - -MODULE MODE_FMWRIT - - USE MODD_MPIF - USE MODD_IO_ll, ONLY: TFILEDATA - - USE MODE_FIELD -#if defined(MNH_IOCDF4) - USE MODE_NETCDF -#endif - USE MODE_READWRITE_LFI - - IMPLICIT NONE - - PRIVATE - - INTERFACE IO_WRITE_FIELD - MODULE PROCEDURE IO_WRITE_FIELD_BYNAME_X0, IO_WRITE_FIELD_BYNAME_X1, & - IO_WRITE_FIELD_BYNAME_X2, IO_WRITE_FIELD_BYNAME_X3, & - IO_WRITE_FIELD_BYNAME_X4, IO_WRITE_FIELD_BYNAME_X5, & - IO_WRITE_FIELD_BYNAME_X6, & - IO_WRITE_FIELD_BYNAME_N0, IO_WRITE_FIELD_BYNAME_N1, & - IO_WRITE_FIELD_BYNAME_N2, IO_WRITE_FIELD_BYNAME_N3, & - IO_WRITE_FIELD_BYNAME_L0, IO_WRITE_FIELD_BYNAME_L1, & - IO_WRITE_FIELD_BYNAME_C0, IO_WRITE_FIELD_BYNAME_C1, & - IO_WRITE_FIELD_BYNAME_T0, & - IO_WRITE_FIELD_BYFIELD_X0,IO_WRITE_FIELD_BYFIELD_X1, & - IO_WRITE_FIELD_BYFIELD_X2,IO_WRITE_FIELD_BYFIELD_X3, & - IO_WRITE_FIELD_BYFIELD_X4,IO_WRITE_FIELD_BYFIELD_X5, & - IO_WRITE_FIELD_BYFIELD_X6, & - IO_WRITE_FIELD_BYFIELD_N0,IO_WRITE_FIELD_BYFIELD_N1, & - IO_WRITE_FIELD_BYFIELD_N2,IO_WRITE_FIELD_BYFIELD_N3, & - IO_WRITE_FIELD_BYFIELD_L0,IO_WRITE_FIELD_BYFIELD_L1, & - IO_WRITE_FIELD_BYFIELD_C0,IO_WRITE_FIELD_BYFIELD_C1, & - IO_WRITE_FIELD_BYFIELD_T0 - END INTERFACE - - INTERFACE IO_WRITE_FIELD_BOX - MODULE PROCEDURE IO_WRITE_FIELD_BOX_BYFIELD_X5 - END INTERFACE - - INTERFACE IO_WRITE_FIELD_LB - MODULE PROCEDURE IO_WRITE_FIELD_BYNAME_LB, IO_WRITE_FIELD_BYFIELD_LB - END INTERFACE - - PUBLIC IO_WRITE_FIELD, IO_WRITE_FIELD_BOX, IO_WRITE_FIELD_LB - PUBLIC IO_WRITE_HEADER - -CONTAINS - - SUBROUTINE FIELD_METADATA_CHECK(TPFIELD,KTYPE,KDIMS,HCALLER) - TYPE(TFIELDDATA), INTENT(IN) :: TPFIELD ! Field to check - INTEGER, INTENT(IN) :: KTYPE ! Expected datatype - INTEGER, INTENT(IN) :: KDIMS ! Expected number of dimensions - CHARACTER(LEN=*), INTENT(IN) :: HCALLER ! name of the calling subroutine - ! - CHARACTER(LEN=2) :: YDIMOK,YDIMKO - CHARACTER(LEN=8) :: YTYPEOK,YTYPEKO - ! - IF (TPFIELD%NGRID<0 .OR. TPFIELD%NGRID>8) THEN - CALL PRINT_MSG(NVERB_WARNING,'IO',HCALLER,'TPFIELD%NGRID is invalid for '//TRIM(TPFIELD%CMNHNAME)) - END IF - IF (TPFIELD%NTYPE/=KTYPE) THEN - CALL TYPE_WRITE(KTYPE,YTYPEOK) - CALL TYPE_WRITE(TPFIELD%NTYPE,YTYPEKO) - CALL PRINT_MSG(NVERB_WARNING,'IO',HCALLER,& - 'TPFIELD%NTYPE should be '//YTYPEOK//' instead of '//YTYPEKO//' for '//TRIM(TPFIELD%CMNHNAME)) - END IF - IF (TPFIELD%NDIMS/=KDIMS) THEN - WRITE (YDIMOK,'(I2)') KDIMS - WRITE (YDIMKO,'(I2)') TPFIELD%NDIMS - CALL PRINT_MSG(NVERB_WARNING,'IO',HCALLER,& - 'TPFIELD%NDIMS should be '//YDIMOK//' instead of '//YDIMKO//' for '//TRIM(TPFIELD%CMNHNAME)) - END IF - ! - CONTAINS - SUBROUTINE TYPE_WRITE(KTYPEINT,HTYPE) - INTEGER, INTENT(IN) :: KTYPEINT - CHARACTER(LEN=8),INTENT(OUT) :: HTYPE - ! - SELECT CASE(KTYPEINT) - CASE(TYPEINT) - HTYPE = 'TYPEINT' - CASE(TYPELOG) - HTYPE = 'TYPELOG' - CASE(TYPEREAL) - HTYPE = 'TYPEREAL' - CASE(TYPECHAR) - HTYPE = 'TYPECHAR' - CASE(TYPEDATE) - HTYPE = 'TYPEDATE' - CASE DEFAULT - HTYPE = 'UNKNOWN' - END SELECT - ! - END SUBROUTINE TYPE_WRITE - END SUBROUTINE FIELD_METADATA_CHECK - - - SUBROUTINE IO_FILE_WRITE_CHECK(TPFILE,HSUBR,KRESP) - TYPE(TFILEDATA), INTENT(IN) :: TPFILE - CHARACTER(LEN=*), INTENT(IN) :: HSUBR - INTEGER, INTENT(OUT) :: KRESP - ! - KRESP = 0 - ! - !Check if file is opened - IF (.NOT.TPFILE%LOPENED) THEN - CALL PRINT_MSG(NVERB_ERROR,'IO',HSUBR,TRIM(TPFILE%CNAME)//' is not opened') - KRESP = -201 - RETURN - END IF - ! - !Check if file is in the right opening mode - IF (TPFILE%CMODE/='WRITE') THEN - CALL PRINT_MSG(NVERB_WARNING,'IO',HSUBR,& - TRIM(TPFILE%CNAME)//': writing in a file opened in '//TRIM(TPFILE%CMODE)//' mode') - END IF - ! - !Check fileformat - IF (TPFILE%CFORMAT/='NETCDF4' .AND. TPFILE%CFORMAT=='LFI' .AND. TPFILE%CFORMAT=='LFICDF4') THEN - CALL PRINT_MSG(NVERB_FATAL,'IO',HSUBR,& - TRIM(TPFILE%CNAME)//': invalid fileformat ('//TRIM(TPFILE%CFORMAT)//')') - KRESP = -202 - RETURN - END IF - ! - END SUBROUTINE IO_FILE_WRITE_CHECK - - - SUBROUTINE IO_WRITE_HEADER(TPFILE,HDAD_NAME) - ! - USE MODD_CONF - USE MODD_CONF_n, ONLY: CSTORAGE_TYPE - USE MODD_PARAMETERS, ONLY: NFILENAMELGTMAXLFI - ! - TYPE(TFILEDATA), INTENT(IN) :: TPFILE ! File structure - CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: HDAD_NAME - ! - CHARACTER(LEN=:),ALLOCATABLE :: YDAD_NAME - INTEGER :: ILEN - ! - CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_HEADER','called for file '//TRIM(TPFILE%CNAME)) - ! - IF ( ASSOCIATED(TPFILE%TDADFILE) .AND. PRESENT(HDAD_NAME) ) THEN - IF ( TRIM(TPFILE%TDADFILE%CNAME) /= TRIM(HDAD_NAME) ) THEN - CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_HEADER','TPFILE%TDADFILE%CNAME /= HDAD_NAME') - END IF - END IF - ! - CALL IO_WRITE_HEADER_NC4(TPFILE) - ! - CALL IO_WRITE_FIELD(TPFILE,'MNHVERSION', NMNHVERSION) - CALL IO_WRITE_FIELD(TPFILE,'MASDEV', NMASDEV) - CALL IO_WRITE_FIELD(TPFILE,'BUGFIX', NBUGFIX) - CALL IO_WRITE_FIELD(TPFILE,'BIBUSER', CBIBUSER) - CALL IO_WRITE_FIELD(TPFILE,'PROGRAM', CPROGRAM) - CALL IO_WRITE_FIELD(TPFILE,'STORAGE_TYPE',CSTORAGE_TYPE) - CALL IO_WRITE_FIELD(TPFILE,'MY_NAME', TPFILE%CNAME) - ! - IF ( ASSOCIATED(TPFILE%TDADFILE) ) THEN - ALLOCATE(CHARACTER(LEN=MAX(NFILENAMELGTMAXLFI,LEN_TRIM(TPFILE%TDADFILE%CNAME))) :: YDAD_NAME) - YDAD_NAME(:) = TPFILE%TDADFILE%CNAME - ELSE IF (PRESENT(HDAD_NAME)) THEN - ILEN = LEN_TRIM(HDAD_NAME) - ALLOCATE(CHARACTER(LEN=MAX(NFILENAMELGTMAXLFI,ILEN)) :: YDAD_NAME) - YDAD_NAME(:) = HDAD_NAME - ELSE - CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_HEADER',TRIM(TPFILE%CNAME)// & - ': TPFILE%TDADFILE not associated and HDAD_NAME not provided') - ALLOCATE(CHARACTER(LEN=NFILENAMELGTMAXLFI) :: YDAD_NAME) - YDAD_NAME(:) = ' ' - ENDIF - CALL IO_WRITE_FIELD(TPFILE,'DAD_NAME',YDAD_NAME) - DEALLOCATE(YDAD_NAME) - ! - END SUBROUTINE IO_WRITE_HEADER - - - SUBROUTINE IO_WRITE_FIELD_BYNAME_X0(TPFILE,HNAME,PFIELD,KRESP) - ! - !* 0.1 Declarations of arguments - ! - TYPE(TFILEDATA), INTENT(IN) :: TPFILE - CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write - REAL, INTENT(IN) :: PFIELD ! array containing the data field - INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code - ! - !* 0.2 Declarations of local variables - ! - INTEGER :: ID ! Index of the field - INTEGER :: IRESP ! return_code - ! - CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYNAME_X0',TRIM(TPFILE%CNAME)//': writing '//TRIM(HNAME)) - ! - CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) - ! - IF(IRESP==0) CALL IO_WRITE_FIELD(TPFILE,TFIELDLIST(ID),PFIELD,IRESP) - ! - IF (PRESENT(KRESP)) KRESP = IRESP - ! - END SUBROUTINE IO_WRITE_FIELD_BYNAME_X0 - - - SUBROUTINE IO_WRITE_FIELD_BYFIELD_X0(TPFILE,TPFIELD,PFIELD,KRESP) - USE MODD_IO_ll - ! - USE MODE_IO_MANAGE_STRUCT, ONLY: IO_FILE_FIND_BYNAME - ! - IMPLICIT NONE - ! - !* 0.1 Declarations of arguments - ! - TYPE(TFILEDATA), INTENT(IN) :: TPFILE - TYPE(TFIELDDATA), INTENT(IN) :: TPFIELD - REAL,TARGET, INTENT(IN) :: PFIELD ! array containing the data field - INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code - ! - !* 0.2 Declarations of local variables - ! - CHARACTER(LEN=28) :: YFILEM ! FM-file name - CHARACTER(LEN=NMNHNAMELGTMAX) :: YRECFM ! name of the article to write - CHARACTER(LEN=2) :: YDIR ! field form - INTEGER :: IERR - INTEGER :: IRESP - ! - INTEGER :: IK_FILE - TYPE(TFILEDATA),POINTER :: TZFILE - CHARACTER(LEN=:),ALLOCATABLE :: YMSG - CHARACTER(LEN=6) :: YRESP - ! - YFILEM = TPFILE%CNAME - YRECFM = TPFIELD%CMNHNAME - YDIR = TPFIELD%CDIR - ! - IRESP = 0 - TZFILE => NULL() - ! - CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYFIELD_X0',TRIM(YFILEM)//': writing '//TRIM(YRECFM)) - ! - CALL FIELD_METADATA_CHECK(TPFIELD,TYPEREAL,0,'IO_WRITE_FIELD_BYFIELD_X0') - ! - CALL IO_FILE_WRITE_CHECK(TPFILE,'IO_WRITE_FIELD_BYFIELD_X0',IRESP) - ! - IF (IRESP==0) THEN - IF (GSMONOPROC) THEN ! sequential execution - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,PFIELD,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,PFIELD,IRESP) - ELSE ! multiprocesses execution - IF (ISP == TPFILE%NMASTER_RANK) THEN - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,PFIELD,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,PFIELD,IRESP) - END IF - ! - CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - END IF ! multiprocesses execution - IF (TPFILE%NSUBFILES_IOZ>0) THEN - ! write the data in all Z files - DO IK_FILE=1,TPFILE%NSUBFILES_IOZ - TZFILE => TPFILE%TFILES_IOZ(IK_FILE)%TFILE - IF ( ISP == TZFILE%NMASTER_RANK ) THEN - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TZFILE,TPFIELD,PFIELD,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TZFILE,TPFIELD,PFIELD,IRESP) - END IF - END DO - ENDIF - END IF - ! - IF (IRESP.NE.0) THEN - WRITE(YRESP, '( I6 )') IRESP - YMSG = 'RESP='//YRESP//' when writing '//TRIM(YRECFM)//' in '//TRIM(TPFILE%CNAME) - CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_FIELD_BYFIELD_X0',YMSG) - END IF - IF (PRESENT(KRESP)) KRESP = IRESP - END SUBROUTINE IO_WRITE_FIELD_BYFIELD_X0 - - - SUBROUTINE IO_WRITE_FIELD_BYNAME_X1(TPFILE,HNAME,PFIELD,KRESP) - ! - USE MODD_IO_ll, ONLY : TFILEDATA - ! - !* 0.1 Declarations of arguments - ! - TYPE(TFILEDATA), INTENT(IN) :: TPFILE - CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write - REAL,DIMENSION(:), INTENT(IN) :: PFIELD ! array containing the data field - INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code - ! - !* 0.2 Declarations of local variables - ! - INTEGER :: ID ! Index of the field - INTEGER :: IRESP ! return-code - ! - CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYNAME_X1',TRIM(TPFILE%CNAME)//': writing '//TRIM(HNAME)) - ! - CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) - ! - IF(IRESP==0) CALL IO_WRITE_FIELD(TPFILE,TFIELDLIST(ID),PFIELD,IRESP) - ! - IF (PRESENT(KRESP)) KRESP = IRESP - ! - END SUBROUTINE IO_WRITE_FIELD_BYNAME_X1 - - - SUBROUTINE IO_WRITE_FIELD_BYFIELD_X1(TPFILE,TPFIELD,PFIELD,KRESP) - USE MODD_IO_ll - ! - USE MODE_ALLOCBUFFER_ll - USE MODE_GATHER_ll - USE MODE_IO_MANAGE_STRUCT, ONLY: IO_FILE_FIND_BYNAME - ! - IMPLICIT NONE - ! - !* 0.1 Declarations of arguments - ! - TYPE(TFILEDATA), INTENT(IN) :: TPFILE - TYPE(TFIELDDATA), INTENT(IN) :: TPFIELD - REAL,DIMENSION(:),TARGET, INTENT(IN) :: PFIELD ! array containing the data field - INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code - ! - !* 0.2 Declarations of local variables - ! - CHARACTER(LEN=28) :: YFILEM ! FM-file name - CHARACTER(LEN=NMNHNAMELGTMAX) :: YRECFM ! name of the article to write - CHARACTER(LEN=2) :: YDIR ! field form - INTEGER :: IERR - INTEGER :: IRESP - INTEGER :: ISIZEMAX - REAL,DIMENSION(:),POINTER :: ZFIELDP - LOGICAL :: GALLOC - ! - CHARACTER(LEN=:),ALLOCATABLE :: YMSG - CHARACTER(LEN=6) :: YRESP - ! - IRESP = 0 - GALLOC = .FALSE. - ! - YFILEM = TPFILE%CNAME - YRECFM = TPFIELD%CMNHNAME - YDIR = TPFIELD%CDIR - ! - CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYFIELD_X1',TRIM(YFILEM)//': writing '//TRIM(YRECFM)) - ! - CALL FIELD_METADATA_CHECK(TPFIELD,TYPEREAL,1,'IO_WRITE_FIELD_BYFIELD_X1') - ! - CALL IO_FILE_WRITE_CHECK(TPFILE,'IO_WRITE_FIELD_BYFIELD_X1',IRESP) - ! - IF (IRESP==0) THEN - IF (GSMONOPROC) THEN ! sequential execution - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,PFIELD,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,PFIELD,IRESP) - ELSE ! multiprocesses execution -#ifndef MNH_INT8 - CALL MPI_ALLREDUCE(SIZE(PFIELD),ISIZEMAX,1,MPI_INTEGER,MPI_MAX,TPFILE%NMPICOMM,IRESP) -#else - CALL MPI_ALLREDUCE(SIZE(PFIELD),ISIZEMAX,1,MPI_INTEGER8,MPI_MAX,TPFILE%NMPICOMM,IRESP) -#endif - IF (ISIZEMAX==0) THEN - CALL PRINT_MSG(NVERB_INFO,'IO','IO_WRITE_FIELD_BYFIELD_X1','ignoring variable with a zero size ('//TRIM(YRECFM)//')') - IF (PRESENT(KRESP)) KRESP=0 - RETURN - END IF - - IF (ISP == TPFILE%NMASTER_RANK) THEN - CALL ALLOCBUFFER_ll(ZFIELDP,PFIELD,YDIR,GALLOC) - ELSE - ALLOCATE(ZFIELDP(0)) - GALLOC = .TRUE. - END IF - ! - IF (YDIR == 'XX' .OR. YDIR =='YY') THEN - CALL GATHER_XXFIELD(YDIR,PFIELD,ZFIELDP,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) - END IF - ! - IF (ISP == TPFILE%NMASTER_RANK) THEN - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) - END IF - ! - CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - END IF ! multiprocesses execution - END IF - ! - IF (IRESP.NE.0) THEN - WRITE(YRESP, '( I6 )') IRESP - YMSG = 'RESP='//YRESP//' when writing '//TRIM(YRECFM)//' in '//TRIM(TPFILE%CNAME) - CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_FIELD_BYFIELD_X1',YMSG) - END IF - IF (GALLOC) DEALLOCATE(ZFIELDP) - IF (PRESENT(KRESP)) KRESP = IRESP - END SUBROUTINE IO_WRITE_FIELD_BYFIELD_X1 - - - SUBROUTINE IO_WRITE_FIELD_BYNAME_X2(TPFILE,HNAME,PFIELD,KRESP) - ! - USE MODD_IO_ll, ONLY : TFILEDATA - ! - !* 0.1 Declarations of arguments - ! - TYPE(TFILEDATA), INTENT(IN) :: TPFILE - CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write - REAL,DIMENSION(:,:), INTENT(IN) :: PFIELD ! array containing the data field - INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code - ! - !* 0.2 Declarations of local variables - ! - INTEGER :: ID ! Index of the field - INTEGER :: IRESP ! return-code - ! - CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYNAME_X2',TRIM(TPFILE%CNAME)//': writing '//TRIM(HNAME)) - ! - CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) - ! - IF(IRESP==0) CALL IO_WRITE_FIELD(TPFILE,TFIELDLIST(ID),PFIELD,IRESP) - ! - IF (PRESENT(KRESP)) KRESP = IRESP - ! - END SUBROUTINE IO_WRITE_FIELD_BYNAME_X2 - - - SUBROUTINE IO_WRITE_FIELD_BYFIELD_X2(TPFILE,TPFIELD,PFIELD,KRESP) - USE MODD_IO_ll - USE MODD_PARAMETERS_ll, ONLY : JPHEXT - USE MODD_TIMEZ, ONLY : TIMEZ - ! - USE MODE_ALLOCBUFFER_ll -#ifdef MNH_GA - USE MODE_GA -#endif - USE MODE_GATHER_ll - USE MODE_MNH_TIMING, ONLY : SECOND_MNH2 - ! - IMPLICIT NONE - ! - !* 0.1 Declarations of arguments - ! - TYPE(TFILEDATA), INTENT(IN) :: TPFILE - TYPE(TFIELDDATA), INTENT(IN) :: TPFIELD - REAL,DIMENSION(:,:),TARGET, INTENT(IN) :: PFIELD ! array containing the data field - INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code - ! - !* 0.2 Declarations of local variables - ! - CHARACTER(LEN=28) :: YFILEM ! FM-file name - CHARACTER(LEN=NMNHNAMELGTMAX) :: YRECFM ! name of the article to write - CHARACTER(LEN=2) :: YDIR ! field form - INTEGER :: IERR - INTEGER :: ISIZEMAX - INTEGER :: IRESP - REAL,DIMENSION(:,:),POINTER :: ZFIELDP - LOGICAL :: GALLOC - ! - REAL*8,DIMENSION(2) :: T0,T1,T2 - REAL*8,DIMENSION(2) :: T11,T22 -#ifdef MNH_GA - REAL,DIMENSION(:,:),POINTER :: ZFIELD_GA -#endif - INTEGER :: IHEXTOT - CHARACTER(LEN=:),ALLOCATABLE :: YMSG - CHARACTER(LEN=6) :: YRESP - ! - YFILEM = TPFILE%CNAME - YRECFM = TPFIELD%CMNHNAME - YDIR = TPFIELD%CDIR - ! - IRESP = 0 - GALLOC = .FALSE. - IHEXTOT = 2*JPHEXT+1 - ! - CALL SECOND_MNH2(T11) - ! - CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYFIELD_X2',TRIM(YFILEM)//': writing '//TRIM(YRECFM)) - ! - CALL FIELD_METADATA_CHECK(TPFIELD,TYPEREAL,2,'IO_WRITE_FIELD_BYFIELD_X2') - ! - CALL IO_FILE_WRITE_CHECK(TPFILE,'IO_WRITE_FIELD_BYFIELD_X2',IRESP) - ! - IF (IRESP==0) THEN - IF (GSMONOPROC) THEN ! sequential execution - ! IF (LPACK .AND. L1D .AND. YDIR=='XY') THEN - IF (LPACK .AND. L1D .AND. SIZE(PFIELD,1)==IHEXTOT .AND. SIZE(PFIELD,2)==IHEXTOT) THEN - ZFIELDP=>PFIELD(JPHEXT+1:JPHEXT+1,JPHEXT+1:JPHEXT+1) - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) - ! ELSE IF (LPACK .AND. L2D .AND. YDIR=='XY') THEN - ELSEIF (LPACK .AND. L2D .AND. SIZE(PFIELD,2)==IHEXTOT) THEN - ZFIELDP=>PFIELD(:,JPHEXT+1:JPHEXT+1) - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) - ELSE - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,PFIELD,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,PFIELD,IRESP) - END IF - ELSE ! multiprocesses execution - CALL SECOND_MNH2(T0) -#ifndef MNH_INT8 - CALL MPI_ALLREDUCE(SIZE(PFIELD),ISIZEMAX,1,MPI_INTEGER,MPI_MAX,TPFILE%NMPICOMM,IRESP) -#else - CALL MPI_ALLREDUCE(SIZE(PFIELD),ISIZEMAX,1,MPI_INTEGER8,MPI_MAX,TPFILE%NMPICOMM,IRESP) -#endif - IF (ISIZEMAX==0) THEN - CALL PRINT_MSG(NVERB_INFO,'IO','IO_WRITE_FIELD_BYFIELD_X2','ignoring variable with a zero size ('//TRIM(YRECFM)//')') - IF (PRESENT(KRESP)) KRESP=0 - RETURN - END IF - - IF (ISP == TPFILE%NMASTER_RANK) THEN - ! I/O process case - CALL ALLOCBUFFER_ll(ZFIELDP,PFIELD,YDIR,GALLOC) - ELSE - ALLOCATE(ZFIELDP(0,0)) - GALLOC = .TRUE. - END IF - ! - IF (YDIR == 'XX' .OR. YDIR =='YY') THEN - CALL GATHER_XXFIELD(YDIR,PFIELD,ZFIELDP,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) - ELSEIF (YDIR == 'XY') THEN - IF (LPACK .AND. L2D) THEN - CALL GATHER_XXFIELD('XX',PFIELD(:,JPHEXT+1),ZFIELDP(:,1),TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) - ELSE -#ifdef MNH_GA - ! - ! init/create the ga , dim3 = 1 - ! - CALL MNH_INIT_GA(SIZE(PFIELD,1),SIZE(PFIELD,2),1,YRECFM,"WRITE") - ! - ! copy columun data to global arrays g_a - ! - ALLOCATE (ZFIELD_GA (SIZE(PFIELD,1),SIZE(PFIELD,2))) - ZFIELD_GA = PFIELD - call nga_put(g_a, lo_col, hi_col,ZFIELD_GA(NIXO_L,NIYO_L) , ld_col) - call ga_sync - DEALLOCATE (ZFIELD_GA) - IF (ISP == TPFILE%NMASTER_RANK) THEN - ! - ! this proc get the Z slide to write - ! - lo_zplan(JPIZ) = 1 - hi_zplan(JPIZ) = 1 - call nga_get(g_a, lo_zplan, hi_zplan,ZFIELDP, ld_zplan) - END IF -#else - CALL GATHER_XYFIELD(PFIELD,ZFIELDP,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) -#endif - END IF - END IF - CALL SECOND_MNH2(T1) - TIMEZ%T_WRIT2D_GATH=TIMEZ%T_WRIT2D_GATH + T1 - T0 - ! - IF (ISP == TPFILE%NMASTER_RANK) THEN - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) - END IF -#ifdef MNH_GA - call ga_sync -#endif - CALL SECOND_MNH2(T2) - TIMEZ%T_WRIT2D_WRIT=TIMEZ%T_WRIT2D_WRIT + T2 - T1 - ! - CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - END IF - END IF - ! - IF (IRESP.NE.0) THEN - WRITE(YRESP, '( I6 )') IRESP - YMSG = 'RESP='//YRESP//' when writing '//TRIM(YRECFM)//' in '//TRIM(TPFILE%CNAME) - CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_FIELD_BYFIELD_X2',YMSG) - END IF - IF (GALLOC) DEALLOCATE(ZFIELDP) - IF (PRESENT(KRESP)) KRESP = IRESP - CALL SECOND_MNH2(T22) - TIMEZ%T_WRIT2D_ALL=TIMEZ%T_WRIT2D_ALL + T22 - T11 - END SUBROUTINE IO_WRITE_FIELD_BYFIELD_X2 - - - SUBROUTINE IO_WRITE_FIELD_BYNAME_X3(TPFILE,HNAME,PFIELD,KRESP) - ! - USE MODD_IO_ll, ONLY : TFILEDATA - ! - !* 0.1 Declarations of arguments - ! - TYPE(TFILEDATA), INTENT(IN) :: TPFILE - CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write - REAL,DIMENSION(:,:,:), INTENT(IN) :: PFIELD ! array containing the data field - INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code - ! - !* 0.2 Declarations of local variables - ! - INTEGER :: ID ! Index of the field - INTEGER :: IRESP ! return_code - ! - CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYNAME_X3',TRIM(TPFILE%CNAME)//': writing '//TRIM(HNAME)) - ! - CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) - ! - IF(IRESP==0) CALL IO_WRITE_FIELD(TPFILE,TFIELDLIST(ID),PFIELD,IRESP) - ! - IF (PRESENT(KRESP)) KRESP = IRESP - ! - END SUBROUTINE IO_WRITE_FIELD_BYNAME_X3 - - - SUBROUTINE IO_WRITE_FIELD_BYFIELD_X3(TPFILE,TPFIELD,PFIELD,KRESP) - USE MODD_IO_ll - USE MODD_PARAMETERS_ll, ONLY : JPHEXT - USE MODD_TIMEZ, ONLY : TIMEZ - ! - USE MODE_ALLOCBUFFER_ll - USE MODE_GATHER_ll - USE MODE_IO_ll, ONLY : IO_FILE - USE MODE_IO_MANAGE_STRUCT, ONLY : IO_FILE_FIND_BYNAME - USE MODE_MNH_TIMING, ONLY : SECOND_MNH2 -#ifdef MNH_GA - USE MODE_GA -#endif - USE MODD_VAR_ll, ONLY : MNH_STATUSES_IGNORE - ! - ! - !* 0.1 Declarations of arguments - ! - TYPE(TFILEDATA),TARGET, INTENT(IN) :: TPFILE - TYPE(TFIELDDATA), INTENT(IN) :: TPFIELD - REAL,DIMENSION(:,:,:),TARGET,INTENT(IN) :: PFIELD ! array containing the data field - INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code - ! - !* 0.2 Declarations of local variables - ! - CHARACTER(LEN=28) :: YFILEM ! FM-file name - CHARACTER(LEN=NMNHNAMELGTMAX) :: YRECFM ! name of the article to write - CHARACTER(LEN=2) :: YDIR ! field form - INTEGER :: IERR - INTEGER :: ISIZEMAX - INTEGER :: IRESP - REAL,DIMENSION(:,:,:),POINTER :: ZFIELDP - LOGICAL :: GALLOC - INTEGER :: JK,JKK - REAL,DIMENSION(:,:),POINTER :: ZSLICE_ll,ZSLICE - INTEGER :: IK_FILE,IK_RANK,INB_PROC_REAL,JK_MAX - INTEGER :: JI,IXO,IXE,IYO,IYE - REAL,DIMENSION(:,:),POINTER :: TX2DP - INTEGER, DIMENSION(MPI_STATUS_SIZE) :: STATUS - LOGICAL :: GALLOC_ll - INTEGER,ALLOCATABLE,DIMENSION(:) :: REQ_TAB - INTEGER :: NB_REQ - TYPE TX_2DP - REAL,DIMENSION(:,:), POINTER :: X - END TYPE TX_2DP - TYPE(TX_2DP),ALLOCATABLE,DIMENSION(:) :: T_TX2DP - REAL*8,DIMENSION(2) :: T0,T1,T2 - REAL*8,DIMENSION(2) :: T11,T22 -#ifdef MNH_GA - REAL,DIMENSION(:,:,:),POINTER :: ZFIELD_GA -#endif - INTEGER :: IHEXTOT - CHARACTER(LEN=:),ALLOCATABLE :: YMSG - CHARACTER(LEN=6) :: YRESP - TYPE(TFILEDATA),POINTER :: TZFILE - ! - TZFILE => NULL() - ! - ZSLICE => NULL() - ZSLICE_ll => NULL() - ! - YFILEM = TPFILE%CNAME - YRECFM = TPFIELD%CMNHNAME - YDIR = TPFIELD%CDIR - ! - IRESP = 0 - GALLOC = .FALSE. - GALLOC_ll = .FALSE. - IHEXTOT = 2*JPHEXT+1 - ! - CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYFIELD_X3',TRIM(YFILEM)//': writing '//TRIM(YRECFM)) - ! - CALL SECOND_MNH2(T11) - ! - CALL FIELD_METADATA_CHECK(TPFIELD,TYPEREAL,3,'IO_WRITE_FIELD_BYFIELD_X3') - ! - CALL IO_FILE_WRITE_CHECK(TPFILE,'IO_WRITE_FIELD_BYFIELD_X3',IRESP) - ! - IF (IRESP==0) THEN - IF (GSMONOPROC .AND. TPFILE%NSUBFILES_IOZ==0 ) THEN ! sequential execution - ! IF (LPACK .AND. L1D .AND. YDIR=='XY') THEN - IF (LPACK .AND. L1D .AND. SIZE(PFIELD,1)==IHEXTOT .AND. SIZE(PFIELD,2)==IHEXTOT) THEN - ZFIELDP=>PFIELD(JPHEXT+1:JPHEXT+1,JPHEXT+1:JPHEXT+1,:) - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) - ! ELSE IF (LPACK .AND. L2D .AND. YDIR=='XY') THEN - ELSEIF (LPACK .AND. L2D .AND. SIZE(PFIELD,2)==IHEXTOT) THEN - ZFIELDP=>PFIELD(:,JPHEXT+1:JPHEXT+1,:) - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) - ELSE - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,PFIELD,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,PFIELD,IRESP) - END IF - ELSEIF ( TPFILE%NSUBFILES_IOZ==0 .OR. YDIR=='--' ) THEN ! multiprocesses execution & 1 proc IO -#ifndef MNH_INT8 - CALL MPI_ALLREDUCE(SIZE(PFIELD),ISIZEMAX,1,MPI_INTEGER,MPI_MAX,TPFILE%NMPICOMM,IRESP) -#else - CALL MPI_ALLREDUCE(SIZE(PFIELD),ISIZEMAX,1,MPI_INTEGER8,MPI_MAX,TPFILE%NMPICOMM,IRESP) -#endif - IF (ISIZEMAX==0) THEN - CALL PRINT_MSG(NVERB_INFO,'IO','IO_WRITE_FIELD_BYFIELD_X3','ignoring variable with a zero size ('//TRIM(YRECFM)//')') - IF (PRESENT(KRESP)) KRESP=0 - RETURN - END IF - - ! write 3D field in 1 time = output for graphique - IF (ISP == TPFILE%NMASTER_RANK) THEN - CALL ALLOCBUFFER_ll(ZFIELDP,PFIELD,YDIR,GALLOC) - ELSE - ALLOCATE(ZFIELDP(0,0,0)) - GALLOC = .TRUE. - END IF - ! - IF (YDIR == 'XX' .OR. YDIR =='YY') THEN - CALL GATHER_XXFIELD(YDIR,PFIELD,ZFIELDP,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) - ELSEIF (YDIR == 'XY') THEN - IF (LPACK .AND. L2D) THEN - CALL GATHER_XXFIELD('XX',PFIELD(:,JPHEXT+1,:),ZFIELDP(:,1,:),TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) - ELSE - CALL GATHER_XYFIELD(PFIELD,ZFIELDP,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) - END IF - END IF - ! - IF (ISP == TPFILE%NMASTER_RANK) THEN - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) - END IF - ! - CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - ! - ELSE ! multiprocesses execution & // IO -#ifndef MNH_INT8 - CALL MPI_ALLREDUCE(SIZE(PFIELD),ISIZEMAX,1,MPI_INTEGER,MPI_MAX,TPFILE%NMPICOMM,IRESP) -#else - CALL MPI_ALLREDUCE(SIZE(PFIELD),ISIZEMAX,1,MPI_INTEGER8,MPI_MAX,TPFILE%NMPICOMM,IRESP) -#endif - IF (ISIZEMAX==0) THEN - CALL PRINT_MSG(NVERB_INFO,'IO','IO_WRITE_FIELD_BYFIELD_X3','ignoring variable with a zero size ('//TRIM(YRECFM)//')') - IF (PRESENT(KRESP)) KRESP=0 - RETURN - END IF - ! - !JUAN BG Z SLICE - ! - ! -#ifdef MNH_GA - ! - ! init/create the ga - ! - CALL SECOND_MNH2(T0) - CALL MNH_INIT_GA(SIZE(PFIELD,1),SIZE(PFIELD,2),SIZE(PFIELD,3),YRECFM,"WRITE") - ! - ! copy columun data to global arrays g_a - ! - ALLOCATE (ZFIELD_GA (SIZE(PFIELD,1),SIZE(PFIELD,2),SIZE(PFIELD,3))) - ZFIELD_GA = PFIELD - call nga_put(g_a, lo_col, hi_col,ZFIELD_GA(NIXO_L,NIYO_L,1) , ld_col) - DEALLOCATE(ZFIELD_GA) - call ga_sync - CALL SECOND_MNH2(T1) - TIMEZ%T_WRIT3D_SEND=TIMEZ%T_WRIT3D_SEND + T1 - T0 - ! - ! write the data - ! - ALLOCATE(ZSLICE_ll(0,0)) ! to avoid bug on test of size - GALLOC_ll = .TRUE. - ! - DO JKK=1,IKU_ll - ! - IK_FILE = IO_FILE(JKK,TPFILE%NSUBFILES_IOZ) - TZFILE => TPFILE%TFILES_IOZ(IK_FILE+1)%TFILE - ! - IK_RANK = TZFILE%NMASTER_RANK - ! - IF (ISP == IK_RANK ) THEN - CALL SECOND_MNH2(T0) - ! - IF ( SIZE(ZSLICE_ll) .EQ. 0 ) THEN - DEALLOCATE(ZSLICE_ll) - CALL ALLOCBUFFER_ll(ZSLICE_ll,ZSLICE,YDIR,GALLOC_ll) - END IF - ! - ! this proc get this JKK slide - ! - lo_zplan(JPIZ) = JKK - hi_zplan(JPIZ) = JKK - call nga_get(g_a, lo_zplan, hi_zplan,ZSLICE_ll, ld_zplan) - CALL SECOND_MNH2(T1) - TIMEZ%T_WRIT3D_RECV=TIMEZ%T_WRIT3D_RECV + T1 - T0 - ! - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,ZSLICE_ll,IRESP,KVERTLEVEL=JKK,KZFILE=IK_FILE+1) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,ZSLICE_ll,IRESP,KVERTLEVEL=JKK,KZFILE=IK_FILE+1) - CALL SECOND_MNH2(T2) - TIMEZ%T_WRIT3D_WRIT=TIMEZ%T_WRIT3D_WRIT + T2 - T1 - END IF - END DO - ! - CALL SECOND_MNH2(T0) - call ga_sync - CALL SECOND_MNH2(T1) - TIMEZ%T_WRIT3D_WAIT=TIMEZ%T_WRIT3D_WAIT + T1 - T0 -#else - ! - ALLOCATE(ZSLICE_ll(0,0)) - GALLOC_ll = .TRUE. - INB_PROC_REAL = MIN(TPFILE%NSUBFILES_IOZ,ISNPROC) - Z_SLICE: DO JK=1,SIZE(PFIELD,3),INB_PROC_REAL - ! - ! collect the data - ! - JK_MAX=MIN(SIZE(PFIELD,3),JK+INB_PROC_REAL-1) - ! - NB_REQ=0 - ALLOCATE(REQ_TAB(INB_PROC_REAL)) - ALLOCATE(T_TX2DP(INB_PROC_REAL)) - DO JKK=JK,JK_MAX - ! - ! get the file & rank to write this level - ! - IF (TPFILE%NSUBFILES_IOZ .GT. 1 ) THEN - IK_FILE = IO_FILE(JKK,TPFILE%NSUBFILES_IOZ) - TZFILE => TPFILE%TFILES_IOZ(IK_FILE+1)%TFILE - ELSE - TZFILE => TPFILE - END IF - ! - IK_RANK = TZFILE%NMASTER_RANK - ! - IF (YDIR == 'XX' .OR. YDIR =='YY') THEN - STOP " XX NON PREVU SUR BG POUR LE MOMENT " - CALL GATHER_XXFIELD(YDIR,PFIELD,ZFIELDP,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) - ELSEIF (YDIR == 'XY') THEN - IF (LPACK .AND. L2D) THEN - STOP " L2D NON PREVU SUR BG POUR LE MOMENT " - CALL GATHER_XXFIELD('XX',PFIELD(:,JPHEXT+1,:),ZFIELDP(:,1,:),TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) - ELSE - CALL SECOND_MNH2(T0) - IF ( ISP /= IK_RANK ) THEN - ! Other processes - CALL GET_DOMWRITE_ll(ISP,'local',IXO,IXE,IYO,IYE) - IF (IXO /= 0) THEN ! intersection is not empty - NB_REQ = NB_REQ + 1 - ALLOCATE(T_TX2DP(NB_REQ)%X(IXO:IXE,IYO:IYE)) - ZSLICE => PFIELD(:,:,JKK) - TX2DP=>ZSLICE(IXO:IXE,IYO:IYE) - T_TX2DP(NB_REQ)%X=ZSLICE(IXO:IXE,IYO:IYE) - CALL MPI_ISEND(T_TX2DP(NB_REQ)%X,SIZE(TX2DP),MPI_FLOAT,IK_RANK-1,99+IK_RANK & - & ,TZFILE%NMPICOMM,REQ_TAB(NB_REQ),IERR) - !CALL MPI_BSEND(TX2DP,SIZE(TX2DP),MPI_FLOAT,IK_RANK-1,99+IK_RANK,TZFILE%NMPICOMM,IERR) - END IF - END IF - CALL SECOND_MNH2(T1) - TIMEZ%T_WRIT3D_SEND=TIMEZ%T_WRIT3D_SEND + T1 - T0 - END IF - END IF - END DO - ! - ! write the data - ! - DO JKK=JK,JK_MAX - IF (TPFILE%NSUBFILES_IOZ .GT. 1 ) THEN - IK_FILE = IO_FILE(JKK,TPFILE%NSUBFILES_IOZ) - TZFILE => TPFILE%TFILES_IOZ(IK_FILE+1)%TFILE - ELSE - TZFILE => TPFILE - ENDIF - IK_RANK = TZFILE%NMASTER_RANK - ! - IF (ISP == IK_RANK ) THEN - CALL SECOND_MNH2(T0) - ! I/O proc case - IF ( SIZE(ZSLICE_ll) .EQ. 0 ) THEN - DEALLOCATE(ZSLICE_ll) - CALL ALLOCBUFFER_ll(ZSLICE_ll,ZSLICE,YDIR,GALLOC_ll) - END IF - DO JI=1,ISNPROC - CALL GET_DOMWRITE_ll(JI,'global',IXO,IXE,IYO,IYE) - IF (IXO /= 0) THEN ! intersection is not empty - TX2DP=>ZSLICE_ll(IXO:IXE,IYO:IYE) - IF (ISP == JI) THEN - CALL GET_DOMWRITE_ll(JI,'local',IXO,IXE,IYO,IYE) - ZSLICE => PFIELD(:,:,JKK) - TX2DP = ZSLICE(IXO:IXE,IYO:IYE) - ELSE - CALL MPI_RECV(TX2DP,SIZE(TX2DP),MPI_FLOAT,JI-1,99+IK_RANK,TZFILE%NMPICOMM,STATUS,IERR) - END IF - END IF - END DO - CALL SECOND_MNH2(T1) - TIMEZ%T_WRIT3D_RECV=TIMEZ%T_WRIT3D_RECV + T1 - T0 - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,ZSLICE_ll,IRESP,KVERTLEVEL=JKK,KZFILE=IK_FILE+1) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,ZSLICE_ll,IRESP,KVERTLEVEL=JKK,KZFILE=IK_FILE+1) - CALL SECOND_MNH2(T2) - TIMEZ%T_WRIT3D_WRIT=TIMEZ%T_WRIT3D_WRIT + T2 - T1 - END IF - END DO - ! - CALL SECOND_MNH2(T0) - IF (NB_REQ .GT.0 ) THEN - CALL MPI_WAITALL(NB_REQ,REQ_TAB,MNH_STATUSES_IGNORE,IERR) - DO JI=1,NB_REQ ; DEALLOCATE(T_TX2DP(JI)%X) ; ENDDO - END IF - DEALLOCATE(T_TX2DP) - DEALLOCATE(REQ_TAB) - CALL SECOND_MNH2(T1) - TIMEZ%T_WRIT3D_WAIT=TIMEZ%T_WRIT3D_WAIT + T1 - T0 - END DO Z_SLICE - !JUAN BG Z SLICE -! end of MNH_GA -#endif - END IF ! multiprocesses execution - END IF - ! - IF (IRESP.NE.0) THEN - WRITE(YRESP, '( I6 )') IRESP - YMSG = 'RESP='//YRESP//' when writing '//TRIM(YRECFM)//' in '//TRIM(TPFILE%CNAME) - CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_FIELD_BYFIELD_X3',YMSG) - END IF - IF (GALLOC) DEALLOCATE(ZFIELDP) - IF (GALLOC_ll) DEALLOCATE(ZSLICE_ll) - IF (PRESENT(KRESP)) KRESP = IRESP - CALL SECOND_MNH2(T22) - TIMEZ%T_WRIT3D_ALL=TIMEZ%T_WRIT3D_ALL + T22 - T11 - END SUBROUTINE IO_WRITE_FIELD_BYFIELD_X3 - - - SUBROUTINE IO_WRITE_FIELD_BYNAME_X4(TPFILE,HNAME,PFIELD,KRESP) - ! - USE MODD_IO_ll, ONLY : TFILEDATA - ! - !* 0.1 Declarations of arguments - ! - TYPE(TFILEDATA), INTENT(IN) :: TPFILE - CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write - REAL,DIMENSION(:,:,:,:), INTENT(IN) :: PFIELD ! array containing the data field - INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code - ! - !* 0.2 Declarations of local variables - ! - INTEGER :: ID ! Index of the field - INTEGER :: IRESP ! return_code - ! - CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYNAME_X4',TRIM(TPFILE%CNAME)//': writing '//TRIM(HNAME)) - ! - CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) - ! - IF(IRESP==0) CALL IO_WRITE_FIELD(TPFILE,TFIELDLIST(ID),PFIELD,IRESP) - ! - IF (PRESENT(KRESP)) KRESP = IRESP - ! - END SUBROUTINE IO_WRITE_FIELD_BYNAME_X4 - - - SUBROUTINE IO_WRITE_FIELD_BYFIELD_X4(TPFILE,TPFIELD,PFIELD,KRESP) - USE MODD_IO_ll - USE MODD_PARAMETERS_ll, ONLY : JPHEXT - USE MODD_TIMEZ, ONLY : TIMEZ - ! - USE MODE_ALLOCBUFFER_ll - USE MODE_GATHER_ll - USE MODE_IO_ll, ONLY : IO_FILE,IO_RANK - USE MODE_MNH_TIMING, ONLY : SECOND_MNH2 - USE MODD_VAR_ll, ONLY : MNH_STATUSES_IGNORE - ! - ! - !* 0.1 Declarations of arguments - ! - TYPE(TFILEDATA), INTENT(IN) :: TPFILE - TYPE(TFIELDDATA), INTENT(IN) :: TPFIELD - REAL,DIMENSION(:,:,:,:),TARGET, INTENT(IN) :: PFIELD ! array containing the data field - INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code - ! - !* 0.2 Declarations of local variables - ! - CHARACTER(LEN=28) :: YFILEM ! FM-file name - CHARACTER(LEN=NMNHNAMELGTMAX) :: YRECFM ! name of the article to write - CHARACTER(LEN=2) :: YDIR ! field form - INTEGER :: IERR - INTEGER :: ISIZEMAX - INTEGER :: IRESP - REAL,DIMENSION(:,:,:,:),POINTER :: ZFIELDP - LOGICAL :: GALLOC - INTEGER :: IHEXTOT - CHARACTER(LEN=:),ALLOCATABLE :: YMSG - CHARACTER(LEN=6) :: YRESP - ! - YFILEM = TPFILE%CNAME - YRECFM = TPFIELD%CMNHNAME - YDIR = TPFIELD%CDIR - ! - IRESP = 0 - GALLOC = .FALSE. - ! - IHEXTOT = 2*JPHEXT+1 - ! - CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYFIELD_X4',TRIM(YFILEM)//': writing '//TRIM(YRECFM)) - ! - CALL FIELD_METADATA_CHECK(TPFIELD,TYPEREAL,4,'IO_WRITE_FIELD_BYFIELD_X4') - ! - CALL IO_FILE_WRITE_CHECK(TPFILE,'IO_WRITE_FIELD_BYFIELD_X4',IRESP) - ! - IF (IRESP==0) THEN - IF (GSMONOPROC) THEN ! sequential execution - ! IF (LPACK .AND. L1D .AND. YDIR=='XY') THEN - IF (LPACK .AND. L1D .AND. SIZE(PFIELD,1)==IHEXTOT .AND. SIZE(PFIELD,2)==IHEXTOT) THEN - ZFIELDP=>PFIELD(JPHEXT+1:JPHEXT+1,JPHEXT+1:JPHEXT+1,:,:) - ! ELSE IF (LPACK .AND. L2D .AND. YDIR=='XY') THEN - ELSEIF (LPACK .AND. L2D .AND. SIZE(PFIELD,2)==IHEXTOT) THEN - ZFIELDP=>PFIELD(:,JPHEXT+1:JPHEXT+1,:,:) - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) - ELSE - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,PFIELD,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,PFIELD,IRESP) - END IF - ELSE -#ifndef MNH_INT8 - CALL MPI_ALLREDUCE(SIZE(PFIELD),ISIZEMAX,1,MPI_INTEGER,MPI_MAX,TPFILE%NMPICOMM,IRESP) -#else - CALL MPI_ALLREDUCE(SIZE(PFIELD),ISIZEMAX,1,MPI_INTEGER8,MPI_MAX,TPFILE%NMPICOMM,IRESP) -#endif - IF (ISIZEMAX==0) THEN - CALL PRINT_MSG(NVERB_INFO,'IO','IO_WRITE_FIELD_BYFIELD_X4','ignoring variable with a zero size ('//TRIM(YRECFM)//')') - IF (PRESENT(KRESP)) KRESP=0 - RETURN - END IF - - IF (ISP == TPFILE%NMASTER_RANK) THEN - CALL ALLOCBUFFER_ll(ZFIELDP,PFIELD,YDIR,GALLOC) - ELSE - ALLOCATE(ZFIELDP(0,0,0,0)) - GALLOC = .TRUE. - END IF - ! - IF (YDIR == 'XX' .OR. YDIR =='YY') THEN - CALL GATHER_XXFIELD(YDIR,PFIELD,ZFIELDP,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) - ELSEIF (YDIR == 'XY') THEN - IF (LPACK .AND. L2D) THEN - CALL GATHER_XXFIELD('XX',PFIELD(:,JPHEXT+1,:,:),ZFIELDP(:,1,:,:),TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) - ELSE - CALL GATHER_XYFIELD(PFIELD,ZFIELDP,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) - END IF - END IF - ! - IF (ISP == TPFILE%NMASTER_RANK) THEN - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) - END IF - ! - CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - END IF ! multiprocess execution - END IF - ! - IF (IRESP.NE.0) THEN - WRITE(YRESP, '( I6 )') IRESP - YMSG = 'RESP='//YRESP//' when writing '//TRIM(YRECFM)//' in '//TRIM(TPFILE%CNAME) - CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_FIELD_BYFIELD_X4',YMSG) - END IF - IF (GALLOC) DEALLOCATE(ZFIELDP) - IF (PRESENT(KRESP)) KRESP = IRESP - END SUBROUTINE IO_WRITE_FIELD_BYFIELD_X4 - - - SUBROUTINE IO_WRITE_FIELD_BYNAME_X5(TPFILE,HNAME,PFIELD,KRESP) - ! - USE MODD_IO_ll, ONLY : TFILEDATA - ! - !* 0.1 Declarations of arguments - ! - TYPE(TFILEDATA), INTENT(IN) :: TPFILE - CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write - REAL,DIMENSION(:,:,:,:,:), INTENT(IN) :: PFIELD ! array containing the data field - INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code - ! - !* 0.2 Declarations of local variables - ! - INTEGER :: ID ! Index of the field - INTEGER :: IRESP ! return_code - ! - CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYNAME_X5',TRIM(TPFILE%CNAME)//': writing '//TRIM(HNAME)) - ! - CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) - ! - IF(IRESP==0) CALL IO_WRITE_FIELD(TPFILE,TFIELDLIST(ID),PFIELD,IRESP) - ! - IF (PRESENT(KRESP)) KRESP = IRESP - ! - END SUBROUTINE IO_WRITE_FIELD_BYNAME_X5 - - - SUBROUTINE IO_WRITE_FIELD_BYFIELD_X5(TPFILE,TPFIELD,PFIELD,KRESP) - USE MODD_IO_ll - USE MODD_PARAMETERS_ll, ONLY : JPHEXT - USE MODD_TIMEZ, ONLY : TIMEZ - ! - USE MODE_ALLOCBUFFER_ll - USE MODE_GATHER_ll - USE MODE_IO_ll, ONLY : IO_FILE,IO_RANK - USE MODE_MNH_TIMING, ONLY : SECOND_MNH2 - USE MODD_VAR_ll, ONLY : MNH_STATUSES_IGNORE - ! - ! - !* 0.1 Declarations of arguments - ! - TYPE(TFILEDATA), INTENT(IN) :: TPFILE - TYPE(TFIELDDATA), INTENT(IN) :: TPFIELD - REAL,DIMENSION(:,:,:,:,:),TARGET,INTENT(IN) :: PFIELD ! array containing the data field - INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code - ! - !* 0.2 Declarations of local variables - ! - CHARACTER(LEN=28) :: YFILEM ! FM-file name - CHARACTER(LEN=NMNHNAMELGTMAX) :: YRECFM ! name of the article to write - CHARACTER(LEN=2) :: YDIR ! field form - INTEGER :: IERR - INTEGER :: ISIZEMAX - INTEGER :: IRESP - REAL,DIMENSION(:,:,:,:,:),POINTER :: ZFIELDP - LOGICAL :: GALLOC - INTEGER :: IHEXTOT - CHARACTER(LEN=:),ALLOCATABLE :: YMSG - CHARACTER(LEN=6) :: YRESP - ! - YFILEM = TPFILE%CNAME - YRECFM = TPFIELD%CMNHNAME - YDIR = TPFIELD%CDIR - ! - IRESP = 0 - GALLOC = .FALSE. - ! - IHEXTOT = 2*JPHEXT+1 - ! - CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYFIELD_X5',TRIM(YFILEM)//': writing '//TRIM(YRECFM)) - ! - CALL FIELD_METADATA_CHECK(TPFIELD,TYPEREAL,5,'IO_WRITE_FIELD_BYFIELD_X5') - ! - CALL IO_FILE_WRITE_CHECK(TPFILE,'IO_WRITE_FIELD_BYFIELD_X5',IRESP) - ! - IF (IRESP==0) THEN - IF (GSMONOPROC) THEN ! sequential execution - ! IF (LPACK .AND. L1D .AND. YDIR=='XY') THEN - IF (LPACK .AND. L1D .AND. SIZE(PFIELD,1)==IHEXTOT .AND. SIZE(PFIELD,2)==IHEXTOT) THEN - ZFIELDP=>PFIELD(JPHEXT+1:JPHEXT+1,JPHEXT+1:JPHEXT+1,:,:,:) - ! ELSE IF (LPACK .AND. L2D .AND. YDIR=='XY') THEN - ELSEIF (LPACK .AND. L2D .AND. SIZE(PFIELD,2)==IHEXTOT) THEN - ZFIELDP=>PFIELD(:,JPHEXT+1:JPHEXT+1,:,:,:) - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) - ELSE - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,PFIELD,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,PFIELD,IRESP) - END IF - ELSE -#ifndef MNH_INT8 - CALL MPI_ALLREDUCE(SIZE(PFIELD),ISIZEMAX,1,MPI_INTEGER,MPI_MAX,TPFILE%NMPICOMM,IRESP) -#else - CALL MPI_ALLREDUCE(SIZE(PFIELD),ISIZEMAX,1,MPI_INTEGER8,MPI_MAX,TPFILE%NMPICOMM,IRESP) -#endif - IF (ISIZEMAX==0) THEN - CALL PRINT_MSG(NVERB_INFO,'IO','IO_WRITE_FIELD_BYFIELD_X5','ignoring variable with a zero size ('//TRIM(YRECFM)//')') - IF (PRESENT(KRESP)) KRESP=0 - RETURN - END IF - - IF (ISP == TPFILE%NMASTER_RANK) THEN - CALL ALLOCBUFFER_ll(ZFIELDP,PFIELD,YDIR,GALLOC) - ELSE - ALLOCATE(ZFIELDP(0,0,0,0,0)) - GALLOC = .TRUE. - END IF - ! - IF (YDIR == 'XX' .OR. YDIR =='YY') THEN - CALL GATHER_XXFIELD(YDIR,PFIELD,ZFIELDP,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) - ELSEIF (YDIR == 'XY') THEN - IF (LPACK .AND. L2D) THEN - CALL GATHER_XXFIELD('XX',PFIELD(:,JPHEXT+1,:,:,:),ZFIELDP(:,1,:,:,:),& - & TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) - ELSE - CALL GATHER_XYFIELD(PFIELD,ZFIELDP,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) - END IF - END IF - ! - IF (ISP == TPFILE%NMASTER_RANK) THEN - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) - END IF - ! - CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - END IF ! multiprocess execution - END IF - ! - IF (IRESP.NE.0) THEN - WRITE(YRESP, '( I6 )') IRESP - YMSG = 'RESP='//YRESP//' when writing '//TRIM(YRECFM)//' in '//TRIM(TPFILE%CNAME) - CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_FIELD_BYFIELD_X5',YMSG) - END IF - IF (GALLOC) DEALLOCATE(ZFIELDP) - IF (PRESENT(KRESP)) KRESP = IRESP - END SUBROUTINE IO_WRITE_FIELD_BYFIELD_X5 - - - SUBROUTINE IO_WRITE_FIELD_BYNAME_X6(TPFILE,HNAME,PFIELD,KRESP) - ! - USE MODD_IO_ll, ONLY : TFILEDATA - ! - !* 0.1 Declarations of arguments - ! - TYPE(TFILEDATA), INTENT(IN) :: TPFILE - CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write - REAL,DIMENSION(:,:,:,:,:,:), INTENT(IN) :: PFIELD ! array containing the data field - INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code - ! - !* 0.2 Declarations of local variables - ! - INTEGER :: ID ! Index of the field - INTEGER :: IRESP ! return_code - ! - CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYNAME_X6',TRIM(TPFILE%CNAME)//': writing '//TRIM(HNAME)) - ! - CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) - ! - IF(IRESP==0) CALL IO_WRITE_FIELD(TPFILE,TFIELDLIST(ID),PFIELD,IRESP) - ! - IF (PRESENT(KRESP)) KRESP = IRESP - ! - END SUBROUTINE IO_WRITE_FIELD_BYNAME_X6 - - SUBROUTINE IO_WRITE_FIELD_BYFIELD_X6(TPFILE,TPFIELD,PFIELD,KRESP) - USE MODD_IO_ll - USE MODD_PARAMETERS_ll, ONLY : JPHEXT - USE MODD_TIMEZ, ONLY : TIMEZ - ! - USE MODE_ALLOCBUFFER_ll - USE MODE_GATHER_ll - USE MODE_IO_ll, ONLY : IO_FILE,IO_RANK - USE MODE_MNH_TIMING, ONLY : SECOND_MNH2 - USE MODD_VAR_ll, ONLY : MNH_STATUSES_IGNORE - ! - ! - !* 0.1 Declarations of arguments - ! - TYPE(TFILEDATA), INTENT(IN) :: TPFILE - TYPE(TFIELDDATA), INTENT(IN) :: TPFIELD - REAL,DIMENSION(:,:,:,:,:,:),TARGET,INTENT(IN) :: PFIELD ! array containing the data field - INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code - ! - !* 0.2 Declarations of local variables - ! - CHARACTER(LEN=28) :: YFILEM ! FM-file name - CHARACTER(LEN=NMNHNAMELGTMAX) :: YRECFM ! name of the article to write - CHARACTER(LEN=2) :: YDIR ! field form - INTEGER :: IERR - INTEGER :: ISIZEMAX - INTEGER :: IRESP - REAL,DIMENSION(:,:,:,:,:,:),POINTER :: ZFIELDP - LOGICAL :: GALLOC - INTEGER :: IHEXTOT - CHARACTER(LEN=:),ALLOCATABLE :: YMSG - CHARACTER(LEN=6) :: YRESP - ! - YFILEM = TPFILE%CNAME - YRECFM = TPFIELD%CMNHNAME - YDIR = TPFIELD%CDIR - ! - IRESP = 0 - GALLOC = .FALSE. - ! - IHEXTOT = 2*JPHEXT+1 - ! - CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYFIELD_X6',TRIM(YFILEM)//': writing '//TRIM(YRECFM)) - ! - CALL FIELD_METADATA_CHECK(TPFIELD,TYPEREAL,6,'IO_WRITE_FIELD_BYFIELD_X6') - ! - CALL IO_FILE_WRITE_CHECK(TPFILE,'IO_WRITE_FIELD_BYFIELD_X6',IRESP) - ! - IF (IRESP==0) THEN - IF (GSMONOPROC) THEN ! sequential execution - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,PFIELD,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,PFIELD,IRESP) - ELSE -#ifndef MNH_INT8 - CALL MPI_ALLREDUCE(SIZE(PFIELD),ISIZEMAX,1,MPI_INTEGER,MPI_MAX,TPFILE%NMPICOMM,IRESP) -#else - CALL MPI_ALLREDUCE(SIZE(PFIELD),ISIZEMAX,1,MPI_INTEGER8,MPI_MAX,TPFILE%NMPICOMM,IRESP) -#endif - IF (ISIZEMAX==0) THEN - CALL PRINT_MSG(NVERB_INFO,'IO','IO_WRITE_FIELD_BYFIELD_X6','ignoring variable with a zero size ('//TRIM(YRECFM)//')') - IF (PRESENT(KRESP)) KRESP=0 - RETURN - END IF - - IF (ISP == TPFILE%NMASTER_RANK) THEN - CALL ALLOCBUFFER_ll(ZFIELDP,PFIELD,YDIR,GALLOC) - ELSE - ALLOCATE(ZFIELDP(0,0,0,0,0,0)) - GALLOC = .TRUE. - END IF - ! - IF (YDIR == 'XX' .OR. YDIR =='YY') THEN - CALL GATHER_XXFIELD(YDIR,PFIELD,ZFIELDP,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) - ELSEIF (YDIR == 'XY') THEN - CALL GATHER_XYFIELD(PFIELD,ZFIELDP,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) - END IF - ! - IF (ISP == TPFILE%NMASTER_RANK) THEN - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) - END IF - ! - CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - END IF ! multiprocess execution - END IF - ! - IF (IRESP.NE.0) THEN - WRITE(YRESP, '( I6 )') IRESP - YMSG = 'RESP='//YRESP//' when writing '//TRIM(YRECFM)//' in '//TRIM(TPFILE%CNAME) - CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_FIELD_BYFIELD_X6',YMSG) - END IF - IF (GALLOC) DEALLOCATE(ZFIELDP) - IF (PRESENT(KRESP)) KRESP = IRESP - END SUBROUTINE IO_WRITE_FIELD_BYFIELD_X6 - - - SUBROUTINE IO_WRITE_FIELD_BYNAME_N0(TPFILE,HNAME,KFIELD,KRESP) - ! - USE MODD_IO_ll, ONLY : TFILEDATA - ! - !* 0.1 Declarations of arguments - ! - TYPE(TFILEDATA), INTENT(IN) :: TPFILE - CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write - INTEGER, INTENT(IN) :: KFIELD ! array containing the data field - INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code - ! - !* 0.2 Declarations of local variables - ! - INTEGER :: ID ! Index of the field - INTEGER :: IRESP ! return_code - ! - CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYNAME_N0',TRIM(TPFILE%CNAME)//': writing '//TRIM(HNAME)) - ! - CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) - ! - IF(IRESP==0) CALL IO_WRITE_FIELD(TPFILE,TFIELDLIST(ID),KFIELD,IRESP) - ! - IF (PRESENT(KRESP)) KRESP = IRESP - ! - END SUBROUTINE IO_WRITE_FIELD_BYNAME_N0 - - - SUBROUTINE IO_WRITE_FIELD_BYFIELD_N0(TPFILE,TPFIELD,KFIELD,KRESP) - USE MODD_IO_ll - !* 0. DECLARATIONS - ! ------------ - ! - ! - !* 0.1 Declarations of arguments - ! - TYPE(TFILEDATA), INTENT(IN) :: TPFILE - TYPE(TFIELDDATA), INTENT(IN) :: TPFIELD - INTEGER, INTENT(IN) :: KFIELD ! array containing the data field - INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code - ! - !* 0.2 Declarations of local variables - ! - INTEGER :: IERR - INTEGER :: IRESP - INTEGER :: IK_FILE - TYPE(TFILEDATA),POINTER :: TZFILE - CHARACTER(LEN=:),ALLOCATABLE :: YMSG - CHARACTER(LEN=6) :: YRESP - ! - IRESP = 0 - TZFILE => NULL() - ! - CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYFIELD_N0',TRIM(TPFILE%CNAME)//': writing '//TRIM(TPFIELD%CMNHNAME)) - ! - CALL FIELD_METADATA_CHECK(TPFIELD,TYPEINT,0,'IO_WRITE_FIELD_BYFIELD_N0') - ! - CALL IO_FILE_WRITE_CHECK(TPFILE,'IO_WRITE_FIELD_BYFIELD_N0',IRESP) - ! - IF (IRESP==0) THEN - IF (GSMONOPROC) THEN ! sequential execution - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,KFIELD,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,KFIELD,IRESP) - ELSE - IF (ISP == TPFILE%NMASTER_RANK) THEN - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,KFIELD,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,KFIELD,IRESP) - END IF - ! - CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - END IF ! multiprocess execution - IF (TPFILE%NSUBFILES_IOZ>0) THEN - ! write the data in all Z files - DO IK_FILE=1,TPFILE%NSUBFILES_IOZ - TZFILE => TPFILE%TFILES_IOZ(IK_FILE)%TFILE - IF ( ISP == TZFILE%NMASTER_RANK ) THEN - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TZFILE,TPFIELD,KFIELD,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TZFILE,TPFIELD,KFIELD,IRESP) - END IF - END DO - ENDIF - END IF - ! - IF (IRESP.NE.0) THEN - WRITE(YRESP, '( I6 )') IRESP - YMSG = 'RESP='//YRESP//' when writing '//TRIM(TPFIELD%CMNHNAME)//' in '//TRIM(TPFILE%CNAME) - CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_FIELD_BYFIELD_N0',YMSG) - END IF - IF (PRESENT(KRESP)) KRESP = IRESP - END SUBROUTINE IO_WRITE_FIELD_BYFIELD_N0 - - - SUBROUTINE IO_WRITE_FIELD_BYNAME_N1(TPFILE,HNAME,KFIELD,KRESP) - ! - USE MODD_IO_ll, ONLY : TFILEDATA - ! - !* 0.1 Declarations of arguments - ! - TYPE(TFILEDATA), INTENT(IN) :: TPFILE - CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write - INTEGER,DIMENSION(:), INTENT(IN) :: KFIELD ! array containing the data field - INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code - ! - !* 0.2 Declarations of local variables - ! - INTEGER :: ID ! Index of the field - INTEGER :: IRESP ! return_code - ! - CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYNAME_N1',TRIM(TPFILE%CNAME)//': writing '//TRIM(HNAME)) - ! - CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) - ! - IF(IRESP==0) CALL IO_WRITE_FIELD(TPFILE,TFIELDLIST(ID),KFIELD,IRESP) - ! - IF (PRESENT(KRESP)) KRESP = IRESP - ! - END SUBROUTINE IO_WRITE_FIELD_BYNAME_N1 - - - SUBROUTINE IO_WRITE_FIELD_BYFIELD_N1(TPFILE,TPFIELD,KFIELD,KRESP) - ! - USE MODD_IO_ll, ONLY : ISP,GSMONOPROC,LIOCDF4,LLFIOUT,TFILEDATA - ! - USE MODE_ALLOCBUFFER_ll - USE MODE_GATHER_ll - ! - IMPLICIT NONE - ! - !* 0.1 Declarations of arguments - ! - TYPE(TFILEDATA), INTENT(IN) :: TPFILE - TYPE(TFIELDDATA), INTENT(IN) :: TPFIELD - INTEGER,DIMENSION(:),TARGET, INTENT(IN) :: KFIELD ! array containing the data field - INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code - ! - !* 0.2 Declarations of local variables - ! - CHARACTER(LEN=28) :: YFILEM ! FM-file name - CHARACTER(LEN=NMNHNAMELGTMAX) :: YRECFM ! name of the article to write - CHARACTER(LEN=2) :: YDIR ! field form - INTEGER :: IERR - INTEGER :: ISIZEMAX - INTEGER :: IRESP - INTEGER,DIMENSION(:),POINTER :: IFIELDP - LOGICAL :: GALLOC - CHARACTER(LEN=:),ALLOCATABLE :: YMSG - CHARACTER(LEN=6) :: YRESP - ! - YFILEM = TPFILE%CNAME - YRECFM = TPFIELD%CMNHNAME - YDIR = TPFIELD%CDIR - ! - IRESP = 0 - GALLOC = .FALSE. - ! - CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYFIELD_N1',TRIM(YFILEM)//': writing '//TRIM(YRECFM)) - ! - CALL FIELD_METADATA_CHECK(TPFIELD,TYPEINT,1,'IO_WRITE_FIELD_BYFIELD_N1') - ! - CALL IO_FILE_WRITE_CHECK(TPFILE,'IO_WRITE_FIELD_BYFIELD_N1',IRESP) - ! - IF (IRESP==0) THEN - IF (GSMONOPROC) THEN ! sequential execution - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,KFIELD,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,KFIELD,IRESP) - ELSE ! multiprocesses execution -#ifndef MNH_INT8 - CALL MPI_ALLREDUCE(SIZE(KFIELD),ISIZEMAX,1,MPI_INTEGER,MPI_MAX,TPFILE%NMPICOMM,IRESP) -#else - CALL MPI_ALLREDUCE(SIZE(KFIELD),ISIZEMAX,1,MPI_INTEGER8,MPI_MAX,TPFILE%NMPICOMM,IRESP) -#endif - IF (ISIZEMAX==0) THEN - CALL PRINT_MSG(NVERB_INFO,'IO','IO_WRITE_FIELD_BYFIELD_N1','ignoring variable with a zero size ('//TRIM(YRECFM)//')') - IF (PRESENT(KRESP)) KRESP=0 - RETURN - END IF - - IF (ISP == TPFILE%NMASTER_RANK) THEN - CALL ALLOCBUFFER_ll(IFIELDP,KFIELD,YDIR,GALLOC) - ELSE - ALLOCATE(IFIELDP(0)) - GALLOC = .TRUE. - END IF - ! - IF (YDIR == 'XX' .OR. YDIR =='YY') THEN - CALL GATHER_XXFIELD(YDIR,KFIELD,IFIELDP,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) - END IF - ! - IF (ISP == TPFILE%NMASTER_RANK) THEN - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,IFIELDP,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,IFIELDP,IRESP) - END IF - ! - CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - END IF - END IF - ! - IF (IRESP.NE.0) THEN - WRITE(YRESP, '( I6 )') IRESP - YMSG = 'RESP='//YRESP//' when writing '//TRIM(YRECFM)//' in '//TRIM(TPFILE%CNAME) - CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_FIELD_BYFIELD_N1',YMSG) - END IF - IF (GALLOC) DEALLOCATE(IFIELDP) - IF (PRESENT(KRESP)) KRESP = IRESP - ! - END SUBROUTINE IO_WRITE_FIELD_BYFIELD_N1 - - - SUBROUTINE IO_WRITE_FIELD_BYNAME_N2(TPFILE,HNAME,KFIELD,KRESP) - ! - USE MODD_IO_ll, ONLY : TFILEDATA - ! - !* 0.1 Declarations of arguments - ! - TYPE(TFILEDATA), INTENT(IN) :: TPFILE - CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write - INTEGER,DIMENSION(:,:), INTENT(IN) :: KFIELD ! array containing the data field - INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code - ! - !* 0.2 Declarations of local variables - ! - INTEGER :: ID ! Index of the field - INTEGER :: IRESP ! return_code - ! - CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYNAME_N2',TRIM(TPFILE%CNAME)//': writing '//TRIM(HNAME)) - ! - CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) - ! - IF(IRESP==0) CALL IO_WRITE_FIELD(TPFILE,TFIELDLIST(ID),KFIELD,IRESP) - ! - IF (PRESENT(KRESP)) KRESP = IRESP - ! - END SUBROUTINE IO_WRITE_FIELD_BYNAME_N2 - - - SUBROUTINE IO_WRITE_FIELD_BYFIELD_N2(TPFILE,TPFIELD,KFIELD,KRESP) - USE MODD_IO_ll - USE MODD_PARAMETERS_ll, ONLY : JPHEXT - USE MODD_TIMEZ, ONLY : TIMEZ - ! - USE MODE_ALLOCBUFFER_ll - USE MODE_GATHER_ll - USE MODE_MNH_TIMING, ONLY : SECOND_MNH2 - ! - IMPLICIT NONE - ! - !* 0.1 Declarations of arguments - ! - TYPE(TFILEDATA), INTENT(IN) :: TPFILE - TYPE(TFIELDDATA), INTENT(IN) :: TPFIELD - INTEGER,DIMENSION(:,:),TARGET,INTENT(IN) :: KFIELD ! array containing the data field - INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code - ! - !* 0.2 Declarations of local variables - ! - CHARACTER(LEN=28) :: YFILEM ! FM-file name - CHARACTER(LEN=NMNHNAMELGTMAX) :: YRECFM ! name of the article to write - CHARACTER(LEN=2) :: YDIR ! field form - INTEGER :: IERR - INTEGER :: ISIZEMAX - INTEGER :: IRESP - INTEGER,DIMENSION(:,:),POINTER :: IFIELDP - LOGICAL :: GALLOC - ! - REAL*8,DIMENSION(2) :: T0,T1,T2 - REAL*8,DIMENSION(2) :: T11,T22 - INTEGER :: IHEXTOT - CHARACTER(LEN=:),ALLOCATABLE :: YMSG - CHARACTER(LEN=6) :: YRESP - ! - YFILEM = TPFILE%CNAME - YRECFM = TPFIELD%CMNHNAME - YDIR = TPFIELD%CDIR - ! - IRESP = 0 - GALLOC = .FALSE. - ! - IHEXTOT = 2*JPHEXT+1 - ! - CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYFIELD_N2',TRIM(YFILEM)//': writing '//TRIM(YRECFM)) - ! - CALL SECOND_MNH2(T11) - ! - CALL FIELD_METADATA_CHECK(TPFIELD,TYPEINT,2,'IO_WRITE_FIELD_BYFIELD_N2') - ! - CALL IO_FILE_WRITE_CHECK(TPFILE,'IO_WRITE_FIELD_BYFIELD_N2',IRESP) - ! - IF (IRESP==0) THEN - IF (GSMONOPROC) THEN ! sequential execution - IF (LPACK .AND. L1D .AND. SIZE(KFIELD,1)==IHEXTOT .AND. SIZE(KFIELD,2)==IHEXTOT) THEN - IFIELDP=>KFIELD(JPHEXT+1:JPHEXT+1,JPHEXT+1:JPHEXT+1) - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,IFIELDP,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,IFIELDP,IRESP) - ! ELSE IF (LPACK .AND. L2D .AND. YDIR=='XY') THEN - ELSEIF (LPACK .AND. L2D .AND. SIZE(KFIELD,2)==IHEXTOT) THEN - IFIELDP=>KFIELD(:,JPHEXT+1:JPHEXT+1) - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,IFIELDP,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,IFIELDP,IRESP) - ELSE - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,KFIELD,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,KFIELD,IRESP) - END IF - ELSE ! multiprocesses execution -#ifndef MNH_INT8 - CALL MPI_ALLREDUCE(SIZE(KFIELD),ISIZEMAX,1,MPI_INTEGER,MPI_MAX,TPFILE%NMPICOMM,IRESP) -#else - CALL MPI_ALLREDUCE(SIZE(KFIELD),ISIZEMAX,1,MPI_INTEGER8,MPI_MAX,TPFILE%NMPICOMM,IRESP) -#endif - IF (ISIZEMAX==0) THEN - CALL PRINT_MSG(NVERB_INFO,'IO','IO_WRITE_FIELD_BYFIELD_N2','ignoring variable with a zero size ('//TRIM(YRECFM)//')') - IF (PRESENT(KRESP)) KRESP=0 - RETURN - END IF - - CALL SECOND_MNH2(T0) - IF (ISP == TPFILE%NMASTER_RANK) THEN - ! I/O process case - CALL ALLOCBUFFER_ll(IFIELDP,KFIELD,YDIR,GALLOC) - ELSE - ALLOCATE(IFIELDP(0,0)) - GALLOC = .TRUE. - END IF - ! - IF (YDIR == 'XX' .OR. YDIR =='YY') THEN - CALL GATHER_XXFIELD(YDIR,KFIELD,IFIELDP,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) - ELSEIF (YDIR == 'XY') THEN - IF (LPACK .AND. L2D) THEN - CALL GATHER_XXFIELD('XX',KFIELD(:,JPHEXT+1),IFIELDP(:,1),TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) - ELSE - CALL GATHER_XYFIELD(KFIELD,IFIELDP,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) - END IF - END IF - CALL SECOND_MNH2(T1) - TIMEZ%T_WRIT2D_GATH=TIMEZ%T_WRIT2D_GATH + T1 - T0 - ! - IF (ISP == TPFILE%NMASTER_RANK) THEN - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,IFIELDP,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,IFIELDP,IRESP) - END IF - CALL SECOND_MNH2(T2) - TIMEZ%T_WRIT2D_WRIT=TIMEZ%T_WRIT2D_WRIT + T2 - T1 - ! - CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - END IF - END IF - ! - IF (IRESP.NE.0) THEN - WRITE(YRESP, '( I6 )') IRESP - YMSG = 'RESP='//YRESP//' when writing '//TRIM(YRECFM)//' in '//TRIM(TPFILE%CNAME) - CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_FIELD_BYFIELD_N2',YMSG) - END IF - IF (GALLOC) DEALLOCATE(IFIELDP) - IF (PRESENT(KRESP)) KRESP = IRESP - CALL SECOND_MNH2(T22) - TIMEZ%T_WRIT2D_ALL=TIMEZ%T_WRIT2D_ALL + T22 - T11 - ! - END SUBROUTINE IO_WRITE_FIELD_BYFIELD_N2 - - - SUBROUTINE IO_WRITE_FIELD_BYNAME_N3(TPFILE,HNAME,KFIELD,KRESP) - ! - USE MODD_IO_ll, ONLY : TFILEDATA - ! - !* 0.1 Declarations of arguments - ! - TYPE(TFILEDATA), INTENT(IN) :: TPFILE - CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write - INTEGER,DIMENSION(:,:,:), INTENT(IN) :: KFIELD ! array containing the data field - INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code - ! - !* 0.2 Declarations of local variables - ! - INTEGER :: ID ! Index of the field - INTEGER :: IRESP ! return_code - ! - CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYNAME_N3',TRIM(TPFILE%CNAME)//': writing '//TRIM(HNAME)) - ! - CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) - ! - IF(IRESP==0) CALL IO_WRITE_FIELD(TPFILE,TFIELDLIST(ID),KFIELD,IRESP) - ! - IF (PRESENT(KRESP)) KRESP = IRESP - ! - END SUBROUTINE IO_WRITE_FIELD_BYNAME_N3 - - SUBROUTINE IO_WRITE_FIELD_BYFIELD_N3(TPFILE,TPFIELD,KFIELD,KRESP) - USE MODD_IO_ll - USE MODD_PARAMETERS_ll, ONLY : JPHEXT - USE MODD_TIMEZ, ONLY : TIMEZ - ! - USE MODE_ALLOCBUFFER_ll - USE MODE_GATHER_ll - USE MODE_MNH_TIMING, ONLY : SECOND_MNH2 - ! - IMPLICIT NONE - ! - !* 0.1 Declarations of arguments - ! - TYPE(TFILEDATA), INTENT(IN) :: TPFILE - TYPE(TFIELDDATA), INTENT(IN) :: TPFIELD - INTEGER,DIMENSION(:,:,:),TARGET,INTENT(IN) :: KFIELD ! array containing the data field - INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code - ! - !* 0.2 Declarations of local variables - ! - CHARACTER(LEN=28) :: YFILEM ! FM-file name - CHARACTER(LEN=NMNHNAMELGTMAX) :: YRECFM ! name of the article to write - CHARACTER(LEN=2) :: YDIR ! field form - INTEGER :: IERR - INTEGER :: ISIZEMAX - INTEGER :: IRESP - INTEGER,DIMENSION(:,:,:),POINTER :: IFIELDP - LOGICAL :: GALLOC - ! - REAL*8,DIMENSION(2) :: T11,T22 - INTEGER :: IHEXTOT - CHARACTER(LEN=:),ALLOCATABLE :: YMSG - CHARACTER(LEN=6) :: YRESP - ! - YFILEM = TPFILE%CNAME - YRECFM = TPFIELD%CMNHNAME - YDIR = TPFIELD%CDIR - ! - IRESP = 0 - GALLOC = .FALSE. - ! - IHEXTOT = 2*JPHEXT+1 - ! - CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYFIELD_N3',TRIM(YFILEM)//': writing '//TRIM(YRECFM)) - ! - CALL SECOND_MNH2(T11) - ! - CALL FIELD_METADATA_CHECK(TPFIELD,TYPEINT,3,'IO_WRITE_FIELD_BYFIELD_N3') - ! - CALL IO_FILE_WRITE_CHECK(TPFILE,'IO_WRITE_FIELD_BYFIELD_N3',IRESP) - ! - IF (IRESP==0) THEN - IF (GSMONOPROC) THEN ! sequential execution - IF (LPACK .AND. L1D .AND. SIZE(KFIELD,1)==IHEXTOT .AND. SIZE(KFIELD,2)==IHEXTOT) THEN - IFIELDP=>KFIELD(JPHEXT+1:JPHEXT+1,JPHEXT+1:JPHEXT+1,:) - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,IFIELDP,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,IFIELDP,IRESP) - ! ELSE IF (LPACK .AND. L2D .AND. YDIR=='XY') THEN - ELSEIF (LPACK .AND. L2D .AND. SIZE(KFIELD,2)==IHEXTOT) THEN - IFIELDP=>KFIELD(:,JPHEXT+1:JPHEXT+1,:) - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,IFIELDP,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,IFIELDP,IRESP) - ELSE - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,KFIELD,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,KFIELD,IRESP) - END IF - ELSE ! multiprocesses execution -#ifndef MNH_INT8 - CALL MPI_ALLREDUCE(SIZE(KFIELD),ISIZEMAX,1,MPI_INTEGER,MPI_MAX,TPFILE%NMPICOMM,IRESP) -#else - CALL MPI_ALLREDUCE(SIZE(KFIELD),ISIZEMAX,1,MPI_INTEGER8,MPI_MAX,TPFILE%NMPICOMM,IRESP) -#endif - IF (ISIZEMAX==0) THEN - CALL PRINT_MSG(NVERB_INFO,'IO','IO_WRITE_FIELD_BYFIELD_N3','ignoring variable with a zero size ('//TRIM(YRECFM)//')') - IF (PRESENT(KRESP)) KRESP=0 - RETURN - END IF - - IF (ISP == TPFILE%NMASTER_RANK) THEN - ! I/O process case - CALL ALLOCBUFFER_ll(IFIELDP,KFIELD,YDIR,GALLOC) - ELSE - ALLOCATE(IFIELDP(0,0,0)) - GALLOC = .TRUE. - END IF - ! - IF (YDIR == 'XX' .OR. YDIR =='YY') THEN - CALL GATHER_XXFIELD(YDIR,KFIELD,IFIELDP,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) - ELSEIF (YDIR == 'XY') THEN - IF (LPACK .AND. L2D) THEN - CALL GATHER_XXFIELD('XX',KFIELD(:,JPHEXT+1,:),IFIELDP(:,1,:),TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) - ELSE - CALL GATHER_XYFIELD(KFIELD,IFIELDP,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) - END IF - END IF - ! - IF (ISP == TPFILE%NMASTER_RANK) THEN - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,IFIELDP,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,IFIELDP,IRESP) - END IF - ! - CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - END IF - END IF - ! - IF (IRESP.NE.0) THEN - WRITE(YRESP, '( I6 )') IRESP - YMSG = 'RESP='//YRESP//' when writing '//TRIM(YRECFM)//' in '//TRIM(TPFILE%CNAME) - CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_FIELD_BYFIELD_N3',YMSG) - END IF - IF (GALLOC) DEALLOCATE(IFIELDP) - IF (PRESENT(KRESP)) KRESP = IRESP - CALL SECOND_MNH2(T22) - TIMEZ%T_WRIT3D_ALL=TIMEZ%T_WRIT3D_ALL + T22 - T11 - ! - END SUBROUTINE IO_WRITE_FIELD_BYFIELD_N3 - - - SUBROUTINE IO_WRITE_FIELD_BYNAME_L0(TPFILE,HNAME,OFIELD,KRESP) - ! - USE MODD_IO_ll, ONLY : TFILEDATA - ! - !* 0.1 Declarations of arguments - ! - TYPE(TFILEDATA), INTENT(IN) :: TPFILE - CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write - LOGICAL, INTENT(IN) :: OFIELD ! array containing the data field - INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code - ! - !* 0.2 Declarations of local variables - ! - INTEGER :: ID ! Index of the field - INTEGER :: IRESP ! return_code - ! - CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYNAME_L0',TRIM(TPFILE%CNAME)//': writing '//TRIM(HNAME)) - ! - CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) - ! - IF(IRESP==0) CALL IO_WRITE_FIELD(TPFILE,TFIELDLIST(ID),OFIELD,IRESP) - ! - IF (PRESENT(KRESP)) KRESP = IRESP - ! - END SUBROUTINE IO_WRITE_FIELD_BYNAME_L0 - - SUBROUTINE IO_WRITE_FIELD_BYFIELD_L0(TPFILE,TPFIELD,OFIELD,KRESP) - USE MODD_IO_ll - ! - USE MODE_IO_MANAGE_STRUCT, ONLY: IO_FILE_FIND_BYNAME - !* 0. DECLARATIONS - ! ------------ - ! - ! - !* 0.1 Declarations of arguments - ! - TYPE(TFILEDATA), INTENT(IN) :: TPFILE - TYPE(TFIELDDATA), INTENT(IN) :: TPFIELD - LOGICAL, INTENT(IN) :: OFIELD ! array containing the data field - INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code - ! - !* 0.2 Declarations of local variables - ! - INTEGER :: IERR - INTEGER :: IRESP - INTEGER :: IK_FILE - TYPE(TFILEDATA),POINTER :: TZFILE - CHARACTER(LEN=:),ALLOCATABLE :: YMSG - CHARACTER(LEN=6) :: YRESP - ! - IRESP = 0 - TZFILE => NULL() - ! - CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYFIELD_L0',TRIM(TPFILE%CNAME)//': writing '//TRIM(TPFIELD%CMNHNAME)) - ! - CALL FIELD_METADATA_CHECK(TPFIELD,TYPELOG,0,'IO_WRITE_FIELD_BYFIELD_L0') - ! - CALL IO_FILE_WRITE_CHECK(TPFILE,'IO_WRITE_FIELD_BYFIELD_L0',IRESP) - ! - IF (IRESP==0) THEN - IF (GSMONOPROC) THEN ! sequential execution - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,OFIELD,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,OFIELD,IRESP) - ELSE - IF (ISP == TPFILE%NMASTER_RANK) THEN - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,OFIELD,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,OFIELD,IRESP) - END IF - ! - CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - END IF ! multiprocesses execution - IF (TPFILE%NSUBFILES_IOZ>0) THEN - ! write the data in all Z files - DO IK_FILE=1,TPFILE%NSUBFILES_IOZ - TZFILE => TPFILE%TFILES_IOZ(IK_FILE)%TFILE - IF ( ISP == TZFILE%NMASTER_RANK ) THEN - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TZFILE,TPFIELD,OFIELD,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TZFILE,TPFIELD,OFIELD,IRESP) - END IF - END DO - ENDIF - END IF - ! - IF (IRESP.NE.0) THEN - WRITE(YRESP, '( I6 )') IRESP - YMSG = 'RESP='//YRESP//' when writing '//TRIM(TPFIELD%CMNHNAME)//' in '//TRIM(TPFILE%CNAME) - CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_FIELD_BYFIELD_L0',YMSG) - END IF - IF (PRESENT(KRESP)) KRESP = IRESP - END SUBROUTINE IO_WRITE_FIELD_BYFIELD_L0 - - - SUBROUTINE IO_WRITE_FIELD_BYNAME_L1(TPFILE,HNAME,OFIELD,KRESP) - ! - USE MODD_IO_ll, ONLY : TFILEDATA - ! - !* 0.1 Declarations of arguments - ! - TYPE(TFILEDATA), INTENT(IN) :: TPFILE - CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write - LOGICAL,DIMENSION(:), INTENT(IN) :: OFIELD ! array containing the data field - INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code - ! - !* 0.2 Declarations of local variables - ! - INTEGER :: ID ! Index of the field - INTEGER :: IRESP ! return_code - ! - CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYNAME_L1',TRIM(TPFILE%CNAME)//': writing '//TRIM(HNAME)) - ! - CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) - ! - IF(IRESP==0) CALL IO_WRITE_FIELD(TPFILE,TFIELDLIST(ID),OFIELD,IRESP) - ! - IF (PRESENT(KRESP)) KRESP = IRESP - ! - END SUBROUTINE IO_WRITE_FIELD_BYNAME_L1 - - - SUBROUTINE IO_WRITE_FIELD_BYFIELD_L1(TPFILE,TPFIELD,OFIELD,KRESP) - ! - USE MODD_IO_ll, ONLY : ISP,GSMONOPROC,LIOCDF4,LLFIOUT,TFILEDATA - ! - USE MODE_ALLOCBUFFER_ll - USE MODE_GATHER_ll - ! - IMPLICIT NONE - ! - !* 0.1 Declarations of arguments - ! - TYPE(TFILEDATA), INTENT(IN) :: TPFILE - TYPE(TFIELDDATA), INTENT(IN) :: TPFIELD - LOGICAL,DIMENSION(:),TARGET, INTENT(IN) :: OFIELD ! array containing the data field - INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code - ! - !* 0.2 Declarations of local variables - ! - CHARACTER(LEN=28) :: YFILEM ! FM-file name - CHARACTER(LEN=NMNHNAMELGTMAX) :: YRECFM ! name of the article to write - CHARACTER(LEN=2) :: YDIR ! field form - INTEGER :: IERR - INTEGER :: ISIZEMAX - INTEGER :: IRESP - LOGICAL,DIMENSION(:),POINTER :: GFIELDP - LOGICAL :: GALLOC - CHARACTER(LEN=:),ALLOCATABLE :: YMSG - CHARACTER(LEN=6) :: YRESP - ! - YFILEM = TPFILE%CNAME - YRECFM = TPFIELD%CMNHNAME - YDIR = TPFIELD%CDIR - ! - IRESP = 0 - GALLOC = .FALSE. - ! - CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYFIELD_L1',TRIM(YFILEM)//': writing '//TRIM(YRECFM)) - ! - CALL FIELD_METADATA_CHECK(TPFIELD,TYPELOG,1,'IO_WRITE_FIELD_BYFIELD_L1') - ! - CALL IO_FILE_WRITE_CHECK(TPFILE,'IO_WRITE_FIELD_BYFIELD_L1',IRESP) - ! - IF (IRESP==0) THEN - IF (GSMONOPROC) THEN ! sequential execution - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,OFIELD,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,OFIELD,IRESP) - ELSE ! multiprocesses execution -#ifndef MNH_INT8 - CALL MPI_ALLREDUCE(SIZE(OFIELD),ISIZEMAX,1,MPI_INTEGER,MPI_MAX,TPFILE%NMPICOMM,IRESP) -#else - CALL MPI_ALLREDUCE(SIZE(OFIELD),ISIZEMAX,1,MPI_INTEGER8,MPI_MAX,TPFILE%NMPICOMM,IRESP) -#endif - IF (ISIZEMAX==0) THEN - CALL PRINT_MSG(NVERB_INFO,'IO','IO_WRITE_FIELD_BYFIELD_L1','ignoring variable with a zero size ('//TRIM(YRECFM)//')') - IF (PRESENT(KRESP)) KRESP=0 - RETURN - END IF - - IF (ISP == TPFILE%NMASTER_RANK) THEN - CALL ALLOCBUFFER_ll(GFIELDP,OFIELD,YDIR,GALLOC) - ELSE - ALLOCATE(GFIELDP(0)) - GALLOC = .TRUE. - END IF - ! - IF (YDIR == 'XX' .OR. YDIR =='YY') THEN - CALL GATHER_XXFIELD(YDIR,OFIELD,GFIELDP,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) - END IF - ! - IF (ISP == TPFILE%NMASTER_RANK) THEN - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,GFIELDP,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,GFIELDP,IRESP) - END IF - ! - CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - END IF - END IF - ! - IF (IRESP.NE.0) THEN - WRITE(YRESP, '( I6 )') IRESP - YMSG = 'RESP='//YRESP//' when writing '//TRIM(YRECFM)//' in '//TRIM(TPFILE%CNAME) - CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_FIELD_BYFIELD_L1',YMSG) - END IF - IF (GALLOC) DEALLOCATE(GFIELDP) - IF (PRESENT(KRESP)) KRESP = IRESP - ! - END SUBROUTINE IO_WRITE_FIELD_BYFIELD_L1 - - - SUBROUTINE IO_WRITE_FIELD_BYNAME_C0(TPFILE,HNAME,HFIELD,KRESP) - ! - USE MODD_IO_ll, ONLY : TFILEDATA - ! - !* 0.1 Declarations of arguments - ! - TYPE(TFILEDATA), INTENT(IN) :: TPFILE - CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write - CHARACTER(LEN=*), INTENT(IN) :: HFIELD ! array containing the data field - INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code - ! - !* 0.2 Declarations of local variables - ! - INTEGER :: ID ! Index of the field - INTEGER :: IRESP ! return_code - ! - CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYNAME_C0',TRIM(TPFILE%CNAME)//': writing '//TRIM(HNAME)) - ! - CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) - ! - IF(IRESP==0) CALL IO_WRITE_FIELD(TPFILE,TFIELDLIST(ID),HFIELD,IRESP) - ! - IF (PRESENT(KRESP)) KRESP = IRESP - ! - END SUBROUTINE IO_WRITE_FIELD_BYNAME_C0 - - - SUBROUTINE IO_WRITE_FIELD_BYFIELD_C0(TPFILE,TPFIELD,HFIELD,KRESP) - USE MODD_IO_ll - ! - !* 0. DECLARATIONS - ! ------------ - ! - ! - !* 0.1 Declarations of arguments - ! - TYPE(TFILEDATA), INTENT(IN) :: TPFILE - TYPE(TFIELDDATA), INTENT(IN) :: TPFIELD - CHARACTER(LEN=*), INTENT(IN) :: HFIELD ! array containing the data field - INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code - ! - !* 0.2 Declarations of local variables - ! - INTEGER :: IERR - INTEGER :: IRESP - CHARACTER(LEN=:),ALLOCATABLE :: YMSG - CHARACTER(LEN=6) :: YRESP - ! - IRESP = 0 - ! - CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYFIELD_C0',TRIM(TPFILE%CNAME)//': writing '//TRIM(TPFIELD%CMNHNAME)) - ! - CALL FIELD_METADATA_CHECK(TPFIELD,TYPECHAR,0,'IO_WRITE_FIELD_BYFIELD_C0') - ! - IF (LEN(HFIELD)==0 .AND. LLFIOUT) THEN - CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_FIELD_BYFIELD_C0',& - 'zero-size string not allowed if LFI output for '//TRIM(TPFIELD%CMNHNAME)) - END IF - ! - CALL IO_FILE_WRITE_CHECK(TPFILE,'IO_WRITE_FIELD_BYFIELD_C0',IRESP) - ! - IF (IRESP==0) THEN - IF (GSMONOPROC) THEN ! sequential execution - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,HFIELD,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,HFIELD,IRESP) - ELSE - IF (ISP == TPFILE%NMASTER_RANK) THEN - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,HFIELD,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,HFIELD,IRESP) - END IF - ! - CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - END IF - END IF - ! - IF (IRESP.NE.0) THEN - WRITE(YRESP, '( I6 )') IRESP - YMSG = 'RESP='//YRESP//' when writing '//TRIM(TPFIELD%CMNHNAME)//' in '//TRIM(TPFILE%CNAME) - CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_FIELD_BYFIELD_C0',YMSG) - END IF - IF (PRESENT(KRESP)) KRESP = IRESP - END SUBROUTINE IO_WRITE_FIELD_BYFIELD_C0 - - - SUBROUTINE IO_WRITE_FIELD_BYNAME_C1(TPFILE,HNAME,HFIELD,KRESP) - ! - USE MODD_IO_ll, ONLY : TFILEDATA - ! - !* 0.1 Declarations of arguments - ! - TYPE(TFILEDATA), INTENT(IN) :: TPFILE - CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write - CHARACTER(LEN=*),DIMENSION(:),INTENT(IN) :: HFIELD ! array containing the data field - INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code - ! - !* 0.2 Declarations of local variables - ! - INTEGER :: ID ! Index of the field - INTEGER :: IRESP ! return_code - ! - CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYNAME_C1',TRIM(TPFILE%CNAME)//': writing '//TRIM(HNAME)) - ! - CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) - ! - IF(IRESP==0) CALL IO_WRITE_FIELD(TPFILE,TFIELDLIST(ID),HFIELD,IRESP) - ! - IF (PRESENT(KRESP)) KRESP = IRESP - ! - END SUBROUTINE IO_WRITE_FIELD_BYNAME_C1 - - - SUBROUTINE IO_WRITE_FIELD_BYFIELD_C1(TPFILE,TPFIELD,HFIELD,KRESP) - USE MODD_IO_ll - ! - !* 0. DECLARATIONS - ! ------------ - ! - ! - !* 0.1 Declarations of arguments - ! - TYPE(TFILEDATA), INTENT(IN) :: TPFILE - TYPE(TFIELDDATA), INTENT(IN) :: TPFIELD - CHARACTER(LEN=*),DIMENSION(:),INTENT(IN) :: HFIELD ! array containing the data field - INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code - ! - !* 0.2 Declarations of local variables - ! - INTEGER :: IERR - INTEGER :: IRESP - INTEGER :: J,JJ - INTEGER :: ILE, IP - INTEGER,DIMENSION(:),ALLOCATABLE :: IFIELD - INTEGER :: ILENG - CHARACTER(LEN=:),ALLOCATABLE :: YMSG - CHARACTER(LEN=6) :: YRESP - ! - CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYFIELD_C1',TRIM(TPFILE%CNAME)//': writing '//TRIM(TPFIELD%CMNHNAME)) - ! - CALL FIELD_METADATA_CHECK(TPFIELD,TYPECHAR,1,'IO_WRITE_FIELD_BYFIELD_C1') - ! - IRESP = 0 - ! - IF(LLFIOUT) THEN - ILE=LEN(HFIELD) - IP=SIZE(HFIELD) - ILENG=ILE*IP - ! - IF (ILENG==0) THEN - IP=1 - ILE=1 - ILENG=1 - ALLOCATE(IFIELD(1)) - IFIELD(1)=IACHAR(' ') - ELSE - ALLOCATE(IFIELD(ILENG)) - DO JJ=1,IP - DO J=1,ILE - IFIELD(ILE*(JJ-1)+J)=IACHAR(HFIELD(JJ)(J:J)) - END DO - END DO - END IF - END IF - ! - CALL IO_FILE_WRITE_CHECK(TPFILE,'IO_WRITE_FIELD_BYFIELD_C1',IRESP) - ! - IF (IRESP==0) THEN - IF (GSMONOPROC) THEN ! sequential execution - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,IFIELD,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,HFIELD,IRESP) - ELSE - IF (ISP == TPFILE%NMASTER_RANK) THEN - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,IFIELD,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,HFIELD,IRESP) - END IF - ! - CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - END IF - END IF - ! - IF (IRESP.NE.0) THEN - WRITE(YRESP, '( I6 )') IRESP - YMSG = 'RESP='//YRESP//' when writing '//TRIM(TPFIELD%CMNHNAME)//' in '//TRIM(TPFILE%CNAME) - CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_FIELD_BYFIELD_C1',YMSG) - END IF - IF (ALLOCATED(IFIELD)) DEALLOCATE(IFIELD) - IF (PRESENT(KRESP)) KRESP = IRESP - END SUBROUTINE IO_WRITE_FIELD_BYFIELD_C1 - - - SUBROUTINE IO_WRITE_FIELD_BYNAME_T0(TPFILE,HNAME,TFIELD,KRESP) - ! - USE MODD_IO_ll, ONLY : TFILEDATA - ! - !* 0.1 Declarations of arguments - ! - TYPE(TFILEDATA), INTENT(IN) :: TPFILE - CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write - TYPE (DATE_TIME), INTENT(IN) :: TFIELD ! array containing the data field - INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code - ! - !* 0.2 Declarations of local variables - ! - INTEGER :: ID ! Index of the field - INTEGER :: IRESP ! return_code - ! - CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYNAME_T0',TRIM(TPFILE%CNAME)//': writing '//TRIM(HNAME)) - ! - CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) - ! - IF(IRESP==0) CALL IO_WRITE_FIELD(TPFILE,TFIELDLIST(ID),TFIELD,IRESP) - ! - IF (PRESENT(KRESP)) KRESP = IRESP - ! - END SUBROUTINE IO_WRITE_FIELD_BYNAME_T0 - - - SUBROUTINE IO_WRITE_FIELD_BYFIELD_T0(TPFILE,TPFIELD,TFIELD,KRESP) - USE MODD_IO_ll - USE MODD_TYPE_DATE - ! - !* 0. DECLARATIONS - ! ------------ - ! - ! - !* 0.1 Declarations of arguments - ! - TYPE(TFILEDATA), INTENT(IN) :: TPFILE - TYPE(TFIELDDATA), INTENT(IN) :: TPFIELD - TYPE (DATE_TIME), INTENT(IN) :: TFIELD ! array containing the data field - INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code - ! - !* 0.2 Declarations of local variables - ! - INTEGER :: IERR - INTEGER :: IRESP - CHARACTER(LEN=:),ALLOCATABLE :: YMSG - CHARACTER(LEN=6) :: YRESP - ! - CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYFIELD_T0',TRIM(TPFILE%CNAME)//': writing '//TRIM(TPFIELD%CMNHNAME)) - ! - CALL FIELD_METADATA_CHECK(TPFIELD,TYPEDATE,0,'IO_WRITE_FIELD_BYFIELD_T0') - ! - IRESP = 0 - ! - CALL IO_FILE_WRITE_CHECK(TPFILE,'IO_WRITE_FIELD_BYFIELD_T0',IRESP) - ! - IF (IRESP==0) THEN - IF (GSMONOPROC) THEN ! sequential execution - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,TFIELD,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,TFIELD,IRESP) - ELSE - IF (ISP == TPFILE%NMASTER_RANK) THEN - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,TFIELD,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,TFIELD,IRESP) - END IF - ! - CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - END IF - END IF - ! - IF (IRESP.NE.0) THEN - WRITE(YRESP, '( I6 )') IRESP - YMSG = 'RESP='//YRESP//' when writing '//TRIM(TPFIELD%CMNHNAME)//' in '//TRIM(TPFILE%CNAME) - CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_FIELD_BYFIELD_T0',YMSG) - END IF - IF (PRESENT(KRESP)) KRESP = IRESP - END SUBROUTINE IO_WRITE_FIELD_BYFIELD_T0 - - - SUBROUTINE IO_WRITE_FIELD_BYNAME_LB(TPFILE,HNAME,KL3D,PLB,KRESP) - ! - USE MODD_IO_ll, ONLY : TFILEDATA - ! - !* 0.1 Declarations of arguments - ! - TYPE(TFILEDATA), INTENT(IN) :: TPFILE - CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write - INTEGER, INTENT(IN) :: KL3D ! size of the LB array in FM - REAL,DIMENSION(:,:,:), INTENT(IN) :: PLB ! array containing the LB field - INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code - ! - !* 0.2 Declarations of local variables - ! - INTEGER :: ID ! Index of the field - INTEGER :: IRESP ! return_code - ! - CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYNAME_LB',TRIM(TPFILE%CNAME)//': writing '//TRIM(HNAME)) - ! - CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) - ! - IF(IRESP==0) CALL IO_WRITE_FIELD_LB(TPFILE,TFIELDLIST(ID),KL3D,PLB,IRESP) - ! - IF (PRESENT(KRESP)) KRESP = IRESP - ! - END SUBROUTINE IO_WRITE_FIELD_BYNAME_LB - - - SUBROUTINE IO_WRITE_FIELD_BYFIELD_LB(TPFILE,TPFIELD,KL3D,PLB,KRESP) - ! - USE MODD_IO_ll - USE MODD_PARAMETERS_ll, ONLY : JPHEXT - USE MODD_VAR_ll, ONLY : MNH_STATUSES_IGNORE - ! - USE MODE_DISTRIB_LB - USE MODE_TOOLS_ll, ONLY : GET_GLOBALDIMS_ll - ! - ! - !* 0.1 Declarations of arguments - ! - TYPE(TFILEDATA), INTENT(IN) :: TPFILE - TYPE(TFIELDDATA), INTENT(INOUT) :: TPFIELD - INTEGER, INTENT(IN) :: KL3D ! size of the LB array in FM - REAL,DIMENSION(:,:,:),TARGET,INTENT(IN) :: PLB ! array containing the LB field - INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code - ! - !* 0.2 Declarations of local variables - ! - CHARACTER(LEN=28) :: YFILEM ! FM-file name - CHARACTER(LEN=NMNHNAMELGTMAX) :: YRECFM ! name of the article to write - CHARACTER(LEN=4) :: YLBTYPE ! 'LBX','LBXU','LBY' or 'LBYV' - INTEGER :: IRIM ! size of the LB area - INTEGER :: IERR - INTEGER :: IRESP - REAL,DIMENSION(:,:,:),ALLOCATABLE,TARGET :: Z3D - REAL,DIMENSION(:,:,:), POINTER :: TX3DP - INTEGER :: IIMAX_ll,IJMAX_ll - INTEGER :: JI - INTEGER :: IIB,IIE,IJB,IJE - INTEGER, DIMENSION(MPI_STATUS_SIZE) :: STATUS - INTEGER,ALLOCATABLE,DIMENSION(:) :: REQ_TAB - INTEGER :: NB_REQ,IKU - TYPE TX_3DP - REAL,DIMENSION(:,:,:), POINTER :: X - END TYPE TX_3DP - TYPE(TX_3DP),ALLOCATABLE,DIMENSION(:) :: T_TX3DP - CHARACTER(LEN=:),ALLOCATABLE :: YMSG - CHARACTER(LEN=6) :: YRESP - ! - YFILEM = TPFILE%CNAME - YRECFM = TPFIELD%CMNHNAME - YLBTYPE = TPFIELD%CLBTYPE - ! - IRESP = 0 - ! - CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYFIELD_LB',TRIM(YFILEM)//': writing '//TRIM(YRECFM)) - ! - IF (YLBTYPE/='LBX' .AND. YLBTYPE/='LBXU' .AND. YLBTYPE/='LBY' .AND. YLBTYPE/='LBYV') THEN - CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_FIELD_BYFIELD_LB','unknown LBTYPE ('//YLBTYPE//')') - RETURN - END IF - ! - IF (TPFIELD%CDIR/='') THEN - CALL PRINT_MSG(NVERB_WARNING,'IO','IO_WRITE_FIELD_BYFIELD_LB','CDIR was set for '//TRIM(YRECFM)) - TPFIELD%CDIR='' - END IF - ! - IRIM = (KL3D-2*JPHEXT)/2 - IF (KL3D /= 2*(IRIM+JPHEXT)) THEN - IRESP = -30 - GOTO 1000 - END IF - ! - CALL IO_FILE_WRITE_CHECK(TPFILE,'IO_WRITE_FIELD_BYFIELD_LB',IRESP) - ! - IF (IRESP==0) THEN - IF (GSMONOPROC) THEN ! sequential execution - IF (LPACK .AND. L2D) THEN - TX3DP=>PLB(:,JPHEXT+1:JPHEXT+1,:) - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,TX3DP,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,TX3DP,IRESP) - ELSE - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,PLB,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,PLB,IRESP) - END IF - ELSE - IF (ISP == TPFILE%NMASTER_RANK) THEN - ! I/O proc case - CALL GET_GLOBALDIMS_ll(IIMAX_ll,IJMAX_ll) - IF (YLBTYPE == 'LBX' .OR. YLBTYPE == 'LBXU') THEN - ALLOCATE(Z3D((IRIM+JPHEXT)*2,IJMAX_ll+2*JPHEXT,SIZE(PLB,3))) - ELSE ! YLBTYPE == 'LBY' .OR. YLBTYPE == 'LBYV' - ALLOCATE(Z3D(IIMAX_ll+2*JPHEXT,(IRIM+JPHEXT)*2,SIZE(PLB,3))) - END IF - DO JI = 1,ISNPROC - CALL GET_DISTRIB_LB(YLBTYPE,JI,'FM','WRITE',IRIM,IIB,IIE,IJB,IJE) - IF (IIB /= 0) THEN - TX3DP=>Z3D(IIB:IIE,IJB:IJE,:) - IF (ISP /= JI) THEN - CALL MPI_RECV(TX3DP,SIZE(TX3DP),MPI_FLOAT,JI-1,99,TPFILE%NMPICOMM,STATUS,IERR) - ELSE - CALL GET_DISTRIB_LB(YLBTYPE,JI,'LOC','WRITE',IRIM,IIB,IIE,IJB,IJE) - TX3DP = PLB(IIB:IIE,IJB:IJE,:) - END IF - END IF - END DO - IF (LPACK .AND. L2D) THEN - TX3DP=>Z3D(:,JPHEXT+1:JPHEXT+1,:) - ELSE - TX3DP=>Z3D - END IF - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,TX3DP,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,TX3DP,IRESP) - ELSE - NB_REQ=0 - ALLOCATE(REQ_TAB(1)) - ALLOCATE(T_TX3DP(1)) - IKU = SIZE(PLB,3) - ! Other processes - CALL GET_DISTRIB_LB(YLBTYPE,ISP,'LOC','WRITE',IRIM,IIB,IIE,IJB,IJE) - IF (IIB /= 0) THEN - TX3DP=>PLB(IIB:IIE,IJB:IJE,:) - NB_REQ = NB_REQ + 1 - ALLOCATE(T_TX3DP(NB_REQ)%X(IIB:IIE,IJB:IJE,IKU)) - T_TX3DP(NB_REQ)%X=PLB(IIB:IIE,IJB:IJE,:) - CALL MPI_ISEND(T_TX3DP(NB_REQ)%X,SIZE(TX3DP),MPI_FLOAT,TPFILE%NMASTER_RANK-1,99, & - TPFILE%NMPICOMM,REQ_TAB(NB_REQ),IERR) - !CALL MPI_BSEND(TX3DP,SIZE(TX3DP),MPI_FLOAT,TPFILE%NMASTER_RANK-1,99,TPFILE%NMPICOMM,IERR) - END IF - IF (NB_REQ .GT.0 ) THEN - CALL MPI_WAITALL(NB_REQ,REQ_TAB,MNH_STATUSES_IGNORE,IERR) - DEALLOCATE(T_TX3DP(1)%X) - END IF - DEALLOCATE(T_TX3DP,REQ_TAB) - END IF - ! - CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - END IF - END IF - ! -1000 CONTINUE - IF (IRESP.NE.0) THEN - WRITE(YRESP, '( I6 )') IRESP - YMSG = 'RESP='//YRESP//' when writing '//TRIM(YRECFM)//' in '//TRIM(TPFILE%CNAME) - CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_FIELD_BYFIELD_LB',YMSG) - END IF - ! - IF (ALLOCATED(Z3D)) DEALLOCATE(Z3D) - IF (PRESENT(KRESP)) KRESP = IRESP - END SUBROUTINE IO_WRITE_FIELD_BYFIELD_LB - - - SUBROUTINE IO_WRITE_FIELD_BOX_BYFIELD_X5(TPFILE,TPFIELD,HBUDGET,PFIELD,KXOBOX,KXEBOX,KYOBOX,KYEBOX,KRESP) - ! - USE MODD_IO_ll - ! - USE MODE_GATHER_ll - ! - ! - !* 0.1 Declarations of arguments - ! - TYPE(TFILEDATA), INTENT(IN) :: TPFILE - TYPE(TFIELDDATA), INTENT(IN) :: TPFIELD - CHARACTER(LEN=*), INTENT(IN) :: HBUDGET ! 'BUDGET' (budget) or 'OTHER' (MesoNH field) - REAL,DIMENSION(:,:,:,:,:),TARGET,INTENT(IN) :: PFIELD ! array containing the data field - INTEGER, INTENT(IN) :: KXOBOX ! - INTEGER, INTENT(IN) :: KXEBOX ! Global coordinates of the box - INTEGER, INTENT(IN) :: KYOBOX ! - INTEGER, INTENT(IN) :: KYEBOX ! - INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code - ! - !* 0.2 Declarations of local variables - ! - INTEGER :: IERR - INTEGER :: IRESP - REAL,DIMENSION(:,:,:,:,:),POINTER :: ZFIELDP - LOGICAL :: GALLOC - CHARACTER(LEN=:),ALLOCATABLE :: YMSG - CHARACTER(LEN=6) :: YRESP - ! - CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BOX_BYFIELD_X5',TRIM(TPFILE%CNAME)//': writing '//TRIM(TPFIELD%CMNHNAME)) - ! - IRESP = 0 - GALLOC = .FALSE. - ! - CALL IO_FILE_WRITE_CHECK(TPFILE,'IO_WRITE_FIELD_BOX_BYFIELD_X5',IRESP) - ! - IF (IRESP==0) THEN - IF (GSMONOPROC) THEN ! sequential execution - IF (HBUDGET /= 'BUDGET') THEN - ! take the sub-section of PFIELD defined by the box - ZFIELDP=>PFIELD(KXOBOX:KXEBOX,KYOBOX:KYEBOX,:,:,:) - ELSE - ! take the field as a budget - ZFIELDP=>PFIELD - END IF - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) - ELSE ! multiprocesses execution - IF (ISP == TPFILE%NMASTER_RANK) THEN - ! Allocate the box - ALLOCATE(ZFIELDP(KXEBOX-KXOBOX+1,KYEBOX-KYOBOX+1,SIZE(PFIELD,3),& - & SIZE(PFIELD,4),SIZE(PFIELD,5))) - GALLOC = .TRUE. - ELSE - ALLOCATE(ZFIELDP(0,0,0,0,0)) - GALLOC = .TRUE. - END IF - ! - CALL GATHER_XYFIELD(PFIELD,ZFIELDP,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM,& - & KXOBOX,KXEBOX,KYOBOX,KYEBOX,HBUDGET) - ! - IF (ISP == TPFILE%NMASTER_RANK) THEN - IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) - IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) - END IF - ! - CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) - END IF ! multiprocesses execution - END IF - ! - IF (IRESP.NE.0) THEN - WRITE(YRESP, '( I6 )') IRESP - YMSG = 'RESP='//YRESP//' when writing '//TRIM(TPFIELD%CMNHNAME)//' in '//TRIM(TPFILE%CNAME) - CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_FIELD_BOX_BYFIELD_X5',YMSG) - END IF - IF (GALLOC) DEALLOCATE(ZFIELDP) - IF (PRESENT(KRESP)) KRESP = IRESP - END SUBROUTINE IO_WRITE_FIELD_BOX_BYFIELD_X5 - -END MODULE MODE_FMWRIT +!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier +!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence +!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt +!MNH_LIC for details. version 1. +!----------------------------------------------------------------- +!--------------- special set of characters for CVS information +!----------------------------------------------------------------- +! $Source$ +! $Name$ +! $Revision$ +! $Date$ +!----------------------------------------------------------------- +!Correction : +! J.Escobar : 15/09/2015 : WENO5 & JPHEXT <> 1 +!----------------------------------------------------------------- + +#ifdef MNH_MPI_DOUBLE_PRECISION +#define MPI_FLOAT MPI_DOUBLE_PRECISION +#else +#define MPI_FLOAT MPI_REAL +#endif + +#ifdef MNH_GA +MODULE MODE_GA +#include "mafdecls.fh" +#include "global.fh" + ! + ! Global Array Variables + ! + INTEGER, PARAMETER :: jpix=1 , jpiy = 2 , jpiz = 3 + ! + INTEGER :: NIMAX_ll,NJMAX_ll, IIU_ll,IJU_ll,IKU_ll + integer :: heap=5*10**6, stack + logical :: gstatus_ga + INTEGER, PARAMETER :: ndim_GA = 3 + INTEGER, DIMENSION(ndim_GA) :: dims_GA , chunk_GA + INTEGER,PARAMETER :: CI=1 ,CJ=-1 ,CK=-1 + INTEGER :: g_a + integer, DIMENSION(ndim_GA) :: lo_col, hi_col , ld_col + integer, DIMENSION(ndim_GA) :: lo_zplan , hi_zplan , ld_zplan + INTEGER :: NIXO_L,NIXE_L,NIYO_L,NIYE_L + INTEGER :: NIXO_G,NIXE_G,NIYO_G,NIYE_G + + LOGICAL,SAVE :: GFIRST_GA = .TRUE. + INTEGER :: IIU_ll_MAX = -1, IJU_ll_MAX = -1, IKU_ll_MAX = -1 + + CONTAINS + + SUBROUTINE MNH_INIT_GA(MY_NI,MY_NJ,MY_NK,HRECFM,HRW_MODE) + +! +! Modification +! J.Escobar 5/02/2015 : use JPHEXT from MODD_PARAMETERS_ll + + USE MODE_TOOLS_ll, ONLY : GET_GLOBALDIMS_ll + USE MODD_PARAMETERS_ll, ONLY : JPHEXT + USE MODD_IO_ll, ONLY : ISP + USE MODE_GATHER_ll, ONLY : GET_DOMWRITE_ll + USE MODE_SCATTER_ll, ONLY : GET_DOMREAD_ll + + IMPLICIT NONE + + INTEGER, INTENT(IN) :: MY_NI,MY_NJ,MY_NK + CHARACTER(LEN=*), INTENT(IN) :: HRECFM ! name of the article to write + CHARACTER(LEN=*), INTENT(IN) :: HRW_MODE + + IF ( GFIRST_GA ) THEN + GFIRST_GA = .FALSE. + ! + ! Allocate memory for GA library + ! + stack = heap + !gstatus_ga = ma_init(MT_F_DBL, stack/ISNPROC, heap/ISNPROC) + gstatus_ga = ma_init(MT_F_DBL, stack, heap) + if ( .not. gstatus_ga ) STOP " MA_INIT FAILED " + ! + ! Initialize GA library + ! + !call ga_initialize_ltd(100000000) + call ga_initialize() + END IF + + CALL GET_GLOBALDIMS_ll (NIMAX_ll,NJMAX_ll) + IIU_ll = NIMAX_ll + 2*JPHEXT + IJU_ll = NJMAX_ll + 2*JPHEXT + IKU_ll = MY_NK + ! + ! configure Global array dimensions + ! + dims_GA(JPIX) = IIU_ll + dims_GA(JPIY) = IJU_ll + dims_GA(JPIZ) = IKU_ll + chunk_GA(JPIX) = CI + chunk_GA(JPIY) = CJ + chunk_GA(JPIZ) = CK + IF ( CI .EQ. 1 ) chunk_GA(JPIX) = dims_GA(JPIX) ! 1 block in X direction + IF ( CJ .EQ. 1 ) chunk_GA(JPIY) = dims_GA(JPIY) ! 1 block in Y direction + IF ( CK .EQ. 1 ) chunk_GA(JPIZ) = dims_GA(JPIZ) ! 1 block in Z direction + ! + ! (re)create global array g_a ( if to small create it ... ) + ! + IF ( ( IIU_ll .GT. IIU_ll_MAX ) .OR. ( IJU_ll .GT. IJU_ll_MAX ) .OR. ( IKU_ll .GT. IKU_ll_MAX ) ) THEN + ! + ! reallocate the g_a , if need with bigger Z size + ! + IF ( IKU_ll_MAX .NE. -1 ) gstatus_ga = ga_destroy(g_a) + IIU_ll_MAX = IIU_ll + IJU_ll_MAX = IJU_ll + IKU_ll_MAX = IKU_ll + gstatus_ga = nga_create(MT_F_DBL, ndim_GA, dims_GA, HRECFM ,chunk_GA, g_a) + call ga_sync() + END IF + !----------------------------------------------------------------------! + ! ! + ! Define/describe local column data owned by this process to write ! + ! ! + !----------------------------------------------------------------------! + IF ( HRW_MODE .EQ. "WRITE" ) THEN + CALL GET_DOMWRITE_ll(ISP,'local',NIXO_L,NIXE_L,NIYO_L,NIYE_L) + CALL GET_DOMWRITE_ll(ISP,'global',NIXO_G,NIXE_G,NIYO_G,NIYE_G) + ELSE + CALL GET_DOMREAD_ll(ISP,NIXO_L,NIXE_L,NIYO_L,NIYE_L) + CALL GET_DOMREAD_ll(ISP,NIXO_G,NIXE_G,NIYO_G,NIYE_G) + END IF + ! + ! portion of data to write/put | read/get by this proc + ! + lo_col(JPIX) = NIXO_G + hi_col(JPIX) = NIXE_G + + lo_col(JPIY) = NIYO_G + hi_col(JPIY) = NIYE_G + + lo_col(JPIZ) = 1 + hi_col(JPIZ) = IKU_ll + ! + ! declaration size of this local input column array + ! + ld_col(JPIX) = MY_NI + ld_col(JPIY) = MY_NJ + ld_col(JPIZ) = MY_NK + ! + !-----------------------------------------------------! + ! ! + ! Size of local ZSLICE_ll Write buffer on I/O proc ! + ! ! + !-----------------------------------------------------! + ! + ! declared dimension + ! + ld_zplan(JPIX) = IIU_ll + ld_zplan(JPIY) = IJU_ll + ld_zplan(JPIZ) = 1 + ! + ! write data by Z slide by I/O proc + ! + lo_zplan(JPIX:JPIY) = 1 + hi_zplan(JPIX) = IIU_ll + hi_zplan(JPIY) = IJU_ll + !call ga_sync() + ! + END SUBROUTINE MNH_INIT_GA + +END MODULE MODE_GA + +#endif + +MODULE MODE_FMWRIT + + USE MODD_MPIF + USE MODD_IO_ll, ONLY: TFILEDATA + + USE MODE_FIELD +#if defined(MNH_IOCDF4) + USE MODE_NETCDF +#endif + USE MODE_READWRITE_LFI + + IMPLICIT NONE + + PRIVATE + + INTERFACE IO_WRITE_FIELD + MODULE PROCEDURE IO_WRITE_FIELD_BYNAME_X0, IO_WRITE_FIELD_BYNAME_X1, & + IO_WRITE_FIELD_BYNAME_X2, IO_WRITE_FIELD_BYNAME_X3, & + IO_WRITE_FIELD_BYNAME_X4, IO_WRITE_FIELD_BYNAME_X5, & + IO_WRITE_FIELD_BYNAME_X6, & + IO_WRITE_FIELD_BYNAME_N0, IO_WRITE_FIELD_BYNAME_N1, & + IO_WRITE_FIELD_BYNAME_N2, IO_WRITE_FIELD_BYNAME_N3, & + IO_WRITE_FIELD_BYNAME_L0, IO_WRITE_FIELD_BYNAME_L1, & + IO_WRITE_FIELD_BYNAME_C0, IO_WRITE_FIELD_BYNAME_C1, & + IO_WRITE_FIELD_BYNAME_T0, & + IO_WRITE_FIELD_BYFIELD_X0,IO_WRITE_FIELD_BYFIELD_X1, & + IO_WRITE_FIELD_BYFIELD_X2,IO_WRITE_FIELD_BYFIELD_X3, & + IO_WRITE_FIELD_BYFIELD_X4,IO_WRITE_FIELD_BYFIELD_X5, & + IO_WRITE_FIELD_BYFIELD_X6, & + IO_WRITE_FIELD_BYFIELD_N0,IO_WRITE_FIELD_BYFIELD_N1, & + IO_WRITE_FIELD_BYFIELD_N2,IO_WRITE_FIELD_BYFIELD_N3, & + IO_WRITE_FIELD_BYFIELD_L0,IO_WRITE_FIELD_BYFIELD_L1, & + IO_WRITE_FIELD_BYFIELD_C0,IO_WRITE_FIELD_BYFIELD_C1, & + IO_WRITE_FIELD_BYFIELD_T0 + END INTERFACE + + INTERFACE IO_WRITE_FIELD_BOX + MODULE PROCEDURE IO_WRITE_FIELD_BOX_BYFIELD_X5 + END INTERFACE + + INTERFACE IO_WRITE_FIELD_LB + MODULE PROCEDURE IO_WRITE_FIELD_BYNAME_LB, IO_WRITE_FIELD_BYFIELD_LB + END INTERFACE + + PUBLIC IO_WRITE_FIELD, IO_WRITE_FIELD_BOX, IO_WRITE_FIELD_LB + PUBLIC IO_WRITE_HEADER + +CONTAINS + + SUBROUTINE FIELD_METADATA_CHECK(TPFIELD,KTYPE,KDIMS,HCALLER) + TYPE(TFIELDDATA), INTENT(IN) :: TPFIELD ! Field to check + INTEGER, INTENT(IN) :: KTYPE ! Expected datatype + INTEGER, INTENT(IN) :: KDIMS ! Expected number of dimensions + CHARACTER(LEN=*), INTENT(IN) :: HCALLER ! name of the calling subroutine + ! + CHARACTER(LEN=2) :: YDIMOK,YDIMKO + CHARACTER(LEN=8) :: YTYPEOK,YTYPEKO + ! + IF (TPFIELD%NGRID<0 .OR. TPFIELD%NGRID>8) THEN + CALL PRINT_MSG(NVERB_WARNING,'IO',HCALLER,'TPFIELD%NGRID is invalid for '//TRIM(TPFIELD%CMNHNAME)) + END IF + IF (TPFIELD%NTYPE/=KTYPE) THEN + CALL TYPE_WRITE(KTYPE,YTYPEOK) + CALL TYPE_WRITE(TPFIELD%NTYPE,YTYPEKO) + CALL PRINT_MSG(NVERB_WARNING,'IO',HCALLER,& + 'TPFIELD%NTYPE should be '//YTYPEOK//' instead of '//YTYPEKO//' for '//TRIM(TPFIELD%CMNHNAME)) + END IF + IF (TPFIELD%NDIMS/=KDIMS) THEN + WRITE (YDIMOK,'(I2)') KDIMS + WRITE (YDIMKO,'(I2)') TPFIELD%NDIMS + CALL PRINT_MSG(NVERB_WARNING,'IO',HCALLER,& + 'TPFIELD%NDIMS should be '//YDIMOK//' instead of '//YDIMKO//' for '//TRIM(TPFIELD%CMNHNAME)) + END IF + ! + CONTAINS + SUBROUTINE TYPE_WRITE(KTYPEINT,HTYPE) + INTEGER, INTENT(IN) :: KTYPEINT + CHARACTER(LEN=8),INTENT(OUT) :: HTYPE + ! + SELECT CASE(KTYPEINT) + CASE(TYPEINT) + HTYPE = 'TYPEINT' + CASE(TYPELOG) + HTYPE = 'TYPELOG' + CASE(TYPEREAL) + HTYPE = 'TYPEREAL' + CASE(TYPECHAR) + HTYPE = 'TYPECHAR' + CASE(TYPEDATE) + HTYPE = 'TYPEDATE' + CASE DEFAULT + HTYPE = 'UNKNOWN' + END SELECT + ! + END SUBROUTINE TYPE_WRITE + END SUBROUTINE FIELD_METADATA_CHECK + + + SUBROUTINE IO_FILE_WRITE_CHECK(TPFILE,HSUBR,KRESP) + TYPE(TFILEDATA), INTENT(IN) :: TPFILE + CHARACTER(LEN=*), INTENT(IN) :: HSUBR + INTEGER, INTENT(OUT) :: KRESP + ! + KRESP = 0 + ! + !Check if file is opened + IF (.NOT.TPFILE%LOPENED) THEN + CALL PRINT_MSG(NVERB_ERROR,'IO',HSUBR,TRIM(TPFILE%CNAME)//' is not opened') + KRESP = -201 + RETURN + END IF + ! + !Check if file is in the right opening mode + IF (TPFILE%CMODE/='WRITE') THEN + CALL PRINT_MSG(NVERB_WARNING,'IO',HSUBR,& + TRIM(TPFILE%CNAME)//': writing in a file opened in '//TRIM(TPFILE%CMODE)//' mode') + END IF + ! + !Check fileformat + IF (TPFILE%CFORMAT/='NETCDF4' .AND. TPFILE%CFORMAT=='LFI' .AND. TPFILE%CFORMAT=='LFICDF4') THEN + CALL PRINT_MSG(NVERB_FATAL,'IO',HSUBR,& + TRIM(TPFILE%CNAME)//': invalid fileformat ('//TRIM(TPFILE%CFORMAT)//')') + KRESP = -202 + RETURN + END IF + ! + END SUBROUTINE IO_FILE_WRITE_CHECK + + + SUBROUTINE IO_WRITE_HEADER(TPFILE,HDAD_NAME) + ! + USE MODD_CONF + USE MODD_CONF_n, ONLY: CSTORAGE_TYPE + USE MODD_PARAMETERS, ONLY: NFILENAMELGTMAXLFI + ! + TYPE(TFILEDATA), INTENT(IN) :: TPFILE ! File structure + CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: HDAD_NAME + ! + CHARACTER(LEN=:),ALLOCATABLE :: YDAD_NAME + INTEGER :: ILEN + ! + CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_HEADER','called for file '//TRIM(TPFILE%CNAME)) + ! + IF ( ASSOCIATED(TPFILE%TDADFILE) .AND. PRESENT(HDAD_NAME) ) THEN + IF ( TRIM(TPFILE%TDADFILE%CNAME) /= TRIM(HDAD_NAME) ) THEN + CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_HEADER','TPFILE%TDADFILE%CNAME /= HDAD_NAME') + END IF + END IF + ! + CALL IO_WRITE_HEADER_NC4(TPFILE) + ! + CALL IO_WRITE_FIELD(TPFILE,'MNHVERSION', NMNHVERSION) + CALL IO_WRITE_FIELD(TPFILE,'MASDEV', NMASDEV) + CALL IO_WRITE_FIELD(TPFILE,'BUGFIX', NBUGFIX) + CALL IO_WRITE_FIELD(TPFILE,'BIBUSER', CBIBUSER) + CALL IO_WRITE_FIELD(TPFILE,'PROGRAM', CPROGRAM) + CALL IO_WRITE_FIELD(TPFILE,'STORAGE_TYPE',CSTORAGE_TYPE) + CALL IO_WRITE_FIELD(TPFILE,'MY_NAME', TPFILE%CNAME) + ! + IF ( ASSOCIATED(TPFILE%TDADFILE) ) THEN + ALLOCATE(CHARACTER(LEN=MAX(NFILENAMELGTMAXLFI,LEN_TRIM(TPFILE%TDADFILE%CNAME))) :: YDAD_NAME) + YDAD_NAME(:) = TPFILE%TDADFILE%CNAME + ELSE IF (PRESENT(HDAD_NAME)) THEN + ILEN = LEN_TRIM(HDAD_NAME) + ALLOCATE(CHARACTER(LEN=MAX(NFILENAMELGTMAXLFI,ILEN)) :: YDAD_NAME) + YDAD_NAME(:) = HDAD_NAME + ELSE + CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_HEADER',TRIM(TPFILE%CNAME)// & + ': TPFILE%TDADFILE not associated and HDAD_NAME not provided') + ALLOCATE(CHARACTER(LEN=NFILENAMELGTMAXLFI) :: YDAD_NAME) + YDAD_NAME(:) = ' ' + ENDIF + CALL IO_WRITE_FIELD(TPFILE,'DAD_NAME',YDAD_NAME) + DEALLOCATE(YDAD_NAME) + ! + END SUBROUTINE IO_WRITE_HEADER + + + SUBROUTINE IO_WRITE_FIELD_BYNAME_X0(TPFILE,HNAME,PFIELD,KRESP) + ! + !* 0.1 Declarations of arguments + ! + TYPE(TFILEDATA), INTENT(IN) :: TPFILE + CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write + REAL, INTENT(IN) :: PFIELD ! array containing the data field + INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code + ! + !* 0.2 Declarations of local variables + ! + INTEGER :: ID ! Index of the field + INTEGER :: IRESP ! return_code + ! + CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYNAME_X0',TRIM(TPFILE%CNAME)//': writing '//TRIM(HNAME)) + ! + CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) + ! + IF(IRESP==0) CALL IO_WRITE_FIELD(TPFILE,TFIELDLIST(ID),PFIELD,IRESP) + ! + IF (PRESENT(KRESP)) KRESP = IRESP + ! + END SUBROUTINE IO_WRITE_FIELD_BYNAME_X0 + + + SUBROUTINE IO_WRITE_FIELD_BYFIELD_X0(TPFILE,TPFIELD,PFIELD,KRESP) + USE MODD_IO_ll + ! + USE MODE_IO_MANAGE_STRUCT, ONLY: IO_FILE_FIND_BYNAME + ! + IMPLICIT NONE + ! + !* 0.1 Declarations of arguments + ! + TYPE(TFILEDATA), INTENT(IN) :: TPFILE + TYPE(TFIELDDATA), INTENT(IN) :: TPFIELD + REAL,TARGET, INTENT(IN) :: PFIELD ! array containing the data field + INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code + ! + !* 0.2 Declarations of local variables + ! + CHARACTER(LEN=28) :: YFILEM ! FM-file name + CHARACTER(LEN=NMNHNAMELGTMAX) :: YRECFM ! name of the article to write + CHARACTER(LEN=2) :: YDIR ! field form + INTEGER :: IERR + INTEGER :: IRESP + ! + INTEGER :: IK_FILE + TYPE(TFILEDATA),POINTER :: TZFILE + CHARACTER(LEN=:),ALLOCATABLE :: YMSG + CHARACTER(LEN=6) :: YRESP + ! + YFILEM = TPFILE%CNAME + YRECFM = TPFIELD%CMNHNAME + YDIR = TPFIELD%CDIR + ! + IRESP = 0 + TZFILE => NULL() + ! + CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYFIELD_X0',TRIM(YFILEM)//': writing '//TRIM(YRECFM)) + ! + CALL FIELD_METADATA_CHECK(TPFIELD,TYPEREAL,0,'IO_WRITE_FIELD_BYFIELD_X0') + ! + CALL IO_FILE_WRITE_CHECK(TPFILE,'IO_WRITE_FIELD_BYFIELD_X0',IRESP) + ! + IF (IRESP==0) THEN + IF (GSMONOPROC) THEN ! sequential execution + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,PFIELD,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,PFIELD,IRESP) + ELSE ! multiprocesses execution + IF (ISP == TPFILE%NMASTER_RANK) THEN + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,PFIELD,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,PFIELD,IRESP) + END IF + ! + CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + END IF ! multiprocesses execution + IF (TPFILE%NSUBFILES_IOZ>0) THEN + ! write the data in all Z files + DO IK_FILE=1,TPFILE%NSUBFILES_IOZ + TZFILE => TPFILE%TFILES_IOZ(IK_FILE)%TFILE + IF ( ISP == TZFILE%NMASTER_RANK ) THEN + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TZFILE,TPFIELD,PFIELD,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TZFILE,TPFIELD,PFIELD,IRESP) + END IF + END DO + ENDIF + END IF + ! + IF (IRESP.NE.0) THEN + WRITE(YRESP, '( I6 )') IRESP + YMSG = 'RESP='//YRESP//' when writing '//TRIM(YRECFM)//' in '//TRIM(TPFILE%CNAME) + CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_FIELD_BYFIELD_X0',YMSG) + END IF + IF (PRESENT(KRESP)) KRESP = IRESP + END SUBROUTINE IO_WRITE_FIELD_BYFIELD_X0 + + + SUBROUTINE IO_WRITE_FIELD_BYNAME_X1(TPFILE,HNAME,PFIELD,KRESP) + ! + USE MODD_IO_ll, ONLY : TFILEDATA + ! + !* 0.1 Declarations of arguments + ! + TYPE(TFILEDATA), INTENT(IN) :: TPFILE + CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write + REAL,DIMENSION(:), INTENT(IN) :: PFIELD ! array containing the data field + INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code + ! + !* 0.2 Declarations of local variables + ! + INTEGER :: ID ! Index of the field + INTEGER :: IRESP ! return-code + ! + CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYNAME_X1',TRIM(TPFILE%CNAME)//': writing '//TRIM(HNAME)) + ! + CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) + ! + IF(IRESP==0) CALL IO_WRITE_FIELD(TPFILE,TFIELDLIST(ID),PFIELD,IRESP) + ! + IF (PRESENT(KRESP)) KRESP = IRESP + ! + END SUBROUTINE IO_WRITE_FIELD_BYNAME_X1 + + + SUBROUTINE IO_WRITE_FIELD_BYFIELD_X1(TPFILE,TPFIELD,PFIELD,KRESP) + USE MODD_IO_ll + ! + USE MODE_ALLOCBUFFER_ll + USE MODE_GATHER_ll + USE MODE_IO_MANAGE_STRUCT, ONLY: IO_FILE_FIND_BYNAME + ! + IMPLICIT NONE + ! + !* 0.1 Declarations of arguments + ! + TYPE(TFILEDATA), INTENT(IN) :: TPFILE + TYPE(TFIELDDATA), INTENT(IN) :: TPFIELD + REAL,DIMENSION(:),TARGET, INTENT(IN) :: PFIELD ! array containing the data field + INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code + ! + !* 0.2 Declarations of local variables + ! + CHARACTER(LEN=28) :: YFILEM ! FM-file name + CHARACTER(LEN=NMNHNAMELGTMAX) :: YRECFM ! name of the article to write + CHARACTER(LEN=2) :: YDIR ! field form + INTEGER :: IERR + INTEGER :: IRESP + INTEGER :: ISIZEMAX + REAL,DIMENSION(:),POINTER :: ZFIELDP + LOGICAL :: GALLOC + ! + CHARACTER(LEN=:),ALLOCATABLE :: YMSG + CHARACTER(LEN=6) :: YRESP + ! + IRESP = 0 + GALLOC = .FALSE. + ! + YFILEM = TPFILE%CNAME + YRECFM = TPFIELD%CMNHNAME + YDIR = TPFIELD%CDIR + ! + CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYFIELD_X1',TRIM(YFILEM)//': writing '//TRIM(YRECFM)) + ! + CALL FIELD_METADATA_CHECK(TPFIELD,TYPEREAL,1,'IO_WRITE_FIELD_BYFIELD_X1') + ! + CALL IO_FILE_WRITE_CHECK(TPFILE,'IO_WRITE_FIELD_BYFIELD_X1',IRESP) + ! + IF (IRESP==0) THEN + IF (GSMONOPROC) THEN ! sequential execution + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,PFIELD,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,PFIELD,IRESP) + ELSE ! multiprocesses execution +#ifndef MNH_INT8 + CALL MPI_ALLREDUCE(SIZE(PFIELD),ISIZEMAX,1,MPI_INTEGER,MPI_MAX,TPFILE%NMPICOMM,IRESP) +#else + CALL MPI_ALLREDUCE(SIZE(PFIELD),ISIZEMAX,1,MPI_INTEGER8,MPI_MAX,TPFILE%NMPICOMM,IRESP) +#endif + IF (ISIZEMAX==0) THEN + CALL PRINT_MSG(NVERB_INFO,'IO','IO_WRITE_FIELD_BYFIELD_X1','ignoring variable with a zero size ('//TRIM(YRECFM)//')') + IF (PRESENT(KRESP)) KRESP=0 + RETURN + END IF + + IF (ISP == TPFILE%NMASTER_RANK) THEN + CALL ALLOCBUFFER_ll(ZFIELDP,PFIELD,YDIR,GALLOC) + ELSE + ALLOCATE(ZFIELDP(0)) + GALLOC = .TRUE. + END IF + ! + IF (YDIR == 'XX' .OR. YDIR =='YY') THEN + CALL GATHER_XXFIELD(YDIR,PFIELD,ZFIELDP,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) + END IF + ! + IF (ISP == TPFILE%NMASTER_RANK) THEN + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) + END IF + ! + CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + END IF ! multiprocesses execution + END IF + ! + IF (IRESP.NE.0) THEN + WRITE(YRESP, '( I6 )') IRESP + YMSG = 'RESP='//YRESP//' when writing '//TRIM(YRECFM)//' in '//TRIM(TPFILE%CNAME) + CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_FIELD_BYFIELD_X1',YMSG) + END IF + IF (GALLOC) DEALLOCATE(ZFIELDP) + IF (PRESENT(KRESP)) KRESP = IRESP + END SUBROUTINE IO_WRITE_FIELD_BYFIELD_X1 + + + SUBROUTINE IO_WRITE_FIELD_BYNAME_X2(TPFILE,HNAME,PFIELD,KRESP) + ! + USE MODD_IO_ll, ONLY : TFILEDATA + ! + !* 0.1 Declarations of arguments + ! + TYPE(TFILEDATA), INTENT(IN) :: TPFILE + CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write + REAL,DIMENSION(:,:), INTENT(IN) :: PFIELD ! array containing the data field + INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code + ! + !* 0.2 Declarations of local variables + ! + INTEGER :: ID ! Index of the field + INTEGER :: IRESP ! return-code + ! + CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYNAME_X2',TRIM(TPFILE%CNAME)//': writing '//TRIM(HNAME)) + ! + CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) + ! + IF(IRESP==0) CALL IO_WRITE_FIELD(TPFILE,TFIELDLIST(ID),PFIELD,IRESP) + ! + IF (PRESENT(KRESP)) KRESP = IRESP + ! + END SUBROUTINE IO_WRITE_FIELD_BYNAME_X2 + + + SUBROUTINE IO_WRITE_FIELD_BYFIELD_X2(TPFILE,TPFIELD,PFIELD,KRESP) + USE MODD_IO_ll + USE MODD_PARAMETERS_ll, ONLY : JPHEXT + USE MODD_TIMEZ, ONLY : TIMEZ + ! + USE MODE_ALLOCBUFFER_ll +#ifdef MNH_GA + USE MODE_GA +#endif + USE MODE_GATHER_ll + USE MODE_MNH_TIMING, ONLY : SECOND_MNH2 + ! + IMPLICIT NONE + ! + !* 0.1 Declarations of arguments + ! + TYPE(TFILEDATA), INTENT(IN) :: TPFILE + TYPE(TFIELDDATA), INTENT(IN) :: TPFIELD + REAL,DIMENSION(:,:),TARGET, INTENT(IN) :: PFIELD ! array containing the data field + INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code + ! + !* 0.2 Declarations of local variables + ! + CHARACTER(LEN=28) :: YFILEM ! FM-file name + CHARACTER(LEN=NMNHNAMELGTMAX) :: YRECFM ! name of the article to write + CHARACTER(LEN=2) :: YDIR ! field form + INTEGER :: IERR + INTEGER :: ISIZEMAX + INTEGER :: IRESP + REAL,DIMENSION(:,:),POINTER :: ZFIELDP + LOGICAL :: GALLOC + ! + REAL*8,DIMENSION(2) :: T0,T1,T2 + REAL*8,DIMENSION(2) :: T11,T22 +#ifdef MNH_GA + REAL,DIMENSION(:,:),POINTER :: ZFIELD_GA +#endif + INTEGER :: IHEXTOT + CHARACTER(LEN=:),ALLOCATABLE :: YMSG + CHARACTER(LEN=6) :: YRESP + ! + YFILEM = TPFILE%CNAME + YRECFM = TPFIELD%CMNHNAME + YDIR = TPFIELD%CDIR + ! + IRESP = 0 + GALLOC = .FALSE. + IHEXTOT = 2*JPHEXT+1 + ! + CALL SECOND_MNH2(T11) + ! + CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYFIELD_X2',TRIM(YFILEM)//': writing '//TRIM(YRECFM)) + ! + CALL FIELD_METADATA_CHECK(TPFIELD,TYPEREAL,2,'IO_WRITE_FIELD_BYFIELD_X2') + ! + CALL IO_FILE_WRITE_CHECK(TPFILE,'IO_WRITE_FIELD_BYFIELD_X2',IRESP) + ! + IF (IRESP==0) THEN + IF (GSMONOPROC) THEN ! sequential execution + ! IF (LPACK .AND. L1D .AND. YDIR=='XY') THEN + IF (LPACK .AND. L1D .AND. SIZE(PFIELD,1)==IHEXTOT .AND. SIZE(PFIELD,2)==IHEXTOT) THEN + ZFIELDP=>PFIELD(JPHEXT+1:JPHEXT+1,JPHEXT+1:JPHEXT+1) + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) + ! ELSE IF (LPACK .AND. L2D .AND. YDIR=='XY') THEN + ELSEIF (LPACK .AND. L2D .AND. SIZE(PFIELD,2)==IHEXTOT) THEN + ZFIELDP=>PFIELD(:,JPHEXT+1:JPHEXT+1) + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) + ELSE + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,PFIELD,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,PFIELD,IRESP) + END IF + ELSE ! multiprocesses execution + CALL SECOND_MNH2(T0) +#ifndef MNH_INT8 + CALL MPI_ALLREDUCE(SIZE(PFIELD),ISIZEMAX,1,MPI_INTEGER,MPI_MAX,TPFILE%NMPICOMM,IRESP) +#else + CALL MPI_ALLREDUCE(SIZE(PFIELD),ISIZEMAX,1,MPI_INTEGER8,MPI_MAX,TPFILE%NMPICOMM,IRESP) +#endif + IF (ISIZEMAX==0) THEN + CALL PRINT_MSG(NVERB_INFO,'IO','IO_WRITE_FIELD_BYFIELD_X2','ignoring variable with a zero size ('//TRIM(YRECFM)//')') + IF (PRESENT(KRESP)) KRESP=0 + RETURN + END IF + + IF (ISP == TPFILE%NMASTER_RANK) THEN + ! I/O process case + CALL ALLOCBUFFER_ll(ZFIELDP,PFIELD,YDIR,GALLOC) + ELSE + ALLOCATE(ZFIELDP(0,0)) + GALLOC = .TRUE. + END IF + ! + IF (YDIR == 'XX' .OR. YDIR =='YY') THEN + CALL GATHER_XXFIELD(YDIR,PFIELD,ZFIELDP,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) + ELSEIF (YDIR == 'XY') THEN + IF (LPACK .AND. L2D) THEN + CALL GATHER_XXFIELD('XX',PFIELD(:,JPHEXT+1),ZFIELDP(:,1),TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) + ELSE +#ifdef MNH_GA + ! + ! init/create the ga , dim3 = 1 + ! + CALL MNH_INIT_GA(SIZE(PFIELD,1),SIZE(PFIELD,2),1,YRECFM,"WRITE") + ! + ! copy columun data to global arrays g_a + ! + ALLOCATE (ZFIELD_GA (SIZE(PFIELD,1),SIZE(PFIELD,2))) + ZFIELD_GA = PFIELD + call nga_put(g_a, lo_col, hi_col,ZFIELD_GA(NIXO_L,NIYO_L) , ld_col) + call ga_sync + DEALLOCATE (ZFIELD_GA) + IF (ISP == TPFILE%NMASTER_RANK) THEN + ! + ! this proc get the Z slide to write + ! + lo_zplan(JPIZ) = 1 + hi_zplan(JPIZ) = 1 + call nga_get(g_a, lo_zplan, hi_zplan,ZFIELDP, ld_zplan) + END IF +#else + CALL GATHER_XYFIELD(PFIELD,ZFIELDP,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) +#endif + END IF + END IF + CALL SECOND_MNH2(T1) + TIMEZ%T_WRIT2D_GATH=TIMEZ%T_WRIT2D_GATH + T1 - T0 + ! + IF (ISP == TPFILE%NMASTER_RANK) THEN + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) + END IF +#ifdef MNH_GA + call ga_sync +#endif + CALL SECOND_MNH2(T2) + TIMEZ%T_WRIT2D_WRIT=TIMEZ%T_WRIT2D_WRIT + T2 - T1 + ! + CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + END IF + END IF + ! + IF (IRESP.NE.0) THEN + WRITE(YRESP, '( I6 )') IRESP + YMSG = 'RESP='//YRESP//' when writing '//TRIM(YRECFM)//' in '//TRIM(TPFILE%CNAME) + CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_FIELD_BYFIELD_X2',YMSG) + END IF + IF (GALLOC) DEALLOCATE(ZFIELDP) + IF (PRESENT(KRESP)) KRESP = IRESP + CALL SECOND_MNH2(T22) + TIMEZ%T_WRIT2D_ALL=TIMEZ%T_WRIT2D_ALL + T22 - T11 + END SUBROUTINE IO_WRITE_FIELD_BYFIELD_X2 + + + SUBROUTINE IO_WRITE_FIELD_BYNAME_X3(TPFILE,HNAME,PFIELD,KRESP) + ! + USE MODD_IO_ll, ONLY : TFILEDATA + ! + !* 0.1 Declarations of arguments + ! + TYPE(TFILEDATA), INTENT(IN) :: TPFILE + CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write + REAL,DIMENSION(:,:,:), INTENT(IN) :: PFIELD ! array containing the data field + INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code + ! + !* 0.2 Declarations of local variables + ! + INTEGER :: ID ! Index of the field + INTEGER :: IRESP ! return_code + ! + CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYNAME_X3',TRIM(TPFILE%CNAME)//': writing '//TRIM(HNAME)) + ! + CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) + ! + IF(IRESP==0) CALL IO_WRITE_FIELD(TPFILE,TFIELDLIST(ID),PFIELD,IRESP) + ! + IF (PRESENT(KRESP)) KRESP = IRESP + ! + END SUBROUTINE IO_WRITE_FIELD_BYNAME_X3 + + + SUBROUTINE IO_WRITE_FIELD_BYFIELD_X3(TPFILE,TPFIELD,PFIELD,KRESP) + USE MODD_IO_ll + USE MODD_PARAMETERS_ll, ONLY : JPHEXT + USE MODD_TIMEZ, ONLY : TIMEZ + ! + USE MODE_ALLOCBUFFER_ll + USE MODE_GATHER_ll + USE MODE_IO_ll, ONLY : IO_FILE + USE MODE_IO_MANAGE_STRUCT, ONLY : IO_FILE_FIND_BYNAME + USE MODE_MNH_TIMING, ONLY : SECOND_MNH2 +#ifdef MNH_GA + USE MODE_GA +#endif + USE MODD_VAR_ll, ONLY : MNH_STATUSES_IGNORE + ! + ! + !* 0.1 Declarations of arguments + ! + TYPE(TFILEDATA),TARGET, INTENT(IN) :: TPFILE + TYPE(TFIELDDATA), INTENT(IN) :: TPFIELD + REAL,DIMENSION(:,:,:),TARGET,INTENT(IN) :: PFIELD ! array containing the data field + INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code + ! + !* 0.2 Declarations of local variables + ! + CHARACTER(LEN=28) :: YFILEM ! FM-file name + CHARACTER(LEN=NMNHNAMELGTMAX) :: YRECFM ! name of the article to write + CHARACTER(LEN=2) :: YDIR ! field form + INTEGER :: IERR + INTEGER :: ISIZEMAX + INTEGER :: IRESP + REAL,DIMENSION(:,:,:),POINTER :: ZFIELDP + LOGICAL :: GALLOC + INTEGER :: JK,JKK + REAL,DIMENSION(:,:),POINTER :: ZSLICE_ll,ZSLICE + INTEGER :: IK_FILE,IK_RANK,INB_PROC_REAL,JK_MAX + INTEGER :: JI,IXO,IXE,IYO,IYE + REAL,DIMENSION(:,:),POINTER :: TX2DP + INTEGER, DIMENSION(MPI_STATUS_SIZE) :: STATUS + LOGICAL :: GALLOC_ll + INTEGER,ALLOCATABLE,DIMENSION(:) :: REQ_TAB + INTEGER :: NB_REQ + TYPE TX_2DP + REAL,DIMENSION(:,:), POINTER :: X + END TYPE TX_2DP + TYPE(TX_2DP),ALLOCATABLE,DIMENSION(:) :: T_TX2DP + REAL*8,DIMENSION(2) :: T0,T1,T2 + REAL*8,DIMENSION(2) :: T11,T22 +#ifdef MNH_GA + REAL,DIMENSION(:,:,:),POINTER :: ZFIELD_GA +#endif + INTEGER :: IHEXTOT + CHARACTER(LEN=:),ALLOCATABLE :: YMSG + CHARACTER(LEN=6) :: YRESP + TYPE(TFILEDATA),POINTER :: TZFILE + ! + TZFILE => NULL() + ! + ZSLICE => NULL() + ZSLICE_ll => NULL() + ! + YFILEM = TPFILE%CNAME + YRECFM = TPFIELD%CMNHNAME + YDIR = TPFIELD%CDIR + ! + IRESP = 0 + GALLOC = .FALSE. + GALLOC_ll = .FALSE. + IHEXTOT = 2*JPHEXT+1 + ! + CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYFIELD_X3',TRIM(YFILEM)//': writing '//TRIM(YRECFM)) + ! + CALL SECOND_MNH2(T11) + ! + CALL FIELD_METADATA_CHECK(TPFIELD,TYPEREAL,3,'IO_WRITE_FIELD_BYFIELD_X3') + ! + CALL IO_FILE_WRITE_CHECK(TPFILE,'IO_WRITE_FIELD_BYFIELD_X3',IRESP) + ! + IF (IRESP==0) THEN + IF (GSMONOPROC .AND. TPFILE%NSUBFILES_IOZ==0 ) THEN ! sequential execution + ! IF (LPACK .AND. L1D .AND. YDIR=='XY') THEN + IF (LPACK .AND. L1D .AND. SIZE(PFIELD,1)==IHEXTOT .AND. SIZE(PFIELD,2)==IHEXTOT) THEN + ZFIELDP=>PFIELD(JPHEXT+1:JPHEXT+1,JPHEXT+1:JPHEXT+1,:) + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) + ! ELSE IF (LPACK .AND. L2D .AND. YDIR=='XY') THEN + ELSEIF (LPACK .AND. L2D .AND. SIZE(PFIELD,2)==IHEXTOT) THEN + ZFIELDP=>PFIELD(:,JPHEXT+1:JPHEXT+1,:) + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) + ELSE + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,PFIELD,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,PFIELD,IRESP) + END IF + ELSEIF ( TPFILE%NSUBFILES_IOZ==0 .OR. YDIR=='--' ) THEN ! multiprocesses execution & 1 proc IO +#ifndef MNH_INT8 + CALL MPI_ALLREDUCE(SIZE(PFIELD),ISIZEMAX,1,MPI_INTEGER,MPI_MAX,TPFILE%NMPICOMM,IRESP) +#else + CALL MPI_ALLREDUCE(SIZE(PFIELD),ISIZEMAX,1,MPI_INTEGER8,MPI_MAX,TPFILE%NMPICOMM,IRESP) +#endif + IF (ISIZEMAX==0) THEN + CALL PRINT_MSG(NVERB_INFO,'IO','IO_WRITE_FIELD_BYFIELD_X3','ignoring variable with a zero size ('//TRIM(YRECFM)//')') + IF (PRESENT(KRESP)) KRESP=0 + RETURN + END IF + + ! write 3D field in 1 time = output for graphique + IF (ISP == TPFILE%NMASTER_RANK) THEN + CALL ALLOCBUFFER_ll(ZFIELDP,PFIELD,YDIR,GALLOC) + ELSE + ALLOCATE(ZFIELDP(0,0,0)) + GALLOC = .TRUE. + END IF + ! + IF (YDIR == 'XX' .OR. YDIR =='YY') THEN + CALL GATHER_XXFIELD(YDIR,PFIELD,ZFIELDP,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) + ELSEIF (YDIR == 'XY') THEN + IF (LPACK .AND. L2D) THEN + CALL GATHER_XXFIELD('XX',PFIELD(:,JPHEXT+1,:),ZFIELDP(:,1,:),TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) + ELSE + CALL GATHER_XYFIELD(PFIELD,ZFIELDP,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) + END IF + END IF + ! + IF (ISP == TPFILE%NMASTER_RANK) THEN + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) + END IF + ! + CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + ! + ELSE ! multiprocesses execution & // IO +#ifndef MNH_INT8 + CALL MPI_ALLREDUCE(SIZE(PFIELD),ISIZEMAX,1,MPI_INTEGER,MPI_MAX,TPFILE%NMPICOMM,IRESP) +#else + CALL MPI_ALLREDUCE(SIZE(PFIELD),ISIZEMAX,1,MPI_INTEGER8,MPI_MAX,TPFILE%NMPICOMM,IRESP) +#endif + IF (ISIZEMAX==0) THEN + CALL PRINT_MSG(NVERB_INFO,'IO','IO_WRITE_FIELD_BYFIELD_X3','ignoring variable with a zero size ('//TRIM(YRECFM)//')') + IF (PRESENT(KRESP)) KRESP=0 + RETURN + END IF + ! + !JUAN BG Z SLICE + ! + ! +#ifdef MNH_GA + ! + ! init/create the ga + ! + CALL SECOND_MNH2(T0) + CALL MNH_INIT_GA(SIZE(PFIELD,1),SIZE(PFIELD,2),SIZE(PFIELD,3),YRECFM,"WRITE") + ! + ! copy columun data to global arrays g_a + ! + ALLOCATE (ZFIELD_GA (SIZE(PFIELD,1),SIZE(PFIELD,2),SIZE(PFIELD,3))) + ZFIELD_GA = PFIELD + call nga_put(g_a, lo_col, hi_col,ZFIELD_GA(NIXO_L,NIYO_L,1) , ld_col) + DEALLOCATE(ZFIELD_GA) + call ga_sync + CALL SECOND_MNH2(T1) + TIMEZ%T_WRIT3D_SEND=TIMEZ%T_WRIT3D_SEND + T1 - T0 + ! + ! write the data + ! + ALLOCATE(ZSLICE_ll(0,0)) ! to avoid bug on test of size + GALLOC_ll = .TRUE. + ! + DO JKK=1,IKU_ll + ! + IK_FILE = IO_FILE(JKK,TPFILE%NSUBFILES_IOZ) + TZFILE => TPFILE%TFILES_IOZ(IK_FILE+1)%TFILE + ! + IK_RANK = TZFILE%NMASTER_RANK + ! + IF (ISP == IK_RANK ) THEN + CALL SECOND_MNH2(T0) + ! + IF ( SIZE(ZSLICE_ll) .EQ. 0 ) THEN + DEALLOCATE(ZSLICE_ll) + CALL ALLOCBUFFER_ll(ZSLICE_ll,ZSLICE,YDIR,GALLOC_ll) + END IF + ! + ! this proc get this JKK slide + ! + lo_zplan(JPIZ) = JKK + hi_zplan(JPIZ) = JKK + call nga_get(g_a, lo_zplan, hi_zplan,ZSLICE_ll, ld_zplan) + CALL SECOND_MNH2(T1) + TIMEZ%T_WRIT3D_RECV=TIMEZ%T_WRIT3D_RECV + T1 - T0 + ! + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,ZSLICE_ll,IRESP,KVERTLEVEL=JKK,KZFILE=IK_FILE+1) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,ZSLICE_ll,IRESP,KVERTLEVEL=JKK,KZFILE=IK_FILE+1) + CALL SECOND_MNH2(T2) + TIMEZ%T_WRIT3D_WRIT=TIMEZ%T_WRIT3D_WRIT + T2 - T1 + END IF + END DO + ! + CALL SECOND_MNH2(T0) + call ga_sync + CALL SECOND_MNH2(T1) + TIMEZ%T_WRIT3D_WAIT=TIMEZ%T_WRIT3D_WAIT + T1 - T0 +#else + ! + ALLOCATE(ZSLICE_ll(0,0)) + GALLOC_ll = .TRUE. + INB_PROC_REAL = MIN(TPFILE%NSUBFILES_IOZ,ISNPROC) + Z_SLICE: DO JK=1,SIZE(PFIELD,3),INB_PROC_REAL + ! + ! collect the data + ! + JK_MAX=MIN(SIZE(PFIELD,3),JK+INB_PROC_REAL-1) + ! + NB_REQ=0 + ALLOCATE(REQ_TAB(INB_PROC_REAL)) + ALLOCATE(T_TX2DP(INB_PROC_REAL)) + DO JKK=JK,JK_MAX + ! + ! get the file & rank to write this level + ! + IF (TPFILE%NSUBFILES_IOZ .GT. 1 ) THEN + IK_FILE = IO_FILE(JKK,TPFILE%NSUBFILES_IOZ) + TZFILE => TPFILE%TFILES_IOZ(IK_FILE+1)%TFILE + ELSE + TZFILE => TPFILE + END IF + ! + IK_RANK = TZFILE%NMASTER_RANK + ! + IF (YDIR == 'XX' .OR. YDIR =='YY') THEN + STOP " XX NON PREVU SUR BG POUR LE MOMENT " + CALL GATHER_XXFIELD(YDIR,PFIELD,ZFIELDP,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) + ELSEIF (YDIR == 'XY') THEN + IF (LPACK .AND. L2D) THEN + STOP " L2D NON PREVU SUR BG POUR LE MOMENT " + CALL GATHER_XXFIELD('XX',PFIELD(:,JPHEXT+1,:),ZFIELDP(:,1,:),TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) + ELSE + CALL SECOND_MNH2(T0) + IF ( ISP /= IK_RANK ) THEN + ! Other processes + CALL GET_DOMWRITE_ll(ISP,'local',IXO,IXE,IYO,IYE) + IF (IXO /= 0) THEN ! intersection is not empty + NB_REQ = NB_REQ + 1 + ALLOCATE(T_TX2DP(NB_REQ)%X(IXO:IXE,IYO:IYE)) + ZSLICE => PFIELD(:,:,JKK) + TX2DP=>ZSLICE(IXO:IXE,IYO:IYE) + T_TX2DP(NB_REQ)%X=ZSLICE(IXO:IXE,IYO:IYE) + CALL MPI_ISEND(T_TX2DP(NB_REQ)%X,SIZE(TX2DP),MPI_FLOAT,IK_RANK-1,99+IK_RANK & + & ,TZFILE%NMPICOMM,REQ_TAB(NB_REQ),IERR) + !CALL MPI_BSEND(TX2DP,SIZE(TX2DP),MPI_FLOAT,IK_RANK-1,99+IK_RANK,TZFILE%NMPICOMM,IERR) + END IF + END IF + CALL SECOND_MNH2(T1) + TIMEZ%T_WRIT3D_SEND=TIMEZ%T_WRIT3D_SEND + T1 - T0 + END IF + END IF + END DO + ! + ! write the data + ! + DO JKK=JK,JK_MAX + IF (TPFILE%NSUBFILES_IOZ .GT. 1 ) THEN + IK_FILE = IO_FILE(JKK,TPFILE%NSUBFILES_IOZ) + TZFILE => TPFILE%TFILES_IOZ(IK_FILE+1)%TFILE + ELSE + TZFILE => TPFILE + ENDIF + IK_RANK = TZFILE%NMASTER_RANK + ! + IF (ISP == IK_RANK ) THEN + CALL SECOND_MNH2(T0) + ! I/O proc case + IF ( SIZE(ZSLICE_ll) .EQ. 0 ) THEN + DEALLOCATE(ZSLICE_ll) + CALL ALLOCBUFFER_ll(ZSLICE_ll,ZSLICE,YDIR,GALLOC_ll) + END IF + DO JI=1,ISNPROC + CALL GET_DOMWRITE_ll(JI,'global',IXO,IXE,IYO,IYE) + IF (IXO /= 0) THEN ! intersection is not empty + TX2DP=>ZSLICE_ll(IXO:IXE,IYO:IYE) + IF (ISP == JI) THEN + CALL GET_DOMWRITE_ll(JI,'local',IXO,IXE,IYO,IYE) + ZSLICE => PFIELD(:,:,JKK) + TX2DP = ZSLICE(IXO:IXE,IYO:IYE) + ELSE + CALL MPI_RECV(TX2DP,SIZE(TX2DP),MPI_FLOAT,JI-1,99+IK_RANK,TZFILE%NMPICOMM,STATUS,IERR) + END IF + END IF + END DO + CALL SECOND_MNH2(T1) + TIMEZ%T_WRIT3D_RECV=TIMEZ%T_WRIT3D_RECV + T1 - T0 + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,ZSLICE_ll,IRESP,KVERTLEVEL=JKK,KZFILE=IK_FILE+1) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,ZSLICE_ll,IRESP,KVERTLEVEL=JKK,KZFILE=IK_FILE+1) + CALL SECOND_MNH2(T2) + TIMEZ%T_WRIT3D_WRIT=TIMEZ%T_WRIT3D_WRIT + T2 - T1 + END IF + END DO + ! + CALL SECOND_MNH2(T0) + IF (NB_REQ .GT.0 ) THEN + CALL MPI_WAITALL(NB_REQ,REQ_TAB,MNH_STATUSES_IGNORE,IERR) + DO JI=1,NB_REQ ; DEALLOCATE(T_TX2DP(JI)%X) ; ENDDO + END IF + DEALLOCATE(T_TX2DP) + DEALLOCATE(REQ_TAB) + CALL SECOND_MNH2(T1) + TIMEZ%T_WRIT3D_WAIT=TIMEZ%T_WRIT3D_WAIT + T1 - T0 + END DO Z_SLICE + !JUAN BG Z SLICE +! end of MNH_GA +#endif + END IF ! multiprocesses execution + END IF + ! + IF (IRESP.NE.0) THEN + WRITE(YRESP, '( I6 )') IRESP + YMSG = 'RESP='//YRESP//' when writing '//TRIM(YRECFM)//' in '//TRIM(TPFILE%CNAME) + CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_FIELD_BYFIELD_X3',YMSG) + END IF + IF (GALLOC) DEALLOCATE(ZFIELDP) + IF (GALLOC_ll) DEALLOCATE(ZSLICE_ll) + IF (PRESENT(KRESP)) KRESP = IRESP + CALL SECOND_MNH2(T22) + TIMEZ%T_WRIT3D_ALL=TIMEZ%T_WRIT3D_ALL + T22 - T11 + END SUBROUTINE IO_WRITE_FIELD_BYFIELD_X3 + + + SUBROUTINE IO_WRITE_FIELD_BYNAME_X4(TPFILE,HNAME,PFIELD,KRESP) + ! + USE MODD_IO_ll, ONLY : TFILEDATA + ! + !* 0.1 Declarations of arguments + ! + TYPE(TFILEDATA), INTENT(IN) :: TPFILE + CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write + REAL,DIMENSION(:,:,:,:), INTENT(IN) :: PFIELD ! array containing the data field + INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code + ! + !* 0.2 Declarations of local variables + ! + INTEGER :: ID ! Index of the field + INTEGER :: IRESP ! return_code + ! + CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYNAME_X4',TRIM(TPFILE%CNAME)//': writing '//TRIM(HNAME)) + ! + CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) + ! + IF(IRESP==0) CALL IO_WRITE_FIELD(TPFILE,TFIELDLIST(ID),PFIELD,IRESP) + ! + IF (PRESENT(KRESP)) KRESP = IRESP + ! + END SUBROUTINE IO_WRITE_FIELD_BYNAME_X4 + + + SUBROUTINE IO_WRITE_FIELD_BYFIELD_X4(TPFILE,TPFIELD,PFIELD,KRESP) + USE MODD_IO_ll + USE MODD_PARAMETERS_ll, ONLY : JPHEXT + USE MODD_TIMEZ, ONLY : TIMEZ + ! + USE MODE_ALLOCBUFFER_ll + USE MODE_GATHER_ll + USE MODE_IO_ll, ONLY : IO_FILE,IO_RANK + USE MODE_MNH_TIMING, ONLY : SECOND_MNH2 + USE MODD_VAR_ll, ONLY : MNH_STATUSES_IGNORE + ! + ! + !* 0.1 Declarations of arguments + ! + TYPE(TFILEDATA), INTENT(IN) :: TPFILE + TYPE(TFIELDDATA), INTENT(IN) :: TPFIELD + REAL,DIMENSION(:,:,:,:),TARGET, INTENT(IN) :: PFIELD ! array containing the data field + INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code + ! + !* 0.2 Declarations of local variables + ! + CHARACTER(LEN=28) :: YFILEM ! FM-file name + CHARACTER(LEN=NMNHNAMELGTMAX) :: YRECFM ! name of the article to write + CHARACTER(LEN=2) :: YDIR ! field form + INTEGER :: IERR + INTEGER :: ISIZEMAX + INTEGER :: IRESP + REAL,DIMENSION(:,:,:,:),POINTER :: ZFIELDP + LOGICAL :: GALLOC + INTEGER :: IHEXTOT + CHARACTER(LEN=:),ALLOCATABLE :: YMSG + CHARACTER(LEN=6) :: YRESP + ! + YFILEM = TPFILE%CNAME + YRECFM = TPFIELD%CMNHNAME + YDIR = TPFIELD%CDIR + ! + IRESP = 0 + GALLOC = .FALSE. + ! + IHEXTOT = 2*JPHEXT+1 + ! + CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYFIELD_X4',TRIM(YFILEM)//': writing '//TRIM(YRECFM)) + ! + CALL FIELD_METADATA_CHECK(TPFIELD,TYPEREAL,4,'IO_WRITE_FIELD_BYFIELD_X4') + ! + CALL IO_FILE_WRITE_CHECK(TPFILE,'IO_WRITE_FIELD_BYFIELD_X4',IRESP) + ! + IF (IRESP==0) THEN + IF (GSMONOPROC) THEN ! sequential execution + ! IF (LPACK .AND. L1D .AND. YDIR=='XY') THEN + IF (LPACK .AND. L1D .AND. SIZE(PFIELD,1)==IHEXTOT .AND. SIZE(PFIELD,2)==IHEXTOT) THEN + ZFIELDP=>PFIELD(JPHEXT+1:JPHEXT+1,JPHEXT+1:JPHEXT+1,:,:) + ! ELSE IF (LPACK .AND. L2D .AND. YDIR=='XY') THEN + ELSEIF (LPACK .AND. L2D .AND. SIZE(PFIELD,2)==IHEXTOT) THEN + ZFIELDP=>PFIELD(:,JPHEXT+1:JPHEXT+1,:,:) + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) + ELSE + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,PFIELD,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,PFIELD,IRESP) + END IF + ELSE +#ifndef MNH_INT8 + CALL MPI_ALLREDUCE(SIZE(PFIELD),ISIZEMAX,1,MPI_INTEGER,MPI_MAX,TPFILE%NMPICOMM,IRESP) +#else + CALL MPI_ALLREDUCE(SIZE(PFIELD),ISIZEMAX,1,MPI_INTEGER8,MPI_MAX,TPFILE%NMPICOMM,IRESP) +#endif + IF (ISIZEMAX==0) THEN + CALL PRINT_MSG(NVERB_INFO,'IO','IO_WRITE_FIELD_BYFIELD_X4','ignoring variable with a zero size ('//TRIM(YRECFM)//')') + IF (PRESENT(KRESP)) KRESP=0 + RETURN + END IF + + IF (ISP == TPFILE%NMASTER_RANK) THEN + CALL ALLOCBUFFER_ll(ZFIELDP,PFIELD,YDIR,GALLOC) + ELSE + ALLOCATE(ZFIELDP(0,0,0,0)) + GALLOC = .TRUE. + END IF + ! + IF (YDIR == 'XX' .OR. YDIR =='YY') THEN + CALL GATHER_XXFIELD(YDIR,PFIELD,ZFIELDP,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) + ELSEIF (YDIR == 'XY') THEN + IF (LPACK .AND. L2D) THEN + CALL GATHER_XXFIELD('XX',PFIELD(:,JPHEXT+1,:,:),ZFIELDP(:,1,:,:),TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) + ELSE + CALL GATHER_XYFIELD(PFIELD,ZFIELDP,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) + END IF + END IF + ! + IF (ISP == TPFILE%NMASTER_RANK) THEN + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) + END IF + ! + CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + END IF ! multiprocess execution + END IF + ! + IF (IRESP.NE.0) THEN + WRITE(YRESP, '( I6 )') IRESP + YMSG = 'RESP='//YRESP//' when writing '//TRIM(YRECFM)//' in '//TRIM(TPFILE%CNAME) + CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_FIELD_BYFIELD_X4',YMSG) + END IF + IF (GALLOC) DEALLOCATE(ZFIELDP) + IF (PRESENT(KRESP)) KRESP = IRESP + END SUBROUTINE IO_WRITE_FIELD_BYFIELD_X4 + + + SUBROUTINE IO_WRITE_FIELD_BYNAME_X5(TPFILE,HNAME,PFIELD,KRESP) + ! + USE MODD_IO_ll, ONLY : TFILEDATA + ! + !* 0.1 Declarations of arguments + ! + TYPE(TFILEDATA), INTENT(IN) :: TPFILE + CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write + REAL,DIMENSION(:,:,:,:,:), INTENT(IN) :: PFIELD ! array containing the data field + INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code + ! + !* 0.2 Declarations of local variables + ! + INTEGER :: ID ! Index of the field + INTEGER :: IRESP ! return_code + ! + CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYNAME_X5',TRIM(TPFILE%CNAME)//': writing '//TRIM(HNAME)) + ! + CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) + ! + IF(IRESP==0) CALL IO_WRITE_FIELD(TPFILE,TFIELDLIST(ID),PFIELD,IRESP) + ! + IF (PRESENT(KRESP)) KRESP = IRESP + ! + END SUBROUTINE IO_WRITE_FIELD_BYNAME_X5 + + + SUBROUTINE IO_WRITE_FIELD_BYFIELD_X5(TPFILE,TPFIELD,PFIELD,KRESP) + USE MODD_IO_ll + USE MODD_PARAMETERS_ll, ONLY : JPHEXT + USE MODD_TIMEZ, ONLY : TIMEZ + ! + USE MODE_ALLOCBUFFER_ll + USE MODE_GATHER_ll + USE MODE_IO_ll, ONLY : IO_FILE,IO_RANK + USE MODE_MNH_TIMING, ONLY : SECOND_MNH2 + USE MODD_VAR_ll, ONLY : MNH_STATUSES_IGNORE + ! + ! + !* 0.1 Declarations of arguments + ! + TYPE(TFILEDATA), INTENT(IN) :: TPFILE + TYPE(TFIELDDATA), INTENT(IN) :: TPFIELD + REAL,DIMENSION(:,:,:,:,:),TARGET,INTENT(IN) :: PFIELD ! array containing the data field + INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code + ! + !* 0.2 Declarations of local variables + ! + CHARACTER(LEN=28) :: YFILEM ! FM-file name + CHARACTER(LEN=NMNHNAMELGTMAX) :: YRECFM ! name of the article to write + CHARACTER(LEN=2) :: YDIR ! field form + INTEGER :: IERR + INTEGER :: ISIZEMAX + INTEGER :: IRESP + REAL,DIMENSION(:,:,:,:,:),POINTER :: ZFIELDP + LOGICAL :: GALLOC + INTEGER :: IHEXTOT + CHARACTER(LEN=:),ALLOCATABLE :: YMSG + CHARACTER(LEN=6) :: YRESP + ! + YFILEM = TPFILE%CNAME + YRECFM = TPFIELD%CMNHNAME + YDIR = TPFIELD%CDIR + ! + IRESP = 0 + GALLOC = .FALSE. + ! + IHEXTOT = 2*JPHEXT+1 + ! + CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYFIELD_X5',TRIM(YFILEM)//': writing '//TRIM(YRECFM)) + ! + CALL FIELD_METADATA_CHECK(TPFIELD,TYPEREAL,5,'IO_WRITE_FIELD_BYFIELD_X5') + ! + CALL IO_FILE_WRITE_CHECK(TPFILE,'IO_WRITE_FIELD_BYFIELD_X5',IRESP) + ! + IF (IRESP==0) THEN + IF (GSMONOPROC) THEN ! sequential execution + ! IF (LPACK .AND. L1D .AND. YDIR=='XY') THEN + IF (LPACK .AND. L1D .AND. SIZE(PFIELD,1)==IHEXTOT .AND. SIZE(PFIELD,2)==IHEXTOT) THEN + ZFIELDP=>PFIELD(JPHEXT+1:JPHEXT+1,JPHEXT+1:JPHEXT+1,:,:,:) + ! ELSE IF (LPACK .AND. L2D .AND. YDIR=='XY') THEN + ELSEIF (LPACK .AND. L2D .AND. SIZE(PFIELD,2)==IHEXTOT) THEN + ZFIELDP=>PFIELD(:,JPHEXT+1:JPHEXT+1,:,:,:) + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) + ELSE + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,PFIELD,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,PFIELD,IRESP) + END IF + ELSE +#ifndef MNH_INT8 + CALL MPI_ALLREDUCE(SIZE(PFIELD),ISIZEMAX,1,MPI_INTEGER,MPI_MAX,TPFILE%NMPICOMM,IRESP) +#else + CALL MPI_ALLREDUCE(SIZE(PFIELD),ISIZEMAX,1,MPI_INTEGER8,MPI_MAX,TPFILE%NMPICOMM,IRESP) +#endif + IF (ISIZEMAX==0) THEN + CALL PRINT_MSG(NVERB_INFO,'IO','IO_WRITE_FIELD_BYFIELD_X5','ignoring variable with a zero size ('//TRIM(YRECFM)//')') + IF (PRESENT(KRESP)) KRESP=0 + RETURN + END IF + + IF (ISP == TPFILE%NMASTER_RANK) THEN + CALL ALLOCBUFFER_ll(ZFIELDP,PFIELD,YDIR,GALLOC) + ELSE + ALLOCATE(ZFIELDP(0,0,0,0,0)) + GALLOC = .TRUE. + END IF + ! + IF (YDIR == 'XX' .OR. YDIR =='YY') THEN + CALL GATHER_XXFIELD(YDIR,PFIELD,ZFIELDP,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) + ELSEIF (YDIR == 'XY') THEN + IF (LPACK .AND. L2D) THEN + CALL GATHER_XXFIELD('XX',PFIELD(:,JPHEXT+1,:,:,:),ZFIELDP(:,1,:,:,:),& + & TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) + ELSE + CALL GATHER_XYFIELD(PFIELD,ZFIELDP,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) + END IF + END IF + ! + IF (ISP == TPFILE%NMASTER_RANK) THEN + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) + END IF + ! + CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + END IF ! multiprocess execution + END IF + ! + IF (IRESP.NE.0) THEN + WRITE(YRESP, '( I6 )') IRESP + YMSG = 'RESP='//YRESP//' when writing '//TRIM(YRECFM)//' in '//TRIM(TPFILE%CNAME) + CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_FIELD_BYFIELD_X5',YMSG) + END IF + IF (GALLOC) DEALLOCATE(ZFIELDP) + IF (PRESENT(KRESP)) KRESP = IRESP + END SUBROUTINE IO_WRITE_FIELD_BYFIELD_X5 + + + SUBROUTINE IO_WRITE_FIELD_BYNAME_X6(TPFILE,HNAME,PFIELD,KRESP) + ! + USE MODD_IO_ll, ONLY : TFILEDATA + ! + !* 0.1 Declarations of arguments + ! + TYPE(TFILEDATA), INTENT(IN) :: TPFILE + CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write + REAL,DIMENSION(:,:,:,:,:,:), INTENT(IN) :: PFIELD ! array containing the data field + INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code + ! + !* 0.2 Declarations of local variables + ! + INTEGER :: ID ! Index of the field + INTEGER :: IRESP ! return_code + ! + CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYNAME_X6',TRIM(TPFILE%CNAME)//': writing '//TRIM(HNAME)) + ! + CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) + ! + IF(IRESP==0) CALL IO_WRITE_FIELD(TPFILE,TFIELDLIST(ID),PFIELD,IRESP) + ! + IF (PRESENT(KRESP)) KRESP = IRESP + ! + END SUBROUTINE IO_WRITE_FIELD_BYNAME_X6 + + SUBROUTINE IO_WRITE_FIELD_BYFIELD_X6(TPFILE,TPFIELD,PFIELD,KRESP) + USE MODD_IO_ll + USE MODD_PARAMETERS_ll, ONLY : JPHEXT + USE MODD_TIMEZ, ONLY : TIMEZ + ! + USE MODE_ALLOCBUFFER_ll + USE MODE_GATHER_ll + USE MODE_IO_ll, ONLY : IO_FILE,IO_RANK + USE MODE_MNH_TIMING, ONLY : SECOND_MNH2 + USE MODD_VAR_ll, ONLY : MNH_STATUSES_IGNORE + ! + ! + !* 0.1 Declarations of arguments + ! + TYPE(TFILEDATA), INTENT(IN) :: TPFILE + TYPE(TFIELDDATA), INTENT(IN) :: TPFIELD + REAL,DIMENSION(:,:,:,:,:,:),TARGET,INTENT(IN) :: PFIELD ! array containing the data field + INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code + ! + !* 0.2 Declarations of local variables + ! + CHARACTER(LEN=28) :: YFILEM ! FM-file name + CHARACTER(LEN=NMNHNAMELGTMAX) :: YRECFM ! name of the article to write + CHARACTER(LEN=2) :: YDIR ! field form + INTEGER :: IERR + INTEGER :: ISIZEMAX + INTEGER :: IRESP + REAL,DIMENSION(:,:,:,:,:,:),POINTER :: ZFIELDP + LOGICAL :: GALLOC + INTEGER :: IHEXTOT + CHARACTER(LEN=:),ALLOCATABLE :: YMSG + CHARACTER(LEN=6) :: YRESP + ! + YFILEM = TPFILE%CNAME + YRECFM = TPFIELD%CMNHNAME + YDIR = TPFIELD%CDIR + ! + IRESP = 0 + GALLOC = .FALSE. + ! + IHEXTOT = 2*JPHEXT+1 + ! + CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYFIELD_X6',TRIM(YFILEM)//': writing '//TRIM(YRECFM)) + ! + CALL FIELD_METADATA_CHECK(TPFIELD,TYPEREAL,6,'IO_WRITE_FIELD_BYFIELD_X6') + ! + CALL IO_FILE_WRITE_CHECK(TPFILE,'IO_WRITE_FIELD_BYFIELD_X6',IRESP) + ! + IF (IRESP==0) THEN + IF (GSMONOPROC) THEN ! sequential execution + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,PFIELD,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,PFIELD,IRESP) + ELSE +#ifndef MNH_INT8 + CALL MPI_ALLREDUCE(SIZE(PFIELD),ISIZEMAX,1,MPI_INTEGER,MPI_MAX,TPFILE%NMPICOMM,IRESP) +#else + CALL MPI_ALLREDUCE(SIZE(PFIELD),ISIZEMAX,1,MPI_INTEGER8,MPI_MAX,TPFILE%NMPICOMM,IRESP) +#endif + IF (ISIZEMAX==0) THEN + CALL PRINT_MSG(NVERB_INFO,'IO','IO_WRITE_FIELD_BYFIELD_X6','ignoring variable with a zero size ('//TRIM(YRECFM)//')') + IF (PRESENT(KRESP)) KRESP=0 + RETURN + END IF + + IF (ISP == TPFILE%NMASTER_RANK) THEN + CALL ALLOCBUFFER_ll(ZFIELDP,PFIELD,YDIR,GALLOC) + ELSE + ALLOCATE(ZFIELDP(0,0,0,0,0,0)) + GALLOC = .TRUE. + END IF + ! + IF (YDIR == 'XX' .OR. YDIR =='YY') THEN + CALL GATHER_XXFIELD(YDIR,PFIELD,ZFIELDP,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) + ELSEIF (YDIR == 'XY') THEN + CALL GATHER_XYFIELD(PFIELD,ZFIELDP,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) + END IF + ! + IF (ISP == TPFILE%NMASTER_RANK) THEN + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) + END IF + ! + CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + END IF ! multiprocess execution + END IF + ! + IF (IRESP.NE.0) THEN + WRITE(YRESP, '( I6 )') IRESP + YMSG = 'RESP='//YRESP//' when writing '//TRIM(YRECFM)//' in '//TRIM(TPFILE%CNAME) + CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_FIELD_BYFIELD_X6',YMSG) + END IF + IF (GALLOC) DEALLOCATE(ZFIELDP) + IF (PRESENT(KRESP)) KRESP = IRESP + END SUBROUTINE IO_WRITE_FIELD_BYFIELD_X6 + + + SUBROUTINE IO_WRITE_FIELD_BYNAME_N0(TPFILE,HNAME,KFIELD,KRESP) + ! + USE MODD_IO_ll, ONLY : TFILEDATA + ! + !* 0.1 Declarations of arguments + ! + TYPE(TFILEDATA), INTENT(IN) :: TPFILE + CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write + INTEGER, INTENT(IN) :: KFIELD ! array containing the data field + INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code + ! + !* 0.2 Declarations of local variables + ! + INTEGER :: ID ! Index of the field + INTEGER :: IRESP ! return_code + ! + CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYNAME_N0',TRIM(TPFILE%CNAME)//': writing '//TRIM(HNAME)) + ! + CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) + ! + IF(IRESP==0) CALL IO_WRITE_FIELD(TPFILE,TFIELDLIST(ID),KFIELD,IRESP) + ! + IF (PRESENT(KRESP)) KRESP = IRESP + ! + END SUBROUTINE IO_WRITE_FIELD_BYNAME_N0 + + + SUBROUTINE IO_WRITE_FIELD_BYFIELD_N0(TPFILE,TPFIELD,KFIELD,KRESP) + USE MODD_IO_ll + !* 0. DECLARATIONS + ! ------------ + ! + ! + !* 0.1 Declarations of arguments + ! + TYPE(TFILEDATA), INTENT(IN) :: TPFILE + TYPE(TFIELDDATA), INTENT(IN) :: TPFIELD + INTEGER, INTENT(IN) :: KFIELD ! array containing the data field + INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code + ! + !* 0.2 Declarations of local variables + ! + INTEGER :: IERR + INTEGER :: IRESP + INTEGER :: IK_FILE + TYPE(TFILEDATA),POINTER :: TZFILE + CHARACTER(LEN=:),ALLOCATABLE :: YMSG + CHARACTER(LEN=6) :: YRESP + ! + IRESP = 0 + TZFILE => NULL() + ! + CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYFIELD_N0',TRIM(TPFILE%CNAME)//': writing '//TRIM(TPFIELD%CMNHNAME)) + ! + CALL FIELD_METADATA_CHECK(TPFIELD,TYPEINT,0,'IO_WRITE_FIELD_BYFIELD_N0') + ! + CALL IO_FILE_WRITE_CHECK(TPFILE,'IO_WRITE_FIELD_BYFIELD_N0',IRESP) + ! + IF (IRESP==0) THEN + IF (GSMONOPROC) THEN ! sequential execution + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,KFIELD,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,KFIELD,IRESP) + ELSE + IF (ISP == TPFILE%NMASTER_RANK) THEN + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,KFIELD,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,KFIELD,IRESP) + END IF + ! + CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + END IF ! multiprocess execution + IF (TPFILE%NSUBFILES_IOZ>0) THEN + ! write the data in all Z files + DO IK_FILE=1,TPFILE%NSUBFILES_IOZ + TZFILE => TPFILE%TFILES_IOZ(IK_FILE)%TFILE + IF ( ISP == TZFILE%NMASTER_RANK ) THEN + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TZFILE,TPFIELD,KFIELD,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TZFILE,TPFIELD,KFIELD,IRESP) + END IF + END DO + ENDIF + END IF + ! + IF (IRESP.NE.0) THEN + WRITE(YRESP, '( I6 )') IRESP + YMSG = 'RESP='//YRESP//' when writing '//TRIM(TPFIELD%CMNHNAME)//' in '//TRIM(TPFILE%CNAME) + CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_FIELD_BYFIELD_N0',YMSG) + END IF + IF (PRESENT(KRESP)) KRESP = IRESP + END SUBROUTINE IO_WRITE_FIELD_BYFIELD_N0 + + + SUBROUTINE IO_WRITE_FIELD_BYNAME_N1(TPFILE,HNAME,KFIELD,KRESP) + ! + USE MODD_IO_ll, ONLY : TFILEDATA + ! + !* 0.1 Declarations of arguments + ! + TYPE(TFILEDATA), INTENT(IN) :: TPFILE + CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write + INTEGER,DIMENSION(:), INTENT(IN) :: KFIELD ! array containing the data field + INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code + ! + !* 0.2 Declarations of local variables + ! + INTEGER :: ID ! Index of the field + INTEGER :: IRESP ! return_code + ! + CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYNAME_N1',TRIM(TPFILE%CNAME)//': writing '//TRIM(HNAME)) + ! + CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) + ! + IF(IRESP==0) CALL IO_WRITE_FIELD(TPFILE,TFIELDLIST(ID),KFIELD,IRESP) + ! + IF (PRESENT(KRESP)) KRESP = IRESP + ! + END SUBROUTINE IO_WRITE_FIELD_BYNAME_N1 + + + SUBROUTINE IO_WRITE_FIELD_BYFIELD_N1(TPFILE,TPFIELD,KFIELD,KRESP) + ! + USE MODD_IO_ll, ONLY : ISP,GSMONOPROC,LIOCDF4,LLFIOUT,TFILEDATA + ! + USE MODE_ALLOCBUFFER_ll + USE MODE_GATHER_ll + ! + IMPLICIT NONE + ! + !* 0.1 Declarations of arguments + ! + TYPE(TFILEDATA), INTENT(IN) :: TPFILE + TYPE(TFIELDDATA), INTENT(IN) :: TPFIELD + INTEGER,DIMENSION(:),TARGET, INTENT(IN) :: KFIELD ! array containing the data field + INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code + ! + !* 0.2 Declarations of local variables + ! + CHARACTER(LEN=28) :: YFILEM ! FM-file name + CHARACTER(LEN=NMNHNAMELGTMAX) :: YRECFM ! name of the article to write + CHARACTER(LEN=2) :: YDIR ! field form + INTEGER :: IERR + INTEGER :: ISIZEMAX + INTEGER :: IRESP + INTEGER,DIMENSION(:),POINTER :: IFIELDP + LOGICAL :: GALLOC + CHARACTER(LEN=:),ALLOCATABLE :: YMSG + CHARACTER(LEN=6) :: YRESP + ! + YFILEM = TPFILE%CNAME + YRECFM = TPFIELD%CMNHNAME + YDIR = TPFIELD%CDIR + ! + IRESP = 0 + GALLOC = .FALSE. + ! + CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYFIELD_N1',TRIM(YFILEM)//': writing '//TRIM(YRECFM)) + ! + CALL FIELD_METADATA_CHECK(TPFIELD,TYPEINT,1,'IO_WRITE_FIELD_BYFIELD_N1') + ! + CALL IO_FILE_WRITE_CHECK(TPFILE,'IO_WRITE_FIELD_BYFIELD_N1',IRESP) + ! + IF (IRESP==0) THEN + IF (GSMONOPROC) THEN ! sequential execution + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,KFIELD,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,KFIELD,IRESP) + ELSE ! multiprocesses execution +#ifndef MNH_INT8 + CALL MPI_ALLREDUCE(SIZE(KFIELD),ISIZEMAX,1,MPI_INTEGER,MPI_MAX,TPFILE%NMPICOMM,IRESP) +#else + CALL MPI_ALLREDUCE(SIZE(KFIELD),ISIZEMAX,1,MPI_INTEGER8,MPI_MAX,TPFILE%NMPICOMM,IRESP) +#endif + IF (ISIZEMAX==0) THEN + CALL PRINT_MSG(NVERB_INFO,'IO','IO_WRITE_FIELD_BYFIELD_N1','ignoring variable with a zero size ('//TRIM(YRECFM)//')') + IF (PRESENT(KRESP)) KRESP=0 + RETURN + END IF + + IF (ISP == TPFILE%NMASTER_RANK) THEN + CALL ALLOCBUFFER_ll(IFIELDP,KFIELD,YDIR,GALLOC) + ELSE + ALLOCATE(IFIELDP(0)) + GALLOC = .TRUE. + END IF + ! + IF (YDIR == 'XX' .OR. YDIR =='YY') THEN + CALL GATHER_XXFIELD(YDIR,KFIELD,IFIELDP,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) + END IF + ! + IF (ISP == TPFILE%NMASTER_RANK) THEN + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,IFIELDP,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,IFIELDP,IRESP) + END IF + ! + CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + END IF + END IF + ! + IF (IRESP.NE.0) THEN + WRITE(YRESP, '( I6 )') IRESP + YMSG = 'RESP='//YRESP//' when writing '//TRIM(YRECFM)//' in '//TRIM(TPFILE%CNAME) + CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_FIELD_BYFIELD_N1',YMSG) + END IF + IF (GALLOC) DEALLOCATE(IFIELDP) + IF (PRESENT(KRESP)) KRESP = IRESP + ! + END SUBROUTINE IO_WRITE_FIELD_BYFIELD_N1 + + + SUBROUTINE IO_WRITE_FIELD_BYNAME_N2(TPFILE,HNAME,KFIELD,KRESP) + ! + USE MODD_IO_ll, ONLY : TFILEDATA + ! + !* 0.1 Declarations of arguments + ! + TYPE(TFILEDATA), INTENT(IN) :: TPFILE + CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write + INTEGER,DIMENSION(:,:), INTENT(IN) :: KFIELD ! array containing the data field + INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code + ! + !* 0.2 Declarations of local variables + ! + INTEGER :: ID ! Index of the field + INTEGER :: IRESP ! return_code + ! + CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYNAME_N2',TRIM(TPFILE%CNAME)//': writing '//TRIM(HNAME)) + ! + CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) + ! + IF(IRESP==0) CALL IO_WRITE_FIELD(TPFILE,TFIELDLIST(ID),KFIELD,IRESP) + ! + IF (PRESENT(KRESP)) KRESP = IRESP + ! + END SUBROUTINE IO_WRITE_FIELD_BYNAME_N2 + + + SUBROUTINE IO_WRITE_FIELD_BYFIELD_N2(TPFILE,TPFIELD,KFIELD,KRESP) + USE MODD_IO_ll + USE MODD_PARAMETERS_ll, ONLY : JPHEXT + USE MODD_TIMEZ, ONLY : TIMEZ + ! + USE MODE_ALLOCBUFFER_ll + USE MODE_GATHER_ll + USE MODE_MNH_TIMING, ONLY : SECOND_MNH2 + ! + IMPLICIT NONE + ! + !* 0.1 Declarations of arguments + ! + TYPE(TFILEDATA), INTENT(IN) :: TPFILE + TYPE(TFIELDDATA), INTENT(IN) :: TPFIELD + INTEGER,DIMENSION(:,:),TARGET,INTENT(IN) :: KFIELD ! array containing the data field + INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code + ! + !* 0.2 Declarations of local variables + ! + CHARACTER(LEN=28) :: YFILEM ! FM-file name + CHARACTER(LEN=NMNHNAMELGTMAX) :: YRECFM ! name of the article to write + CHARACTER(LEN=2) :: YDIR ! field form + INTEGER :: IERR + INTEGER :: ISIZEMAX + INTEGER :: IRESP + INTEGER,DIMENSION(:,:),POINTER :: IFIELDP + LOGICAL :: GALLOC + ! + REAL*8,DIMENSION(2) :: T0,T1,T2 + REAL*8,DIMENSION(2) :: T11,T22 + INTEGER :: IHEXTOT + CHARACTER(LEN=:),ALLOCATABLE :: YMSG + CHARACTER(LEN=6) :: YRESP + ! + YFILEM = TPFILE%CNAME + YRECFM = TPFIELD%CMNHNAME + YDIR = TPFIELD%CDIR + ! + IRESP = 0 + GALLOC = .FALSE. + ! + IHEXTOT = 2*JPHEXT+1 + ! + CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYFIELD_N2',TRIM(YFILEM)//': writing '//TRIM(YRECFM)) + ! + CALL SECOND_MNH2(T11) + ! + CALL FIELD_METADATA_CHECK(TPFIELD,TYPEINT,2,'IO_WRITE_FIELD_BYFIELD_N2') + ! + CALL IO_FILE_WRITE_CHECK(TPFILE,'IO_WRITE_FIELD_BYFIELD_N2',IRESP) + ! + IF (IRESP==0) THEN + IF (GSMONOPROC) THEN ! sequential execution + IF (LPACK .AND. L1D .AND. SIZE(KFIELD,1)==IHEXTOT .AND. SIZE(KFIELD,2)==IHEXTOT) THEN + IFIELDP=>KFIELD(JPHEXT+1:JPHEXT+1,JPHEXT+1:JPHEXT+1) + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,IFIELDP,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,IFIELDP,IRESP) + ! ELSE IF (LPACK .AND. L2D .AND. YDIR=='XY') THEN + ELSEIF (LPACK .AND. L2D .AND. SIZE(KFIELD,2)==IHEXTOT) THEN + IFIELDP=>KFIELD(:,JPHEXT+1:JPHEXT+1) + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,IFIELDP,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,IFIELDP,IRESP) + ELSE + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,KFIELD,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,KFIELD,IRESP) + END IF + ELSE ! multiprocesses execution +#ifndef MNH_INT8 + CALL MPI_ALLREDUCE(SIZE(KFIELD),ISIZEMAX,1,MPI_INTEGER,MPI_MAX,TPFILE%NMPICOMM,IRESP) +#else + CALL MPI_ALLREDUCE(SIZE(KFIELD),ISIZEMAX,1,MPI_INTEGER8,MPI_MAX,TPFILE%NMPICOMM,IRESP) +#endif + IF (ISIZEMAX==0) THEN + CALL PRINT_MSG(NVERB_INFO,'IO','IO_WRITE_FIELD_BYFIELD_N2','ignoring variable with a zero size ('//TRIM(YRECFM)//')') + IF (PRESENT(KRESP)) KRESP=0 + RETURN + END IF + + CALL SECOND_MNH2(T0) + IF (ISP == TPFILE%NMASTER_RANK) THEN + ! I/O process case + CALL ALLOCBUFFER_ll(IFIELDP,KFIELD,YDIR,GALLOC) + ELSE + ALLOCATE(IFIELDP(0,0)) + GALLOC = .TRUE. + END IF + ! + IF (YDIR == 'XX' .OR. YDIR =='YY') THEN + CALL GATHER_XXFIELD(YDIR,KFIELD,IFIELDP,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) + ELSEIF (YDIR == 'XY') THEN + IF (LPACK .AND. L2D) THEN + CALL GATHER_XXFIELD('XX',KFIELD(:,JPHEXT+1),IFIELDP(:,1),TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) + ELSE + CALL GATHER_XYFIELD(KFIELD,IFIELDP,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) + END IF + END IF + CALL SECOND_MNH2(T1) + TIMEZ%T_WRIT2D_GATH=TIMEZ%T_WRIT2D_GATH + T1 - T0 + ! + IF (ISP == TPFILE%NMASTER_RANK) THEN + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,IFIELDP,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,IFIELDP,IRESP) + END IF + CALL SECOND_MNH2(T2) + TIMEZ%T_WRIT2D_WRIT=TIMEZ%T_WRIT2D_WRIT + T2 - T1 + ! + CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + END IF + END IF + ! + IF (IRESP.NE.0) THEN + WRITE(YRESP, '( I6 )') IRESP + YMSG = 'RESP='//YRESP//' when writing '//TRIM(YRECFM)//' in '//TRIM(TPFILE%CNAME) + CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_FIELD_BYFIELD_N2',YMSG) + END IF + IF (GALLOC) DEALLOCATE(IFIELDP) + IF (PRESENT(KRESP)) KRESP = IRESP + CALL SECOND_MNH2(T22) + TIMEZ%T_WRIT2D_ALL=TIMEZ%T_WRIT2D_ALL + T22 - T11 + ! + END SUBROUTINE IO_WRITE_FIELD_BYFIELD_N2 + + + SUBROUTINE IO_WRITE_FIELD_BYNAME_N3(TPFILE,HNAME,KFIELD,KRESP) + ! + USE MODD_IO_ll, ONLY : TFILEDATA + ! + !* 0.1 Declarations of arguments + ! + TYPE(TFILEDATA), INTENT(IN) :: TPFILE + CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write + INTEGER,DIMENSION(:,:,:), INTENT(IN) :: KFIELD ! array containing the data field + INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code + ! + !* 0.2 Declarations of local variables + ! + INTEGER :: ID ! Index of the field + INTEGER :: IRESP ! return_code + ! + CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYNAME_N3',TRIM(TPFILE%CNAME)//': writing '//TRIM(HNAME)) + ! + CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) + ! + IF(IRESP==0) CALL IO_WRITE_FIELD(TPFILE,TFIELDLIST(ID),KFIELD,IRESP) + ! + IF (PRESENT(KRESP)) KRESP = IRESP + ! + END SUBROUTINE IO_WRITE_FIELD_BYNAME_N3 + + SUBROUTINE IO_WRITE_FIELD_BYFIELD_N3(TPFILE,TPFIELD,KFIELD,KRESP) + USE MODD_IO_ll + USE MODD_PARAMETERS_ll, ONLY : JPHEXT + USE MODD_TIMEZ, ONLY : TIMEZ + ! + USE MODE_ALLOCBUFFER_ll + USE MODE_GATHER_ll + USE MODE_MNH_TIMING, ONLY : SECOND_MNH2 + ! + IMPLICIT NONE + ! + !* 0.1 Declarations of arguments + ! + TYPE(TFILEDATA), INTENT(IN) :: TPFILE + TYPE(TFIELDDATA), INTENT(IN) :: TPFIELD + INTEGER,DIMENSION(:,:,:),TARGET,INTENT(IN) :: KFIELD ! array containing the data field + INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code + ! + !* 0.2 Declarations of local variables + ! + CHARACTER(LEN=28) :: YFILEM ! FM-file name + CHARACTER(LEN=NMNHNAMELGTMAX) :: YRECFM ! name of the article to write + CHARACTER(LEN=2) :: YDIR ! field form + INTEGER :: IERR + INTEGER :: ISIZEMAX + INTEGER :: IRESP + INTEGER,DIMENSION(:,:,:),POINTER :: IFIELDP + LOGICAL :: GALLOC + ! + REAL*8,DIMENSION(2) :: T11,T22 + INTEGER :: IHEXTOT + CHARACTER(LEN=:),ALLOCATABLE :: YMSG + CHARACTER(LEN=6) :: YRESP + ! + YFILEM = TPFILE%CNAME + YRECFM = TPFIELD%CMNHNAME + YDIR = TPFIELD%CDIR + ! + IRESP = 0 + GALLOC = .FALSE. + ! + IHEXTOT = 2*JPHEXT+1 + ! + CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYFIELD_N3',TRIM(YFILEM)//': writing '//TRIM(YRECFM)) + ! + CALL SECOND_MNH2(T11) + ! + CALL FIELD_METADATA_CHECK(TPFIELD,TYPEINT,3,'IO_WRITE_FIELD_BYFIELD_N3') + ! + CALL IO_FILE_WRITE_CHECK(TPFILE,'IO_WRITE_FIELD_BYFIELD_N3',IRESP) + ! + IF (IRESP==0) THEN + IF (GSMONOPROC) THEN ! sequential execution + IF (LPACK .AND. L1D .AND. SIZE(KFIELD,1)==IHEXTOT .AND. SIZE(KFIELD,2)==IHEXTOT) THEN + IFIELDP=>KFIELD(JPHEXT+1:JPHEXT+1,JPHEXT+1:JPHEXT+1,:) + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,IFIELDP,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,IFIELDP,IRESP) + ! ELSE IF (LPACK .AND. L2D .AND. YDIR=='XY') THEN + ELSEIF (LPACK .AND. L2D .AND. SIZE(KFIELD,2)==IHEXTOT) THEN + IFIELDP=>KFIELD(:,JPHEXT+1:JPHEXT+1,:) + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,IFIELDP,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,IFIELDP,IRESP) + ELSE + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,KFIELD,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,KFIELD,IRESP) + END IF + ELSE ! multiprocesses execution +#ifndef MNH_INT8 + CALL MPI_ALLREDUCE(SIZE(KFIELD),ISIZEMAX,1,MPI_INTEGER,MPI_MAX,TPFILE%NMPICOMM,IRESP) +#else + CALL MPI_ALLREDUCE(SIZE(KFIELD),ISIZEMAX,1,MPI_INTEGER8,MPI_MAX,TPFILE%NMPICOMM,IRESP) +#endif + IF (ISIZEMAX==0) THEN + CALL PRINT_MSG(NVERB_INFO,'IO','IO_WRITE_FIELD_BYFIELD_N3','ignoring variable with a zero size ('//TRIM(YRECFM)//')') + IF (PRESENT(KRESP)) KRESP=0 + RETURN + END IF + + IF (ISP == TPFILE%NMASTER_RANK) THEN + ! I/O process case + CALL ALLOCBUFFER_ll(IFIELDP,KFIELD,YDIR,GALLOC) + ELSE + ALLOCATE(IFIELDP(0,0,0)) + GALLOC = .TRUE. + END IF + ! + IF (YDIR == 'XX' .OR. YDIR =='YY') THEN + CALL GATHER_XXFIELD(YDIR,KFIELD,IFIELDP,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) + ELSEIF (YDIR == 'XY') THEN + IF (LPACK .AND. L2D) THEN + CALL GATHER_XXFIELD('XX',KFIELD(:,JPHEXT+1,:),IFIELDP(:,1,:),TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) + ELSE + CALL GATHER_XYFIELD(KFIELD,IFIELDP,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) + END IF + END IF + ! + IF (ISP == TPFILE%NMASTER_RANK) THEN + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,IFIELDP,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,IFIELDP,IRESP) + END IF + ! + CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + END IF + END IF + ! + IF (IRESP.NE.0) THEN + WRITE(YRESP, '( I6 )') IRESP + YMSG = 'RESP='//YRESP//' when writing '//TRIM(YRECFM)//' in '//TRIM(TPFILE%CNAME) + CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_FIELD_BYFIELD_N3',YMSG) + END IF + IF (GALLOC) DEALLOCATE(IFIELDP) + IF (PRESENT(KRESP)) KRESP = IRESP + CALL SECOND_MNH2(T22) + TIMEZ%T_WRIT3D_ALL=TIMEZ%T_WRIT3D_ALL + T22 - T11 + ! + END SUBROUTINE IO_WRITE_FIELD_BYFIELD_N3 + + + SUBROUTINE IO_WRITE_FIELD_BYNAME_L0(TPFILE,HNAME,OFIELD,KRESP) + ! + USE MODD_IO_ll, ONLY : TFILEDATA + ! + !* 0.1 Declarations of arguments + ! + TYPE(TFILEDATA), INTENT(IN) :: TPFILE + CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write + LOGICAL, INTENT(IN) :: OFIELD ! array containing the data field + INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code + ! + !* 0.2 Declarations of local variables + ! + INTEGER :: ID ! Index of the field + INTEGER :: IRESP ! return_code + ! + CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYNAME_L0',TRIM(TPFILE%CNAME)//': writing '//TRIM(HNAME)) + ! + CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) + ! + IF(IRESP==0) CALL IO_WRITE_FIELD(TPFILE,TFIELDLIST(ID),OFIELD,IRESP) + ! + IF (PRESENT(KRESP)) KRESP = IRESP + ! + END SUBROUTINE IO_WRITE_FIELD_BYNAME_L0 + + SUBROUTINE IO_WRITE_FIELD_BYFIELD_L0(TPFILE,TPFIELD,OFIELD,KRESP) + USE MODD_IO_ll + ! + USE MODE_IO_MANAGE_STRUCT, ONLY: IO_FILE_FIND_BYNAME + !* 0. DECLARATIONS + ! ------------ + ! + ! + !* 0.1 Declarations of arguments + ! + TYPE(TFILEDATA), INTENT(IN) :: TPFILE + TYPE(TFIELDDATA), INTENT(IN) :: TPFIELD + LOGICAL, INTENT(IN) :: OFIELD ! array containing the data field + INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code + ! + !* 0.2 Declarations of local variables + ! + INTEGER :: IERR + INTEGER :: IRESP + INTEGER :: IK_FILE + TYPE(TFILEDATA),POINTER :: TZFILE + CHARACTER(LEN=:),ALLOCATABLE :: YMSG + CHARACTER(LEN=6) :: YRESP + ! + IRESP = 0 + TZFILE => NULL() + ! + CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYFIELD_L0',TRIM(TPFILE%CNAME)//': writing '//TRIM(TPFIELD%CMNHNAME)) + ! + CALL FIELD_METADATA_CHECK(TPFIELD,TYPELOG,0,'IO_WRITE_FIELD_BYFIELD_L0') + ! + CALL IO_FILE_WRITE_CHECK(TPFILE,'IO_WRITE_FIELD_BYFIELD_L0',IRESP) + ! + IF (IRESP==0) THEN + IF (GSMONOPROC) THEN ! sequential execution + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,OFIELD,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,OFIELD,IRESP) + ELSE + IF (ISP == TPFILE%NMASTER_RANK) THEN + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,OFIELD,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,OFIELD,IRESP) + END IF + ! + CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + END IF ! multiprocesses execution + IF (TPFILE%NSUBFILES_IOZ>0) THEN + ! write the data in all Z files + DO IK_FILE=1,TPFILE%NSUBFILES_IOZ + TZFILE => TPFILE%TFILES_IOZ(IK_FILE)%TFILE + IF ( ISP == TZFILE%NMASTER_RANK ) THEN + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TZFILE,TPFIELD,OFIELD,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TZFILE,TPFIELD,OFIELD,IRESP) + END IF + END DO + ENDIF + END IF + ! + IF (IRESP.NE.0) THEN + WRITE(YRESP, '( I6 )') IRESP + YMSG = 'RESP='//YRESP//' when writing '//TRIM(TPFIELD%CMNHNAME)//' in '//TRIM(TPFILE%CNAME) + CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_FIELD_BYFIELD_L0',YMSG) + END IF + IF (PRESENT(KRESP)) KRESP = IRESP + END SUBROUTINE IO_WRITE_FIELD_BYFIELD_L0 + + + SUBROUTINE IO_WRITE_FIELD_BYNAME_L1(TPFILE,HNAME,OFIELD,KRESP) + ! + USE MODD_IO_ll, ONLY : TFILEDATA + ! + !* 0.1 Declarations of arguments + ! + TYPE(TFILEDATA), INTENT(IN) :: TPFILE + CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write + LOGICAL,DIMENSION(:), INTENT(IN) :: OFIELD ! array containing the data field + INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code + ! + !* 0.2 Declarations of local variables + ! + INTEGER :: ID ! Index of the field + INTEGER :: IRESP ! return_code + ! + CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYNAME_L1',TRIM(TPFILE%CNAME)//': writing '//TRIM(HNAME)) + ! + CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) + ! + IF(IRESP==0) CALL IO_WRITE_FIELD(TPFILE,TFIELDLIST(ID),OFIELD,IRESP) + ! + IF (PRESENT(KRESP)) KRESP = IRESP + ! + END SUBROUTINE IO_WRITE_FIELD_BYNAME_L1 + + + SUBROUTINE IO_WRITE_FIELD_BYFIELD_L1(TPFILE,TPFIELD,OFIELD,KRESP) + ! + USE MODD_IO_ll, ONLY : ISP,GSMONOPROC,LIOCDF4,LLFIOUT,TFILEDATA + ! + USE MODE_ALLOCBUFFER_ll + USE MODE_GATHER_ll + ! + IMPLICIT NONE + ! + !* 0.1 Declarations of arguments + ! + TYPE(TFILEDATA), INTENT(IN) :: TPFILE + TYPE(TFIELDDATA), INTENT(IN) :: TPFIELD + LOGICAL,DIMENSION(:),TARGET, INTENT(IN) :: OFIELD ! array containing the data field + INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code + ! + !* 0.2 Declarations of local variables + ! + CHARACTER(LEN=28) :: YFILEM ! FM-file name + CHARACTER(LEN=NMNHNAMELGTMAX) :: YRECFM ! name of the article to write + CHARACTER(LEN=2) :: YDIR ! field form + INTEGER :: IERR + INTEGER :: ISIZEMAX + INTEGER :: IRESP + LOGICAL,DIMENSION(:),POINTER :: GFIELDP + LOGICAL :: GALLOC + CHARACTER(LEN=:),ALLOCATABLE :: YMSG + CHARACTER(LEN=6) :: YRESP + ! + YFILEM = TPFILE%CNAME + YRECFM = TPFIELD%CMNHNAME + YDIR = TPFIELD%CDIR + ! + IRESP = 0 + GALLOC = .FALSE. + ! + CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYFIELD_L1',TRIM(YFILEM)//': writing '//TRIM(YRECFM)) + ! + CALL FIELD_METADATA_CHECK(TPFIELD,TYPELOG,1,'IO_WRITE_FIELD_BYFIELD_L1') + ! + CALL IO_FILE_WRITE_CHECK(TPFILE,'IO_WRITE_FIELD_BYFIELD_L1',IRESP) + ! + IF (IRESP==0) THEN + IF (GSMONOPROC) THEN ! sequential execution + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,OFIELD,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,OFIELD,IRESP) + ELSE ! multiprocesses execution +#ifndef MNH_INT8 + CALL MPI_ALLREDUCE(SIZE(OFIELD),ISIZEMAX,1,MPI_INTEGER,MPI_MAX,TPFILE%NMPICOMM,IRESP) +#else + CALL MPI_ALLREDUCE(SIZE(OFIELD),ISIZEMAX,1,MPI_INTEGER8,MPI_MAX,TPFILE%NMPICOMM,IRESP) +#endif + IF (ISIZEMAX==0) THEN + CALL PRINT_MSG(NVERB_INFO,'IO','IO_WRITE_FIELD_BYFIELD_L1','ignoring variable with a zero size ('//TRIM(YRECFM)//')') + IF (PRESENT(KRESP)) KRESP=0 + RETURN + END IF + + IF (ISP == TPFILE%NMASTER_RANK) THEN + CALL ALLOCBUFFER_ll(GFIELDP,OFIELD,YDIR,GALLOC) + ELSE + ALLOCATE(GFIELDP(0)) + GALLOC = .TRUE. + END IF + ! + IF (YDIR == 'XX' .OR. YDIR =='YY') THEN + CALL GATHER_XXFIELD(YDIR,OFIELD,GFIELDP,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM) + END IF + ! + IF (ISP == TPFILE%NMASTER_RANK) THEN + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,GFIELDP,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,GFIELDP,IRESP) + END IF + ! + CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + END IF + END IF + ! + IF (IRESP.NE.0) THEN + WRITE(YRESP, '( I6 )') IRESP + YMSG = 'RESP='//YRESP//' when writing '//TRIM(YRECFM)//' in '//TRIM(TPFILE%CNAME) + CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_FIELD_BYFIELD_L1',YMSG) + END IF + IF (GALLOC) DEALLOCATE(GFIELDP) + IF (PRESENT(KRESP)) KRESP = IRESP + ! + END SUBROUTINE IO_WRITE_FIELD_BYFIELD_L1 + + + SUBROUTINE IO_WRITE_FIELD_BYNAME_C0(TPFILE,HNAME,HFIELD,KRESP) + ! + USE MODD_IO_ll, ONLY : TFILEDATA + ! + !* 0.1 Declarations of arguments + ! + TYPE(TFILEDATA), INTENT(IN) :: TPFILE + CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write + CHARACTER(LEN=*), INTENT(IN) :: HFIELD ! array containing the data field + INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code + ! + !* 0.2 Declarations of local variables + ! + INTEGER :: ID ! Index of the field + INTEGER :: IRESP ! return_code + ! + CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYNAME_C0',TRIM(TPFILE%CNAME)//': writing '//TRIM(HNAME)) + ! + CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) + ! + IF(IRESP==0) CALL IO_WRITE_FIELD(TPFILE,TFIELDLIST(ID),HFIELD,IRESP) + ! + IF (PRESENT(KRESP)) KRESP = IRESP + ! + END SUBROUTINE IO_WRITE_FIELD_BYNAME_C0 + + + SUBROUTINE IO_WRITE_FIELD_BYFIELD_C0(TPFILE,TPFIELD,HFIELD,KRESP) + USE MODD_IO_ll + ! + !* 0. DECLARATIONS + ! ------------ + ! + ! + !* 0.1 Declarations of arguments + ! + TYPE(TFILEDATA), INTENT(IN) :: TPFILE + TYPE(TFIELDDATA), INTENT(IN) :: TPFIELD + CHARACTER(LEN=*), INTENT(IN) :: HFIELD ! array containing the data field + INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code + ! + !* 0.2 Declarations of local variables + ! + INTEGER :: IERR + INTEGER :: IRESP + CHARACTER(LEN=:),ALLOCATABLE :: YMSG + CHARACTER(LEN=6) :: YRESP + ! + IRESP = 0 + ! + CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYFIELD_C0',TRIM(TPFILE%CNAME)//': writing '//TRIM(TPFIELD%CMNHNAME)) + ! + CALL FIELD_METADATA_CHECK(TPFIELD,TYPECHAR,0,'IO_WRITE_FIELD_BYFIELD_C0') + ! + IF (LEN(HFIELD)==0 .AND. LLFIOUT) THEN + CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_FIELD_BYFIELD_C0',& + 'zero-size string not allowed if LFI output for '//TRIM(TPFIELD%CMNHNAME)) + END IF + ! + CALL IO_FILE_WRITE_CHECK(TPFILE,'IO_WRITE_FIELD_BYFIELD_C0',IRESP) + ! + IF (IRESP==0) THEN + IF (GSMONOPROC) THEN ! sequential execution + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,HFIELD,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,HFIELD,IRESP) + ELSE + IF (ISP == TPFILE%NMASTER_RANK) THEN + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,HFIELD,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,HFIELD,IRESP) + END IF + ! + CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + END IF + END IF + ! + IF (IRESP.NE.0) THEN + WRITE(YRESP, '( I6 )') IRESP + YMSG = 'RESP='//YRESP//' when writing '//TRIM(TPFIELD%CMNHNAME)//' in '//TRIM(TPFILE%CNAME) + CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_FIELD_BYFIELD_C0',YMSG) + END IF + IF (PRESENT(KRESP)) KRESP = IRESP + END SUBROUTINE IO_WRITE_FIELD_BYFIELD_C0 + + + SUBROUTINE IO_WRITE_FIELD_BYNAME_C1(TPFILE,HNAME,HFIELD,KRESP) + ! + USE MODD_IO_ll, ONLY : TFILEDATA + ! + !* 0.1 Declarations of arguments + ! + TYPE(TFILEDATA), INTENT(IN) :: TPFILE + CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write + CHARACTER(LEN=*),DIMENSION(:),INTENT(IN) :: HFIELD ! array containing the data field + INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code + ! + !* 0.2 Declarations of local variables + ! + INTEGER :: ID ! Index of the field + INTEGER :: IRESP ! return_code + ! + CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYNAME_C1',TRIM(TPFILE%CNAME)//': writing '//TRIM(HNAME)) + ! + CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) + ! + IF(IRESP==0) CALL IO_WRITE_FIELD(TPFILE,TFIELDLIST(ID),HFIELD,IRESP) + ! + IF (PRESENT(KRESP)) KRESP = IRESP + ! + END SUBROUTINE IO_WRITE_FIELD_BYNAME_C1 + + + SUBROUTINE IO_WRITE_FIELD_BYFIELD_C1(TPFILE,TPFIELD,HFIELD,KRESP) + USE MODD_IO_ll + ! + !* 0. DECLARATIONS + ! ------------ + ! + ! + !* 0.1 Declarations of arguments + ! + TYPE(TFILEDATA), INTENT(IN) :: TPFILE + TYPE(TFIELDDATA), INTENT(IN) :: TPFIELD + CHARACTER(LEN=*),DIMENSION(:),INTENT(IN) :: HFIELD ! array containing the data field + INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code + ! + !* 0.2 Declarations of local variables + ! + INTEGER :: IERR + INTEGER :: IRESP + INTEGER :: J,JJ + INTEGER :: ILE, IP + INTEGER,DIMENSION(:),ALLOCATABLE :: IFIELD + INTEGER :: ILENG + CHARACTER(LEN=:),ALLOCATABLE :: YMSG + CHARACTER(LEN=6) :: YRESP + ! + CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYFIELD_C1',TRIM(TPFILE%CNAME)//': writing '//TRIM(TPFIELD%CMNHNAME)) + ! + CALL FIELD_METADATA_CHECK(TPFIELD,TYPECHAR,1,'IO_WRITE_FIELD_BYFIELD_C1') + ! + IRESP = 0 + ! + IF(LLFIOUT) THEN + ILE=LEN(HFIELD) + IP=SIZE(HFIELD) + ILENG=ILE*IP + ! + IF (ILENG==0) THEN + IP=1 + ILE=1 + ILENG=1 + ALLOCATE(IFIELD(1)) + IFIELD(1)=IACHAR(' ') + ELSE + ALLOCATE(IFIELD(ILENG)) + DO JJ=1,IP + DO J=1,ILE + IFIELD(ILE*(JJ-1)+J)=IACHAR(HFIELD(JJ)(J:J)) + END DO + END DO + END IF + END IF + ! + CALL IO_FILE_WRITE_CHECK(TPFILE,'IO_WRITE_FIELD_BYFIELD_C1',IRESP) + ! + IF (IRESP==0) THEN + IF (GSMONOPROC) THEN ! sequential execution + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,IFIELD,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,HFIELD,IRESP) + ELSE + IF (ISP == TPFILE%NMASTER_RANK) THEN + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,IFIELD,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,HFIELD,IRESP) + END IF + ! + CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + END IF + END IF + ! + IF (IRESP.NE.0) THEN + WRITE(YRESP, '( I6 )') IRESP + YMSG = 'RESP='//YRESP//' when writing '//TRIM(TPFIELD%CMNHNAME)//' in '//TRIM(TPFILE%CNAME) + CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_FIELD_BYFIELD_C1',YMSG) + END IF + IF (ALLOCATED(IFIELD)) DEALLOCATE(IFIELD) + IF (PRESENT(KRESP)) KRESP = IRESP + END SUBROUTINE IO_WRITE_FIELD_BYFIELD_C1 + + + SUBROUTINE IO_WRITE_FIELD_BYNAME_T0(TPFILE,HNAME,TFIELD,KRESP) + ! + USE MODD_IO_ll, ONLY : TFILEDATA + ! + !* 0.1 Declarations of arguments + ! + TYPE(TFILEDATA), INTENT(IN) :: TPFILE + CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write + TYPE (DATE_TIME), INTENT(IN) :: TFIELD ! array containing the data field + INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code + ! + !* 0.2 Declarations of local variables + ! + INTEGER :: ID ! Index of the field + INTEGER :: IRESP ! return_code + ! + CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYNAME_T0',TRIM(TPFILE%CNAME)//': writing '//TRIM(HNAME)) + ! + CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) + ! + IF(IRESP==0) CALL IO_WRITE_FIELD(TPFILE,TFIELDLIST(ID),TFIELD,IRESP) + ! + IF (PRESENT(KRESP)) KRESP = IRESP + ! + END SUBROUTINE IO_WRITE_FIELD_BYNAME_T0 + + + SUBROUTINE IO_WRITE_FIELD_BYFIELD_T0(TPFILE,TPFIELD,TFIELD,KRESP) + USE MODD_IO_ll + USE MODD_TYPE_DATE + ! + !* 0. DECLARATIONS + ! ------------ + ! + ! + !* 0.1 Declarations of arguments + ! + TYPE(TFILEDATA), INTENT(IN) :: TPFILE + TYPE(TFIELDDATA), INTENT(IN) :: TPFIELD + TYPE (DATE_TIME), INTENT(IN) :: TFIELD ! array containing the data field + INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code + ! + !* 0.2 Declarations of local variables + ! + INTEGER :: IERR + INTEGER :: IRESP + CHARACTER(LEN=:),ALLOCATABLE :: YMSG + CHARACTER(LEN=6) :: YRESP + ! + CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYFIELD_T0',TRIM(TPFILE%CNAME)//': writing '//TRIM(TPFIELD%CMNHNAME)) + ! + CALL FIELD_METADATA_CHECK(TPFIELD,TYPEDATE,0,'IO_WRITE_FIELD_BYFIELD_T0') + ! + IRESP = 0 + ! + CALL IO_FILE_WRITE_CHECK(TPFILE,'IO_WRITE_FIELD_BYFIELD_T0',IRESP) + ! + IF (IRESP==0) THEN + IF (GSMONOPROC) THEN ! sequential execution + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,TFIELD,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,TFIELD,IRESP) + ELSE + IF (ISP == TPFILE%NMASTER_RANK) THEN + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,TFIELD,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,TFIELD,IRESP) + END IF + ! + CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + END IF + END IF + ! + IF (IRESP.NE.0) THEN + WRITE(YRESP, '( I6 )') IRESP + YMSG = 'RESP='//YRESP//' when writing '//TRIM(TPFIELD%CMNHNAME)//' in '//TRIM(TPFILE%CNAME) + CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_FIELD_BYFIELD_T0',YMSG) + END IF + IF (PRESENT(KRESP)) KRESP = IRESP + END SUBROUTINE IO_WRITE_FIELD_BYFIELD_T0 + + + SUBROUTINE IO_WRITE_FIELD_BYNAME_LB(TPFILE,HNAME,KL3D,PLB,KRESP) + ! + USE MODD_IO_ll, ONLY : TFILEDATA + ! + !* 0.1 Declarations of arguments + ! + TYPE(TFILEDATA), INTENT(IN) :: TPFILE + CHARACTER(LEN=*), INTENT(IN) :: HNAME ! name of the field to write + INTEGER, INTENT(IN) :: KL3D ! size of the LB array in FM + REAL,DIMENSION(:,:,:), INTENT(IN) :: PLB ! array containing the LB field + INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code + ! + !* 0.2 Declarations of local variables + ! + INTEGER :: ID ! Index of the field + INTEGER :: IRESP ! return_code + ! + CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYNAME_LB',TRIM(TPFILE%CNAME)//': writing '//TRIM(HNAME)) + ! + CALL FIND_FIELD_ID_FROM_MNHNAME(HNAME,ID,IRESP) + ! + IF(IRESP==0) CALL IO_WRITE_FIELD_LB(TPFILE,TFIELDLIST(ID),KL3D,PLB,IRESP) + ! + IF (PRESENT(KRESP)) KRESP = IRESP + ! + END SUBROUTINE IO_WRITE_FIELD_BYNAME_LB + + + SUBROUTINE IO_WRITE_FIELD_BYFIELD_LB(TPFILE,TPFIELD,KL3D,PLB,KRESP) + ! + USE MODD_IO_ll + USE MODD_PARAMETERS_ll, ONLY : JPHEXT + USE MODD_VAR_ll, ONLY : MNH_STATUSES_IGNORE + ! + USE MODE_DISTRIB_LB + USE MODE_TOOLS_ll, ONLY : GET_GLOBALDIMS_ll + ! + ! + !* 0.1 Declarations of arguments + ! + TYPE(TFILEDATA), INTENT(IN) :: TPFILE + TYPE(TFIELDDATA), INTENT(INOUT) :: TPFIELD + INTEGER, INTENT(IN) :: KL3D ! size of the LB array in FM + REAL,DIMENSION(:,:,:),TARGET,INTENT(IN) :: PLB ! array containing the LB field + INTEGER,OPTIONAL, INTENT(OUT) :: KRESP ! return-code + ! + !* 0.2 Declarations of local variables + ! + CHARACTER(LEN=28) :: YFILEM ! FM-file name + CHARACTER(LEN=NMNHNAMELGTMAX) :: YRECFM ! name of the article to write + CHARACTER(LEN=4) :: YLBTYPE ! 'LBX','LBXU','LBY' or 'LBYV' + INTEGER :: IRIM ! size of the LB area + INTEGER :: IERR + INTEGER :: IRESP + REAL,DIMENSION(:,:,:),ALLOCATABLE,TARGET :: Z3D + REAL,DIMENSION(:,:,:), POINTER :: TX3DP + INTEGER :: IIMAX_ll,IJMAX_ll + INTEGER :: JI + INTEGER :: IIB,IIE,IJB,IJE + INTEGER, DIMENSION(MPI_STATUS_SIZE) :: STATUS + INTEGER,ALLOCATABLE,DIMENSION(:) :: REQ_TAB + INTEGER :: NB_REQ,IKU + TYPE TX_3DP + REAL,DIMENSION(:,:,:), POINTER :: X + END TYPE TX_3DP + TYPE(TX_3DP),ALLOCATABLE,DIMENSION(:) :: T_TX3DP + CHARACTER(LEN=:),ALLOCATABLE :: YMSG + CHARACTER(LEN=6) :: YRESP + ! + YFILEM = TPFILE%CNAME + YRECFM = TPFIELD%CMNHNAME + YLBTYPE = TPFIELD%CLBTYPE + ! + IRESP = 0 + ! + CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BYFIELD_LB',TRIM(YFILEM)//': writing '//TRIM(YRECFM)) + ! + IF (YLBTYPE/='LBX' .AND. YLBTYPE/='LBXU' .AND. YLBTYPE/='LBY' .AND. YLBTYPE/='LBYV') THEN + CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_FIELD_BYFIELD_LB','unknown LBTYPE ('//YLBTYPE//')') + RETURN + END IF + ! + IF (TPFIELD%CDIR/='') THEN + CALL PRINT_MSG(NVERB_WARNING,'IO','IO_WRITE_FIELD_BYFIELD_LB','CDIR was set for '//TRIM(YRECFM)) + TPFIELD%CDIR='' + END IF + ! + IRIM = (KL3D-2*JPHEXT)/2 + IF (KL3D /= 2*(IRIM+JPHEXT)) THEN + IRESP = -30 + GOTO 1000 + END IF + ! + CALL IO_FILE_WRITE_CHECK(TPFILE,'IO_WRITE_FIELD_BYFIELD_LB',IRESP) + ! + IF (IRESP==0) THEN + IF (GSMONOPROC) THEN ! sequential execution + IF (LPACK .AND. L2D) THEN + TX3DP=>PLB(:,JPHEXT+1:JPHEXT+1,:) + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,TX3DP,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,TX3DP,IRESP) + ELSE + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,PLB,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,PLB,IRESP) + END IF + ELSE + IF (ISP == TPFILE%NMASTER_RANK) THEN + ! I/O proc case + CALL GET_GLOBALDIMS_ll(IIMAX_ll,IJMAX_ll) + IF (YLBTYPE == 'LBX' .OR. YLBTYPE == 'LBXU') THEN + ALLOCATE(Z3D((IRIM+JPHEXT)*2,IJMAX_ll+2*JPHEXT,SIZE(PLB,3))) + ELSE ! YLBTYPE == 'LBY' .OR. YLBTYPE == 'LBYV' + ALLOCATE(Z3D(IIMAX_ll+2*JPHEXT,(IRIM+JPHEXT)*2,SIZE(PLB,3))) + END IF + DO JI = 1,ISNPROC + CALL GET_DISTRIB_LB(YLBTYPE,JI,'FM','WRITE',IRIM,IIB,IIE,IJB,IJE) + IF (IIB /= 0) THEN + TX3DP=>Z3D(IIB:IIE,IJB:IJE,:) + IF (ISP /= JI) THEN + CALL MPI_RECV(TX3DP,SIZE(TX3DP),MPI_FLOAT,JI-1,99,TPFILE%NMPICOMM,STATUS,IERR) + ELSE + CALL GET_DISTRIB_LB(YLBTYPE,JI,'LOC','WRITE',IRIM,IIB,IIE,IJB,IJE) + TX3DP = PLB(IIB:IIE,IJB:IJE,:) + END IF + END IF + END DO + IF (LPACK .AND. L2D) THEN + TX3DP=>Z3D(:,JPHEXT+1:JPHEXT+1,:) + ELSE + TX3DP=>Z3D + END IF + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,TX3DP,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,TX3DP,IRESP) + ELSE + NB_REQ=0 + ALLOCATE(REQ_TAB(1)) + ALLOCATE(T_TX3DP(1)) + IKU = SIZE(PLB,3) + ! Other processes + CALL GET_DISTRIB_LB(YLBTYPE,ISP,'LOC','WRITE',IRIM,IIB,IIE,IJB,IJE) + IF (IIB /= 0) THEN + TX3DP=>PLB(IIB:IIE,IJB:IJE,:) + NB_REQ = NB_REQ + 1 + ALLOCATE(T_TX3DP(NB_REQ)%X(IIB:IIE,IJB:IJE,IKU)) + T_TX3DP(NB_REQ)%X=PLB(IIB:IIE,IJB:IJE,:) + CALL MPI_ISEND(T_TX3DP(NB_REQ)%X,SIZE(TX3DP),MPI_FLOAT,TPFILE%NMASTER_RANK-1,99, & + TPFILE%NMPICOMM,REQ_TAB(NB_REQ),IERR) + !CALL MPI_BSEND(TX3DP,SIZE(TX3DP),MPI_FLOAT,TPFILE%NMASTER_RANK-1,99,TPFILE%NMPICOMM,IERR) + END IF + IF (NB_REQ .GT.0 ) THEN + CALL MPI_WAITALL(NB_REQ,REQ_TAB,MNH_STATUSES_IGNORE,IERR) + DEALLOCATE(T_TX3DP(1)%X) + END IF + DEALLOCATE(T_TX3DP,REQ_TAB) + END IF + ! + CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + END IF + END IF + ! +1000 CONTINUE + IF (IRESP.NE.0) THEN + WRITE(YRESP, '( I6 )') IRESP + YMSG = 'RESP='//YRESP//' when writing '//TRIM(YRECFM)//' in '//TRIM(TPFILE%CNAME) + CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_FIELD_BYFIELD_LB',YMSG) + END IF + ! + IF (ALLOCATED(Z3D)) DEALLOCATE(Z3D) + IF (PRESENT(KRESP)) KRESP = IRESP + END SUBROUTINE IO_WRITE_FIELD_BYFIELD_LB + + + SUBROUTINE IO_WRITE_FIELD_BOX_BYFIELD_X5(TPFILE,TPFIELD,HBUDGET,PFIELD,KXOBOX,KXEBOX,KYOBOX,KYEBOX,KRESP) + ! + USE MODD_IO_ll + ! + USE MODE_GATHER_ll + ! + ! + !* 0.1 Declarations of arguments + ! + TYPE(TFILEDATA), INTENT(IN) :: TPFILE + TYPE(TFIELDDATA), INTENT(IN) :: TPFIELD + CHARACTER(LEN=*), INTENT(IN) :: HBUDGET ! 'BUDGET' (budget) or 'OTHER' (MesoNH field) + REAL,DIMENSION(:,:,:,:,:),TARGET,INTENT(IN) :: PFIELD ! array containing the data field + INTEGER, INTENT(IN) :: KXOBOX ! + INTEGER, INTENT(IN) :: KXEBOX ! Global coordinates of the box + INTEGER, INTENT(IN) :: KYOBOX ! + INTEGER, INTENT(IN) :: KYEBOX ! + INTEGER,OPTIONAL, INTENT(OUT):: KRESP ! return-code + ! + !* 0.2 Declarations of local variables + ! + INTEGER :: IERR + INTEGER :: IRESP + REAL,DIMENSION(:,:,:,:,:),POINTER :: ZFIELDP + LOGICAL :: GALLOC + CHARACTER(LEN=:),ALLOCATABLE :: YMSG + CHARACTER(LEN=6) :: YRESP + ! + CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_WRITE_FIELD_BOX_BYFIELD_X5',TRIM(TPFILE%CNAME)//': writing '//TRIM(TPFIELD%CMNHNAME)) + ! + IRESP = 0 + GALLOC = .FALSE. + ! + CALL IO_FILE_WRITE_CHECK(TPFILE,'IO_WRITE_FIELD_BOX_BYFIELD_X5',IRESP) + ! + IF (IRESP==0) THEN + IF (GSMONOPROC) THEN ! sequential execution + IF (HBUDGET /= 'BUDGET') THEN + ! take the sub-section of PFIELD defined by the box + ZFIELDP=>PFIELD(KXOBOX:KXEBOX,KYOBOX:KYEBOX,:,:,:) + ELSE + ! take the field as a budget + ZFIELDP=>PFIELD + END IF + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) + ELSE ! multiprocesses execution + IF (ISP == TPFILE%NMASTER_RANK) THEN + ! Allocate the box + ALLOCATE(ZFIELDP(KXEBOX-KXOBOX+1,KYEBOX-KYOBOX+1,SIZE(PFIELD,3),& + & SIZE(PFIELD,4),SIZE(PFIELD,5))) + GALLOC = .TRUE. + ELSE + ALLOCATE(ZFIELDP(0,0,0,0,0)) + GALLOC = .TRUE. + END IF + ! + CALL GATHER_XYFIELD(PFIELD,ZFIELDP,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM,& + & KXOBOX,KXEBOX,KYOBOX,KYEBOX,HBUDGET) + ! + IF (ISP == TPFILE%NMASTER_RANK) THEN + IF (LLFIOUT) CALL IO_WRITE_FIELD_LFI(TPFILE,TPFIELD,ZFIELDP,IRESP) + IF (LIOCDF4) CALL IO_WRITE_FIELD_NC4(TPFILE,TPFIELD,ZFIELDP,IRESP) + END IF + ! + CALL MPI_BCAST(IRESP,1,MPI_INTEGER,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR) + END IF ! multiprocesses execution + END IF + ! + IF (IRESP.NE.0) THEN + WRITE(YRESP, '( I6 )') IRESP + YMSG = 'RESP='//YRESP//' when writing '//TRIM(TPFIELD%CMNHNAME)//' in '//TRIM(TPFILE%CNAME) + CALL PRINT_MSG(NVERB_ERROR,'IO','IO_WRITE_FIELD_BOX_BYFIELD_X5',YMSG) + END IF + IF (GALLOC) DEALLOCATE(ZFIELDP) + IF (PRESENT(KRESP)) KRESP = IRESP + END SUBROUTINE IO_WRITE_FIELD_BOX_BYFIELD_X5 + +END MODULE MODE_FMWRIT diff --git a/src/MNH/compute_mf_cloud_bigaus.f90 b/src/MNH/compute_mf_cloud_bigaus.f90 old mode 100755 new mode 100644 diff --git a/src/MNH/compute_mf_cloud_direct.f90 b/src/MNH/compute_mf_cloud_direct.f90 old mode 100755 new mode 100644 diff --git a/src/MNH/compute_mf_cloud_stat.f90 b/src/MNH/compute_mf_cloud_stat.f90 old mode 100755 new mode 100644 diff --git a/src/MNH/ini_radar.f90 b/src/MNH/ini_radar.f90 old mode 100755 new mode 100644 diff --git a/src/MNH/mean_field.f90 b/src/MNH/mean_field.f90 old mode 100755 new mode 100644 diff --git a/src/MNH/modd_prep_real.f90 b/src/MNH/modd_prep_real.f90 old mode 100755 new mode 100644