diff --git a/MAR/code_nestor/Compile.exe b/MAR/code_nestor/Compile.exe
new file mode 100644
index 0000000000000000000000000000000000000000..915401d9ede6f1075ea3b210b84da726c720f560
--- /dev/null
+++ b/MAR/code_nestor/Compile.exe
@@ -0,0 +1,134 @@
+#!/bin/bash
+##!/bin/ksh (no colors)
+# XF, 20/02/04
+#######################################
+
+# SuSE Linux 8.2 (gcc 3.2)
+# ------------------------
+
+# f77="f77"
+# o1="-w -O3 -finit-local-zero"
+# o2="-lnetcdf"
+# netcdf="/usr/include/netcdf.inc"
+
+# SuSE Linux 8.2 (ifc 7.1)
+# ------------------------
+
+# f77="ifc"
+# o1="-w -zero -O3" # -tpp7 -axW -xW don't work with PRCout
+# o2="-lnetcdfifc -lf2c_ifc"
+# netcdf="/usr/include/netcdf.inc"
+
+# SuSE Linux 9.0 (ifc 8.0)
+# ------------------------
+
+ f77="ifort"
+ o1="-static -O3 -w -zero -vec_report0"
+ o2="-lnetcdf_ifort"
+ netcdf="/usr/include/netcdf.inc"
+
+ [ -f $MARdir/lib/netcdf/netcdf.inc ] && netcdf="$MARdir/lib/netcdf/netcdf.inc"
+
+ [ ${#MARstatic} -eq 1 ] && [ "${MARstatic}" == "n" ] && o1="-O3 -w -zero -vec_report0"
+
+# IRIX64 6.5 (rhodes)
+# -------------------
+
+# f77="f90"
+# o1="-w -i8 -r8 -OPT:Olimit=3821 -O2"
+# o2="/usr/local/pub/lib64/netcdf-3.4/libnetcdf_i8_r8.a"
+# netcdf="/usr/local/pub/include/netcdf.inc"
+
+# DEC OSF1 V5.1 alpha
+# -------------------
+
+# f77="f90"
+# o1="-O4 -tune ev67 -arch ev67"
+# o2="/usr/local/netcdf/lib/libnetcdf.a"
+# netcdf="/opt/netcdf/include/netcdf.inc"
+
+# Output MAR in double precision with NESTOR in simple precision
+# to no have problem with input netcdf on DEC alpha e.g.
+
+ color=y
+
+ Version="4.1.8"
+
+#######################################
+
+if [ $color = "y" ] ; then
+
+E="-e"
+Rl="\E[31;1m" ; Rd="\E[31;2m" # red
+Yl="\E[33;1m" ; Yd="\E[33;2m" # yellow
+Gl="\E[32;1m" ; Gd="\E[32;2m" # green
+Bl="\E[34;1m" ; Bd="\E[34;2m" # blue
+W="\E[39;1m" ; D="\E[0m" # white/dark
+C="\E[36;1m" # cyan
+M="\E[35;1m" # magenta
+
+# WARNING: Don't work with /bin/ksh
+
+fi
+
+
+echo $E " "
+echo $E "${Rl} NESTOR ${Yl}${Version}${D}"
+echo $E "${Bl} --------------${D}"
+echo $E " "
+echo $E " ${Bl}Compilator : ${M}$f77${D}"
+echo $E " ${Bl}Option for $f77 : ${M}$o1${D}"
+echo $E " ${Bl}NetCDF.inc : ${M}$netcdf${D}"
+echo $E " "
+
+cd src
+
+rm -f NetCDF.inc &> /dev/null
+if [ ! -f $netcdf ] ; then
+ echo "$netcdf not found" && exit
+else
+ cp -f $netcdf NetCDF.inc
+fi
+
+
+
+rm -f *.o
+
+for File in *.f *.f90 ; do
+ if [ -f $File ] ; then
+
+ case ${#File} in
+ (5) f1=$File" " ;;
+ (6) f1=$File" " ;;
+ (7) f1=$File" " ;;
+ (8) f1=$File ;;
+ esac
+
+ $f77 $o1 -c $File
+
+ if [ $? -ne 0 ] ; then
+ echo $E " $f1 [${Rl}ERROR${D}]"
+ exit
+ else
+ echo $E " $f1 [${Gl} OK ${D}]"
+ fi
+
+ fi
+done
+
+rm -f ../NESTOR.exe
+$f77 $o1 -o ../NESTOR.exe *.o $o2
+
+cd ..
+
+if [ -f NESTOR.exe ] ; then
+ echo $E " "
+ echo $E "${Yd} Compilation of NESTOR $Version: ${Gl}OK${D}"
+ echo $E " "
+else
+ echo $E " "
+ echo $E "${Yd} Compilation of NESTOR $Version: ${Rl}ERROR${D}"
+ echo $E " "
+fi
+
+exit
diff --git a/MAR/code_nestor/LSCfil.dat b/MAR/code_nestor/LSCfil.dat
new file mode 100644
index 0000000000000000000000000000000000000000..b021e5b4ba64c77affe31329ab0c60eea0a98527
--- /dev/null
+++ b/MAR/code_nestor/LSCfil.dat
@@ -0,0 +1,3 @@
+Input/ERA-40/ECM.1990.11.01-15.GRD.nc
+Input/ERA-40/ECM.1990.11.16-30.GRD.nc
+Input/ERA-40/ECM.1990.12.01-15.GRD.nc
diff --git a/MAR/code_nestor/MARgrd.ctr b/MAR/code_nestor/MARgrd.ctr
new file mode 100644
index 0000000000000000000000000000000000000000..fe5d635c35004d002c5f198f45ea247f066e522d
--- /dev/null
+++ b/MAR/code_nestor/MARgrd.ctr
@@ -0,0 +1,28 @@
+PARAMETERS FOR MAR GRID CREATION
+================================
+
+-------------------------------------------------------------------------
+1 | Map type (0=polar,1=stereo,2=lambert)
+------------------------|------------------------------------------------
+0 | MAR domain center longitude
+70 | MAR domain center longitude (grid point = imez)
+89 | MAR domain center latitude
+80 | MAR domain center latitude (grid point = jmez)
+------------------------|------------------------------------------------
+50.0 | MAR mesh size (km)
+------------------------|------------------------------------------------
+90. | x-Direction (2D runs only ; 0=North, clockwise)
+------------------------|------------------------------------------------
+0.01 | Pressure at top (kPa)
+------------------------|------------------------------------------------
+2. | zzmin= STD NEW (0=>OK) Vertical discretisation
+1.8 | aavu= STD NEW (0=>OK) "
+1.13 | bbvu= STD NEW (0=>OK) "
+1000 | ccvu= STD NEW (0=>OK) "
+------------------------|------------------------------------------------
+T | Fine resolution of the Surface Layer
+------------------------|------------------------------------------------
+271.2 | Sea ST - parameter only used for vertical grid
+-------------------------------------------------------------------------
+0.0075 | Filter selectivity FIslo* (0.->sets to default)
+-------------------------------------------------------------------------
diff --git a/MAR/code_nestor/MODlai.f b/MAR/code_nestor/MODlai.f
new file mode 100644
index 0000000000000000000000000000000000000000..7a6eea440a8a16687e8f47bf6c5e09004088d292
--- /dev/null
+++ b/MAR/code_nestor/MODlai.f
@@ -0,0 +1,239 @@
+C +-------------------------------------------------------------------+
+C | Subroutine MODlai Apr 2023 NESTING |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE MERlai
+
+ IMPLICIT none
+
+
+C +---General variables
+C + -----------------
+
+ INCLUDE 'NSTdim.inc'
+ INCLUDE 'NSTvar.inc'
+ INCLUDE 'LOCfil.inc'
+ INCLUDE 'NetCDF.inc'
+ INCLUDE 'NESTOR.inc'
+
+ real ,parameter :: reso_y=0.0042 !ny/cy
+ real ,parameter :: reso_x=0.0042 !nx/cx
+ real ,parameter :: MOD_lon=-0.4996
+ real ,parameter :: MOD_lat=46.9046
+
+
+ integer,parameter :: cx = 2750 ! I of MODIS
+ integer,parameter :: cy = 1700 ! J of MODIS
+
+ integer ii,jj,i,j,k,l, i1,i2,j1,j2
+ integer NET_ID_LAI,NET_ID_GLF,NETcid,Rcode,start(4),count(4)
+ integer nbr_day,i_cent,j_cent,G_nx,G_ny, nerror
+
+ real AUXlon,AUXlat,debug
+ real AUXlo1,AUXlo2,AUXla1,AUXla2
+ real MODIS_lai(cx,cy),nsamp, laisum
+
+ integer DATiyr,DATmma,DATjda,DATjhu
+
+ CALL DATcnv (DATiyr,DATmma,DATjda,DATjhu,DATtim,.false.)
+
+ nbr_day=0
+
+ do i=1,DATmma-1
+ if(i==1.or.i==3.or.i==5.or.i==7.or.i==8.or.i==10.or.i==12)
+ . nbr_day=nbr_day+31
+ if(i==4.or.i==6.or.i==9.or.i==11) nbr_day=nbr_day+30
+ if(i==2) nbr_day=nbr_day+28
+ enddo
+
+ nbr_day=nbr_day+DATjda
+
+!-----------------------------------------------------------------------
+
+ NETcid = NCOPN("input/VEGE/Climato_non_leap_year.nc"
+ . ,NCNOWRIT,Rcode)
+ NET_ID_LAI = NCVID(NETcid,'LAI',Rcode)
+
+ ! NET_ID_GLF = NCVID(NETcid,'GLF',Rcode) removed GLF for now and
+ ! it will be 0.93
+
+ start(1)=1
+ start(2)=1
+ start(3)=nbr_day ! time step
+ count(1)=cx
+ count(2)=cy
+ count(3)=1
+
+ Rcode = nf_get_vara_real(NETcid,NET_ID_LAI,start,count,MODIS_lai)
+ !Rcode = nf_get_vara_real(NETcid,NET_ID_GLF,start,count,MODIS_glf)
+
+ CALL NCCLOS(NETcid, RCODE)
+
+
+!-----------------------------------------------------------------------
+
+ write(6,*) 'MERRA2 LAI-GLF data set'
+ write(6,*) '~~~~~~~~~~~~~~~~~~~~~~~'
+ write(6,*) ' '
+
+ nerror = 0
+
+ DO j=1,my !Loop on each Y of MAR
+ DO i=1,mx !Loop on each x of MAR
+
+C + *****
+ IF(NSTsol(i,j)>=3.and.NST__y(i,j)>-60.)THEN !if not on ice
+C + *****
+
+ if(NSTsvt(i,j,1)<=0.or.NSTsvt(i,j,1)==13) then
+ DO l=1,nvx
+ NSTlai(i,j,l) = 0.0
+ NSTglf(i,j,l) = 0.0
+ enddo
+ else
+
+ AUXlon = NST__x(i,j)
+ AUXlat = NST__y(i,j)
+
+C +---Search for the closest point in data file
+C + -----------------------------------------
+
+ i_cent=NINT((AUXlon-REAL(MOD_lon))/reso_x)+1
+ j_cent=NINT((AUXlat-REAL(MOD_lat))/reso_y)+1
+
+
+C +---Compute the resolution of the considered NST cell
+C + -------------------------------------------------
+
+ ii = MAX(i,2)
+ jj = MAX(j,2)
+
+ AUXlo1 = NST__x(ii ,jj )
+ AUXla1 = NST__y(ii ,jj )
+ AUXlo2 = NST__x(ii-1,jj-1)
+ AUXla2 = NST__y(ii-1,jj-1)
+
+
+C +---Define the data points to be read around (i_cent,j_cent)
+C + --------------------------------------------------------
+
+
+ G_nx=MAX(NINT(ABS(AUXlo1-AUXlo2)/reso_x),0)
+ G_ny=MAX(NINT(ABS(AUXla1-AUXla2)/reso_y),0)
+
+ i1=i_cent-G_nx
+ i2=i_cent+G_nx
+ j1=j_cent-G_ny
+ j2=j_cent+G_ny
+
+ ! not to go out of domain
+ i1=MAX(i1,1)
+ i2=MIN(i2,cx)
+ j1=MAX(j1,1)
+ j2=MIN(j2,cy)
+
+
+C +---Read subset of data
+C + -------------------
+
+ nsamp =0
+ laisum=0.
+
+ DO l=j1,j2 ! Loop on data grid points
+ DO k=i1,i2 ! contained in the (i,j) NST cell
+
+
+ IF (MODIS_lai(k,cy-l+1).ge.0
+ . .and. MODIS_lai(k,cy-l+1).le.20) THEN
+ laisum=laisum+MAX(0.,MODIS_lai(k,cy-l+1))
+ nsamp =nsamp+1
+ ENDIF
+
+ ENDDO
+ ENDDO
+
+ IF (nsamp.eq.0) THEN
+ ! write(6,*) 'error at (', NST__x(i,j), NST__y(i,j),')'
+ ! write(6,*) "SVT:",NSTsvt(i,j,1)
+ nerror = nerror +1
+ ! debug = MOD_lon+ reso_x*i1
+ ! write(6,*)i1,i2,j1,j2
+ ! write(6,*) NST__x(i,j), debug
+ ! debug = MOD_lon+ reso_x*i2
+ ! write(6,*) NST__x(i,j), debug
+ ENDIF
+
+
+ DO l=1,nvx
+ NSTlai(i,j,l)=min(10.,laisum/nsamp) ! interpolate to NST grid
+ ENDDO
+! -----------------------------------------------
+
+ DO l=1,nvx
+ NSTglf(i,j,l)= 0.93 ! interpolate to NST grid
+ ENDDO
+
+! -----------------------------------------------
+
+ DO l=1,nvx !For each vegetation type, we define a LAI max --> is
+ !also in GLOveg.f
+ IF (NSTsvt(i,j,l).eq. 0) NSTlmx(i,j,l) = 0.0
+ IF (NSTsvt(i,j,l).eq. 1) NSTlmx(i,j,l) = 0.6
+ IF (NSTsvt(i,j,l).eq. 2) NSTlmx(i,j,l) = 0.9
+ IF (NSTsvt(i,j,l).eq. 3) NSTlmx(i,j,l) = 1.2
+ IF (NSTsvt(i,j,l).eq. 4) NSTlmx(i,j,l) = 0.7
+ IF (NSTsvt(i,j,l).eq. 5) NSTlmx(i,j,l) = 1.4
+ IF (NSTsvt(i,j,l).eq. 6) NSTlmx(i,j,l) = 2.0
+ IF (NSTsvt(i,j,l).eq. 7.or.NSTsvt(i,j,l).eq.10)
+ . NSTlmx(i,j,l) = 3.0
+ IF (NSTsvt(i,j,l).eq. 8.or.NSTsvt(i,j,l).eq.11)
+ . NSTlmx(i,j,l) = 4.5
+ IF (NSTsvt(i,j,l).eq. 9.or.NSTsvt(i,j,l).eq.12)
+ . NSTlmx(i,j,l) = 6.0
+
+ ENDDO
+
+! -----------------------------------------------
+
+ DO l=1,nvx
+
+ ! NSTlai(i,j,l) = NSTlai(i,j,l) *
+ !. max(1.,min(2.,(1.+(NSTlmx(i,j,l)-3.)/12.)))
+
+ ! MERRA lai = mean lai over 50 x 50 km2
+ ! it is a bit corrected here in fct of vegetation.
+
+ !NSTlai(i,j,l) =max(0.,min(1.25*NSTlmx(i,j,l),NSTlai(i,j,l)))
+ ! maximum values are a bit too low in respect to literature
+
+ if(NSTsvt(i,j,l)<=0.or.NSTsvt(i,j,l)==13) then
+ NSTlai(i,j,l) = 0.0
+ NSTglf(i,j,l) = 0.0
+ endif ! city or bare soil or ice
+
+ ENDDO
+ endif
+! -----------------------------------------------
+
+C + ****
+ ELSE ! Ocean, ice, snow
+C + ****
+
+ DO l=1,nvx
+ NSTlai(i,j,l) = 0.0
+ NSTglf(i,j,l) = 0.0
+ ENDDO
+
+C + *****
+ ENDIF ! Continental areas
+C + *****
+
+ ENDDO
+ ENDDO
+ write(6,*)"Number of errors", nerror
+
+ END SUBROUTINE
+
+!--------------------------------------------------------------------------------------------------------------------------
+
+
diff --git a/MAR/code_nestor/NESTOR.exe b/MAR/code_nestor/NESTOR.exe
new file mode 100644
index 0000000000000000000000000000000000000000..7bfaf740342fb2e63a3bbccacf2554e948b48acb
Binary files /dev/null and b/MAR/code_nestor/NESTOR.exe differ
diff --git a/MAR/code_nestor/NSTing.ctr b/MAR/code_nestor/NSTing.ctr
new file mode 100644
index 0000000000000000000000000000000000000000..18122c1c0cd7f533a0d403dc05cf35c0b120e774
--- /dev/null
+++ b/MAR/code_nestor/NSTing.ctr
@@ -0,0 +1,88 @@
+*************************************************************************
+***************** CONTROL FILE FOR NESTOR PROGRAM *********************
+*************************************************************************
+
+-------------------------------------------------------------------------
+------------------------| NESTOR CONFIGURATION |
+1 | - 1 = Nesting field computation |
+ | - 2 = Rain disagregation |
+ | - 3 = Wind gust estimate |
+-------------------------------------------------------------------------
+GRu | Label experience (a3)
+------------------------+-----------------------------------+------------
+output/ | output path
+------------------------+-----------------------------------+------------
+NC1 | Large-scale model, e.g. E15, E40, MAR, TVM (a3)
+------------------------|------------------------------------------------
+MAR | Nested model, e.g. MAR, TVM, EUR (a3)
+------------------------|------------------------------------------------
+GRD | Region .e.g. GRD,ANT,EUR,GRD (a3)
+------------------------|------------------------------------------------
+2013,11,01,00 | DATE of RUN START (YY,mm,dd,hh)
+ 30,00 | RUN LENGHT (dd,hh)
+ 06 | Time interval between two forcings (hh)
+------------------------|------------------------------------------------
+------------------------| OUTPUT :
+T | - initial/forcing files (*.DAT) (F/T)
+F | - ASCII format init./for. files (MAR only)(F/T)
+T | - graphic check file (NST*.nc) (F/T)
+------------------------|------------------------------------------------
+T | Spherical coordinates for LSC grid (F/T)
+------------------------|------------------------------------------------
+1 | Horizontal interpol. type (1=bilin, 3=bicub)
+------------------------|------------------------------------------------
+1 | Vertical interpol. type (1=linear,3=cubic)
+------------------------|------------------------------------------------
+------------------------| TOPOGRAPHY SOURCE :
+T | - ETOPO data set (resol. : 5 minutes ) (F/T)
+F | - GTOPO data set (resol. : 30 secondes) (F/T)
+------------------------|------------------------------------------------
+------------------------| TOPOGRAPHY TREATMENT : |
+F | - border of constant topography at boundaries |
+F | - imposed LSC topography in the const. border |
+F | - imposed LSC topography in the whole domain |
+F | - zero topography in the const. border |
+T | - filtering of topography |
+------------------------|------------------------------------------------
+------------------------| CORRECTION APPLIED TO METEO. FIELDS :
+F | - 600-hPa geopotential height (F/T)
+T | - mixed surface layer (F/T)
+------------------------|------------------------------------------------
+------------------------| ROUGHNESS LENGHT :
+F | Computed from land use datasets (T/F)
+------------------------|------------------------------------------------
+------------------------| VEGETATION COVER :
+T | - Global land cover (IGBP) (T/F)
+F | - European land cover (Corine) : Europe (T/F)
+T | - GlobCover V.2.2 Land Cover (T/F)
+------------------------|------------------------------------------------
+------------------------| VEGETATION FRACTION (select max. one option) :
+F | - Correction with NDVI index (res. 1 km) (T/F)
+F | - MERRA2 LAI/GLF data set (res.50 km) (T/F)
+------------------------|------------------------------------------------
+------------------------| SOIL MODEL :
+T | De Ridder and Schayes (1997) soil model (T/F)
+40. | Imposed soil wetness in all layers (0 to 100 %)
+F | Soil wetness from ECMWF fields (T/F)
+------------------------|------------------------------------------------
+------------------------| SEA SURFACE TEMPERATURE :
+F | Imposed Reynolds sea surface temperature (T/F)
+------------------------|------------------------------------------------
+------------------------| SOUNDING
+F | Simplified initialisation with sounding (T/F)
+------------------------+---------------------------------+--------------
+/input | Sounding file
+------------------------+---------------------------------+--------------
+------------------------| CLOUD MICROPHYSICS
+F | Include cloud content in spec. humidity (T/F)
+------------------------|------------------------------------------------
+------------------------| RAIN DISAGGREGATION
+0 | 0 = no rain disaggregation (only model fields)
+ | 1 = disaggregation model of Sinclair (1994)
+ | 2 = disaggregation model of Alpert (1989)
+-------------------------------------------------------------------------
+------------------------| WIND GUST ESTIMATE METHOD
+1 | 1 = Standard WGE method of Brasseur (2001)
+ | 2 = BRN method (without TKE) of Ramel (2001)
+ | 3 = Ratio method
+-------------------------------------------------------------------------
diff --git a/MAR/code_nestor/NSTvou.dat b/MAR/code_nestor/NSTvou.dat
new file mode 100644
index 0000000000000000000000000000000000000000..bec015bde0c5fb68c6b01417fb08b9f321c4299f
--- /dev/null
+++ b/MAR/code_nestor/NSTvou.dat
@@ -0,0 +1,51 @@
+#---*--------*--------*--------*--------*--------*-----------*----------(NetCDF/IDL)-+
+# Variable ---------Dimensions---------------- Unites Nom complet (description)
+#---*--------1--------2--------3--------4--------*-----------*-----------------------+
+ DATE - - - time MMDDHH Date (MM/DD/HH)
+ LON x y - - degrees Longitude (NSTlon)
+ LAT x y - - degrees Latitude (NSTlat)
+ SH x y - - m Surface height (NST_sh)
+ SOL x y - - - Surface type (NSTsol)
+ TEX x y - - - Soil texture (NSTtex)
+ Z0 x y - - m Roug. lenght (mom.) (NST_z0)
+ R0 x y - - m Roug. lenght (heat) (NST_r0)
+ ALB x y - - - Soil Albedo (Deardorf) (NSTalb)
+ DSA x y - - - Soil Albedo (SVAT) (NSTdsa)
+ ICE x y - - % Ice mask (if mw=2) (NSTice)
+ GROUND x y - - % Grounded ice (NSTgrd)
+ ROCK x y - - % Rock (NSTrck)
+ AREA x y - - - Area (NSTarea)
+ RES x y - - s/m Stomatal resistance (NSTres)
+#
+ NDV x y - time - NDVI (NSTndv)
+ DV1 x y - - - Minimum NDVI index (NSTdv1)
+ DV2 x y - - - Maximum NDVI index (NSTdv2)
+#
+ FRC x y - - - Fract. of vege. cover (NSTfrc)
+ GLF x y sector time - Green leaf fraction (NSTglf)
+ VFR x y sector - - Frct. of IGBP veg. (NSTvfr)
+ SFR x y sector - - Frct. of SVAT veg. (NSTsfr)
+#
+ VEG x y sector - - IGBP veg. types (NSTveg)
+ SVT x y sector - - SVAT veg. types (NSTsvt)
+#
+ LAI x y sector time - Leaf area index (NSTlai)
+ EFRV x y - time - Effect. frac. of veg.
+ ELAI x y - time - Effect. leaf area index
+#
+ TS x y soil - K Init. soil temp. (NST_ts)
+ SW x y soil - - Init. soil wetn. (NST_sw)
+#
+ UU x y level time m/s X-wind speed comp. (NST__u)
+ VV x y level time m/s Y-wind speed comp. (NST__v)
+ TT x y level time K Real Temperature (NST__t)
+ PT x y level time K Potential temp. (NST_pt)
+ QQ x y level time Kg/Kg Specific Humidity (NST_qv)
+ ZZ x y level time m Model Levels Height (NST_zz)
+ SP x y - time kPa Pressure Tickness (NST_sp)
+ ST x y - time K Surface temperature (NST_st)
+#
+ SST x y - time K Sea surf. temp. (NSTsst)
+ SIC x y - time - Sea Ice . fraction (NSTsic)
+ EWC x y - time kg/m2 Equivalent W. C. (NSTewc)
+#
diff --git a/MAR/code_nestor/Nb_Proc_PERMIS/.gitignore b/MAR/code_nestor/Nb_Proc_PERMIS/.gitignore
new file mode 100644
index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391
diff --git a/MAR/code_nestor/Nb_Proc_PERMIS/Nb_Proc_PERMIS.OUT b/MAR/code_nestor/Nb_Proc_PERMIS/Nb_Proc_PERMIS.OUT
new file mode 100644
index 0000000000000000000000000000000000000000..4e6671b4ec3e4cfba183a4990ec60db0a8571612
--- /dev/null
+++ b/MAR/code_nestor/Nb_Proc_PERMIS/Nb_Proc_PERMIS.OUT
@@ -0,0 +1,771 @@
+
+Nb Pts / Proc-1 (i.e., mxx), HALO = 2
+Nb Proc--> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
+ 12 10 11# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 13 11 12# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 14 12 13# 8# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 15 13 14# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 16 14 15# 9# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 17 15 16# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 18 16 17# 10# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 19 17 18# 0 8# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 20 18 19# 11# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ (1st,2nd,3rd) column = (mx in NSTdim.inc, mxtt in MAR_control.dat, mxx if NO subdomain)
+
+Nb Pts / Proc-1 (i.e., mxx), HALO = 2
+Nb Proc--> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
+Nb Pts| 21 19 20# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+MARdim| 22 20 21# 12# 9# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+(.NE. | 23 21 22# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ Dom.)v 24 22 23# 13# 0 8# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 25 23 24# 0 10# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 26 24 25# 14# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 27 25 26# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 28 26 27# 15# 11# 9# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 29 27 28# 0 0 0 8# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 30 28 29# 16# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 31 29 30# 0 12# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 32 30 31# 17# 0 10# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 33 31 32# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 34 32 33# 18# 13# 0 9# 8# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 35 33 34# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 36 34 35# 19# 0 11# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 37 35 36# 0 14# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 38 36 37# 20# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 39 37 38# 0 0 0 10# 0 8# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 40 38 39# 21# 15# 12# 0 9# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ (1st,2nd,3rd) column = (mx in NSTdim.inc, mxtt in MAR_control.dat, mxx if NO subdomain)
+
+Nb Pts / Proc-1 (i.e., mxx), HALO = 2
+Nb Proc--> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
+Nb Pts| 41 39 40# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+MARdim| 42 40 41# 22# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+(.NE. | 43 41 42# 0 16# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ Dom.)v 44 42 43# 23# 0 13# 11# 0 0 8# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 45 43 44# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 46 44 45# 24# 17# 0 0 10# 9# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 47 45 46# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 48 46 47# 25# 0 14# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 49 47 48# 0 18# 0 12# 0 0 0 8# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 50 48 49# 26# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 51 49 50# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 52 50 51# 27# 19# 15# 0 11# 0 9# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 53 51 52# 0 0 0 0 0 10# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 54 52 53# 28# 0 0 13# 0 0 0 0 8# 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 55 53 54# 0 20# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 56 54 55# 29# 0 16# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 57 55 56# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 58 56 57# 30# 21# 0 0 12# 0 0 9# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 59 57 58# 0 0 0 14# 0 0 0 0 0 8# 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 60 58 59# 31# 0 17# 0 0 11# 10# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ (1st,2nd,3rd) column = (mx in NSTdim.inc, mxtt in MAR_control.dat, mxx if NO subdomain)
+
+Nb Pts / Proc-1 (i.e., mxx), HALO = 2
+Nb Proc--> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
+Nb Pts| 61 59 60# 0 22# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+MARdim| 62 60 61# 32# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+(.NE. | 63 61 62# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ Dom.)v 64 62 63# 33# 23# 18# 15# 13# 0 0 0 9# 0 8# 0 0 0 0 0 0 0 0 0 0 0 0
+ 65 63 64# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 66 64 65# 34# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 67 65 66# 0 24# 0 0 0 12# 0 10# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 68 66 67# 35# 0 19# 0 0 0 11# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 69 67 68# 0 0 0 16# 0 0 0 0 0 0 0 8# 0 0 0 0 0 0 0 0 0 0 0
+ 70 68 69# 36# 25# 0 0 14# 0 0 0 0 9# 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 71 69 70# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 72 70 71# 37# 0 20# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 73 71 72# 0 26# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 74 72 73# 38# 0 0 17# 0 13# 0 0 10# 0 0 0 8# 0 0 0 0 0 0 0 0 0 0
+ 75 73 74# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 76 74 75# 39# 27# 21# 0 15# 0 12# 11# 0 0 9# 0 0 0 0 0 0 0 0 0 0 0 0
+ 77 75 76# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 78 76 77# 40# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 79 77 78# 0 28# 0 18# 0 0 0 0 0 0 0 0 0 8# 0 0 0 0 0 0 0 0 0
+ 80 78 79# 41# 0 22# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ (1st,2nd,3rd) column = (mx in NSTdim.inc, mxtt in MAR_control.dat, mxx if NO subdomain)
+
+Nb Pts / Proc-1 (i.e., mxx), HALO = 2
+Nb Proc--> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
+Nb Pts| 81 79 80# 0 0 0 0 0 14# 0 0 0 10# 0 0 0 0 0 0 0 0 0 0 0 0 0
+MARdim| 82 80 81# 42# 29# 0 0 16# 0 0 0 0 0 0 9# 0 0 0 0 0 0 0 0 0 0 0
+(.NE. | 83 81 82# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ Dom.)v 84 82 83# 43# 0 23# 19# 0 0 13# 0 11# 0 0 0 0 0 8# 0 0 0 0 0 0 0 0
+ 85 83 84# 0 30# 0 0 0 0 0 12# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 86 84 85# 44# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 87 85 86# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 88 86 87# 45# 31# 24# 0 17# 15# 0 0 0 0 10# 0 9# 0 0 0 0 0 0 0 0 0 0
+ 89 87 88# 0 0 0 20# 0 0 0 0 0 0 0 0 0 0 0 8# 0 0 0 0 0 0 0
+ 90 88 89# 46# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 91 89 90# 0 32# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 92 90 91# 47# 0 25# 0 0 0 14# 0 0 11# 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 93 91 92# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 94 92 93# 48# 33# 0 21# 18# 0 0 13# 12# 0 0 0 0 9# 0 0 8# 0 0 0 0 0 0
+ 95 93 94# 0 0 0 0 0 16# 0 0 0 0 0 10# 0 0 0 0 0 0 0 0 0 0 0
+ 96 94 95# 49# 0 26# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 97 95 96# 0 34# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 98 96 97# 50# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 99 97 98# 0 0 0 22# 0 0 0 0 0 0 0 0 0 0 0 0 0 8# 0 0 0 0 0
+ 100 98 99# 51# 35# 27# 0 19# 0 15# 0 0 0 11# 0 0 0 9# 0 0 0 0 0 0 0 0
+ (1st,2nd,3rd) column = (mx in NSTdim.inc, mxtt in MAR_control.dat, mxx if NO subdomain)
+
+Nb Pts / Proc-1 (i.e., mxx), HALO = 2
+Nb Proc--> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
+Nb Pts| 101 99 100# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+MARdim| 102 100 101# 52# 0 0 0 0 17# 0 0 0 0 0 0 10# 0 0 0 0 0 0 0 0 0 0
+(.NE. | 103 101 102# 0 36# 0 0 0 0 0 14# 0 12# 0 0 0 0 0 0 0 0 0 0 0 0 0
+ Dom.)v 104 102 103# 53# 0 28# 23# 0 0 0 0 13# 0 0 0 0 0 0 0 0 0 8# 0 0 0 0
+ 105 103 104# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 106 104 105# 54# 37# 0 0 20# 0 0 0 0 0 0 0 0 0 0 9# 0 0 0 0 0 0 0
+ 107 105 106# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 108 106 107# 55# 0 29# 0 0 0 16# 0 0 0 0 11# 0 0 0 0 0 0 0 0 0 0 0
+ 109 107 108# 0 38# 0 24# 0 18# 0 0 0 0 0 0 0 10# 0 0 0 0 0 8# 0 0 0
+ 110 108 109# 56# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 111 109 110# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 112 110 111# 57# 39# 30# 0 21# 0 0 15# 0 0 12# 0 0 0 0 0 9# 0 0 0 0 0 0
+ 113 111 112# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 114 112 113# 58# 0 0 25# 0 0 0 0 14# 13# 0 0 0 0 0 0 0 0 0 0 8# 0 0
+ 115 113 114# 0 40# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 116 114 115# 59# 0 31# 0 0 19# 17# 0 0 0 0 0 11# 0 10# 0 0 0 0 0 0 0 0
+ 117 115 116# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 118 116 117# 60# 41# 0 0 22# 0 0 0 0 0 0 0 0 0 0 0 0 9# 0 0 0 0 0
+ 119 117 118# 0 0 0 26# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 8# 0
+ 120 118 119# 61# 0 32# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ (1st,2nd,3rd) column = (mx in NSTdim.inc, mxtt in MAR_control.dat, mxx if NO subdomain)
+
+Nb Pts / Proc-1 (i.e., mxx), HALO = 2
+Nb Proc--> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
+Nb Pts| 121 119 120# 0 42# 0 0 0 0 0 16# 0 0 0 12# 0 0 0 0 0 0 0 0 0 0 0
+MARdim| 122 120 121# 62# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+(.NE. | 123 121 122# 0 0 0 0 0 20# 0 0 0 0 0 0 0 0 0 10# 0 0 0 0 0 0 0
+ Dom.)v 124 122 123# 63# 43# 33# 27# 23# 0 18# 0 15# 0 13# 0 0 11# 0 0 0 0 9# 0 0 0 8#
+ 125 123 124# 0 0 0 0 0 0 0 0 0 14# 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 126 124 125# 64# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 127 125 126# 0 44# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 128 126 127# 65# 0 34# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 129 127 128# 0 0 0 28# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 130 128 129# 66# 45# 0 0 24# 21# 0 17# 0 0 0 0 12# 0 0 0 10# 0 0 9# 0 0 0
+ 131 129 130# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 132 130 131# 67# 0 35# 0 0 0 19# 0 0 0 0 0 0 0 11# 0 0 0 0 0 0 0 0
+ 133 131 132# 0 46# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 134 132 133# 68# 0 0 29# 0 0 0 0 16# 0 0 13# 0 0 0 0 0 0 0 0 0 0 0
+ 135 133 134# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 136 134 135# 69# 47# 36# 0 25# 0 0 0 0 15# 14# 0 0 0 0 0 0 0 0 0 9# 0 0
+ 137 135 136# 0 0 0 0 0 22# 0 0 0 0 0 0 0 0 0 0 0 10# 0 0 0 0 0
+ 138 136 137# 70# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 139 137 138# 0 48# 0 30# 0 0 0 18# 0 0 0 0 0 12# 0 0 0 0 0 0 0 0 0
+ 140 138 139# 71# 0 37# 0 0 0 20# 0 0 0 0 0 0 0 0 11# 0 0 0 0 0 0 0
+ (1st,2nd,3rd) column = (mx in NSTdim.inc, mxtt in MAR_control.dat, mxx if NO subdomain)
+
+Nb Pts / Proc-1 (i.e., mxx), HALO = 2
+Nb Proc--> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
+Nb Pts| 141 139 140# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+MARdim| 142 140 141# 72# 49# 0 0 26# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 9# 0
+(.NE. | 143 141 142# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ Dom.)v 144 142 143# 73# 0 38# 31# 0 23# 0 0 17# 0 0 0 13# 0 0 0 0 0 10# 0 0 0 0
+ 145 143 144# 0 50# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 146 144 145# 74# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 147 145 146# 0 0 0 0 0 0 0 0 0 16# 0 14# 0 0 0 0 0 0 0 0 0 0 0
+ 148 146 147# 75# 51# 39# 0 27# 0 21# 19# 0 0 15# 0 0 0 12# 0 11# 0 0 0 0 0 9#
+ 149 147 148# 0 0 0 32# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 150 148 149# 76# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 151 149 150# 0 52# 0 0 0 24# 0 0 0 0 0 0 0 0 0 0 0 0 0 10# 0 0 0
+ 152 150 151# 77# 0 40# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 153 151 152# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 154 152 153# 78# 53# 0 33# 28# 0 0 0 18# 0 0 0 0 13# 0 0 0 0 0 0 0 0 0
+ 155 153 154# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 156 154 155# 79# 0 41# 0 0 0 22# 0 0 0 0 0 0 0 0 0 0 11# 0 0 0 0 0
+ 157 155 156# 0 54# 0 0 0 0 0 20# 0 0 0 0 0 0 0 12# 0 0 0 0 0 0 0
+ 158 156 157# 80# 0 0 0 0 25# 0 0 0 17# 0 0 14# 0 0 0 0 0 0 0 10# 0 0
+ 159 157 158# 0 0 0 34# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 160 158 159# 81# 55# 42# 0 29# 0 0 0 0 0 16# 15# 0 0 0 0 0 0 0 0 0 0 0
+ (1st,2nd,3rd) column = (mx in NSTdim.inc, mxtt in MAR_control.dat, mxx if NO subdomain)
+
+Nb Pts / Proc-1 (i.e., mxx), HALO = 2
+Nb Proc--> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
+Nb Pts| 161 159 160# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+MARdim| 162 160 161# 82# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+(.NE. | 163 161 162# 0 56# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ Dom.)v 164 162 163# 83# 0 43# 35# 0 0 23# 0 19# 0 0 0 0 0 13# 0 0 0 11# 0 0 0 0
+ 165 163 164# 0 0 0 0 0 26# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 10# 0
+ 166 164 165# 84# 57# 0 0 30# 0 0 21# 0 0 0 0 0 0 0 0 12# 0 0 0 0 0 0
+ 167 165 166# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 168 166 167# 85# 0 44# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 169 167 168# 0 58# 0 36# 0 0 0 0 0 18# 0 0 0 14# 0 0 0 0 0 0 0 0 0
+ 170 168 169# 86# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 171 169 170# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 172 170 171# 87# 59# 45# 0 31# 27# 24# 0 0 0 17# 0 15# 0 0 0 0 0 0 11# 0 0 10#
+ 173 171 172# 0 0 0 0 0 0 0 0 0 0 0 16# 0 0 0 0 0 0 0 0 0 0 0
+ 174 172 173# 88# 0 0 37# 0 0 0 0 20# 0 0 0 0 0 0 13# 0 0 0 0 0 0 0
+ 175 173 174# 0 60# 0 0 0 0 0 22# 0 0 0 0 0 0 0 0 0 12# 0 0 0 0 0
+ 176 174 175# 89# 0 46# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 177 175 176# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 178 176 177# 90# 61# 0 0 32# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 179 177 178# 0 0 0 38# 0 28# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 180 178 179# 91# 0 47# 0 0 0 25# 0 0 19# 0 0 0 0 14# 0 0 0 0 0 11# 0 0
+ (1st,2nd,3rd) column = (mx in NSTdim.inc, mxtt in MAR_control.dat, mxx if NO subdomain)
+
+Nb Pts / Proc-1 (i.e., mxx), HALO = 2
+Nb Proc--> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
+Nb Pts| 181 179 180# 0 62# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+MARdim| 182 180 181# 92# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+(.NE. | 183 181 182# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ Dom.)v 184 182 183# 93# 63# 48# 39# 33# 0 0 23# 21# 0 18# 0 0 15# 0 0 13# 0 12# 0 0 0 0
+ 185 183 184# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 186 184 185# 94# 0 0 0 0 29# 0 0 0 0 0 17# 16# 0 0 0 0 0 0 0 0 0 0
+ 187 185 186# 0 64# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 188 186 187# 95# 0 49# 0 0 0 26# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 11# 0
+ 189 187 188# 0 0 0 40# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 190 188 189# 96# 65# 0 0 34# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 191 189 190# 0 0 0 0 0 0 0 0 0 20# 0 0 0 0 0 14# 0 0 0 0 0 0 0
+ 192 190 191# 97# 0 50# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 193 191 192# 0 66# 0 0 0 30# 0 24# 0 0 0 0 0 0 0 0 0 0 0 12# 0 0 0
+ 194 192 193# 98# 0 0 41# 0 0 0 0 22# 0 0 0 0 0 0 0 0 13# 0 0 0 0 0
+ 195 193 194# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 196 194 195# 99# 67# 51# 0 35# 0 27# 0 0 0 19# 0 0 0 15# 0 0 0 0 0 0 0 11#
+ 197 195 196# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 198 196 197# 100# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 199 197 198# 0 68# 0 42# 0 0 0 0 0 0 0 18# 0 16# 0 0 0 0 0 0 0 0 0
+ 200 198 199# 101# 0 52# 0 0 31# 0 0 0 0 0 0 17# 0 0 0 0 0 0 0 0 0 0
+ (1st,2nd,3rd) column = (mx in NSTdim.inc, mxtt in MAR_control.dat, mxx if NO subdomain)
+
+Nb Pts / Proc-1 (i.e., mxx), HALO = 2
+Nb Proc--> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
+Nb Pts| 201 199 200# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+MARdim| 202 200 201# 102# 69# 0 0 36# 0 0 25# 0 21# 0 0 0 0 0 0 14# 0 0 0 12# 0 0
+(.NE. | 203 201 202# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ Dom.)v 204 202 203# 103# 0 53# 43# 0 0 28# 0 23# 0 0 0 0 0 0 0 0 0 13# 0 0 0 0
+ 205 203 204# 0 70# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 206 204 205# 104# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 207 205 206# 0 0 0 0 0 32# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 208 206 207# 105# 71# 54# 0 37# 0 0 0 0 0 20# 0 0 0 0 15# 0 0 0 0 0 0 0
+ 209 207 208# 0 0 0 44# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 210 208 209# 106# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 211 209 210# 0 72# 0 0 0 0 0 26# 0 0 0 0 0 0 0 0 0 0 0 0 0 12# 0
+ 212 210 211# 107# 0 55# 0 0 0 29# 0 0 0 0 19# 0 0 16# 0 0 0 0 0 0 0 0
+ 213 211 212# 0 0 0 0 0 0 0 0 0 22# 0 0 0 0 0 0 0 14# 0 0 0 0 0
+ 214 212 213# 108# 73# 0 45# 38# 33# 0 0 24# 0 0 0 18# 17# 0 0 0 0 0 13# 0 0 0
+ 215 213 214# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 216 214 215# 109# 0 56# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 217 215 216# 0 74# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 218 216 217# 110# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 219 217 218# 0 0 0 46# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 220 218 219# 111# 75# 57# 0 39# 0 30# 27# 0 0 21# 0 0 0 0 0 15# 0 0 0 0 0 12#
+ (1st,2nd,3rd) column = (mx in NSTdim.inc, mxtt in MAR_control.dat, mxx if NO subdomain)
+
+Nb Pts / Proc-1 (i.e., mxx), HALO = 2
+Nb Proc--> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
+Nb Pts| 221 219 220# 0 0 0 0 0 34# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+MARdim| 222 220 221# 112# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+(.NE. | 223 221 222# 0 76# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ Dom.)v 224 222 223# 113# 0 58# 47# 0 0 0 0 25# 23# 0 0 0 0 0 0 0 0 14# 0 13# 0 0
+ 225 223 224# 0 0 0 0 0 0 0 0 0 0 0 20# 0 0 0 16# 0 0 0 0 0 0 0
+ 226 224 225# 114# 77# 0 0 40# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 227 225 226# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 228 226 227# 115# 0 59# 0 0 35# 31# 0 0 0 0 0 19# 0 17# 0 0 0 0 0 0 0 0
+ 229 227 228# 0 78# 0 48# 0 0 0 28# 0 0 0 0 0 18# 0 0 0 0 0 0 0 0 0
+ 230 228 229# 116# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 231 229 230# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 232 230 231# 117# 79# 60# 0 41# 0 0 0 0 0 22# 0 0 0 0 0 0 15# 0 0 0 0 0
+ 233 231 232# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 234 232 233# 118# 0 0 49# 0 0 0 0 26# 0 0 0 0 0 0 0 0 0 0 0 0 13# 0
+ 235 233 234# 0 80# 0 0 0 36# 0 0 0 24# 0 0 0 0 0 0 0 0 0 14# 0 0 0
+ 236 234 235# 119# 0 61# 0 0 0 32# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 237 235 236# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 238 236 237# 120# 81# 0 0 42# 0 0 29# 0 0 0 21# 0 0 0 0 16# 0 0 0 0 0 0
+ 239 237 238# 0 0 0 50# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 240 238 239# 121# 0 62# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ (1st,2nd,3rd) column = (mx in NSTdim.inc, mxtt in MAR_control.dat, mxx if NO subdomain)
+
+Nb Pts / Proc-1 (i.e., mxx), HALO = 2
+Nb Proc--> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
+Nb Pts| 241 239 240# 0 82# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+MARdim| 242 240 241# 122# 0 0 0 0 37# 0 0 0 0 0 0 20# 0 0 17# 0 0 0 0 0 0 0
+(.NE. | 243 241 242# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ Dom.)v 244 242 243# 123# 83# 63# 51# 43# 0 33# 0 27# 0 23# 0 0 19# 18# 0 0 0 15# 0 0 0 13#
+ 245 243 244# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 246 244 245# 124# 0 0 0 0 0 0 0 0 25# 0 0 0 0 0 0 0 0 0 0 14# 0 0
+ 247 245 246# 0 84# 0 0 0 0 0 30# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 248 246 247# 125# 0 64# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 249 247 248# 0 0 0 52# 0 38# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 250 248 249# 126# 85# 0 0 44# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 251 249 250# 0 0 0 0 0 0 0 0 0 0 0 22# 0 0 0 0 0 16# 0 0 0 0 0
+ 252 250 251# 127# 0 65# 0 0 0 34# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 253 251 252# 0 86# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 254 252 253# 128# 0 0 53# 0 0 0 0 28# 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 255 253 254# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 256 254 255# 129# 87# 66# 0 45# 39# 0 31# 0 0 24# 0 21# 0 0 0 17# 0 0 15# 0 0 0
+ 257 255 256# 0 0 0 0 0 0 0 0 0 26# 0 0 0 0 0 0 0 0 0 0 0 14# 0
+ 258 256 257# 130# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 259 257 258# 0 88# 0 54# 0 0 0 0 0 0 0 0 0 20# 0 18# 0 0 0 0 0 0 0
+ 260 258 259# 131# 0 67# 0 0 0 35# 0 0 0 0 0 0 0 19# 0 0 0 0 0 0 0 0
+ (1st,2nd,3rd) column = (mx in NSTdim.inc, mxtt in MAR_control.dat, mxx if NO subdomain)
+
+Nb Pts / Proc-1 (i.e., mxx), HALO = 2
+Nb Proc--> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
+Nb Pts| 261 259 260# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+MARdim| 262 260 261# 132# 89# 0 0 46# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+(.NE. | 263 261 262# 0 0 0 0 0 40# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ Dom.)v 264 262 263# 133# 0 68# 55# 0 0 0 0 29# 0 0 23# 0 0 0 0 0 0 16# 0 0 0 0
+ 265 263 264# 0 90# 0 0 0 0 0 32# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 266 264 265# 134# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 267 265 266# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 268 266 267# 135# 91# 69# 0 47# 0 36# 0 0 27# 25# 0 0 0 0 0 0 0 0 0 15# 0 14#
+ 269 267 268# 0 0 0 56# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 270 268 269# 136# 0 0 0 0 41# 0 0 0 0 0 0 22# 0 0 0 0 17# 0 0 0 0 0
+ 271 269 270# 0 92# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 272 270 271# 137# 0 70# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 273 271 272# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 274 272 273# 138# 93# 0 57# 48# 0 0 33# 30# 0 0 0 0 21# 0 0 18# 0 0 0 0 0 0
+ 275 273 274# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 276 274 275# 139# 0 71# 0 0 0 37# 0 0 0 0 0 0 0 20# 19# 0 0 0 0 0 0 0
+ 277 275 276# 0 94# 0 0 0 42# 0 0 0 0 0 24# 0 0 0 0 0 0 0 16# 0 0 0
+ 278 276 277# 140# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 279 277 278# 0 0 0 58# 0 0 0 0 0 28# 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 280 278 279# 141# 95# 72# 0 49# 0 0 0 0 0 26# 0 0 0 0 0 0 0 0 0 0 15# 0
+ (1st,2nd,3rd) column = (mx in NSTdim.inc, mxtt in MAR_control.dat, mxx if NO subdomain)
+
+Nb Pts / Proc-1 (i.e., mxx), HALO = 2
+Nb Proc--> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
+Nb Pts| 281 279 280# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+MARdim| 282 280 281# 142# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+(.NE. | 283 281 282# 0 96# 0 0 0 0 0 34# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ Dom.)v 284 282 283# 143# 0 73# 59# 0 43# 38# 0 31# 0 0 0 23# 0 0 0 0 0 17# 0 0 0 0
+ 285 283 284# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 286 284 285# 144# 97# 0 0 50# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 287 285 286# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 288 286 287# 145# 0 74# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 289 287 288# 0 98# 0 60# 0 0 0 0 0 0 0 0 0 22# 0 0 0 18# 0 0 0 0 0
+ 290 288 289# 146# 0 0 0 0 0 0 0 0 29# 0 25# 0 0 0 0 0 0 0 0 16# 0 0
+ 291 289 290# 0 0 0 0 0 44# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 292 290 291# 147# 99# 75# 0 51# 0 39# 35# 0 0 27# 0 0 0 21# 0 19# 0 0 0 0 0 15#
+ 293 291 292# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 20# 0 0 0 0 0 0 0
+ 294 292 293# 148# 0 0 61# 0 0 0 0 32# 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 295 293 294# 0 100# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 296 294 295# 149# 0 76# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 297 295 296# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 298 296 297# 150# 101# 0 0 52# 45# 0 0 0 0 0 0 24# 0 0 0 0 0 0 17# 0 0 0
+ 299 297 298# 0 0 0 62# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 300 298 299# 151# 0 77# 0 0 0 40# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ (1st,2nd,3rd) column = (mx in NSTdim.inc, mxtt in MAR_control.dat, mxx if NO subdomain)
+
+Nb Pts / Proc-1 (i.e., mxx), HALO = 2
+Nb Proc--> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
+Nb Pts| 301 299 300# 0 102# 0 0 0 0 0 36# 0 30# 0 0 0 0 0 0 0 0 0 0 0 0 0
+MARdim| 302 300 301# 152# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+(.NE. | 303 301 302# 0 0 0 0 0 0 0 0 0 0 0 26# 0 0 0 0 0 0 0 0 0 16# 0
+ Dom.)v 304 302 303# 153# 103# 78# 63# 53# 0 0 0 33# 0 28# 0 0 23# 0 0 0 0 18# 0 0 0 0
+ 305 303 304# 0 0 0 0 0 46# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 306 304 305# 154# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 307 305 306# 0 104# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 308 306 307# 155# 0 79# 0 0 0 41# 0 0 0 0 0 0 0 22# 0 0 19# 0 0 0 0 0
+ 309 307 308# 0 0 0 64# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 310 308 309# 156# 105# 0 0 54# 0 0 37# 0 0 0 0 0 0 0 21# 20# 0 0 0 0 0 0
+ 311 309 310# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 312 310 311# 157# 0 80# 0 0 47# 0 0 0 31# 0 0 25# 0 0 0 0 0 0 0 17# 0 0
+ 313 311 312# 0 106# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 314 312 313# 158# 0 0 65# 0 0 0 0 34# 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 315 313 314# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 316 314 315# 159# 107# 81# 0 55# 0 42# 0 0 0 29# 27# 0 0 0 0 0 0 0 0 0 0 16#
+ 317 315 316# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 318 316 317# 160# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 319 317 318# 0 108# 0 66# 0 48# 0 38# 0 0 0 0 0 24# 0 0 0 0 0 18# 0 0 0
+ 320 318 319# 161# 0 82# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ (1st,2nd,3rd) column = (mx in NSTdim.inc, mxtt in MAR_control.dat, mxx if NO subdomain)
+
+Nb Pts / Proc-1 (i.e., mxx), HALO = 2
+Nb Proc--> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
+Nb Pts| 321 319 320# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+MARdim| 322 320 321# 162# 109# 0 0 56# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+(.NE. | 323 321 322# 0 0 0 0 0 0 0 0 0 32# 0 0 0 0 0 0 0 0 0 0 0 0 0
+ Dom.)v 324 322 323# 163# 0 83# 67# 0 0 43# 0 35# 0 0 0 0 0 23# 0 0 0 19# 0 0 0 0
+ 325 323 324# 0 110# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 326 324 325# 164# 0 0 0 0 49# 0 0 0 0 0 0 26# 0 0 0 0 0 0 0 0 17# 0
+ 327 325 326# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 22# 0 20# 0 0 0 0 0
+ 328 326 327# 165# 111# 84# 0 57# 0 0 39# 0 0 30# 0 0 0 0 0 21# 0 0 0 0 0 0
+ 329 327 328# 0 0 0 68# 0 0 0 0 0 0 0 28# 0 0 0 0 0 0 0 0 0 0 0
+ 330 328 329# 166# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 331 329 330# 0 112# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 332 330 331# 167# 0 85# 0 0 0 44# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 333 331 332# 0 0 0 0 0 50# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 334 332 333# 168# 113# 0 69# 58# 0 0 0 36# 33# 0 0 0 25# 0 0 0 0 0 0 18# 0 0
+ 335 333 334# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 336 334 335# 169# 0 86# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 337 335 336# 0 114# 0 0 0 0 0 40# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 338 336 337# 170# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 339 337 338# 0 0 0 70# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 340 338 339# 171# 115# 87# 0 59# 51# 45# 0 0 0 31# 0 27# 0 24# 0 0 0 0 19# 0 0 17#
+ (1st,2nd,3rd) column = (mx in NSTdim.inc, mxtt in MAR_control.dat, mxx if NO subdomain)
+
+Nb Pts / Proc-1 (i.e., mxx), HALO = 2
+Nb Proc--> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
+Nb Pts| 341 339 340# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+MARdim| 342 340 341# 172# 0 0 0 0 0 0 0 0 0 0 29# 0 0 0 0 0 0 0 0 0 0 0
+(.NE. | 343 341 342# 0 116# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ Dom.)v 344 342 343# 173# 0 88# 71# 0 0 0 0 37# 0 0 0 0 0 0 23# 0 0 20# 0 0 0 0
+ 345 343 344# 0 0 0 0 0 0 0 0 0 34# 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 346 344 345# 174# 117# 0 0 60# 0 0 41# 0 0 0 0 0 0 0 0 22# 21# 0 0 0 0 0
+ 347 345 346# 0 0 0 0 0 52# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 348 346 347# 175# 0 89# 0 0 0 46# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 349 347 348# 0 118# 0 72# 0 0 0 0 0 0 0 0 0 26# 0 0 0 0 0 0 0 18# 0
+ 350 348 349# 176# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 351 349 350# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 352 350 351# 177# 119# 90# 0 61# 0 0 0 0 0 32# 0 0 0 0 0 0 0 0 0 0 0 0
+ 353 351 352# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 354 352 353# 178# 0 0 73# 0 53# 0 0 38# 0 0 0 28# 0 0 0 0 0 0 0 0 0 0
+ 355 353 354# 0 120# 0 0 0 0 0 42# 0 0 0 30# 0 0 0 0 0 0 0 0 0 0 0
+ 356 354 355# 179# 0 91# 0 0 0 47# 0 0 35# 0 0 0 0 25# 0 0 0 0 0 19# 0 0
+ 357 355 356# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 358 356 357# 180# 121# 0 0 62# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 359 357 358# 0 0 0 74# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 360 358 359# 181# 0 92# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ (1st,2nd,3rd) column = (mx in NSTdim.inc, mxtt in MAR_control.dat, mxx if NO subdomain)
+
+Nb Pts / Proc-1 (i.e., mxx), HALO = 2
+Nb Proc--> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
+Nb Pts| 361 359 360# 0 122# 0 0 0 54# 0 0 0 0 0 0 0 0 0 24# 0 0 0 20# 0 0 0
+MARdim| 362 360 361# 182# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+(.NE. | 363 361 362# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ Dom.)v 364 362 363# 183# 123# 93# 75# 63# 0 48# 43# 39# 0 33# 0 0 27# 0 0 23# 0 21# 0 0 0 18#
+ 365 363 364# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 22# 0 0 0 0 0
+ 366 364 365# 184# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 367 365 366# 0 124# 0 0 0 0 0 0 0 36# 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 368 366 367# 185# 0 94# 0 0 55# 0 0 0 0 0 31# 29# 0 0 0 0 0 0 0 0 0 0
+ 369 367 368# 0 0 0 76# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 370 368 369# 186# 125# 0 0 64# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 371 369 370# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 372 370 371# 187# 0 95# 0 0 0 49# 0 0 0 0 0 0 0 26# 0 0 0 0 0 0 19# 0
+ 373 371 372# 0 126# 0 0 0 0 0 44# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 374 372 373# 188# 0 0 77# 0 0 0 0 40# 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 375 373 374# 0 0 0 0 0 56# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 376 374 375# 189# 127# 96# 0 65# 0 0 0 0 0 34# 0 0 0 0 0 0 0 0 0 0 0 0
+ 377 375 376# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 378 376 377# 190# 0 0 0 0 0 0 0 0 37# 0 0 0 0 0 25# 0 0 0 0 20# 0 0
+ 379 377 378# 0 128# 0 78# 0 0 0 0 0 0 0 0 0 28# 0 0 0 0 0 0 0 0 0
+ 380 378 379# 191# 0 97# 0 0 0 50# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ (1st,2nd,3rd) column = (mx in NSTdim.inc, mxtt in MAR_control.dat, mxx if NO subdomain)
+
+Nb Pts / Proc-1 (i.e., mxx), HALO = 2
+Nb Proc--> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
+Nb Pts| 381 379 380# 0 0 0 0 0 0 0 0 0 0 0 32# 0 0 0 0 0 0 0 0 0 0 0
+MARdim| 382 380 381# 192# 129# 0 0 66# 57# 0 45# 0 0 0 0 30# 0 0 0 24# 0 0 21# 0 0 0
+(.NE. | 383 381 382# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ Dom.)v 384 382 383# 193# 0 98# 79# 0 0 0 0 41# 0 0 0 0 0 0 0 0 23# 22# 0 0 0 0
+ 385 383 384# 0 130# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 386 384 385# 194# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 387 385 386# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 388 386 387# 195# 131# 99# 0 67# 0 51# 0 0 0 35# 0 0 0 27# 0 0 0 0 0 0 0 19#
+ 389 387 388# 0 0 0 80# 0 58# 0 0 0 38# 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 390 388 389# 196# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 391 389 390# 0 132# 0 0 0 0 0 46# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 392 390 391# 197# 0 100# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 393 391 392# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 394 392 393# 198# 133# 0 81# 68# 0 0 0 42# 0 0 33# 0 29# 0 0 0 0 0 0 0 0 0
+ 395 393 394# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 26# 0 0 0 0 0 20# 0
+ 396 394 395# 199# 0 101# 0 0 59# 52# 0 0 0 0 0 31# 0 0 0 0 0 0 0 0 0 0
+ 397 395 396# 0 134# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 398 396 397# 200# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 399 397 398# 0 0 0 82# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 400 398 399# 201# 135# 102# 0 69# 0 0 47# 0 39# 36# 0 0 0 0 0 25# 0 0 0 21# 0 0
+ (1st,2nd,3rd) column = (mx in NSTdim.inc, mxtt in MAR_control.dat, mxx if NO subdomain)
+
+Nb Pts / Proc-1 (i.e., mxx), HALO = 2
+Nb Proc--> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
+Nb Pts| 401 399 400# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+MARdim| 402 400 401# 202# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+(.NE. | 403 401 402# 0 136# 0 0 0 60# 0 0 0 0 0 0 0 0 0 0 0 24# 0 22# 0 0 0
+ Dom.)v 404 402 403# 203# 0 103# 83# 0 0 53# 0 43# 0 0 0 0 0 28# 0 0 0 23# 0 0 0 0
+ 405 403 404# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 406 404 405# 204# 137# 0 0 70# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 407 405 406# 0 0 0 0 0 0 0 0 0 0 0 34# 0 0 0 0 0 0 0 0 0 0 0
+ 408 406 407# 205# 0 104# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 409 407 408# 0 138# 0 84# 0 0 0 48# 0 0 0 0 0 30# 0 0 0 0 0 0 0 0 0
+ 410 408 409# 206# 0 0 0 0 61# 0 0 0 0 0 0 32# 0 0 0 0 0 0 0 0 0 0
+ 411 409 410# 0 0 0 0 0 0 0 0 0 40# 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 412 410 411# 207# 139# 105# 0 71# 0 54# 0 0 0 37# 0 0 0 0 27# 0 0 0 0 0 0 20#
+ 413 411 412# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 414 412 413# 208# 0 0 85# 0 0 0 0 44# 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 415 413 414# 0 140# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 416 414 415# 209# 0 106# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 417 415 416# 0 0 0 0 0 62# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 418 416 417# 210# 141# 0 0 72# 0 0 49# 0 0 0 0 0 0 0 0 26# 0 0 0 0 21# 0
+ 419 417 418# 0 0 0 86# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 420 418 419# 211# 0 107# 0 0 0 55# 0 0 0 0 35# 0 0 29# 0 0 0 0 0 0 0 0
+ (1st,2nd,3rd) column = (mx in NSTdim.inc, mxtt in MAR_control.dat, mxx if NO subdomain)
+
+Nb Pts / Proc-1 (i.e., mxx), HALO = 2
+Nb Proc--> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
+Nb Pts| 421 419 420# 0 142# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+MARdim| 422 420 421# 212# 0 0 0 0 0 0 0 0 41# 0 0 0 0 0 0 0 25# 0 0 22# 0 0
+(.NE. | 423 421 422# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ Dom.)v 424 422 423# 213# 143# 108# 87# 73# 63# 0 0 45# 0 38# 0 33# 31# 0 0 0 0 24# 23# 0 0 0
+ 425 423 424# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 426 424 425# 214# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 427 425 426# 0 144# 0 0 0 0 0 50# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 428 426 427# 215# 0 109# 0 0 0 56# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 429 427 428# 0 0 0 88# 0 0 0 0 0 0 0 0 0 0 0 28# 0 0 0 0 0 0 0
+ 430 428 429# 216# 145# 0 0 74# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 431 429 430# 0 0 0 0 0 64# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 432 430 431# 217# 0 110# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 433 431 432# 0 146# 0 0 0 0 0 0 0 42# 0 36# 0 0 0 0 0 0 0 0 0 0 0
+ 434 432 433# 218# 0 0 89# 0 0 0 0 46# 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 435 433 434# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 436 434 435# 219# 147# 111# 0 75# 0 57# 51# 0 0 39# 0 0 0 30# 0 27# 0 0 0 0 0 21#
+ 437 435 436# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 438 436 437# 220# 0 0 0 0 65# 0 0 0 0 0 0 34# 0 0 0 0 0 0 0 0 0 0
+ 439 437 438# 0 148# 0 90# 0 0 0 0 0 0 0 0 0 32# 0 0 0 0 0 0 0 0 0
+ 440 438 439# 221# 0 112# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ (1st,2nd,3rd) column = (mx in NSTdim.inc, mxtt in MAR_control.dat, mxx if NO subdomain)
+
+Nb Pts / Proc-1 (i.e., mxx), HALO = 2
+Nb Proc--> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
+Nb Pts| 441 439 440# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 26# 0 0 0 22# 0
+MARdim| 442 440 441# 222# 149# 0 0 76# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+(.NE. | 443 441 442# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ Dom.)v 444 442 443# 223# 0 113# 91# 0 0 58# 0 47# 43# 0 0 0 0 0 0 0 0 25# 0 23# 0 0
+ 445 443 444# 0 150# 0 0 0 66# 0 52# 0 0 0 0 0 0 0 0 0 0 0 24# 0 0 0
+ 446 444 445# 224# 0 0 0 0 0 0 0 0 0 0 37# 0 0 0 29# 0 0 0 0 0 0 0
+ 447 445 446# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 448 446 447# 225# 151# 114# 0 77# 0 0 0 0 0 40# 0 0 0 0 0 0 0 0 0 0 0 0
+ 449 447 448# 0 0 0 92# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 450 448 449# 226# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 451 449 450# 0 152# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 452 450 451# 227# 0 115# 0 0 67# 59# 0 0 0 0 0 35# 0 31# 0 0 0 0 0 0 0 0
+ 453 451 452# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 454 452 453# 228# 153# 0 93# 78# 0 0 53# 48# 0 0 0 0 33# 0 0 28# 0 0 0 0 0 0
+ 455 453 454# 0 0 0 0 0 0 0 0 0 44# 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 456 454 455# 229# 0 116# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 457 455 456# 0 154# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 458 456 457# 230# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 459 457 458# 0 0 0 94# 0 68# 0 0 0 0 0 38# 0 0 0 0 0 0 0 0 0 0 0
+ 460 458 459# 231# 155# 117# 0 79# 0 60# 0 0 0 41# 0 0 0 0 0 0 27# 0 0 0 0 22#
+ (1st,2nd,3rd) column = (mx in NSTdim.inc, mxtt in MAR_control.dat, mxx if NO subdomain)
+
+Nb Pts / Proc-1 (i.e., mxx), HALO = 2
+Nb Proc--> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
+Nb Pts| 461 459 460# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+MARdim| 462 460 461# 232# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+(.NE. | 463 461 462# 0 156# 0 0 0 0 0 54# 0 0 0 0 0 0 0 30# 0 0 0 0 0 0 0
+ Dom.)v 464 462 463# 233# 0 118# 95# 0 0 0 0 49# 0 0 0 0 0 0 0 0 0 26# 0 0 23# 0
+ 465 463 464# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 466 464 465# 234# 157# 0 0 80# 69# 0 0 0 45# 0 0 36# 0 0 0 0 0 0 25# 24# 0 0
+ 467 465 466# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 468 466 467# 235# 0 119# 0 0 0 61# 0 0 0 0 0 0 0 32# 0 0 0 0 0 0 0 0
+ 469 467 468# 0 158# 0 96# 0 0 0 0 0 0 0 0 0 34# 0 0 0 0 0 0 0 0 0
+ 470 468 469# 236# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 471 469 470# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 472 470 471# 237# 159# 120# 0 81# 0 0 55# 0 0 42# 39# 0 0 0 0 29# 0 0 0 0 0 0
+ 473 471 472# 0 0 0 0 0 70# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 474 472 473# 238# 0 0 97# 0 0 0 0 50# 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 475 473 474# 0 160# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 476 474 475# 239# 0 121# 0 0 0 62# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 477 475 476# 0 0 0 0 0 0 0 0 0 46# 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 478 476 477# 240# 161# 0 0 82# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 479 477 478# 0 0 0 98# 0 0 0 0 0 0 0 0 0 0 0 0 0 28# 0 0 0 0 0
+ 480 478 479# 241# 0 122# 0 0 71# 0 0 0 0 0 0 37# 0 0 31# 0 0 0 0 0 0 0
+ (1st,2nd,3rd) column = (mx in NSTdim.inc, mxtt in MAR_control.dat, mxx if NO subdomain)
+
+Nb Pts / Proc-1 (i.e., mxx), HALO = 2
+Nb Proc--> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
+Nb Pts| 481 479 480# 0 162# 0 0 0 0 0 56# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+MARdim| 482 480 481# 242# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+(.NE. | 483 481 482# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ Dom.)v 484 482 483# 243# 163# 123# 99# 83# 0 63# 0 51# 0 43# 0 0 35# 33# 0 0 0 27# 0 0 0 23#
+ 485 483 484# 0 0 0 0 0 0 0 0 0 0 0 40# 0 0 0 0 0 0 0 0 0 0 0
+ 486 484 485# 244# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 487 485 486# 0 164# 0 0 0 72# 0 0 0 0 0 0 0 0 0 0 0 0 0 26# 0 24# 0
+ 488 486 487# 245# 0 124# 0 0 0 0 0 0 47# 0 0 0 0 0 0 0 0 0 0 25# 0 0
+ 489 487 488# 0 0 0 100# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 490 488 489# 246# 165# 0 0 84# 0 0 57# 0 0 0 0 0 0 0 0 30# 0 0 0 0 0 0
+ 491 489 490# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 492 490 491# 247# 0 125# 0 0 0 64# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 493 491 492# 0 166# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 494 492 493# 248# 0 0 101# 0 73# 0 0 52# 0 0 0 38# 0 0 0 0 0 0 0 0 0 0
+ 495 493 494# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 496 494 495# 249# 167# 126# 0 85# 0 0 0 0 0 44# 0 0 0 0 0 0 0 0 0 0 0 0
+ 497 495 496# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 32# 0 0 0 0 0 0 0
+ 498 496 497# 250# 0 0 0 0 0 0 0 0 0 0 41# 0 0 0 0 0 29# 0 0 0 0 0
+ 499 497 498# 0 168# 0 102# 0 0 0 58# 0 48# 0 0 0 36# 0 0 0 0 0 0 0 0 0
+ 500 498 499# 251# 0 127# 0 0 0 65# 0 0 0 0 0 0 0 34# 0 0 0 0 0 0 0 0
+ (1st,2nd,3rd) column = (mx in NSTdim.inc, mxtt in MAR_control.dat, mxx if NO subdomain)
+
+Nb Pts / Proc-1 (i.e., mxx), HALO = 2
+Nb Proc--> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
+Nb Pts| 501 499 500# 0 0 0 0 0 74# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+MARdim| 502 500 501# 252# 169# 0 0 86# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+(.NE. | 503 501 502# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ Dom.)v 504 502 503# 253# 0 128# 103# 0 0 0 0 53# 0 0 0 0 0 0 0 0 0 28# 0 0 0 0
+ 505 503 504# 0 170# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 506 504 505# 254# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 507 505 506# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 508 506 507# 255# 171# 129# 0 87# 75# 66# 59# 0 0 45# 0 39# 0 0 0 31# 0 0 27# 0 0 24#
+ 509 507 508# 0 0 0 104# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 510 508 509# 256# 0 0 0 0 0 0 0 0 49# 0 0 0 0 0 0 0 0 0 0 26# 25# 0
+ 511 509 510# 0 172# 0 0 0 0 0 0 0 0 0 42# 0 0 0 0 0 0 0 0 0 0 0
+ 512 510 511# 257# 0 130# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 513 511 512# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 514 512 513# 258# 173# 0 105# 88# 0 0 0 54# 0 0 0 0 37# 0 33# 0 0 0 0 0 0 0
+ 515 513 514# 0 0 0 0 0 76# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 516 514 515# 259# 0 131# 0 0 0 67# 0 0 0 0 0 0 0 35# 0 0 0 0 0 0 0 0
+ 517 515 516# 0 174# 0 0 0 0 0 60# 0 0 0 0 0 0 0 0 0 30# 0 0 0 0 0
+ 518 516 517# 260# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 519 517 518# 0 0 0 106# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 520 518 519# 261# 175# 132# 0 89# 0 0 0 0 0 46# 0 0 0 0 0 0 0 0 0 0 0 0
+ (1st,2nd,3rd) column = (mx in NSTdim.inc, mxtt in MAR_control.dat, mxx if NO subdomain)
+
+Nb Pts / Proc-1 (i.e., mxx), HALO = 2
+Nb Proc--> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
+Nb Pts| 521 519 520# 0 0 0 0 0 0 0 0 0 50# 0 0 0 0 0 0 0 0 0 0 0 0 0
+MARdim| 522 520 521# 262# 0 0 0 0 77# 0 0 0 0 0 0 40# 0 0 0 0 0 0 0 0 0 0
+(.NE. | 523 521 522# 0 176# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ Dom.)v 524 522 523# 263# 0 133# 107# 0 0 68# 0 55# 0 0 43# 0 0 0 0 0 0 29# 0 0 0 0
+ 525 523 524# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 526 524 525# 264# 177# 0 0 90# 0 0 61# 0 0 0 0 0 0 0 0 32# 0 0 0 0 0 0
+ 527 525 526# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 528 526 527# 265# 0 134# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 529 527 528# 0 178# 0 108# 0 78# 0 0 0 0 0 0 0 38# 0 0 0 0 0 28# 0 0 0
+ 530 528 529# 266# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 531 529 530# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 34# 0 0 0 0 0 0 0
+ 532 530 531# 267# 179# 135# 0 91# 0 69# 0 0 51# 47# 0 0 0 36# 0 0 0 0 0 27# 0 25#
+ 533 531 532# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 26# 0
+ 534 532 533# 268# 0 0 109# 0 0 0 0 56# 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 535 533 534# 0 180# 0 0 0 0 0 62# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 536 534 535# 269# 0 136# 0 0 79# 0 0 0 0 0 0 41# 0 0 0 0 31# 0 0 0 0 0
+ 537 535 536# 0 0 0 0 0 0 0 0 0 0 0 44# 0 0 0 0 0 0 0 0 0 0 0
+ 538 536 537# 270# 181# 0 0 92# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 539 537 538# 0 0 0 110# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 540 538 539# 271# 0 137# 0 0 0 70# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ (1st,2nd,3rd) column = (mx in NSTdim.inc, mxtt in MAR_control.dat, mxx if NO subdomain)
+
+Nb Pts / Proc-1 (i.e., mxx), HALO = 2
+Nb Proc--> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
+Nb Pts| 541 539 540# 0 182# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+MARdim| 542 540 541# 272# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+(.NE. | 543 541 542# 0 0 0 0 0 80# 0 0 0 52# 0 0 0 0 0 0 0 0 0 0 0 0 0
+ Dom.)v 544 542 543# 273# 183# 138# 111# 93# 0 0 63# 57# 0 48# 0 0 39# 0 0 33# 0 30# 0 0 0 0
+ 545 543 544# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 546 544 545# 274# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 547 545 546# 0 184# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 548 546 547# 275# 0 139# 0 0 0 71# 0 0 0 0 0 0 0 37# 35# 0 0 0 0 0 0 0
+ 549 547 548# 0 0 0 112# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 550 548 549# 276# 185# 0 0 94# 81# 0 0 0 0 0 45# 42# 0 0 0 0 0 0 29# 0 0 0
+ 551 549 550# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 552 550 551# 277# 0 140# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 553 551 552# 0 186# 0 0 0 0 0 64# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 554 552 553# 278# 0 0 113# 0 0 0 0 58# 53# 0 0 0 0 0 0 0 0 0 0 28# 0 0
+ 555 553 554# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 32# 0 0 0 0 0
+ 556 554 555# 279# 187# 141# 0 95# 0 72# 0 0 0 49# 0 0 0 0 0 0 0 0 0 0 27# 26#
+ 557 555 556# 0 0 0 0 0 82# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 558 556 557# 280# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 559 557 558# 0 188# 0 114# 0 0 0 0 0 0 0 0 0 40# 0 0 0 0 0 0 0 0 0
+ 560 558 559# 281# 0 142# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ (1st,2nd,3rd) column = (mx in NSTdim.inc, mxtt in MAR_control.dat, mxx if NO subdomain)
+
+Nb Pts / Proc-1 (i.e., mxx), HALO = 2
+Nb Proc--> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
+Nb Pts| 561 559 560# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+MARdim| 562 560 561# 282# 189# 0 0 96# 0 0 65# 0 0 0 0 0 0 0 0 34# 0 0 0 0 0 0
+(.NE. | 563 561 562# 0 0 0 0 0 0 0 0 0 0 0 46# 0 0 0 0 0 0 0 0 0 0 0
+ Dom.)v 564 562 563# 283# 0 143# 115# 0 83# 73# 0 59# 0 0 0 43# 0 38# 0 0 0 31# 0 0 0 0
+ 565 563 564# 0 190# 0 0 0 0 0 0 0 54# 0 0 0 0 0 36# 0 0 0 0 0 0 0
+ 566 564 565# 284# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 567 565 566# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 568 566 567# 285# 191# 144# 0 97# 0 0 0 0 0 50# 0 0 0 0 0 0 0 0 0 0 0 0
+ 569 567 568# 0 0 0 116# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 570 568 569# 286# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 571 569 570# 0 192# 0 0 0 84# 0 66# 0 0 0 0 0 0 0 0 0 0 0 30# 0 0 0
+ 572 570 571# 287# 0 145# 0 0 0 74# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 573 571 572# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 574 572 573# 288# 193# 0 117# 98# 0 0 0 60# 0 0 0 0 41# 0 0 0 33# 0 0 0 0 0
+ 575 573 574# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 576 574 575# 289# 0 146# 0 0 0 0 0 0 55# 0 47# 0 0 0 0 0 0 0 0 29# 0 0
+ 577 575 576# 0 194# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 578 576 577# 290# 0 0 0 0 85# 0 0 0 0 0 0 44# 0 0 0 0 0 0 0 0 0 0
+ 579 577 578# 0 0 0 118# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 28# 0
+ 580 578 579# 291# 195# 147# 0 99# 0 75# 67# 0 0 51# 0 0 0 39# 0 35# 0 0 0 0 0 27#
+ (1st,2nd,3rd) column = (mx in NSTdim.inc, mxtt in MAR_control.dat, mxx if NO subdomain)
+
+Nb Pts / Proc-1 (i.e., mxx), HALO = 2
+Nb Proc--> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
+Nb Pts| 581 579 580# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+MARdim| 582 580 581# 292# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 37# 0 0 0 0 0 0 0
+(.NE. | 583 581 582# 0 196# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ Dom.)v 584 582 583# 293# 0 148# 119# 0 0 0 0 61# 0 0 0 0 0 0 0 0 0 32# 0 0 0 0
+ 585 583 584# 0 0 0 0 0 86# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 586 584 585# 294# 197# 0 0 100# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 587 585 586# 0 0 0 0 0 0 0 0 0 56# 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 588 586 587# 295# 0 149# 0 0 0 76# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 589 587 588# 0 198# 0 120# 0 0 0 68# 0 0 0 48# 0 42# 0 0 0 0 0 0 0 0 0
+ 590 588 589# 296# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 591 589 590# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 592 590 591# 297# 199# 150# 0 101# 87# 0 0 0 0 52# 0 45# 0 0 0 0 0 0 31# 0 0 0
+ 593 591 592# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 34# 0 0 0 0 0
+ 594 592 593# 298# 0 0 121# 0 0 0 0 62# 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 595 593 594# 0 200# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 596 594 595# 299# 0 151# 0 0 0 77# 0 0 0 0 0 0 0 40# 0 0 0 0 0 0 0 0
+ 597 595 596# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 598 596 597# 300# 201# 0 0 102# 0 0 69# 0 57# 0 0 0 0 0 0 36# 0 0 0 30# 0 0
+ 599 597 598# 0 0 0 122# 0 88# 0 0 0 0 0 0 0 0 0 38# 0 0 0 0 0 0 0
+ 600 598 599# 301# 0 152# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ (1st,2nd,3rd) column = (mx in NSTdim.inc, mxtt in MAR_control.dat, mxx if NO subdomain)
+
+Nb Pts / Proc-1 (i.e., mxx), HALO = 2
+Nb Proc--> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
+Nb Pts| 601 599 600# 0 202# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+MARdim| 602 600 601# 302# 0 0 0 0 0 0 0 0 0 0 49# 0 0 0 0 0 0 0 0 0 29# 0
+(.NE. | 603 601 602# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ Dom.)v 604 602 603# 303# 203# 153# 123# 103# 0 78# 0 63# 0 53# 0 0 43# 0 0 0 0 33# 0 0 0 28#
+ 605 603 604# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 606 604 605# 304# 0 0 0 0 89# 0 0 0 0 0 0 46# 0 0 0 0 0 0 0 0 0 0
+ 607 605 606# 0 204# 0 0 0 0 0 70# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 608 606 607# 305# 0 154# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 609 607 608# 0 0 0 124# 0 0 0 0 0 58# 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 610 608 609# 306# 205# 0 0 104# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 611 609 610# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 612 610 611# 307# 0 155# 0 0 0 79# 0 0 0 0 0 0 0 41# 0 0 35# 0 0 0 0 0
+ 613 611 612# 0 206# 0 0 0 90# 0 0 0 0 0 0 0 0 0 0 0 0 0 32# 0 0 0
+ 614 612 613# 308# 0 0 125# 0 0 0 0 64# 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 615 613 614# 0 0 0 0 0 0 0 0 0 0 0 50# 0 0 0 0 0 0 0 0 0 0 0
+ 616 614 615# 309# 207# 156# 0 105# 0 0 71# 0 0 54# 0 0 0 0 39# 37# 0 0 0 0 0 0
+ 617 615 616# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 618 616 617# 310# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 619 617 618# 0 208# 0 126# 0 0 0 0 0 0 0 0 0 44# 0 0 0 0 0 0 0 0 0
+ 620 618 619# 311# 0 157# 0 0 91# 80# 0 0 59# 0 0 47# 0 0 0 0 0 0 0 31# 0 0
+ (1st,2nd,3rd) column = (mx in NSTdim.inc, mxtt in MAR_control.dat, mxx if NO subdomain)
+
+Nb Pts / Proc-1 (i.e., mxx), HALO = 2
+Nb Proc--> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
+Nb Pts| 621 619 620# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+MARdim| 622 620 621# 312# 209# 0 0 106# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+(.NE. | 623 621 622# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ Dom.)v 624 622 623# 313# 0 158# 127# 0 0 0 0 65# 0 0 0 0 0 0 0 0 0 34# 0 0 0 0
+ 625 623 624# 0 210# 0 0 0 0 0 72# 0 0 0 0 0 0 0 0 0 0 0 0 0 30# 0
+ 626 624 625# 314# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 627 625 626# 0 0 0 0 0 92# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 628 626 627# 315# 211# 159# 0 107# 0 81# 0 0 0 55# 51# 0 0 42# 0 0 0 0 0 0 0 29#
+ 629 627 628# 0 0 0 128# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 630 628 629# 316# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 631 629 630# 0 212# 0 0 0 0 0 0 0 60# 0 0 0 0 0 0 0 36# 0 0 0 0 0
+ 632 630 631# 317# 0 160# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 633 631 632# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 40# 0 0 0 0 0 0 0
+ 634 632 633# 318# 213# 0 129# 108# 93# 0 73# 66# 0 0 0 48# 45# 0 0 38# 0 0 33# 0 0 0
+ 635 633 634# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 636 634 635# 319# 0 161# 0 0 0 82# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 637 635 636# 0 214# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 638 636 637# 320# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 639 637 638# 0 0 0 130# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 640 638 639# 321# 215# 162# 0 109# 0 0 0 0 0 56# 0 0 0 0 0 0 0 0 0 0 0 0
+ (1st,2nd,3rd) column = (mx in NSTdim.inc, mxtt in MAR_control.dat, mxx if NO subdomain)
+
+Nb Pts / Proc-1 (i.e., mxx), HALO = 2
+Nb Proc--> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
+Nb Pts| 641 639 640# 0 0 0 0 0 94# 0 0 0 0 0 52# 0 0 0 0 0 0 0 0 0 0 0
+MARdim| 642 640 641# 322# 0 0 0 0 0 0 0 0 61# 0 0 0 0 0 0 0 0 0 0 32# 0 0
+(.NE. | 643 641 642# 0 216# 0 0 0 0 0 74# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ Dom.)v 644 642 643# 323# 0 163# 131# 0 0 83# 0 67# 0 0 0 0 0 43# 0 0 0 35# 0 0 0 0
+ 645 643 644# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 646 644 645# 324# 217# 0 0 110# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 647 645 646# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 648 646 647# 325# 0 164# 0 0 95# 0 0 0 0 0 0 49# 0 0 0 0 0 0 0 0 31# 0
+ 649 647 648# 0 218# 0 132# 0 0 0 0 0 0 0 0 0 46# 0 0 0 0 0 0 0 0 0
+ 650 648 649# 326# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 41# 0 37# 0 0 0 0 0
+ 651 649 650# 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
diff --git a/MAR/code_nestor/Nb_Proc_PERMIS/Nb_Proc_PERMIS.f90 b/MAR/code_nestor/Nb_Proc_PERMIS/Nb_Proc_PERMIS.f90
new file mode 100644
index 0000000000000000000000000000000000000000..10f6c3ea0d0b0cb706c6310d7d2d85336e327ea2
--- /dev/null
+++ b/MAR/code_nestor/Nb_Proc_PERMIS/Nb_Proc_PERMIS.f90
@@ -0,0 +1,69 @@
+ program Nb_Proc_PERMIS
+
+!------------------------------------------------------------------------------+
+! |
+! Nb_Proc_PERMIS: marp: Table des Processeurs autorises |
+! mxtt is prescribed in MAR_control.dat |
+! mxxtt = mxtt+1 is the nb of points along the x-axis, minus 1 |
+! mxxtt+1 is the nb of points along the x-axis, |
+! is prescribed in NSTdim.inc |
+! |
+!------------------------------------------------------------------------------+
+
+ integer :: mxxtt
+ integer :: nb_pr
+ integer :: nbrOx = 2
+ integer :: mxxt
+ integer :: mxx
+ character(len=1) :: ch
+
+ WRITE(*,6)nbrOx,(nb_pr,nb_pr=1,24)
+ 6 format(/,'Nb Pts / Proc-1 (i.e., mxx), HALO =',i2, &
+ & /,'Nb Proc--> ', 25i5)
+ DO mxxtt = 11,650
+ IF (mod(mxxtt,20).EQ.0) THEN
+ WRITE(*,7)
+ 7 FORMAT(8x,'(1st,2nd,3rd) column = (mx in NSTdim.inc,' &
+ & ,' mxtt in MAR_control.dat, mxx if NO subdomain)')
+ WRITE(*,6)nbrOx,(nb_pr,nb_pr=1,24)
+ END IF
+
+ IF (mod(mxxtt,20).EQ.0) THEN
+ WRITE(*,1) mxxtt+1,mxxtt-1
+ 1 format('Nb Pts|',2i4,$)
+ ELSE IF (mod(mxxtt,20).EQ.1) THEN
+ WRITE(*,2) mxxtt+1,mxxtt-1
+ 2 format('MARdim|',2i4,$)
+ ELSE IF (mod(mxxtt,20).EQ.2) THEN
+ WRITE(*,3) mxxtt+1,mxxtt-1
+ 3 format('(.NE. |',2i4,$)
+ ELSE IF (mod(mxxtt,20).EQ.3) THEN
+ WRITE(*,4) mxxtt+1,mxxtt-1
+ 4 format(' Dom.)v',2i4,$)
+ ELSE
+ WRITE(*,5) mxxtt+1,mxxtt-1
+ 5 format(' ',2i4,$)
+ END IF
+
+ DO nb_pr = 1,24
+ i = mod(mxxtt+1-2*nbrOx ,nb_pr)
+ mxxt = mxxtt - mod(mxxtt+1-2*nbrOx ,nb_pr)
+ mxt = mxxt - 1
+ mxx = ((mxxt + 1 -2*nbrOx)/nb_pr)+2*nbrOx-1
+ IF (i .EQ. 0 .AND. mxx .GT. 7) THEN
+ mxxt = mxxtt - mod(mxxtt+1-2*nbrOx ,nb_pr)
+ mxt = mxxt - 1
+ mxx = ((mxxt + 1 -2*nbrOx)/nb_pr)+2*nbrOx-1
+ ch = '#'
+ ELSE
+ mxxt = 0
+ mxx = 0
+ ch = ' '
+ END IF
+ WRITE(*,10)mxx,ch
+ 10 format(i4,a1,$)
+ ENDDO
+ WRITE(*,*) " "
+ ENDDO
+
+ END
diff --git a/MAR/code_nestor/Nb_Proc_PERMIS/Nb_Proc_PERMIS.sh b/MAR/code_nestor/Nb_Proc_PERMIS/Nb_Proc_PERMIS.sh
new file mode 100644
index 0000000000000000000000000000000000000000..fb41ef126a11d78410ff30928a30035446fbc785
--- /dev/null
+++ b/MAR/code_nestor/Nb_Proc_PERMIS/Nb_Proc_PERMIS.sh
@@ -0,0 +1,6 @@
+gfortran -o Nb_Proc_PERMIS Nb_Proc_PERMIS.f90
+ ./Nb_Proc_PERMIS > Nb_Proc_PERMIS.OUT
+rm Nb_Proc_PERMIS
+TOUCH Nb_Proc_PERMIS.f90
+TOUCH Nb_Proc_PERMIS.OUT
+
diff --git a/MAR/code_nestor/doc/NESTOR-doc.doc b/MAR/code_nestor/doc/NESTOR-doc.doc
new file mode 100644
index 0000000000000000000000000000000000000000..82051ede5455b728a2c3b1804ccbde5f4c1ccdd9
Binary files /dev/null and b/MAR/code_nestor/doc/NESTOR-doc.doc differ
diff --git a/MAR/code_nestor/doc/NESTOR-doc.pdf b/MAR/code_nestor/doc/NESTOR-doc.pdf
new file mode 100644
index 0000000000000000000000000000000000000000..5855794085977cb3d7b7f95d10404d421bbd65fe
Binary files /dev/null and b/MAR/code_nestor/doc/NESTOR-doc.pdf differ
diff --git a/MAR/code_nestor/doc/NESTOR-doc.sxw b/MAR/code_nestor/doc/NESTOR-doc.sxw
new file mode 100644
index 0000000000000000000000000000000000000000..7387ae01f9091b6efcb025f47f8b953e53763753
Binary files /dev/null and b/MAR/code_nestor/doc/NESTOR-doc.sxw differ
diff --git a/MAR/code_nestor/input/FAO/TEXUNIT.ASC b/MAR/code_nestor/input/FAO/TEXUNIT.ASC
new file mode 100644
index 0000000000000000000000000000000000000000..495b293002742c477605625a62e293338d052a51
Binary files /dev/null and b/MAR/code_nestor/input/FAO/TEXUNIT.ASC differ
diff --git a/MAR/code_nestor/input/GTOPO/File_List b/MAR/code_nestor/input/GTOPO/File_List
new file mode 100644
index 0000000000000000000000000000000000000000..b86b81629deef7322f396f457e01976497f21686
--- /dev/null
+++ b/MAR/code_nestor/input/GTOPO/File_List
@@ -0,0 +1,39 @@
+ CHARACTERISTICS OF GTOPO_30 FILES
+ *********************************
+
+Filename Long.MIN Long.MAX Lat.MIN Lat.MAX Nb. rows Nb. cols
+======== ======== ======== ======= ======= ======== ========
+
+W180N90 -180 -140 40 90 6000 4800
+W140N90 -140 -100 40 90 6000 4800
+W100N90 -100 -60 40 90 6000 4800
+W060N90 -60 -20 40 90 6000 4800
+W020N90 -20 20 40 90 6000 4800
+E020N90 20 60 40 90 6000 4800
+E060N90 60 100 40 90 6000 4800
+E100N90 100 140 40 90 6000 4800
+E140N90 140 180 40 90 6000 4800
+W180N40 -180 -140 -10 40 6000 4800
+W140N40 -140 -100 -10 40 6000 4800
+W100N40 -100 -60 -10 40 6000 4800
+W060N40 -60 -20 -10 40 6000 4800
+W020N40 -20 20 -10 40 6000 4800
+E020N40 20 60 -10 40 6000 4800
+E060N40 60 100 -10 40 6000 4800
+E100N40 100 140 -10 40 6000 4800
+E140N40 140 180 -10 40 6000 4800
+W180S10 -180 -140 -60 -10 6000 4800
+W140S10 -140 -100 -60 -10 6000 4800
+W100S10 -100 -60 -60 -10 6000 4800
+W060S10 -60 -20 -60 -10 6000 4800
+W020S10 -20 20 -60 -10 6000 4800
+E020S10 20 60 -60 -10 6000 4800
+E060S10 60 100 -60 -10 6000 4800
+E100S10 100 140 -60 -10 6000 4800
+E140S10 140 180 -60 -10 6000 4800
+W180S60 -180 -120 -90 -60 3600 7200
+W120S60 -120 -60 -90 -60 3600 7200
+W060S60 -60 0 -90 -60 3600 7200
+W000S60 0 60 -90 -60 3600 7200
+E060S60 60 120 -90 -60 3600 7200
+E120S60 120 180 -90 -60 3600 7200
diff --git a/MAR/code_nestor/input/SOIL/AFRmax-alb.nc b/MAR/code_nestor/input/SOIL/AFRmax-alb.nc
new file mode 100644
index 0000000000000000000000000000000000000000..a696d76fea40e6128a8c2efedcbe3e46f5abc922
Binary files /dev/null and b/MAR/code_nestor/input/SOIL/AFRmax-alb.nc differ
diff --git a/MAR/code_nestor/input/SOIL/GSWP-SOIL.nc b/MAR/code_nestor/input/SOIL/GSWP-SOIL.nc
new file mode 100644
index 0000000000000000000000000000000000000000..40aa628da49e23620bf7ae5ded6765891a37b88c
Binary files /dev/null and b/MAR/code_nestor/input/SOIL/GSWP-SOIL.nc differ
diff --git a/MAR/code_nestor/src/AWSgeo.f b/MAR/code_nestor/src/AWSgeo.f
new file mode 100644
index 0000000000000000000000000000000000000000..741360bb48c7f13e78c33e0c46ae85038b39ba4c
--- /dev/null
+++ b/MAR/code_nestor/src/AWSgeo.f
@@ -0,0 +1,701 @@
+ subroutine AWSgeo(x__MAR,y__MAR)
+
+C +----------------------------------------------------------------------------+
+C | |
+C | MAR OUTPUT Generic Routine 10-06-2008 MAR |
+C | condition on next closest MAR Grid Point modified 29-04-2010 |
+C +----------------------------------------------------------------------------+
+
+ IMPLICIT NONE
+
+ INCLUDE 'NSTdim.inc'
+ INCLUDE 'NSTvar.inc'
+ INCLUDE 'for2cdf.inc'
+
+ REAL x__MAR(mx,my),y__MAR(mx,my) ! MAR coordinate
+ ! on RAMP DEM
+ REAL earthr
+ REAL pi ,degrad
+ REAL x__AWS ,y__AWS
+ REAL ddista ,dd_min
+ REAL d__lon ,d__lat
+ REAL dlomin ,dlamin
+ REAL dlosgn ,dlasgn
+ INTEGER i ,j ,idx
+ INTEGER i__min ,j__min
+ INTEGER ilomin ,jlomin
+ INTEGER ilamin ,jlamin
+
+ INTEGER i0,j0,i1,j1,i2,j2,i3,j3
+ REAL INT_la_1 ,INT_la_2
+ REAL AWSgdx_1 ,AWSgdx_2
+ REAL AWSgdy_1 ,AWSgdy_2
+
+ integer n_AWS
+ parameter (n_AWS=279)
+ integer nnAWS, n
+ integer AWSio(n_AWS),AWS_i(n_AWS),AWS_j(n_AWS)
+ REAL AWSla(n_AWS),AWSlo(n_AWS),AWS_z(n_AWS)
+ REAL AWS_x(n_AWS),AWS_y(n_AWS)
+ character*6 AWS_0(n_AWS)
+ character*6 AWS_0_n
+ character*8 AWS_1(n_AWS),AWS_2(n_AWS)
+ character*19 filtxt
+
+ common /AWS_nc_INT/AWSio ,AWS_i ,AWS_j
+ . ,nnAWS
+ common /AWS_nc_REA/AWSla ,AWSlo ,AWS_z
+ common /AWS_nc_CH6/AWS_0
+ common /AWS_nc_CH8/ AWS_1 ,AWS_2
+
+
+C + INITIALIZATION
+C + ==============
+
+ DATA earthr/6396.990e3/ ! Earth Radius
+
+ pi = acos( -1.0d0)
+ degrad = pi / 180.0d0
+ idx = NST_dx*1.e-3
+
+
+C + OUTPUT FILE
+C + ===========
+
+ filtxt = 'RAntMP_1_km_DEM.JNL'
+ open (unit=1,status='unknown',file=filtxt)
+ ! 1234567890123456789
+ rewind 1
+
+ filtxt = 'MARdom_20km_DEM.JNL'
+ write(filtxt(8:9),'(i2)') idx
+ IF (filtxt(8:8).EQ.' ') filtxt( 8: 8) = '_'
+ open (unit=2,status='unknown',file=filtxt)
+ rewind 2
+ filtxt(17:19) = 'txt'
+ open (unit=3,status='unknown',file=filtxt)
+ rewind 3
+ write(3,30)
+ 30 format('AWS Station | Latit. | Longit.|'
+ . , ' x [km] | y [km] | Altit.||'
+ . , ' Grid pt.| x [km] | y [km] |'
+ . , ' Latit. | Longit.| Altit.||'
+ . , ' D(AWS)|')
+ write(3,32)
+ 32 format('-----------------------+--------+--------+'
+ . , '--------+--------+-------++'
+ . , '---------+--------+--------+'
+ . , '--------+--------+-------++'
+ . , '-------+')
+
+ write(6,61)
+ 61 format(/,' AWSgeo: OUTPUT File RAntMP/MARdom*km_DEM.JNL IN')
+
+ DO n=1,n_AWS
+ IF (AWSio(n).GE.1) THEN
+
+
+C + Search AWS coordinates in MAR Grid
+C + ==================================
+
+C + RAMP/DEM coordinates of the AWS
+C + -------------------------------
+
+ ddista = earthr *(sin( 71.d0 *degrad) + 1.d0)
+ . * tan((45.d0+AWSla(n)*0.5d0)*degrad)
+ x__AWS = ddista * cos((90.d0-AWSlo(n)) *degrad)
+ y__AWS = ddista * sin((90.d0-AWSlo(n)) *degrad)
+
+
+C + Indices of the closest MAR Grid Point
+C + ------------------------------------------
+
+ dd_min = 1.e6
+ i__min = 0
+ j__min = 0
+ DO j=1,my
+ DO i=1,mx
+ ddista =sqrt((x__AWS-x__MAR(i,j))*(x__AWS-x__MAR(i,j))
+ . +(y__AWS-y__MAR(i,j))*(y__AWS-y__MAR(i,j)))
+ IF (ddista.LT.dd_min) THEN
+ dd_min = ddista
+ i__min = i
+ j__min = j
+ ENDIF
+ ENDDO
+ ENDDO
+
+
+C + Indices of the next closest MAR Grid Point (Longitude)
+C + ------------------------------------------------------
+
+ IF ((i__min.GT. 1.AND.j__min.GT. 1)
+ . .AND.(i__min.LT.mx.AND.j__min.LT.my)) THEN
+ IF (AWSlo(n)-NST__x(i__min,j__min) .GT. 0.0) THEN
+ dlosgn = 1.0
+ ELSE
+ dlosgn = -1.0
+ END IF
+
+ dlomin = 1.e6
+ DO j=j__min-1,j__min+1
+ DO i=i__min-1,i__min+1
+ d__lon = AWSlo(n)-NST__x(i ,j )
+ IF (d__lon * dlosgn .LT. 0.0 .AND.
+ . abs(d__lon) .LT. dlomin) THEN
+ dlomin = abs(d__lon)
+ ilomin = i -i__min
+ jlomin = j -j__min
+ ENDIF
+ ENDDO
+ ENDDO
+
+
+C + Indices of the next closest MAR Grid Point (Latitude)
+C + ------------------------------------------------------
+
+ IF (AWSla(n)-NST__y(i__min,j__min) .GT. 0.0) THEN
+ dlasgn = 1.0
+ ELSE
+ dlasgn = -1.0
+ END IF
+
+ dlamin = 1.e6
+ DO j=j__min-1,j__min+1
+ DO i=i__min-1,i__min+1
+ d__lat = AWSla(n)-NST__y(i ,j )
+ IF (d__lat * dlasgn .LT. 0.0 .AND.
+ . abs(d__lat) .LT. dlamin) THEN
+ dlamin = abs(d__lat)
+ ilamin = i -i__min
+ jlamin = j -j__min
+ ENDIF
+ ENDDO
+ ENDDO
+
+C + Bilinear Interpolation
+C + ----------------------
+
+ i0 = i__min
+ j0 = j__min
+ i1 = i__min+ilomin
+ j1 = j__min+jlomin
+ i2 = i__min +ilamin
+ j2 = j__min +jlamin
+ i3 = i__min+ilomin+ilamin
+ j3 = j__min+jlomin+jlamin
+
+C + 1st Line of Longitudes: AWSlo between NST__x(i__min ,j__min ) &
+C + ~~~~~~~~~~~~~~~~~~~~~~ NST__x(i__min+ilomin,j__min+jlomin)
+ ! ==> NST_la_1
+ ! & NSTgdx_1
+ ! & NSTgdy_1
+
+ INT_la_1 = NST__y(i0,j0) +( AWSlo(n) -NST__x(i0,j0))
+ . *(NST__y(i1,j1)-NST__y(i0,j0))
+ . /(NST__x(i1,j1)-NST__x(i0,j0))
+
+ AWSgdx_1 = NSTgdx(i0 ) +( AWSlo(n) -NST__x(i0,j0))
+ . *(NSTgdx(i1 )-NSTgdx(i0 ))
+ . /(NST__x(i1,j1)-NST__x(i0,j0))
+
+ AWSgdy_1 = NSTgdy( j0) +( AWSlo(n) -NST__x(i0,j0))
+ . *(NSTgdy( j1)-NSTgdy( j0))
+ . /(NST__x(i1,j1)-NST__x(i0,j0))
+
+
+C + 2nd Line of Longitudes: AWSlo between NST__x(i__min+ilamin,j__min+jlamin) &
+C + ~~~~~~~~~~~~~~~~~~~~~~ NST__x(i__min+ilomin,j__min+jlomin)
+ ! +ilamin +jlamin
+ ! ==> NST_la_2
+ ! & NSTgdx_2
+ ! & NSTgdy_2
+
+ INT_la_2 = NST__y(i2,j2) +( AWSlo(n) -NST__x(i2,j2))
+ . *(NST__y(i3,j3)-NST__y(i2,j2))
+ . /(NST__x(i3,j3)-NST__x(i2,j2))
+
+ AWSgdx_2 = NSTgdx(i2 ) +( AWSlo(n) -NST__x(i2,j2))
+ . *(NSTgdx(i3 )-NSTgdx(i2 ))
+ . /(NST__x(i3,j3)-NST__x(i2,j2))
+
+ AWSgdy_2 = NSTgdy( j2) +( AWSlo(n) -NST__x(i2,j2))
+ . *(NSTgdy( j3)-NSTgdy( j2))
+ . /(NST__x(i3,j3)-NST__x(i2,j2))
+
+C + Line of Latitudes: AWSla between NST_la_1 & NST_la_2 ==> NSTgdx,NSTgdy
+C + ~~~~~~~~~~~~~~~~~~
+ AWS_x(n) = AWSgdx_1 +( AWSla(n) -INT_la_1)
+ . *(AWSgdx_2 -AWSgdx_1)
+ . /(INT_la_2 -INT_la_1)
+
+ AWS_y(n) = AWSgdy_1 +( AWSla(n) -INT_la_1)
+ . *(AWSgdy_2 -AWSgdy_1)
+ . /(INT_la_2 -INT_la_1)
+
+C + OUTPUT
+C + ------
+
+ IF (AWS_x(n) .GE. NSTgdx(1) .AND. AWS_x(n) .LE. NSTgdx(mx) .AND.
+ . AWS_y(n) .GE. NSTgdy(1) .AND. AWS_y(n) .LE. NSTgdy(my)) THEN
+ IF(AWSio(n) .EQ. 2)
+ . write(6,66) AWS_0(n)
+ . ,AWSlo(n), i0 ,j0
+ . ,NST__x(i0 ,j0 )
+ . ,i0,ilomin,j0,jlomin
+ . ,NST__x(i1 ,j1 ),AWS_x(n)
+ . ,AWSla(n), i0 ,j0
+ . ,NST__y(i0 ,j0 )
+ . ,i0,ilamin,j0,jlamin
+ . ,NST__y(i2 ,j2 ),AWS_y(n)
+ 66 format(a6,' Lon(AWS) =',f9.4,3x,'Lon(', i3,',', i3,') =',f9.4
+ . ,3x,'Lon(',2i3,',',2i3,') =',f9.4
+ . ,3x,' x =' ,f10.4
+ . /,6x,' Lat(AWS) =',f9.4,3x,'Lat(', i3,',', i3,') =',f9.4
+ . ,3x,'Lat(',2i3,',',2i3,') =',f9.4
+ . ,3x,' y =' ,f10.4)
+
+ AWS_0_n= AWS_0(n)
+ IF (AWS_0_n(1:3).EQ.'B__') THEN
+ write(1,20) x__AWS *1.e-3
+ . , y__AWS *1.e-3
+ ELSE
+ write(1,21) x__AWS *1.e-3
+ . , y__AWS *1.e-3
+ . , AWS_0(n)
+ . , x__AWS *1.e-3
+ . , y__AWS *1.e-3
+ . , NSTgdx(i0 )
+ . , NSTgdy( j0)
+ END IF
+
+ IF (AWS_0_n(1:3).EQ.'B__') THEN
+ write(2,20) AWS_x(n)
+ . , AWS_y(n)
+ 20 format('LABEL ',2(f8.2,','),' 0,0,.07 @P6.' )
+ ELSE
+ write(2,21) AWS_x(n)
+ . , AWS_y(n)
+ . , AWS_0(n)
+ . , AWS_x(n)
+ . , AWS_y(n)
+ . , NSTgdx(i0 )
+ . , NSTgdy( j0)
+ 21 format('LABEL ',2(f8.2,','),'-1,0,.07 \\',1x,a6
+ . ,/,'LABEL ',2(f8.2,','),' 0,0,.12 @P7x'
+ . ,/,'LABEL ',2(f8.2,','),' 0,0,.15 @P5.'
+ . )
+ END IF
+
+ write(3,31) AWS_0(n)
+ . ,AWS_1(n) ,AWS_2(n)
+ . ,AWSla(n) ,AWSlo(n)
+ . ,AWS_x(n) ,AWS_y(n)
+ . ,AWS_z(n)
+ . , i__min,j__min
+ . ,NSTgdx(i__min )
+ . ,NSTgdy( j__min)
+ . ,NST__y(i__min,j__min)
+ . ,NST__x(i__min,j__min)
+ . ,NST_sh(i__min,j__min), 1.e-3*dd_min
+ 31 format(a6,1x,2a8, '|',2(f7.2,' |'),2(f7.1,' |'),f6.0,' ||',
+ . 2i4,' |',2(f7.1,' |'),
+ . 2(f7.2,' |'), f6.0,' ||',f6.1,' |')
+ END IF
+ END IF
+ END IF
+ ENDDO
+
+ write(3,32)
+
+ close(unit=1)
+ close(unit=2)
+ close(unit=3)
+
+ write(6,60)
+ 60 format( ' AWSgeo: OUTPUT File RAntMP/MARdom*km_DEM.JNL OUT')
+
+ return
+ end
+
+ block data AWS_nc_DATA
+
+C +----------------------------------------------------------------------------+
+C | |
+C | MAR OUTPUT Generic Routine 17-09-2007 MAR |
+C | Manned and Automatic Weather Stations (AWS) Geographic Coordinates |
+C | |
+C +----------------------------------------------------------------------------+
+
+
+C +--General Variables
+C + =================
+
+ integer n_AWS, n
+ parameter (n_AWS=279)
+ integer AWSio(n_AWS),AWS_i(n_AWS),AWS_j(n_AWS)
+ integer nnAWS
+ REAL AWSla(n_AWS),AWSlo(n_AWS),AWS_z(n_AWS)
+ character*6 AWS_0(n_AWS)
+ character*8 AWS_1(n_AWS),AWS_2(n_AWS)
+
+ common /AWS_nc_INT/AWSio ,AWS_i ,AWS_j
+ . ,nnAWS
+ common /AWS_nc_REA/AWSla ,AWSlo ,AWS_z
+ common /AWS_nc_CH6/AWS_0
+ common /AWS_nc_CH8/ AWS_1 ,AWS_2
+
+
+C +--DATA
+C + ====
+
+C +--ANT
+C + ---
+
+ data (AWS_0(n),AWS_1(n),AWS_2(n)
+ . ,AWSla(n),AWSlo(n),AWS_z(n),AWSio(n),n=001,094)
+C +... LABel AWS LABELS Latit. Longit. Alti. PR
+C + 0 => No IO
+C + 1 => OUTone
+C + 2 => OUTone
+C + ASCII
+ . / 'CapSpe' ,'Cape Spe','ncer ', -77.97, 167.55, 30., 1, ! 1
+ . 'HerbA1' ,'Herbie A','lley ', -78.10, 166.67, 30., 1, ! 2
+ . 'Harry_' ,'Harry ',' ', -83.00,-121.39, 945., 1, ! 3
+ . 'CapBir' ,'Cape Bir','d ', -77.22, 166.44, 100., 1, ! 4
+ . 'Butler' ,'Butler I','sland ', -72.21, 299.84, 91., 1, ! 5
+ . 'Byrd__' ,'Byrd ',' ', -80.01,-119.40, 1530., 1, ! 6
+ . 'Dome-F' ,'Dome F ',' ', -77.31, 39.70, 3810., 1, ! 7
+ . 'Manuel' ,'Manuela ',' ', -74.95, 163.69, 78., 1, ! 8
+ . 'Marble' ,'Marble P','oint ', -77.44, 163.75, 120., 1, ! 9
+ . 'Whitlo' ,'Whitlock',' ', -76.14, 168.39, 275., 1, ! 10
+ . 'Lettau' ,'Lettau ',' ', -82.52,-174.45, 30., 1, ! 11
+ . 'PortMa' ,'Port Mar','tin ', -66.82, 141.40, 39., 1, ! 12
+ . 'PengPt' ,'Penguin ','Point ', -67.62, 146.18, 30., 1, ! 13
+ . 'Gill_1' ,'Gill ',' ', -79.99,-178.61, 25., 1, ! 14
+ . 'Schwer' ,'Schwerdt','feger ', -79.90, 169.97, 60., 1, ! 15
+ . 'D10___' ,'D-10 ',' ', -66.71, 139.83, 243., 1, ! 16
+ . 'Elaine' ,'Elaine ',' ', -83.13, 174.17, 60., 1, ! 17
+ . 'Ski_Hi' ,'Ski Hi ',' ', -74.79, 289.51, 1395., 1, ! 18
+ . 'Relay_' ,'Relay St',' ', -74.02, 43.06, 3353., 1, ! 19
+ . 'Linda_' ,'Linda ',' ', -78.46, 168.38, 50., 1, ! 20
+ . 'Uranus' ,'Uranus G','lacier ', -71.43, 291.07, 780., 1, ! 21
+ . 'MADISO' ,'MADISON ',' ', 43.08, -89.38, 0., 1, ! 22
+ . 'Doug__' ,'Doug ',' ', -82.32,-113.24, 1430., 1, ! 23
+ . 'BonaPt' ,'Bonapart','e Point ', -64.78, 295.93, 8., 1, ! 24
+ . 'Nico__' ,'Nico ',' ', -89.00, 89.67, 2935., 1, ! 25
+ . 'Limbrt' ,'Limbert ',' ', -75.42, 300.15, 40., 1, ! 26
+ . 'Larsen' ,'Larsen I','ce ', -66.95, 299.10, 17., 1, ! 27
+ . 'Wndlss' ,'Wndlss B','t ', -77.73, 167.70, 60., 1, ! 28
+ . 'Ferrel' ,'Ferrell ',' ', -77.91, 170.82, 45., 1, ! 29
+ . 'Kirkwd' ,'Kirkwood',' ', -68.34, 290.99, 30., 1, ! 30
+ . 'Dismal' ,'Dismal I','s ', -68.09, 291.18, 10., 1, ! 31
+ . 'Marily' ,'Marilyn ',' ', -79.95, 165.13, 75., 1, ! 32
+ . 'MinnaB' ,'Minna Bl','uff ', -78.55, 166.66, 920., 1, ! 33
+ . 'PegasS' ,'Pegasus ','South ', -77.99, 166.58, 10., 1, ! 34
+ . 'SipleD' ,'Siple Do','me ', -81.66,-148.77, 620., 1, ! 35
+ . 'Sutton' ,'Sutton ',' ', -67.10, 141.40, 871., 1, ! 36
+ . 'RacerR' ,'Racer Ro','ck ', -64.07, 298.39, 17., 1, ! 37
+ . 'YoungI' ,'Young Is',' ', -66.20, 162.30, 30., 1, ! 38
+ . 'MtSipl' ,'Mount Si','ple ', -73.20,-127.05, 230., 1, ! 39
+ . 'PossIs' ,'Poss Is ',' ', -71.89, 171.21, 30., 1, ! 40
+ . 'Henry_' ,'Henry ',' ', -89.01, -1.02, 2755., 1, ! 41
+ . 'D47___' ,'D-47 ',' ', -67.40, 138.73, 1560., 2, ! 42
+ . 'D57___' ,'D-57 ',' ', -68.30, 137.87, 2105., 2, ! 43
+ . 'CapDen' ,'Cape Den','ison ', -67.01, 142.66, 31., 1, ! 44
+ . 'DomeC2' ,'Dome C2 ',' ', -75.12, 123.37, 3250., 1, ! 45
+ . 'SwiBnk' ,'Swithinb','ank ', -81.20,-126.17, 945., 1, ! 46
+ . 'PegasN' ,'Pegasus ','North ', -77.95, 166.50, 8., 1, ! 47
+ . 'Theres' ,'Theresa ',' ', -84.60,-115.81, 1463., 1, ! 48
+ . 'Mizuho' ,'Mizuho ',' ', -70.70, 44.29, 2260., 1, ! 49
+ . 'LaurII' ,'Laurie I','I ', -77.55, 170.81, 30., 1, ! 50
+ . 'Elizab' ,'Elizabet','h ', -82.61,-137.08, 519., 1, ! 51
+ . 'Briana' ,'Brianna ',' ', -83.89,-134.15, 526., 1, ! 52
+ . 'Erin__' ,'Erin ',' ', -84.90, 231.17, 990., 1, ! 53
+ . 'WillF1' ,'Willie F','ield ', -77.87, 167.02, 20., 1, ! 54
+ . 'Young2' ,'Young Is','land ', -62.23, 162.28, 30., 1, ! 55
+ . 'CleanA' ,'Clean Ai','r ', -90.00, 0.00, 2835., 1, ! 56
+ . 'OdellG' ,'Odell Gl','acier ', -76.63, 160.05, 1637., 1, ! 57
+ . 'HerbA2' ,'Herbie A','lley ', -77.97, 167.54, 24., 1, ! 58
+ . 'SkyBlu' ,'Sky Blu ',' ', -74.79, 288.51, 1395., 1, ! 59
+ . 'A028-A' ,'A028-A ',' ', -67.59, 112.22, 1622., 1, ! 60
+ . 'A028__' ,'A028 ',' ', -67.59, 112.22, 1622., 1, ! 61
+ . 'GC41__' ,'GC41 ',' ', -70.40, 111.26, 2791., 1, ! 62
+ . 'GC46__' ,'GC46 ',' ', -70.86, 109.84, 3096., 1, ! 63
+ . 'GF08__' ,'GF08 ',' ', -67.51, 102.18, 2123., 1, ! 64
+ . 'LawDom' ,'Law Dome',' ', -65.27, 112.74, 1376., 1, ! 65
+ . 'DDU___' ,'DDU ',' ', -66.67, 140.02, 42., 2, ! 66
+ . 'Mawson' ,'Mawson ',' ', -67.60, 62.87, 10., 2, ! 67
+ . 'Casey_' ,'Casey ',' ', -66.28, 110.52, 40., 2, ! 68
+ . 'McMurd' ,'McMurdo ','(Fogle) ', -77.82, 166.75, 202., 2, ! 69
+ . 'Mirny_' ,'Mirny ',' ', -66.33, 93.01, 30., 2, ! 70
+ . 'Vostok' ,'Vostok ',' ', -78.45, 106.84, 3471., 2, ! 71
+ . 'Alison' ,'Allison ',' ', -89.88, 300.00, 2835., 0, ! 72
+ . 'Bowers' ,'Bowers ',' ', -85.20, 163.40, 2090., 0, ! 73
+ . 'D80___' ,'D80 ',' ', -70.02, 134.72, 2500., 0, ! 74
+ . 'Dollem' ,'Dolleman',' Island ', -70.58, 299.08, 396., 0, ! 75
+c #C1. 'DomeC1' ,'Dome C ',' ', -74.65, 124.40, 3232., 0, ! 76
+ . 'Dome-A' ,'Dome A ','China ', -81.00, 77.00, 4100., 0, ! 76
+ . 'DomeCA' ,'Dome C ','AMRC ', -74.50, 123.00, 3280., 0, ! 77
+ . 'DomeCE' ,'Dome C ','EPICA ', -75.11, 123.32, 3232., 2, ! 78
+ . 'Eneid_' ,'Eneid ','(TNB) ', -74.41, 164.06, 88., 0, ! 79
+ . 'Gill_2' ,'Gill ',' ', -80.00, 181.00, 55., 0, ! 80
+ . 'Maning' ,'Manning ',' ', -78.80, 166.80, 65., 0, ! 81
+ . 'Martha' ,'Martha ',' ', -78.31,-172.50, 42., 0, ! 82
+ . 'Patrik' ,'Patrick ',' ', -89.88, 45.00, 2835., 0, ! 83
+ . 'RidgeB' ,'Ridge B ',' ', -77.08, 94.92, 3400., 1, ! 84
+ . 'Tiffan' ,'Tiffany ',' ', -77.95, 168.17, 25., 0, ! 85
+ . 'Whitlo' ,'Whitlok ',' ', -76.24, 168.66, 274., 0, ! 86
+ . 'WindlB' ,'Windless',' Bight ', -77.70, 167.70, 40., 0, ! 87
+ . 'GPS2__' ,'GPS2 ',' ', -74.61, 157.38, 1804., 0, ! 88
+ . '31Dpt_' ,'31Dpt ',' ', -74.06, 155.93, 2041., 0, ! 89
+ . 'M2____' ,'M2 ',' ', -74.80, 151.10, 2272., 0, ! 90
+ . 'MidPt2' ,'MdPt2 ',' ', -75.53, 145.92, 2454., 0, ! 91
+ . 'D2____' ,'D2 ',' ', -75.65, 140.48, 2482., 0, ! 92
+ . 'D4____' ,'D4 ',' ', -75.60, 135.83, 2793., 0, ! 93
+ . 'D6____' ,'D6 ',' ', -75.44, 129.63, 3038., 0/ ! 94
+
+
+ data (AWS_0(n),AWS_1(n),AWS_2(n)
+ . ,AWSla(n),AWSlo(n),AWS_z(n),AWSio(n),n= 95,100)
+ . / 'Rother' ,'Rothera ',' ', -67.50, 291.90, 16., 1, ! 95
+ . 'Primav' ,'Primaver','a ', -64.20, 259.00, 50., 1, ! 96
+ . 'O_Higg' ,'O Higgin','s ', -63.30, 302.10, 10., 1, ! 97
+ . 'Bellin' ,'Bellings','hausen ', -62.20, 301.10, 16., 1, ! 98
+ . 'Adelai' ,'Adelaide',' ', -67.80, 302.10, 26., 1, ! 99
+ . 'SanMar' ,'San Mart','in ', -68.10, 292.90, 4., 1/ ! 100
+
+
+C +--AFW
+C + ---
+
+ data (AWS_0(n),AWS_1(n),AWS_2(n)
+ . ,AWSla(n),AWSlo(n),AWS_z(n),AWSio(n),n=101,175)
+C +... LABel AWS LABELS Latit. Longit. Alti. PR
+C + 0 => No IO
+C + 1 => OUTone
+C + 2 => OUTone
+C + ASCII
+ . / 'Bamako' ,' Bamako ',' Mali', 12.32, -7.57, 381., 2, ! 101
+ . 'Tombou' ,' Tombouc','tou Mali', 16.43, -3.00, 264., 2, ! 102
+ . 'NiameA' ,' Niamey-','Aero NI', 13.48, 2.16, 223., 2, ! 103
+ . 'Abidjn' ,' Abidjan',' Cote Iv', 5.15, -3.56, 8., 2, ! 104
+ . 'Tamanr' ,' Tamanra','sset AL', 22.78, 5.51, 1377., 2, ! 105
+ . 'Dakar_' ,' Dakar ',' Senegal', 14.44, -17.30, 27., 2, ! 106
+ . 'Adiake' ,' Adiake ',' Cote Iv', 5.3, -3.3, 7., 0, ! 107
+ . 'Bondok' ,' Bondouk',' Cote Iv', 08.03, -2.47, 370., 0, ! 108
+ . 'Bouake' ,' Bouake ',' Cote Iv', 07.44, -5.04, 376., 0, ! 109
+ . 'MAN___' ,' Man ',' Cote Iv', 07.23, -7.31, 340., 0, ! 110
+ . 'Korhog' ,' Korhogo',' Cote Iv', 09.25, -5.37, 381., 0, ! 111
+ . 'Sassan' ,' Sassand',' Cote Iv', 04.57, -6.05, 66., 0, ! 112
+ . 'Tabou_' ,' Tabou ',' Cote Iv', 04.25, -7.22, 21., 0, ! 113
+ . 'Dimbok' ,' Dimbokr',' Cote Iv', 06.39, -4.42, 92., 0, ! 114
+ . 'Odienn' ,' Odienné',' Cote Iv', 09.30, -7.34, 421., 0, ! 115
+ . 'Bobodi' ,' Bobodio',' Burkfas', 11.10, -4.19, 460., 0, ! 116
+ . 'Ouaga_' ,' Ouaga ',' Burkfas', 12.21, -1.31, 306., 0, ! 117
+ . 'Ouahig' ,' Ouahigo',' Burkfas', 13.34, -2.25, 336., 0, ! 118
+ . 'Fadago' ,' Fadagou',' Burkfas', 12.02, 0.22, 309., 0, ! 119
+ . 'Conakr' ,' Conakry',' Guinee ', 09.34, -13.37, 26., 2, ! 120
+ . 'Labe__' ,' Labe ',' Guinee ', 11.19, -12.18, 1026., 0, ! 121
+ . 'Nzere_' ,' Nzere ',' Guinee ', 7.44, -8.50, 470., 0, ! 122
+ . 'Siguir' ,' Siguiri',' Guinee ', 11.26, -9.10, 366., 0, ! 123
+ . 'Bissau' ,' Bissau ',' Gbissau', 11.53, -15.39, 26., 2, ! 124
+ . 'StLoui' ,' Stlouis',' Senegal', 16.03, -16.26, 04., 0, ! 125
+ . 'Matam_' ,' Matam ',' Senegal', 15.39, -13.15, 17., 0, ! 126
+ . 'Tambac' ,' Tambaco',' Senegal', 13.46, -13.41, 50., 0, ! 127
+ . 'Kolda_' ,' Kolda ',' Senegal', 12.53, -14.58, 10., 0, ! 128
+ . 'Ziguin' ,' Ziguinc',' Senegal', 12.33, -16.16, 23., 0, ! 129
+ . 'Diourb' ,' Diourbe',' Senegal', 14.39, -16.14, 9., 0, ! 130
+ . 'Kedouk' ,' Kedouko',' Senegal', 12.34, -12.13, 167., 0, ! 131
+ . 'Lungi_' ,' Lungi ',' Sierral', 8.37, -13.12, 27., 0, ! 132
+ . 'Robert' ,' Robertf',' Liberia', 6.15, -10.21, 18., 0, ! 133
+ . 'Nouakc' ,' Nouakch',' Maurita', 18.06, -15.57, 3., 0, ! 134
+ . 'Nouadi' ,' Nouadib',' Maurita', 20.56, -17.02, 3., 0, ! 135
+ . 'Zouera' ,' Zouerat',' Maurita', 22.45, -12.29, 343., 0, ! 136
+ . 'Nema__' ,' Nema ',' Maurita', 16.36, -7.16, 269., 0, ! 137
+ . 'Atar__' ,' Atar ',' Maurita', 20.31, -13.04, 224., 0, ! 138
+ . 'Kayes_' ,' Kayes ',' Mali ', 14.26, -11.26, 47., 0, ! 139
+ . 'Kidal_' ,' Kidal ',' Mali ', 18.26, 1.21, 459., 0, ! 140
+ . 'Mopti_' ,' Mopti ',' Mali ', 14.31, -4.06, 272., 0, ! 141
+ . 'Sikaso' ,' Sikasso',' Mali ', 11.21, -5.41, 375., 0, ! 142
+ . 'Accra_' ,' Accra ',' Ghana ', 5.36, -0.10, 69., 0, ! 143
+ . 'Kumasi' ,' Kumassi',' Ghana ', 6.43, -1.36, 293., 2, ! 144
+ . 'Tamal_' ,' Tamal ',' Ghana ', 9.30, -0.51, 173., 0, ! 145
+ . 'WAG___' ,' WA ',' Ghana ', 10.03, -0.30, 323., 0, ! 146
+ . 'Wenchi' ,' Wenchi ',' Ghana ', 7.43, -2.06, 340., 0, ! 147
+ . 'Ada___' ,' Ada ',' Ghana ', 5.47, -0.38, 7., 0, ! 148
+ . 'Abuja_' ,' Abuja ',' Nigeria', 9.15, 7.00, 344., 0, ! 149
+ . 'Lagos_' ,' Lagos ',' Nigeria', 6.35, 3.20, 38., 2, ! 150
+ . 'Maidug' ,' Maidugu',' Nigeria', 11.51, 13.05, 354., 0, ! 151
+ . 'Cotonu' ,' Cotonou',' Benin ', 2.21, 2.23, 9., 2, ! 152
+ . 'Paraku' ,' Parakou',' Benin ', 9.21, 2.37, 393., 2, ! 153
+ . 'Kandi_' ,' Kandi ',' Benin ', 11.08, 2.56, 292., 0, ! 154
+ . 'Natiti' ,' Natitin',' Benin ', 10.19, 1.23, 461., 0, ! 155
+ . 'Lome__' ,' Lome ',' Togo ', 6.10, 1.15, 25., 0, ! 156
+ . 'Atakpa' ,' Atakpam',' Togo ', 7.35, 1.07, 402., 0, ! 157
+ . 'Sokode' ,' Sokode ',' Togo ', 8.59, 1.09, 387., 0, ! 158
+ . 'Dapaon' ,' Dapaon ',' Togo ', 10.52, 0.15, 330., 0, ! 159
+ . 'Faya__' ,' Faya ',' Tchad ', 18.00, 19.10, 234., 0, ! 160
+ . 'Moundu' ,' Moundou',' Tchad ', 8.37, 16.10, 422., 0, ! 161
+ . 'Ndjame' ,' Ndjamen','a Tchad ', 12.08, 15.02, 295., 2, ! 162
+ . 'Sarh__' ,' Sarh ',' Tchad ', 9.09, 18.23, 365., 0, ! 163
+ . 'Douala' ,' Douala ',' Camerou', 4.00, 9.44, 9., 2, ! 164
+ . 'Garoua' ,' Garoua ',' Camerou', 9.20, 13.23, 244., 0, ! 165
+ . 'Malabo' ,' Malabo ',' Camerou', 3.49, 8.46, 56., 0, ! 166
+ . 'Tindou' ,' Tindouf',' Algerie', 27.40, -8.08, 431., 0, ! 167
+ . 'Agadir' ,' Agadir ',' Maroc ', 30.20, -9.24, 74., 0, ! 168
+ . 'Villac' ,'Villacis',' Sah Occ', 23.42, -15.52, 10., 0, ! 169
+ . 'Daloa_' ,'Daloa ',' Cote Iv', 6.52, -6.28, 276., 2, ! 170
+ . 'Gagnoa' ,'Gagnoa ',' Cote Iv', 6.08, -5.57, 205., 2, ! 171
+ . 'SanPed' ,'San Pedr',' Cote Iv', 4.45, -6.39, 31., 2, ! 172
+ . 'Tabou_' ,'Tabou ',' Cote Iv', 4.25, -7.22, 20., 2, ! 173
+ . 'Yamous' ,'Yamousso',' Cote Iv', 6.54, -5.21, 196., 2, ! 174
+ . 'Sal___' ,'Cap Vert',' Cote Iv', 16.44, -22.57, 54., 2/ ! 175
+
+
+C +--ANT (again)
+C + ---
+
+ data (AWS_0(n),AWS_1(n),AWS_2(n)
+ . ,AWSla(n),AWSlo(n),AWS_z(n),AWSio(n),n=176,188)
+C +... LABel AWS LABELS Latit. Longit. Alti. PR
+C + 0 => No IO
+C + 1 => OUTone
+C + 2 => OUTone
+C + ASCII
+ . / 'AGO-A8' ,'AGO-A8 ',' ', -84.36, -23.86, 2103., 1, ! 176
+ . 'Davis_' ,'Davis ',' ', -68.35, 77.59, 18., 2, ! 177
+ . 'Kenton' ,'Kenton ',' ', -72.28, -38.82, 3185., 1, ! 178
+ . 'SantCI' ,'Santa Cl','aus Isla', -64.96, -65.67, 25., 1, ! 179
+ . 'ScottI' ,'Scott Is','land ', -67.37,-179.97, 30., 1, ! 180
+ . 'ScottB' ,'Scott Ba','se ', -77.51, 166.45, 94., 2, ! 181
+ . 'Ski-Hi' ,'Ski-Hi ',' ', -74.98, -70.77, 1395., 1, ! 182
+ . 'TNB___' ,'Terra No','va Bay ', -74.42, 164.06, 80., 1, ! 183
+ . 'Theres' ,'Theresa ',' ', -84.60,-115.81, 1463., 1, ! 184
+ . 'WhiteO' ,'White Ou','t ', -77.87, 168.16, 30., 1, ! 185
+ . 'WhiteI' ,'White Is','land ', -78.09, 168.01, 30., 1, ! 186
+ . 'Kohnen' ,'Kohnen ',' ', -75.00, 0.07, 2892., 1, ! 187
+ . 'ElizBe' ,'Princess',' Elizab ', -71.90, 23.33, 1390., 2/ ! 188
+
+
+C +--ANT (Balises Glacioclim Samba, Antarctique)
+C + ---
+
+ data (AWS_0(n),AWS_1(n),AWS_2(n)
+ . ,AWSla(n),AWSlo(n),AWS_z(n),AWSio(n),n=189,n_AWS)
+C +... LABel AWS LABELS Latit. Longit. Alti. PR
+C + 0 => No IO
+C + 1 => OUTone
+C + 2 => OUTone
+C + ASCII
+ . /'B____1' ,'Balise S','AMBA 1',-66.69592,139.8985, 0., 1, ! 189
+ . 'B____2' ,'Balise S','AMBA 2',-66.69861,139.8915, 0., 1, ! 190
+ . 'B____3' ,'Balise S','AMBA 3',-66.69849,139.8801, 0., 1, ! 191
+ . 'B____4' ,'Balise S','AMBA 4',-66.69848,139.8690, 0., 1, ! 192
+ . 'B____5' ,'Balise S','AMBA 5',-66.69933,139.8545, 0., 1, ! 193
+ . 'B____6' ,'Balise S','AMBA 6',-66.70067,139.8398, 0., 1, ! 194
+ . 'B____7' ,'Balise S','AMBA 7',-66.70199,139.8236, 0., 1, ! 195
+ . 'B____8' ,'Balise S','AMBA 8',-66.70349,139.8088, 0., 1, ! 196
+ . 'B____9' ,'Balise S','AMBA 9',-66.70551,139.8021, 0., 1, ! 197
+ . 'B___10' ,'Balise S','AMBA 10',-66.70689,139.7838, 0., 1, ! 198
+ . 'B___11' ,'Balise S','AMBA 11',-66.70894,139.7746, 0., 1, ! 199
+ . 'B___12' ,'Balise S','AMBA 12',-66.71090,139.7628, 0., 1, ! 200
+ . 'B___13' ,'Balise S','AMBA 13',-66.71597,139.7400, 0., 1, ! 201
+ . 'B___14' ,'Balise S','AMBA 14',-66.72215,139.7237, 0., 1, ! 202
+ . 'B___15' ,'Balise S','AMBA 15',-66.72684,139.6999, 0., 1, ! 203
+ . 'B___16' ,'Balise S','AMBA 16',-66.73164,139.6770, 0., 1, ! 204
+ . 'B___17' ,'Balise S','AMBA 17',-66.73676,139.6557, 0., 1, ! 205
+ . 'B___18' ,'Balise S','AMBA 18',-66.74189,139.6336, 0., 1, ! 206
+ . 'B___19' ,'Balise S','AMBA 19',-66.74656,139.6087, 0., 1, ! 207
+ . 'B___20' ,'Balise S','AMBA 20',-66.75196,139.5914, 0., 1, ! 208
+ . 'B___21' ,'Balise S','AMBA 21',-66.76015,139.5783, 0., 1, ! 209
+ . 'B___22' ,'Balise S','AMBA 22',-66.76746,139.5677, 0., 1, ! 210
+ . 'B___23' ,'Balise S','AMBA 23',-66.77496,139.5568, 0., 1, ! 211
+ . 'B___24' ,'Balise S','AMBA 24',-66.78358,139.5459, 0., 1, ! 212
+ . 'B___25' ,'Balise S','AMBA 25',-66.79026,139.5321, 0., 1, ! 213
+ . 'B___26' ,'Balise S','AMBA 26',-66.79795,139.5204, 0., 1, ! 214
+ . 'B___27' ,'Balise S','AMBA 27',-66.80594,139.5093, 0., 1, ! 215
+ . 'B___28' ,'Balise S','AMBA 28',-66.81308,139.4968, 0., 1, ! 216
+ . 'B___29' ,'Balise S','AMBA 29',-66.82068,139.4857, 0., 1, ! 217
+ . 'B___30' ,'Balise S','AMBA 30',-66.82845,139.4750, 0., 1, ! 218
+ . 'B___31' ,'Balise S','AMBA 31',-66.83596,139.4623, 0., 1, ! 219
+ . 'B___32' ,'Balise S','AMBA 32',-66.84335,139.4495, 0., 1, ! 220
+ . 'B___33' ,'Balise S','AMBA 33',-66.85136,139.4383, 0., 1, ! 221
+ . 'B___34' ,'Balise S','AMBA 34',-66.85864,139.4251, 0., 1, ! 222
+ . 'B___35' ,'Balise S','AMBA 35',-66.86616,139.4135, 0., 1, ! 223
+ . 'B___36' ,'Balise S','AMBA 36',-66.87332,139.4004, 0., 1, ! 224
+ . 'B___37' ,'Balise S','AMBA 37',-66.88036,139.3867, 0., 1, ! 225
+ . 'B___38' ,'Balise S','AMBA 38',-66.88902,139.3759, 0., 1, ! 226
+ . 'B___39' ,'Balise S','AMBA 39',-66.89655,139.3638, 0., 1, ! 227
+ . 'B___40' ,'Balise S','AMBA 40',-66.90511,139.3541, 0., 1, ! 228
+ . 'B___41' ,'Balise S','AMBA 41',-66.91162,139.3414, 0., 1, ! 229
+ . 'B___42' ,'Balise S','AMBA 42',-66.92023,139.3318, 0., 1, ! 230
+ . 'B___43' ,'Balise S','AMBA 43',-66.92771,139.3174, 0., 1, ! 231
+ . 'B___44' ,'Balise S','AMBA 44',-66.93586,139.3041, 0., 1, ! 232
+ . 'B___45' ,'Balise S','AMBA 45',-66.94995,139.2799, 0., 1, ! 233
+ . 'B___46' ,'Balise S','AMBA 46',-66.96581,139.2567, 0., 1, ! 234
+ . 'B___47' ,'Balise S','AMBA 47',-66.98064,139.2319, 0., 1, ! 235
+ . 'B___48' ,'Balise S','AMBA 48',-66.99638,139.2094, 0., 1, ! 236
+ . 'B___49' ,'Balise S','AMBA 49',-67.01013,139.1807, 0., 1, ! 237
+ . 'B___50' ,'Balise S','AMBA 50',-67.02596,139.1579, 0., 1, ! 238
+ . 'B___51' ,'Balise S','AMBA 51',-67.04180,139.1366, 0., 1, ! 239
+ . 'B___52' ,'Balise S','AMBA 52',-67.05727,139.1129, 0., 1, ! 240
+ . 'B___53' ,'Balise S','AMBA 53',-67.07246,139.0880, 0., 1, ! 241
+ . 'B___54' ,'Balise S','AMBA 54',-67.08774,139.0636, 0., 1, ! 242
+ . 'B___55' ,'Balise S','AMBA 55',-67.10892,139.0396, 0., 1, ! 243
+ . 'B___56' ,'Balise S','AMBA 56',-67.13006,139.0164, 0., 1, ! 244
+ . 'B___57' ,'Balise S','AMBA 57',-67.15158,138.9922, 0., 1, ! 245
+ . 'B___58' ,'Balise S','AMBA 58',-67.17299,138.9688, 0., 1, ! 246
+ . 'B___59' ,'Balise S','AMBA 59',-67.19441,138.9449, 0., 1, ! 247
+ . 'B___60' ,'Balise S','AMBA 60',-67.21529,138.9217, 0., 1, ! 248
+ . 'B___61' ,'Balise S','AMBA 61',-67.23701,138.8970, 0., 1, ! 249
+ . 'B___62' ,'Balise S','AMBA 62',-67.25777,138.8741, 0., 1, ! 250
+ . 'B___63' ,'Balise S','AMBA 63',-67.27934,138.8516, 0., 1, ! 251
+ . 'B___64' ,'Balise S','AMBA 64',-67.29985,138.8272, 0., 1, ! 252
+ . 'B___65' ,'Balise S','AMBA 65',-67.32085,138.8031, 0., 1, ! 253
+ . 'B___66' ,'Balise S','AMBA 66',-67.34199,138.7810, 0., 1, ! 254
+ . 'B___67' ,'Balise S','AMBA 67',-67.36324,138.7575, 0., 1, ! 255
+ . 'B___68' ,'Balise S','AMBA 68',-67.38330,138.7339, 0., 1, ! 256
+ . 'B___69' ,'Balise S','AMBA 69',-67.39895,138.6845, 0., 1, ! 257
+ . 'B___70' ,'Balise S','AMBA 70',-67.41148,138.6308, 0., 1, ! 258
+ . 'B___71' ,'Balise S','AMBA 71',-67.42337,138.5791, 0., 1, ! 259
+ . 'B___72' ,'Balise S','AMBA 72',-67.43371,138.5271, 0., 1, ! 260
+ . 'B___73' ,'Balise S','AMBA 73',-67.44520,138.4770, 0., 1, ! 261
+ . 'B___74' ,'Balise S','AMBA 74',-67.45652,138.4266, 0., 1, ! 262
+ . 'B___75' ,'Balise S','AMBA 75',-67.46742,138.3745, 0., 1, ! 263
+ . 'B___76' ,'Balise S','AMBA 76',-67.48021,138.3261, 0., 1, ! 264
+ . 'B___77' ,'Balise S','AMBA 77',-67.49033,138.2753, 0., 1, ! 265
+ . 'B___78' ,'Balise S','AMBA 78',-67.50198,138.2254, 0., 1, ! 266
+ . 'B___79' ,'Balise S','AMBA 79',-67.51268,138.1755, 0., 1, ! 267
+ . 'B___80' ,'Balise S','AMBA 80',-67.52428,138.1233, 0., 1, ! 268
+ . 'B___81' ,'Balise S','AMBA 81',-67.53552,138.0752, 0., 1, ! 269
+ . 'B___82' ,'Balise S','AMBA 82',-67.54633,138.0226, 0., 1, ! 270
+ . 'B___83' ,'Balise S','AMBA 83',-67.55824,137.9738, 0., 1, ! 271
+ . 'B___84' ,'Balise S','AMBA 84',-67.56938,137.9211, 0., 1, ! 272
+ . 'B___85' ,'Balise S','AMBA 85',-67.57919,137.8671, 0., 1, ! 273
+ . 'B___86' ,'Balise S','AMBA 86',-67.59188,137.8209, 0., 1, ! 274
+ . 'B___87' ,'Balise S','AMBA 87',-67.60346,137.7698, 0., 1, ! 275
+ . 'B___88' ,'Balise S','AMBA 88',-67.61475,137.7186, 0., 1, ! 276
+ . 'B___89' ,'Balise S','AMBA 89',-67.62682,137.6693, 0., 1, ! 277
+ . 'B___90' ,'Balise S','AMBA 90',-67.64194,137.5968, 0., 1, ! 278
+ . 'B___91' ,'Balise S','AMBA 91',-67.66007,137.5244, 0., 1/ ! 279
+C + | | | | | | |
+C + | | | | | | v_
+C + | | | | | | OUTPUT = 0: All OUTPUT are prohibited
+C + | | | | | | OUTPUT = 1: netcdf OUTPUT decided in AWSloc
+C + | | | | | | OUTPUT = 2: netcdf OUTPUT decided in AWSloc
+C + | | | | | | ASCII OUTPUT decided in AWSloc
+C + | | | | | v (see #WV in SISVAT)
+C + | | | | v ALTITUDE of the Station
+C + | | | v LONGITUDE of the Station
+C + | v v LATITUDE of the Station
+C + v ATTRIBUTE of the Station, will be written in a title of the corresponding netcdf file
+C + LABEL of the Station, will be used as the first 3 characters of the corresponding netcdf file
+
+
+C + *******
+C +--CAUTION: DO'NT FORGET TO MODIFY THE parameter n_AWS in AWSloc IF YOU ADD NEW STATIONS!
+C + ******* AWS_nc
+C + AWS_nc_DATA
+
+ end
diff --git a/MAR/code_nestor/src/BELveg.f b/MAR/code_nestor/src/BELveg.f
new file mode 100644
index 0000000000000000000000000000000000000000..7dc82af42687695b5915fd8cc24395261b4086a6
--- /dev/null
+++ b/MAR/code_nestor/src/BELveg.f
@@ -0,0 +1,347 @@
+C +-------------------------------------------------------------------+
+C | Subroutine BELveg August 99 NESTING |
+C +-------------------------------------------------------------------+
+C | |
+C | Input : - NST__x, NST__y : horizontal grid of NST model |
+C | ^^^^^^^ |
+C | |
+C | Output: - NSTveg : vegetation type (IGBP classification) |
+C | ^^^^^^^ - NSTvfr : fraction of vegetation in the grid cell (IGBP) |
+C | |
+C | Source : L. VAN DER AUWERA (IRM - Pollution Dep.) |
+C | ^^^^^^ |
+C +-------------------------------------------------------------------+
+C | |
+C | Explanation given with the data (L. Van der Auwera) : |
+C | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
+C | VOLGENDE FILE BEVAT 'LAND USE' GEGEVENS VAN BELGIE |
+C | DE X,Y COORDINATEN ZIJN UITGEDRUKT IN DEZE LAMBERT-COORDINATEN |
+C | DE INDELING IS VOOR ELKE LIJN: |
+C | VOLGNR,MATRIXPLAATS,STAFKAARTNR,ONDERVERDELINGSNR V. D. STAFKAART,|
+C | X-LAMBERT COORD,Y-LAMBERT COORD,RUWHEIDSCODE,LAMBDA,PHI, |
+C | CODE(HOOGTE INFORMATIEBRON),COMMENTAAR |
+C | MATRIXPLAATS=(Y-1)*300+X ,PUNT (1,1) IS LINKSONDER,RIJ PER RIJ |
+C | LAMBDA,PHI IN GRADEN EN DECIMALE GRAADINDELING |
+C | CODE = 0 HOOGTE EN RUWHEIDSCODE GENOMEN VANAF BELGISCHE STAFKAART |
+C | 1/25000, ALLE PUNTEN BINNEN BELGIE GELEGEN |
+C | 1 GEINTERPOLEERDE WAARDEN UIT NEDERLANDSE GEGEVENS |
+C | (J.WIERINGA) |
+C | 2 GEINTERPOLEERDE WAARDEN UIT ALPEX GEGEVENS |
+C | 3 GEINTERPOLEERDE WAARDEN UIT DUITSE GEGEVENS (H.SCHMIDT |
+C | D.WETT.) |
+C | 4 GEINTERPOLEERDE WAARDEN UIT DUITSE + ALPEX COMBINATIES |
+C | 5 WAARDEN OP DE NOORDZEE: hoogte = 0 en ruwheidscode = Z |
+C | VERKLARING AANGENOMEN RUWHEIDSCODE = (CF. J.WIERINGA) |
+C | CODE - OMSCHRIJVING (MOGELIJKE)RUWHEIDSLENGTE(CM) |
+C | Z - ZEE 0.03 |
+C | M - MEER,WATER 0.6 |
+C | R - RIET,MOERAS,DRAS 1.5 |
+C | P - POLDER,ZAND,WEIDE,GRAS 7.0 |
+C | D - DUIN,HEIDE,LAAG KREUPELHOUT 10.0 |
+C | A - AKKERLAND,BEBOUWD LAND 17.0 |
+C | W - WEGEN,KANALEN,BOMEN RIJEN 24.0 |
+C | G - BOOMGAARDEN,BOSJES 35.0 |
+C | B - BOS,LOOFWOUD 75.0 |
+C | N - NAALDWOUD 100.0 |
+C | H - HUIZEN,DORPEN 112.0 |
+C | S - STEDEN,HOOGBOUW 160.0 |
+C | |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE BELveg
+
+
+ IMPLICIT NONE
+
+
+C +---General variables
+C + -----------------
+
+ INCLUDE 'NSTdim.inc'
+ INCLUDE 'NSTvar.inc'
+ INCLUDE 'LOCfil.inc'
+
+C +---Local variables
+C + ---------------
+
+ INTEGER i,j,k,l,dim_x,dim_y,px,py,nbx,nby,count,nigbp,
+ . aux1,aux2,aux3,aux4,aux5,TMPuse
+
+ REAL tmp_lon,tmp_lat,dxi,dyi,dist,dist_max,dist_best,
+ . distx,disty,degrad,VEGtot,TMPfrc
+
+ CHARACTER*1 soil_id
+
+ PARAMETER (dim_x=310,dim_y=260)
+ PARAMETER (nigbp=17)
+
+ INTEGER IBGPcl(dim_x,dim_y),VEGcls(mx,my,nvx)
+ REAL VEGlon(dim_x,dim_y),VEGlat(dim_x,dim_y),
+ . VEGfrc(mx,my,3),IGBPfr(nigbp)
+
+ CHARACTER*80 BELveg_file
+
+
+C +---Data
+C + ----
+
+ DATA degrad / 1.745329252d-2 /
+
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Initialization
+C + ==============
+
+ DO j=1,my
+ DO i=1,mx
+
+C + Standard vegetation : 60 % natural prairies
+C + ^^^^^^^^^^^^^^^^^^^ 20 % agricultural crop
+C + 20 % evergreen forest
+
+ DO k=1,nvx
+ VEGcls(i,j,k)=0
+ VEGfrc(i,j,k)=0.
+ ENDDO
+
+ ENDDO
+ ENDDO
+
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Read the data file : LANDUSE_Belg
+C + =================================
+
+
+C +---Initialisation
+C + --------------
+
+ DO j=1,dim_y
+ DO i=1,dim_x
+ IBGPcl(i,j)=10
+ ENDDO
+ ENDDO
+
+
+C +---Data File
+C + ---------
+
+ BELveg_file = BELveg_dir // 'BELveg_IRM.asc'
+ OPEN (unit=10,status='old',file=BELveg_file)
+ REWIND 10
+
+ DO k=1,37836
+
+ READ (10,100) aux1,aux2,aux3,aux4,i,j,soil_id,
+ . tmp_lon,tmp_lat,aux5
+
+100 FORMAT (2i6,2i3,2i4,5x,a1,f8.5,f9.5,i2)
+
+
+C +---Longitude and latitude
+C + ----------------------
+
+ VEGlon(i,j) = tmp_lon
+ VEGlat(i,j) = tmp_lat
+
+
+C +---Convertion of land use to IGBP classification
+C + ---------------------------------------------
+
+ IF (soil_id .eq. 'Z') IBGPcl(i,j) = 17 ! Water
+ IF (soil_id .eq. 'M') IBGPcl(i,j) = 17 ! Water
+ IF (soil_id .eq. 'R') IBGPcl(i,j) = 11 ! Permanent wetland
+ IF (soil_id .eq. 'P') IBGPcl(i,j) = 10 ! Grassland
+ IF (soil_id .eq. 'D') IBGPcl(i,j) = 16 ! Barren or sparsely veg.
+ IF (soil_id .eq. 'A') IBGPcl(i,j) = 12 ! Croplands
+ IF (soil_id .eq. 'W') IBGPcl(i,j) = 7 ! Open shrublands
+ IF (soil_id .eq. 'G') IBGPcl(i,j) = 6 ! Closed shrublands
+ IF (soil_id .eq. 'B') IBGPcl(i,j) = 4 ! Deciduous broadleaf
+ IF (soil_id .eq. 'N') IBGPcl(i,j) = 1 ! Evergreen needleleaf
+ IF (soil_id .eq. 'H') IBGPcl(i,j) = 13 ! Urban and built-up
+ IF (soil_id .eq. 'S') IBGPcl(i,j) = 13 ! Urban and built-up
+
+ ENDDO
+
+ CLOSE(unit=10)
+
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Average of vegetation types for each grid cell
+C + ==============================================
+
+
+ DO j=1,my
+ DO i=1,mx
+
+ dxi=ABS(NST__x(i,j)-NST__x(i-1,j-1))*111111.
+ . *COS(degrad*NST__y(i,j))
+ dyi=ABS(NST__y(i,j)-NST__y(i-1,j-1))*111111.
+
+ dist_max =SQRT(dxi*dxi+dyi*dyi)
+
+
+C +---Seraching for the data grid point closest to the NST grid point
+C + ---------------------------------------------------------------
+
+ dist_best=dist_max
+ px =0
+ py =0
+
+ DO l=1,dim_y
+ DO k=1,dim_x
+
+ distx=(NST__x(i,j)-VEGlon(k,l))*111111.
+ . *COS(degrad*NST__y(i,j))
+ disty=(NST__y(i,j)-VEGlat(k,l))*111111.
+ dist =SQRT(distx*distx+disty*disty)
+
+ IF (dist.lt.dist_best) THEN
+ dist_best=dist
+ px =k
+ py =l
+ ENDIF
+
+ ENDDO
+ ENDDO
+
+ IF (dist_best.gt.dist_max) THEN
+ px=0
+ py=0
+ ENDIF
+
+
+C +---Compute an average for each vegetation types in the grid cell
+C + -------------------------------------------------------------
+
+ IF (px.ne.0.and.py.ne.0.and.NSTsol(i,j).ge.4) THEN
+
+C +---Initialization
+C + --------------
+
+ nbx =NINT(dxi/1000.)/2
+ nby =NINT(dyi/1000.)/2
+ count=0
+
+ DO k=1,nigbp
+ IGBPfr(k)=0.
+ ENDDO
+
+
+C +---Vegetation types in the grid cell
+C + ---------------------------------
+
+ DO l=MAX(py-nby,1),MIN(py+nby,dim_y)
+ DO k=MAX(px-nbx,1),MIN(px+nbx,dim_x)
+ count=count+1
+ IGBPfr(IBGPcl(k,l))=IGBPfr(IBGPcl(k,l))+1.
+ ENDDO
+ ENDDO
+
+
+C +---Percentages of each vegetation types
+C + ------------------------------------
+
+ DO k=1,nigbp
+ IF (count.gt.0) THEN
+ IGBPfr(k)=IGBPfr(k)/MAX(1.,REAL(count))
+ ELSE
+ IGBPfr(k)=0.
+ ENDIF
+ ENDDO
+
+
+C +---Retain three more important vegetation types
+C + --------------------------------------------
+
+ DO k=1,nvx
+ VEGcls(i,j,k)=0
+ ENDDO
+
+ DO k=1,nvx
+
+ TMPuse=0
+ TMPfrc=0.
+
+ DO l=1,nigbp
+ IF (l.ne.13 .and. l.ne.17 .and. IGBPfr(l).gt.TMPfrc) THEN
+ TMPfrc=IGBPfr(l)
+ TMPuse=l
+ ENDIF
+ ENDDO
+
+ VEGcls(i,j,k)=TMPuse
+ VEGfrc(i,j,k)=TMPfrc
+
+ ENDDO
+
+
+C +---Fraction of the three retained vegetation types
+C + -----------------------------------------------
+
+ VEGtot=0
+ DO k=1,nvx
+ VEGtot=VEGtot+VEGcls(i,j,k)
+ ENDDO
+
+ DO k=1,nvx
+ IF (VEGtot.gt.0.2) THEN
+ VEGfrc(i,j,k)=REAL(VEGcls(i,j,k))/REAL(VEGtot)*100.
+ ELSE
+ VEGfrc(i,j,k)=0.
+ ENDIF
+ ENDDO
+
+
+C +---Use of SVAT model ?
+C + -------------------
+
+ IF (VEGtot.eq.0) THEN
+ NSTsol(i,j)=4 ! No
+ ELSE
+ NSTsol(i,j)=5 ! Yes
+ ENDIF
+
+
+ ENDIF
+
+ ENDDO
+ ENDDO
+
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Attribution of vegetation types to some NST grid points
+C + =======================================================
+
+ DO j=1,my
+ DO i=1,mx
+
+ IF (NSTsol(i,j).eq.5) THEN
+ DO k=1,nvx
+ NSTveg(i,j,k)=VEGcls (i,j,k)
+ NSTvfr(i,j,k)=NINT(VEGfrc(i,j,k))
+ ENDDO
+ ELSE
+ DO k=1,nvx
+ NSTveg(i,j,k)=0
+ NSTvfr(i,j,k)=0.
+ ENDDO
+ ENDIF
+
+ ENDDO
+ ENDDO
+
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+ RETURN
+ END
diff --git a/MAR/code_nestor/src/BETOPO.f b/MAR/code_nestor/src/BETOPO.f
new file mode 100644
index 0000000000000000000000000000000000000000..431d68c246f05d244b80773901fc3e9de48b4746
--- /dev/null
+++ b/MAR/code_nestor/src/BETOPO.f
@@ -0,0 +1,236 @@
+C +-------------------------------------------------------------------+
+C | Subroutine BETOPO September 2002 NESTING |
+C +-------------------------------------------------------------------+
+C | |
+C | Input : NST__x : longitude (degree) of the NST grid |
+C | ^^^^^^^ NST__y : latitude (degree) of the NST grid |
+C | |
+C | Output: NST_sh: surface elevation |
+C | ^^^^^^^ NSTsol: land (4) / sea (1) mask |
+C | |
+C +-------------------------------------------------------------------+
+
+
+ SUBROUTINE BETOPO (NST__x,NST__y,NST_sh,NSTsol)
+
+
+ IMPLICIT NONE
+
+
+C +---General and local variables
+C + ---------------------------
+
+ INCLUDE 'NSTdim.inc'
+ INCLUDE 'LOCfil.inc'
+ INCLUDE 'NetCDF.inc'
+
+ INTEGER i,j,n,nbchar,i_cent,j_cent,i1,
+ . i2,j1,j2,TOP_id,Rcode,start(3),count(3),nsamp,
+ . k,l,G_nx,G_ny,ii,jj,fID,N_lon,N_lat
+
+ INTEGER*2 TOPhgt(1,1),zero
+
+ REAL G_reso,degrad,dx,dy,dx1,dx2,dy1,dy2,altsum,
+ . G_dx,G_dy,AUXlon,AUXlat,AUXlo1,AUXlo2,AUXla1,
+ . AUXla2,G_lon1,G_lon2,G_lat1,G_lat2
+
+ REAL NST__x(mx,my),NST__y(mx,my),NST_sh(mx,my)
+
+ INTEGER NSTsol(mx,my)
+
+ LOGICAL Vtrue
+
+
+C +---Data
+C + ----
+
+ DATA degrad / 1.745329252d-2 /
+ DATA start / 1,1,1 /
+ DATA count / 0,0,0 /
+ DATA zero / 0 /
+ DATA Vtrue / .true. /
+
+
+C +---Info about data file
+C + --------------------
+
+ G_lon1 = 2.50 ! South-West corner (longitude)
+ G_lat1 = 49.25 ! South-West corner (latitude )
+
+ G_lon2 = 6.50 ! North-East corner (longitude)
+ G_lat2 = 51.50 ! North-East corner (latitude )
+
+ G_reso = 1./3600. ! Resolution : about 30 m
+
+ N_lon = 14401 ! Number of grid points in longitude
+ N_lat = 8101 ! Number of grid points in latitude
+
+
+C +---Screen message
+C + --------------
+
+ write(6,*) 'Topography of Belgium (30 m resolution)'
+ write(6,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+
+
+C +---Input directory
+C + ---------------
+
+ nbchar = 1
+
+ DO i=1,60
+ IF (BTOPO_dir(i:i).ne.' ') nbchar=i
+ ENDDO
+
+
+C +---Open the Netcdf data file
+C + -------------------------
+
+ fID=NCOPN(BTOPO_dir(1:nbchar)//'B_TOPO.nc',NCNOWRIT,Rcode)
+
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ DO j=1,my ! Loop on horizontal NST grid points
+ DO i=1,mx
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Choice of the appropriate data file
+C + -----------------------------------
+
+ AUXlon = NST__x(i,j)
+ AUXlat = NST__y(i,j)
+C + ******
+ CALL SPHERC (Vtrue,AUXlon,AUXlat)
+C + ******
+
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+C +---Check if the grid point is located in the data domain
+C + -----------------------------------------------------
+
+ IF ((AUXlon.ge.G_lon1).and.(AUXlon.le.G_lon2).and.
+ . (AUXlat.ge.G_lat1).and.(AUXlat.le.G_lat2)) THEN
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Search for the closest point in data file
+C + -----------------------------------------
+
+ i_cent=NINT((AUXlon-REAL(G_lon1))/G_reso)+1
+ j_cent=NINT((AUXlat-REAL(G_lat1))/G_reso)+1
+
+
+C +---Compute the resolution of the considered NST cell
+C + -------------------------------------------------
+
+ ii = MAX(i,2)
+ jj = MAX(j,2)
+
+ AUXlo1 = NST__x(ii ,jj )
+ AUXla1 = NST__y(ii ,jj )
+ AUXlo2 = NST__x(ii-1,jj-1)
+ AUXla2 = NST__y(ii-1,jj-1)
+C + ******
+ CALL SPHERC (Vtrue,AUXlo1,AUXla1)
+ CALL SPHERC (Vtrue,AUXlo2,AUXla2)
+C + ******
+
+ dx=ABS(AUXlo1-AUXlo2)*111111.*COS(AUXla1*degrad)
+ dy=ABS(AUXla1-AUXla2)*111111.
+
+
+C +---Define the data points to be read around (i_cent,j_cent)
+C + --------------------------------------------------------
+
+ G_dx = G_reso*111111.*COS(AUXla1*degrad)
+ G_dy = G_reso*111111.
+
+ G_nx=NINT(dx/G_dx/2.)-1
+ G_ny=NINT(dy/G_dy/2.)-1
+
+ G_nx=MAX(G_nx,0)
+ G_ny=MAX(G_ny,0)
+
+ i1=i_cent-G_nx
+ i2=i_cent+G_nx
+ j1=j_cent-G_ny
+ j2=j_cent+G_ny
+
+ i1=MAX(i1,1)
+ i2=MIN(i2,N_lon)
+ j1=MAX(j1,1)
+ j2=MIN(j2,N_lat)
+
+
+C +---Read subset of data
+C + -------------------
+
+ TOP_id=NCVID(fID,'topo',Rcode)
+
+ nsamp =0
+ altsum=0.
+
+ DO l=j1,j2 ! Loop on data grid points
+ DO k=i1,i2 ! contained in the (i,j) NST cell
+
+ start(1)=k
+ start(2)=l
+ count(1)=1
+ count(2)=1
+
+ CALL NCVGT(fID,TOP_id,start,count,TOPhgt,Rcode)
+
+ IF (TOPhgt(1,1).ge.0.0.and.TOPhgt(1,1).le.2000.0) THEN
+ altsum=altsum+MAX(zero,TOPhgt(1,1))
+ nsamp =nsamp+1
+ ENDIF
+
+ ENDDO
+ ENDDO
+
+
+C +---Final computation of the topography at (i,j) location
+C + -----------------------------------------------------
+
+ IF (nsamp.ne.0) THEN
+ NST_sh(i,j)=altsum/real(nsamp)
+ ENDIF
+
+
+C +---Distinction between land and sea (further refined)
+C + --------------------------------
+
+ IF (NST_sh(i,j).lt.0.01) THEN
+ NSTsol(i,j)=1
+ ELSE
+ NSTsol(i,j)=4
+ ENDIF
+
+
+C +---No atmosphere below sea level...
+C + --------------------------------
+
+ IF (NST_sh(i,j).lt.0.0) THEN
+ NST_sh(i,j)= 0.0
+ ENDIF
+
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ ENDIF ! Grid point (i,j) is in Belgium
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ ENDDO ! Loop on NST grid points
+ ENDDO
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+ RETURN
+ END
diff --git a/MAR/code_nestor/src/CHKcel.f b/MAR/code_nestor/src/CHKcel.f
new file mode 100644
index 0000000000000000000000000000000000000000..b5150396b77103259db80039aa29639601ea7d9b
--- /dev/null
+++ b/MAR/code_nestor/src/CHKcel.f
@@ -0,0 +1,272 @@
+C +-------------------------------------------------------------------+
+C | Subroutine CHKcel June 2000 NESTING |
+C +-------------------------------------------------------------------+
+C | |
+C | Search for all NST cells contained in a LSC grid cell. |
+C | |
+C | Input : LSC__x (ni, nj) : Input grid points position x(i,j) |
+C | ^^^^^^^ LSC__y (ni, nj) : " " " " y(i,j) |
+C | NST__x (mx, my) : Output grid positions x(i,j) |
+C | NST__y (mx, my) : Output grid positions y(i,j) |
+C | kk,ll : selection of the LSC cell |
+C | |
+C | Output: icell (mx, my) : i-index of NST cells in the LSC cell |
+C | ^^^^^^^ jcell (mx, my) : j-index of NST cells in the LSC cell |
+C | nlist : number of NST cells in the LSC cell |
+C | |
+C +-------------------------------------------------------------------+
+
+
+ SUBROUTINE CHKcel (ni,nj,LSC__x,LSC__y,mx,my,NST__x,NST__y,
+ . kk,ll,MXlist,icell,jcell,nlist)
+
+
+ IMPLICIT NONE
+
+
+C +---General and local variables
+C + ---------------------------
+
+ INTEGER i,j,k,l,kk,ll,ni,nj,mx,my,ilist,nlist,MXlist
+
+ INTEGER icell(MXlist),jcell(MXlist)
+
+ REAL clon,clat,lat1,lat2,lat3,lat4,lon1,lon2,lon3,lon4,val1,
+ . val2,val3,val4,tmp,dlon12,dlon14,dlat12,dlat14,ilat,ilon
+
+ REAL LSC__x(ni,nj),LSC__y(ni,nj),NST__x(mx,my),NST__y(mx,my)
+
+ LOGICAL includ
+
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ DO l=ll,ll ! LOOP on LSC grid-points : BEGIN
+ DO k=kk,kk
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ lon1=0.5*(LSC__x(k,l)+LSC__x(k-1,l-1))
+ lon2=0.5*(LSC__x(k,l)+LSC__x(k+1,l-1))
+ lon3=0.5*(LSC__x(k,l)+LSC__x(k+1,l+1))
+ lon4=0.5*(LSC__x(k,l)+LSC__x(k-1,l+1))
+
+ lat1=0.5*(LSC__y(k,l)+LSC__y(k-1,l-1))
+ lat2=0.5*(LSC__y(k,l)+LSC__y(k+1,l-1))
+ lat3=0.5*(LSC__y(k,l)+LSC__y(k+1,l+1))
+ lat4=0.5*(LSC__y(k,l)+LSC__y(k-1,l+1))
+
+
+C +---Rotation of input grid cell ?
+C + =============================
+
+ dlat12=ABS(lat2-lat1)
+ dlat14=ABS(lat4-lat1)
+ dlon12=ABS(lon2-lon1)
+ dlon14=ABS(lon4-lon1)
+
+ IF ((dlat14.lt.dlat12).and.(dlon14.gt.dlon12)) THEN
+ tmp =lat1 ! Latitude
+ lat1=lat2
+ lat2=lat3
+ lat3=lat4
+ lat4=tmp
+ tmp =lon1 ! Longitude
+ lon1=lon2
+ lon2=lon3
+ lon3=lon4
+ lon4=tmp
+ tmp =val1 ! Values
+ val1=val2
+ val2=val3
+ val3=val4
+ val4=tmp
+ ENDIF
+
+
+C +---Invert latitude ?
+C + =================
+
+ IF (lat4.lt.lat1) THEN
+
+ IF (lat3.lt.lat2) THEN
+ tmp =lat2 ! Latitude
+ lat2=lat3
+ lat3=tmp
+ tmp =lat1
+ lat1=lat4
+ lat4=tmp
+ tmp =lon2 ! Longitude
+ lon2=lon3
+ lon3=tmp
+ tmp =lon1
+ lon1=lon4
+ lon4=tmp
+ tmp =val2 ! Values
+ val2=val3
+ val3=tmp
+ tmp =val1
+ val1=val4
+ val4=tmp
+ ELSE
+ WRITE(6,*) 'Inconsistance in latitude. Cannot be resolved'
+ WRITE(6,*) 'by CHKcel subroutine. --- STOP'
+ WRITE(6,*)
+ WRITE(6,*) 'Info : ',lat1,lat2,lat3,lat4
+ STOP
+ ENDIF
+
+ ELSE
+
+ IF (lat3.lt.lat2) THEN
+
+ WRITE(6,*) 'Inconsistance in latitude. Cannot be resolved'
+ WRITE(6,*) 'by CHKcel subroutine. --- STOP'
+ WRITE(6,*)
+ WRITE(6,*) 'Info : ',lat1,lat2,lat3,lat4
+ STOP
+
+ ENDIF
+
+ ENDIF
+
+
+C +---Invert longitude ?
+C + ==================
+
+ IF (lon2.lt.lon1) THEN
+
+ IF (lon3.lt.lon4) THEN
+ tmp =lat3 ! Latitude
+ lat3=lat4
+ lat4=tmp
+ tmp =lat1
+ lat1=lat2
+ lat2=tmp
+ tmp =lon3 ! Longitude
+ lon3=lon4
+ lon4=tmp
+ tmp =lon1
+ lon1=lon2
+ lon2=tmp
+ tmp =val3 ! Values
+ val3=val4
+ val4=tmp
+ tmp =val1
+ val1=val2
+ val2=tmp
+ ELSE
+ WRITE(6,*) 'Inconsistance in longitude. Cannot be resolved'
+ WRITE(6,*) 'CHKcel subroutine. --- STOP'
+ WRITE(6,*)
+ WRITE(6,*) 'Info : ',lon1,lon2,lon3,lon4
+ STOP
+ ENDIF
+
+ ELSE
+
+ IF (lon3.lt.lon4) THEN
+
+ WRITE(6,*) 'Inconsistance in longitude. Cannot be resolved'
+ WRITE(6,*) 'CHKcel subroutine. --- STOP'
+ WRITE(6,*)
+ WRITE(6,*) 'Info : ',lon1,lon2,lon3,lon4
+ STOP
+
+ ENDIF
+
+ ENDIF
+
+
+C + At this stage, it is assumed that the input grid cell is
+C + such that :
+C +
+C + 4----------3
+C + | |
+C + | |
+C + | |
+C + 1----------2
+C +
+C + with lon1 < lon2, lon4 < lon3
+C + lat1 < lat4, lat2 < lat3
+
+
+C +---Initialization of list of cells included in LSC cell
+C + ====================================================
+
+ nlist=0
+ DO ilist=1,MXlist
+ icell(ilist)=0
+ jcell(ilist)=0
+ ENDDO
+
+
+C +---Check if input cell includes output grid point
+C + ==============================================
+
+
+ DO j=1,my ! LOOP on NST grid-points : BEGIN
+ DO i=1,mx
+
+ clon=NST__x(i,j)
+ clat=NST__y(i,j)
+
+ includ=.true.
+
+C +---Segment 1-2
+C + -----------
+
+ ilat=lat1+(clon-lon1)/(lon2-lon1)*(lat2-lat1)
+ IF (ilat.gt.clat) includ=.false.
+
+C +---Segment 4-3
+C + -----------
+
+ ilat=lat4+(clon-lon4)/(lon3-lon4)*(lat3-lat4)
+ IF (ilat.lt.clat) includ=.false.
+
+C +---Segment 2-3
+C + -----------
+
+ ilon=lon2+(clat-lat2)/(lat3-lat2)*(lon3-lon2)
+ IF (ilon.lt.clon) includ=.false.
+
+C +---Segment 1-4
+C + -----------
+
+ ilon=lon1+(clat-lat1)/(lat4-lat1)*(lon4-lon1)
+ IF (ilon.gt.clon) includ=.false.
+
+
+C +---Complete list of cells
+C + ======================
+
+ IF (includ) THEN
+ nlist=nlist+1
+ IF (nlist.gt.MXlist) THEN
+ WRITE(6,*) 'The size of the icell and jcell variables has to'
+ WRITE(6,*) 'be increased. Please modify MXlist in PRCdes'
+ WRITE(6,*) 'subroutine. --- STOP'
+ WRITE(6,*)
+ STOP
+ ENDIF
+ icell(nlist)=i
+ jcell(nlist)=j
+ ENDIF
+
+
+ ENDDO ! Loop on NST grid-points : END
+ ENDDO
+
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ ENDDO
+ ENDDO ! Loop on LSC grid-points : END
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+ RETURN
+ END
+
diff --git a/MAR/code_nestor/src/CORveg.f b/MAR/code_nestor/src/CORveg.f
new file mode 100644
index 0000000000000000000000000000000000000000..9926bfdeafb95da5fb5230be2155eb44abe47adb
--- /dev/null
+++ b/MAR/code_nestor/src/CORveg.f
@@ -0,0 +1,498 @@
+C +-------------------------------------------------------------------+
+C | Subroutine CORveg 08/2004 NESTING |
+C +-------------------------------------------------------------------+
+C | |
+C | Derives MAR vegetation and surface type from CORINE |
+C | from CORINE land use database (revised version 2004) |
+C | |
+C | Input : - NST__x, NST__y : horizontal grid of NST model |
+C | ^^^^^^^ |
+C | |
+C | Output: - NSTsvt : vegetation type (SVAT classification) |
+C | ^^^^^^^ - NSTsfr : fraction of vegetation in the grid cell (SVAT) |
+C | - NSTlai : leaf area index |
+C | |
+C | |
+C | Data source : CORINE land cover (Corine detail level 2 or 3) |
+C | ^^^^^^^^^^^ |
+C | |
+C | |
+C | |
+C +-------------------------------------------------------------------+
+ SUBROUTINE CORveg
+
+
+ IMPLICIT NONE
+
+C +---General variables
+C + -----------------
+
+ INCLUDE 'NSTdim.inc'
+ INCLUDE 'NSTvar.inc'
+ INCLUDE 'LOCfil.inc'
+ INCLUDE 'NetCDF.inc'
+ INCLUDE 'NESTOR.inc'
+
+C +---Local variables
+C + ---------------
+
+ INTEGER imx,imy,nclass,nsvat
+
+C CORINE grid size
+ PARAMETER (imx=18294,imy=18514)
+ PARAMETER (nclass=50)
+ PARAMETER (nsvat =12)
+
+ INTEGER VARSIZE
+ EXTERNAL VARSIZE
+
+ INTEGER ii,jj,kk,ll,Ierror,lomi,
+ . nbchar,iclass,CORcid,nFrNul,
+ . AXX_ID,AXY_ID,frac_itot,AgFlag
+ LOGICAL AgNeed
+
+ REAL FrMwat,FrMfor,FrMnul,
+ . frac_tot,degrad,reqlon,
+ . reqlat,radius,phi0,lam0,C_reso,xlaea,ylaea
+
+ REAL out_X(0:mx,0:my), out_Y(0:mx,0:my),
+ . ainX(imx),ainY(imy)
+
+
+ INTEGER SVT_class(nvx)
+
+ REAL CORfrc(mx,my,nclass),VEGlon,
+ . convert(nclass,0:nsvat),Curban(nclass),
+ . CORwat(nclass),Cnoveg(nclass),CORtmp(nclass),
+ . COR_z0(nclass),FrAsSVT(0:nsvat),SVT_frac(nvx)
+
+ CHARACTER*200 CHnul
+
+C +---Data
+C + ----
+
+C CORINE Map projection information
+ DATA degrad / 1.745329252d-2 /
+ DATA lam0 / 9.0 /
+ DATA phi0 / 48.0 /
+ DATA radius / 6378388.0 /
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Screen message
+C + ==============
+
+ write(6,*) 'CORINE land cover over Europe'
+ write(6,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+ write(6,*)
+
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+
+C +---Convertion table : CORINE -> SVAT classification
+C + =================================================
+
+
+C +---Initialisation
+C + --------------
+
+ DO kk=1,nclass
+ DO ll=0,nsvat
+ convert(kk,ll)=0.
+ ENDDO
+ ENDDO
+
+
+C +---Convertion table
+C + ----------------
+ nbchar=VARSIZE(CORveg_dir)
+ OPEN (unit=40,status='old',
+ . file=CORveg_dir(1:nbchar)//'CORINEtab.txt')
+
+ READ(40,'(1x)')
+ READ(40,'(1x)')
+ READ(40,'(1x)')
+ READ(40,'(1x)')
+ DO kk=1,nclass
+ READ(40,*) iclass,(convert(kk,ll),ll=0,nsvat),Cnoveg(kk),
+ . Curban(kk),CORwat(kk),COR_z0(kk)
+ IF(kk.ne.iclass)THEN
+ write(*,*) 'CORveg: error reading CORINEtab.txt '
+ STOP
+ ENDIF
+ ENDDO
+ CLOSE (unit=40)
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Initialization
+C + ==============
+
+C Currently disabled because CORINE is intended to be used
+C "where data is available" only :
+C The initalisation should be performed in GLOveg (IGBP database),
+C and after this CORveg will change the values where
+C there are CORINE data available.
+
+ IF (.NOT.VEGdat) THEN
+ write(*,*) 'CORveg: '
+ write(*,*) '======= '
+ write(*,*) 'This routine should be used only after GLOveg'
+ write(*,*) 'Please activate GLOveg (set VEGdat to true)'
+ write(*,*) 'or see comments in CORveg ?'
+ STOP
+ ENDIF
+
+C -- Please delete this commented code in 2006 if still unused...
+C -- DO jj=1,my
+C -- DO ii=1,mx
+C --
+C -- DO kk=1,nvx-1
+C -- NSTsvt(ii,jj,kk)=0
+C -- NSTsfr(ii,jj,kk)=0
+C -- ENDDO
+C --
+C -- IF (NSTsol(ii,jj).ge.4) THEN ! Continental areas
+C -- NSTsvt(ii,jj,nvx)= 6
+C -- NSTsfr(ii,jj,nvx)=100
+C -- DO kk=1,nvx
+C -- NSTlai(ii,jj,kk) = 2.0
+C -- NSTglf(ii,jj,kk) = 1.0
+C -- ENDDO
+C --
+C -- ELSE
+C -- NSTsvt(ii,jj,nvx)= 0
+C -- NSTsfr(ii,jj,nvx)=100
+C -- DO kk=1,nvx
+C -- NSTlai(ii,jj,kk) = 0.0
+C -- NSTglf(ii,jj,kk) = 0.0
+C -- ENDDO
+C -- ENDIF
+C --
+C -- ENDDO
+C -- ENDDO
+
+ nFrNul=0
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Find coordinates of the NST grid meshes boundaries on the
+C + CORINE MAP (Lambert EA projection)
+C + ==========================================================
+
+ DO jj=1,my-1
+ DO ii=1,mx-1
+
+ reqlon = (NST__x(ii,jj) + NST__x(ii+1,jj+1)) / 2.
+ reqlat = (NST__y(ii,jj) + NST__y(ii+1,jj+1)) / 2.
+C + Approximation valid for "small" meshes of any orientation
+
+C + ***********
+ CALL lamphi2laea (xlaea,ylaea,reqlon*degrad,reqlat*degrad,
+ . lam0*degrad,phi0*degrad,radius)
+C + ***********
+
+ out_X (ii,jj) = xlaea
+ out_Y (ii,jj) = ylaea
+
+ ENDDO
+ ENDDO
+C
+C + Domain boundaries
+ DO ii=1,mx-1
+ out_X (ii,0) = 2. * out_X (ii,1) - out_X (ii,2)
+ out_Y (ii,0) = 2. * out_Y (ii,1) - out_Y (ii,2)
+ out_X (ii,my)= 2. * out_X (ii,my-1) - out_X (ii,my-2)
+ out_Y (ii,my)= 2. * out_Y (ii,my-1) - out_Y (ii,my-2)
+ ENDDO
+ DO jj=0,my
+ out_X (0,jj) = 2. * out_X (1,jj) - out_X (2,jj)
+ out_Y (0,jj) = 2. * out_Y (1,jj) - out_Y (2,jj)
+ out_X (mx,jj)= 2. * out_X (mx-1,jj) - out_X (mx-2,jj)
+ out_Y (mx,jj)= 2. * out_Y (mx-1,jj) - out_Y (mx-2,jj)
+ ENDDO
+
+C +---Read and "upscale" CORINE data
+C + ==============================
+
+
+C + Open the CORINE data file
+C + -------------------------
+
+ Ierror=NF_OPEN(CORveg_dir(1:nbchar)//'CORINE250.nc',
+ . NF_NOWRITE,CORcid)
+ Ierror=NF_INQ_VARID(CORcid,'x' ,AXX_ID)
+ Ierror=NF_INQ_VARID(CORcid,'y' ,AXY_ID)
+ Ierror=NF_GET_VAR_REAL(CORcid, AXX_ID, ainX)
+ Ierror=NF_GET_VAR_REAL(CORcid, AXY_ID, ainY)
+
+C + Read & upscale
+C + --------------
+
+C + ******
+ CALL UPScor (ainX, ainY, imx, imy, nclass,
+ . CORcid, 'luse', out_X, out_Y, corFRC)
+C + ******
+
+
+C +---Close Netcdf data file
+C + ----------------------
+ CALL UNCLOSE(CORcid)
+
+
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ DO jj=1,my
+ DO ii=1,mx
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Specific areas
+C ==============
+
+ FrMwat = 0.
+
+C +---Water areas
+C + -----------
+ DO kk=38,nclass
+ FrMwat = FrMwat + CORfrc(ii,jj,kk)
+ ENDDO
+
+C +---Forest areas
+C + ------------
+ FrMfor = (CORfrc(ii,jj,23)+CORfrc(ii,jj,24)+CORfrc(ii,jj,25))
+
+ IF (FrMfor.gt.0.8.and.RUGdat) THEN
+ FrMfor = MIN(1.0,FrMfor)
+C + ? NST_z0(ii,jj) = NST_z0(ii,jj) * (1.0-0.3*(FrMfor-0.8)/0.2)
+C + ? NST_r0(ii,jj) = 0.1*NST_z0(ii,jj)
+ ENDIF
+
+C +---No-data area in CORINE
+C ----------------------
+ FrMnul = CORfrc(ii,jj,49)
+ IF (FrMnul .GT. 0.5) THEN
+C WRITE (*,*) 'No-data area in CORINE (i,j,%) :'
+C WRITE (*,*) ii,jj,CORfrc(ii,jj,49)*100.
+ nFrNul=nFrNul+1
+ ENDIF
+
+
+C + **************************************************************
+ IF (FrMnul.lt.0.5) THEN ! Not undefined in CORINE
+ IF (FrMwat.lt.0.5) THEN ! continent
+C + **************************************************************
+
+ NSTsol(ii,jj)=4 ! unclear ==============================
+
+C +---Convertion of CORINE to SVAT classification
+C + ===========================================
+
+
+C +... initialisation
+C + ~~~~~~~~~~~~~~
+ DO ll=0,nsvat
+ FrAsSVT(ll)=0.
+ ENDDO
+
+C +... convertion to SVAT classes
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~
+ DO kk=1,nclass
+ DO ll=1,nsvat
+ FrAsSVT(ll)=FrAsSVT(ll)+convert(kk,ll)
+ . /100.*CORfrc(ii,jj,kk)
+ ENDDO
+ ENDDO
+
+C +... If too much classes / nvx -> aggregate some
+ AgNeed=.TRUE. ! First call must test if aggr. needed
+ AgFlag= 0 ! No aggregation performed here
+
+ CALL AgClasses(FrAsSVT,nsvat, 5, 6, AgNeed,AgFlag)
+ CALL AgClasses(FrAsSVT,nsvat, 5, 4, AgNeed,AgFlag)
+ CALL AgClasses(FrAsSVT,nsvat, 2, 1, AgNeed,AgFlag)
+ CALL AgClasses(FrAsSVT,nsvat, 2, 3, AgNeed,AgFlag)
+ CALL AgClasses(FrAsSVT,nsvat,11,10, AgNeed,AgFlag)
+ CALL AgClasses(FrAsSVT,nsvat,11,12, AgNeed,AgFlag)
+ CALL AgClasses(FrAsSVT,nsvat, 8, 7, AgNeed,AgFlag)
+ CALL AgClasses(FrAsSVT,nsvat, 8, 9, AgNeed,AgFlag)
+ CALL AgClasses(FrAsSVT,nsvat, 5, 2, AgNeed,AgFlag)
+ CALL AgClasses(FrAsSVT,nsvat, 8,11, AgNeed,AgFlag)
+
+C +... retain the nvx dominant classes
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ DO kk=1,nvx
+ lomi=0
+ DO ll=0,nsvat
+ IF (FrAsSVT(ll).GT.FrAsSVT(lomi)) THEN
+ lomi=ll
+ ENDIF
+ ENDDO
+ SVT_class(kk)=lomi
+ SVT_frac (kk)=FrAsSVT(lomi)
+ FrAsSVT(lomi)=0.0
+ ENDDO
+
+C +... normalizing the three dominant fractions
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ frac_tot=0.
+ DO ll=1,nvx
+ frac_tot=frac_tot+SVT_frac(ll)
+ ENDDO
+ IF (frac_tot.ne.0.) THEN
+ DO ll=1,nvx
+ SVT_frac(ll)=SVT_frac(ll)/frac_tot
+ ENDDO
+ ENDIF
+
+C +... attribute classes and fractions to NST variables
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ DO kk=1,nvx
+ NSTsvt(ii,jj,kk)= SVT_class(kk)
+ NSTsfr(ii,jj,kk)=NINT(SVT_frac (kk)*100.)
+ ENDDO
+
+C +---Final check of soil fractions
+C + =============================
+
+ frac_itot=0
+ DO ll=1,nvx
+ frac_itot=frac_itot+NSTsfr(ii,jj,ll)
+ ENDDO
+
+ IF (frac_itot.le.0) THEN ! Imposed bare soil
+ NSTsvt(ii,jj,nvx)= 0
+ NSTsfr(ii,jj,nvx)=100
+ DO kk=1,nvx-1
+ NSTsvt(ii,jj,kk)=0
+ NSTsfr(ii,jj,kk)=0
+ ENDDO
+ write(6,*) 'Warning : bare soil imposed for grid point ',ii,jj
+ . ,frac_itot
+ ENDIF
+
+
+C +---Define max leaf area index
+C + ==========================
+
+ DO ll=1,nvx
+
+ IF (NSTsvt(ii,jj,ll).eq. 0) NSTlmx(ii,jj,ll) = 0.0
+ IF (NSTsvt(ii,jj,ll).eq. 1) NSTlmx(ii,jj,ll) = 0.6
+ IF (NSTsvt(ii,jj,ll).eq. 2) NSTlmx(ii,jj,ll) = 0.9
+ IF (NSTsvt(ii,jj,ll).eq. 3) NSTlmx(ii,jj,ll) = 1.2
+ IF (NSTsvt(ii,jj,ll).eq. 4) NSTlmx(ii,jj,ll) = 0.7
+ IF (NSTsvt(ii,jj,ll).eq. 5) NSTlmx(ii,jj,ll) = 1.4
+ IF (NSTsvt(ii,jj,ll).eq. 6) NSTlmx(ii,jj,ll) = 2.0
+ IF (NSTsvt(ii,jj,ll).eq. 7.or.NSTsvt(ii,jj,ll).eq.10)
+ . NSTlmx(ii,jj,ll) = 3.0
+ IF (NSTsvt(ii,jj,ll).eq. 8.or.NSTsvt(ii,jj,ll).eq.11)
+ . NSTlmx(ii,jj,ll) = 4.5
+ IF (NSTsvt(ii,jj,ll).eq. 9.or.NSTsvt(ii,jj,ll).eq.12)
+ . NSTlmx(ii,jj,ll) = 6.0
+
+ NSTlai(ii,jj,ll) = NSTlmx(ii,jj,ll)
+ NSTglf(ii,jj,ll) = 1.0
+
+ ENDDO
+
+
+C + **************************************************************
+ ELSE ! Ocean / lake in CORINE
+C + **************************************************************
+
+ NSTsol(ii,jj) = 1 ! Water
+
+ NSTsvt(ii,jj,nvx)= 0
+ NSTsfr(ii,jj,nvx)=100
+ DO ll=1,nvx
+ NSTlai(ii,jj,ll) = 0.0
+ NSTglf(ii,jj,ll) = 0.0
+ ENDDO
+
+
+C + **************************************************************
+ ENDIF ! End of continent / water selection
+ ENDIF ! End of "not undefined in CORINE" section
+C + **************************************************************
+
+
+
+C +---Roughness
+C + =========
+C + (computed with all CORINE data, regardless of SISVAT subgrid nvx)
+
+
+ IF (FrMnul.lt.0.5.and.RUGdat) THEN ! CORINE data available
+ NST_z0(ii,jj)=0.0
+ DO kk=1,nclass
+ NST_z0(ii,jj)=NST_z0(ii,jj)+COR_z0(kk)*CORfrc(ii,jj,kk)
+ . /(1.0-FrMnul)
+C + NST_r0(ii,jj)=0.1*NST_z0(ii,jj)
+ ENDDO
+ ENDIF
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ENDDO
+ ENDDO
+
+ IF (nFrNul.GT.0) THEN
+ write(*,*) 'CORveg (info) : '
+ write(*,*) nFrNul,' points with no CORINE data'
+ write(*,*)
+ ENDIF
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ END
+
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+C + +++++++++++++++++++++ Minor Subroutines ++++++++++++++++++++++++++
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ SUBROUTINE AgClasses (FrAsSVT, nsvat,
+ . iAgCls, iDetCls, AgNeed, AgFlag)
+C
+C Purpose :
+C AgClasses checks that the number of classes whith a significant
+C fraction is not higher then the number of retained classes in
+C SISVAT (nvx). If so, the 2 provided class numbers are
+C "agregated" = the first gets the total fraction of both.
+C Aim of this = avoiding to drop an entire category of vegetation
+C simply because it is divided into "subclasses" which thus have
+C smaller fractions.
+
+ INCLUDE 'NSTdim.inc'
+ LOGICAL AgNeed
+ INTEGER AgFlag, iAgCls, iDetCls, kk, ll, nuclas
+ REAL FrAsSVT(0:nsvat), FrMin
+
+ PARAMETER (FrMin=0.1)
+
+ IF (AgNeed) THEN
+
+C + Count #classes abovre thereshold fraction
+ nuclas= 0
+ DO ll=0,nsvat
+ IF (FrAsSVT(ll).GT.FrMin) THEN
+ nuclas= nuclas + 1
+ ENDIF
+ ENDDO
+
+C + If too much used classes, aggregate
+ IF (nuclas.GT.nvx) THEN
+ FrAsSVT(iAgCls)= FrAsSVT(iAgCls) + FrAsSVT(iDetCls)
+ FrAsSVT(iDetCls)= 0.0
+ AgFlag=1
+ ELSE
+ AgNeed= .FALSE.
+ ENDIF
+
+
+ ENDIF
+ END
diff --git a/MAR/code_nestor/src/CPLhgd.f b/MAR/code_nestor/src/CPLhgd.f
new file mode 100644
index 0000000000000000000000000000000000000000..38d25842a43c3a1637e38c1894f4133a7aedf6d1
--- /dev/null
+++ b/MAR/code_nestor/src/CPLhgd.f
@@ -0,0 +1,342 @@
+C +-------------------------------------------------------------------+
+C + Subroutine CPLhgd January 2002 NESTING +
+C +-------------------------------------------------------------------+
+C + +
+C + Input : Parameters from MARgrd.ctr +
+C + ^^^^^^^ +
+C + +
+C + Output: Creation of the horizontal grid of MAR +
+C + ^^^^^^^ Variables : NST__x(mx,my) and NST__y(mx,my) (long./lat.) +
+C + NSTgdx(mx) and NSTgdy(my) (Lambert) +
+C + NST_dx (horizontal resolution) +
+C + +
+C +-------------------------------------------------------------------+
+
+
+ SUBROUTINE CPLhgd
+
+
+ IMPLICIT NONE
+
+
+C +---General variables
+C + -----------------
+
+ INCLUDE 'NSTdim.inc'
+ INCLUDE 'NSTvar.inc'
+
+C +---Local variables
+C + ---------------
+
+ INTEGER i,j,i1,i2,i3,ilat_min,ilat_max,ilon_min,
+ . ilon_max,mmx,mmy,imez,jmez
+
+ REAL degrad,MinLon,MaxLon,MinLat,MaxLat,long1,lati1,
+ . long2,lati2,long3,lati3,long4,lati4
+
+ REAL long_tmp(4),lati_tmp(4),lati_min,lati_max,
+ . long_min,long_max,auxlong,auxlati,vlon(4),vlat(4),
+ . dx,dy,delta_lon,delta_lat,center_lon,center_lat
+
+
+C +---Constants
+C + ---------
+
+ DATA degrad / 1.745329252d-2/
+C +... degrad : Conversion Factor: Radian --> Degrees
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Check validity of array dimensions
+C + ==================================
+
+ mmx = mx
+ mmy = my
+
+ IF (mmx.ne.3.or.mmy.ne.3) THEN
+ WRITE(6,*) ' '
+ WRITE(6,*) 'CPL (SVAT coupling) is valid only when mx = 3 and'
+ WRITE(6,*) 'my = 3 in NSTdim.inc.'
+ WRITE(6,*) 'Please modify these parameters and rerun NESTOR.'
+ WRITE(6,*) ' '
+ WRITE(6,*) 'STOP in CPLhgd.f'
+ WRITE(6,*) ' '
+ STOP
+ ENDIF
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---READING OF GRID PARAMETERS IN CPLgrd.ctr
+C + ========================================
+
+ OPEN (unit=51,status='old',file='CPLgrd.ctr')
+
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) long1
+ read (51,*) lati1
+ read (51,*) long2
+ read (51,*) lati2
+ read (51,*) long3
+ read (51,*) lati3
+ read (51,*) long4
+ read (51,*) lati4
+ccccc read (51,*) !- - - - - - - - - - - - - - - - - -
+ccccc read (51,*) ptopDY
+ccccc read (51,*) !- - - - - - - - - - - - - - - - - -
+ccccc read (51,*) zmin
+ccccc read (51,*) aavu
+ccccc read (51,*) bbvu
+ccccc read (51,*) ccvu
+ccccc read (51,*) !- - - - - - - - - - - - - - - - - -
+ccccc read (51,'(l4)') vertic
+ccccc read (51,*) !- - - - - - - - - - - - - - - - - -
+ccccc read (51,*) sst_SL
+ccccc read (51,*) !- - - - - - - - - - - - - - - - - -
+
+ CLOSE(unit=51)
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Ordering input grid points
+C + --------------------------
+
+C +...Temporary arrays
+
+ long_tmp(1) = long1
+ long_tmp(2) = long2
+ long_tmp(3) = long3
+ long_tmp(4) = long4
+ lati_tmp(1) = lati1
+ lati_tmp(2) = lati2
+ lati_tmp(3) = lati3
+ lati_tmp(4) = lati4
+
+C +...Search for minimum and maximum latitudes
+
+ lati_min = lati_tmp(1)
+ ilat_min = 1
+ lati_max = lati_tmp(1)
+ ilat_max = 1
+ DO i=2,4
+ IF (lati_tmp(i).lt.lati_min) THEN
+ lati_min = lati_tmp(i)
+ ilat_min = i
+ ENDIF
+ IF (lati_tmp(i).gt.lati_max) THEN
+ lati_max = lati_tmp(i)
+ ilat_max = i
+ ENDIF
+ ENDDO
+
+C +...Grid point of minimum latitude becomes the first grid point
+
+ auxlong = long_tmp(1)
+ auxlati = lati_tmp(1)
+ long_tmp(1) = long_tmp(ilat_min)
+ lati_tmp(1) = lati_tmp(ilat_min)
+ long_tmp(ilat_min) = auxlong
+ lati_tmp(ilat_min) = auxlati
+
+C +...Grid point of maximum latitude becomes the fourth grid point
+
+ auxlong = long_tmp(4)
+ auxlati = lati_tmp(4)
+ long_tmp(4) = long_tmp(ilat_max)
+ lati_tmp(4) = lati_tmp(ilat_max)
+ long_tmp(ilat_max) = auxlong
+ lati_tmp(ilat_max) = auxlati
+
+C +...Search for the next minimum latitude
+
+ lati_min = lati_tmp(2)
+ ilat_min = 2
+ DO i=3,4
+ IF (lati_tmp(i).lt.lati_min) THEN
+ lati_min = lati_tmp(i)
+ ilat_min = i
+ ENDIF
+ ENDDO
+
+C +...Grid point of next minimum latitude becomes grid point 2
+
+ auxlong = long_tmp(2)
+ auxlati = lati_tmp(2)
+ long_tmp(2) = long_tmp(ilat_min)
+ lati_tmp(2) = lati_tmp(ilat_min)
+ long_tmp(ilat_min) = auxlong
+ lati_tmp(ilat_min) = auxlati
+
+C +...Exchange grid points 1 and 2 if necessary (depending on their long.)
+
+ IF (long_tmp(2).lt.long_tmp(1)) THEN
+ auxlong = long_tmp(2)
+ auxlati = lati_tmp(2)
+ long_tmp(2) = long_tmp(1)
+ lati_tmp(2) = lati_tmp(1)
+ long_tmp(1) = auxlong
+ lati_tmp(1) = auxlati
+ ENDIF
+
+C +...Search for the next maximum latitude
+
+ lati_max = lati_tmp(1)
+ ilat_max = 1
+ DO i=2,3
+ IF (lati_tmp(i).gt.lati_max) THEN
+ lati_max = lati_tmp(i)
+ ilat_max = i
+ ENDIF
+ ENDDO
+
+C +...Grid point of next maximum latitude becomes grid point 3
+
+ auxlong = long_tmp(3)
+ auxlati = lati_tmp(3)
+ long_tmp(3) = long_tmp(ilat_max)
+ lati_tmp(3) = lati_tmp(ilat_max)
+ long_tmp(ilat_max) = auxlong
+ lati_tmp(ilat_max) = auxlati
+
+C +...Exchange grid points 3 and 4 if necessary (depending on their long.)
+
+ IF (long_tmp(3).lt.long_tmp(4)) THEN
+ auxlong = long_tmp(4)
+ auxlati = lati_tmp(4)
+ long_tmp(4) = long_tmp(3)
+ lati_tmp(4) = lati_tmp(3)
+ long_tmp(3) = auxlong
+ lati_tmp(3) = auxlati
+ ENDIF
+
+C +...Store ordered lat/long
+
+ DO i=1,4
+ vlon(i) = long_tmp(i)
+ vlat(i) = lati_tmp(i)
+ ENDDO
+
+C +...Center of the cell
+
+ center_lon = 0.25*(vlon(1)+vlon(2)+vlon(3)+vlon(4))
+ center_lat = 0.25*(vlat(1)+vlat(2)+vlat(3)+vlat(4))
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---HORIZONTAL RESOLUTION
+C + =====================
+
+ delta_lon = ABS(vlon(2)-vlon(1)+vlon(3)-vlon(4))
+ delta_lat = ABS(vlat(4)-vlat(1)+vlat(3)-vlat(2))
+
+ dx = 0.5*delta_lon*111111.0
+ dy = 0.5*delta_lat*111111.0 * ABS(COS(vlat(1)/degrad))
+
+ NST_dx=MAX(dx,dy)
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---CREATION OF HORIZONTAL MAR GRID
+C + ===============================
+
+
+C +---Domain reference grid point
+C + ---------------------------
+
+ IF (imez.lt.0.or.imez.gt.mx) imez = 2
+ IF (jmez.lt.0.or.jmez.gt.my) jmez = 2
+
+
+C +---Simple grid (Lambert coordinates)
+C + ---------------------------------
+
+ DO i=1,mx
+ NSTgdx(i)=(i-imez)*dx/1000.
+ ENDDO
+
+ DO j=1,my
+ NSTgdy(j)=(j-jmez)*dy/1000.
+ ENDDO
+
+
+C +---Create NST grid
+C + ---------------
+
+ i1 = 1
+ i2 = 2
+ i3 = 3
+
+ NST__x(i2,i2) = center_lon
+ NST__y(i2,i2) = center_lat
+
+ NST__x(i1,i1) = NST__x(i2,i2) - 2.0*ABS(center_lon-vlon(1))
+ NST__y(i1,i1) = NST__y(i2,i2) - 2.0*ABS(center_lat-vlat(1))
+ NST__x(i3,i1) = NST__x(i2,i2) + 2.0*ABS(center_lon-vlon(2))
+ NST__y(i3,i1) = NST__y(i2,i2) - 2.0*ABS(center_lat-vlat(2))
+ NST__x(i1,i3) = NST__x(i2,i2) - 2.0*ABS(center_lon-vlon(4))
+ NST__y(i1,i3) = NST__y(i2,i2) + 2.0*ABS(center_lat-vlat(4))
+ NST__x(i3,i3) = NST__x(i2,i2) + 2.0*ABS(center_lon-vlon(3))
+ NST__y(i3,i3) = NST__y(i2,i2) + 2.0*ABS(center_lat-vlat(3))
+ NST__x(i2,i1) = 0.5*(vlon(1)+vlon(2))
+ NST__y(i2,i1) = NST__y(i2,i2)
+ . - 1.0*ABS(2.0*center_lat-vlat(1)-vlat(2))
+ NST__x(i2,i3) = 0.5*(vlon(3)+vlon(4))
+ NST__y(i2,i3) = NST__y(i2,i2)
+ . + 1.0*ABS(2.0*center_lat-vlat(3)-vlat(4))
+ NST__x(i1,i2) = NST__x(i2,i2)
+ . - 1.0*ABS(2.0*center_lon-vlon(1)-vlon(4))
+ NST__y(i1,i2) = 0.5*(vlat(1)+vlat(4))
+ NST__x(i3,i2) = NST__x(i2,i2)
+ . + 1.0*ABS(2.0*center_lon-vlon(2)-vlon(3))
+ NST__y(i3,i2) = 0.5*(vlat(2)+vlat(3))
+
+
+C +---Compute horizontal extent of the horizontal domain
+C + --------------------------------------------------
+
+ MinLon = NST__x(1,1)
+ MaxLon = NST__x(1,1)
+ MinLat = NST__y(1,1)
+ MaxLat = NST__y(1,1)
+ DO j=1,my
+ DO i=1,mx
+ MinLon = MIN(NST__x(i,j),MinLon)
+ MaxLon = MAX(NST__x(i,j),MaxLon)
+ MinLat = MIN(NST__y(i,j),MinLat)
+ MaxLat = MAX(NST__y(i,j),MaxLat)
+ ENDDO
+ ENDDO
+
+
+C +---Print the characteristics of the horizontal grid
+C + ------------------------------------------------
+
+ write(6,*) 'Horizontal CPL grid created'
+ write(6,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+ write(6,200) mx,my,dx/1000.,dy/1000.,
+ . MinLon,MaxLon,MinLat,MaxLat
+200 format(' Grid points : ',i4,' * ',i4,/,
+ . ' Horizontal resol. (X) : ',f7.1,' km.',/,
+ . ' Horizontal resol. (Y) : ',f7.1,' km.',/,
+ . ' MAR longitude between : ',f7.2,' and ',f7.2,/,
+ . ' MAR latitude between : ',f7.2,' and ',f7.2,/)
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+ RETURN
+ END
+
diff --git a/MAR/code_nestor/src/CPLvgd.f b/MAR/code_nestor/src/CPLvgd.f
new file mode 100644
index 0000000000000000000000000000000000000000..75b5c46598bee97ca3f75e95594e0bf02035be7c
--- /dev/null
+++ b/MAR/code_nestor/src/CPLvgd.f
@@ -0,0 +1,166 @@
+C +-------------------------------------------------------------------+
+C | Subroutine CPLvgd 15-04-2022 JFG |
+C +-------------------------------------------------------------------+
+C | |
+C | Creation of the vertical grid of the MAR model (as NST output) |
+C | (SVAT coupling). |
+C | |
+C | Input : - nz : number of vertical levels (N.B.: nz rather |
+C | ^^^^^^^ than nk because nk already used in NSTdim.inc) |
+C | - klev : if specified, the level at which pressure and |
+C | hybrid coordinate has to be computed |
+C | - VGD_sp(mx,my) : surface pressure (kPa) |
+C | - parameters from CPLgrd.ctr |
+C | - dimensions from NSTdim.inc (e.g. mx, my) |
+C | |
+C | Output: Vertical MAR grid given in hybrid coordinates : |
+C | ^^^^^^^ - VGD__p(mx,my,nz+1) : pressure coordinates (kPa) |
+C | - VGD_hp(mx,my,nz+1) : local hybrid coord. for vertical |
+C | interpolation |
+C | - VGDgdz(nz ) : model coordinates (sigma) |
+C | |
+C | J.-F. Grailet remark: contrary to LSCvgd and its associated |
+C | routines, VGDgdz has been kept because it appears to be actually |
+C | used in a meaningful way by NESTOR (could be checked thoroughly). |
+C | Only change here is the position of the parameter in the list. |
+C | |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE CPLvgd (nz,klev,VGD_sp,VGD__p,VGD_hp,VGDgdz)
+
+ IMPLICIT NONE
+
+ INCLUDE 'NSTdim.inc'
+
+C +---Local variables
+C + ---------------
+
+ INTEGER nz,klev,i,j,k,k1,k2
+
+ ! J.-F. Grailet remark: GElat0, GElon0 + others seem unused.
+ REAL pp1,pps,ppm,dpsl,pp,hh,ppf,GElat0,GElon0,dx,GEddxx,
+ . ptopDY,zmin,aavu,bbvu,ccvu,sst_SL,TUkhmx,long1,lati1,
+ . long2,lati2,long3,lati3,long4,lati4
+
+ REAL VGD_sp(mx,my),VGD__p(mx,my,nz+1),VGD_hp(mx,my,nz+1),
+ . VGDgdz(nz),sigma(nz)
+
+ LOGICAL vertic
+
+ CHARACTER*10 var_units
+
+C +---CREATION OF SIGMA MAR GRID USING PARAMETERS IN CPLgrd.ctr
+C + =========================================================
+
+C +---Read grid parameters in CPLgrd.ctr
+C + ----------------------------------
+
+ OPEN (unit=51,status='old',file='CPLgrd.ctr')
+
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) long1
+ read (51,*) lati1
+ read (51,*) long2
+ read (51,*) lati2
+ read (51,*) long3
+ read (51,*) lati3
+ read (51,*) long4
+ read (51,*) lati4
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) ptopDY
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) zmin
+ read (51,*) aavu
+ read (51,*) bbvu
+ read (51,*) ccvu
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,'(l4)') vertic
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) sst_SL
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+
+ CLOSE(unit=51)
+
+C +---Sets the standard values of vertical grid parameters
+C + ----------------------------------------------------
+
+ CALL SETsig (nz,zmin,aavu,bbvu,ccvu,ptopDY)
+
+C +---Computation of vertical grid
+C + ----------------------------
+
+ CALL GRDsig (nz,zmin,aavu,bbvu,ccvu,vertic,sst_SL,TUkhmx,sigma)
+
+C +---Print the characteristics of the vertical grid
+C + ----------------------------------------------
+
+ write(6,*) 'Vertical CPL grid parameters'
+ write(6,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+ write(6,300) nz,ptopDY
+300 format(' Number of grid points : ',i4,/,
+ . ' Pressure at the top : ',f9.4,' kPa.')
+ write(6,310) zmin, aavu, bbvu, ccvu
+310 format(' First level height : ', f6.1,/,
+ . ' aavu, bbvu, ccvu : ',(f6.1,', ',f6.1,', ',f6.1),/)
+
+C +---Sigma coordinates
+C + -----------------
+
+ DO k=1,nz
+ VGDgdz(k)=sigma(k)
+ ENDDO
+
+C +---HYBRID AND PRESSURE COORDINATES (required by the nesting code)
+C + ===============================
+
+C +---Reference levels for hybrid coordinates
+C + ---------------------------------------
+
+ pp1 = 105. ! Reference pressure (KPa)
+ dpsl = 20. ! "> boundary layer" (KPa)
+
+C +---Selection of vertical levels
+C + ----------------------------
+
+ IF ((klev.le.0).or.(klev.gt.nz)) THEN
+ k1=1
+ k2=nz
+ ELSE
+ k1=1
+ k2=klev
+ ENDIF
+
+C +---For each i,j pixel (start of grid traversal)
+C + --------------------------------------------
+
+ DO i=1,mx
+ DO j=1,my
+
+C +---Computation of hybrid coordinates used in vertic. interp.
+C + ---------------------------------------------------------
+
+ pps = VGD_sp(i,j)
+ ppm = pps - dpsl
+ DO k = k1,k2+1
+ IF (k.eq.(nz+1)) THEN
+ pp = VGD_sp(i,j)
+ ELSE
+ pp = VGDgdz(k)*(VGD_sp(i,j)-ptopDY) + ptopDY
+ ENDIF
+ hh = pp/pp1
+ IF (pp.gt.ppm) THEN
+ ppf= (pp-ppm)/(pps-ppm)
+ hh = hh + (pp1-pps)/pp1 * ppf * ppf
+ END IF
+ VGD_hp(i,j,k) = LOG(hh)
+ VGD__p(i,j,k) = pp
+ ENDDO
+
+ END DO; END DO ! End of grid traversal
+
+ RETURN
+ END
+
diff --git a/MAR/code_nestor/src/CTRvar.inc b/MAR/code_nestor/src/CTRvar.inc
new file mode 100644
index 0000000000000000000000000000000000000000..626b1f9afa6f595949d9c119fc0deee383f64f33
--- /dev/null
+++ b/MAR/code_nestor/src/CTRvar.inc
@@ -0,0 +1,15 @@
+
+C +---Control parameters
+C + ------------------
+
+ LOGICAL lfirst_LSC,lfirst_NST
+
+ COMMON / TPARAM / lfirst_LSC,lfirst_NST
+
+
+C +---Grid control parameters (XXXgrd.ctr)
+C + ------------------------------------
+
+ REAL NSTfis
+
+ COMMON / GRDctr / NSTfis
diff --git a/MAR/code_nestor/src/Compile.info b/MAR/code_nestor/src/Compile.info
new file mode 100644
index 0000000000000000000000000000000000000000..18b5f389eaf22a29aa510cfa2f4d829b5e89a7f5
--- /dev/null
+++ b/MAR/code_nestor/src/Compile.info
@@ -0,0 +1,6 @@
+OpenSuse/RedHat Linux (tested with ifort 19.0, 18.0, 12.0, 11.1 and 10.1)
+ifort
+ifort is /opt/intel-19/compilers_and_libraries_2019.5.281/linux/bin/intel64/ifort
+-w -zero -static -vec_report0 -mp1 -ipo -ipo-jobs4 -O3 -xSSE4.2 -traceback
+-lnetcdf_ifort
+/usr/include/netcdf.inc
diff --git a/MAR/code_nestor/src/DATcnv.f b/MAR/code_nestor/src/DATcnv.f
new file mode 100644
index 0000000000000000000000000000000000000000..bfaa92584b7e584013164dcad8d0edaba634bdc3
--- /dev/null
+++ b/MAR/code_nestor/src/DATcnv.f
@@ -0,0 +1,189 @@
+C +-------------------------------------------------------------------+
+C | Subroutine DATcnv May 2001 NESTING |
+C +-------------------------------------------------------------------+
+C | |
+C | Input : Date : year, month, day, hour |
+C | ^^^^^^^ or I_date (integer) |
+C | datTOint : if true, transformation from date to I_date |
+C | if false,transformation from I_date to date |
+C | |
+C | Output: I_date (integer) |
+C | ^^^^^^^ or Date (year, month, day, hour) |
+C | |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE DATcnv (year,month,day,hour,I_date,datTOint)
+
+
+ IMPLICIT NONE
+
+ INCLUDE 'LSCmod.inc'
+
+ INTEGER imonth,year,month,day,hour,i,Nmonth(12),Nhour(0:12),
+ . nday,nextnh,iyear
+
+ INTEGER*4 I_date,N_date,nyhour
+ INTEGER y365, y366
+
+ LOGICAL datTOint
+
+
+C +---Number of days in each month
+C + ----------------------------
+
+ DATA (Nmonth(i),i=1,12)
+ . /31, ! January
+ . 28, ! February
+ . 31, ! March
+ . 30, ! April
+ . 31, ! May
+ . 30, ! June
+ . 31, ! July
+ . 31, ! August
+ . 30, ! September
+ . 31, ! October
+ . 30, ! November
+ . 31/ ! December
+
+ IF (M30d) THEN ! For specific models (e.g. CM3): 30 days/month
+ DO i=1,12
+ Nmonth(i)=30
+ ENDDO
+ y365 = 360
+ y366 = 360
+ ELSE
+ y365 = 365
+ y366 = 366
+ if(f28d) y366 = 365
+ ENDIF
+
+
+C + ******************
+ IF (datTOint) THEN
+C + ******************
+
+
+C +---Case of bisextil year
+C + ---------------------
+ IF (.not.M30d.and..not.f28d) THEN
+ IF (mod(year,4).eq.0.and.(mod(year,100).ne.0
+ . .or.mod(year,400).eq.0)) THEN
+ Nmonth(2)=29
+ ELSE
+ Nmonth(2)=28
+ ENDIF
+ ENDIF
+
+C +---Convertion in hours
+C + -------------------
+
+ nday =0
+ Nhour(0)=0
+
+ DO i=1,12
+ nday =nday+Nmonth(i)
+ Nhour(i)=nday*24
+ ENDDO
+
+
+C +---Hours from year 0 to the considered year
+C + ----------------------------------------
+
+ nyhour = 0
+
+ DO iyear=0,year-1
+ IF (mod(iyear,4).eq.0.and.(mod(iyear,100).ne.0
+ . .or.mod(iyear,400).eq.0)) THEN
+ nyhour = nyhour + y366*24
+ ELSE
+ nyhour = nyhour + y365*24
+ ENDIF
+ ENDDO
+
+C +---Convert from DATE to I_date
+C + ---------------------------
+
+ I_date=nyhour+Nhour(month-1)+(day-1)*24+hour
+
+
+C + ****
+ ELSE
+C + ****
+
+
+C +---Search for year
+C + ---------------
+
+ nyhour = I_date
+
+ iyear = 0
+ nextnh = y366*24
+
+ DO WHILE (nyhour.ge.nextnh)
+ nyhour = nyhour - nextnh
+ iyear = iyear + 1
+ IF (mod(iyear,4).eq.0.and.(mod(iyear,100).ne.0
+ . .or.mod(iyear,400).eq.0)) THEN
+ nextnh = y366*24
+ ELSE
+ nextnh = y365*24
+ ENDIF
+ ENDDO
+
+ year = iyear
+ N_date = nyhour
+
+
+C +---Case of bisextil year
+C + ---------------------
+ IF (.not.M30d.and..not.f28d) THEN
+ IF (mod(year,4).eq.0.and.(mod(year,100).ne.0
+ . .or.mod(year,400).eq.0)) THEN
+
+ Nmonth(2)=29
+ ELSE
+ Nmonth(2)=28
+ ENDIF
+ ENDIF
+
+
+
+C +---Convertion in hours
+C + -------------------
+
+ nday =0
+ Nhour(0)=0
+
+ DO i=1,12
+ nday =nday+Nmonth(i)
+ Nhour(i)=nday*24
+ ENDDO
+
+
+C +---Convert from I_date to DATE
+C + ---------------------------
+
+ imonth=0
+
+ DO i=1,12
+ IF ((N_date.ge.Nhour(i-1)).and.(N_date.lt.Nhour(i))) imonth=i
+ ENDDO
+
+ IF (imonth.eq.0) THEN
+ write(6,*) 'I_date =',N_date,' cannot be converted.'
+ write(6,*) 'STOP.'
+ STOP
+ ENDIF
+
+ month=imonth
+ day =AINT(REAL(N_date-Nhour(month-1))/24.) + 1
+ hour =N_date-Nhour(month-1)-24*(day-1)
+
+
+C + *****
+ ENDIF
+C + *****
+
+
+ RETURN
+ END
diff --git a/MAR/code_nestor/src/DEShgd.f b/MAR/code_nestor/src/DEShgd.f
new file mode 100644
index 0000000000000000000000000000000000000000..ae103d509263a1c79ee8d8182bebe370199525bf
--- /dev/null
+++ b/MAR/code_nestor/src/DEShgd.f
@@ -0,0 +1,351 @@
+C +-------------------------------------------------------------------+
+C + Subroutine DEShgd 21/09/2004 NESTING +
+C +-------------------------------------------------------------------+
+C + +
+C + Input : Parameters from MARgrd.ctr +
+C + ^^^^^^^ +
+C + +
+C + Output: Creation of the horizontal grid of MAR +
+C + ^^^^^^^ Variables : NST__x(mx,my) and NST__y(mx,my) (long./lat.) +
+C + NSTgdx(mx) and NSTgdy(my) (Lambert) +
+C + NST_dx (horizontal resolution) +
+C + +
+C +-------------------------------------------------------------------+
+
+
+ SUBROUTINE DEShgd
+
+
+ IMPLICIT NONE
+
+
+C +---General variables
+C + -----------------
+
+ INCLUDE 'NSTdim.inc'
+ INCLUDE 'NESTOR.inc'
+ INCLUDE 'NSTvar.inc'
+ INCLUDE 'LSCvar.inc'
+ INCLUDE 'DESvar.inc'
+ INCLUDE 'MARvar.inc'
+
+C +---Local variables
+C + ---------------
+
+ INTEGER i,j,fID,iloc,jloc
+
+ REAL degrad,MinLon,MaxLon,MinLat,MaxLat,lwblon,upblon,
+ . lwblat,upblat,empty1(1),dist,distmin,LSC_dx,LSC_dy
+
+ CHARACTER*7 namlon,namlat,nam_SH
+ CHARACTER*10 var_units
+ CHARACTER*100 LSCtit
+
+
+C +---Constants
+C + ---------
+
+ DATA degrad / 1.745329252d-2/
+C +... degrad : Conversion Factor: Radian --> Degrees
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---READING OF GRID PARAMETERS IN MARgrd.ctr
+C + ========================================
+
+ OPEN (unit=51,status='old',file='MARgrd.ctr')
+
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) maptyp
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) GElon0
+ read (51,*) imez
+ read (51,*) GElat0
+ read (51,*) jmez
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) dx
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) GEddxx
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) ptopDY
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) zmin
+ read (51,*) aavu
+ read (51,*) bbvu
+ read (51,*) ccvu
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,'(l4)') vertic
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) sst_SL
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+
+ CLOSE(unit=51)
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---HORIZONTAL RESOLUTION
+C + =====================
+
+ dx = dx * 1000.
+ dy = dx
+
+ NST_dx=dx
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---CREATION OF HORIZONTAL MAR GRID
+C + ===============================
+
+
+C +---Domain reference grid point
+C + ---------------------------
+
+ IF (imez.le.0.or.imez.gt.mx) imez = mx/2
+ IF (jmez.le.0.or.jmez.gt.my) jmez = my/2
+
+
+C +---Compute interpolated horizontal grid
+C + ------------------------------------
+
+ OPEN (unit=52,status='old',file='LSCfil.dat')
+ READ (52,'(a100)',END=230) LSCfil
+ GOTO 240
+
+230 write(6,*) 'No file found in LSCfil.dat.'
+ write(6,*) 'STOP in DEShgd.f'
+ STOP
+
+240 CONTINUE
+ CLOSE(unit=52)
+
+C + *******
+ CALL UNropen (LSCfil,fID,LSCtit)
+C + *******
+
+
+C +---Screen message
+C + --------------
+
+ write(6,*) 'Map projection: interpolation from LSC grid'
+ write(6,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+ write(6,*) 'Open file : ',LSCfil
+
+
+C +---Read LSC (input) grid
+C + ---------------------
+
+ lwblon = -400.0
+ upblon = 400.0
+ lwblat = -100.0
+ upblat = 100.0
+
+ IF (LSCmod.eq.'MAR') THEN
+ namlon='lon'
+ namlat='lat'
+ nam_SH='sh'
+ ELSE
+ IF (LSCmod.eq.'NCP') THEN
+ namlon='lon'
+ namlat='lat'
+ nam_SH='SH'
+ ELSE
+ namlon='lon'
+ namlat='lat'
+ nam_SH='SH'
+ ENDIF
+ ENDIF
+
+ IF (REGgrd) THEN
+
+C + ******
+ CALL UNread (fID,nam_SH,1,1,bi,bj,ni,nj,1,
+ . LSC1Dx,LSC1Dy,empty1,var_units,LSC_sh)
+C + ******
+
+ DO j=1,nj
+ DO i=1,ni
+ LSC__x(i,j)=LSC1Dx(i)
+ LSC__y(i,j)=LSC1Dy(j)
+ ENDDO
+ ENDDO
+
+ ELSE
+
+C + ******
+ CALL UNread (fID,namlon,1,1,bi,bj,ni,nj,1,
+ . LSC1Dx,LSC1Dy,empty1,var_units,LSC__x)
+C + ******
+ CALL VALchk (namlon,ni,nj,LSC__x,lwblon,upblon)
+C + ******
+ CALL UNread (fID,namlat,1,1,bi,bj,ni,nj,1,
+ . LSC1Dx,LSC1Dy,empty1,var_units,LSC__y)
+C + ******
+ CALL VALchk (namlat,ni,nj,LSC__y,lwblat,upblat)
+C + ******
+
+ ENDIF
+
+
+ IF (LSCmod.eq.'MAR') THEN
+ LSC_dx = (LSC1Dx(2)-LSC1Dx(1))*1000.
+ LSC_dy = (LSC1Dy(2)-LSC1Dy(1))*1000.
+ ELSE
+ LSC_dx = ABS(LSC__x(ni/2+1,nj/2)-LSC__x(ni/2,nj/2))
+ . * 111111.11111*ABS(COS(LSC__y(ni/2,nj/2)/degrad))
+ LSC_dy = ABS(LSC__y(ni/2,nj/2+1)-LSC__y(ni/2,nj/2))
+ . * 111111.11111
+ ENDIF
+
+
+C +---Close the NetCDF file
+C + =====================
+
+C + *******
+ CALL UNclose (fID)
+C + *******
+
+
+C +---Factor between LSC and NST resolutions
+C + --------------------------------------
+
+ fdiv = NINT(MAX(LSC_dx,LSC_dy)/NST_dx)
+
+
+C +---Compute new horizontal resolution
+C + ---------------------------------
+
+ NST_dx = LSC_dx / REAL(fdiv)
+
+
+C +---Simple grid (Lambert coordinates)
+C + ---------------------------------
+
+ DO i=1,mx
+ NSTgdx(i)=(i-imez)*LSC_dx/REAL(fdiv)/1000.
+ ENDDO
+
+ DO j=1,my
+ NSTgdy(j)=(j-jmez)*LSC_dy/REAL(fdiv)/1000.
+ ENDDO
+
+
+C +---Compute NST grid
+C + ----------------
+
+ iloc = -1
+ jloc = -1
+ distmin = 1.d+30
+
+ DO j=1,nj
+ DO i=1,ni
+ dist = SQRT( (LSC__x(i,j)-GElon0)**2.
+ . + (LSC__y(i,j)-GElat0)**2. )
+ IF (dist.lt.distmin) THEN
+ distmin = dist
+ iloc = i ! This point will correspond to imez in NST
+ jloc = j ! This point will correspond to jmez in NST
+ ENDIF
+ ENDDO
+ ENDDO
+
+ IF (iloc.eq.-1.or.jloc.eq.-1) THEN
+ write(6,*) 'The center of NST grid is not included in LSC grid.'
+ write(6,*) 'STOP in DEShgd.f'
+ STOP
+ ENDIF
+
+
+C +---Define transfer of index
+C + ------------------------
+
+ DO j=1,my
+ DO i=1,mx
+ iiL2N(i,j) = ((i-imez+(imez*fdiv))/fdiv) - imez + iloc
+ jjL2N(i,j) = ((j-jmez+(jmez*fdiv))/fdiv) - jmez + jloc
+ IF (iiL2N(i,j).lt.1.or.iiL2N(i,j).gt.ni.or.
+ . jjL2N(i,j).lt.1.or.jjL2N(i,j).gt.nj) THEN
+ write(6,*) 'The NST grid is outside the LSC grid.'
+ write(6,*) 'Please check the definition of the NST domain.'
+ write(6,*) i,j,iiL2N(i,j),jjL2N(i,j)
+ write(6,*) 'STOP in DEShgd.f'
+ STOP
+ ENDIF
+ ENDDO
+ ENDDO
+
+
+C +---Create NST grid
+C + ---------------
+
+ DO j=1,my
+ DO i=1,mx
+
+ auxL2N(i,j) = REAL(MOD(i-imez+(imez*fdiv),fdiv)) / REAL(fdiv)
+ auyL2N(i,j) = REAL(MOD(j-jmez+(jmez*fdiv),fdiv)) / REAL(fdiv)
+
+ NST__x(i,j) = auxL2N(i,j)
+ . * ( auyL2N(i,j)*LSC__x(iiL2N(i,j)+1,jjL2N(i,j)+1)
+ . +(1-auyL2N(i,j))*LSC__x(iiL2N(i,j)+1,jjL2N(i,j) ))
+ . + (1.0-auxL2N(i,j))
+ . * ( auyL2N(i,j)*LSC__x(iiL2N(i,j) ,jjL2N(i,j)+1)
+ . +(1-auyL2N(i,j))*LSC__x(iiL2N(i,j) ,jjL2N(i,j) ))
+
+ NST__y(i,j) = auxL2N(i,j)
+ . * ( auyL2N(i,j)*LSC__y(iiL2N(i,j)+1,jjL2N(i,j)+1)
+ . +(1-auyL2N(i,j))*LSC__y(iiL2N(i,j)+1,jjL2N(i,j) ))
+ . + (1.0-auxL2N(i,j))
+ . * ( auyL2N(i,j)*LSC__y(iiL2N(i,j) ,jjL2N(i,j)+1)
+ . +(1-auyL2N(i,j))*LSC__y(iiL2N(i,j) ,jjL2N(i,j) ))
+
+ ENDDO
+ ENDDO
+
+
+C +---Compute horizontal extent of the horizontal domain
+C + --------------------------------------------------
+
+ MinLon = NST__x(1,1)
+ MaxLon = NST__x(1,1)
+ MinLat = NST__y(1,1)
+ MaxLat = NST__y(1,1)
+ DO j=1,my
+ DO i=1,mx
+ MinLon = MIN(NST__x(i,j),MinLon)
+ MaxLon = MAX(NST__x(i,j),MaxLon)
+ MinLat = MIN(NST__y(i,j),MinLat)
+ MaxLat = MAX(NST__y(i,j),MaxLat)
+ ENDDO
+ ENDDO
+
+
+C +---Print the characteristics of the horizontal grid
+C + ------------------------------------------------
+
+ write(6,*) 'Horizontal MAR grid created'
+ write(6,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+ write(6,200) mx,my,LSC_dx/REAL(fdiv)/1000.,
+ . LSC_dy/REAL(fdiv)/1000.,GEddxx,
+ . MinLon,MaxLon,MinLat,MaxLat
+200 format(' Grid points : ',i4,' * ',i4,/,
+ . ' Horizontal resol. (X) : ',f7.1,' km.',/,
+ . ' Horizontal resol. (Y) : ',f7.1,' km.',/,
+ . ' Domain orientation : ',f7.0,' deg.',/,
+ . ' MAR longitude between : ',f7.2,' and ',f7.2,/,
+ . ' MAR latitude between : ',f7.2,' and ',f7.2,/)
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+ RETURN
+ END
+
diff --git a/MAR/code_nestor/src/DESvar.inc b/MAR/code_nestor/src/DESvar.inc
new file mode 100644
index 0000000000000000000000000000000000000000..e46cfa8af9bbf1eeb108aca38a0c3fe61a2dda0f
--- /dev/null
+++ b/MAR/code_nestor/src/DESvar.inc
@@ -0,0 +1,21 @@
+
+C +---Relation between desagregated grid and input grid
+C + =================================================
+
+ INTEGER iiL2N (mx,my),jjL2N (mx,my)
+
+ REAL auxL2N(mx,my),auyL2N(mx,my)
+
+ INTEGER fdiv
+
+
+C +...fdiv : factor between input and output resolutions
+C +...iiL2N : location of (i,j) NST grid point in LSC grid (X-coord)
+C +...jjL2N : location of (i,j) NST grid point in LSC grid (Y-coord)
+C +...auxL2N : interpolation factors between NST and LSC grid (X)
+C +...auyL2N : interpolation factors between NST and LSC grid (Y)
+
+
+ COMMON/DESvar_i/iiL2N , jjL2N,fdiv
+
+ COMMON/DESvar_r/auxL2N,auyL2N
diff --git a/MAR/code_nestor/src/ECMvgd.f b/MAR/code_nestor/src/ECMvgd.f
new file mode 100644
index 0000000000000000000000000000000000000000..1b7ad545a447ce3c7113b83f7cebb6ccc638c436
--- /dev/null
+++ b/MAR/code_nestor/src/ECMvgd.f
@@ -0,0 +1,132 @@
+C +-------------------------------------------------------------------+
+C | Subroutine ECMvgd 11-04-2022 JFG |
+C +-------------------------------------------------------------------+
+C | |
+C | Vertical grid of the ECMWF model. Tailored for a 2D grid. One |
+C | additional logical parameter is used to also re-use this routine |
+C | for the hadCM3/ECHAM5/CanESM2/NorESM1 model (same method, only |
+C | the UNsread calls change). |
+C | |
+C | Input : - fID : identificator of the Netcdf data file |
+C | ^^^^^^^ - nk : number of vertical levels |
+C | - baseI : minimum X index of the relevant LSC sub-region |
+C | - baseJ : minimum Y index of the relevant LSC sub-region |
+C | - maxI : maximum X index of the relevant LSC sub-region |
+C | - maxJ : maximum Y index of the relevant LSC sub-region |
+C | - klev : if specified, the level at which pressure and |
+C | hybrid coordinate has to be computed |
+C | - isCM3 : true if hadCM3/ECHAM5/CanESM2/NorESM1 model |
+C | - ECM_sp(ni,nj) : surface pressure |
+C | |
+C | Output: Vertical grid of the ECMWF model : |
+C | ^^^^^^^ - ECM__p(ni,nj,nk+1) : pressure at each level [kPa] |
+C | - ECM_hp(ni,nj,nk+1) : local hybrid coord. for vertical |
+C | interpolation. |
+C | |
+C | Remarks on optimization via sub-region selection (29/05/2022): |
+C | -to compute the vertical grid for the full LSC domain, use |
+C | baseI=1, baseJ=1, maxI=ni, maxJ=nj. |
+C | -code assumes that the user will use 1 <= baseI <= maxI <= ni and |
+C | 1 <= baseJ <= maxJ <= nj. |
+C | -if the variables baseI, baseJ, maxI and maxJ are set to delimit |
+C | a sub-region of the LSC grid, only this sub-region will be |
+C | completed in the output grids. |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE ECMvgd(fID,ni,nj,nk,baseI,baseJ,maxI,maxJ,klev,isCM3,
+ . ECM_sp,ECM__p,ECM_hp)
+
+ IMPLICIT NONE
+
+C +---Local variables
+C + ---------------
+ INTEGER fID,ni,nj,baseI,baseJ,maxI,maxJ,nk,klev,i,j,k,k1,k2,k21
+
+ REAL pp,ppm,pps,ppf,pp1,dpsl,hh,empty1(1),CSTp(nk),SIGp(nk),
+ . ECM_sp(ni,nj),ECM__p(ni,nj,nk+1),ECM_hp(ni,nj,nk+1)
+
+ CHARACTER*10 var_units
+
+ LOGICAL isCM3
+
+C +---Atmospheric levels: pressure levels
+C + -----------------------------------
+C + Initially, there was a separate CM3vgd routine, but it was
+C + identical to ECMvgd except for the subsequent calls, hence the
+C + additional logical argument and the following lines.
+
+ IF (isCM3) THEN
+ CALL UNsread (fID,'CSTp',1,1,1,1,nk,1,1,var_units,CSTp)
+ CALL UNsread (fID,'SIGp',1,1,1,1,nk,1,1,var_units,SIGp)
+ ELSE
+ CALL UNsread (fID,'CSTp',0,0,0,0,nk,1,1,var_units,CSTp)
+ CALL UNsread (fID,'SIGp',0,0,0,0,nk,1,1,var_units,SIGp)
+ ENDIF
+
+C +---Adapt units
+C + -----------
+
+ DO k=1,nk
+ CSTp(k) = CSTp(k) * 1.E-3 !(Pa-->KPa)
+ ENDDO
+
+C +---Computation for a given level or all levels ?
+C + ---------------------------------------------
+
+ IF ((klev.le.0).or.(klev.gt.(nk+1))) THEN
+ k1 =1
+ k2 =nk
+ k21=nk+1
+ ELSE
+ k1 =klev
+ k2 =klev
+ k21=klev
+ ENDIF
+
+ pp1 = 105. ! Reference pressure (KPa)
+ dpsl = 20. ! "> boundary layer" (KPa)
+
+C +---For each i,j pixel (start of grid traversal)
+C + --------------------------------------------
+C + 29/05/2022: added a small optimization; grid traversal now only
+C + takes account of the sub-region of the LSC domain which includes
+C + the NST domain.
+
+ DO i=baseI,maxI ! i=1,ni
+ DO j=baseJ,maxJ ! j=1,nj
+
+C +---Compute pressure at each levels
+C + -------------------------------
+
+C +...Pressure in LS atmosphere is such that :
+C +...p(level) = CSTp(level) + SIGp(level) * Surf_pressure
+
+ IF (klev.ne.(nk+1)) THEN
+ DO k=k1,k2
+ ECM__p(i,j,k)=CSTp(k)+SIGp(k)*ECM_sp(i,j) ! (kPa)
+ ENDDO
+ ENDIF
+
+ ECM__p(i,j,nk+1)=ECM_sp(i,j)
+
+
+C +---Compute hybrid coordinates (required by nesting procedure)
+C + --------------------------
+C +...Local hybrid coordinate: set parameters
+
+ pps = ECM_sp(i,j)
+ ppm = pps - dpsl
+ DO k = k1,k21
+ pp = ECM__p(i,j,k)
+ hh = pp/pp1
+ IF (pp.gt.ppm) THEN
+ ppf= (pp-ppm)/(pps-ppm)
+ hh = hh + (pp1-pps)/pp1 * ppf * ppf
+ END IF
+ ECM_hp(i,j,k) = LOG(hh)
+ ENDDO
+
+ END DO; END DO ! End of grid traversal
+
+ RETURN
+ END
diff --git a/MAR/code_nestor/src/ETOPO1.f b/MAR/code_nestor/src/ETOPO1.f
new file mode 100644
index 0000000000000000000000000000000000000000..9e82b51b49df4c2eefe90e8e42a8c16a9ebcf293
--- /dev/null
+++ b/MAR/code_nestor/src/ETOPO1.f
@@ -0,0 +1,261 @@
+C +-------------------------------------------------------------------+
+C | Subroutine ETOPO1 Dec 12 NESTING |
+C +-------------------------------------------------------------------+
+C | |
+C | Input : Grid : NST__x and NST__y (longitude and latitude, degrees)|
+C | ^^^^^^^ ETOPO data set, resolution: 1 minutes |
+C | |
+C | Output: NST_sh: surface elevation |
+C | ^^^^^^^ NSTsol: land (4) / sea (1) mask |
+C | |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE ETOPO1
+
+ IMPLICIT NONE
+
+C +---Netcdf specifications
+C + ---------------------
+
+ INCLUDE 'NetCDF.inc'
+
+C +---NST variables
+C + -------------
+
+ INCLUDE 'NSTdim.inc'
+ INCLUDE 'NSTvar.inc'
+ INCLUDE 'NESTOR.inc'
+ INCLUDE 'LOCfil.inc'
+ INCLUDE 'MARvar.inc'
+
+C +---Local variables
+C + ---------------
+
+ INTEGER i,j,mlon,mlat,elat,midlon,mlon1,mlat1,
+ . nbchar,TOPOmx,TOPOmy
+
+ PARAMETER (mlon = 21601)
+ PARAMETER (mlat = 10801)
+ PARAMETER (mlon1 =mlon+1)
+ PARAMETER (mlat1 =mlat+1)
+C +...Size of full ETOPO file
+
+ PARAMETER (elat = 3500)
+ PARAMETER (TOPOmx= mlon)
+ PARAMETER (TOPOmy= elat)
+C +...Size of sub-domain (latitude only)
+
+ INTEGER DIMS(1),TOPO_ID,LAT_ID,LON_ID,sol,start(3),
+ . count(3),i1lon,i2lon,i1lat,i2lat,imlon,imlat,
+ . irien,ncid,Rcode
+
+ integer*4, allocatable :: etopo(:,:)
+
+
+ REAL*8 , allocatable :: etopo_lon(:), etopo_lat(:)
+
+ REAL topo_lon(mlon),topo_lat(mlat),size_lon,
+ . TOPlon(TOPOmx),TOPlat(TOPOmy),size_lat,
+ . TOPsh(TOPOmx,TOPOmy),tmpTOP(TOPOmx,TOPOmy),
+ . tmp_in(0:TOPOmx+1,0:TOPOmy+1),MINlon,MINlat,
+ . MAXlon,MAXlat,AUXlon,AUXlat
+
+ LOGICAL Vtrue
+
+ CHARACTER*80 ETOPOfile
+
+C +---Data
+C + ----
+
+ DATA start / 1,1,1/
+ DATA Vtrue /.true./
+
+ allocate (etopo(mlon,elat))
+ allocate (etopo_lon(mlon))
+ allocate (etopo_lat(mlat))
+
+C +---Opening and reading of ETOPO data file
+C + ======================================
+
+ write(6,*) 'Topography : ETOPO1 data set (1 minutes)'
+ write(6,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+ write(6,*)
+
+C +---Open NetCDF file
+C + ----------------
+
+ nbchar=1
+
+ DO i=1,60
+ IF (ETOPO_dir(i:i).ne.' ') nbchar=i
+ ENDDO
+
+ ETOPOfile = ETOPO_dir(1:nbchar-1) // '1/etopo1.nc'
+ ncid = NCOPN(ETOPOfile,NCNOWRIT,Rcode)
+
+C +---Find out the id of the variables
+C + --------------------------------
+
+ LON_ID =NCVID(ncid,'x' ,Rcode)
+ LAT_ID =NCVID(ncid,'y' ,Rcode)
+ TOPO_ID=NCVID(ncid,'z',Rcode)
+
+C +---Read latitudes and longitudes of ETOPO
+C + --------------------------------------
+
+C +...! etopo_lon and _lat are real*8 !
+
+ start(1)=1
+ count(1)=mlon
+C + *****
+ CALL NCVGT(ncid,LON_ID,start,count,etopo_lon,Rcode)
+C + *****
+ DO i=1,mlon
+ topo_lon(i) = etopo_lon(i)
+ END DO
+C +...topo_lon : from -180 to 180 deg.
+
+ start(1)=1
+ count(1)=mlat
+C + *****
+ CALL NCVGT(ncid,LAT_ID,start,count,etopo_lat,Rcode)
+C + *****
+ DO j=1,mlat
+ topo_lat(j) = etopo_lat(j)
+ END DO
+C +...topo_lat : from -90 to 90 deg.
+
+C +---Compute the extension of the sub-domain to be read
+C --------------------------------------------------
+
+ AUXlon = NST__x(1,1)
+ AUXlat = NST__y(1,1)
+C + ******
+ CALL SPHERC (Vtrue,AUXlon,AUXlat)
+C + ******
+ MINlon = AUXlon
+ MAXlon = AUXlon
+ MINlat = AUXlat
+ MAXlat = AUXlat
+ DO j=1,my
+ DO i=1,mx
+ AUXlon = NST__x(i,j)
+ AUXlat = NST__y(i,j)
+C + ******
+ CALL SPHERC (Vtrue,AUXlon,AUXlat)
+C + ******
+ MINlon = min(AUXlon,MINlon)
+ MAXlon = max(AUXlon,MAXlon)
+ MINlat = min(AUXlat,MINlat)
+ MAXlat = max(AUXlat,MAXlat)
+ ENDDO
+ ENDDO
+
+C +---Define extraction zone
+C + ----------------------
+
+C + ******
+ CALL SEARCH (topo_lon,mlon,MINlon,i1lon,irien)
+ CALL SEARCH (topo_lon,mlon,MAXlon,irien,i2lon)
+C + ******
+ imlon = i2lon - i1lon + 1
+C + ******
+ CALL SEARCH (topo_lat,mlat,MINlat,i1lat,irien)
+ CALL SEARCH (topo_lat,mlat,MAXlat,irien,i2lat)
+C + ******
+ imlat = i2lat - i1lat + 1
+
+ IF (imlat.ge.elat) THEN
+ write(*,*) 'Extent of the simulation domain in latitude'
+ write(*,*) 'is too large. Please choose a larger value '
+ write(*,*) 'for the elat parameter. - STOP '
+ STOP
+ ENDIF
+
+ i1lat = i1lat + (i2lat-i1lat)/2 - elat/2
+ i1lat = MAX(1,i1lat)
+ i2lat = i1lat + elat - 1
+ IF (i2lat.gt.mlat) THEN
+ i2lat= mlat
+ i1lat= i2lat - elat + 1
+ ENDIF
+
+C +---Read values of the variables for the sub-domain
+C + -----------------------------------------------
+
+ start(1)=1
+ start(2)=max(1,i1lat-1)
+ count(1)=mlon
+ count(2)=elat
+
+C + *****
+ CALL NCVGT(ncid,TOPO_ID,start,count,etopo,Rcode)
+C + *****
+
+ DO i=1,mlon
+ DO j=1,elat
+ TOPsh(i,j) = etopo(i,j)
+ END DO
+ END DO
+
+C + ******
+ CALL NCCLOS (ncid,Rcode)
+C + ******
+
+ DO i=1,TOPOmx
+ TOPlon(i)=topo_lon(i)
+ ENDDO
+
+ DO j=1,TOPOmy
+ TOPlat(j)=topo_lat(i1lat-1+j)
+ ENDDO
+
+C +---Interpolation of topography to the NST grid
+C + -------------------------------------------
+
+C + ******
+ CALL bilSim (TOPOmx,TOPOmy,TOPlon,TOPlat,TOPsh ,Vtrue ,
+ . mx ,my ,NST__x,NST__y,NST_sh,tmp_in)
+C + ******
+
+C +---Distinction between land and sea (further refined)
+C + --------------------------------
+
+ DO j=1,my
+ DO i=1,mx
+
+ IF (NST_sh(i,j).lt.0.01) THEN
+ NSTsol(i,j)=1
+ NSTice(i,j)=0
+ ELSE
+ NSTsol(i,j)=4
+ ENDIF
+
+ ENDDO
+ ENDDO
+
+C +---Special topo for Greenland Simulation
+C + -------------------------------------
+
+ IF (region.eq."GRD") call USRgrd ('ETOPOg')
+ IF (region.eq."EUR") call USReur ('ETOPO1')
+
+C +---No atmosphere below sea level...
+C + --------------------------------
+
+ DO j=1,my
+ DO i=1,mx
+
+ IF (NST_sh(i,j).lt.0.0) THEN
+ NST_sh(i,j)= 0.0
+ ENDIF
+
+ ENDDO
+ ENDDO
+
+ deallocate(etopo)
+ deallocate(etopo_lon)
+ deallocate(etopo_lat)
+
+ RETURN
+ END
diff --git a/MAR/code_nestor/src/FAOsol.f b/MAR/code_nestor/src/FAOsol.f
new file mode 100644
index 0000000000000000000000000000000000000000..5bf6f752cb97f89e8fa4ff7538380aaf13d9b713
--- /dev/null
+++ b/MAR/code_nestor/src/FAOsol.f
@@ -0,0 +1,456 @@
+C +-------------------------------------------------------------------+
+C | Subroutine FAOsol February 2004 NESTING |
+C +-------------------------------------------------------------------+
+C | |
+C | Input : - NST__x : NST grid, longitude (degrees) |
+C | ^^^^^^^ - NST__y : NST grid, latitude (degrees) |
+C | |
+C | Output: - NSTdsa : soil albedo |
+C | ^^^^^^^ - NSTtex : soil texture (fine, medium, rough) |
+C | |
+C | This routine reads the files : |
+C | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |
+C | - TEXUNIT.ASC : soil type characteristics given in the FAO |
+C | classification ; |
+C | - FAO_SOIL.nc : soil types over the globe |
+C | --> domain : -180 -> 180 (lon.), -90 -> 90 (lat) |
+C | --> resolution : 5 minutes (8 to 10 km) |
+C | |
+C | FAO soil data file contains 9 fields : |
+C | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |
+C | - Soil Texture Map : |
+C | ---------------- |
+C | . 1 : % of cell containing rough texture ; |
+C | . 2 : % of cell containing medium texture ; |
+C | . 3 : % of cell containing fine texture ; |
+C | . 4 : % of cell containing dominant texture ; |
+C | |
+C | - Soil Moisture Storage Capacity Map : |
+C | ---------------------------------- |
+C | . 5 : phase ; |
+C | . 6 : % phase ; |
+C | |
+C | - Soil Map : |
+C | -------- |
+C | . 7 : slope < 8 % ; |
+C | . 8 : 8 % < slope < 30 % ; |
+C | . 9 : slope > 30 % . |
+C | |
+C +-------------------------------------------------------------------+
+
+
+ SUBROUTINE FAOsol
+
+
+ IMPLICIT NONE
+
+
+C +---Netcdf specifications
+C + ---------------------
+
+ INCLUDE 'NetCDF.inc'
+
+
+C +---General and local variables
+C + ---------------------------
+
+ INCLUDE 'NSTdim.inc'
+ INCLUDE 'NSTvar.inc'
+ INCLUDE 'NESTOR.inc'
+ INCLUDE 'LOCfil.inc'
+
+ INTEGER i,j,num,FAO_nx,FAO_ny,nline,ntype,ix,iy,i2,j2,compt,
+ . stype,ncl,FAO_ID,i1lat,i2lat,i1lon,i2lon,imlat,imlon,
+ . start(3),count(3),nbi,nbj,ncid,Rcode,FAOmaxy,nbchar
+
+ REAL coarfr,amedfr,finefr,phase,plat,prphase,ondule,pente,dx,
+ . dy,FAO_px,FAO_py,FAOres,pi,degrad,AUXlon,AUXlat,MINlat,
+ . MAXlat,FAO_dx,FAO_dy,dx1,dx2,dy1,dy2
+
+ CHARACTER*20 name
+
+ CHARACTER*80 FAO_text,FAO_file
+
+
+C +---General parameters of FAO file
+C + ------------------------------
+
+ PARAMETER(FAO_nx=4320,FAO_ny=1300,FAOmaxy=2160)
+C +... ^ size of the large-scale arrays
+
+ PARAMETER(ntype=7000,nline=4931)
+C +... ^ number of soil types in FAO classification
+C +... ^ number of lines to be read in EUROSOIL
+
+ PARAMETER(FAOres=1./12.)
+C +... ^ horizontal resolution of the data
+
+ PARAMETER(FAO_px=-180.,FAO_py=-90.)
+C +... ^ initial grid point in longitude and latitude
+
+ INTEGER*2 FAOsoil(FAO_nx,FAO_ny)
+
+ INTEGER FAOtext(0:3),texture(ntype)
+
+ REAL FAOlon(FAO_nx),FAOlat(FAO_ny)
+
+ LOGICAL Vtrue
+
+
+C +---Data
+C + ----
+
+ DATA start / 1,1,1/
+ DATA count / 0,0,0/
+ DATA Vtrue /.true./
+
+ pi = 3.141592653589793238462643d0
+ degrad= pi / 180.d0
+
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Read the FAO CLASSIFICATION OF SOIL TYPES
+C + =========================================
+
+ nbchar=1
+
+ DO i=1,60
+ IF (FAO_dir(i:i).ne.' ') nbchar=i
+ ENDDO
+
+ FAO_text = FAO_dir(1:nbchar) // 'TEXUNIT.ASC'
+ OPEN(unit=10,status='old',file=FAO_text)
+
+ DO i=1,ntype
+ texture(i)=0.
+ ENDDO
+
+ DO i=1,nline
+
+ READ(10,100) num,name,coarfr,amedfr,finefr,phase,prphase,
+ . plat,ondule,pente
+
+100 FORMAT(i4,1x,a20,3f6.0,f4.0,f9.3,3f8.0)
+
+C + COARSE TEXTURE --> SAND --> num.= 1
+ IF (coarfr.ge.amedfr.and.coarfr.ge.finefr) texture(num)=1
+C + MEDIUM TEXTURE --> LOAM --> num.= 2
+ IF (amedfr.ge.coarfr.and.amedfr.ge.finefr) texture(num)=2
+C + FINE TEXTURE --> CLAY --> num.= 3
+ IF (finefr.ge.coarfr.and.finefr.ge.amedfr) texture(num)=3
+
+ ENDDO
+
+ CLOSE(unit=10)
+
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Read FAO SOIL TYPES
+C + ===================
+
+
+ write(6,*) 'Soil types : FAO data set (5 minutes)'
+ write(6,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+ write(6,*)
+
+
+C +---Open NetCDF file
+C + ----------------
+
+ FAO_file = FAO_dir(1:nbchar) // 'FAO_SOIL.nc'
+
+ ncid = NCOPN(FAO_file,NCNOWRIT,Rcode)
+ FAO_ID = NCVID(ncid,'FAO_SOIL' ,Rcode)
+
+
+C +---Compute the extension of the sub-domain to be read
+C --------------------------------------------------
+
+ AUXlon = NST__x(1,1)
+ AUXlat = NST__y(1,1)
+C + ******
+ CALL SPHERC (Vtrue,AUXlon,AUXlat)
+C + ******
+ MINlat = AUXlat
+ MAXlat = AUXlat
+ DO j=1,my
+ DO i=1,mx
+ AUXlon = NST__x(i,j)
+ AUXlat = NST__y(i,j)
+C + ******
+ CALL SPHERC (Vtrue,AUXlon,AUXlat)
+C + ******
+ MINlat = min(AUXlat,MINlat)
+ MAXlat = max(AUXlat,MAXlat)
+ ENDDO
+ ENDDO
+
+
+C +---Define extraction zone
+C + ----------------------
+
+ i1lat = AINT ( (MINlat-(-90.))/FAOres )
+ i2lat = AINT ( (MAXlat-(-90.))/FAOres )
+ imlat = i2lat - i1lat + 1
+
+ i1lon = 1
+ i2lon = FAO_nx
+ imlon = i2lon - i1lon + 1
+
+ IF (imlat.ge.FAO_ny) THEN
+ write(*,*) 'Extent of the simulation domain in latitude'
+ write(*,*) 'is too large. Please choose a larger value '
+ write(*,*) 'for the FAO_ny parameter. - STOP '
+ STOP
+ ENDIF
+
+ i1lat = i1lat + (i2lat-i1lat)/2 - FAO_ny/2
+ i2lat = i1lat + FAO_ny - 1
+
+ IF (i1lat.lt.1) THEN
+ i1lat=1
+ i2lat=FAO_ny
+ ENDIF
+
+ IF (i2lat.gt.FAOmaxy) THEN
+ i1lat=FAOmaxy-FAO_ny+1
+ i2lat=FAOmaxy
+ ENDIF
+
+
+C +---Define the FAO grid
+C + -------------------
+
+ DO i=i1lon,i2lon
+ FAOlon(i)=FAO_px+real(i-1)*FAOres+FAOres/2.
+ ENDDO
+
+ DO j=i1lat,i2lat
+ FAOlat(j-i1lat+1)=FAO_py+real(j-1)*FAOres+FAOres/2.
+ ENDDO
+
+
+C +---Read values of the variables for the sub-domain
+C + -----------------------------------------------
+
+ start(1)=i1lon
+ start(2)=i1lat
+ count(1)=FAO_nx
+ count(2)=FAO_ny
+ CALL NCVGT(ncid,FAO_ID,start,count,FAOsoil,Rcode)
+
+
+C +---Close Netcdf data file
+C + ----------------------
+
+ CALL NCCLOS(ncid,Rcode)
+
+
+C + ###################################################################
+
+ DO j=1,my ! Loop for each NST grid point
+ DO i=1,mx ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+C + ###################################################################
+
+
+C +---FAO grid ---> NST grid
+C + ========================
+
+
+C +---Nearest FAO grid point
+C + ----------------------
+
+ AUXlon = NST__x(i,j)
+ AUXlat = NST__y(i,j)
+C + ******
+ CALL SPHERC (Vtrue,AUXlon,AUXlat)
+C + ******
+ ix=NINT((AUXlon-FAOlon(1))/FAOres)+1
+ iy=NINT((AUXlat-FAOlat(1))/FAOres)+1
+
+
+C +---Correction to avoid limits in the representation of numbers
+C + -----------------------------------------------------------
+
+ IF (ix.eq.0) THEN
+ IF (((AUXlon-FAOlon(1))/FAOres).gt.(-0.51)) ix=1
+ ENDIF
+
+ IF (iy.eq.0) THEN
+ IF (((AUXlat-FAOlat(1))/FAOres).gt.(-0.51)) iy=1
+ ENDIF
+
+ IF (ix.eq.(FAO_nx+1)) THEN
+ IF (((AUXlon-FAOlon(1))/FAOres).lt.(real(FAO_nx-1)+0.51))
+ . ix=FAO_nx
+ ENDIF
+
+ IF (iy.eq.(FAO_ny+1)) THEN
+ IF (((AUXlat-FAOlat(1))/FAOres).lt.(real(FAO_ny-1)+0.51))
+ . iy=FAO_ny
+ ENDIF
+
+
+C +---Check if NST latitudes/longitudes are valid
+C + -------------------------------------------
+
+ IF ( (ix.lt.1).or.(ix.gt.FAO_nx).or.
+ . (iy.lt.1).or.(iy.gt.FAO_ny) ) THEN
+ WRITE (6,*) 'NST grid point (i,j)= ',i,j,' out of global'
+ WRITE (6,*) 'FAO domain.'
+ WRITE (6,*) 'STOP in FAOsol.'
+ STOP
+ ENDIF
+
+
+C +---Compute the resolution of the considered NST cell
+C + -------------------------------------------------
+
+ IF (NST_dx.gt.0.01) THEN
+
+ dx =NST_dx
+ dy =NST_dx
+
+ ELSE
+
+ dx1=(NST__x(i,j)-NST__x(i-1,j))*111111.
+ . *COS(NST__y(i,j)*degrad)
+ dx2=(NST__y(i,j)-NST__y(i-1,j))*111111.
+ dx =SQRT(dx1*dx1+dx2*dx2)
+
+ dy1=(NST__x(i,j)-NST__x(i,j-1))*111111.
+ . *COS(NST__y(i,j)*degrad)
+ dy2=(NST__y(i,j)-NST__y(i,j-1))*111111.
+ dy =SQRT(dy1*dy1+dy2*dy2)
+
+ ENDIF
+
+
+C +---Define the data points to be read around (i_cent,j_cent)
+C + --------------------------------------------------------
+
+ FAO_dx = FAOres*111111.*COS(NST__y(i,j)*degrad)
+ FAO_dy = FAOres*111111.
+
+ nbi=NINT(dx/FAO_dx/2.)-1
+ nbj=NINT(dy/FAO_dy/2.)-1
+
+ nbi=MAX(nbi,0)
+ nbj=MAX(nbj,0)
+
+
+C +---Examine all FAO grid points contained in a given NST cell
+C + ---------------------------------------------------------
+
+ FAOtext(0)=0
+ FAOtext(1)=0
+ FAOtext(2)=0
+ FAOtext(3)=0
+
+ DO j2=MAX(1,iy-nbj),MIN(FAO_ny,iy+nbj)
+ DO i2=MAX(1,ix-nbi),MIN(FAO_nx,ix+nbi)
+
+ IF (FAOsoil(i2,j2).ne.0) THEN
+ stype=texture(FAOsoil(i2,j2))
+ ELSE
+ stype=0
+ ENDIF
+
+C +... stype = 0 : water
+C +... 1 : coarse texture
+C +... 2 : medium texture
+C +... 3 : fine texture
+
+ IF (stype.ge.0.and.stype.le.3)
+ . FAOtext(stype)=FAOtext(stype)+1
+
+ ENDDO
+ ENDDO
+
+
+C +---Determination of the dominant soil type
+C + ---------------------------------------
+
+ compt=0
+ stype=2
+
+ DO ncl=0,3
+ IF (FAOtext(ncl).gt.compt) THEN
+ compt=FAOtext(ncl)
+ stype=ncl
+ ENDIF
+ ENDDO
+
+
+C +---Output : NSTsol and NSTtex
+C + --------------------------
+
+C +---Sea and Sea Ice
+
+ IF (NSTsol(i,j).le.2 ) then
+ NSTtex(i,j) = 0
+ NSTdsa(i,j) = 0.15
+ IF (region.eq."GRD".or.region.eq."ANT") NSTdsa(i,j) = 0.20
+ ENDIF
+
+C +---Snow - Ice
+
+ IF (NSTsol(i,j).eq.3 ) then
+ NSTtex(i,j) = 3
+ NSTdsa(i,j) = 0.85
+ ENDIF
+
+C +---Soil - Tundra
+
+ IF (NSTsol(i,j).ge.4) THEN
+
+ IF (stype.ne.0) THEN
+ NSTtex(i,j)=stype
+ ELSE
+ NSTtex(i,j)=2
+ ENDIF
+
+ IF (NSTtex(i,j).eq.1) THEN
+ NSTdsa(i,j) = 0.40
+C +... Dry Quartz Sand (Deardorff 1978 JGR p.1891)
+ ELSE IF (NSTtex(i,j).eq.3) THEN
+ NSTdsa(i,j) = 0.15
+C +... Clay Pasture (Deardorff 1978 JGR p.1891)
+ ELSE
+ NSTdsa(i,j) = 0.25
+C +... O'Neill average (Deardorff 1978 JGR p.1891)
+ ENDIF
+
+ ENDIF
+
+C +---Special Texture for Polar Simulation
+C + ------------------------------------
+
+ IF (region.eq."GRD".or.region.eq."ANT") THEN
+
+ if (i.eq.2.and.j.eq.2) then
+ write(6,*) "Special Texture for Polar region"
+ write(6,*)
+ endif
+
+ IF (NSTsol(i,j).le.2 ) NSTtex(i,j) = 0 ! sea
+ IF (NSTsol(i,j).eq.3 ) NSTtex(i,j) = 3 ! ice
+ IF (NSTsol(i,j).ge.4 ) NSTtex(i,j) = 2 ! tundra
+
+ ENDIF
+
+C + ###################################################################
+
+ ENDDO ! Loop for i (NST grid)
+ ENDDO ! Loop for j (NST grid)
+
+C + ###################################################################
+
+
+ RETURN
+ END
diff --git a/MAR/code_nestor/src/FILTER.f b/MAR/code_nestor/src/FILTER.f
new file mode 100644
index 0000000000000000000000000000000000000000..a7e2af8fc6f3621bb476d000de77dde0caeac27f
--- /dev/null
+++ b/MAR/code_nestor/src/FILTER.f
@@ -0,0 +1,200 @@
+ subroutine DYNfil_2H (f,eps)
+C +
+C +------------------------------------------------------------------------+
+C | MAR DYNAMICS FILTER (2-D) 30-12-2000 MAR |
+C | SubRoutine DYNfil_2H is used to Filter Horizontal Fields in 3D Code |
+C | |
+C +------------------------------------------------------------------------+
+C | |
+C | INPUT: f(i,j) : variable to be filtered for a particular Level k |
+C | ^^^^^ eps : value of the selectivity parameter |
+C | |
+C | OUTPUT: f(i,j) |
+C | ^^^^^^ |
+C | |
+C | LATERAL BOUNDARIES: |
+C | ^^^^^^^^^^^^^^^^^^^ |
+C | 1. The value of the variable is fixed at the Boundary |
+C | |
+C | REFER.: Raymond and Garder, MWR 116, Jan 1988, p209 |
+C | ^^^^^^ |
+C +------------------------------------------------------------------------+
+C +
+C +
+ IMPLICIT NONE
+C +
+C +
+C +--Global Variables
+C + ================
+C +
+ include 'NSTdim.inc'
+C +
+ real f(mx,my),eps
+C +
+C +
+C +--Local Variables
+C + ================
+C +
+ integer i,j,ip11,jp11,mx1,my1,m,m1,m2,mn1,mn2,mx2,my2,mn
+ real aa,bb
+C +
+ real x(mx,my)
+ real a1(1:mx) ,b1(1:mx) ,d1(1:mx) ,p1(mx) ,q1(mx) ,wk1(1:mx)
+ real a2(1:my) ,b2(1:my) ,d2(1:my) ,p2(my) ,q2(my) ,wk2(1:my)
+C +
+C +
+C +--Initialisation
+C + ==============
+C +
+ ip11 = 2
+ jp11 = 2
+ mx1 = mx-1
+ my1 = my-1
+ mx2 = mx-2
+ my2 = my-2
+C +
+ m = mx
+ m1 = mx1
+ m2 = mx2
+ mn = my
+ mn1= my1
+ mn2= my2
+C +
+C +
+C +--1st Matrix Initialisation
+C + -------------------------
+C +
+ a1( 1) = 0.d0
+ b1( 1) = 1.d0
+ a1(mx) = 0.d0
+ b1(mx) = 1.d0
+C +
+ aa = 1.d0-eps
+ bb = 2.d0*(1.d0+eps)
+C +
+ DO i=ip11,mx1
+ a1(i) = aa
+ b1(i) = bb
+ END DO
+C +
+C +
+C +--2th Matrix Initialisation
+C + -------------------------
+C +
+ a2( 1) = 0.d0
+ b2( 1) = 1.d0
+ a2(my) = 0.d0
+ b2(my) = 1.d0
+C +
+ DO j=jp11,my1
+ a2(j) = aa
+ b2(j) = bb
+ END DO
+C +
+C +
+C +--1st Equations System
+C + ====================
+C +
+ DO j=jp11,my1
+C +
+ d1( 1) =f( 1,j-1) +2.d0*f( 1,j) + f( 1,j+1)
+ d1(mx) =f(mx,j-1) +2.d0*f(mx,j) + f(mx,j+1)
+C +
+ DO i=ip11,mx1
+ d1(i )=f(i-1,j+1)+2.d0*f(i,j+1)+ f(i+1,j+1)+
+ & 2.d0*f(i-1,j) +4.d0*f(i,j) +2.d0*f(i+1,j) +
+ & f(i-1,j-1)+2.d0*f(i,j-1)+ f(i+1,j-1)
+ END DO
+C +
+C + *********
+ call tlat(a1,b1,a1,d1,p1,q1,m ,m ,wk1)
+C + *********
+C +
+ DO i=ip11,mx1
+ x(i,j) = wk1(i)
+ END DO
+C +
+ END DO
+C +
+C +
+C +--2th Equations System
+C + ====================
+C +
+ DO i=ip11,mx1
+C +
+ d2( 1) = f(i, 1)
+ d2(my) = f(i,my)
+C +
+ DO j=jp11,my1
+ d2( j) = x(i,j)
+ END DO
+C +
+C + *********
+ call tlat(a2,b2,a2,d2,p2,q2,mn ,mn ,wk2)
+C + *********
+C +
+ DO j=jp11,my1
+ f(i,j) = wk2(j)
+ END DO
+C +
+ END DO
+C +
+ return
+ end
+C +
+C +
+ subroutine tlat(tlat_a,tlat_b,tlat_c,tlat_d,tlat_p,tlat_q,nx,n
+ . ,tlat_x)
+C +
+C +------------------------------------------------------------------------+
+C | MAR DYNAMICS FILTER 20-09-2001 MAR |
+C | SubRoutine tlat uses the Gaussian Elimination Algorithm |
+C | (e.g. Pielke (1984), pp.302--303) |
+C | (needed to solve the implicit scheme developped for filtering) |
+C +------------------------------------------------------------------------+
+C | |
+C | INPUT: tlat_a,tlat_b,tlat_c: tri-diagional matrix coefficients |
+C | ^^^^^ tlat_d : tri-diagional matrix independent term |
+C | tlat_p,tlat_q : working variables |
+C | n : dimension of the variables |
+C | tlat_x : variable to solve |
+C | |
+C | OUTPUT: tlat_x |
+C | ^^^^^^ |
+C +------------------------------------------------------------------------+
+C +
+ IMPLICIT NONE
+C +
+ integer nx,n
+ real tlat_a(nx),tlat_b(nx),tlat_c(nx),tlat_d(nx)
+ real tlat_x(nx),tlat_p(nx),tlat_q(nx)
+C +
+ integer k ,l
+C +
+C +
+C +--Forward Sweep
+C + ==============
+C +
+ tlat_p(1)= tlat_b(1)
+ tlat_q(1)=-tlat_c(1)/tlat_p(1)
+ DO k=2,n
+ tlat_p(k)= tlat_a(k)*tlat_q(k-1)+tlat_b(k)
+ tlat_q(k)=-tlat_c(k)/tlat_p(k)
+ END DO
+C +
+ tlat_x(1)= tlat_d(1)/tlat_p(1)
+ DO k=2,n
+ tlat_x(k)=(tlat_d(k)-tlat_a(k) *tlat_x(k-1))/tlat_p(k)
+ END DO
+C +
+C +
+C +--Backward Sweep
+C + ==============
+C +
+ DO l=2,n
+ k=n-l+1
+ tlat_x(k)=tlat_q(k)*tlat_x(k+1)+tlat_x(k)
+ END DO
+C +
+ return
+ end
diff --git a/MAR/code_nestor/src/GEOpot.f b/MAR/code_nestor/src/GEOpot.f
new file mode 100644
index 0000000000000000000000000000000000000000..2083249e042e92ab3083bcd3a5f51c6d8423d250
--- /dev/null
+++ b/MAR/code_nestor/src/GEOpot.f
@@ -0,0 +1,73 @@
+C +-------------------------------------------------------------------+
+C | Subroutine GEOpot June 99 NESTING |
+C +-------------------------------------------------------------------+
+C | |
+C | This subroutine contains the integration of the hydrostatic |
+C | relation. |
+C | |
+C | Input : - NST__t : real temperature (K) |
+C | ^^^^^^^ - NST_sh : surface height (m) |
+C | - NST_sp : surface pressure (kPa) |
+C | - NST__p : pressure (kPa) |
+C | |
+C | Output: - NST_zz : levels height |
+C | ^^^^^^^ |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE GEOpot (NST__t,NST_sh,NST_sp,NST__p,NST_zz)
+
+
+ IMPLICIT NONE
+
+
+C +--General Variables
+C + =================
+
+ INCLUDE 'NSTdim.inc'
+
+ INTEGER i,j,k
+
+ REAL ab,ra,gravit
+
+ REAL NST__t(mx,my,mz),NST__p(mx,my,mz),NST_zz(mx,my,mz),
+ . NST_sh(mx,my ),NST_sp(mx,my )
+
+
+C +--Constants
+C + =========
+
+ DATA ra / 287.d0 /
+C +... ra : Perfect Gas Law Constant (J/kg/K)
+
+ DATA gravit / 9.81d0 /
+C +... gravit : Gravity constant
+
+C 'WARNING - GEOpot: you may consider using VERhyd'
+
+C +---Integration of the Hydrostatic Equation
+C + =======================================
+
+ DO j=1,my
+ DO i=1,mx
+
+ NST_zz(i,j,mz)=NST_sh(i,j)
+ . +(ra/gravit)*NST__t(i,j,mz)
+ . *LOG(NST_sp(i,j)/NST__p(i,j,mz))
+
+ DO k=mz-1,1,-1
+
+ NST_zz(i,j,k)=NST_zz(i,j,k+1)
+ . +(ra/gravit)*0.5*(NST__t(i,j,k)+NST__t(i,j,k+1))
+ . *LOG(NST__p(i,j,k+1)/NST__p(i,j,k))
+
+ ENDDO
+
+C +... z1 = z0 - (RT/g) ln(p1/p0)
+C +... = z0 + (RT/g) ln(p0/p1)
+
+ ENDDO
+ ENDDO
+
+
+ RETURN
+ END
diff --git a/MAR/code_nestor/src/GEOpro.f b/MAR/code_nestor/src/GEOpro.f
new file mode 100644
index 0000000000000000000000000000000000000000..404d882217551ae20920304dc4097889757e932d
--- /dev/null
+++ b/MAR/code_nestor/src/GEOpro.f
@@ -0,0 +1,190 @@
+
+! +----------------------------------------------------------------------+
+ subroutine StereoSouth_inverse (lon,lat,lonE,E,N)
+! | Compute Polar Stereographic Projection from lon,lat coordinates |
+! | Written by Cecile Agosta 02-02-21 |
+! | EPSG Polar Stereographic transformation Variant B |
+! | (http://www.epsg.org/guides/docs/G7-2.pdf) |
+! | Equivalent to EPSG 3031 (WGS-84 ellipsoid) for SH |
+! | Equivalent to EPSG 3413 (WGS-84 ellipsoid) for NH |
+! +----------------------------------------------------------------------+
+! | |
+! | INPUT : lon : Longitude (deg) |
+! | ^^^^^^^ lat : Latitude (deg) |
+! | lon0 : Longitude of X axis (90 = East, clockwise) |
+! | [lat true = 71S/70N] |
+! | |
+! | OUTPUT : E : Stereo coordinate on the East (X, km) |
+! | ^^^^^^^^ N : Stereo coordinate on the North (Y, km) |
+! | |
+! +----------------------------------------------------------------------+
+ implicit none
+
+ include 'NSTdim.inc'
+
+! +-- General Variables
+! + -----------------
+ real,intent(in ) :: lon,lat,lonE
+ real,intent(out) :: E,N
+
+! +-- Local Variables
+! + ---------------
+ real costru,ddista
+
+! +-- Constants
+! + ---------
+ real aa,ex,pi,degrad,latF,FE,FN,tF,mF,k0,t,rho,lonrad,latrad
+ real lon0,trulat,GElat0
+
+ GElat0 = lat
+ aa = 6378.1370 ! aa (km) = demi grand axe
+ ex = 0.081819190842621 ! excentricity WGS-84 : 0.081 819 190 842 622 0.081 819 190 842 621
+ if(sign(1.,GElat0)<=0) then
+ trulat = -71. ! Latitude of standard parallel, 71S for ESPG 3031
+ else
+ trulat = 70. ! Latitude of standard parallel, 70N for EPSG 3413
+ endif
+ pi = 4. * atan(1.)
+ degrad = pi / 180.
+
+ latF = trulat*degrad ! Latitude of standard parallel, 71 for ESPG 3031/3995
+ lon0 = (lonE - 90.)*degrad
+ lonrad = lon *degrad
+ latrad = lat *degrad
+
+ FE = 0. !False Easting
+ FN = 0. !False Northing
+
+! +
+! +- Polar Stereographic Projection
+! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! +
+ if(sign(1.,GElat0)<=0) then
+ tF = tan (pi/4 + latF /2) /
+ . ( (1 + ex*sin(latF )) / (1 - ex*sin(latF )) )**(ex/2)
+ else
+ tF = tan (pi/4 - latF /2) *
+ . ( (1 + ex*sin(latF )) / (1 - ex*sin(latF )) )**(ex/2)
+ endif
+
+ mF = cos(latF) / (1 - ex**2 * sin(latF)**2)**0.5
+ k0 = mF*( (1+ex)**(1+ex) * (1-ex)**(1-ex) )**0.5 / (2*tF)
+
+c if(sign(1.,GElat0)>=0) then
+c k0=1 ! scale factor of 1
+c endif
+
+ if(sign(1.,GElat0)<=0) then
+ t = tan (pi/4 + latrad/2) /
+ . ( (1 + ex*sin(latrad)) / (1 - ex*sin(latrad)) )**(ex/2)
+ else
+ t = tan (pi/4 - latrad/2) *
+ . ( (1 + ex*sin(latrad)) / (1 - ex*sin(latrad)) )**(ex/2)
+ endif
+
+ rho = 2*aa*k0*t / ( (1+ex)**(1+ex) * (1-ex)**(1-ex) )**0.5
+
+ E = FE + rho*sin (lonrad - lon0)
+
+ if(sign(1.,GElat0)<=0) then
+ N = FN + rho*cos (lonrad - lon0)
+ else
+ N = FN - rho*cos (lonrad - lon0)
+ endif
+
+ return
+ end subroutine StereoSouth_inverse
+C +------------------------------------------------------------------------+
+
+! +----------------------------------------------------------------------+
+ subroutine LambertAzimuthalEqualArea_inv(lon,lat,xx,yy)
+! | Compute Oblique Stereographic Projection from lon,lat coordinates |
+! | Written by Cecile Agosta 17-05-10 |
+! | EPSG Polar Stereographic transformation Variant B |
+! | (http://www.epsg.org/guides/docs/G7-2.pdf) |
+! | Equivalent to EPSG 3031 (WGS-84 ellipsoid) |
+! +----------------------------------------------------------------------+
+! | |
+! | INPUT : lon : Longitude (deg) |
+! | ^^^^^^^ lat : Latitude (deg) |
+! | |
+! | OUTPUT : xx : coordinate on the East (X, km) |
+! | ^^^^^^^^ yy : coordinate on the North (Y, km) |
+! | |
+! +----------------------------------------------------------------------+
+ implicit none
+
+ include 'NSTdim.inc'
+
+! +-- General Variables
+! + -----------------
+ real,intent(in ) :: lon, lat
+ real,intent(out) :: xx, yy
+
+ real lonrad,latrad
+ real kp1,kp
+
+! +-- Constants
+! + ---------
+ real pi,degrad
+ real lon0,lat0
+
+ pi = 4. * atan(1.)
+ degrad = pi / 180.
+
+ lon0 = 0.*degrad
+ lat0 = -90.*degrad
+
+ lonrad = lon *degrad
+ latrad = lat *degrad
+
+! +
+! +- Polar Stereographic Projection
+! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! +
+ kp1 = 1 + sin(lat0)*sin(latrad) +
+ . cos(lat0)*cos(latrad)*cos(lonrad-lon0)
+ kp = sqrt(2/kp1)
+
+ xx = kp*cos(latrad)*sin(lonrad-lon0)
+ yy = kp*(cos(lat0)*sin(latrad) -
+ . sin(lat0)*cos(latrad)*cos(lonrad-lon0))
+
+ return
+ end subroutine LambertAzimuthalEqualArea_inv
+C +------------------------------------------------------------------------+
+
+ subroutine areaLambertAzimuthal(xl,xr,yl,yu,GEddxx,area)
+
+ implicit none
+
+ real,intent(in)::xl,xr,yl,yu,GEddxx
+ real,intent(out)::area
+
+ real lonll,latll,lonlu,latlu
+ real lonrl,latrl,lonru,latru
+ real xll,yll,xlu,ylu
+ real xrl,yrl,xru,yru
+ real l1,l2,l3
+ real dp
+
+ call StereoSouth(xl,yl,GEddxx,lonll,latll,-71.)
+ call StereoSouth(xl,yu,GEddxx,lonlu,latlu,-71.)
+ call StereoSouth(xr,yl,GEddxx,lonrl,latrl,-71.)
+ call StereoSouth(xr,yu,GEddxx,lonru,latru,-71.)
+
+ call LambertAzimuthalEqualArea_inv(lonll,latll,xll,yll)
+ call LambertAzimuthalEqualArea_inv(lonlu,latlu,xlu,ylu)
+ call LambertAzimuthalEqualArea_inv(lonrl,latrl,xrl,yrl)
+ call LambertAzimuthalEqualArea_inv(lonru,latru,xru,yru)
+
+ l1 = sqrt((xll-xlu)**2+(yll-ylu)**2)
+ l2 = sqrt((xll-xrl)**2+(yll-yrl)**2)
+ l3 = sqrt((xlu-xrl)**2+(ylu-yrl)**2)
+ dp = (l1+l2+l3)/2.
+ area = sqrt(dp*(dp-l1)*(dp-l2)*(dp-l3))
+ l1 = sqrt((xru-xlu)**2+(yru-ylu)**2)
+ l2 = sqrt((xru-xrl)**2+(yru-yrl)**2)
+ dp = (l1+l2+l3)/2.
+ area = area + sqrt(dp*(dp-l1)*(dp-l2)*(dp-l3))
+ end subroutine areaLambertAzimuthal
diff --git a/MAR/code_nestor/src/GLOcov.f b/MAR/code_nestor/src/GLOcov.f
new file mode 100644
index 0000000000000000000000000000000000000000..ba6241b8de140d19b7b3cd521ebf516658235087
--- /dev/null
+++ b/MAR/code_nestor/src/GLOcov.f
@@ -0,0 +1,354 @@
+C +-------------------------------------------------------------------+
+C | Subroutine GLOcov Jan 2018 NESTING |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE GLOcov
+
+ IMPLICIT none
+
+C +---General variables
+C + -----------------
+
+ INCLUDE 'NSTdim.inc'
+ INCLUDE 'NSTvar.inc'
+ INCLUDE 'LOCfil.inc'
+ INCLUDE 'NetCDF.inc'
+ INCLUDE 'NESTOR.inc'
+
+ real ,parameter :: reso=0.00833333
+ integer,parameter :: cx = 43200
+ integer,parameter :: cy = 21600
+
+ ! J.-F. Grailet: renamed in/jn as ins/jns (s=size) to avoid
+ ! a potential confusion with the "in" keyword in Fortran (it is
+ ! highlighted as such in my code editor).
+
+ integer minL,dimL
+ integer ins,jns,i,j,k,l,kk,ll
+ integer NET_ID,NETcid,Rcode
+ integer ilc(mw+1),lcmax
+ integer cov,NET_ID2,NETcid2,icemask
+
+ ! Variables used for buffering chunks of the (large) data array
+ integer :: fiCell(2),nCells(2)
+ integer, dimension(:,:), allocatable :: arrCov
+ integer, dimension(:,:), allocatable :: arrIce
+
+ ! J.-F. Grailet remark: previous_dx2 has not practical use.
+ real dx1,dx2,dy1,dy2,previous_dx1,previous_dx2
+ real lc(-1:13),nbr_lc,sum1
+ real dx3,dy3,dx4,dy4
+
+ NETcid = NCOPN("input/VEGE/glcesa3a.nc",NCNOWRIT,Rcode)
+ NET_ID = NCVID(NETcid,'Band1',Rcode)
+
+ write(6,*) 'GlobCover V.2.2 Land Cover'
+ write(6,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~'
+ write(6,*) ' '
+
+ IF (region.eq."GRD".or.region.eq."ANT") THEN
+
+ NETcid2= NCOPN("input/ICEmask/ICEmask_full.nc",NCNOWRIT,Rcode)
+ NET_ID2= NCVID(NETcid2,'MASK',Rcode)
+
+ write(6,*) 'Ice mask ESA CCI Land Cover User Tool (v.3.10)'
+ write(6,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+ write(6,*) ' '
+
+ ENDIF
+
+ previous_dx1=5
+ previous_dx2=5
+
+ ! Loads a single large data band for the whole dual loop
+ CALL bufLim (cy, 90., minL, dimL)
+
+ fiCell(1) = 1
+ fiCell(2) = minL+1
+ nCells(1) = cx
+ nCells(2) = dimL
+
+ allocate(arrCov(cx, dimL))
+ RCode = nf_get_vara_int(NETcid,NET_ID,fiCell,nCells,arrCov)
+
+ ! Ditto for the ice coverage
+ IF (region.eq."GRD".or.region.eq."ANT") THEN
+ allocate(arrIce(cx, dimL))
+ Rcode = nf_get_vara_int(NETcid2,NET_ID2,fiCell,nCells,arrIce)
+ ENDIF
+
+ DO j=1,my
+
+ ! Old display is no longer useful given the time/memory trade-off
+ ! WRITE(6,'(i4,$)') j
+
+ DO i=1,mx
+
+C + *****
+ IF(NSTsol(i,j)>=3)THEN
+C + *****
+
+ NSTsol(i,j)=max(4,NSTsol(i,j))
+
+ dx1=abs(NST__x(i,j)-
+ . NST__x(max(1,min(mx,i-1)),max(1,min(my,j))))
+ dx2=abs(NST__x(i,j)-
+ . NST__x(max(1,min(mx,i+1)),max(1,min(my,j))))
+
+ dx3=abs(NST__x(i,j)-
+ . NST__x(max(1,min(mx,i)),max(1,min(my,j-1))))
+ dx4=abs(NST__x(i,j)-
+ . NST__x(max(1,min(mx,i)),max(1,min(my,j+1))))
+
+ dx1=max(dx1,max(dx2,max(dx3,dx4)))
+
+ dy1=abs(NST__y(i,j)-
+ . NST__y(max(1,min(mx,i )),max(1,min(my,j-1))))
+ dy2=abs(NST__y(i,j)-
+ . NST__y(max(1,min(mx,i )),max(1,min(my,j+1))))
+
+ dy3=abs(NST__y(i,j)-
+ . NST__y(max(1,min(mx,i-1)),max(1,min(my,j))))
+ dy4=abs(NST__y(i,j)-
+ . NST__y(max(1,min(mx,i+1)),max(1,min(my,j))))
+
+ dy1=max(dy1,max(dy2,max(dy3,dy4)))
+
+ if(dx1<50) then
+ dx1=dx1/(2.*reso)
+ else
+ dx1=previous_dx1
+ endif
+
+ dy1=dy1/(2.*reso)
+
+ ins=nint((NST__x(i,j)+180.)/reso)
+ jns=nint((NST__y(i,j)+ 90.)/reso)
+
+ nbr_lc=0
+
+ do while(nbr_lc==0)
+
+ lc=0.
+
+ do k=ins-nint(dx1),ins+nint(dx1)
+ do l=jns-nint(dy1),jns+nint(dy1)
+
+ kk=k
+ ll=l
+ if(kk<1) kk=cx+kk
+ if(ll<1) ll=1 ! cy+ll (previous code used lat. rollover ?)
+ if(kk>cx) kk=kk-cx
+ if(ll>cy) ll=cy ! ll-cy (ditto)
+
+ kk=max(1,min(cx,kk))
+ ll=max(1,min(cy,ll))
+
+ cov = arrCov(kk,ll-minL)
+ icemask = 0
+ IF (region.eq."GRD".or.region.eq."ANT") THEN
+ icemask = arrIce(kk,ll-minL)
+ ENDIF
+
+ if(cov<0) cov=cov+256
+
+ IF ((region.eq."GRD".or.region.eq."ANT").and.icemask>0) THEN
+ lc(-1)=lc(-1)+1.! Permanent snow and ice
+ ELSE
+
+ if(cov==11) lc(0)=lc(0)+1. ! NO VEGETATION
+ if(cov==14) lc(1)=lc(1)+1. ! Rainfed croplands
+ if(cov==20) lc(2)=lc(2)+1. ! Mosaic cropland (50-70%) / vegetation (grassland/shrubland/forest) (20-50%)
+ if(cov==30) lc(3)=lc(3)+1. ! Mosaic vegetation (grassland/shrubland/forest) (50-70%) / cropland (20-50%)
+ if(cov==40) lc(9)=lc(9)+1. ! Closed to open (>15%) broadleaved evergreen or semi-deciduous forest (>5m)
+ if(cov==50) lc(9)=lc(9)+1. ! Closed (>40%) broadleaved deciduous forest (>5m)
+ if(cov==60) lc(8)=lc(8)+1. ! Open (15-40%) broadleaved deciduous forest/woodland (>5m)
+ if(cov==70) lc(12)=lc(12)+1.! Closed (>40%) needleleaved evergreen forest (>5m)
+ if(cov==90) lc(11)=lc(11)+1.! Open (15-40%) needleleaved deciduous or evergreen forest (>5m)
+ if(cov==100) lc(7)=lc(7)+1. ! Closed to open (>15%) mixed broadleaved and needleleaved forest (>5m)
+ if(cov==110) lc(6)=lc(6)+1. ! Mosaic forest or shrubland (50-70%) / grassland (20-50%)
+ if(cov==120) lc(5)=lc(5)+1. ! Mosaic grassland (50-70%) / forest or shrubland (20-50%)
+ if(cov==130) lc(10)=lc(10)+1.! Closed to open (>15%) (broadleaved or needleleaved, evergreen or deciduous) shrubland (<5m)
+ if(cov==140) lc(5)=lc(5)+1. ! Closed to open (>15%) herbaceous vegetation (grassland, savannas or lichens/mosses)
+ if(cov==150) lc(4)=lc(4)+1. ! Sparse (<15%) vegetation
+ if(cov==160) lc(7)=lc(7)+1. ! Closed to open (>15%) broadleaved forest regularly flooded (semi-permanently or temporarily)
+ if(cov==170) lc(9)=lc(9)+1. ! Closed (>40%) broadleaved forest or shrubland permanently flooded - Saline or brackish water
+ if(cov==180) lc(5)=lc(5)+1. ! Closed to open (>15%) grassland or woody vegetation on regularly flooded or waterlogged soil
+ if(cov==190) lc(13)=lc(13)+1.! Artificial surfaces and associated areas (Urban areas >50%)
+ if(cov==200) lc(0)=lc(0)+1. ! Bare areas
+ if(cov==220) lc(0)=lc(0)+1 ! Permanent snow and ice => Bare areas
+
+ ENDIF
+
+ enddo ; enddo
+
+ nbr_lc=0
+
+ do l=-1,13
+ nbr_lc=nbr_lc+lc(l)
+ enddo
+
+ dx1=dx1*1.5
+ dx2=dx2*1.5
+ dy1=dy1*1.5
+ dy2=dy2*1.5
+
+ enddo
+
+ ilc=-1
+
+ do l=1,mw-1
+
+ lcmax=0
+
+ do k=0,13
+
+ if(k/=1) then
+
+ if(l==1.and.lc(k)>=lcmax) then
+ lcmax=lc(k)
+ ilc(l)=k
+ endif
+
+ if(l==2.and.k/=ilc(1).and.lc(k)>=lcmax) then
+ lcmax=lc(k)
+ ilc(l)=k
+ endif
+
+ if(l==3.and.k/=ilc(1).and.k/=ilc(2).and.lc(k)>=lcmax) then
+ lcmax=lc(k)
+ ilc(l)=k
+ endif
+
+ if(l==4.and.k/=ilc(1).and.k/=ilc(2).and.
+ . k/=ilc(3).and.lc(k)>=lcmax) then
+ lcmax=lc(k)
+ ilc(l)=k
+ endif
+
+ if(l==5) then
+ print *,"mw>5!!" ; stop
+ endif
+
+ endif
+
+ enddo ; enddo
+
+ nbr_lc=0
+
+ do l=-1,13
+ nbr_lc=nbr_lc+lc(l)
+ enddo
+
+ IF (region.eq."GRD".or.region.eq."ANT")THEN
+ if(lc(-1)>0.1*nbr_lc.and.ilc(1)/=-1) then ! 10%
+ do k=mw+1,2,-1
+ ilc(k)=ilc(k-1)
+ enddo
+ ilc(1)=-1
+ endif
+ ENDIF
+
+ do k=1,mw-1
+
+ if(lc(ilc(k))>=0)then
+ NSTsvt(i,j,k)=ilc(k)
+ NSTsfr(i,j,k)=lc(ilc(k))/nbr_lc * 100.
+ else
+ NSTsvt(i,j,k)=0
+ NSTsfr(i,j,k)=0
+ endif
+
+ enddo
+
+ if(NSTsvt(i,j,1)==-1.and.NSTsfr(i,j,1)>0) then
+ NSTice(i,j) = NSTsfr(i,j,1)
+ else
+ NSTice(i,j) = 0.
+ endif
+
+ NSTsvt(i,j,mw)=1.
+ NSTsfr(i,j,mw)=0.
+
+ do l=1,mw-1
+ NSTsfr(i,j,l) = min(100.,max(0.,NSTsfr(i,j,l)))
+
+ if (NSTice(i,j)==0.and.NSTsfr(i,j,l)<10) then
+ NSTsfr(i,j,mw)= NSTsfr(i,j,mw) +NSTsfr(i,j,l)
+ NSTsfr(i,j,l) = 0.
+ endif ! sfr < 10% => the subpixel is removed
+ ! to gain computer time
+
+ NSTsfr(i,j,mw)= NSTsfr(i,j,mw) +NSTsfr(i,j,l)
+ enddo
+
+ if(NSTsfr(i,j,mw)>100.0001) then
+ print *,"ERROR: NSTsrf>100",i,j
+ do l=1,mw-1
+ print *,l,NSTsvt(i,j,l),NSTsfr(i,j,l)
+ enddo
+ stop
+ endif
+
+ NSTsfr(i,j,mw) = min(100.,max(0.,100. - NSTsfr(i,j,mw)))
+
+ sum1=0
+ do l=1,mw
+ sum1=sum1+NSTsfr(i,j,l)
+ enddo
+
+ do l=1,mw
+ NSTsfr(i,j,l) = NSTsfr(i,j,l)/sum1*100.
+ NSTveg(i,j,k) = NSTsvt(i,j,k)
+ NSTvfr(i,j,k) = NSTsfr(i,j,k)
+ enddo
+
+ DO l=1,nvx
+ IF (NSTsvt(i,j,l).le. 0) NSTlmx(i,j,l) = 0.0
+ IF (NSTsvt(i,j,l).eq. 1) NSTlmx(i,j,l) = 0.6
+ IF (NSTsvt(i,j,l).eq. 2) NSTlmx(i,j,l) = 0.9
+ IF (NSTsvt(i,j,l).eq. 3) NSTlmx(i,j,l) = 1.2
+ IF (NSTsvt(i,j,l).eq. 4) NSTlmx(i,j,l) = 0.7
+ IF (NSTsvt(i,j,l).eq. 5) NSTlmx(i,j,l) = 1.4
+ IF (NSTsvt(i,j,l).eq. 6) NSTlmx(i,j,l) = 2.0
+ IF (NSTsvt(i,j,l).eq. 7.or.NSTsvt(i,j,l).eq.10)
+ . NSTlmx(i,j,l) = 3.0
+ IF (NSTsvt(i,j,l).eq. 8.or.NSTsvt(i,j,l).eq.11)
+ . NSTlmx(i,j,l) = 4.5
+ IF (NSTsvt(i,j,l).eq. 9.or.NSTsvt(i,j,l).eq.12)
+ . NSTlmx(i,j,l) = 6.0
+
+ NSTlai(i,j,l) = NSTlmx(i,j,l)
+ NSTglf(i,j,l) = 1.0
+
+ ENDDO
+
+C + ****
+ ELSE ! Ocean, ice, snow
+C + ****
+
+ NSTsvt(i,j,nvx)= 0
+ NSTsfr(i,j,nvx)=100
+ NSTveg(i,j,nvx)= -1
+ NSTvfr(i,j,nvx)=100
+ DO l=1,nvx
+ NSTlai(i,j,l) = 0.0
+ NSTglf(i,j,l) = 0.0
+ ENDDO
+
+ previous_dx1=dx1
+ previous_dx2=dx2
+
+C + *****
+ ENDIF ! Continental areas
+C + *****
+
+ ENDDO
+ ENDDO
+
+ if (allocated(arrCov)) deallocate (arrCov)
+ if (allocated(arrIce)) deallocate (arrIce)
+
+ IF (region.eq."GRD") call USRgrd ("GLOcov")
+
+ END SUBROUTINE
diff --git a/MAR/code_nestor/src/GLOfrc.f b/MAR/code_nestor/src/GLOfrc.f
new file mode 100644
index 0000000000000000000000000000000000000000..1fc5c68cfaafae145a5eca64e361d6dc227bf48b
--- /dev/null
+++ b/MAR/code_nestor/src/GLOfrc.f
@@ -0,0 +1,1021 @@
+C +-------------------------------------------------------------------+
+C | Subroutine GLOfrc 18 March 2009 NESTING |
+C +-------------------------------------------------------------------+
+C | |
+C | GLOfrc read NDVI index (-> max. fract. of vegetation) over Africa |
+C | and Europe. |
+C | |
+C | Input : - NST__x, NST__y : NST grid coordinates (lat./long.) |
+C | ^^^^^^^ - NSTsol : soil type |
+C | - NSTveg : vegetation type (IGBP classification) |
+C | - NSTvfr : fraction of vegetation in the grid cell (IGBP) |
+C | - NSTsvt : vegetation type (SVAT classification) |
+C | - NSTsfr : fraction of vegetation in the grid cell (SVAT) |
+C | |
+C | Output: - NSTveg : vegetation type (IGBP classification) |
+C | ^^^^^^^ - NSTvfr : fraction of vegetation in the grid cell (IGBP) |
+C | - NSTsvt : vegetation type (SVATclassification) |
+C | - NSTsfr : fraction of vegetation in the grid cell (SVAT) |
+C | - NSTfrc : fraction of vegetation cover (from NDVI index) |
+C | - NSTdv1 : minimum NDVI index over a period of one year |
+C | - NSTdv2 : maximum NDVI index over a period of one year |
+C | |
+C | Remark: Note that NSTveg = -1 (IGBP) or NSTsvt = 0 (SVAT) corres- |
+C | ^^^^^^^ pond to bare soil (no vegetation). |
+C | NSTvfr and NSTsfr give vegetation fraction in % (integer) |
+C | |
+C +-------------------------------------------------------------------+
+
+
+ SUBROUTINE GLOfrc
+
+ IMPLICIT none
+
+
+C +---General variables
+C + -----------------
+
+ INCLUDE 'NSTdim.inc'
+ INCLUDE 'NSTvar.inc'
+ INCLUDE 'LOCfil.inc'
+ INCLUDE 'NetCDF.inc'
+ INCLUDE 'NESTOR.inc'
+
+C +---Local variables
+C + ---------------
+
+ INTEGER nbchar,
+ . i,j,k,l,ii,jj,size_X(nbdom),size_Y(nbdom),
+ . i1,i2,j1,j2,i_cent,j_cent,G_nx,G_ny,totvfr,
+ . ncid(nbdom),start(3),count(3),lmin,frac_ini,
+ . vegtmp,frctmp,ndv1ID(nbdom),ndv2ID(nbdom),
+ . EURcid,EUR1ID,EUR2ID,AFR_size_X,AFR_size_Y,
+ . AFRcid,EUR_size_X,EUR_size_Y,Rcode,frac_max,vauxID,
+ . AFR1ID,AFR2ID,lmax,idom,EUidom,AFidom,error,iauxID,
+ . NAidom,SAidom,NAMcid,NAM1ID,NAM2ID,NAM_size_X,
+ . NAM_size_Y,SAMcid,SAM1ID,SAM2ID,SAM_size_X,
+ . SAM_size_Y,int_1,int_2,ii1,ii2,jj1,jj2,mmx,mmy
+
+ INTEGER int_3,first
+
+ INTEGER*2 val1,val2
+
+!HG v
+ integer*2, allocatable :: VIEmin(:,:)
+ integer*2, allocatable :: VIEmax(:,:)
+ integer*2, allocatable :: VIAmin(:,:)
+ integer*2, allocatable :: VIAmax(:,:)
+!HG ^
+
+ REAL AUXlo1,AUXla1,AUXlo2,AUXla2,G_reso(nbdom),
+ . AUXlon,AUXlat,G_lon1(nbdom),G_lat1(nbdom),
+ . aux1,aux2,aux3,cmpt1,cmpt2,iAVndv1,iAVndv2,
+ . AFR_G_lon1,AFR_G_lat1,degrad,
+ . AFR_G_reso,AFR_G_lon2,AFR_G_lat2,EUR_G_lat1,
+ . EUR_G_lon1,EUR_G_reso,EUR_G_lon2,EUR_G_lat2,
+ . NAM_G_lon1,NAM_G_lat1,NAM_G_reso,NAM_G_lon2,
+ . NAM_G_lat2,SAM_G_lon1,SAM_G_lat1,SAM_G_reso,
+ . SAM_G_lon2,SAM_G_lat2,Rval1,Rval2,
+ . dx,dy,G_dx,G_dy,VEGfrc,AVndv1,AVndv2,VEGaux
+
+ LOGICAL Vtrue,Vfalse,AFRdom,EURdom,NAMdom,SAMdom,NDVclim
+
+ CHARACTER*2 nustri(0:99)
+ CHARACTER*60 EURndvdir,AFRndvdir,NAMndvdir,SAMndvdir
+ CHARACTER*80 EURndv_file,AFRndv_file,NAMndv_file,
+ . SAMndv_file
+
+
+C +---Data
+C + ----
+
+ DATA degrad / 1.745329252d-2 /
+ DATA Vtrue / .true. /
+ DATA Vfalse / .false. /
+
+ DATA (nustri(i),i=0,99)
+ . /'00','01','02','03','04','05','06','07','08','09',
+ . '10','11','12','13','14','15','16','17','18','19',
+ . '20','21','22','23','24','25','26','27','28','29',
+ . '30','31','32','33','34','35','36','37','38','39',
+ . '40','41','42','43','44','45','46','47','48','49',
+ . '50','51','52','53','54','55','56','57','58','59',
+ . '60','61','62','63','64','65','66','67','68','69',
+ . '70','71','72','73','74','75','76','77','78','79',
+ . '80','81','82','83','84','85','86','87','88','89',
+ . '90','91','92','93','94','95','96','97','98','99'/
+
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Grid parameters
+C + ===============
+
+
+ EUidom = 1 ! Europe
+ AFidom = 2 ! Africa
+c #AM NAidom = 3 ! North America
+c #AM SAidom = 4 ! South America
+
+
+C +---1-KM RESOLUTION DATA
+C + = = = = = = = = = = =
+
+ IF (NDV1km) THEN
+
+
+C +---Europe
+C + ------
+
+ EUR_G_lat1= 0.1200000E+02
+ EUR_G_lon1=-0.1100000E+02
+ EUR_G_reso= 0.0100000E+00
+ EUR_size_X= 8500
+ EUR_size_Y= 6000
+ EUR_G_lon2= EUR_G_lon1+REAL(EUR_size_X)*EUR_G_reso
+ EUR_G_lat2= EUR_G_lat1+REAL(EUR_size_Y)*EUR_G_reso
+
+C +---Africa
+C + ------
+
+ AFR_G_lat1=-0.3500000E+02
+ AFR_G_lon1=-0.2000000E+02
+ AFR_G_reso= 0.0100000E+00
+ AFR_size_X= 8000
+ AFR_size_Y= 7500
+ AFR_G_lon2= AFR_G_lon1+REAL(AFR_size_X)*AFR_G_reso
+ AFR_G_lat2= AFR_G_lat1+REAL(AFR_size_Y)*AFR_G_reso
+
+C +---North America
+C + -------------
+
+c #AM NAM_G_lat1= 0.1200000E+02
+c #AM NAM_G_lon1=-0.1100000E+02
+c #AM NAM_G_reso= 0.0100000E+00
+c #AM NAM_size_X= 8500
+c #AM NAM_size_Y= 6000
+c #AM NAM_G_lon2= NAM_G_lon1+REAL(NAM_size_X)*NAM_G_reso
+c #AM NAM_G_lat2= NAM_G_lat1+REAL(NAM_size_Y)*NAM_G_reso
+
+
+C +---South America
+C + -------------
+
+c #AM SAM_G_lat1= 0.1200000E+02
+c #AM SAM_G_lon1=-0.1100000E+02
+c #AM SAM_G_reso= 0.0100000E+00
+c #AM SAM_size_X= 8500
+c #AM SAM_size_Y= 6000
+c #AM SAM_G_lon2= SAM_G_lon1+REAL(SAM_size_X)*SAM_G_reso
+c #AM SAM_G_lat2= SAM_G_lat1+REAL(SAM_size_Y)*SAM_G_reso
+
+
+ ENDIF ! (NDV1km)
+
+
+C +---8-KM RESOLUTION DATA
+C + = = = = = = = = = = =
+
+
+ IF (NDV8km) THEN
+
+
+C +---Africa
+C + ------
+
+ AFR_G_lat1=-0.380000000000E+02
+ AFR_G_lon1=-0.200000000000E+02
+ AFR_G_reso= 0.083333333333E+00
+ AFR_size_X= 984
+ AFR_size_Y= 924
+ AFR_G_lon2= AFR_G_lon1+REAL(AFR_size_X)*AFR_G_reso
+ AFR_G_lat2= AFR_G_lat1+REAL(AFR_size_Y)*AFR_G_reso
+
+
+ ENDIF ! (NDV8km)
+
+
+C +---Select grid parameters
+C + ----------------------
+
+ AFRdom=.false.
+ EURdom=.false.
+ NAMdom=.false.
+ SAMdom=.false.
+
+ DO j=1,my
+ DO i=1,mx
+
+ IF (NSTinc(i,j,AFidom)) AFRdom=.true.
+ IF (NSTinc(i,j,EUidom)) EURdom=.true.
+c #AM IF (NSTinc(i,j,NAidom)) NAMdom=.true.
+c #AM IF (NSTinc(i,j,SAidom)) SAMdom=.true.
+
+ ENDDO
+ ENDDO
+
+
+C +---Screen message
+C + ==============
+
+ IF (AFRdom) THEN
+ write(6,*) 'NDVI Min/Max index over Africa'
+ ENDIF
+
+ IF (EURdom) THEN
+ write(6,*) 'NDVI Min/Max index over Europe'
+ ENDIF
+
+ IF (NAMdom) THEN
+ write(6,*) 'NDVI Min/Max index over N. America'
+ ENDIF
+
+ IF (SAMdom) THEN
+ write(6,*) 'NDVI Min/Max index over S. America'
+ ENDIF
+
+ IF (AFRdom.or.EURdom.or.NAMdom.or.SAMdom) THEN
+ write(6,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+ write(6,*)
+ ENDIF
+
+ IF ((.not.EURdom).and.(.not.AFRdom).and.
+ . (.not.NAMdom).and.(.not.SAMdom)) THEN
+ write(6,*) '***************'
+ write(6,*) '*** CAUTION ***'
+ write(6,*) '***************'
+ write(6,*)
+ write(6,*) 'No NDVI index available for this domain !!!'
+ write(6,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+ write(6,*)
+ GOTO 990
+ ENDIF
+
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Select MIN/MAX NDVI file
+C + ========================
+
+
+C +---Year and month ?
+C + ----------------
+
+C + ******
+ CALL DATcnv (RUNiyr,RUNmma,RUNjda,RUNjhu,DATtim,Vfalse)
+C + ******
+
+
+ IF (NDV1km) THEN
+
+
+C +....Africa
+
+ nbchar=1
+ AFRndvdir=AFRndv_dir
+
+ DO i=1,60
+ IF (AFRndvdir(i:i).ne.' ') nbchar=i
+ ENDDO
+
+ AFRndv_file=AFRndvdir(1:nbchar)//'AFRndv.nc'
+
+C +... Europe
+
+ nbchar=1
+ EURndvdir=EURndv_dir
+
+ DO i=1,60
+ IF (EURndvdir(i:i).ne.' ') nbchar=i
+ ENDDO
+
+ EURndv_file=EURndvdir(1:nbchar)//'EURndv.nc'
+
+
+C +... North America
+
+c #AM nbchar=1
+c #AM NAMndvdir=NAMndv_dir
+
+c #AM DO i=1,60
+c #AM IF (NAMndvdir(i:i).ne.' ') nbchar=i
+c #AM ENDDO
+
+c #AM NAMndv_file=NAMndvdir(1:nbchar)//'NAMndv.nc'
+
+
+C +... South America
+
+c #AM nbchar=1
+c #AM SAMndvdir=SAMndv_dir
+
+c #AM DO i=1,60
+c #AM IF (SAMndvdir(i:i).ne.' ') nbchar=i
+c #AM ENDDO
+
+c #AM SAMndv_file=SAMndvdir(1:nbchar)//'SAMndv.nc'
+
+
+ ENDIF ! (NDV1km)
+
+
+ IF (NDV8km) THEN
+
+
+C +....Africa
+
+ nbchar=1
+ AFRndvdir=AFRndv8dir
+
+ DO i=1,60
+ IF (AFRndvdir(i:i).ne.' ') nbchar=i
+ ENDDO
+
+ int_1 = RUNiyr/100
+ int_2 = RUNiyr - (int_1*100)
+
+ AFRndv_file=AFRndvdir(1:nbchar)//'AFRndv.'
+ . //nustri(int_1 )
+ . //nustri(int_2 )
+ . //'.nc'
+
+ ENDIF ! (NDV8km)
+
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Open Netcdf data file - NDVI index
+C + ==================================
+
+ AFRcid=-1 ; AFR1ID=-1 ; AFR2ID=-1
+ EURcid=-1 ; EUR1ID=-1 ; EUR2ID=-1
+
+ IF (AFRdom) THEN
+C + *****
+ AFRcid = NCOPN(AFRndv_file,NCNOWRIT,Rcode)
+ AFR1ID = NCVID(AFRcid,'NDVImin',Rcode)
+ AFR2ID = NCVID(AFRcid,'NDVImax',Rcode)
+C + *****
+ ENDIF
+
+ IF (EURdom.and..not.NDV8km) THEN
+C + *****
+ EURcid = NCOPN(EURndv_file,NCNOWRIT,Rcode)
+ EUR1ID = NCVID(EURcid,'NDVImin',Rcode)
+ EUR2ID = NCVID(EURcid,'NDVImax',Rcode)
+C + *****
+ ENDIF
+
+c #AM IF (NAMdom.and..not.NDV8km) THEN
+C + *****
+c #AM NAMcid = NCOPN(NAMndv_file,NCNOWRIT,Rcode)
+c #AM NAM1ID = NCVID(NAMcid,'NDVImin',Rcode)
+c #AM NAM2ID = NCVID(NAMcid,'NDVImax',Rcode)
+C + *****
+c #AM ENDIF
+
+c #AM IF (SAMdom.and..not.NDV8km) THEN
+C + *****
+c #AM SAMcid = NCOPN(SAMndv_file,NCNOWRIT,Rcode)
+c #AM SAM1ID = NCVID(SAMcid,'NDVImin',Rcode)
+c #AM SAM2ID = NCVID(SAMcid,'NDVImax',Rcode)
+C + *****
+c #AM ENDIF
+
+
+C +---Initialisation of fraction of vegetation cover
+C + ==============================================
+
+ DO j=1,my
+ DO i=1,mx
+ NSTfrc(i,j)=0.
+ NSTdv1(i,j)=0.
+ NSTdv2(i,j)=0.
+ ENDDO
+ ENDDO
+
+
+C +---Select domains (Africa and/or Europe)
+C + =====================================
+
+C +---idom = 1 : Europe
+C + -----------------
+
+ G_lat1(EUidom)=EUR_G_lat1
+ G_lon1(EUidom)=EUR_G_lon1
+ G_reso(EUidom)=EUR_G_reso
+ size_X(EUidom)=EUR_size_X
+ size_Y(EUidom)=EUR_size_Y
+ ndv1ID(EUidom)=EUR1ID
+ ndv2ID(EUidom)=EUR2ID
+ ncid (EUidom)=EURcid
+
+!HG v
+ idom = EUidom
+ start(1) = 1
+ start(2) = 1
+ count(2) = 6000
+ count(1) = 8500
+
+ allocate (VIEmin(8500,6000))
+ allocate (VIEmax(8500,6000))
+
+ IF (EURdom.and..not.NDV8km) THEN
+ write(*,*) ' '
+ write(*,*) 'INPUT from EURndv.nc BEGIN'
+
+! ****************
+ CALL NCVGT (ncid(idom),ndv1ID(idom),start,count,VIEmin,Rcode)
+ CALL NCVGT (ncid(idom),ndv2ID(idom),start,count,VIEmax,Rcode)
+! ****************
+
+ write(*,*) 'INPUT from EURndv.nc ENDED'
+ write(*,*) ' '
+ endif
+!HG ^
+
+C +---idom = 2 : Africa
+C + -----------------
+
+ G_lat1(AFidom)=AFR_G_lat1
+ G_lon1(AFidom)=AFR_G_lon1
+ G_reso(AFidom)=AFR_G_reso
+ size_X(AFidom)=AFR_size_X
+ size_Y(AFidom)=AFR_size_Y
+ ndv1ID(AFidom)=AFR1ID
+ ndv2ID(AFidom)=AFR2ID
+ ncid (AFidom)=AFRcid
+
+!HG v
+ idom = AFidom
+ start(1) = 1
+ start(2) = 1
+ count(2) = 7500
+ count(1) = 8000
+
+ allocate (VIAmin(8000,7500))
+ allocate (VIAmax(8000,7500))
+
+ IF (AFRdom) THEN
+ write(*,*) ' '
+ write(*,*) 'INPUT from AFRndv.nc BEGIN'
+
+! ****************
+ CALL NCVGT (ncid(idom),ndv1ID(idom),start,count,VIAmin,Rcode)
+ CALL NCVGT (ncid(idom),ndv2ID(idom),start,count,VIAmax,Rcode)
+! ****************
+
+ write(*,*) 'INPUT from AFRndv.nc ENDED'
+ write(*,*) ' '
+ ENDIF
+!HG ^
+
+
+
+C +---idom = 3 : North America
+C + ------------------------
+
+c #AM G_lat1(NAidom)=NAM_G_lat1
+c #AM G_lon1(NAidom)=NAM_G_lon1
+c #AM G_reso(NAidom)=NAM_G_reso
+c #AM size_X(NAidom)=NAM_size_X
+c #AM size_Y(NAidom)=NAM_size_Y
+c #AM ndv1ID(NAidom)=NAM1ID
+c #AM ndv2ID(NAidom)=NAM2ID
+c #AM ncid (NAidom)=NAMcid
+
+
+C +---idom = 4 : South America
+C + ------------------------
+
+c #AM G_lat1(SAidom)=SAM_G_lat1
+c #AM G_lon1(SAidom)=SAM_G_lon1
+c #AM G_reso(SAidom)=SAM_G_reso
+c #AM size_X(SAidom)=SAM_size_X
+c #AM size_Y(SAidom)=SAM_size_Y
+c #AM ndv1ID(SAidom)=SAM1ID
+c #AM ndv2ID(SAidom)=SAM2ID
+c #AM ncid (SAidom)=SAMcid
+
+
+C +---Search for MIN/MAX values of NDVI
+C + =================================
+
+ NDVmin = 1000.
+ NDVmax = 0.
+ NDVclim=.false.
+c IF (Region .eq. "AFW") NDVclim=.true.
+
+ IF (NDVclim) THEN
+
+! int_3 = NCOPN('./input/NDVI08/maxNDVI83-92.nc',NCNOWRIT,Rcode)
+! iauxID = NCVID(int_3,'NDVImax',Rcode)
+ NDVmin(idom) = 135.
+ NDVmax(idom) = 240.
+
+ ELSE
+
+
+ DO idom=1,nbdom
+
+c IF (idom.eq.2.and.AFRdom) THEN
+
+c DO l=1,size_Y(idom)
+c DO k=1,size_X(idom)
+
+c start(1)=k
+c start(2)=l
+c count(1)=1
+c count(2)=1
+
+C + *****
+c CALL NCVGT (ncid(idom),ndv1ID(idom),start,count,val1,Rcode)
+c CALL NCVGT (ncid(idom),ndv2ID(idom),start,count,val2,Rcode)
+C + *****
+
+c Rval1 = REAL(val1)
+c IF (Rval1.gt.2.) NDVmin(idom) = MIN(NDVmin(idom),Rval1)
+C +... ^^^ value (in input file) corresponding to bare soil
+C +... e.g. : desert (Sahara) or city
+
+c Rval2 = REAL(val2)
+c NDVmax(idom) = MAX(NDVmax(idom),Rval2)
+C +... ^^^ value (in input file) corresponding to dense vegetation
+C +... e.g. : tropical forest
+
+c ENDDO ! k=1,size_X(idom)
+c ENDDO ! l=1,size_Y(idom)
+
+c ENDIF ! Condition on idom, EURdom and AFRdom
+
+ IF ((idom.eq.2.and.AFRdom)) THEN
+ NDVmin(idom) = 49.
+ NDVmax(idom) = 185.
+ ENDIF
+
+ IF ((idom.eq.1.and.EURdom)) THEN
+ NDVmin(idom) = 98.
+ NDVmax(idom) = 185.
+ ENDIF
+
+ ENDDO ! idom=1,nbdom
+ ENDIF
+
+ NDVmin = NDVmin * 1.10
+C +...Corrected NDVmin
+
+
+C +---Treatment of each NST grid point (except boundaries)
+C + ====================================================
+
+ mmx = mx
+ mmy = my
+ ii1 = MIN(2,mmx)
+ ii2 = MAX(1,mmx-1)
+ IF (mmx.eq.1) THEN
+ ii1 = 1
+ ii2 = 1
+ ENDIF
+ jj1 = MIN(2,mmy)
+ jj2 = MAX(1,mmy-1)
+ IF (mmy.eq.1) THEN
+ jj1 = 1
+ jj2 = 1
+ ENDIF
+
+
+ DO j=jj1,jj2 ! Loop on NST grid points
+ DO i=ii1,ii2 ! -----------------------
+
+
+C +---Initialisation of NDVI variables
+C + ================================
+
+ AVndv1=0.
+ AVndv2=0.
+
+
+C +---Location of NST grid cell in the input data grid
+C + ================================================
+
+ DO idom=1,nbdom
+
+ IF (NSTinc(i,j,idom).and.(G_reso(idom).gt.0.)) THEN
+
+
+C +---Search for the closest point in data file
+C + -----------------------------------------
+
+ AUXlon = NST__x(i,j)
+ AUXlat = NST__y(i,j)
+C + ******
+ CALL SPHERC (Vtrue,AUXlon,AUXlat)
+C + ******
+
+ i_cent=NINT((AUXlon-G_lon1(idom))/G_reso(idom))+1
+ j_cent=NINT((AUXlat-G_lat1(idom))/G_reso(idom))+1
+
+
+C +---Check if (i,j) belong to the data domain
+C + ----------------------------------------
+
+ IF (i_cent.lt.3 .or. i_cent.gt.(size_X(idom)-2) .or.
+ . j_cent.lt.3 .or. j_cent.gt.(size_Y(idom)-2)) GOTO 900
+
+
+C +---Compute the resolution of the considered NST cell
+C + -------------------------------------------------
+
+ dx = 0.0
+ dy = 0.0
+
+ IF (mmx.ne.1.and.mmy.ne.1) THEN
+ ii=MAX(i,2)
+ jj=MAX(j,2)
+ AUXlo1 = NST__x(ii ,jj )
+ AUXlo2 = NST__x(ii-1,jj-1)
+ AUXla1 = NST__y(ii ,jj )
+ AUXla2 = NST__y(ii-1,jj-1)
+ ELSE
+ IF (mmx.ne.1) THEN
+ ii=MAX(i,2)
+ jj=1
+ AUXlo1 = NST__x(ii ,jj)
+ AUXlo2 = NST__x(ii-1,jj)
+ AUXla1 = NST__y(ii ,jj)
+ AUXla2 = NST__y(ii-1,jj)
+ ELSE
+ ii=1
+ jj=1
+ AUXlo1 = NST__x(ii,jj)
+ AUXlo2 = NST__x(ii,jj)
+ AUXla1 = NST__y(ii,jj)
+ AUXla2 = NST__y(ii,jj)
+ ENDIF
+
+ ENDIF
+
+C + ******
+ CALL SPHERC (Vtrue,AUXlo1,AUXla1)
+ CALL SPHERC (Vtrue,AUXlo2,AUXla2)
+C + ******
+ dx=ABS(AUXlo1-AUXlo2)*111111.*COS(AUXla1*degrad)
+ dy=ABS(AUXla1-AUXla2)*111111.
+
+
+C +---Define the data points to be read around (i_cent,j_cent)
+C + --------------------------------------------------------
+
+ G_dx = G_reso(idom)*111111.*COS(AUXla1*degrad)
+ G_dy = G_reso(idom)*111111.
+
+ G_nx=NINT(dx/G_dx/2.)-1
+ G_ny=NINT(dy/G_dy/2.)-1
+
+ G_nx=MAX(G_nx,0)
+ G_ny=MAX(G_ny,0)
+
+ first=0.
+1000 continue
+
+ IF (mmx.eq.1) G_nx=0
+ IF (mmy.eq.1) G_ny=0
+
+ i1=i_cent-G_nx
+ i2=i_cent+G_nx
+ j1=j_cent-G_ny
+ j2=j_cent+G_ny
+
+ i1=MAX(i1,1)
+ i2=MIN(i2,size_X(idom))
+ j1=MAX(j1,1)
+ j2=MIN(j2,size_Y(idom))
+
+C +---Initialisation of temporary NDVI variables
+C + ==========================================
+
+ iAVndv1=0.
+ iAVndv2=0.
+ cmpt1 =0.
+ cmpt2 =0.
+
+
+C +---Reading of input data
+C + =====================
+
+ IF (NDVclim) THEN
+
+ DO l=j1,j2
+ DO k=i1,i2
+
+ start(1)=k
+ start(2)=l
+ count(1)=1
+ count(2)=1
+
+C + *****
+ CALL NCVGT (int_3,iauxID,start,count,val2,Rcode)
+C + *****
+ IF (NDV8km) THEN
+ IF (val2.gt.100.) THEN
+ iAVndv2=iAVndv2+REAL(val2)
+ cmpt2 =cmpt2 +1.
+ ENDIF
+ ENDIF
+c +
+ ENDDO
+ ENDDO
+c +
+ IF (cmpt2.gt.0.) THEN
+ iAVndv2 = iAVndv2 / cmpt2
+ ELSE
+ iAVndv2 = 0.
+ ENDIF
+
+ ELSE
+c +
+ DO l=j1,j2
+ DO k=i1,i2
+
+ start(1)=k
+ start(2)=l
+ count(1)=1
+ count(2)=1
+
+C + *****
+! CALL NCVGT (ncid(idom),ndv1ID(idom),start,count,val1,Rcode)
+! CALL NCVGT (ncid(idom),ndv2ID(idom),start,count,val2,Rcode)
+C + *****
+
+ IF (NDV1km) THEN
+
+!HG v
+ IF (idom.EQ.EUidom) THEN
+ val1=VIEmin(k,l)
+ val2=VIEmax(k,l)
+ END IF
+ IF (idom.EQ.AFidom) THEN
+ val1=VIAmin(k,l)
+ val2=VIAmax(k,l)
+ END IF
+!HG ^
+
+ IF (val1.gt.100) THEN
+ iAVndv1=iAVndv1+REAL(val1)
+ cmpt1 =cmpt1 +1.
+ ENDIF
+ IF (val2.gt.100) THEN
+ iAVndv2=iAVndv2+REAL(val2)
+ cmpt2 =cmpt2 +1.
+ ENDIF
+ ENDIF
+
+ IF (NDV8km) THEN
+ IF (val1.gt.1) THEN
+ iAVndv1=iAVndv1+REAL(val1)
+ cmpt1 =cmpt1 +1.
+ ENDIF
+ IF (val2.gt.1) THEN
+ iAVndv2=iAVndv2+REAL(val2)
+ cmpt2 =cmpt2 +1.
+ ENDIF
+ ENDIF
+
+ ENDDO
+ ENDDO
+
+ IF (cmpt1.gt.0.) THEN
+ iAVndv1 = iAVndv1 / cmpt1
+ ELSE
+ iAVndv1 = 0.
+ ENDIF
+
+ IF (cmpt2.gt.0.) THEN
+ iAVndv2 = iAVndv2 / cmpt2
+ ELSE
+ iAVndv2 = 0.
+ ENDIF
+C +
+ ENDIF ! Condition on NDVclim
+
+
+ IF (iAVndv1.ge.AVndv1 .and. iAVndv2.ge.AVndv2) THEN
+ AVndv1=iAVndv1
+ AVndv2=iAVndv2
+ ENDIF
+
+ IF (NSTsol(i,j).eq.4.and.AVndv1.eq.0.and.
+ . AVndv2.eq.0.and.first.eq.0) THEN
+ G_nx=G_nx*2.
+ G_ny=G_ny*2.
+ print *,"WARNING: no NDVImin data for (DOM,i,j):"
+ . ,idom,i,j
+ first=1
+ goto 1000
+ ENDIF
+
+ ENDIF ! Condition on NSTinc
+
+ ENDDO ! Loop on idom
+
+C +---Compute normalized NDVI index
+C + =============================
+
+ DO idom=1,nbdom
+ IF (NSTinc(i,j,idom)) THEN
+
+ NSTdv1(i,j) = AVndv1
+ NSTdv1(i,j) = MIN(NSTdv1(i,j),NDVmax(idom))
+ NSTdv1(i,j) = MAX(NSTdv1(i,j),NDVmin(idom))
+
+ NSTdv2(i,j) = AVndv2
+ NSTdv2(i,j) = MIN(NSTdv2(i,j),NDVmax(idom))
+ NSTdv2(i,j) = MAX(NSTdv2(i,j),NDVmin(idom))
+
+C +---Estimate of vegetation cover
+C + ============================
+
+ VEGaux =
+ . (NSTdv2(i,j) - NDVmin(idom)) / (NDVmax(idom) - NDVmin(idom))
+ ENDIF
+
+C +---Exclusion grid cell dominated by water, ice or snow
+C + ===================================================
+
+ IF(NSTsol(i,j).le.3) THEN
+ NSTdv1(i,j) = 0
+ NSTdv2(i,j) = 0
+ ENDIF
+
+ ENDDO
+
+ VEGfrc = VEGaux*(2.-VEGaux-EXP(-2.5*VEGaux))
+ VEGfrc = MAX(VEGfrc,0.01)
+
+ IF (NSTsol(i,j).le.3) THEN
+ NSTfrc(i,j) = 0.
+ ELSE
+ NSTfrc(i,j) = VEGfrc
+ ENDIF
+
+
+C +---Modification of fractions of IGBP vegetation cover
+C + ==================================================
+
+ IF (NSTsol(i,j).ge.4) THEN
+
+C +... Search for the less dominant class
+ frac_ini=100
+ DO l=1,nvx
+ IF (NSTvfr(i,j,l).lt.frac_ini) THEN
+ lmin =l
+ frac_ini=NSTvfr(i,j,l)
+ ENDIF
+ ENDDO
+
+C +... Attribution of bare soil type (convention = -1)
+ NSTveg(i,j,lmin)=-1
+ NSTvfr(i,j,lmin)=NINT((1.-VEGfrc)*100.)
+
+C +... Normalization of NSTvfr
+ totvfr=0
+ DO l=1,nvx
+ totvfr=totvfr+NSTvfr(i,j,l)
+ ENDDO
+ totvfr=totvfr-NSTvfr(i,j,lmin)
+ IF (totvfr.ne.0) THEN
+ DO l=1,nvx
+ IF (l.ne.lmin) THEN
+ aux1 =REAL(NSTvfr(i,j,l))
+ aux2 =REAL(totvfr)
+ aux3 =REAL(NSTvfr(i,j,lmin))
+ NSTvfr(i,j,l)=NINT(aux1/aux2*(100.-aux3))
+ ENDIF
+ ENDDO
+ ELSE
+ DO l=1,nvx
+ NSTvfr(i,j,l) =0
+ ENDDO
+ NSTvfr(i,j,lmin)=100
+ ENDIF
+
+C +... Reordering of vegetation types
+ lmax =1
+ frac_max=0
+ DO l=1,nvx
+ IF (NSTvfr(i,j,l).gt.frac_max) THEN
+ lmax =l
+ frac_max=NSTvfr(i,j,l)
+ ENDIF
+ ENDDO
+ vegtmp=NSTveg(i,j,lmax)
+ frctmp=NSTvfr(i,j,lmax)
+ NSTveg(i,j,lmax)=NSTveg(i,j,1)
+ NSTvfr(i,j,lmax)=NSTvfr(i,j,1)
+ NSTveg(i,j,1) =vegtmp
+ NSTvfr(i,j,1) =frctmp
+
+ ENDIF
+
+
+C +---Modification of fractions of SVAT vegetation cover
+C + ==================================================
+
+ IF (NSTsol(i,j).ge.4) THEN
+
+C +... Attribution of bare soil type
+ NSTsvt(i,j,nvx)=1
+ NSTsfr(i,j,nvx)=NINT((1.-VEGfrc)*100.)
+
+C +... Normalization of NSTsfr
+ totvfr=0
+ DO l=1,nvx
+ totvfr=totvfr+NSTsfr(i,j,l)
+ ENDDO
+ totvfr=totvfr-NSTsfr(i,j,nvx)
+ IF (totvfr.ne.0) THEN
+ DO l=1,nvx-1
+ aux1 =REAL(NSTsfr(i,j,l))
+ aux2 =REAL(totvfr)
+ aux3 =REAL(NSTsfr(i,j,nvx))
+ NSTsfr(i,j,l)=NINT(aux1/aux2*(100.-aux3))
+ ENDDO
+ ELSE
+ DO l=1,nvx
+ NSTsfr(i,j,l) =0
+ ENDDO
+ NSTsfr(i,j,nvx)=100
+ ENDIF
+
+C +... Reordering of vegetation types
+ccccc lmax =1
+ccccc frac_max=0
+ccccc DO l=1,nvx-1
+ccccc IF (NSTsfr(i,j,l).gt.frac_max) THEN
+ccccc lmax =l
+ccccc frac_max=NSTsfr(i,j,l)
+ccccc ENDIF
+ccccc ENDDO
+ccccc vegtmp=NSTsvt(i,j,lmax)
+ccccc frctmp=NSTsfr(i,j,lmax)
+ccccc NSTsvt(i,j,lmax)=NSTsvt(i,j,1)
+ccccc NSTsfr(i,j,lmax)=NSTsfr(i,j,1)
+ccccc NSTsvt(i,j,1) =vegtmp
+ccccc NSTsfr(i,j,1) =frctmp
+
+ ENDIF
+
+
+900 CONTINUE
+
+
+ ENDDO ! Loop on NST grid points
+ ENDDO ! -----------------------
+
+C +---Close Netcdf data file
+C + ======================
+
+ IF (AFRdom) THEN
+C + ******
+ CALL NCCLOS(AFRcid,Rcode)
+C + ******
+ ENDIF
+
+ IF (EURdom.and..not.NDV8km) THEN
+C + ******
+ CALL NCCLOS(EURcid,Rcode)
+C + ******
+ ENDIF
+
+c #AM IF (NAMdom.and..not.NDV8km) THEN
+C + ******
+c #AM CALL NCCLOS(NAMcid,Rcode)
+C + ******
+c #AM ENDIF
+
+c #AM IF (SAMdom.and..not.NDV8km) THEN
+C + ******
+c #AM CALL NCCLOS(SAMcid,Rcode)
+C + ******
+c #AM ENDIF
+
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+990 CONTINUE
+
+!HG v
+ IF (NDV1km) THEN
+ deallocate (VIEmin)
+ deallocate (VIEmax)
+ deallocate (VIAmin)
+ deallocate (VIAmax)
+ END IF
+!HG ^
+
+ RETURN
+ END
diff --git a/MAR/code_nestor/src/GLOglf.f b/MAR/code_nestor/src/GLOglf.f
new file mode 100644
index 0000000000000000000000000000000000000000..7ffda899d08548facd98e097b69167a255b6ba59
--- /dev/null
+++ b/MAR/code_nestor/src/GLOglf.f
@@ -0,0 +1,1033 @@
+C +-------------------------------------------------------------------+
+C | Subroutine GLOglf 18 March 2009 NESTING |
+C +-------------------------------------------------------------------+
+C | |
+C | GLOglf read NDVI index over Africa and Europe to determine the |
+C | green leaf fraction. |
+C | |
+C | Input : - NST__x, NST__y : NST grid coordinates (lat./long.) |
+C | ^^^^^^^ - NSTsol : soil type |
+C | - NSTdv1 : minimum NDVI index |
+C | - NSTdv2 : maximum NDVI index |
+C | |
+C | Output: - NSTglf : green leaf fraction (from NDVI index) |
+C | ^^^^^^^ - NSTlai : leaf area index (from NDVI index) |
+C | |
+C +-------------------------------------------------------------------+
+
+
+ SUBROUTINE GLOglf
+
+ IMPLICIT none
+
+
+C +---General variables
+C + -----------------
+
+ INCLUDE 'NSTdim.inc'
+ INCLUDE 'NSTvar.inc'
+ INCLUDE 'NESTOR.inc'
+ INCLUDE 'LOCfil.inc'
+ INCLUDE 'NetCDF.inc'
+
+ LOGICAL INIwri
+ common/GLOglf_log/ INIwri
+
+
+C +---Local variables
+C + ---------------
+
+ INTEGER nbchar,i,j,k,l,ii,jj,size_X(nbdom),size_Y(nbdom),
+ . j1,j2,i_cent,j_cent,G_nx,G_ny,ncid(nbdom),
+ . start(3),count(3),EUR_ID,AFR_ID,AFR_size_X,
+ . AFR_size_Y,EUR_size_X,EUR_size_Y,AFRcid,
+ . NAM_size_X,NAM_size_Y,SAM_size_X,SAM_size_Y,
+ . i1,i2,EURcid,Rcode,ndviID(nbdom),idom,idat,
+ . EUidom,AFidom,NAidom,SAidom,NAM_ID,SAM_ID,
+ . SAMcid,int_1,int_2,RUNdec,ndat,GLOiyr,GLOmma,
+ . GLOjda,GLOjhu,GLOdec,ii1,ii2,jj1,jj2,mmx,mmy
+
+ INTEGER*2 Ival_NDVI,first
+
+ INTEGER*4 GLOtim
+
+ REAL AUXlo1,AUXla1,AUXlo2,AUXla2,dx,dy,degrad,
+ . G_dx,G_dy,G_lon1(nbdom),G_lat1(nbdom),G_lon2,
+ . G_lat2,aux1,aux2,aux3,cmpt,iAVndvi,zero,unun,
+ . NDVrea,AFR_G_lon1,AFR_G_lat1,
+ . AFR_G_reso,AFR_G_lon2,AFR_G_lat2,EUR_G_lat1,
+ . EUR_G_lon1,EUR_G_reso,EUR_G_lon2,EUR_G_lat2,
+ . NAM_G_lat1,NAM_G_lon1,NAM_G_reso,NAM_G_lon2,
+ . NAM_G_lat2,SAM_G_lat1,SAM_G_lon1,SAM_G_reso,
+ . SAM_G_lon2,SAM_G_lat2,LAImax,GLFmax,kval,
+ . AUXlon,AUXlat,G_reso(nbdom),AVndvi,aux,alpha,
+ . weight(5),shiftDAY,tmp_z0(mx,my),val_NDVI,
+ . laiaux,ndvaux,alpha1,beta,alpha2,raux
+
+ LOGICAL Vtrue,Vfalse,AFRdom,EURdom,NAMdom,SAMdom
+
+ CHARACTER*2 nustri(0:99)
+ CHARACTER*60 AFRndvdir,EURndvdir,NAMndvdir,SAMndvdir
+ CHARACTER*80 AFRndv_file,EURndv_file,NAMndv_file,
+ . SAMndv_file
+
+
+C +---Data
+C + ----
+
+ DATA degrad / 1.745329252d-2 /
+ DATA zero / 0. /
+ DATA unun / 1. /
+ DATA Vtrue / .true. /
+ DATA Vfalse / .false. /
+
+ DATA (nustri(i),i=0,99)
+ . /'00','01','02','03','04','05','06','07','08','09',
+ . '10','11','12','13','14','15','16','17','18','19',
+ . '20','21','22','23','24','25','26','27','28','29',
+ . '30','31','32','33','34','35','36','37','38','39',
+ . '40','41','42','43','44','45','46','47','48','49',
+ . '50','51','52','53','54','55','56','57','58','59',
+ . '60','61','62','63','64','65','66','67','68','69',
+ . '70','71','72','73','74','75','76','77','78','79',
+ . '80','81','82','83','84','85','86','87','88','89',
+ . '90','91','92','93','94','95','96','97','98','99'/
+
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Grid parameters
+C + ===============
+
+
+ EUidom = 1 ! Europe
+ AFidom = 2 ! Africa
+c #AM NAidom = 3 ! North America
+c #AM SAidom = 4 ! South America
+
+
+C +---1-KM RESOLUTION DATA
+C + = = = = = = = = = = =
+
+
+ IF (NDV1km) THEN
+
+
+C +---Europe
+C + ------
+
+ EUR_G_lat1= 0.1200000E+02
+ EUR_G_lon1=-0.1100000E+02
+ EUR_G_reso= 0.0100000E+00
+ EUR_size_X= 8500
+ EUR_size_Y= 6000
+ EUR_G_lon2= EUR_G_lon1+REAL(EUR_size_X)*EUR_G_reso
+ EUR_G_lat2= EUR_G_lat1+REAL(EUR_size_Y)*EUR_G_reso
+
+
+C +---Africa
+C + ------
+
+ AFR_G_lat1=-0.3500000E+02
+ AFR_G_lon1=-0.2000000E+02
+ AFR_G_reso= 0.0100000E+00
+ AFR_size_X= 8000
+ AFR_size_Y= 7500
+ AFR_G_lon2= AFR_G_lon1+REAL(AFR_size_X)*AFR_G_reso
+ AFR_G_lat2= AFR_G_lat1+REAL(AFR_size_Y)*AFR_G_reso
+
+
+C +---North America
+C + -------------
+
+c #AM NAM_G_lat1= 0.1200000E+02
+c #AM NAM_G_lon1=-0.1100000E+02
+c #AM NAM_G_reso= 0.0100000E+00
+c #AM NAM_size_X= 8500
+c #AM NAM_size_Y= 6000
+c #AM NAM_G_lon2= NAM_G_lon1+REAL(NAM_size_X)*NAM_G_reso
+c #AM NAM_G_lat2= NAM_G_lat1+REAL(NAM_size_Y)*NAM_G_reso
+
+
+C +---South America
+C + -------------
+
+c #AM SAM_G_lat1= 0.1200000E+02
+c #AM SAM_G_lon1=-0.1100000E+02
+c #AM SAM_G_reso= 0.0100000E+00
+c #AM SAM_size_X= 8500
+c #AM SAM_size_Y= 6000
+c #AM SAM_G_lon2= SAM_G_lon1+REAL(SAM_size_X)*SAM_G_reso
+c #AM SAM_G_lat2= SAM_G_lat1+REAL(SAM_size_Y)*SAM_G_reso
+
+
+ ENDIF ! (NDV1km)
+
+
+C +---8-KM RESOLUTION DATA
+C + = = = = = = = = = = =
+
+
+ IF (NDV8km) THEN
+
+
+C +---Africa
+C + ------
+
+ AFR_G_lat1=-0.088894023001E+02
+ AFR_G_lon1=-0.249166007340E+02
+ AFR_G_reso= 0.083333333333E+00
+ AFR_size_X= 612
+ AFR_size_Y= 587
+ AFR_G_lon2= AFR_G_lon1+REAL(AFR_size_X)*AFR_G_reso
+ AFR_G_lat2= AFR_G_lat1+REAL(AFR_size_Y)*AFR_G_reso
+
+C +---Europe
+C + ------
+
+ EUR_G_lat1=-0.380000000000E+02
+ EUR_G_lon1=-0.200000000000E+02
+ EUR_G_reso= 0.083333333333E+00
+ EUR_size_X= 984
+ EUR_size_Y= 924
+ EUR_G_lon2= EUR_G_lon1+REAL(EUR_size_X)*EUR_G_reso
+ EUR_G_lat2= EUR_G_lat1+REAL(EUR_size_Y)*EUR_G_reso
+
+
+ ENDIF ! (NDV8km)
+
+
+C +---Select grid parameters
+C + ----------------------
+
+ AFRdom=.false.
+ EURdom=.false.
+ NAMdom=.false.
+ SAMdom=.false.
+
+C Redefine the domain in order to get:
+C - African continent: use of the new set of NDVI (only Africa)
+C - European continent: use of the old set of NDVI
+
+ DO j=1,my
+ DO i=1,mx
+ AUXlon=NST__x(i,j)
+ AUXlat=NST__y(i,j)
+ IF (AUXlat.le.36.0) THEN
+ NSTinc(i,j,EUidom)=.false. !but still missing Crete
+ NSTinc(i,j,AFidom)=.true. !African continent
+ !but still missing northern Algeria
+ ELSE
+ IF (AUXlon.le.-15.0) THEN
+ NSTinc(i,j,EUidom)=.false. !still in Africa as Europe dataset
+ NSTinc(i,j,AFidom)=.true. !doesn't extend further than 20W
+ ELSE
+ NSTinc(i,j,EUidom)=.true. ! in Europe
+ NSTinc(i,j,AFidom)=.false. !not in Africa
+ ENDIF
+ ENDIF
+ IF (AUXlat.le.36.0 .and.
+ . AUXlon.ge. 0.0 .and. AUXlon.le.12.0) THEN !Northern Algeria
+ NSTinc(i,j,EUidom)=.false. !not in Europe
+ NSTinc(i,j,AFidom)=.true. ! in Africa
+ ENDIF
+ IF (AUXlat.ge.34.0 .and.
+ . AUXlon.ge.22.0 .and. AUXlon.le.27.0) THEN !Crete
+ NSTinc(i,j,EUidom)=.true. ! in Europe
+ NSTinc(i,j,AFidom)=.false. !not in Africa
+ ENDIF
+ ENDDO
+ ENDDO
+
+
+ DO j=1,my
+ DO i=1,mx
+
+ IF (NSTinc(i,j,AFidom)) AFRdom=.true.
+ IF (NSTinc(i,j,EUidom)) EURdom=.true.
+c #AM IF (NSTinc(i,j,NAidom)) NAMdom=.true.
+c #AM IF (NSTinc(i,j,SAidom)) SAMdom=.true.
+
+ ENDDO
+ ENDDO
+
+
+C +---Screen messages (JFG 02/05/2022: added "vrbose" check)
+C + ======================================================
+
+ IF (AFRdom.and.vrbose) THEN
+ write(6,*) 'Green leaf fraction from NDVI index over Africa'
+ ENDIF
+
+ IF (EURdom.and.vrbose) THEN
+ write(6,*) 'Green leaf fraction from NDVI index over Europe'
+ ENDIF
+
+ IF (NAMdom.and.vrbose) THEN
+ write(6,*) 'Green leaf fraction from NDVI index over N. America'
+ ENDIF
+
+ IF (SAMdom.and.vrbose) THEN
+ write(6,*) 'Green leaf fraction from NDVI index over S. America'
+ ENDIF
+
+ IF ((AFRdom.or.EURdom.or.NAMdom.or.SAMdom).and.vrbose) THEN
+ write(6,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+ write(6,*)
+ ENDIF
+
+ IF (((.not.EURdom).and.(.not.AFRdom).and.
+ . (.not.NAMdom).and.(.not.SAMdom)).and.vrbose) THEN
+ write(6,*) '***************'
+ write(6,*) '*** CAUTION ***'
+ write(6,*) '***************'
+ write(6,*)
+ write(6,*) 'No NDVI index available for this domain !!!'
+ write(6,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+ write(6,*)
+ GOTO 990
+ ENDIF
+
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+C +---Initialisation
+C + ==============
+
+ DO j=1,my
+ DO i=1,mx
+ NSTndv(i,j) = 0.
+ ENDDO
+ ENDDO
+
+ DO k=1,nvx
+ DO j=1,my
+ DO i=1,mx
+ NSTglf(i,j,k) = 0.
+ ENDDO
+ ENDDO
+ ENDDO
+
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+ IF (NDV8km) THEN
+ ndat = 5
+ ELSE
+ ndat = 1
+ ENDIF
+
+
+ DO idat = 1,ndat
+
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Select a monthly file
+C + =====================
+
+
+C +---Year, month and decade ?
+C + ------------------------
+
+C + ******
+ CALL DATcnv (RUNiyr,RUNmma,RUNjda,RUNjhu,DATtim,Vfalse)
+C + ******
+
+ IF (RUNjda.lt.11) THEN
+ RUNdec = 1
+ ELSE
+ IF (RUNjda.lt.21) THEN
+ RUNdec = 11
+ ELSE
+ RUNdec = 21
+ ENDIF
+ ENDIF
+
+
+ IF (NDV1km) THEN
+
+
+C +---File name
+C + ---------
+
+C +.... Africa
+
+ nbchar=1
+ AFRndvdir=AFRndv_dir
+
+ DO i=1,60
+ IF (AFRndvdir(i:i).ne.' ') nbchar=i
+ ENDDO
+
+ AFRndv_file=AFRndvdir(1:nbchar)//'AFRn'
+ . //nustri(RUNmma)
+ . //'.nc'
+
+C +.... Europe
+
+ nbchar=1
+ EURndvdir=EURndv_dir
+
+ DO i=1,60
+ IF (EURndvdir(i:i).ne.' ') nbchar=i
+ ENDDO
+
+ EURndv_file=EURndvdir(1:nbchar)//'EURn'
+ . //nustri(RUNmma)
+ . //'.nc'
+
+C +.... North America
+
+c #AM nbchar=1
+c #AM NAMndvdir=NAMndv_dir
+
+c #AM DO i=1,60
+c #AM IF (NAMndvdir(i:i).ne.' ') nbchar=i
+c #AM ENDDO
+
+c #AM NAMndv_file=NAMndvdir(1:nbchar)//'NAMn'
+c #AM. //nustri(RUNmma)
+c #AM. //'.nc'
+
+C +.... South America
+
+c #AM nbchar=1
+c #AM SAMndvdir=SAMndv_dir
+
+c #AM DO i=1,60
+c #AM IF (SAMndvdir(i:i).ne.' ') nbchar=i
+c #AM ENDDO
+
+c #AM SAMndv_file=SAMndvdir(1:nbchar)//'SAMn'
+c #AM. //nustri(RUNmma)
+c #AM. //'.nc'
+
+
+ ENDIF ! (NDV1km)
+
+
+ IF (NDV8km) THEN
+
+ shiftDAY = (REAL(RUNjda) - REAL(RUNdec) - 5.0) ! day
+ . + REAL(RUNjhu)/24. ! hour
+
+ IF (RUNiyr.ge.1983) THEN
+
+ IF (idat.le.2) THEN
+ IF (RUNmma.ge.2) THEN
+ GLOtim = DATtim + NINT(24.*(-shiftDAY - 10.0*REAL(3-idat)))
+ ELSE
+ GLOtim = DATtim
+ ENDIF
+ ENDIF
+ IF (idat.ge.3) THEN
+ GLOtim = DATtim + NINT(24.*(-shiftDAY + 10.0*REAL(idat-3)))
+ ENDIF
+
+ ELSE
+
+ ! No vrbose check: this is mandatory to understand the stop.
+ write(6,*) 'No NDVI files available before 1983.'
+ write(6,*) 'Please select NDVI database at 1-km resolution'
+ write(6,*) 'in NSTing.ctr input file.'
+ write(6,*)
+ write(6,*) 'STOP in GLOglf.f'
+ write(6,*)
+ STOP
+
+ ENDIF
+
+C + ******
+ CALL DATcnv (GLOiyr,GLOmma,GLOjda,GLOjhu,GLOtim,Vfalse)
+C + ******
+
+ IF (GLOjda.lt.11) THEN
+ GLOdec = 1
+ ELSE
+ IF (GLOjda.lt.21) THEN
+ GLOdec = 11
+ ELSE
+ GLOdec = 21
+ ENDIF
+ ENDIF
+
+
+C +---Compute weights for time interpolation of green leaf fraction
+C + -------------------------------------------------------------
+
+ IF (idat.eq.1) THEN
+ weight(3) = 10. / 30.
+ IF (shiftDAY.le.0.) THEN
+ weight(5) = 0.0
+ weight(2) = 10. / 30.
+ weight(1) = ABS(shiftDAY) / 30.
+ weight(4) = 10. / 30. - weight(1)
+ ELSE
+ weight(1) = 0.0
+ weight(4) = 10. / 30.
+ weight(5) = ABS(shiftDAY) / 30.
+ weight(2) = 10. / 30. - weight(5)
+ ENDIF
+ ENDIF
+
+C + ----X---------X---------X---------X---------X---------X
+C + 1 2 3 4 5
+C + ^^ current date
+C +
+C + - X represents the beginning of each decade
+C + - The current day is assumed to be in decade 3 (between 3 and 4)
+C + - shiftDAY is the difference between the current date and the center
+C + of the decade
+
+
+C +---File name
+C + ---------
+
+C +.... Africa
+
+ nbchar=1
+ AFRndvdir=AFRndv8dir
+
+ DO i=1,60
+ IF (AFRndvdir(i:i).ne.' ') nbchar=i
+ ENDDO
+
+ int_1 = GLOiyr/100
+ int_2 = GLOiyr - (int_1*100)
+
+C + Monthly data files
+ccccc AFRndv_file=AFRndvdir(1:nbchar)//'AFRn.'
+ccccc. //nustri(int_1 )
+C + 10-days data files
+ AFRndv_file=AFRndvdir(1:nbchar)//'ndvi_mar'
+ . //nustri(int_2 )
+ . //nustri(GLOmma)
+ . //nustri(GLOdec)
+ . //'.nc'
+
+C +.... Europe
+
+ nbchar=1
+ EURndvdir=EURndv8dir
+
+ DO i=1,60
+ IF (EURndvdir(i:i).ne.' ') nbchar=i
+ ENDDO
+
+ EURndv_file=EURndvdir(1:nbchar)//'avhrrpf.ndvi.1ntfgl.'
+ . //nustri(int_2)
+ . //nustri(GLOmma)
+ . //nustri(GLOdec)
+ . //'.nc'
+
+ ENDIF ! (NDV8km)
+
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Open Netcdf data file - NDVI index
+C + ==================================
+
+ AFRcid=-1 ; AFR_ID=-1
+ EURcid=-1 ; EUR_ID=-1
+
+ IF (AFRdom) THEN
+ IF (vrbose) THEN
+ WRITE(6,*) 'Open file : ',AFRndv_file
+ ENDIF
+C + *****
+ AFRcid = NCOPN(AFRndv_file,NCNOWRIT,Rcode)
+ AFR_ID = NCVID(AFRcid,'NDVI',Rcode)
+C + *****
+ ENDIF
+
+c IF (EURdom.and..not.NDV8km) THEN
+ IF (EURdom) THEN
+ IF (vrbose) THEN
+ WRITE(6,*) 'Open file : ',EURndv_file
+ ENDIF
+C + *****
+ EURcid = NCOPN(EURndv_file,NCNOWRIT,Rcode)
+ EUR_ID = NCVID(EURcid,'NDVI',Rcode)
+C + *****
+ ENDIF
+
+c #AM IF (NAMdom.and..not.NDV8km) THEN
+c #AM WRITE(6,*) 'Open file : ',NAMndv_file
+C + *****
+c #AM NAMcid = NCOPN(NAMndv_file,NCNOWRIT,Rcode)
+c #AM NAM_ID = NCVID(NAMcid,'NDVI',Rcode)
+C + *****
+c #AM ENDIF
+
+c #AM IF (SAMdom.and..not.NDV8km) THEN
+c #AM WRITE(6,*) 'Open file : ',SAMndv_file
+C + *****
+c #AM SAMcid = NCOPN(SAMndv_file,NCNOWRIT,Rcode)
+c #AM SAM_ID = NCVID(SAMcid,'NDVI',Rcode)
+C + *****
+c #AM ENDIF
+
+
+C +---Select domains (Africa and/or Europe)
+C + =====================================
+
+C +---idom = 1 : Europe
+C + -----------------
+
+ G_lat1(EUidom)=EUR_G_lat1
+ G_lon1(EUidom)=EUR_G_lon1
+ G_reso(EUidom)=EUR_G_reso
+ size_X(EUidom)=EUR_size_X
+ size_Y(EUidom)=EUR_size_Y
+ ndviID(EUidom)=EUR_ID
+ ncid (EUidom)=EURcid
+
+
+C +---idom = 2 : Africa
+C + -----------------
+
+ G_lat1(AFidom)=AFR_G_lat1
+ G_lon1(AFidom)=AFR_G_lon1
+ G_reso(AFidom)=AFR_G_reso
+ size_X(AFidom)=AFR_size_X
+ size_Y(AFidom)=AFR_size_Y
+ ndviID(AFidom)=AFR_ID
+ ncid (AFidom)=AFRcid
+
+
+C +---idom = 3 : North America
+C + ------------------------
+
+c #AM G_lat1(NAidom)=NAM_G_lat1
+c #AM G_lon1(NAidom)=NAM_G_lon1
+c #AM G_reso(NAidom)=NAM_G_reso
+c #AM size_X(NAidom)=NAM_size_X
+c #AM size_Y(NAidom)=NAM_size_Y
+c #AM ndviID(NAidom)=NAM_ID
+c #AM ncid (NAidom)=NAMcid
+
+
+C +---idom = 4 : South America
+C + ------------------------
+
+c #AM G_lat1(SAidom)=SAM_G_lat1
+c #AM G_lon1(SAidom)=SAM_G_lon1
+c #AM G_reso(SAidom)=SAM_G_reso
+c #AM size_X(SAidom)=SAM_size_X
+c #AM size_Y(SAidom)=SAM_size_Y
+c #AM ndviID(SAidom)=SAM_ID
+c #AM ncid (SAidom)=SAMcid
+
+
+C +---Treatment of each NST grid point (except boundaries)
+C + ====================================================
+
+ mmx = mx
+ mmy = my
+ ii1 = MIN(2,mmx)
+ ii2 = MAX(1,mmx-1)
+ IF (mmx.eq.1) THEN
+ ii1 = 1
+ ii2 = 1
+ ENDIF
+ jj1 = MIN(2,mmy)
+ jj2 = MAX(1,mmy-1)
+ IF (mmy.eq.1) THEN
+ jj1 = 1
+ jj2 = 1
+ ENDIF
+
+
+ DO j=jj1,jj2 ! Loop on NST grid points
+ DO i=ii1,ii2 ! -----------------------
+
+
+C +---Initialisation of temporary NDVI variables
+C + ==========================================
+
+ AVndvi=0.
+
+
+C +---Location of NST grid cell in the input data grid
+C + ================================================
+
+ DO idom=1,nbdom
+
+ IF (NSTinc(i,j,idom).and.(G_reso(idom).gt.0.)) THEN
+
+
+C +---Search for the closest point in data file
+C + -----------------------------------------
+
+ AUXlon = NST__x(i,j)
+ AUXlat = NST__y(i,j)
+C + ******
+ CALL SPHERC (Vtrue,AUXlon,AUXlat)
+C + ******
+
+ i_cent=NINT((AUXlon-G_lon1(idom))/G_reso(idom))+1
+ j_cent=NINT((AUXlat-G_lat1(idom))/G_reso(idom))+1
+
+
+C +---Check if (i,j) belong to the data domain
+C + ----------------------------------------
+
+ IF (.NOT.INIwri) THEN
+ IF (i_cent.lt.3 .or. i_cent.gt.(size_X(idom)-2) .or.
+ . j_cent.lt.3 .or. j_cent.gt.(size_Y(idom)-2)) THEN
+c write(6,899) i,j,idom
+c 899 format('GLOglf.f: (',i3,',',i3,') does not belong to the'
+c . ' data domain (idom=',i1,')')
+ GOTO 900
+ ENDIF
+ ENDIF
+
+
+C +---Compute the resolution of the considered NST cell
+C + -------------------------------------------------
+
+ dx = 0.0
+ dy = 0.0
+
+ IF (mmx.ne.1.and.mmy.ne.1) THEN
+ ii=MAX(i,2)
+ jj=MAX(j,2)
+ AUXlo1 = NST__x(ii ,jj )
+ AUXlo2 = NST__x(ii-1,jj-1)
+ AUXla1 = NST__y(ii ,jj )
+ AUXla2 = NST__y(ii-1,jj-1)
+ ELSE
+ IF (mmx.ne.1) THEN
+ ii=MAX(i,2)
+ jj=1
+ AUXlo1 = NST__x(ii ,jj)
+ AUXlo2 = NST__x(ii-1,jj)
+ AUXla1 = NST__y(ii ,jj)
+ AUXla2 = NST__y(ii-1,jj)
+ ELSE
+ ii=1
+ jj=1
+ AUXlo1 = NST__x(ii,jj)
+ AUXlo2 = NST__x(ii,jj)
+ AUXla1 = NST__y(ii,jj)
+ AUXla2 = NST__y(ii,jj)
+ ENDIF
+
+ ENDIF
+
+C + ******
+ CALL SPHERC (Vtrue,AUXlo1,AUXla1)
+ CALL SPHERC (Vtrue,AUXlo2,AUXla2)
+C + ******
+ dx=ABS(AUXlo1-AUXlo2)*111111.*COS(AUXla1*degrad)
+ dy=ABS(AUXla1-AUXla2)*111111.
+
+
+C +---Define the data points to be read around (i_cent,j_cent)
+C + --------------------------------------------------------
+
+ G_dx = G_reso(idom)*111111.*COS(AUXla1*degrad)
+ G_dy = G_reso(idom)*111111.
+
+ G_nx=NINT(dx/G_dx/2.)-1
+ G_ny=NINT(dy/G_dy/2.)-1
+
+ G_nx=MAX(G_nx,0)
+ G_ny=MAX(G_ny,0)
+
+ first=0
+1000 continue
+
+ i1=i_cent-G_nx
+ i2=i_cent+G_nx
+ j1=j_cent-G_ny
+ j2=j_cent+G_ny
+
+ i1=MAX(i1,1)
+ i2=MIN(i2,size_X(idom))
+ j1=MAX(j1,1)
+ j2=MIN(j2,size_Y(idom))
+
+
+C +---Initialisation of temporary NDVI variables
+C + ==========================================
+
+ iAVndvi=0.
+ cmpt =0.
+
+
+C +---Reading of input data
+C + =====================
+
+ DO l=j1,j2
+ DO k=i1,i2
+
+ start(1)=k
+ start(2)=l
+ start(3)=1
+ count(1)=1
+ count(2)=1
+ count(3)=1
+
+C + *****
+c IF (idom.eq.2 .and. NSTinc(i,j,idom)) THEN !read as REAL (NDVI anom.)
+c CALL NCVGT(ncid(idom),ndviID(idom),start,count,val_NDVI,Rcode)
+c ENDIF ! BUG BUG !!!!
+c IF (idom.eq.1 .and. NSTinc(i,j,idom)) THEN !read as INTEGER*2
+ CALL NCVGT(ncid(idom),ndviID(idom),start,count,Ival_NDVI,Rcode)
+ val_NDVI = REAL(Ival_NDVI)
+c ENDIF
+C + *****
+
+ IF (NDV1km) THEN
+ IF (val_NDVI.gt.100.) THEN
+ iAVndvi = iAVndvi + val_NDVI
+ cmpt = cmpt + 1.
+ ENDIF
+ ENDIF
+
+ IF (NDV8km) THEN
+ IF (val_NDVI.gt.20.) THEN
+ iAVndvi = iAVndvi + val_NDVI
+ cmpt = cmpt + 1.
+ ENDIF
+ ENDIF
+
+ ENDDO
+ ENDDO
+
+ IF (cmpt.gt.0.) THEN
+ iAVndvi = iAVndvi / cmpt
+ ELSE
+ iAVndvi = 0.
+ ENDIF
+
+ IF (iAVndvi.gt.AVndvi) AVndvi=iAVndvi
+
+ IF (NSTsol(i,j).eq.4.and.AVndvi.eq.0.and.first.eq.0) THEN
+ G_nx=G_nx*2.
+ G_ny=G_ny*2.
+ first=1
+ goto 1000
+ ENDIF
+
+ ENDIF ! Condition on NSTinc
+
+ ENDDO ! Loop on idom
+
+
+C +---Compute normalized NDVI index
+C + =============================
+
+ DO idom=1,nbdom
+ IF (NSTinc(i,j,idom)) THEN
+
+ NDVrea = AVndvi
+ NDVrea = MIN(NDVrea,NDVmax(idom))
+ NDVrea = MAX(NDVrea,NDVmin(idom))
+
+ ENDIF
+ ENDDO
+
+C +---Exclusion grid cell dominated by water, ice or snow
+C + ===================================================
+
+ IF (NSTsol(i,j).le.3) THEN
+ NDVrea = 0.
+ ENDIF
+
+C +---Time interpolation of NDVI
+C + ==========================
+
+ IF (ndat.gt.1) THEN
+ NSTndv(i,j) = NSTndv(i,j) + weight(idat)*NDVrea
+ ELSE
+ NSTndv(i,j) = NDVrea
+ ENDIF
+
+
+900 CONTINUE
+
+
+ ENDDO ! Loop on NST grid points
+ ENDDO ! -----------------------
+
+
+C +---Close Netcdf data file
+C + ======================
+
+ IF (AFRdom) THEN
+C + ******
+ CALL NCCLOS(AFRcid,Rcode)
+C + ******
+ ENDIF
+
+c IF (EURdom.and..not.NDV8km) THEN
+ IF (EURdom) THEN
+C + ******
+ CALL NCCLOS(EURcid,Rcode)
+C + ******
+ ENDIF
+
+c #AM IF (NAMdom.and..not.NDV8km) THEN
+C + ******
+c #AM CALL NCCLOS(NAMcid,Rcode)
+C + ******
+c #AM ENDIF
+
+c #AM IF (SAMdom.and..not.NDV8km) THEN
+C + ******
+c #AM CALL NCCLOS(SAMcid,Rcode)
+C + ******
+c #AM ENDIF
+
+
+ ENDDO ! {idat=1,ndat}
+
+
+
+ mmx = mx
+ mmy = my
+ ii1 = MIN(2,mmx)
+ ii2 = MAX(1,mmx-1)
+ jj1 = MIN(2,mmy)
+ jj2 = MAX(1,mmy-1)
+
+
+ DO j=jj1,jj2 ! Loop on NST grid points
+ DO i=ii1,ii2 ! -----------------------
+
+
+C +---Estimate of green leaf fraction
+C + ===============================
+
+ IF (NSTdv1(i,j).ge.0. .and.
+ . NSTdv1(i,j).le.256. .and.
+ . NSTdv2(i,j).ge.0. .and.
+ . NSTdv2(i,j).le.256. .and.
+ . NSTdv1(i,j).ne.NSTdv2(i,j)) THEN
+
+ DO k=1,nvx
+ DO idom=1,nbdom
+ IF (NSTinc(i,j,idom)) THEN
+ NSTglf(i,j,k)= (NSTndv(i,j)-NDVmin(idom))
+ . / (NSTdv2(i,j)-NDVmin(idom))
+ ENDIF
+ ENDDO
+ NSTglf(i,j,k) = MIN(unun,NSTglf(i,j,k))
+ NSTglf(i,j,k) = MAX(zero,NSTglf(i,j,k))
+
+ ENDDO
+
+ IF (region.eq."AFW" .OR. region.eq."WAF") THEN
+ DO k=1,nvx
+ NSTglf(i,j,k) = 1.0
+ ENDDO
+ ENDIF
+
+ ELSE
+
+ DO k=1,nvx
+ NSTglf(i,j,k) = 1.0
+ ENDDO
+
+ ENDIF
+
+ IF (NSTsol(i,j).le.3 ) THEN
+
+ DO k=1,nvx
+ NSTglf(i,j,k) = 0.0
+ NSTlai(i,j,k) = 0.0
+ ENDDO
+
+ ENDIF
+
+C +---Compute leaf area index
+C + =======================
+
+ IF (NSTsol(i,j).ge.4) THEN
+
+c DO l=1,nvx
+c LAImax = NSTlmx(i,j,l)
+c GLFmax = 1.0
+c kval = 0.5
+c alpha = (1.0-EXP(-kval*LAImax)) / GLFmax
+c aux = MIN(0.999,alpha*NSTglf(i,j,l))
+c NSTlai(i,j,l) = -LOG(1.0-aux) / kval
+c NSTlai(i,j,l) = MIN(NSTlai(i,j,l),LAImax)
+c ENDDO
+ DO idom=1,nbdom
+ IF (NSTinc(i,j,idom)) THEN
+ ndvaux = (NSTndv(i,j) -NDVmin(idom))
+ . / (NDVmax(idom)-NDVmin(idom))
+ ENDIF
+ ENDDO
+ ndvaux = MAX(ndvaux,0.)
+ ndvaux = MIN(ndvaux,0.99)
+ kval = 0.15
+ laiaux = -LOG(1.0-ndvaux) / kval
+ IF (NSTsfr(i,j,2).eq.0 ) THEN
+ NSTlai(i,j,2) = 0.
+ IF (NSTsfr(i,j,1).eq.0) THEN
+ NSTlai(i,j,1) = 0.
+ ELSE
+ alpha1 = REAL(NSTsfr(i,j,1))/100.
+ NSTlai(i,j,1) = laiaux/alpha1
+ ENDIF
+ ELSE
+ IF (NSTsfr(i,j,1).eq.0) THEN
+ NSTlai(i,j,1) = 0.
+ alpha2 = REAL(NSTsfr(i,j,2))/100.
+ NSTlai(i,j,2) = laiaux/alpha2
+ ELSE
+
+C +vv Hubert Gall
+c #@X beta = NSTlmx(i,j,1) /NSTlmx(i,j,2) ! BOUM !
+c #@X alpha1 = REAL(NSTsfr(i,j,1))/100.
+c #@X alpha2 = REAL(NSTsfr(i,j,2))/100.
+c #@X NSTlai(i,j,1) = beta*laiaux/(alpha2+beta*alpha1)
+c #@X NSTlai(i,j,2) = laiaux/(alpha2+beta*alpha1)
+c #@X write(6,6000) i,j ,NSTlmx(i,j,1),NSTlmx(i,j,2),beta
+ 6000 format(2i3,3e15.3)
+ alpha1 = NSTlmx(i,j,1)*REAL(NSTsfr(i,j,1))/100.
+ alpha2 = NSTlmx(i,j,2)*REAL(NSTsfr(i,j,2))/100.
+ beta = laiaux / (alpha1 + alpha2)
+ NSTlai(i,j,1) = NSTlmx(i,j,1)*beta
+ NSTlai(i,j,2) = NSTlmx(i,j,2)*beta
+C +^^ Hubert Gall
+
+ ENDIF
+ ENDIF
+ raux = 0.01*REAL(NSTsfr(i,j,1) +NSTsfr(i,j,2))
+ . / NSTfrc(i,j)
+ DO l = 1,nvx-1
+ NSTlai(i,j,l) = NSTlai(i,j,l) *raux
+ ENDDO
+ NSTlai(i,j,nvx) = 1.0 ! Emilie Vanvyve, e-mail 22-8-2006
+ ENDIF
+
+ DO l = 1,nvx
+ NSTlai(i,j,l) = max(0.,min(10.,NSTlai(i,j,l)))
+ enddo
+
+ ENDDO ! Loop on NST grid points
+ ENDDO ! -----------------------
+
+
+
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+990 CONTINUE
+
+ INIwri=.TRUE.
+
+ RETURN
+ END
diff --git a/MAR/code_nestor/src/GLOveg.f b/MAR/code_nestor/src/GLOveg.f
new file mode 100644
index 0000000000000000000000000000000000000000..efa29456b1d8776a400fbfaf82d58e500abe846c
--- /dev/null
+++ b/MAR/code_nestor/src/GLOveg.f
@@ -0,0 +1,830 @@
+C +-------------------------------------------------------------------+
+C | Subroutine GLOveg March 2004 NESTING |
+C +-------------------------------------------------------------------+
+C | |
+C | GLOveg read vegetation classification (IGBP) only for Africa and |
+C | Europe. |
+C | |
+C | Input : - NST__x, NST__y : NST grid coordinates (lat./long.) |
+C | ^^^^^^^ - NST_sh : surface elevation |
+C | - NSTsol : soil type |
+C | |
+C | Output: - NSTveg : vegetation type (IGBP classification) |
+C | ^^^^^^^ - NSTvfr : fraction of vegetation in the grid cell (IGBP) |
+C | - NSTsvt : vegetation type (SVATclassification) |
+C | - NSTsfr : fraction of vegetation in the grid cell (SVAT) |
+C | - NSTlai : leaf area index |
+C | |
+C | Remark: Note that NSTveg = -1 (IGBP) or NSTsvt = 0 (SVAT) corres- |
+C | ^^^^^^^ pond to bare soil (no vegetation). |
+C | NSTvfr and NSTsfr give vegetation fraction in % (integer) |
+C | |
+C +-------------------------------------------------------------------+
+
+
+ SUBROUTINE GLOveg
+
+ IMPLICIT none
+
+
+C +---General variables
+C + -----------------
+
+ INCLUDE 'NSTdim.inc'
+ INCLUDE 'NSTvar.inc'
+ INCLUDE 'LOCfil.inc'
+ INCLUDE 'NetCDF.inc'
+ INCLUDE 'NESTOR.inc'
+
+C +---Vegetation classes
+C + ------------------
+
+ INTEGER nsvat,nigbp
+ PARAMETER (nsvat=12)
+ PARAMETER (nigbp=17)
+
+
+C +---Local variables
+C + ---------------
+
+ INTEGER*2 val_IGBP
+
+ INTEGER i,j,k,l,ii,jj,size_X(nbdom),size_Y(nbdom),nbchar,
+ . i1,i2,j1,j2,i_cent,j_cent,G_nx,G_ny,totvfr,Rcode,
+ . AFR_ID,ncid(nbdom),start(3),count(3),AFR_size_X,
+ . VEG_ID(nbdom),AFR_size_Y,EUR_size_X,EUR_size_Y,
+ . EUR_ID,EURcid,AFRcid,idom,frac_itot,EUidom,AFidom,
+ . ii1,ii2,jj1,jj2,mmx,mmy,ido,idomi,s0,s1
+
+ REAL AUXlo1,AUXla1,AUXlo2,AUXla2,dx,dy,degrad,frac_tot,
+ . AUXlon,AUXlat,G_dx,G_dy,G_lon1(nbdom),G_lat1(nbdom),
+ . aux,aux1,aux2,aux3,AFR_G_lon1,AFR_G_lat1,AFR_G_reso,
+ . cmpt,AFR_G_lon2,AFR_G_lat2,EUR_G_lat1,EUR_G_lon1,
+ . icmpt,EUR_G_reso,EUR_G_lon2,EUR_G_lat2,G_reso(nbdom),
+ . NSTmsk(mx,my),tmp_z0(mx,my)
+
+ INTEGER svat_class(nvx),WK_tmp(nigbp)
+
+ REAL SVAT(0:nsvat),IGBP(nigbp),convert(nigbp,0:nsvat),
+ . svat_frac (nvx),iIGBP(nigbp),igbp_z0(nigbp)
+
+ LOGICAL Vtrue,AFRdom,EURdom
+
+ CHARACTER*80 AFRveg_file,EURveg_file
+
+
+C +---Data
+C + ----
+
+ DATA degrad / 1.745329252d-2 /
+ DATA Vtrue / .true. /
+
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Grid parameters
+C + ===============
+
+
+C +---Europe
+C + ------
+
+ EUidom = 1
+
+ EUR_G_lat1= 0.1200000E+02
+ EUR_G_lon1=-0.1100000E+02
+ EUR_G_reso= 0.0100000E+00
+ EUR_size_X= 8500
+ EUR_size_Y= 6000
+ EUR_G_lon2= EUR_G_lon1+REAL(EUR_size_X)*EUR_G_reso
+ EUR_G_lat2= EUR_G_lat1+REAL(EUR_size_Y)*EUR_G_reso
+
+
+C +---Africa
+C + ------
+
+ AFidom = 2
+
+ AFR_G_lat1=-0.3500000E+02
+ AFR_G_lon1=-0.2000000E+02
+ AFR_G_reso= 0.0100000E+00
+ AFR_size_X= 8000
+ AFR_size_Y= 7500
+ AFR_G_lon2= AFR_G_lon1+REAL(AFR_size_X)*AFR_G_reso
+c AFR_G_lat2= AFR_G_lat1+REAL(AFR_size_Y)*AFR_G_reso
+ AFR_G_lat2= 0.3800000E+02
+
+C +---Select grid parameters
+C + ----------------------
+
+ AFRdom=.false.
+ EURdom=.false.
+
+ DO j=1,my
+ DO i=1,mx
+
+ AUXlon=NST__x(i,j)
+ AUXlat=NST__y(i,j)
+
+ IF (AUXlon.gt.AFR_G_lon1.and.AUXlon.lt.AFR_G_lon2.and.
+ . AUXlat.gt.AFR_G_lat1.and.AUXlat.lt.AFR_G_lat2) THEN
+ AFRdom =.true.
+ NSTinc(i,j,AFidom)=.true.
+ ELSE
+ NSTinc(i,j,AFidom)=.false.
+ ENDIF
+
+ IF (AUXlon.gt.EUR_G_lon1.and.AUXlon.lt.EUR_G_lon2.and.
+ . AUXlat.gt.EUR_G_lat1.and.AUXlat.lt.EUR_G_lat2) THEN
+ EURdom =.true.
+ NSTinc(i,j,EUidom)=.true.
+ ELSE
+ NSTinc(i,j,EUidom)=.false.
+ ENDIF
+
+ ENDDO
+ ENDDO
+
+
+C +---Screen message
+C + ==============
+
+ IF (Region.eq."GRD") GOTO 990
+
+ IF (AFRdom) THEN
+ write(6,*) 'Global land cover (IGBP) over Africa'
+ ENDIF
+
+ IF (EURdom) THEN
+ write(6,*) 'Global land cover (IGBP) over Europe'
+ ENDIF
+
+ IF (AFRdom.or.EURdom) THEN
+ write(6,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+ ENDIF
+
+ IF ((.not.EURdom).and.(.not.AFRdom)) THEN
+ write(6,*) '***************'
+ write(6,*) '*** CAUTION ***'
+ write(6,*) '***************'
+ write(6,*)
+ write(6,*) 'No Global land cover available for this domain !!!'
+ write(6,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+ write(6,*)
+ GOTO 990
+ ENDIF
+
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Convertion table : IGBP -> SVAT classification
+C + ===============================================
+
+
+C +---Initialisation
+C + --------------
+
+ DO k=1,nigbp
+ DO l=0,nsvat
+ convert(k,l)=0.
+ ENDDO
+ ENDDO
+
+
+C +---Convertion table
+C + ----------------
+
+C +...1. Evergreen Needleleaf Forest
+C + ------------------------------
+ convert( 1,12)=70. ! needleleaf high
+ convert( 1,11)=30. ! needleleaf medium
+ igbp_z0( 1 )=0.94
+
+C +...2. Evergreen Broadleaf Forest
+C + -----------------------------
+ convert( 2, 9)=70. ! broadleaf high
+ convert( 2, 8)=30. ! broadleaf medium
+ igbp_z0( 2 )=0.94
+
+C +...3. Deciduous Needleleaf Forest
+C + ------------------------------
+ convert( 3,11)=70. ! needleleaf medium
+ convert( 3,12)=30. ! needleleaf high
+ igbp_z0( 3 )=0.86
+
+C +...4. Deciduous Broadleaf Forest
+C + -----------------------------
+ convert( 4, 8)=70. ! broadleaf medium
+ convert( 4, 9)=30. ! broadleaf high
+ igbp_z0( 4 )=0.86
+
+C +...5. Mixed Forest
+C + ---------------
+ convert( 5, 7)=10. ! broadleaf low
+ convert( 5, 8)=20. ! broadleaf medium
+ convert( 5, 9)=20. ! broadleaf high
+ convert( 5,10)=10. ! needleleaf low
+ convert( 5,11)=20. ! needleleaf medium
+ convert( 5,12)=20. ! needleleaf high
+ igbp_z0( 5 )=0.76
+
+C +...6. Closed Shrublands
+C + --------------------
+ convert( 6, 7)=60. ! broadleaf low
+ convert( 6, 8)=40. ! broadleaf medium
+ igbp_z0( 6 )=0.44
+
+C +...7. Open Shrublands
+C + ------------------
+ convert( 7, 5)=30. ! grass medium
+ convert( 7, 7)=40. ! broadleaf low
+ convert( 7, 8)=30. ! broadleaf medium
+ igbp_z0( 7 )=0.33
+
+C +...8. Woody Savannas
+C + -----------------
+ convert( 8, 5)=30. ! grass medium
+ convert( 8, 8)=35. ! broadleaf medium
+ convert( 8, 9)=35. ! broadleaf high
+ igbp_z0( 8 )=0.64
+
+C +...9. Savannas
+C + -----------
+ convert( 9, 6)=60. ! grass high
+ convert( 9, 8)=40. ! broadleaf medium
+ igbp_z0( 9 )=0.38
+
+C +...10. Grasslands
+C + --------------
+ convert(10, 4)=70. ! grass low
+ convert(10, 5)=30. ! grass medium
+ igbp_z0(10 )=0.016
+
+C +...11. Permanent Wetlands
+C + ----------------------
+ convert(11, 4)=20. ! grass low
+ convert(11, 5)=50. ! grass medium
+ convert(11, 6)=30. ! grass high
+ igbp_z0(11 )=0.047
+
+C +...12. Croplands
+C + -------------
+ convert(12, 1)=20. ! crops low
+ convert(12, 2)=30. ! crops medium
+ convert(12, 3)=20. ! crops high
+ convert(12, 0)=30. ! barren soil
+ igbp_z0(12 )=0.047
+
+C +...13. Urban and Built-Up
+C + ----------------------
+ convert(13, 9)=100. ! broadleaf high
+ igbp_z0(13 )=1.0
+
+C +...14. Cropland/Natural Vegetation Mosaic
+C + --------------------------------------
+ convert(14, 1)=20. ! crops low
+ convert(14, 2)=20. ! crops medium
+ convert(14, 3)=20. ! crops high
+ convert(14, 5)=20. ! grass medium
+ convert(14, 7)=20. ! broadleaf low
+ igbp_z0(14 )=0.074
+
+C +...15. Snow and Ice
+C + ----------------
+C If dominant, NSTsol is set to 2 (ice) or 3 (snow)
+C depending on the height.
+ igbp_z0(15 )=0.001
+
+C +...16. Barren or Sparsely Vegetated
+C + --------------------------------
+ convert(16, 4)=20. ! grass low
+ convert(16, 7)=5. ! broadleaf low
+ convert(16, 0)=75. ! barren soil
+ igbp_z0(16 )=0.022
+
+C +...17. Water Bodies
+C + ----------------
+C If dominant, NSTsol is set to 1
+ igbp_z0(17 )=0.001
+
+
+C +---Correction
+C + ----------
+
+ if (nvx.le.4) then
+
+ DO k=1,nigbp
+
+ DO s0=1,10,3
+
+ ! S0=1 [crop] , S0=2 [grass]
+ ! S0=3 [broadleaf], S0=4 [needleleaf]
+
+ s1=s0+1
+
+ if(convert(k,s0 ).gt.convert(k,s0+1).and.
+ . convert(k,s0 ).gt.convert(k,s0+2)) s1=s0
+
+ if(convert(k,s0+2).gt.convert(k,s0).and.
+ . convert(k,s0+2).gt.convert(k,s0+1)) s1=s0+2
+
+ convert(k,s1)=convert(k,s0)+convert(k,s0+1)+convert(k,s0+2)
+
+ ENDDO
+
+ ENDDO
+
+ endif
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+C +---Open Netcdf data file(s) - IGBP Classification
+C + ==============================================
+
+ AFR_ID=-1 ; AFRcid=-1
+ EUR_ID=-1 ; EURcid=-1
+
+ IF (AFRdom) THEN
+ nbchar=1
+ DO i=1,60
+ IF (AFRveg_dir(i:i).ne.' ') nbchar=i
+ ENDDO
+ AFRveg_file = AFRveg_dir(1:nbchar) // 'AFRveg_IGBP.nc'
+C + *****
+ AFRcid = NCOPN(AFRveg_file,NCNOWRIT,Rcode)
+ AFR_ID = NCVID(AFRcid,'IGBP',Rcode)
+C + *****
+ ENDIF
+
+ IF (EURdom) THEN
+ nbchar=1
+ DO i=1,60
+ IF (EURveg_dir(i:i).ne.' ') nbchar=i
+ ENDDO
+ EURveg_file = EURveg_dir(1:nbchar) // 'EURveg_IGBP.nc'
+C + *****
+ EURcid = NCOPN(EURveg_file,NCNOWRIT,Rcode)
+ EUR_ID = NCVID(EURcid,'IGBP',Rcode)
+C + *****
+ ENDIF
+
+C +---Select domains (Africa and/or Europe)
+C + =====================================
+
+C +---idom = 1 : Europe
+C + -----------------
+
+ G_lat1(EUidom)=EUR_G_lat1
+ G_lon1(EUidom)=EUR_G_lon1
+ G_reso(EUidom)=EUR_G_reso
+ size_X(EUidom)=EUR_size_X
+ size_Y(EUidom)=EUR_size_Y
+ VEG_ID(EUidom)=EUR_ID
+ ncid (EUidom)=EURcid
+
+
+C +---idom = 2 : Africa
+C + -----------------
+
+ G_lat1(AFidom)=AFR_G_lat1
+ G_lon1(AFidom)=AFR_G_lon1
+ G_reso(AFidom)=AFR_G_reso
+ size_X(AFidom)=AFR_size_X
+ size_Y(AFidom)=AFR_size_Y
+ VEG_ID(AFidom)=AFR_ID
+ ncid (AFidom)=AFRcid
+
+
+C +---Treatment of each NST grid point (except boundaries)
+C + ====================================================
+
+ mmx = mx
+ mmy = my
+ ii1 = MIN(2,mmx)
+ ii2 = MAX(1,mmx-1)
+ IF (mmx.eq.1) THEN
+ ii1 = 1
+ ii2 = 1
+ ENDIF
+ jj1 = MIN(2,mmy)
+ jj2 = MAX(1,mmy-1)
+ IF (mmy.eq.1) THEN
+ jj1 = 1
+ jj2 = 1
+ ENDIF
+
+
+ DO j=jj1,jj2 ! Loop on NST grid points
+ DO i=ii1,ii2 ! -----------------------
+
+C +---Initialisation of IGBP variables
+C + ================================
+
+ cmpt=0.
+ DO k=1,nigbp
+ IGBP(k)=0.
+ ENDDO
+
+
+C +---Location of NST grid cell in the input data grid
+C + ================================================
+
+ DO idom=1,nbdom
+
+ IF (NSTinc(i,j,idom)) THEN
+
+
+C +---Search for the closest point in data file
+C + -----------------------------------------
+
+ AUXlon = NST__x(i,j)
+ AUXlat = NST__y(i,j)
+C + ******
+ CALL SPHERC (Vtrue,AUXlon,AUXlat)
+C + ******
+
+ i_cent=NINT((AUXlon-G_lon1(idom))/G_reso(idom))+1
+ j_cent=NINT((AUXlat-G_lat1(idom))/G_reso(idom))+1
+
+
+C +---Check if (i,j) belong to the data domain
+C + ----------------------------------------
+
+ IF (i_cent.lt.3 .or. i_cent.gt.(size_X(idom)-2) .or.
+ . j_cent.lt.3 .or. j_cent.gt.(size_Y(idom)-2)) GOTO 900
+
+
+C +---Compute the resolution of the considered NST cell
+C + -------------------------------------------------
+
+ dx = 0.0
+ dy = 0.0
+
+ IF (mmx.ne.1.and.mmy.ne.1) THEN
+ ii=MAX(i,2)
+ jj=MAX(j,2)
+ AUXlo1 = NST__x(ii ,jj )
+ AUXlo2 = NST__x(ii-1,jj-1)
+ AUXla1 = NST__y(ii ,jj )
+ AUXla2 = NST__y(ii-1,jj-1)
+ ELSE
+ IF (mmx.ne.1) THEN
+ ii=MAX(i,2)
+ jj=1
+ AUXlo1 = NST__x(ii ,jj)
+ AUXlo2 = NST__x(ii-1,jj)
+ AUXla1 = NST__y(ii ,jj)
+ AUXla2 = NST__y(ii-1,jj)
+ ELSE
+ ii=1
+ jj=1
+ AUXlo1 = NST__x(ii,jj)
+ AUXlo2 = NST__x(ii,jj)
+ AUXla1 = NST__y(ii,jj)
+ AUXla2 = NST__y(ii,jj)
+ ENDIF
+
+ ENDIF
+
+C + ******
+ CALL SPHERC (Vtrue,AUXlo1,AUXla1)
+ CALL SPHERC (Vtrue,AUXlo2,AUXla2)
+C + ******
+ dx=ABS(AUXlo1-AUXlo2)*111111.*COS(AUXla1*degrad)
+ dy=ABS(AUXla1-AUXla2)*111111.
+
+
+C +---Define the data points to be read around (i_cent,j_cent)
+C + --------------------------------------------------------
+
+ G_dx = G_reso(idom)*111111.*COS(AUXla1*degrad)
+ G_dy = G_reso(idom)*111111.
+
+ G_nx=NINT(dx/G_dx/2.)-1
+ G_ny=NINT(dy/G_dy/2.)-1
+
+ G_nx=MAX(G_nx,0)
+ G_ny=MAX(G_ny,0)
+
+ i1=i_cent-G_nx
+ i2=i_cent+G_nx
+ j1=j_cent-G_ny
+ j2=j_cent+G_ny
+
+ i1=MAX(i1,1)
+ i2=MIN(i2,size_X(idom))
+ j1=MAX(j1,1)
+ j2=MIN(j2,size_Y(idom))
+
+
+C +---Initialisation of temporary IGBP variables
+C + ==========================================
+
+ icmpt=0.
+ DO k=1,nigbp
+ iIGBP(k)=0.
+ ENDDO
+
+ tmp_z0(i,j) = 0.
+
+
+C +---Reading of input data
+C + =====================
+
+ DO l=j1,j2
+ DO k=i1,i2
+
+ start(1)=k
+ start(2)=l
+ count(1)=1
+ count(2)=1
+
+C + *****
+ CALL NCVGT (ncid(idom),VEG_ID(idom),start,count,val_IGBP,Rcode)
+C + *****
+
+ IF ((val_IGBP.gt.0).and.(val_IGBP.le.nigbp)) THEN
+ icmpt =icmpt +1.
+ iIGBP(val_IGBP)=iIGBP(val_IGBP)+1.
+ tmp_z0(i,j) =tmp_z0(i,j) +igbp_z0(val_IGBP)
+ ENDIF
+
+ ENDDO
+ ENDDO
+
+ aux = 0.
+ DO k=1,nigbp-1
+ aux = aux + REAL(iIGBP(k))
+ ENDDO
+
+ IF (aux.gt.0.) THEN
+ cmpt =icmpt
+ NSTmsk(i,j)=idom
+ DO k=1,nigbp
+ IGBP(k)=iIGBP(k)
+ ENDDO
+ tmp_z0(i,j) = tmp_z0(i,j)/aux
+ ENDIF
+
+ ENDIF ! NSTinc
+
+ ENDDO ! Loop on idom
+
+
+C +---Particular case 1 : water area
+C + ==============================
+
+ IF (IGBP(17).gt.(cmpt/2.).and.NST_sh(i,j).le.300) THEN
+ cmpt =0.
+ NSTsol(i,j)=1
+ ENDIF
+
+C +---Particular case 2 : dominant ice/snow
+C + =====================================
+
+ IF (IGBP(15).gt.(cmpt/2.)) THEN
+! cmpt =0.
+! NSTsol(i,j)=3
+ write(6,*)
+ write(6,*)
+ . 'WARNING (GLOveg.f): snow/ice imposed for grid point ',i,j
+ write(6,*)
+ . ' You must initialise SISVAT snow model !!'
+ ENDIF
+
+C +---Particular case 3 : dominant land
+C + =================================
+
+ IF (cmpt.GT.0.1E-10.and.NSTsol(i,j).le.2) NSTsol(i,j)=4
+
+C + **************************
+ IF (NSTsol(i,j).ge.4) THEN ! Continental areas
+C + **************************
+
+
+C +---Initialisation of surface variables
+C + ===================================
+
+ NSTsvt(i,j,1) = 6
+ NSTsfr(i,j,1) =100
+ NSTveg(i,j,1) = 9
+ NSTvfr(i,j,1) =100
+ DO k=1,nvx
+ NSTlai(i,j,k) = 2.0
+ NSTglf(i,j,k) = 1.0
+ ENDDO
+
+C +---Dominant IGBP classes
+C + =====================
+
+C +... Initialization
+ DO k=1,nigbp
+ WK_tmp(k)=IGBP(k)
+ ENDDO
+
+C +... Search for dominant classes
+ DO l=1,nvx
+ DO k=1,nigbp
+ IF (WK_tmp(k).gt.NSTvfr(i,j,l)) THEN
+ NSTvfr(i,j,l)=WK_tmp(k)
+ NSTveg(i,j,l)=k
+ WK_tmp(k) =0
+ ENDIF
+ ENDDO
+ ENDDO
+
+C +... Normalization of NSTvfr
+ totvfr=0
+ DO l=1,nvx
+ totvfr=totvfr+NSTvfr(i,j,l)
+ ENDDO
+ IF (totvfr.ne.0) THEN
+ DO l=1,nvx
+ aux1 =REAL(NSTvfr(i,j,l))
+ aux2 =REAL(totvfr)
+ NSTvfr(i,j,l)=NINT(aux1/aux2*100.)
+ ENDDO
+ ENDIF
+
+
+C +---Convertion of IGBP to SVAT classification
+C + =========================================
+
+ IF (cmpt.gt.0.) THEN
+
+C +... initialisation
+C + ~~~~~~~~~~~~~~
+ DO l=0,nsvat
+ SVAT(l)=0.
+ ENDDO
+
+C +... convertion to SVAT
+C + ~~~~~~~~~~~~~~~~~~
+ DO k=1,nigbp
+ DO l=0,nsvat
+ SVAT(l)=SVAT(l)+convert(k,l)*IGBP(k)/cmpt
+ ENDDO
+ ENDDO
+
+C SVAT(l) is the fraction covered by class l
+C for each SVAT class
+
+C +... retain the (nvx-1) dominant classes
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ DO ido=1,nvx
+ idomi=0
+ DO l=0,nsvat
+ IF (SVAT(l).GT.SVAT(idomi)) THEN
+ idomi=l
+ ENDIF
+ ENDDO
+ svat_class(ido)=idomi
+ svat_frac (ido)=SVAT(idomi)
+ SVAT(idomi)=0.0
+ ENDDO
+
+C +... class (nvx) was reserved for barren soil
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+c svat_class(nvx) = 0
+c svat_frac (nvx) = SVAT(0)
+
+C +... normalizing the three dominant fractions
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ frac_tot=0.
+ DO l=1,nvx
+ frac_tot=frac_tot+svat_frac(l)
+ ENDDO
+ IF (frac_tot.ne.0.) THEN
+ DO l=1,nvx
+ svat_frac(l)=svat_frac(l)/frac_tot
+ ENDDO
+ ENDIF
+
+C +... attribute classes and fractions to NST variables
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ DO k=1,nvx
+ NSTsvt(i,j,k)= svat_class(k)
+ NSTsfr(i,j,k)=NINT(svat_frac (k)*100.)
+ ENDDO
+
+ ENDIF
+
+
+C +---Final check of soil fractions
+C + =============================
+
+ frac_itot=0
+ DO l=1,nvx
+ frac_itot=frac_itot+NSTsfr(i,j,l)
+ ENDDO
+
+ IF (frac_itot.le.0) THEN ! Imposed bare soil
+ NSTsvt(i,j,nvx)= 0
+ NSTsfr(i,j,nvx)=100
+ NSTveg(i,j,nvx)= -1
+ NSTvfr(i,j,nvx)=100
+ DO k=1,nvx-1
+ NSTsvt(i,j,k)=0
+ NSTsfr(i,j,k)=0
+ NSTveg(i,j,k)=0
+ NSTvfr(i,j,k)=0
+ ENDDO
+ write(6,*) 'Warning : bare soil imposed for grid point ',i,j
+ . ,frac_itot
+ ENDIF
+
+
+C +---Roughness length
+C + ================
+
+ IF (RUGdat) THEN
+ NST_z0(i,j) = tmp_z0(i,j)
+C + NST_r0(i,j) = 0.1*NST_z0(i,j)
+ ENDIF
+
+
+C +---Define max leaf area index
+C + ==========================
+
+ DO l=1,nvx
+
+ IF (NSTsvt(i,j,l).eq. 0) NSTlmx(i,j,l) = 0.0
+ IF (NSTsvt(i,j,l).eq. 1) NSTlmx(i,j,l) = 0.6
+ IF (NSTsvt(i,j,l).eq. 2) NSTlmx(i,j,l) = 0.9
+ IF (NSTsvt(i,j,l).eq. 3) NSTlmx(i,j,l) = 1.2
+ IF (NSTsvt(i,j,l).eq. 4) NSTlmx(i,j,l) = 0.7
+ IF (NSTsvt(i,j,l).eq. 5) NSTlmx(i,j,l) = 1.4
+ IF (NSTsvt(i,j,l).eq. 6) NSTlmx(i,j,l) = 2.0
+ IF (NSTsvt(i,j,l).eq. 7.or.NSTsvt(i,j,l).eq.10)
+ . NSTlmx(i,j,l) = 3.0
+ IF (NSTsvt(i,j,l).eq. 8.or.NSTsvt(i,j,l).eq.11)
+ . NSTlmx(i,j,l) = 4.5
+ IF (NSTsvt(i,j,l).eq. 9.or.NSTsvt(i,j,l).eq.12)
+ . NSTlmx(i,j,l) = 6.0
+
+ NSTlai(i,j,l) = NSTlmx(i,j,l)
+ NSTglf(i,j,l) = 1.0
+
+ ENDDO
+
+
+C + ****
+ ELSE ! Ocean, ice, snow
+C + ****
+
+
+ NSTsvt(i,j,nvx)= 0
+ NSTsfr(i,j,nvx)=100
+ NSTveg(i,j,nvx)= -1
+ NSTvfr(i,j,nvx)=100
+ DO l=1,nvx
+ NSTlai(i,j,l) = 0.0
+ NSTglf(i,j,l) = 0.0
+ ENDDO
+
+
+C + *****
+ ENDIF ! Continental areas
+C + *****
+
+900 CONTINUE
+
+
+ ENDDO ! Loop on NST grid points
+ ENDDO ! -----------------------
+
+
+C +---Close Netcdf data file
+C + ======================
+
+ IF (AFRdom) THEN
+C + ******
+ CALL NCCLOS(AFRcid,Rcode)
+C + ******
+ ENDIF
+
+ IF (EURdom) THEN
+C + ******
+ CALL NCCLOS(EURcid,Rcode)
+C + ******
+ ENDIF
+
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+990 CONTINUE
+
+ IF (region.eq."GRD") call USRgrd('GLOveg') ! Greenland
+ IF (region.eq."EUR") call USReur('GLOveg') ! Iceland
+
+ write(6,*)
+
+ RETURN
+ END
diff --git a/MAR/code_nestor/src/GRAhgd.f b/MAR/code_nestor/src/GRAhgd.f
new file mode 100644
index 0000000000000000000000000000000000000000..ddaa34b4aecdd326752c16f17d1501aeeda2061b
--- /dev/null
+++ b/MAR/code_nestor/src/GRAhgd.f
@@ -0,0 +1,292 @@
+C +-------------------------------------------------------------------+
+C + Subroutine GRAhgd February 2002 NESTING +
+C +-------------------------------------------------------------------+
+C + +
+C + Input : Parameters from MARgrd.ctr +
+C + ^^^^^^^ +
+C + +
+C + Output: Creation of the horizontal grid for GRADS +
+C + ^^^^^^^ Variables : NST__x(mx,my) and NST__y(mx,my) (long./lat.) +
+C + NSTgdx(mx) and NSTgdy(my) (Lambert) +
+C + NST_dx (horizontal resolution) +
+C + +
+C +-------------------------------------------------------------------+
+
+
+ SUBROUTINE GRAhgd
+
+
+ IMPLICIT NONE
+
+
+C +---General variables
+C + ---------------
+
+ INCLUDE 'NSTdim.inc'
+ INCLUDE 'NESTOR.inc'
+ INCLUDE 'NSTvar.inc'
+ INCLUDE 'LSCvar.inc'
+
+C +---Local variables
+C + ---------------
+
+ INTEGER i,j,fID,iloc,jloc,vmx1,vmx2,vmy1,vmy2,imez,jmez
+
+ REAL degrad,MinLon,MaxLon,MinLat,MaxLat,lwblon,upblon,
+ . lwblat,upblat,empty1(1),dist,distmin,GElon0,GElat0,
+ . dx,dy,resol
+
+ CHARACTER*7 namlon,namlat,nam_SH
+ CHARACTER*10 var_units
+ CHARACTER*100 LSCtit
+
+C +---Constants
+C + ---------
+
+ DATA degrad / 1.745329252d-2/
+C +... degrad : Conversion Factor: Radian --> Degrees
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---READING OF GRID PARAMETERS IN MARgrd.ctr
+C + ========================================
+
+ OPEN (unit=51,status='old',file='GRAgrd.ctr')
+
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) GElon0
+ read (51,*) imez
+ read (51,*) GElat0
+ read (51,*) jmez
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) resol
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+
+ CLOSE(unit=51)
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---HORIZONTAL RESOLUTION (degree)
+C + =====================
+
+ dx = resol*111.111111
+ dy = dx
+
+ NST_dx=dx
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---CREATION OF HORIZONTAL MAR GRID
+C + ===============================
+
+
+C +---Domain reference grid point
+C + ---------------------------
+
+ IF (imez.lt.0.or.imez.gt.mx) imez = mx/2
+ IF (jmez.lt.0.or.jmez.gt.my) jmez = my/2
+
+
+C +---Create NST grid
+C + ---------------
+
+ DO i=1,mx
+ NSTgdx(i)=GElon0+(i-imez)*resol
+ ENDDO
+
+ DO j=1,my
+ NSTgdy(j)=GElat0+(j-jmez)*resol
+ ENDDO
+
+ DO j=1,my
+ DO i=1,mx
+ NST__x(i,j) = NSTgdx(i)
+ NST__y(i,j) = NSTgdy(j)
+ ENDDO
+ ENDDO
+
+
+C +---Open LSC file in order to verify the inclusion in LSC grid
+C + ----------------------------------------------------------
+
+ OPEN (unit=52,status='old',file='LSCfil.dat')
+ READ (52,'(a100)',END=230) LSCfil
+ GOTO 240
+
+230 write(6,*) 'No file found in LSCfil.dat.'
+ write(6,*) 'STOP in DEShgd.f'
+ STOP
+
+240 CONTINUE
+ CLOSE(unit=52)
+
+
+C +---Screen message
+C + --------------
+
+ write(6,*) 'Map projection: regular grid included in LSC grid'
+ write(6,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+ write(6,*) 'Open file : ',LSCfil
+
+
+C + *******
+ CALL UNropen (LSCfil,fID,LSCtit)
+C + *******
+
+
+C +---Read LSC (input) grid
+C + ---------------------
+
+ lwblon = -400.0
+ upblon = 400.0
+ lwblat = -100.0
+ upblat = 100.0
+
+ IF (LSCmod.eq.'MAR') THEN
+ namlon='lon'
+ namlat='lat'
+ nam_SH='sh'
+ ELSE
+ IF (LSCmod.eq.'NCP') THEN
+ namlon='lon'
+ namlat='lat'
+ nam_SH='SH'
+ ELSE
+ namlon='lon'
+ namlat='lat'
+ nam_SH='SH'
+ ENDIF
+ ENDIF
+
+ IF (REGgrd) THEN
+
+C + ******
+ CALL UNread (fID,nam_SH,1,1,bi,bj,ni,nj,1,
+ . LSC1Dx,LSC1Dy,empty1,var_units,LSC_sh)
+C + ******
+
+ DO j=1,nj
+ DO i=1,ni
+ LSC__x(i,j)=LSC1Dx(i)
+ LSC__y(i,j)=LSC1Dy(j)
+ ENDDO
+ ENDDO
+
+ ELSE
+
+C + ******
+ CALL UNread (fID,namlon,1,1,bi,bj,ni,nj,1,
+ . LSC1Dx,LSC1Dy,empty1,var_units,LSC__x)
+C + ******
+ CALL VALchk (namlon,ni,nj,LSC__x,lwblon,upblon)
+C + ******
+ CALL UNread (fID,namlat,1,1,bi,bj,ni,nj,1,
+ . LSC1Dx,LSC1Dy,empty1,var_units,LSC__y)
+C + ******
+ CALL VALchk (namlat,ni,nj,LSC__y,lwblat,upblat)
+C + ******
+
+ ENDIF
+
+
+C +---Close the NetCDF file
+C + =====================
+
+C + *******
+ CALL UNclose (fID)
+C + *******
+
+
+C +---Verify the inclusion of NST grid in LSC grid
+C + --------------------------------------------
+
+ MinLon = LSC__x( 1,1)
+ MaxLon = LSC__x(ni,1)
+ MinLat = LSC__y(1, 1)
+ MaxLat = LSC__y(1,nj)
+ DO i=1,ni
+ MinLat = MAX(LSC__y(i, 1),MinLat)
+ MaxLat = MIN(LSC__y(i,nj),MaxLat)
+ ENDDO
+ DO j=1,nj
+ MinLon = MAX(LSC__x( 1,j),MinLon)
+ MaxLon = MIN(LSC__x(ni,j),MaxLon)
+ ENDDO
+
+ IF (GElon0.lt.MinLon .or.
+ . GElon0.gt.MaxLon .or.
+ . GElat0.lt.MinLat .or.
+ . GElat0.gt.MaxLat) THEN
+ write(6,*)
+ write(6,*) 'The center of the NST grid is not included'
+ write(6,*) 'in the LSC grid. Please check and modify'
+ write(6,*) 'the GRAgrd.ctr file.'
+ write(6,*)
+ write(6,*) '--> STOP in GRAhgd.f'
+ write(6,*)
+ STOP
+ ENDIF
+
+ IF (MinLon.gt.NSTgdx( 1) .or.
+ . MaxLon.lt.NSTgdx(mx) .or.
+ . MinLat.gt.NSTgdy( 1) .or.
+ . MaxLat.lt.NSTgdy(my)) THEN
+ vmx1 = INT((GElon0-MinLon)/resol)
+ vmx2 = INT((MaxLon-GElon0)/resol)
+ vmy1 = INT((GElat0-MinLat)/resol)
+ vmy2 = INT((MaxLat-GElat0)/resol)
+ write(6,*)
+ write(6,*) 'NST grid is not fully included in LSC grid'
+ write(6,*)
+ write(6,*) 'Characteristics of the LSC grid :'
+ write(6,*) '- MinLon = ',MinLon
+ write(6,*) '- MaxLon = ',MaxLon
+ write(6,*) '- MinLat = ',MinLat
+ write(6,*) '- MaxLat = ',MaxLat
+ write(6,*)
+ write(6,*) 'Characteristics of the NST grid :'
+ write(6,*) '- MinLon = ',NSTgdx(1)
+ write(6,*) '- MaxLon = ',NSTgdx(mx)
+ write(6,*) '- MinLat = ',NSTgdy(1)
+ write(6,*) '- MaxLat = ',NSTgdy(my)
+ write(6,*)
+ write(6,*) 'Please try the following parameters : '
+ write(6,*)
+ write(6,*) 'mx (in NSTdim.inc) = ',vmx1+vmx2
+ write(6,*) 'my (in NSTdim.inc) = ',vmy1+vmy2
+ write(6,*) 'imez (in GRAgrd.ctr) = ',vmx1
+ write(6,*) 'jmez (in GRAgrd.ctr) = ',vmy1
+ write(6,*)
+ write(6,*) '--> STOP in GRAhgd.f'
+ write(6,*)
+ STOP
+ ENDIF
+
+
+C +---Print the characteristics of the horizontal grid
+C + ------------------------------------------------
+
+ write(6,*) 'Horizontal regular grid created'
+ write(6,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+ write(6,200) mx,my,resol,
+ . MinLon,MaxLon,MinLat,MaxLat
+200 format(' Grid points : ',i4,' * ',i4,/,
+ . ' Horizontal resolution : ',f7.2,' degree',/,
+ . ' GRADS longitude between : ',f7.2,' and ',f7.2,/,
+ . ' GRADS latitude between : ',f7.2,' and ',f7.2,/)
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+ RETURN
+ END
diff --git a/MAR/code_nestor/src/GRAvgd.f b/MAR/code_nestor/src/GRAvgd.f
new file mode 100644
index 0000000000000000000000000000000000000000..ab202c832ce85f03efce4c83916fa636d71ab89b
--- /dev/null
+++ b/MAR/code_nestor/src/GRAvgd.f
@@ -0,0 +1,113 @@
+C +-------------------------------------------------------------------+
+C | Subroutine GRAvgd 13-04-2022 JFG |
+C +-------------------------------------------------------------------+
+C | |
+C | Vertical grid for GRADS output analysis. Tailored for 2D grids in |
+C | April 2022 to improve performance. |
+C | |
+C | Input : - nz : number of vertical levels (N.B.: nz rather |
+C | ^^^^^^^ than nk because nk already used in NSTdim.inc) |
+C | - klev : if specified, the level at which pressure and |
+C | hybrid coordinate has to be computed |
+C | - GRA_sp(mx,my) : surface pressure |
+C | - dimensions from NSTdim.inc (e.g. mx, my) |
+C | |
+C | Output: Vertical grid of the ECMWF model : |
+C | ^^^^^^^ - GRA__p(mx,my,nz+1) : pressure at each level [kPa] |
+C | - GRA_hp(mx,my,nz+1) : hybrid coordinates |
+C | |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE GRAvgd (nz,klev,GRA_sp,GRA__p,GRA_hp)
+
+ IMPLICIT NONE
+
+ INCLUDE 'NSTdim.inc' ! Provides mx, my
+
+C +---Local variables
+C + ---------------
+
+ INTEGER nz,klev,i,j,k,k1,k2
+
+ REAL pp,ppm,pps,ppf,pp1,dpsl,hh,plevel(nz),
+ . GRA_sp(mx,my),GRA__p(mx,my,nz+1),GRA_hp(mx,my,nz+1)
+
+ CHARACTER*10 var_units
+
+C +---Atmospheric levels: pressure levels
+C + -----------------------------------
+
+ IF (nz.ne.12) THEN
+ write(6,*)
+ write(6,*) 'GRADS output grid is valid only with 12 vertical'
+ write(6,*) 'levels. Please set mz=12 in NSTdim.inc'
+ write(6,*)
+ write(6,*) '--> STOP in GRAvgd.f'
+ write(6,*)
+ STOP
+ ENDIF
+
+ plevel( 1) = 100.
+ plevel( 2) = 150.
+ plevel( 3) = 200.
+ plevel( 4) = 250.
+ plevel( 5) = 300.
+ plevel( 6) = 400.
+ plevel( 7) = 500.
+ plevel( 8) = 600.
+ plevel( 9) = 700.
+ plevel(10) = 850.
+ plevel(11) = 925.
+ plevel(12) = 1000.
+
+C +---Computation for a given level or all levels ?
+C + ---------------------------------------------
+
+ IF ((klev.le.0).or.(klev.gt.nz)) THEN
+ k1=1
+ k2=nz
+ ELSE
+ k1=1
+ k2=klev
+ ENDIF
+
+ pp1 = 105. ! Reference pressure (KPa)
+ dpsl = 20. ! "> boundary layer" (KPa)
+
+C +---For each i,j pixel (start of grid traversal)
+C + --------------------------------------------
+
+ DO i=1,mx
+ DO j=1,my
+
+C +---Compute pressure at each levels
+C + -------------------------------
+
+ DO k=k1,k2
+ GRA__p(i,j,k)=plevel(k)/10. ! (kPa)
+ccccc IF (GRA__p(i,j,k).gt.GRA_sp)
+ccccc. GRA__p(i,j,k)=GRA_sp(i,j)-REAL(k)*0.1
+ ENDDO
+
+ GRA__p(i,j,nz+1)=GRA_sp(i,j)
+
+C +---Compute hybrid coordinates (required by nesting procedure)
+C + --------------------------
+C +...Local hybrid coordinate: set parameters:
+
+ pps = GRA_sp(i,j)
+ ppm = pps - dpsl
+ DO k = k1,k2+1
+ pp = GRA__p(i,j,k)
+ hh = pp/pp1
+ IF (pp.gt.ppm) THEN
+ ppf= (pp-ppm)/(pps-ppm)
+ hh = hh + (pp1-pps)/pp1 * ppf * ppf
+ END IF
+ GRA_hp(i,j,k) = LOG(hh)
+ ENDDO
+
+ END DO; END DO ! End of grid traversal
+
+ RETURN
+ END
diff --git a/MAR/code_nestor/src/GSWPsl.f b/MAR/code_nestor/src/GSWPsl.f
new file mode 100644
index 0000000000000000000000000000000000000000..c1cf4308c9a8eabba514ed778c6acaee4df77166
--- /dev/null
+++ b/MAR/code_nestor/src/GSWPsl.f
@@ -0,0 +1,275 @@
+C +-------------------------------------------------------------------+
+C | Subroutine GSWPsl April 2004 NESTING |
+C +-------------------------------------------------------------------+
+C | |
+C | Input : - NST__x : NST grid, longitude (degrees) |
+C | ^^^^^^^ - NST__y : NST grid, latitude (degrees) |
+C | |
+C | Output: - NSTdsa : soil albedo |
+C | ^^^^^^^ - NSTtex : soil texture (fine, medium, rough) |
+C | |
+C | from GSWP data set (http://grads.iges.org/gswp/) |
+C | |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE GSWPsl
+
+
+ IMPLICIT NONE
+
+
+C +---Netcdf specifications
+C + ---------------------
+
+ INCLUDE 'NetCDF.inc'
+
+
+C +---General and local variables
+C + ---------------------------
+
+ INCLUDE 'NSTdim.inc'
+ INCLUDE 'NSTvar.inc'
+ INCLUDE 'NESTOR.inc'
+ INCLUDE 'LOCfil.inc'
+
+ INTEGER error,itmp1,itmp2,Nlon,Nlat,ii,jj,i,j,inc,Nlon1,Nlat1
+ INTEGER iimin,jjmin,l
+
+ PARAMETER(Nlon=360,Nlat=150,Nlon1=320,Nlat1=320)
+
+ REAL rtmp1,rtmp2,distmin,
+ . GSWPalb(NLON,NLAT),GSWPsol(NLON,NLAT),GSWPmsk(NLON,NLAT),
+ . GSWPlon(NLON),GSWPlat(NLAT),
+ . NOAAalb(NLON1,NLAT1),NOAAlon(NLON1),NOAAlat(NLAT1)
+
+C +---1. Read cdf file for soil parameters : texture and bare soil albedo
+C + ===================================================================
+
+C +---1.1 GSWP (GSWP-SOIL.nc)
+C -----------------------
+
+ error = nf_open('input/SOIL/GSWP-SOIL.nc',nf_nowrite,inc)
+
+ IF (error.ne.nf_noerr) THEN
+ write(6,*) '+++++++++++++++++++++++++++++++++'
+ write(6,*) 'Routine GSWPsl.f -----> Warning !!!'
+ write(6,*) 'File GSWP-SOIL.nc not provided'
+ write(6,*) 'Check the directory input/SOIL/'
+ write(6,*) 'NESTOR stopped NOW !!!'
+ write(6,*) '+++++++++++++++++++++++++++++++++'
+ stop
+ ENDIF
+
+ error = nf_inq_varid(inc,'LON' ,itmp1)
+ error = nf_get_var_real(inc ,itmp1,GSWPlon)
+ error = nf_inq_varid(inc,'LAT' ,itmp1)
+ error = nf_get_var_real(inc ,itmp1,GSWPlat)
+ error = nf_inq_varid(inc,'ALBEDO_SOIL',itmp1)
+ error = nf_get_var_real(inc ,itmp1,GSWPalb)
+ error = nf_inq_varid(inc,'SOILCLASS' ,itmp1)
+ error = nf_get_var_real(inc ,itmp1,GSWPsol)
+ error = nf_inq_varid(inc,'LANDMASK' ,itmp1)
+ error = nf_get_var_real(inc ,itmp1,GSWPmsk)
+ error = nf_close(inc)
+
+C +---1.2 NOAA (AFRmax-alb.nc)
+C ------------------------
+
+ error = nf_open('input/SOIL/AFRmax-alb.nc',nf_nowrite,inc)
+
+ IF (region.eq.'AFW'.and.error.ne.nf_noerr) THEN
+ write(6,*) '+++++++++++++++++++++++++++++++++'
+ write(6,*) 'Routine GSWPsl.f -----> Warning !!!'
+ write(6,*) 'File AFRmax-alb.nc not provided'
+ write(6,*) 'Check the directory input/SOIL/'
+ write(6,*) 'NESTOR stopped NOW !!!'
+ write(6,*) '+++++++++++++++++++++++++++++++++'
+ stop
+ ENDIF
+
+ error = nf_inq_varid(inc,'lon',itmp1)
+ error = nf_get_var_real(inc, itmp1,NOAAlon)
+ error = nf_inq_varid(inc,'lat',itmp1)
+ error = nf_get_var_real(inc, itmp1,NOAAlat)
+ error = nf_inq_varid(inc,'alb',itmp1)
+ error = nf_get_var_real(inc, itmp1,NOAAalb)
+ error = nf_close(inc)
+
+C +---2. GSWP grid ---> NST grid
+C + ============================
+
+ DO j=1,my ! Loop for each NST grid point
+ DO i=1,mx ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+ IF (region.eq.'AFW') THEN
+
+ itmp1=0
+ rtmp1=0
+ rtmp2=0
+
+ DO ii = 1,NLON
+ DO jj = 1,NLAT
+
+
+ if(abs(NST__x(i,j)-GSWPlon(ii)).le.0.55 .and.
+ . abs(NST__y(i,j)-GSWPlat(jj)).le.0.55) then
+
+ ! GSWP resolution = 1°
+
+ rtmp1 = GSWPmsk(ii,jj) + rtmp1
+ itmp1 = 1 + itmp1
+
+ ENDIF
+
+ enddo
+ enddo
+
+! if(rtmp1/real(itmp1)> 0.5) NSTsol(i,j) =4
+! if(rtmp1/real(itmp1)<= 0.5) NSTsol(i,j) =1
+
+ ENDIF
+
+C +---2.1 Sea and Sea Ice
+C -------------------
+
+ IF (NSTsol(i,j).le.2) then
+ NSTtex(i,j) = 0
+ NSTdsa(i,j) = 0.15
+ IF (region.eq."GRD".or.region.eq."ANT") NSTdsa(i,j) = 0.20
+ ENDIF
+
+C +---2.2 Snow - Ice
+C --------------
+
+ IF (NSTsol(i,j).eq.3) then
+ NSTtex(i,j) = 3
+ NSTdsa(i,j) = 0.85
+ ENDIF
+
+C +---2.3 Soil - Tundra
+C -----------------
+
+ IF (NSTsol(i,j).ge.4) then
+
+ itmp1=0
+ itmp2=0
+ rtmp1=0
+ rtmp2=0
+
+ distmin=10000
+
+ DO ii = 1,NLON
+ DO jj = 1,NLAT
+
+ if(abs(NST__x(i,j)-GSWPlon(ii))+
+ . abs(NST__y(i,j)-GSWPlat(jj))<distmin.and.
+ . GSWPmsk(ii,jj) .ne.0.0) then
+
+ distmin=
+ . abs(NST__x(i,j)-GSWPlon(ii))+
+ . abs(NST__y(i,j)-GSWPlat(jj))
+ iimin = ii
+ jjmin = jj
+ itmp1 = 1 + itmp1
+ endif
+
+ if(abs(NST__x(i,j)-GSWPlon(ii)).le.0.6 .and.
+ . abs(NST__y(i,j)-GSWPlat(jj)).le.0.6 .and.
+ . GSWPmsk(ii,jj) .ne.0.0) then
+
+ ! GSWP resolution = 1°
+
+ rtmp1 = GSWPalb(ii,jj) + rtmp1
+ rtmp2 = GSWPsol(ii,jj) + rtmp2
+ itmp2 = 1 + itmp2
+
+ endif
+
+ ENDDO
+ ENDDO
+
+ IF (itmp1.gt.0) THEN
+
+ IF (itmp2.gt.0) THEN
+ NSTdsa(i,j) = REAL(rtmp1/itmp2)
+ ELSE
+ NSTdsa(i,j) = GSWPalb(iimin,jjmin)
+ ENDIF
+
+c NSTtex(i,j) = NINT (rtmp2/itmp2)
+ NSTtex(i,j) = GSWPsol(iimin,jjmin)
+ ELSE
+ NSTtex(i,j) = 5
+ NSTdsa(i,j) = 0.20
+ ENDIF
+
+ ENDIF
+
+C +---2.3.1 Special Albedo for AFW simulation
+
+C XF Jan 2014: albedo too low in the "congo" basin
+
+c IF (region.eq.'AFW'.and.NSTsol(i,j).ge.4) THEN
+c
+c itmp1=0
+c rtmp1=0
+c
+c DO ii = 1,NLON1
+c DO jj = 1,NLAT1
+c
+c if(abs(NST__x(i,j)-NOAAlon(ii)) .le. 0.30.and.
+c . abs(NST__y(i,j)-NOAAlat(jj)) .le. 0.30.and.
+c . NOAAalb(ii,jj).ne.-99.0 ) then
+c
+c ! NOAA resolution = 0.25 deg
+c
+c rtmp1 = NOAAalb(ii,jj) + rtmp1
+c itmp1 = 1 + itmp1
+c
+c ENDIF
+c
+c ENDDO
+c ENDDO
+c
+c IF (itmp1.gt.0) THEN
+c NSTdsa(i,j) = REAL(rtmp1/itmp1)/100.
+c ELSE
+c NSTdsa(i,j) = 0.25
+c ENDIF
+c
+c ENDIF
+
+ IF (region.eq.'AFW'.and.NSTsol(i,j).ge.4) THEN
+ NSTdsa(i,j) = max(0.1,min(0.45,NSTdsa(i,j)))
+ ENDIF
+
+C +---2.3.2 Special Texture/Albedo for GRD Simulation
+
+c IF (region.eq."GRD".and.NSTsol(i,j).ge.4) THEN
+c NSTdsa(i,j) = 0.25
+c NSTtex(i,j) = 2
+c ENDIF
+
+C +---2.3.3 Max/Min of Texture/Albedo
+
+ IF (NSTsol(i,j).ge.4) THEN
+ NSTdsa(i,j) = max(0.15,min(0.5,NSTdsa(i,j)))
+ NSTalb(i,j) = NSTdsa(i,j)
+ NSTtex(i,j) = max(1 ,min(12 ,NSTtex(i,j)))
+ ENDIF
+
+ if(NSTsvt(i,j,1)==13) then ! city
+ rtmp1=0
+ do l=2,mw
+ rtmp1=rtmp1+NSTsfr(i,j,l)
+ enddo
+ NSTdsa(i,j) = (0.1 *NSTsvt(i,j,1) + NSTdsa(i,j)*rtmp1)
+ . / ( NSTsvt(i,j,1) + rtmp1)
+ NSTalb(i,j) = NSTdsa(i,j)
+ endif
+
+ ENDDO ! Loop for i (NST grid)
+ ENDDO ! Loop for j (NST grid)
+
+ RETURN
+ END
diff --git a/MAR/code_nestor/src/HWSDsl.f b/MAR/code_nestor/src/HWSDsl.f
new file mode 100644
index 0000000000000000000000000000000000000000..7b8d9b25b9a83bf2a1938e8315b49c50db369ff1
--- /dev/null
+++ b/MAR/code_nestor/src/HWSDsl.f
@@ -0,0 +1,208 @@
+C +-------------------------------------------------------------------+
+C | Subroutine HWSDsl JAN 2018 NESTING |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE HWSDsl
+
+ IMPLICIT none
+
+C +---General variables
+C + -----------------
+
+ INCLUDE 'NSTdim.inc'
+ INCLUDE 'NSTvar.inc'
+ INCLUDE 'LOCfil.inc'
+ INCLUDE 'NetCDF.inc'
+ INCLUDE 'NESTOR.inc'
+
+ real ,parameter :: reso=0.00833333
+ integer,parameter :: cx = 43200
+ integer,parameter :: cy = 17760
+
+ ! J.-F. Grailet: renamed in/jn as ins/jns (s=size) to avoid
+ ! a potential confusion with the "in" keyword in Fortran (it is
+ ! highlighted as such in my code editor).
+
+ integer minL, dimL
+ integer ins,jns,i,j,k,l,kk,ll,x,y
+ integer NET_ID,NETcid,Rcode
+ integer ilc(mw+1),lcmax
+ integer cov
+
+ ! WIP
+ integer :: fiCell(2), nCells(2)
+ integer, dimension(:,:), allocatable :: arrCov
+
+ ! J.-F. Grailet remark: previous_dx2 has not practical use.
+ real dx1,dx2,dy1,dy2,previous_dx1,previous_dx2
+ real lc(0:13),nbr_lc
+ real dx3,dy3,dx4,dy4
+
+ NETcid = NCOPN("input/SOIL/HWSDglob.nc",NCNOWRIT,Rcode)
+ NET_ID = NCVID(NETcid,'HWS',Rcode)
+
+ write(6,*) 'HSWD SOIL Cover'
+ write(6,*) '~~~~~~~~~~~~~~~'
+ write(6,*) ' '
+
+ previous_dx1=5
+ previous_dx2=5
+
+ ! Loads a single large data band for the whole dual loop
+ CALL bufLim (cy, 58., minL, dimL)
+
+ fiCell(1) = 1
+ fiCell(2) = minL+1
+ nCells(1) = cx
+ nCells(2) = dimL
+
+ allocate(arrCov(cx, dimL))
+ RCode = nf_get_vara_int(NETcid,NET_ID,fiCell,nCells,arrCov)
+
+ DO j=1,my
+
+ ! Old display is no longer useful given the time/memory trade-off
+ ! WRITE(6,'(i4,$)') j
+
+ DO i=1,mx
+
+C + *****
+
+ IF(NSTsol(i,j)>=3.)THEN
+
+C+ +---No data areas !CKittel 07/10/16
+C+ if HWSDsl.f is very slow, please verify
+C+ http://webarchive.iiasa.ac.at/Research/LUC/External-World-soil-database/HTML/
+C+ and if no data over your area add it below
+
+ IF (NST__y(i,j)<-58 .or. !Antarctica
+ . (NST__y(i,j)<-40 .and. NST__y(i,j)>-55 !Kerguelen Island
+ . .and. NST__x(i,j)> 60
+ . .and. NST__X(i,j)< 75) .or.
+ . (NST__y(i,j)<-46.5 .and. NST__y(i,j)>-47.25 !Prince Edward Islands
+ . .and. NST__x(i,j)> 37
+ . .and. NST__X(i,j)< 38) .or.
+ . (NST__y(i,j)<-50 .and. NST__y(i,j)>-55 !South Georgia and the South Sandwich Islands
+ . .and. NST__x(i,j)>-42
+ . .and. NST__X(i,j)<-30)
+ . ) then
+ GOTO 2222
+ endif
+C + *****
+
+ dx1=abs(NST__x(i,j)-
+ . NST__x(max(1,min(mx,i-1)),max(1,min(my,j))))
+ dx2=abs(NST__x(i,j)-
+ . NST__x(max(1,min(mx,i+1)),max(1,min(my,j))))
+
+ dx3=abs(NST__x(i,j)-
+ . NST__x(max(1,min(mx,i)),max(1,min(my,j-1))))
+ dx4=abs(NST__x(i,j)-
+ . NST__x(max(1,min(mx,i)),max(1,min(my,j+1))))
+
+ dx1=max(dx1,max(dx2,max(dx3,dx4)))
+
+ dy1=abs(NST__y(i,j)-
+ . NST__y(max(1,min(mx,i )),max(1,min(my,j-1))))
+ dy2=abs(NST__y(i,j)-
+ . NST__y(max(1,min(mx,i )),max(1,min(my,j+1))))
+
+ dy3=abs(NST__y(i,j)-
+ . NST__y(max(1,min(mx,i-1)),max(1,min(my,j))))
+ dy4=abs(NST__y(i,j)-
+ . NST__y(max(1,min(mx,i+1)),max(1,min(my,j))))
+
+ dy1=max(dy1,max(dy2,max(dy3,dy4)))
+
+ if(dx1<50) then
+ dx1=dx1/(2.*reso)
+ else
+ dx1=previous_dx1
+ endif
+
+ dy1=dy1/(2.*reso)
+
+ ins=nint((NST__x(i,j)+180.)/reso)
+ jns=nint((NST__y(i,j)+ 58.)/reso)
+
+ nbr_lc=0
+
+ do while(nbr_lc==0)
+
+ lc=0.
+
+ do k=ins-nint(dx1),ins+nint(dx1)
+ do l=jns-nint(dy1),jns+nint(dy1)
+
+ kk=k
+ ll=l
+ if(kk<1) kk=cx+kk
+ if(ll<1) ll=1 ! cy+ll (previous code used lat. rollover ?)
+ if(kk>cx) kk=kk-cx
+ if(ll>cy) ll=cy ! ll-cy (ditto)
+
+ kk=max(1,min(cx,kk))
+ ll=max(1,min(cy,ll))
+
+ cov = arrCov(kk,ll-minL)
+
+ if(cov==1) lc(11)= lc(11)+1
+ if(cov==2) lc(10)= lc(10)+1
+ if(cov==3) lc(11)= lc(11)+1
+ if(cov==4) lc(7) = lc(7) +1
+ if(cov==5) lc(8) = lc(8) +1
+ if(cov==6) lc(4) = lc(4) +1
+ if(cov==7) lc(4) = lc(4) +1
+ if(cov==8) lc(9) = lc(9) +1
+ if(cov==9) lc(5) = lc(5) +1
+ if(cov==10) lc(6) = lc(6) +1
+ if(cov==11) lc(3) = lc(3) +1
+ if(cov==12) lc(2) = lc(2) +1
+ if(cov==13) lc(1) = lc(1) +1
+
+ if(cov==-1) lc(0) = lc(0)+1
+
+ enddo ; enddo
+
+ nbr_lc=0
+
+ do l=0,12
+ nbr_lc=nbr_lc+lc(l)
+ enddo
+
+ dx1=dx1*1.5
+ dx2=dx2*1.5
+ dy1=dy1*1.5
+ dy2=dy2*1.5
+
+ enddo
+
+ ilc=-1
+
+ lcmax=0 ; l=1
+
+ do k=0,12
+
+ if(l==1.and.lc(k)>=lcmax) then
+ lcmax=lc(k)
+ ilc(l)=k
+ endif
+
+ enddo
+
+ if(ilc(l)>0) then
+ NSTtex(i,j) = ilc(l)
+ NSTtex(i,j) = max(1 ,min(12 ,NSTtex(i,j)))
+ endif
+
+C + *****
+2222 continue
+ ENDIF ! Continental area
+C + *****
+
+ ENDDO
+ ENDDO
+
+ if (allocated(arrCov)) deallocate (arrCov)
+
+ END SUBROUTINE HWSDsl
diff --git a/MAR/code_nestor/src/ICEmsk.f b/MAR/code_nestor/src/ICEmsk.f
new file mode 100644
index 0000000000000000000000000000000000000000..09348b16094ec18f1760134dd1ea267b3bb5df4b
--- /dev/null
+++ b/MAR/code_nestor/src/ICEmsk.f
@@ -0,0 +1,235 @@
+C +-------------------------------------------------------------------+
+C | Subroutine ICEmsk Dec 12 NESTING |
+C +-------------------------------------------------------------------+
+C | |
+C | Input : Grid : NST__x and NST__y (longitude and latitude, degrees)|
+C | ^^^^^^^ ETOPO data set, resolution: 1 minutes |
+C | |
+C | Output: NST_sh: surface elevation |
+C | ^^^^^^^ NSTsol: land (4) / sea (1) mask |
+C | |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE ICEmsk
+
+ IMPLICIT NONE
+
+C +---Netcdf specifications
+C + ---------------------
+
+ INCLUDE 'NetCDF.inc'
+
+C +---NST variables
+C + -------------
+
+ INCLUDE 'NSTdim.inc'
+ INCLUDE 'NSTvar.inc'
+ INCLUDE 'NESTOR.inc'
+ INCLUDE 'LOCfil.inc'
+ INCLUDE 'MARvar.inc'
+
+C +---Local variables
+C + ---------------
+
+ INTEGER i,j,mlon,mlat,elat,midlon,mlon1,mlat1,
+ . nbchar,TOPOmx,TOPOmy
+
+ PARAMETER (mlon = 1440)
+ PARAMETER (mlat = 720)
+ PARAMETER (mlon1 =mlon+1)
+ PARAMETER (mlat1 =mlat+1)
+C +...Size of full ETOPO file
+
+ PARAMETER (elat = 360)
+ PARAMETER (TOPOmx= mlon)
+ PARAMETER (TOPOmy= elat)
+C +...Size of sub-domain (latitude only)
+
+ INTEGER DIMS(1),TOPO_ID,LAT_ID,LON_ID,sol,start(3),
+ . count(3),i1lon,i2lon,i1lat,i2lat,imlon,imlat,
+ . irien,ncid,Rcode
+
+ REAL*4 etopo(mlon,elat)
+
+ REAL*8 etopo_lon(mlon), etopo_lat(mlat)
+
+ REAL topo_lon(mlon),topo_lat(mlat),size_lon,
+ . TOPlon(TOPOmx),TOPlat(TOPOmy),size_lat,
+ . TOPsh(TOPOmx,TOPOmy),tmpTOP(TOPOmx,TOPOmy),
+ . tmp_in(0:TOPOmx+1,0:TOPOmy+1),MINlon,MINlat,
+ . MAXlon,MAXlat,AUXlon,AUXlat
+
+ LOGICAL Vtrue
+
+ CHARACTER*80 ETOPOfile
+
+C +---Data
+C + ----
+
+ DATA start / 1,1,1/
+ DATA Vtrue /.true./
+
+C +---Opening and reading of ICEmask data file
+C + ======================================
+
+ write(6,*) 'Topography : ICEmask data set (4 minutes)'
+ write(6,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+ write(6,*)
+
+C +---Open NetCDF file
+C + ----------------
+
+ nbchar=1
+
+ DO i=1,60
+ IF (ETOPO_dir(i:i).ne.' ') nbchar=i
+ ENDDO
+
+ ETOPOfile = 'input/ICEmask/ICEmask.nc'
+ ncid = NCOPN(ETOPOfile,NCNOWRIT,Rcode)
+
+C +---Find out the id of the variables
+C + --------------------------------
+
+ LON_ID =NCVID(ncid,'LON' ,Rcode)
+ LAT_ID =NCVID(ncid,'LAT' ,Rcode)
+ TOPO_ID=NCVID(ncid,'ICE',Rcode)
+
+C +---Read latitudes and longitudes of ETOPO
+C + --------------------------------------
+
+C +...! etopo_lon and _lat are real*8 !
+
+ start(1)=1
+ count(1)=mlon
+C + *****
+ CALL NCVGT(ncid,LON_ID,start,count,etopo_lon,Rcode)
+C + *****
+ DO i=1,mlon
+ topo_lon(i) = etopo_lon(i)-360.
+ END DO
+C +...topo_lon : from -180 to 180 deg.
+
+ start(1)=1
+ count(1)=mlat
+C + *****
+ CALL NCVGT(ncid,LAT_ID,start,count,etopo_lat,Rcode)
+C + *****
+ DO j=1,mlat
+ topo_lat(j) = etopo_lat(j)
+ END DO
+C +...topo_lat : from -90 to 90 deg.
+
+C +---Compute the extension of the sub-domain to be read
+C --------------------------------------------------
+
+ AUXlon = NST__x(1,1)
+ AUXlat = NST__y(1,1)
+C + ******
+ CALL SPHERC (Vtrue,AUXlon,AUXlat)
+C + ******
+ MINlon = AUXlon
+ MAXlon = AUXlon
+ MINlat = AUXlat
+ MAXlat = AUXlat
+ DO j=1,my
+ DO i=1,mx
+ AUXlon = NST__x(i,j)
+ AUXlat = NST__y(i,j)
+C + ******
+ CALL SPHERC (Vtrue,AUXlon,AUXlat)
+C + ******
+ MINlon = min(AUXlon,MINlon)
+ MAXlon = max(AUXlon,MAXlon)
+ MINlat = min(AUXlat,MINlat)
+ MAXlat = max(AUXlat,MAXlat)
+ ENDDO
+ ENDDO
+
+C +---Define extraction zone
+C + ----------------------
+
+C + ******
+ CALL SEARCH (topo_lon,mlon,MINlon,i1lon,irien)
+ CALL SEARCH (topo_lon,mlon,MAXlon,irien,i2lon)
+C + ******
+ imlon = i2lon - i1lon + 1
+C + ******
+ CALL SEARCH (topo_lat,mlat,MINlat,i1lat,irien)
+ CALL SEARCH (topo_lat,mlat,MAXlat,irien,i2lat)
+C + ******
+ imlat = i2lat - i1lat + 1
+
+ IF (imlat.ge.elat) THEN
+ write(*,*) 'Extent of the simulation domain in latitude'
+ write(*,*) 'is too large. Please choose a larger value '
+ write(*,*) 'for the elat parameter. - STOP '
+ STOP
+ ENDIF
+
+ i1lat = i1lat + (i2lat-i1lat)/2 - elat/2
+ i1lat = MAX(1,i1lat)
+ i2lat = i1lat + elat - 1
+ IF (i2lat.gt.mlat) THEN
+ i2lat= mlat
+ i1lat= i2lat - elat + 1
+ ENDIF
+
+C +---Read values of the variables for the sub-domain
+C + -----------------------------------------------
+
+ start(1)=1
+ start(2)=max(1,i1lat-1)
+ count(1)=mlon
+ count(2)=elat
+
+C + *****
+ CALL NCVGT(ncid,TOPO_ID,start,count,etopo,Rcode)
+C + *****
+
+ DO i=1,mlon
+ DO j=1,elat
+ TOPsh(i,j) = etopo(i,j)
+ END DO
+ END DO
+
+C + ******
+ CALL NCCLOS (ncid,Rcode)
+C + ******
+
+ DO i=1,TOPOmx
+ TOPlon(i)=topo_lon(i)
+ ENDDO
+
+ DO j=1,TOPOmy
+ TOPlat(j)=topo_lat(i1lat-1+j)
+ ENDDO
+
+C +---Interpolation of topography to the NST grid
+C + -------------------------------------------
+
+C + ******
+ CALL bilSim (TOPOmx,TOPOmy,TOPlon,TOPlat,TOPsh ,Vtrue ,
+ . mx ,my ,NST__x,NST__y,NSTice,tmp_in)
+C + ******
+
+C +---Distinction between land and sea (further refined)
+C + --------------------------------
+
+ DO j=1,my
+ DO i=1,mx
+
+ IF (NSTsol(i,j)<=2) THEN
+ NSTice(i,j)=0
+ ENDIF
+
+ ENDDO
+ ENDDO
+
+C +---Special topo for Greenland Simulation
+C + -------------------------------------
+
+ IF (region.eq."GRD") call USRgrd ('ETOPOg')
+
+ RETURN
+ END
diff --git a/MAR/code_nestor/src/INTERp.f b/MAR/code_nestor/src/INTERp.f
new file mode 100644
index 0000000000000000000000000000000000000000..b187cba020ec24721b691f7496940c72b1bf1e39
--- /dev/null
+++ b/MAR/code_nestor/src/INTERp.f
@@ -0,0 +1,768 @@
+C +-------------------------------------------------------------------+
+C | File contents: |
+C | intHor |
+C | bilSim |
+C | intLin |
+C | SPHERC |
+C | SEARCH |
+C | SPLINE, SPLINT (from Numerical Recipies) |
+C | dist (computes a distance between two lon,lat points) |
+C | Additional files complementing this one: |
+C | intBil.f (subroutines for bilinear interpolation) |
+C | intBic.f (subroutines for bicubic interpolation) |
+C | intMAR.f (subroutine for MAR on MAR forcing) |
+C +-------------------------------------------------------------------+
+
+C +-------------------------------------------------------------------+
+C | Subroutine intHor Dec. 95 NESTING |
+C | (Rev 2002 may) |
+C +-------------------------------------------------------------------+
+C | |
+C | Horizontal interpolation from LSC grid to NST grid distribute |
+C | tasks to bicubic, linear... routines according to the "intype" |
+C | variable (1=bilinear, 3=bicubic). |
+C | Note that this routine uses the dimensions specified in NSTdim.inc|
+C | The bilinear interpolation is able to treat cyclic domains, or |
+C | domains including the South/North pole. |
+C | |
+C | Input : intype : requested interpolation type |
+C | ^^^^^^^ grd_Ix (ni,nj) : input grid points position x(i,j) |
+C | grd_Iy (ni,nj) : input grid points position y(i,j) |
+C | var_I (ni,nj) : input field values |
+C | SPHgrd (T/F) : if true, spherical coordinates for |
+C | input fields |
+C | grd_Ox (mx,my) : output grid positions x(i,j) |
+C | grd_Oy (mx,my) : output grid positions y(i,j) |
+C | REGgrd (T/F) : if true, means the input grid is regular |
+C | |
+C | Output: var_O (mx,my) : output field values |
+C | ^^^^^^^ pos_Ox (mx,my) : retained posit.for non-regular grid(long)|
+C | pos_Oy (mx,my) : retained posit.for non-regular grid (lat)|
+C | |
+C | J.-F. Grailet note (27/04/2022): this routine now takes advantage |
+C | of the new intBil.f and intBic.f libraries to store interpolation |
+C | data at the first interpolation to speed up the subsequent ones. |
+C | |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE intHor (intype,grd_Ix,grd_Iy,var_I,
+ . SPHgrd,grd_Ox,grd_Oy,var_O,
+ . REGgrd,pos_Ox,pos_Oy)
+
+C +---LSC and NST domain dimensions
+C + -----------------------------
+
+ include 'NSTdim.inc'
+
+C +---Local variables
+C + ---------------
+
+ INTEGER intype,i,j
+
+ INTEGER pos_Ox(mx,my),pos_Oy(mx,my)
+
+ REAL grd_Ix(ni,nj),grd_Iy(ni,nj),var_I(ni,nj),
+ . grd_Ox(mx,my),grd_Oy(mx,my),var_O(mx,my)
+
+ LOGICAL SPHgrd,REGgrd
+
+C +---Temporary arrays
+C + ----------------
+
+ REAL tmp_I2a(ni,nj),tmp1in(ni,nj), ! tmp2in(0:ni+1,0:nj+1),
+ . grd1Ix(ni),grd1Iy(nj)
+
+C +---Logical to know if interpolation data has been buffered
+C + -------------------------------------------------------
+C + Addition made by J.-F. Grailet on 27/04/2022, based on the same
+C + mechanism as "lfirst" in MARvgd in the unmodified NESTOR.
+
+ LOGICAL ifirst
+ SAVE ifirst
+ DATA ifirst/.true./
+
+C +---Interpolation
+C + -------------
+
+ IF (REGgrd) THEN ! Regular input grid
+
+ DO i=1,ni
+ grd1Ix(i)=grd_Ix(i,1)
+ if(grd1Ix(i)>180) grd1Ix(i)=grd1Ix(i)-360.
+ ENDDO
+
+ DO j=1,nj
+ grd1Iy(j)=grd_Iy(1,j)
+ ENDDO
+
+ ! Bilinear interpolation
+ IF (intype.EQ.1) THEN
+
+ IF (ifirst) THEN
+ CALL bilSet(grd1Ix, grd1Iy, SPHgrd, grd_Ox, grd_Oy)
+ ifirst=.false.
+ ENDIF
+ CALL bilDo(grd1Ix, grd1Iy, var_I, SPHgrd, var_O)
+
+ ! Bicubic interpolation
+ ELSE IF (intype.EQ.3) THEN
+
+ IF (ifirst) THEN
+ CALL bicSet(grd1Ix, grd1Iy, grd_Ox, grd_Oy)
+ ifirst=.false.
+ ENDIF
+ CALL bicDo(grd1Ix, grd1Iy, var_I, grd_Ox, grd_Oy, var_O)
+
+ ENDIF
+
+ ! Non-regular input grid (MAR forced by MAR in practice)
+ ELSE
+
+ CALL intMAR (grd_Ix,grd_Iy,var_I,grd_Ox,grd_Oy,var_O,
+ . pos_Ox,pos_Oy)
+
+ ENDIF
+
+ RETURN
+ END
+
+C +-------------------------------------------------------------------+
+C | Subroutine bilSim 01-07-2004 NESTING |
+C +-------------------------------------------------------------------+
+C | |
+C | This routine is a bilinear interpolation of a 2D scalar fields. |
+C | If the output resolution is lower than input, an average of 5 |
+C | bilinear interpolations is performed, considering 5 sampling |
+C | points located around the selected point in the output mesh. |
+C | Note that a specific treatment of latitudes/longitudes is |
+C | included for input grids using spherical coordinates. |
+C | |
+C | J.-F. Grailet note (09/05/2022): the "sim" is for "simple" as |
+C | this specific routine is subtly different from calling |
+C | successively bilSet and bilDo. Moreover, it is meant to work with |
+C | varying dimensions in practice, hence why its parameters still |
+C | include them rather than including NSTdim.inc. In the original |
+C | code, this routine was called INTsimple and located in ETOPO1.f. |
+C | Since it's also called by the ICEmsk routine, it was moved here. |
+C | |
+C | It should be noted that this specific routine, beyond a few minor |
+C | changes (like the name), is untouched compared to the unmodified |
+C | NESTOR. This is because ETOPO1 and ICEmsk both only call it once, |
+C | at the very start of NESTOR, meaning no optimization is needed. |
+C | Moreover, in the original NESTOR, this routine is called by |
+C | ETOPO1 and ICEmsk even if the user selected bicubic interpolation |
+C | via the control file. |
+C | |
+C | Input : grd_Ix (ni) : Input grid points position x(i) |
+C | ^^^^^^^ grd_Iy (nj) : " " " " y(j) |
+C | var_I (ni, nj) : Input field values |
+C | grd_Ox (mx, my) : Output grid positions x(i,j) |
+C | grd_Oy (mx, my) : Output grid positions y(i,j) |
+C | SPHgrd (T/F) : If true, spherical coordinates for |
+C | input fields |
+C | |
+C | Output: var_O (mx, my) : Output field values |
+C | ^^^^^^^ |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE bilSim (ni,nj,grd_Ix,grd_Iy,var_I,SPHgrd,
+ . mx,my,grd_Ox,grd_Oy,var_O,tmp_in)
+
+ IMPLICIT NONE
+
+C +---General and local variables
+C + ---------------------------
+
+ INTEGER ns,i,j,ii,jj,p,q,is,ind0,ind1,nsamp,LocDim,
+ . ni,nj,mx,my,mmx,mmy,icent1,jcent1,icent2,jcent2
+
+ PARAMETER (ns = 5) ! Number of sampling points
+ PARAMETER (LocDim=21601) ! Dim. of local 1D arrays
+
+ REAL x,y,tmp,tmp2,x0,x1,y0,y1,epsi,AUXlon,MINlon,MAXlon,
+ . AUXlat,MINlat,MAXlat,dist_O,dist_I,AUXlo1,AUXlo2,
+ . AUXla1,AUXla2,dx,dy,degrad,ns2,tmp3
+
+ REAL grd_Ix(ni),grd_Iy(nj),grd_Ox(mx,my),grd_Oy(mx,my),
+ . tmp_in(0:ni+1,0:nj+1),tmp_Ix(0:LocDim+1),samOx(ns),
+ . samOy(ns),tmp_Iy(0:LocDim+1),var_I(ni,nj),var_O(mx,my)
+
+ ! JFG (09/05/2022): cyclic, npole and spole were only used for
+ ! display purposes (display instructions were commented).
+ LOGICAL SPHgrd ! ,cyclic,npole,spole
+
+C +---Data
+C + ----
+
+ DATA epsi / 1.d-4 /
+ DATA degrad / 1.745329252d-2 /
+
+C +---Check dimensions of temporary arrays
+C + ====================================
+
+ IF (ni.gt.LocDim .or. nj.gt.LocDim) THEN
+ WRITE(6,*) 'bilSim - fatal error: dimension',LocDim
+ WRITE(6,*) 'Please change LocDim - STOP'
+ STOP
+ ENDIF
+
+C +---Check if the sampling technique is required
+C + ===========================================
+
+ mmx = mx
+ mmy = my
+
+ dx =(grd_Ix(ni/2)-grd_Ix(ni/2-1))*111111.
+ . *COS(grd_Iy(nj/2)*degrad)
+ dy =(grd_Iy(nj/2)-grd_Iy(nj/2-1))*111111.
+ dist_I=max(dx,dy)
+
+ icent1=MAX(1,mx/2)
+ icent2=MAX(1,mx/2-1)
+ jcent1=MAX(1,my/2)
+ jcent2=MAX(1,my/2-1)
+ IF (mmx.eq.2) icent1=2
+ IF (mmy.eq.2) jcent1=2
+
+ AUXlo1=grd_Ox(icent1,jcent1)
+CWARNINGXla1=grd_Oy(icent1,icent1)
+ AUXla1=grd_Oy(icent1,jcent1)
+ AUXlo2=grd_Ox(icent2,jcent2)
+ AUXla2=grd_Oy(icent2,jcent2)
+
+C + ******
+ CALL SPHERC (SPHgrd,AUXlo1,AUXla1)
+ CALL SPHERC (SPHgrd,AUXlo2,AUXla2)
+C + ******
+
+ dx =(AUXlo1-AUXlo2)*111111.*COS(AUXla1*degrad)
+ IF (mmx.le.1) dx = 1000.
+ dy =(AUXla1-AUXla2)*111111.
+ IF (mmy.le.1) dy = 1000.
+ dist_O=max(dx,dy)
+
+ nsamp=1
+ ns2 = max(2.,(dist_O/dist_I))
+
+ if(ns2==1) then
+ print *,"WARNING: in bilSim dist_O < dist_I!!"
+ endif
+
+C +---Coordinates indexes inversion (if necessary)
+C + ============================================
+
+C +---Storage in temporary arrays
+C + ---------------------------
+
+ DO jj=1,nj
+ DO ii=1,ni
+ tmp_in(ii,jj)=var_I(ii,jj)
+ ENDDO
+ ENDDO
+
+ DO ii=1,ni
+ tmp_Ix(ii)=grd_Ix(ii)
+ ENDDO
+
+ DO jj=1,nj
+ tmp_Iy(jj)=grd_Iy(jj)
+ ENDDO
+
+C +---Revert grd_Ix (1) <--> grd_Ix (n), ... ?
+C + ----------------------------------------
+
+ IF (grd_Ix(ni).lt.grd_Ix(1)) THEN
+ DO ii=1,ni
+ DO jj=1,nj
+ tmp_in(ii,jj)=var_I(ni-ii+1, jj)
+ ENDDO
+ tmp_Ix(ii)=grd_Ix(ni-ii+1)
+ ENDDO
+ ENDIF
+
+C +---Revert grd_Iy (1) <--> grd_Iy (n), ... ?
+C + ----------------------------------------
+
+ IF (grd_Iy(nj).lt.grd_Iy(1)) THEN
+ DO jj=1,nj
+ DO ii=1,ni
+ tmp_in(ii,jj)=var_I(ii,nj-jj+1)
+ ENDDO
+ tmp_Iy(jj)=grd_Iy(nj-jj+1)
+ ENDDO
+ ENDIF
+
+C +---Extended coordinates in longitude and latitude
+C + ==============================================
+
+C +---Check validity of longitude
+C + ---------------------------
+
+ IF (SPHgrd) THEN
+ IF ((tmp_Ix(1).lt.(-180.)).or.(tmp_Ix(ni).gt.180.)) THEN
+ WRITE(6,*) 'Longitudes of data fields are not between'
+ WRITE(6,*) '-180 and +180 deg. (as required by bilSim)'
+ WRITE(6,*) 'but rather between : '
+ WRITE(6,*) tmp_Ix(1),tmp_Ix(ni)
+ WRITE(6,*) '--- STOP in bilSim ---'
+ STOP
+ ENDIF
+ ENDIF
+
+C +---Extended left/right boundaries (longitude if SPHgrd)
+C + ----------------------------------------------------
+
+ tmp_Ix(0) =2.*tmp_Ix( 1)-tmp_Ix(2)
+ tmp_Ix(ni+1)=2.*tmp_Ix(ni)-tmp_Ix(ni-1)
+
+C +---Extended bottom/top boundaries (latitude if SPHgrd)
+C + ---------------------------------------------------
+
+ tmp_Iy(0) =2.*tmp_Iy( 1)-tmp_Iy(2)
+ tmp_Iy(nj+1)=2.*tmp_Iy(nj)-tmp_Iy(nj-1)
+
+C +---Define the cyclic field in longitude
+C + ------------------------------------
+
+ IF (SPHgrd) THEN ! Stereographic coordinates
+
+ ind0=-1
+ ind1=-1
+
+ AUXlon=tmp_Ix(0)+360.
+ DO i=1,ni
+ IF (ABS(AUXlon-tmp_Ix(i)).lt.epsi) ind0=i
+ ENDDO
+
+ AUXlon=tmp_Ix(ni+1)-360.
+ DO i=1,ni
+ IF (ABS(AUXlon-tmp_Ix(i)).lt.epsi) ind1=i
+ ENDDO
+
+ ! .not.(ind0.gt.(-1).and.ind1.gt.(-1))
+ IF (ind0.lt.(0).or.ind1.lt.(0)) THEN
+ ! cyclic=.false.
+ ind0=ni
+ ind1= 1
+ ! ELSE
+ ! cyclic=.true.
+ ENDIF
+
+ IF (ABS(tmp_Ix(ni+1)-180.).lt.epsi) tmp_Ix(ni+1)=180.+epsi
+
+ ELSE ! Non spherical coordinates
+
+ ind0=ni
+ ind1= 1
+
+ ENDIF
+
+ DO j=1,nj
+ tmp_in( 0,j)=tmp_in(ind0,j)
+ tmp_in(ni+1,j)=tmp_in(ind1,j)
+ ENDDO
+
+C +---Define extra lower and upper boundaries (latitude)
+C + --------------------------------------------------
+
+ IF (SPHgrd) THEN ! Stereographic coordinates
+
+ IF (tmp_Iy(0).lt.(-90.))
+ . tmp_Iy(0)=MIN(-90.,tmp_Iy(1)-epsi)
+
+ IF (tmp_Iy(nj+1).gt.90.)
+ . tmp_Iy(nj+1)=MAX(90.,tmp_Iy(nj)+epsi)
+
+ !spole=.false.
+ !npole=.false.
+
+ !IF (tmp_Iy(0).le.(-90.)) spole=.true.
+ !IF (tmp_Iy(nj+1).ge.90.) npole=.true.
+
+ ENDIF
+
+ DO i=0,ni+1
+ tmp_in(i, 0)=tmp_in(i, 1)
+ tmp_in(i,nj+1)=tmp_in(i,nj)
+ ENDDO
+
+C +---Check the extension of the sub-domain to be read
+C ================================================
+
+ AUXlon = grd_Ox(1,1)
+ AUXlat = grd_Oy(1,1)
+C + ******
+ CALL SPHERC (SPHgrd,AUXlon,AUXlat)
+C + ******
+ MINlon = AUXlon
+ MAXlon = AUXlon
+ MINlat = AUXlat
+ MAXlat = AUXlat
+
+ DO j=1,my
+ DO i=1,mx
+ AUXlon = grd_Ox(i,j)
+ AUXlat = grd_Oy(i,j)
+C + ******
+ CALL SPHERC (SPHgrd,AUXlon,AUXlat)
+C + ******
+
+ MINlon = min(AUXlon,MINlon)
+ MAXlon = max(AUXlon,MAXlon)
+ MINlat = min(AUXlat,MINlat)
+ MAXlat = max(AUXlat,MAXlat)
+ ENDDO
+ ENDDO
+
+ IF ((tmp_Ix( 0).gt.MINlon) .or.
+ . (tmp_Ix(ni+1).lt.MAXlon) .or.
+ . (tmp_Iy( 0).gt.MINlat) .or.
+ . (tmp_Iy(nj+1).lt.MAXlat)) THEN
+ WRITE(6,*) 'Output domain is not (fully) included in'
+ WRITE(6,*) 'the input domain.'
+ WRITE(6,*) 'Input domain :'
+ WRITE(6,*) tmp_Ix(0),tmp_Ix(ni+1),tmp_Iy(0),tmp_Iy(nj+1)
+ WRITE(6,*) 'Output domain :'
+ WRITE(6,*) MINlon,MAXlon,MINlat,MAXlat
+ WRITE(6,*) '--- STOP in bilSim ---'
+ ENDIF
+
+C +---Bi-linear interpolation
+C + =======================
+
+C +---Some initialisations
+C + --------------------
+
+ p=0
+ q=0
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ DO i=1,mx ! LOOP on output grid-points : BEGIN
+ DO j=1,my
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+C +---Define sampling point positions
+C + -------------------------------
+
+ DO is=1,nsamp ! Boundaries : no sampling
+ samOx(is)=grd_Ox(i,j)
+ samOy(is)=grd_Oy(i,j)
+ ENDDO
+
+ tmp2=0.0 ! Initialisation of sum of sampled values
+
+ DO is=1,nsamp ! Loop on the sampling points: BEGIN
+
+ x=samOx(is)
+ y=samOy(is)
+
+C +---Check the range of latitude and longitude
+C + -----------------------------------------
+
+C + ******
+ CALL SPHERC (SPHgrd,x,y)
+C + ******
+
+C +---Search for the bottom-left corner of the surrounding mesh
+C + ---------------------------------------------------------
+
+C +...This simple method accounts for the fact that two successive
+C +...requests usually refer to neighbour points.
+
+C +---Search for dimension 1 value
+C + ----------------------------
+
+ IF (tmp_Ix(p).le.x) THEN ! Search upwards
+ DO WHILE (tmp_Ix(p+1).lt.x)
+ p=p+1
+ ENDDO
+ ELSE ! Search downwards
+ DO WHILE (tmp_Ix(p).gt.x)
+ p=p-1
+ ENDDO
+ ENDIF
+
+C +---Search for dimension 2 value
+C + ----------------------------
+
+ IF (tmp_Iy(q).le.y) THEN ! Search upwards
+ DO WHILE (tmp_Iy(q+1).lt.y)
+ q=q+1
+ ENDDO
+ ELSE ! Search downwards
+ DO WHILE (tmp_Iy(q).gt.y)
+ q=q-1
+ ENDDO
+ ENDIF
+
+C +---Check the validity of p/q indexes
+C + ---------------------------------
+
+ IF ((p.lt. 0).or.(q.lt. 0).or.
+ . (p.gt.(ni+1)).or.(q.gt.(nj+1))) THEN
+ WRITE (6,*) 'Inconsistency between input and output'
+ WRITE (6,*) 'domains.'
+ WRITE (6,*) 'p and q = ',p,q
+ WRITE (6,*) '--- STOP in intSim ---'
+ STOP
+ ENDIF
+
+C +---Linear interpolation
+C + --------------------
+
+ tmp2=0 ; tmp3=0
+
+ do ii=nint(-1*ns2/2.),nint(ns2/2.)
+ do jj=nint(-1*ns2/2.),nint(ns2/2.)
+
+ x0=min(ni,max(1,p+ii))
+ y0=min(nj,max(1,q+jj))
+
+ tmp = 1.
+ !if(max(abs(ii),abs(jj))>= ns2/2.) tmp = 2/3.
+
+ tmp2 = tmp2 + tmp_in(x0,y0) * tmp
+ tmp3 = tmp3 + tmp
+ enddo
+ enddo
+
+ ENDDO ! LOOP on the sampling points: END
+
+C +---Output value given by the average of the samplings
+C + --------------------------------------------------
+
+ var_O(i,j)=tmp2/tmp3
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ ENDDO
+ ENDDO ! Loop on output grid-points : END
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ ! IF (cyclic) WRITE(6,*) 'bilSim info: cyclic boundaries'
+ ! IF (npole ) WRITE(6,*) 'bilSim info: North pole included'
+ ! IF (spole ) WRITE(6,*) 'bilSim info: South pole included'
+
+ RETURN
+ END
+
+C +--------------------------------------------------------------+
+ SUBROUTINE intLin (xx,vv,ni,xreq,outvar) ! Last modif. : 04/99
+C +--------------------------------------------------------------+
+
+ REAL xx(ni), vv(ni)
+ REAL xreq, outvar, fdis
+ INTEGER ind, KLO, KHI,ni,k
+
+ KLO=1
+ KHI=ni
+ 1 IF (KHI-KLO.GT.1) THEN
+ K=(KHI+KLO)/2
+ IF(xx(K).GT.xreq)THEN
+ KHI=K
+ ELSE
+ KLO=K
+ ENDIF
+ GOTO 1
+ ENDIF
+ ind=KLO
+
+ fdis = xx(ind+1)-xx(ind)
+ outvar= vv(ind)*((xx(ind+1)-xreq)/fdis)
+ . + vv(ind+1)*((xreq-xx(ind ))/fdis)
+
+ IF (xreq.LT.xx(ind )) outvar=vv(ind )
+ IF (xreq.GT.xx(ind+1)) outvar=vv(ind+1)
+
+ RETURN
+ END
+
+C +-------------------------------------------------------------------+
+C | Subroutine SPHERC July 99 NESTING |
+C +-------------------------------------------------------------------+
+C | |
+C | This routine sets longitude between -180 and +180, and latitude |
+C | between -90 and +90, as required by some interpolation sub- |
+C | routines. |
+C | |
+C | Input : SPHgrd : If true, LONval and LATval really are spherical |
+C | ^^^^^^^ coordinates |
+C | LONval : longitude (degree) |
+C | LATval : latitude (degree) |
+C | |
+C | Output: LONval : longitude (degree) |
+C | ^^^^^^^ LATval : latitude (degree) |
+C | |
+C | J.-F. Grailet remark (03/05/2022): SPHERC subroutine is also |
+C | called outside interpolation operations from time to time. |
+C | |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE SPHERC (SPHgrd,LONval,LATval)
+
+ IMPLICIT NONE
+
+ REAL LONval,LATval
+ LOGICAL SPHgrd
+
+ IF (SPHgrd) THEN
+
+C +---Longitude defined between -180 and +180 degree
+C + ----------------------------------------------
+
+ IF (LONval.ge. 180. ) LONval=LONval-360.
+ IF (LONval.lt.(-180.)) LONval=LONval+360.
+
+C +---Latitude defined between -90 and +90 degree
+C + -------------------------------------------
+
+ IF (LATval.gt. 90.1 ) LATval=LATval-180.
+ IF (LATval.lt. (-90.1)) LATval=LATval+180.
+
+ ENDIF
+
+ RETURN
+ END
+
+C +-------------------------------------------------------------------+
+C | Subroutine SEARCH June 03 NESTING ? |
+C +-------------------------------------------------------------------+
+C | |
+C | J.-F. Grailet remark (09/05/2022): this routine was originally |
+C | in ETOPOg.f in older NESTOR versions, but given that it's called |
+C | by routines that also call bilSim, it was moved here. |
+C | |
+C | This routine was originally not documented, but given that it was |
+C | declared in the (now deprecated) ETOPOg.f source file, it may |
+C | have been written roughly around the same time or before (2003). |
+C | |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE SEARCH (xx,ni,xreq,KLO,KHI)
+
+ REAL xx(ni)
+
+ KLO=1
+ KHI=ni
+ 1 IF (KHI-KLO.GT.1) THEN
+ K=(KHI+KLO)/2
+ IF(xx(K).GT.xreq)THEN
+ KHI=K
+ ELSE
+ KLO=K
+ ENDIF
+ GOTO 1
+ ENDIF
+
+ RETURN
+ END
+
+C +--------------------------------------------------------------+
+C | * From numerical recipes (H. Press et al., 1992) |
+C +--------------------------------------------------------------+
+
+ SUBROUTINE SPLINE(X,Y,N,YP1,YPN,Y2)
+
+ PARAMETER (NMAX=500)
+ DIMENSION X(N),Y(N),Y2(N),U(NMAX)
+
+ IF (YP1.GT..99E30) THEN
+ Y2(1)=0.
+ U(1)=0.
+ ELSE
+ Y2(1)=-0.5
+ U(1)=(3./(X(2)-X(1)))*((Y(2)-Y(1))/(X(2)-X(1))-YP1)
+ ENDIF
+ DO 11 I=2,N-1
+ SIG=(X(I)-X(I-1))/(X(I+1)-X(I-1))
+ P=SIG*Y2(I-1)+2.
+ Y2(I)=(SIG-1.)/P
+ U(I)=(6.*((Y(I+1)-Y(I))/(X(I+1)-X(I))-(Y(I)-Y(I-1))
+ * /(X(I)-X(I-1)))/(X(I+1)-X(I-1))-SIG*U(I-1))/P
+11 CONTINUE
+ IF (YPN.GT..99E30) THEN
+ QN=0.
+ UN=0.
+ ELSE
+ QN=0.5
+ UN=(3./(X(N)-X(N-1)))*(YPN-(Y(N)-Y(N-1))/(X(N)-X(N-1)))
+ ENDIF
+ Y2(N)=(UN-QN*U(N-1))/(QN*Y2(N-1)+1.)
+ DO 12 K=N-1,1,-1
+ Y2(K)=Y2(K)*Y2(K+1)+U(K)
+12 CONTINUE
+ RETURN
+ END
+
+C +--------------------------------------------------------------+
+C | * From numerical recipes (H. Press et al., 1992) |
+C +--------------------------------------------------------------+
+
+ SUBROUTINE SPLINT(XA,YA,Y2A,N,X,Y)
+
+ DIMENSION XA(N),YA(N),Y2A(N)
+ KLO=1
+ KHI=N
+1 IF (KHI-KLO.GT.1) THEN
+ K=(KHI+KLO)/2
+ IF(XA(K).GT.X)THEN
+ KHI=K
+ ELSE
+ KLO=K
+ ENDIF
+ GOTO 1
+ ENDIF
+ H=XA(KHI)-XA(KLO)
+ IF (H.EQ.0.) PAUSE 'Bad XA input.'
+
+ A=(XA(KHI)-X)/H
+ B=(X-XA(KLO))/H
+ Y=A*YA(KLO)+B*YA(KHI)+
+ * ((A**3-A)*Y2A(KLO)+(B**3-B)*Y2A(KHI))*(H**2)/6.
+
+ RETURN
+ END
+
+C +-------------------------------------------------------------------+
+C | Function dist 31/08/2004 NESTING ? |
+C +-------------------------------------------------------------------+
+C | |
+C | J.-F. Grailet remark (09/05/2022): this function was originally |
+C | not documented, but given that it was declared in the original |
+C | INTnrg2.f source file (in practical equivalent to this file), it |
+C | may have been written roughly around the same time or before |
+C | (2004). The name and purpose are self-explanatory. |
+C | |
+C | The function was moved here rather than staying in intMAR.f since |
+C | it use is now a bit more general: it is now called by both intMar |
+C | and bicSet (new bicubic interpolation subroutine). |
+C | |
+C +-------------------------------------------------------------------+
+
+ function dist(lon2o,lat2o,lon1o,lat1o)
+
+ implicit none
+ real,parameter :: pi = 3.141592
+ real,parameter :: R = 6371.
+
+ real :: lon1,lat1
+ real :: lon2,lat2
+ real :: dlat,dlon,a,c,dist
+ real :: lon2o,lat2o,lon1o,lat1o
+
+ lon1=lon1o * Pi/180.
+ lon2=lon2o * Pi/180.
+ lat1=lat1o * Pi/180.
+ lat2=lat2o * Pi/180.
+
+ dlat = (lat2-lat1)
+ dlon = (lon2-lon1)
+ a = sin(dLat/2.) * sin(dLat/2.) + cos(lat1) * cos(lat2)
+ . * sin(dLon/2.) * sin(dLon/2.)
+ c = 2. * atan2(sqrt(a), sqrt(1.-a))
+ dist = R * c
+
+ end function
diff --git a/MAR/code_nestor/src/INTmsk.f b/MAR/code_nestor/src/INTmsk.f
new file mode 100644
index 0000000000000000000000000000000000000000..46de031f612de2182fad4efb065539d939e4562e
--- /dev/null
+++ b/MAR/code_nestor/src/INTmsk.f
@@ -0,0 +1,120 @@
+C +-------------------------------------------------------------------+
+C | Subroutine INTmsk 01-07-2004 NESTING |
+C +-------------------------------------------------------------------+
+C | |
+C | Extrapolation of sea large-scale data to land to reduce the |
+C | problem of the fjord.
+C | |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE INTmsk(var1)
+
+
+ IMPLICIT NONE
+
+C +---Include files
+C + -------------
+
+ include "NSTdim.inc"
+
+C +---Local variables
+C + ---------------
+
+ integer i,j,k,l,tt
+ real var1(ni,nj),var2(ni,nj)
+ real nbr,valmax
+
+C +---Variable max value
+C + -------------------
+
+ valmax=1e20
+
+C +---Extrapolation to land
+C + ---------------------
+
+ do i=1,ni
+ do j=1,nj
+ var2(i,j)=var1(i,j)
+ enddo
+ enddo
+
+ do i=2,ni-1
+ do j=2,nj-1
+
+ nbr=0.
+
+ if(abs(var1(i,j)).ge.valmax) then
+
+ do k=-1,1,1
+ do l=-1,1,1
+ if(abs(var1(i+k,j+l)).le.valmax) then
+ if(abs(var2(i,j)).ge.valmax) var2(i,j)=0.0
+ var2(i,j)=var2(i,j)+var1(i+k,j+l)
+ nbr=nbr+1
+ endif
+ enddo
+ enddo
+
+ var2(i,j)=var2(i,j)/max(1.,nbr)
+ endif
+
+ enddo
+ enddo
+
+
+ do i=1,ni
+ do j=1,nj
+ var1(i,j)=var2(i,j)
+ enddo
+ enddo
+
+
+ do tt=1,5
+
+ do i=1,ni
+ do j=1,nj
+ var2(i,j)=var1(i,j)
+ enddo
+ enddo
+
+ do i=2,ni-1
+ do j=2,nj-1
+
+ nbr=0.
+
+ if(abs(var1(i,j)).ge.valmax) then
+
+ do k=-1,1,1
+ do l=-1,1,1
+ if(abs(var2(i+k,j+l)).le.valmax) then
+ if(k.ne.0.or.l.ne.0) then
+ if(abs(var1(i,j)).ge.valmax) var1(i,j)=0.0
+ var1(i,j)=var1(i,j)+var2(i+k,j+l)
+ nbr=nbr+1
+ endif
+ endif
+ enddo
+ enddo
+
+ var1(i,j)=var1(i,j)/max(1.,nbr)
+
+ endif
+
+ enddo
+ enddo
+
+ enddo
+
+ do i=1,ni
+ if(abs(var1(i,1)) .ge.valmax) var1(i,1) =var1(i,2)
+ if(abs(var1(i,nj)).ge.valmax) var1(i,nj)=var1(i,nj-1)
+ enddo
+
+ do j=1,nj
+ if(abs(var1(1,j)) .ge.valmax) var1(1,j) =var1(2,j)
+ if(abs(var1(ni,j)).ge.valmax) var1(ni,j)=var1(ni-1,j)
+ enddo
+
+ END
+
+
diff --git a/MAR/code_nestor/src/INTvar.inc b/MAR/code_nestor/src/INTvar.inc
new file mode 100644
index 0000000000000000000000000000000000000000..d24c57d3f72b565999013c8313d7fd831102b505
--- /dev/null
+++ b/MAR/code_nestor/src/INTvar.inc
@@ -0,0 +1,56 @@
+
+C +---2-D surface variables
+C + ---------------------
+
+ REAL INT_st(mx,my),INTdst(mx,my),INT_sw(mx,my),
+ . INTdsw(mx,my),INT_sp(mx,my),INT_dt(mx,my),
+ . INT_sh(mx,my),INT_pr(mx,my),INT_sn(mx,my),
+ . INTsol(mx,my),INTtcc(mx,my),INTuts(mx,my),
+ . INTsic(mx,my),INTsst(mx,my)
+
+C +...INT_st : soil or sea surface temperature
+C +...INTdst : deep soil temperature
+C +...INT_sw : soil wetness
+C +...INTdsw : deep soil wetness
+C +...INT_sp : surface pressure
+C +...INT_dt : temperature diff. between 1st lev and surf.
+C +...INT_sh : surface elevation
+C +...INT_pr : rain precipitation
+C +...INT_sn : snow precipitation
+C +...INTsol : soil types (water,ice,snow,land,...)
+C +...INTtcc : total cloud cover
+C +...INTuts : surface heat flux
+C +...INTsic : Sea-Ice Fraction
+C +...INTsic : Sea Surface Temperature
+
+C +---3-D atmospheric variables
+C + -------------------------
+
+ REAL INT__u(mx,my,nk+1),INT_pt(mx,my,nk+1),INT__p(mx,my,nk+1),
+ . INT__v(mx,my,nk+1),INT_qv(mx,my,nk+1),INTtke(mx,my,nk+1),
+ . INT_qt(mx,my,nk+1),INT_rh(mx,my,nk+1)
+
+C +...INT__u : U-wind
+C +...INT__v : V-wind
+C +...INT_pt : potential temperature
+C +...INT_qv : specific humidity
+C +...INT_rh : relative humidity
+C +...INT__p : pressure
+C +...INTtke : turbulent kinetic energy
+C +...INT_qt : total cloud water content
+
+
+C +---Temporary arrays
+C + ----------------
+
+ REAL INT1Dz(nk+1),INT1Dp(nk+1),INT1Du(nk+1),INT1Dv(nk+1),
+ . INT1Dt(nk+1),INT1Dq(nk+1),INT1De(nk+1),INT1Dh(nk+1),
+ . INT1zz(mx,my,nk+1)
+
+
+ common/INTvar_r/INT_st,INTdst,INT_sw,INTdsw,INT_sp,INT_dt,
+ . INT_sh,INT_pr,INT_sn,INTsol,INTtcc,INTuts,
+ . INT__u,INT_pt,INT__p,INT__v,INT_qv,INTtke,
+ . INT_qt,INTsic,INT_rh
+
+
diff --git a/MAR/code_nestor/src/LOCfil.inc b/MAR/code_nestor/src/LOCfil.inc
new file mode 100644
index 0000000000000000000000000000000000000000..d990d8502341413c0414a643df528bc4eddf9524
--- /dev/null
+++ b/MAR/code_nestor/src/LOCfil.inc
@@ -0,0 +1,17 @@
+!-Files locations
+! ===============
+
+ CHARACTER*60 ETOPO_dir ,FAO_dir ,BELveg_dir, &
+ & AFRveg_dir,EURveg_dir,NAMveg_dir,SAMveg_dir, &
+ & AFRndv_dir,EURndv_dir,NAMndv_dir,SAMndv_dir, &
+ & AFRndv8dir,EURndv8dir,NAMndv8dir,SAMndv8dir, &
+ & CORveg_dir,BTOPO_dir,PFXdir
+
+ INTEGER PFXsiz
+
+ common /LOCfil/ &
+ & ETOPO_dir ,FAO_dir ,BELveg_dir, &
+ & AFRveg_dir,EURveg_dir,NAMveg_dir,SAMveg_dir, &
+ & AFRndv_dir,EURndv_dir,NAMndv_dir,SAMndv_dir, &
+ & AFRndv8dir,EURndv8dir,NAMndv8dir,SAMndv8dir, &
+ & CORveg_dir,BTOPO_dir,PFXdir,PFXsiz
diff --git a/MAR/code_nestor/src/LOCset.inc b/MAR/code_nestor/src/LOCset.inc
new file mode 100644
index 0000000000000000000000000000000000000000..14a09ffd9a6c25a810f68dfb4f2a70a414da0d0d
--- /dev/null
+++ b/MAR/code_nestor/src/LOCset.inc
@@ -0,0 +1,73 @@
+C +---Prefix for all directories (e.g. your work directory)
+C + -----------------------------------------------------
+
+ PFXdir = './input/'
+
+ PFXsiz = VARSIZE(PFXdir)
+
+
+C +---ETOPO topography - 5 minutes (Netcdf file)
+C + ------------------------------------------
+
+ ETOPO_dir = PFXdir(1:PFXsiz)//'ETOPO/'
+
+
+C +---BTOPO topography - 30-m resol. over Belgium
+C + -------------------------------------------
+
+ BTOPO_dir = PFXdir(1:PFXsiz)//'BTOPO/'
+
+
+C +---FAO SOIL TYPES (Ascii and Netcdf files)
+C + ---------------------------------------
+
+ FAO_dir = PFXdir(1:PFXsiz)//'FAO/'
+
+
+C +---VEGETATION - IGBP Classification
+C + --------------------------------
+
+C +...AFRICA
+ AFRveg_dir = PFXdir(1:PFXsiz)//'VEGE/'
+C +...EUROPE
+ EURveg_dir = PFXdir(1:PFXsiz)//'VEGE/'
+C +...BELGIUM
+ BELveg_dir = PFXdir(1:PFXsiz)//'VEGE/'
+C +...NORTH AMERICA
+ NAMveg_dir = PFXdir(1:PFXsiz)//'VEGE/'
+C +...SOUTH AMERICA
+ SAMveg_dir = PFXdir(1:PFXsiz)//'VEGE/'
+
+
+C +---VEGETATION - CORINE Classification - EUROPE
+C + -------------------------------------------
+
+ CORveg_dir = PFXdir(1:PFXsiz)//'CORINE/'
+
+
+C +---VEGETATION - 1-km NDVI index (April 1992 to March 1993)
+C + -------------------------------------------------------
+
+C +...AFRICA
+ AFRndv_dir = PFXdir(1:PFXsiz)//'NDVI01/'
+C +...EUROPE
+ EURndv_dir = PFXdir(1:PFXsiz)//'NDVI01/'
+C +...NORTH AMERICA
+ NAMndv_dir = PFXdir(1:PFXsiz)//'NDVI01/'
+C +...SOUTH AMERICA
+ SAMndv_dir = PFXdir(1:PFXsiz)//'NDVI01/'
+
+
+C +---VEGETATION - 8-km NDVI index (??? to ???)
+C + -----------------------------------------
+
+C +...AFRICA
+ AFRndv8dir = PFXdir(1:PFXsiz)//'NDVI08/'
+C +...EUROPE
+ EURndv8dir = PFXdir(1:PFXsiz)//'NDVI08/'
+C +...NORTH AMERICA
+ NAMndv8dir = PFXdir(1:PFXsiz)//'NDVI08/'
+C +...SOUTH AMERICA
+ SAMndv8dir = PFXdir(1:PFXsiz)//'NDVI08/'
+
+
diff --git a/MAR/code_nestor/src/LSCinp.f b/MAR/code_nestor/src/LSCinp.f
new file mode 100644
index 0000000000000000000000000000000000000000..10c4a9ec9035d7bd13d023674c13d5f0801334f0
--- /dev/null
+++ b/MAR/code_nestor/src/LSCinp.f
@@ -0,0 +1,214 @@
+C +-------------------------------------------------------------------+
+C | Subroutine LSCinp April 2001 NESTING |
+C +-------------------------------------------------------------------+
+C | |
+C | Input : - DATtim : date given in hours from beginning of the year |
+C | ^^^^^^^ - LSCmod : LSC model used for init. and forcing fields |
+C | |
+C | Output: - LSCfil : file to be read for the fields at DATtim |
+C | ^^^^^^^ - I_time : time corresponding to DATtim in LSCfil |
+C | |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE LSCinp
+
+
+ IMPLICIT NONE
+
+
+C +---General variables
+C + -----------------
+
+ INCLUDE 'NetCDF.inc'
+ INCLUDE 'NSTdim.inc'
+ INCLUDE 'LSCvar.inc'
+ INCLUDE 'NESTOR.inc'
+
+C +---Local variables
+C + ---------------
+
+ INTEGER nfile,maxfile
+ PARAMETER (maxfile=200)
+
+ INTEGER i,itR,Ierro,FILEid,
+ . DATiyr,DATmma,DATjda,DATjhu
+
+ REAL Cdate,Rdate,Fdate,yyyy,mm,dd,hh,yyyyp,mmp,ddp,hhp
+
+ CHARACTER*200 LSCfln(maxfile),LSCtitle,xline
+
+ CHARACTER*10 var_units
+
+ LOGICAL Vtrue,Vfalse
+
+ common/date_LSPinp/yyyyp,mmp,ddp,hhp
+
+
+C +---Local data
+C + ----------
+
+ DATA Vtrue / .true. /
+ DATA Vfalse / .false. /
+
+ DATA yyyyp /0./
+ DATA mmp /0./
+ DATA ddp /0./
+ DATA hhp /0./
+
+
+C +---Requested date
+C + --------------
+
+C + ******
+ CALL DATcnv (DATiyr,DATmma,DATjda,DATjhu,DATtim,Vfalse)
+C + ******
+
+ Cdate = (DATmma*100 + DATjda) *100 + DATjhu
+
+ ! JFG (02/05/2022): added "vrbose" check (new verbose mode)
+ IF (vrbose) THEN
+ WRITE(6,*) 'Date'
+ WRITE(6,*) '~~~~'
+ ENDIF
+ WRITE(6,1000) DATiyr,DATmma,DATjda,DATjhu
+1000 FORMAT('Processing (yyyy, mm, dd, hh): ',i5,',',i3,',',i3,',',i3)
+ IF (vrbose) THEN
+ WRITE(6,*)
+ ENDIF
+
+
+C +---Input file names
+C + ----------------
+
+ OPEN (unit=52,status='old',file='LSCfil.dat')
+ i = 0
+
+210 CONTINUE
+ READ (52,'(a100)',END=230) xline
+ IF (xline.eq.'') GOTO 210
+ IF (xline(1:1).eq.' ') THEN
+ ! No "vrbose" check: this is useful to understand the stop.
+ write(6,*) 'Blank characters in LSCfil.dat. Please remove'
+ write(6,*) 'them and restart NESTOR.'
+ write(6,*) 'STOP in LSCinp.f'
+ STOP
+ ENDIF
+ i = i + 1
+ LSCfln(i) = xline
+ GOTO 210
+
+230 CONTINUE
+ CLOSE(unit=52)
+
+ nfile = i
+
+ IF (nfile.gt.maxfile) THEN
+ ! No "vrbose" check: this is useful to understand the stop.
+ write(6,*) 'Increase maxfile in LSCinp.f '
+ write(6,*) 'Error - STOP '
+ STOP
+ ENDIF
+
+
+C +---Search the LSC file for the requested date
+C + ------------------------------------------
+
+ I_time = -1
+
+ DO i=1,nfile
+
+C + *******
+ CALL UNropen (LSCfln(i),FILEid,LSCtitle)
+C + *******
+ CALL UNgindx (FILEid,'date',Cdate,Rdate,Fdate,itR)
+C + *******
+
+ if(LSCmod.eq."MAR".and.Cdate.eq.123118.and.Rdate.eq.10100)then
+ Rdate=123118
+ itR = itR-1
+ endif
+
+ if(LSCmod.eq."MAR".and.Cdate.eq.10100.and.
+ . mmp==12.and.ddp>=30.and.hhp==18)then
+ Cdate=123118
+ CALL UNgindx (FILEid,'date',Cdate,Rdate,Fdate,itR)
+ Cdate=10100
+ endif
+
+ IF (ABS(Rdate-Cdate).LE.0.5) THEN
+ LSCfil = LSCfln(i)
+ I_time = itR
+ ENDIF
+
+C + ******
+ CALL NCCLOS (FILEid,Ierro)
+C + ******
+
+ ENDDO
+
+C +---Case of no data file found
+C + --------------------------
+
+ IF (I_time.eq.(-1)) THEN
+
+ ! No "vrbose" check: this is useful to understand the stop.
+ write(6,*) 'No LSC data file found for the following date :'
+ write(6,*) DATiyr,DATmma,DATjda,DATjhu
+ write(6,*)
+ write(6,*) ' --- STOP in LSCinp --- '
+ write(6,*)
+
+ STOP
+
+ ELSE
+
+ CALL UNropen (LSCfil,FILEid,LSCtitle)
+
+ IF (LSCmod.eq.'MAR') then
+
+ CALL UNsread (FILEid,'year',I_time,1,
+ & I_time,I_time,1,1,1,var_units,yyyy)
+
+ CALL UNsread (FILEid,'date',I_time,1,
+ & I_time,I_time,1,1,1,var_units,HH)
+
+ MM=int(HH/10000)
+ DD=int((HH-MM*10000)/100)
+ HH=int(HH-MM*10000-DD*100)
+
+ ELSE
+
+
+ CALL UNsread (FILEid,'YEAR',I_time,1,
+ & I_time,I_time,1,1,1,var_units,yyyy)
+
+ CALL UNsread (FILEid,'MONTH',I_time,1,
+ & I_time,I_time,1,1,1,var_units,MM)
+
+ CALL UNsread (FILEid,'DAY',I_time,1,
+ & I_time,I_time,1,1,1,var_units,DD)
+
+ CALL UNsread (FILEid,'HOUR',I_time,1,
+ & I_time,I_time,1,1,1,var_units,HH)
+
+ CALL NCCLOS (FILEid,Ierro)
+
+ endif
+
+ IF (vrbose) THEN
+ write(6,'(a14,i5,3i3,a14,i3,a9,a30)') " LSCfile date:",
+ & int(yyyy),int(MM),int(DD),int(HH),
+ & " - time step:", I_time,
+ & " - file: ",trim(LSCfil)
+ write(6,*)
+ ENDIF
+
+ yyyyp=yyyy ; mmp=mm ; ddp=dd ; hhp=hh
+
+ ENDIF
+
+
+ RETURN
+ END
+
+
diff --git a/MAR/code_nestor/src/LSCmod.inc b/MAR/code_nestor/src/LSCmod.inc
new file mode 100644
index 0000000000000000000000000000000000000000..becab137af5173b797430a10104ecc66993efb53
--- /dev/null
+++ b/MAR/code_nestor/src/LSCmod.inc
@@ -0,0 +1,2 @@
+ LOGICAL M30d,f28d
+ COMMON /LSCmod/ M30d,f28d
diff --git a/MAR/code_nestor/src/LSCvar.inc b/MAR/code_nestor/src/LSCvar.inc
new file mode 100644
index 0000000000000000000000000000000000000000..5d364970c543d99e9d9b6764d77bc81115dbedb8
--- /dev/null
+++ b/MAR/code_nestor/src/LSCvar.inc
@@ -0,0 +1,87 @@
+
+!-Input model
+! -----------
+
+ CHARACTER*3 LSCmod
+ LOGICAL SPHgrd,REGgrd
+
+! ....LSCmod : acronym of the large-scale model
+! ....SPHgrd : stereographic grid
+! ....REGgrd : regular grid (in latitude and longitude)
+
+
+!-Horizontal and vertical grid
+! ----------------------------
+
+ REAL LSC1Dx(ni ),LSC1Dy( nj),LSC__z(nk), &
+ & LSC__x(ni,nj),LSC__y(ni,nj), &
+ & LSC_zz(ni,nj,nk+1)
+
+! ....LSC__x : X-coordinates
+! ....LSC1Dx : X-coordinates (for regular input grid)
+! ....LSC__y : Y-coordinates
+! ....LSC1Dy : Y-coordinates (for regular input grid)
+! ....LSC__z : Z-coordinates (hybrid) as a vector
+! ....LSC_zz : Z-coordinates (hybrid) for a 2D grid
+
+
+!-2-D surface variables
+! ---------------------
+
+ REAL LSC_st(ni,nj),LSCdst(ni,nj),LSC_sw(ni,nj), &
+ & LSCdsw(ni,nj),LSC_sp(ni,nj),LSC_dt(ni,nj), &
+ & LSC_sh(ni,nj),LSC_pr(ni,nj),LSCppr(ni,nj), &
+ & LSC_sn(ni,nj),LSCtcc(ni,nj),LSCuts(ni,nj), &
+ & LSCsic(ni,nj),LSCsst(ni,nj),LSClsm(ni,nj)
+
+! ....LSC_st : soil or sea surface temperature
+! ....LSCdst : deep soil temperature
+! ....LSC_sw : soil wetness
+! ....LSCdsw : deep soil wetness
+! ....LSC_sp : surface pressure
+! ....LSC_dt : temperature diff. between 1st lev. and surf.
+! ....LSC_sh : surface elevation
+! ....LSC_pr : rain precipitation at the current time step
+! ....LSCppr : rain precipitation at the previous time step
+! ....LSC_sn : snow precipitation
+! ....LSCtcc : total cloud cover
+! ....LSCuts : surface heat flux
+! ....LSCsic : Sea Ice Fraction
+! ....LSCsst : Sea Surface Temperature
+! ....LSClsm : Land Sea Mask
+
+
+!-3-D atmospheric variables (storred on 1 level = 2D)
+! -------------------------
+
+ REAL LSC__p(ni,nj),LSC_pp(ni,nj,nk+1), &
+ & LSC__u(ni,nj),LSC__v(ni,nj),LSC__w(ni,nj), &
+ & LSC_pt(ni,nj),LSC__t(ni,nj),LSC_qv(ni,nj), &
+ & LSCtke(ni,nj),LSC_qt(ni,nj),LSCtmp(ni,nj), &
+ & LSCtm2(ni,nj),LSC_rh(ni,nj)
+
+! ....LSC__p : pressure for a 2D grid
+! ....LSC_pp : pressure by level for a 2D grid
+! ....LSC__u : U-wind
+! ....LSC__v : V-wind
+! ....LSC__w : W-wind
+! ....LSC_pt : potential temperature
+! ....LSC__t : real temperature
+! ....LSC_qv : specific humidity
+! ....LSCtke : turbulent kinetic energy
+! ....LSC_qt : total cloud water
+! ....LSCtmp : temporary array
+! ....LSCtm2 : temporary array
+
+
+ COMMON/LSCvar_c/LSCmod
+
+ COMMON/LSCvar_l/SPHgrd,REGgrd
+
+ COMMON/LSCvar_r/LSC1Dx,LSC1Dy,LSC__z,LSC__x,LSC__y,LSC_st, &
+ & LSCdst,LSC_sw,LSCdsw,LSC_sp,LSC_dt,LSC_sh, &
+ & LSC_pr,LSCppr,LSC_sn,LSCtcc,LSCuts,LSC__p, &
+ & LSC__u,LSC__v,LSC__w,LSC_pt,LSC__t,LSC_qv, &
+ & LSCtke,LSC_qt,LSCtmp,LSCtm2,LSCsic,LSCsst, &
+ & LSC_rh,LSClsm
+
diff --git a/MAR/code_nestor/src/LSCvgd.f b/MAR/code_nestor/src/LSCvgd.f
new file mode 100644
index 0000000000000000000000000000000000000000..21857a53aba23d8dae2717fae992a37c8d2be36a
--- /dev/null
+++ b/MAR/code_nestor/src/LSCvgd.f
@@ -0,0 +1,93 @@
+C +-------------------------------------------------------------------+
+C | Subroutine LSCvgd 12-04-2022 JFG |
+C +-------------------------------------------------------------------+
+C | |
+C | Creation of a vertical grid for a given LSC model. |
+C | |
+C | Input : - LSCmod : selected LSC model |
+C | ^^^^^^^ - fID : identificator of the Netcdf data file |
+C | - nk : number of vertical levels |
+C | - baseI : minimum X index of the relevant LSC sub-region |
+C | - baseJ : minimum Y index of the relevant LSC sub-region |
+C | - maxI : maximum X index of the relevant LSC sub-region |
+C | - maxJ : maximum Y index of the relevant LSC sub-region |
+C | - k : if specified, the level at which pressure and |
+C | hybrid coordinate has to be computed |
+C | - VGD_sp(ni,nj) : surface pressure |
+C | |
+C | Output: Vertical grid of the LSC model : |
+C | ^^^^^^^ - VGD__p(ni,nj,nk) : pressure at each level [kPa] |
+C | - VGD_hp(ni,nj,nk) : local hybrid coord. for vertic. |
+C | interpolation |
+C | |
+C | Remarks on optimization via sub-region selection (29/05/2022): |
+C | -to compute the vertical grid for the full LSC domain, use |
+C | baseI=1, baseJ=1, maxI=ni, maxJ=nj. |
+C | -code assumes that the user will use 1 <= baseI <= maxI <= ni and |
+C | 1 <= baseJ <= maxJ <= nj. |
+C | -if the variables baseI, baseJ, maxI and maxJ are set to delimit |
+C | a sub-region of the LSC grid, only this sub-region will be |
+C | completed in the output grids. |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE LSCvgd(LSCmod,fID,ni,nj,nk,baseI,baseJ,maxI,maxJ,klev,
+ . VGD_sp,VGD__p,VGD_hp)
+
+ IMPLICIT NONE
+
+ INCLUDE 'CTRvar.inc'
+
+C +---Local variables
+C + ===============
+
+ INTEGER fID,ni,nj,baseI,baseJ,maxI,maxJ,nk,klev
+
+ REAL VGD_sp(ni,nj),VGD__p(ni,nj,nk),VGD_hp(ni,nj,nk)
+
+ CHARACTER*3 LSCmod
+
+C +---Creation of the vertical grid depending on the specified model
+C + ==============================================================
+
+C +---European Center of Medium-Range Forecast (ECMWF)
+C + ------------------------------------------------
+
+C +---Hybrid levels
+C + -------------
+
+ IF (LSCmod.eq.'ECM'.or.LSCmod.eq.'E15'.or.LSCmod.eq.'E40')
+
+ . CALL ECMvgd(fID,ni,nj,nk,baseI,baseJ,maxI,maxJ,klev,.false.,
+ . VGD_sp,VGD__p,VGD_hp)
+
+ IF (LSCmod.eq.'GCM')
+
+ . CALL ECMvgd(fID,ni,nj,nk,baseI,baseJ,maxI,maxJ,klev,.true.,
+ . VGD_sp,VGD__p,VGD_hp)
+
+C +---Pressure levels
+C + ---------------
+
+ IF (LSCmod.eq.'ECP')
+
+ . CALL XCPvgd(fID,ni,nj,nk,baseI,baseJ,maxI,maxJ,klev,.false.,
+ . VGD_sp,VGD__p,VGD_hp)
+
+C +---NCEP analysis
+C + -------------
+
+ IF (LSCmod.eq.'NCP')
+
+ . CALL XCPvgd(fID,ni,nj,nk,baseI,baseJ,maxI,maxJ,klev,.true.,
+ . VGD_sp,VGD__p,VGD_hp)
+
+C +---Modele Atmospherique Regional (MAR)
+C + -----------------------------------
+
+ IF (LSCmod.eq.'MAR')
+
+ . CALL MRLvgd(fID,ni,nj,nk,baseI,baseJ,maxI,maxJ,klev,
+ . VGD_sp,VGD__p,VGD_hp)
+
+ RETURN
+ END
diff --git a/MAR/code_nestor/src/MARfil.f b/MAR/code_nestor/src/MARfil.f
new file mode 100644
index 0000000000000000000000000000000000000000..b93c26aefd23d116d43af10ecd99d2c5931d5aee
--- /dev/null
+++ b/MAR/code_nestor/src/MARfil.f
@@ -0,0 +1,177 @@
+C +-------------------------------------------------------------------+
+C | Subroutine MARfil June 99 NESTING |
+C +-------------------------------------------------------------------+
+C | |
+C | Input : my,dx,dt : grid size, horizontal resolution and time step |
+C | ^^^^^^^ |
+C | |
+C | Output: - deltat : Implicit Filter Parameter (Temperature) |
+C | ^^^^^^^ - deltau : Implicit Filter Parameter (Wind Speed) |
+C | - deltap : Implicit Filter Parameter (Pressure) |
+C | - akhdel : Horizontal Diffusion Coefficient |
+C | - akhfac : Horiz.vKar**2 (horizontal diffusion) |
+C | - akhmax : Upper sponge |
+C | |
+C +-------------------------------------------------------------------+
+
+ subroutine MARfil(my,dx,dt,deltat,deltau,deltap,
+ . akhdel,akhfac,akhmax)
+
+ implicit none
+
+ integer my,mmy
+
+ real dx,dy,dt,deltat,deltau,deltap,akhdel,akhfac,akhmax,akh
+
+ mmy = my
+ dy = dx
+
+
+C + Horizontal Diffusion Parameters
+C + -------------------------------
+
+ if (mmy.eq.1) then
+ call rdelta(dx,dt,deltat,akhdel,akh)
+ else
+ call sdelta(dx,dt,deltat,akhdel,akh)
+ end if
+
+ deltau = deltat
+ deltap = deltat
+ akhfac = 0.16
+ akhmax = 0.1*dx*dx/dt
+C... Vertical upper sponge
+
+ return
+ end
+
+
+C +------------------------------------------------------------------------+
+C | SubRoutine rdelta is used to define the horizontal 1-D filter in MAR |
+C +------------------------------------------------------------------------+
+
+ subroutine rdelta(dx,dt,delta,akhdel,akh)
+
+ implicit none
+
+ character*1 schema
+
+ integer i
+
+ real pi,al,dx,dt,delta,akhdel,akh,ak,ckx,amorf,akhp,clx,
+ . slx,r1,amin,amax,alpha,beta,r,amor,alph,akhmn
+
+ data schema/'E'/
+
+ data pi / 3.1415926567 /
+ delta = 0.05
+
+ do i=3,21,3
+
+ al = i * dx
+
+ ak = dx *2. *pi /al
+ ckx = cos(ak)
+
+ amorf = (ckx + 1) / ((1-delta) *ckx + 1 + delta)
+
+ akhp = -(dx*dx/(dt *ak *ak)) *alog(amorf)
+
+ clx = (cos(ak/2))**2
+ slx = (sin(ak/2))**2
+ r1 = dx**2/dt
+
+ amin = 1.e30
+ amax = 0.
+
+ if (schema.eq.'I') then
+ alpha = 0.25
+ else
+ alpha = 1.
+ end if
+
+ akh = r1 *delta /(4. *(clx + delta *alpha *slx))
+
+ beta = 1. - alpha
+ r = akh / r1
+ amor = (1 -4. *alpha *r *slx) / (1. +4. *beta * r *slx)
+ amin = amor
+ alph = alpha
+ akhmn = akh
+ alpha = alph
+ amor = amin
+ akh = akhmn
+
+ enddo
+
+ akhdel = akh
+
+ return
+ end
+
+
+C +------------------------------------------------------------------------+
+C | SubRoutine sdelta is used to define the horizontal 2-D filter in MAR |
+C +------------------------------------------------------------------------+
+
+ subroutine sdelta(dx,dt,delta,akhdel,akh)
+
+ implicit none
+
+ character*1 schema
+
+ integer i
+
+ real pi,al,dx,dt,delta,akhdel,akh,ak,ckx,amorf,akhp,clx,
+ . slx,r1,amin,amax,alpha,beta,r,amor,alph,akhmn,tlx,
+ . dtlx
+
+ data schema/'E'/
+
+ data pi / 3.1415926567 /
+ delta = 0.05
+
+ do i=3,15,3
+
+ al = i * dx
+
+ ak = dx *2. *pi /al
+ ckx = cos(ak)
+
+ amorf = 1 / (1 + (delta*(1-ckx*ckx)
+ . + delta*delta*(ckx-1)*(ckx-1))
+ . / ( (ckx+1)*(ckx+1) ) )
+
+ clx = (cos(ak/2))**2
+ slx = (sin(ak/2))**2
+ tlx = slx / clx
+ dtlx = 1 + delta *tlx
+ r1 = dx**2/dt
+
+ amin = 1.e30
+ amax = 0.
+
+ if (schema.eq.'I') then
+ alpha = 0.25
+ else
+ alpha = 1.
+ end if
+
+ akh = r1 *delta *dtlx /(4. *(clx + alpha *delta *slx *dtlx))
+
+ beta = 1. - alpha
+ r = akh / r1
+ amor = (1 -4. *alpha *r *slx) / (1. +4. *beta * r *slx)
+ amin = amor
+ alph = alpha
+ akhmn = akh
+ alpha = alph
+ amor = amin
+ akh = akhmn
+
+ enddo
+
+ akhdel = akh
+
+ return
+ end
diff --git a/MAR/code_nestor/src/MARhgd.f b/MAR/code_nestor/src/MARhgd.f
new file mode 100644
index 0000000000000000000000000000000000000000..53178fbc4d9d1fc3a6b3a020938b2120e77a65d0
--- /dev/null
+++ b/MAR/code_nestor/src/MARhgd.f
@@ -0,0 +1,899 @@
+C +-------------------------------------------------------------------+
+C + Subroutine MARhgd 29-07-2021 NESTING +
+C +-------------------------------------------------------------------+
+C + +
+C + Input : Parameters from MARgrd.ctr +
+C + ^^^^^^^ +
+C + +
+C + Output: Creation of the horizontal grid of MAR +
+C + ^^^^^^^ Variables : NST__x(mx,my) and NST__y(mx,my) (long./lat.) +
+C + NSTgdx(mx) and NSTgdy(my) (Lambert) +
+C + NST_dx (horizontal resolution) +
+C + +
+C +-------------------------------------------------------------------+
+
+
+ SUBROUTINE MARhgd
+
+
+ IMPLICIT NONE
+
+
+C +---General variables
+C + -----------------
+
+ INCLUDE 'NSTdim.inc'
+ INCLUDE 'NESTOR.inc'
+ INCLUDE 'NSTvar.inc'
+ INCLUDE 'MARvar.inc'
+
+C +---Local variables
+C + ---------------
+
+ INTEGER i,j
+
+ REAL degrad,MinLon,MaxLon,MinLat,MaxLat,DEGresol,argrot,TruRCL
+ real x0,y0
+C +---Constants
+C + ---------
+
+ DATA degrad / 1.745329252d-2/
+C +... degrad : Conversion Factor: Radian --> Degrees
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---READING OF GRID PARAMETERS IN MARgrd.ctr
+C + ========================================
+
+ OPEN (unit=51,status='old',file='MARgrd.ctr')
+
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) maptyp
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) GElon0
+ read (51,*) imez
+ read (51,*) GElat0
+ read (51,*) jmez
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) dx
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) GEddxx
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) ptopDY
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) zmin
+ read (51,*) aavu
+ read (51,*) bbvu
+ read (51,*) ccvu
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,'(l4)') vertic
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) sst_SL
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+
+ CLOSE(unit=51)
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---HORIZONTAL RESOLUTION
+C + =====================
+
+ dx = dx * 1000.
+ dy = dx
+
+ NST_dx=dx
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---CREATION OF HORIZONTAL 3-D MAR GRID
+C + ===================================
+
+
+ IF (NSTmod.eq.'MAR') THEN
+
+
+C +---Choice of map projection
+C + ------------------------
+
+ write(6,'(A,$)') ' Map projection :'
+
+ IF (maptyp.eq.0)
+ . write(6,*) ' Polar Stereographic Projection'
+ IF (maptyp.eq.1)
+ . write(6,*) ' Stereographic Oblique Projection'
+ IF (maptyp.eq.2)
+ . write(6,*) ' Lambert Conformal, 2 Std. Par. Projection'
+ write(6,*)
+
+
+C +---Domain reference grid point
+C + ---------------------------
+
+ IF (imez.le.0.or.imez.gt.mx) imez = mx/2
+ IF (jmez.le.0.or.jmez.gt.my) jmez = my/2
+
+
+C +---Simple grid (Lambert coordinates)
+C + ---------------------------------
+
+ DO i=1,mx
+ NSTgdx(i)=(i-imez)*dx / 1000.
+ ENDDO
+
+ DO j=1,my
+ NSTgdy(j)=(j-jmez)*dy / 1000.
+ ENDDO
+
+ IF (maptyp.eq.0) THEN
+ call StereoSouth_inverse(GElon0,GElat0,GEddxx,x0,y0)
+ NSTgdx = NSTgdx + x0 !*1000.
+ NSTgdy = NSTgdy + y0 !*1000.
+ ENDIF
+
+
+C +---Compute map projection
+C + ----------------------
+
+ NSTrcl = 0.
+ include 'NESTOR.stereo'
+ TruRCL = NSTrcl
+
+C + ******
+ CALL GRDgeo (maptyp,imez,jmez,dx,dy,GElon0,GElat0,TruRCL,
+ . GEddxx,NST__x,NST__y)
+C + ******
+
+
+C +---Convertion to degree units
+C + --------------------------
+
+ DO j=1,my
+ DO i=1,mx
+ NST__x(i,j) = NST__x(i,j) * 15.d0
+C +... Conversion: Hour->degrees
+ NST__y(i,j) = min( 90.,NST__y(i,j) / degrad)
+ NST__y(i,j) = max(-90.,NST__y(i,j))
+C +... Conversion: rad ->degrees
+ ENDDO
+ ENDDO
+
+
+ ENDIF ! {NSTmod.eq.'MAR'}
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---CREATION OF HORIZONTAL 2-D MAR GRID
+C + ===================================
+
+
+ IF (NSTmod.eq.'M2D') THEN
+
+
+C +---Simple grid (Lambert coordinates)
+C + ---------------------------------
+
+ DO i=1,mx
+ NSTgdx(i)=(i-imez)*dx/1000.
+ ENDDO
+
+ DO j=1,my
+ NSTgdy(j)=(j-jmez)*dy/1000.
+ ENDDO
+
+
+C +---Compute map projection
+C + ----------------------
+
+ DEGresol = 111.111111 * ABS(COS(GElat0*degrad))
+
+ argrot = (90.d0-GEddxx)*degrad
+
+ DO j=1,my
+ DO i=1,mx
+ NST__x(i,j) = GElon0
+ . + (NSTgdx(i) / DEGresol * COS(argrot))
+ . + (NSTgdy(j) / DEGresol * SIN(argrot))
+ NST__y(i,j) = GElat0
+ . + (NSTgdx(i) / DEGresol * SIN(argrot))
+ . + (NSTgdy(j) / DEGresol * COS(argrot))
+C +... Conversion: km -> degrees
+ ENDDO
+ ENDDO
+
+
+ ENDIF
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Compute horizontal extent of the horizontal domain
+C + ==================================================
+
+ MinLon = NST__x(1,1)
+ MaxLon = NST__x(1,1)
+ MinLat = NST__y(1,1)
+ MaxLat = NST__y(1,1)
+ DO j=1,my
+ DO i=1,mx
+ MinLon = MIN(NST__x(i,j),MinLon)
+ MaxLon = MAX(NST__x(i,j),MaxLon)
+ MinLat = MIN(NST__y(i,j),MinLat)
+ MaxLat = MAX(NST__y(i,j),MaxLat)
+ ENDDO
+ ENDDO
+
+
+C +---Print the characteristics of the grid
+C + =====================================
+
+ write(6,200) mx,my,dx/1000.,GEddxx,MinLon,MaxLon,
+ . MinLat,MaxLat
+200 format(' Grid points : ',i4,' * ',i4,/,
+ . ' Horizontal resolution : ',f7.0,' km.',/,
+ . ' Domain orientation : ',f7.0,' deg.',/,
+ . ' MAR longitude between : ',f7.2,' and ',f7.2,/,
+ . ' MAR latitude between : ',f7.2,' and ',f7.2,/)
+
+ write(6,300) mz,ptopDY
+300 format(' Number of grid points : ',i4,/,
+ . ' Pressure at the top : ',f9.4,' kPa.')
+ write(6,310) zmin, aavu, bbvu, ccvu
+310 format(' First level height : ', f6.1,/,
+ . ' aavu, bbvu, ccvu : ',(f6.1,', ',f6.1,', ',f6.1),/)
+
+
+C +---nvx = mw ?
+C + ==========
+
+ If(nvx.ne.mw)then
+ write(6,201) nvx,mw
+201 format(' WARNING -- nvx(',i1,') ne mw(',i1,') -- WARNING',/)
+ endif
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+ RETURN
+ END
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+ subroutine GRDgeo(maptyp,imez,jmez,dx,dy,GElon0,GElat0,TruRCL,
+ . GEddxx,GElonh,GElatr)
+C +
+C +------------------------------------------------------------------------+
+C | MAR GRID 17-07-1996 MAR |
+C | SubRoutine GRDgeo computes the Latitudes, Longitudes and |
+C | the Time Zone of each Grid Point |
+C | |
+C +------------------------------------------------------------------------+
+C | |
+C | INPUT: imez,jmez : Indices of the MAR Domain Center |
+C | ^^^^^^ GEddxx : (2-D): x-Axis Direction |
+C | (3-D): South-North Direction along |
+C | 90E, 180E, 270E or 360E Meridians |
+C | GElat0 : Latitude of (0,0) in MAR (deg) |
+C | GElon0 : Longitude of (0,0) in MAR (deg) |
+C | |
+C | HYPOT.: maptyp = 0 : Polar Stereogr. Project. (SOUTH HEMISPHERE) |
+C | ^^^^^^^ maptyp = 1 : Oblique Stereogr. Project. (ALL LATITUDES) |
+C | maptyp = 2 : Lambert Comformal Project. (ALL LAT, 3D only) |
+C | |
+C | OUTPUT: GElatr(mx,my): Latitude of the (x,y) MAR coordinate (rad) |
+C | ^^^^^^^ GElonh(mx,my): Longitude of the (x,y) MAR coordinate (h) |
+C | itizGE(mx,my): Time Zone |
+C | fcorDY(mx,my): Coriolis Parameter (Variable/only 3-D Domain) |
+C | |
+C +------------------------------------------------------------------------+
+C +
+C +
+ implicit none
+C +
+C +
+C +--General Variables
+C + =================
+C +
+ include 'NSTdim.inc'
+C +
+ integer i,j,mmx,mmy,maptyp,imez,jmez
+C +
+ real degrad,pi,argrot,cosrot,sinrot,xxmar,yymar,epsi,
+ . ddista,xdista,ydista,zero,dx,dy,earthr,hourad
+
+ real GEddxx,GElonh(mx,my),GElatr(mx,my),GElon0,GElat0,TruRCL,
+ . GElon,GElat
+ real x0,y0
+C +
+C +
+C +--Some initialisations
+C + --------------------
+C +
+ mmx=mx
+ mmy=my
+C +
+ pi = 3.141592653589793238462643d0
+ degrad= pi / 180.d0
+ hourad= pi / 12.d0
+ epsi = 1.0d-6
+ zero = 0.d0
+ earthr= 6371.229d+3
+C +
+C +
+C +--GEOGRAPHIC Coordinates
+C + ======================
+C +
+C +
+C +--1-D and 2-D Cases
+C + -----------------
+C +
+ if (mmy.eq.1) then ! CTR
+C +
+ argrot = (GEddxx-90.d0)*degrad
+ cosrot = cos(argrot)
+ sinrot = sin(argrot)
+C +
+ do 21 j=1,my
+ do 21 i=1,mx
+C +
+ xxmar = cosrot*(i-imez)*dx + sinrot*(j-jmez)*dx
+ yymar = cosrot*(j-jmez)*dx - sinrot*(i-imez)*dx
+C +
+C + ***********
+ call GRDstr(xxmar,yymar,GElon0,GElat0,GElon,GElat,TruRCL)
+C + ***********
+C +
+ GElatr(i,j) = GElat
+ GElonh(i,j) = GElon
+C +
+ 21 continue
+C +
+C +
+C +--3-D Cases
+C + -----------------
+C +
+ else ! CTR
+C +
+C +- ANTARCTICA (Polar Stereographic Projection is assumed)
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if (maptyp.eq.0) then ! CTR
+ ddista = earthr * 2.d0 * tan((45.d0+GElat0*0.5d0)*degrad)
+ xdista = ddista * cos((90.d0-GElon0) *degrad)
+ ydista = ddista * sin((90.d0-GElon0) *degrad)
+C +
+ argrot = (GEddxx-90.d0)*degrad
+ cosrot = cos(argrot)
+ sinrot = sin(argrot)
+C +
+ do 31 j=1,my
+ do 31 i=1,mx
+ if (abs(GEddxx- 90.d0).lt.epsi) then
+ xxmar = (i-imez)*dx
+ yymar = (j-jmez)*dy
+ end if
+ if (abs(GEddxx ).lt.epsi) then
+ xxmar = (j-jmez)*dy
+ yymar =-(i-imez)*dx
+ end if
+ if (abs(GEddxx-270.d0).lt.epsi) then
+ xxmar =-(i-imez)*dx
+ yymar =-(j-jmez)*dy
+ end if
+ if (abs(GEddxx-180.d0).lt.epsi) then
+ xxmar =-(j-jmez)*dy
+ yymar = (i-imez)*dx
+ end if
+C +
+ if (abs(GEddxx ).GT.epsi .AND.
+ . abs(GEddxx-90.d0 ).GT.epsi .AND.
+ . abs(GEddxx-180.d0).GT.epsi .AND.
+ . abs(GEddxx-270.d0).GT.epsi) then
+ xxmar = cosrot*(i-imez)*dx+sinrot*(j-jmez)*dy
+ yymar = cosrot*(j-jmez)*dy-sinrot*(i-imez)*dx
+ endif
+C +
+ xxmar = xxmar + xdista
+ yymar = yymar + ydista
+C +
+ ddista = sqrt(xxmar*xxmar+yymar*yymar)
+ GElatr(i,j) =-0.5d0*pi +2.d0*atan(ddista*0.5d0/earthr)
+ if(abs(xxmar).gt.zero) then
+ GElonh(i,j) = atan(yymar/xxmar)
+ if (xxmar.lt.zero)
+ . GElonh(i,j) = GElonh(i,j) + pi
+C +
+ GElonh(i,j) = 0.5d0 * pi - GElonh(i,j)
+ if(GElonh(i,j).gt. pi)
+ . GElonh(i,j) = -2.0d0 * pi + GElonh(i,j)
+ if(GElonh(i,j).lt. -pi)
+ . GElonh(i,j) = 2.0d0 * pi + GElonh(i,j)
+C +
+ else
+ if (yymar.gt.zero) then
+ GElonh(i,j) = 0.0d0
+ else
+ GElonh(i,j) = pi
+ end if
+ end if
+C +... transformation stereographic coordinates (center = South Pole)
+C + -> spherical coordinates
+C +
+ GElonh(i,j) = GElonh(i,j) / hourad
+C +... Conversion: radian -> Hour
+C +
+ 31 continue
+C +
+ end if ! CTR
+
+C +
+C +- EPSG Polar Stereographic transformation Variant B
+C +- (http://www.epsg.org/guides/docs/G7-2.pdf)
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+C +
+ if (maptyp.eq.0) then ! CTR
+
+ call StereoSouth_inverse(GElon0,GElat0,GEddxx,x0,y0)
+
+ do j=1,my
+ do i=1,mx
+C +
+ xxmar = (i-imez)*dx/1000. + x0
+ yymar = (j-jmez)*dy/1000. + y0
+C +
+C + ***********
+ call StereoSouth(xxmar,yymar,GEddxx,GElon,GElat,GElat0)
+C + ***********
+C +
+ GElonh(i,j) = GElon / 15.
+C +... Conversion: degrees->hour
+ GElatr(i,j) = GElat * degrad
+C +... Conversion: degrees->rad
+C +
+ enddo
+ enddo
+C +
+ end if
+
+
+C +
+C +- Oblique Stereographic Projection
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if (maptyp.eq.1) then ! CTR
+C +
+ do 32 j=1,my
+ do 32 i=1,mx
+C +
+ argrot = (GEddxx-90.d0)*degrad
+ cosrot = cos(argrot)
+ sinrot = sin(argrot)
+ xxmar = cosrot*(i-imez)*dx+sinrot*(j-jmez)*dy
+ yymar = cosrot*(j-jmez)*dy-sinrot*(i-imez)*dx
+C +
+C + ***********
+ call GRDstr(xxmar,yymar,GElon0,GElat0,GElon,GElat,TruRCL)
+C + ***********
+C +
+ GElatr(i,j) = GElat
+ GElonh(i,j) = GElon
+C +
+ 32 continue
+C +
+C +- Lambert Comformal Projection (2 std parallels)
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ else if (maptyp.eq.2) then ! CTR
+C +
+C + ***********
+ call GRDlam (dx,dy,imez,jmez,GElon0,GElat0,GElatr,GElonh)
+C + ***********
+C +
+ end if ! CTR
+C +
+ end if ! CTR
+C +
+ return
+ end
+
+! +----------------------------------------------------------------------+
+ Subroutine StereoSouth (E,N,GEddxx,lon,lat,GElat0)
+! | Compute the lon, lat from Polar Stereographic Projection |
+! | Written by Cecile Agosta 02-02-21 |
+! | EPSG Polar Stereographic transformation Variant B |
+! | (http://www.epsg.org/guides/docs/G7-2.pdf) |
+! | Equivalent to EPSG 3031 (WGS-84 ellipsoid) for SH |
+! | Equivalent to EPSG 3413 (WGS-84 ellipsoid) for NH |
+! +----------------------------------------------------------------------+
+! | |
+! | INPUT : E : Stereo coordinate on the East (X, km) |
+! | ^^^^^^^ N : Stereo coordinate on the North (Y, km) |
+! | GEddxx : Longitude of X axis (=GEddxx, 90 = East, clockwise)|
+! | [lat true = 71S/70N] |
+! | |
+! | OUTPUT : lon : longitude (deg) |
+! | ^^^^^^^ lat : latitude (deg) |
+! | |
+! +----------------------------------------------------------------------+
+ IMPLICIT NONE
+
+ INCLUDE 'NSTdim.inc'
+
+! +-- General Variables
+! + -----------------
+ Real,INTENT(in ) :: E,N,GEddxx
+ Real,INTENT(out) :: lon,lat
+
+! +-- Local Variables
+! + ---------------
+ Real ddista
+
+! +-- Constants
+! + ---------
+ Real aa,ex,pi,degrad,latF,FE,FN,tF,mF,k0,t,rho,khi,lon0
+ Real trulat,GElat0
+ aa = 6378.1370 ! aa (km) = demi grand axe
+ ex = 0.081819190842621 ! excentricity WGS-84 : 0.081 819 190 842 622 0.081 819 190 842 621
+
+ if(sign(1.,GElat0)<=0) then
+
+ trulat = -71. ! Latitude of standard parallel, 71S for ESPG 3031
+
+ if(GEddxx/=90) then
+ print *,"GEddxx: x-Direction in MARgrd.ctr should"//
+ . " be 90deg for ESPG 3031" ; stop
+ endif
+ else
+ if(GEddxx/=45) then
+ print *,"GEddxx: x-Direction in MARgrd.ctr should"//
+ . " be 45deg for ESPG 3413" ; stop
+ endif
+ trulat = 70. ! Latitude of standard parallel, 70N for EPSG 3413
+ endif
+
+ pi = 4. * atan(1.)
+ degrad = pi / 180.
+
+ latF = trulat*degrad
+ lon0 = (GEddxx - 90.)*degrad
+
+ FE = 0. !False Easting
+ FN = 0. !False Northing
+
+! +- Polar Stereographic Projection
+! + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+! +----------------------------------------------------------------------+
+ if(sign(1.,GElat0)<=0) then
+ tF = tan (pi/4 + latF/2) /
+ . ( (1 + ex*sin(latF)) / (1 - ex*sin(latF)) )**(ex/2)
+ else
+ tF = tan (pi/4 - latF/2) *
+ . ( (1 + ex*sin(latF)) / (1 - ex*sin(latF)) )**(ex/2)
+ endif
+
+ mF = cos(latF) / (1 - ex**2 * sin(latF)**2)**0.5
+ k0 = mF *( (1+ex)**(1+ex) * (1-ex)**(1-ex) )**0.5 / (2*tF)
+
+ rho = ( (E-FE)**2 + (N-FN)**2 )**0.5
+ t = rho * ( (1+ex)**(1+ex) * (1-ex)**(1-ex) )**0.5 / (2*aa*k0)
+
+ if(sign(1.,GElat0)<=0) then
+ khi = 2*atan(t) - pi/2
+ else
+ khi = pi/2 -2*atan(t)
+ endif
+
+ lat = khi
+ . + ( ex**2/2 + 5*ex**4/24 + ex**6/12 + 13*ex**8/360)
+ . *sin(2*khi)
+ . + (7*ex**4/48 + 29*ex**6/240 + 811*ex**8/11520 )
+ . *sin(4*khi)
+ . + (7*ex**6/120 + 81*ex**8/1120 )
+ . *sin(6*khi)
+ . + ( 4279*ex**8/161280 )
+ . *sin(8*khi)
+
+ if (E-FE .eq. 0. .and. N-FN .eq. 0) then
+ lon = lon0 + pi/2.
+ else if (E-FE .eq. 0. .and. N-FN .ge. 0) then
+ if(sign(1.,GElat0)<=0) then
+ lon = lon0
+ else
+ lon = lon0 - pi
+ endif
+ else if (E-FE .eq. 0. .and. N-FN .le. 0) then
+ if(sign(1.,GElat0)<=0) then
+ lon = lon0 - pi
+ else
+ lon = lon0
+ endif
+ else
+
+ if(sign(1.,GElat0)<=0) then
+ lon = lon0 + atan2(E-FE,N-FN)
+ else
+ lon = lon0 + atan2(E-FE,FN-N)
+ endif
+
+ endif
+
+ lat = lat / degrad
+ lon = lon / degrad
+ if (lon.gt.180.) then
+ lon = lon - 360.
+ else if (lon.lt.-180.) then
+ lon = lon + 360.
+ endif
+
+ return
+ End Subroutine StereoSouth
+
+ subroutine GRDstr(xxmar,yymar,GElon0,GElat0,GElon,GElat,TruRCL)
+C +
+C +------------------------------------------------------------------------+
+C | MAR GRID 16-11-2004 MAR |
+C | SubRoutine GRDstr computes the Latitudes, Longitudes |
+C | of a MAR Domain Grid Point |
+C | Written by Philippe Marbaix 8-03-1996 |
+C | Modified by Hubert Gallée 16-11-2004 |
+C +------------------------------------------------------------------------+
+C | |
+C | METHOD: Inverse Stereographic Oblique Projection |
+C | ^^^^^^^ |
+C | |
+C | REFERENCE: F. Pearson, Map projection methods, CRC Press, 1990. |
+C | ^^^^^^^^^^ |
+C | |
+C | INPUT: xxmar,yymar : MAR Coordinates |
+C | ^^^^^^ GElon0,GElat0: Geographic Coordinates of MAR Domain Center |
+C | (3-D): South-North Direction along |
+C | 90E, 180E, 270E or 360E Meridians |
+C | |
+C | OUTPUT: GElat : Latitude of the MAR grid point (radian) |
+C | ^^^^^^^ GElon : Longitude of the MAR grid point (hour) |
+C | |
+C +------------------------------------------------------------------------+
+C +
+C +
+ implicit none
+C +
+C +
+C +--General Variables
+C + =================
+C +
+ include 'NSTdim.inc'
+C +
+ real pidemi,pi,CphiP,SphiP,degrad,OBLlon,xxmar,yymar,Sphi,
+ . denomi,dGElon,epsi,OBLlat,ddista,earthr,hourad,costru
+C +
+ real GElon0,GElat0,GElon,GElat,TruRCL
+C +
+C +
+C +--local Parameters
+C + =================
+C +
+ pi = 3.141592653589793238462643d0
+ degrad= pi / 180.d0
+ hourad= pi / 12.d0
+ epsi = 1.0d-6
+ earthr= 6371.229e+3
+C +
+ pidemi= pi / 2.0d0
+C +
+ CphiP = cos(degrad*GElat0)
+ SphiP = sin(degrad*GElat0)
+
+C +...HG
+ costru= cos(degrad*TruRCL)
+C +
+C +
+C +--Coordinates relative to a Pole set to the Domain Center
+C + =======================================================
+C +
+C +
+C +--Relative Longitude -OBLlon (0 <= OBLlon < 2pi)
+C + ----------------------------------------------
+C +
+ if (xxmar.gt.0.) then
+ OBLlon = pidemi - atan(yymar/xxmar)
+ else if (xxmar.eq.0. .and. yymar.lt.0.) then
+ OBLlon = pi
+ else if (xxmar.lt.0.) then
+ OBLlon = 3.0d0*pidemi - atan(yymar/xxmar)
+ else if (xxmar.eq.0. .and. yymar.ge.0.) then
+ OBLlon = 0.d0
+ end if
+C +
+C +
+C +--Relative Latitude OBLlat
+C + --------------------------
+C +
+ ddista = sqrt ( xxmar*xxmar + yymar*yymar )
+
+C +...HG
+ OBLlat = 0.5d0*pi - 2.d0*atan(ddista/(earthr*(1+costru)))
+C +
+C +
+C +--Coordinates Change (OBLlon,OBLlat) -> (GElon,GElat)
+C + / (rotation, Pearson p.57)
+C + ===================================================
+C +
+C +
+C +--Latitude (radians)
+C + ------------------
+C +
+ Sphi = SphiP * sin(OBLlat) + CphiP * cos(OBLlat) * cos(OBLlon)
+ GElat= asin(Sphi)
+C +
+C +
+C +--Longitude (hours)
+C + ------------------
+C +
+C +--dGElon = GElon - GElon0 (-pi < dGElon <= pi)
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ denomi = CphiP * tan (OBLlat) - SphiP * cos(OBLlon)
+C +
+ if (OBLlon.gt.epsi .and. OBLlon.lt.(pi-epsi)) then
+C +
+C +--1) OBLlon in trigonometric quadrant 1 or 4 ("right"):
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ dGElon = atan(sin(OBLlon)/denomi)
+ if (dGElon.lt.0.d0) then
+ dGElon = dGElon + pi
+C +... Go to Quadrant 1 by adding 180 degrees
+ end if
+C +
+C +--2) OBLlon is in trigonometric quadrant 2or3 ("left "):
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ else if (OBLlon.gt.(pi+epsi).and. OBLlon.lt.(2.0*pi-epsi)) then
+C +
+ dGElon = atan(sin(OBLlon)/denomi)
+ if (dGElon.gt.0.d0) then
+ dGElon = dGElon - pi
+C +... Go to Quadrant 2 by substracting 180 degrees
+ end if
+C +
+ else if (OBLlon.le.epsi .or. OBLlon.ge.(2.0*pi-epsi)) then
+C +
+C +--3) OBLlon = 0 -> dGElon = 0 or pi :
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if ((pidemi-OBLlat) .gt. (pidemi-degrad*GElat0) ) then
+C +... North pole crossed ==> add 180 degrees to Longitude
+ dGElon = pi
+ else
+ dGElon = 0.d0
+ end if
+C +
+ else if (OBLlon.ge.(pi-epsi) .and. OBLlon.le.(pi+epsi)) then
+C +
+C +--4) OBLlon = pi -> dGElon = 0 or pi :
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ if ((pidemi-OBLlat) .gt. (pidemi+degrad*GElat0) ) then
+C +... South pole crossed ==> add 180 degrees to Longitude
+ dGElon = pi
+ else
+ dGElon = 0.d0
+ end if
+ end if
+C +
+C +--Longitude (hours)
+C + ~~~~~~~~~
+ GElon= (dGElon + GElon0 * degrad) / hourad
+C +
+ return
+ end
+
+
+ subroutine GRDlam (dx,dy,imez,jmez,GElon0,GElat0,GElatr,GElonh)
+C +
+C +------------------------------------------------------------------------+
+C | MAR GRID 20-10-1997 MAR |
+C | SubRoutine GRDlam computes the Latitudes, Longitudes |
+C | of a MAR Domain Grid Point |
+C | using Lambert projection |
+C +------------------------------------------------------------------------+
+C | |
+C | METHOD: Inverse Lambert Comformal Projection |
+C | ^^^^^^^ (conical, two standard parrallels) |
+C | |
+C | REFERENCE: F. Pearson, Map projection methods, CRC Press, 1990. |
+C | ^^^^^^^^^^ |
+C | |
+C | INPUT: |
+C | ^^^^^^ GElon0,GElat0: Geographic Coordinates of MAR Domain Center |
+C | (both in degree!) |
+C | |
+C | OUTPUT: GElatr(mx,my): Latitude of MAR grid points (radian) |
+C | ^^^^^^^ GElonh(mx,my): Longitude of MAR grid points (hour) |
+C | |
+C +------------------------------------------------------------------------+
+C +
+C +
+ implicit none
+C +
+C +
+C +--General Variables
+C + =================
+C +
+ include 'NSTdim.inc'
+C +
+ integer i,j,imez,jmez
+C +
+ real rayter,pi,Rlat0,RlatSz,phi1,phi2,xx,yy,rK,psi,
+ . delty,xxmar,yymar,xxP,yyP,pol_r,theta,GElon0,GElat0,
+ . GElonh(mx,my),GElatr(mx,my),dx,dy,earthr,degrad
+C +
+C +
+C +--Local constants:
+C + ----------------
+ rayter=6371229.0
+ pi = 3.141592653589793238462643d0
+ degrad= pi / 180.d0
+ earthr= 6371.229d+3
+C +
+C +--Domain center (radiant) and size:
+C + ---------------------------------
+ Rlat0 = degrad*GElat0
+
+ RlatSz = float(my) * dy / earthr
+
+C +--"True latitudes" phi1 and phi2 :
+C + --------------------------------
+ phi1 = Rlat0 - RlatSz / 3.
+ phi2 = Rlat0 + RlatSz / 3.
+
+C +--Constants rK (sin phi0) and psi
+C + -------------------------------
+ xx = cos (phi1) / cos (phi2)
+ yy = tan (pi /4. - phi1 /2.) / tan (pi /4. - phi2 /2.)
+ rK= log (xx) / log (yy)
+ psi = rayter*cos(phi1) / (rK*(tan(pi/4.-phi1 /2.))**rK)
+
+C +--y distance from center to pole
+C + ------------------------------
+ delty = psi * (tan(pi/4. - Rlat0/2.))**rK
+
+C +--Main loop over grid points.
+C + ===========================
+ do j = 1, my
+ do i = 1, mx
+
+C +-- Mar coordinate
+C + --------------
+ xxmar = (i-imez)*dx
+ yymar = (j-jmez)*dy
+
+C +-- Transformation to pole-centered xP,yP
+C + -------------------------------------
+ xxP = delty - yymar
+ yyP = xxmar
+
+C +-- Coordinate change : to polar.
+C + -----------------------------
+ pol_r = SQRT (xxP**2. + yyP**2.)
+ theta = ATAN (yyP/xxP)
+
+C +-- Compute longitude (hour)
+C + ------------------------
+ GElonh(i,j) = (GElon0 + theta/rK / degrad) / 15.
+
+C +-- Compute latitude (radian)
+C + -------------------------
+ GElatr(i,j) = (pi/2.)-2.*ATAN((pol_r/psi)**(1./rK))
+
+ end do
+ end do
+
+ return
+ end
diff --git a/MAR/code_nestor/src/MARout.f b/MAR/code_nestor/src/MARout.f
new file mode 100644
index 0000000000000000000000000000000000000000..237848c5560d14e25913df570d8ef25c9d3b4729
--- /dev/null
+++ b/MAR/code_nestor/src/MARout.f
@@ -0,0 +1,1776 @@
+C +-------------------------------------------------------------------+
+C | Subroutine MARout April 2004 NESTING |
+C +-------------------------------------------------------------------+
+C | |
+C | Input : Interpolated LSC (large-scale) fields |
+C | ^^^^^^^ |
+C | |
+C | Output: Creation of MARdyn.DAT (initialization) |
+C | ^^^^^^^ MARsol.DAT ( " ) |
+C | MARlbc.DAT (bound. forcing) |
+C | MARubc.DAT (bound. forcing) |
+C | MARsic.DAT (bound. forcing / Sea-Ice) |
+C | MARdom.dat (surf. characteristics) |
+C | Note that *.DAT file can be written according to ASCII |
+C | or Binary format, depending on ASCfor variable. |
+C | |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE MARout
+
+
+ IMPLICIT NONE
+
+
+C +---General variables
+C + -----------------
+
+ INCLUDE 'NSTdim.inc'
+ INCLUDE 'NESTOR.inc'
+ INCLUDE 'NSTvar.inc'
+ INCLUDE 'MARvar.inc'
+ INCLUDE 'CTRvar.inc'
+
+
+C +---Local variables
+C + ---------------
+
+ INTEGER i,j,k,l,n,ifh,nbchar,jjmez,
+ . veg_1D(mx),iwf_1D(mx),svt_1D(mx,nvx),sfr_1D(mx,nvx),
+ . isol1D(mx),ii1,ii2,jj1,jj2,tmpveg,mmx,mmy,m1,m2,
+ . ic1,ic2,jc1,jc2,ip11,jp11,mx1,mx2,my1,my2
+
+
+ REAL pcap,WK2_1D(mz),compt,compt1
+
+ REAL sst1D(mx),dsa_1D(mx),lai_1D(mx,nvx),SH_1D(mx),
+ . glf_1D(mx,nvx),d1__1D(mx),ts__1D(mx,nvx,nsl),
+ . sw__1D(mx,nvx,nsl),compt2,z0__1D(mx,mw),
+ . r0__1D(mx,mw),ch0_1D(mx),rsur1D(mx),alb01D(mx),
+ . eps01D(mx)
+
+ REAL uairUB(mx,my,mzabso),vairUB(mx,my,mzabso)
+ REAL pktaUB(mx,my,mzabso)
+
+ CHARACTER*7 cklon
+ CHARACTER*10 NSTinfo
+
+ LOGICAL NSTini,NSTfor,NSTend,Vfalse
+
+ REAL MARsig(mz)
+ COMMON/cMARvgd/MARsig
+C See MARvgd.f
+
+C +---Thermodynamical Constants (Atmosphere)
+C + --------------------------------------
+
+ DATA pcap / 3.730037070d0/
+C +... pcap = 100 ** (R / Cp)
+
+
+C +---Data
+C + ----
+
+ DATA Vfalse / .false. /
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Dates
+C + -----
+
+ NSTini=.false.
+ NSTend=.false.
+ NSTfor=.true.
+
+ IF (DATtim.eq.DATini) NSTini=.true.
+ IF (DATtim.eq.DATfin) NSTend=.true.
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---READING OF GRID PARAMETERS IN MARgrd.ctr
+C + ========================================
+
+ OPEN (unit=51,status='old',file='MARgrd.ctr')
+
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) maptyp
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) GElon0
+ read (51,*) imez
+ read (51,*) GElat0
+ read (51,*) jmez
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) dx
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) GEddxx
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) ptopDY
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) zmin
+ read (51,*) aavu
+ read (51,*) bbvu
+ read (51,*) ccvu
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,'(l4)') vertic
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) sst_SL
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+
+ CLOSE(unit=51)
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---DATE
+C + ====
+
+
+ itexpe = 0
+
+C + ******
+ CALL DATcnv (RUNiyr,mmaDYN,jdaDYN,jhuDYN,DATtim,Vfalse)
+C + ******
+
+ iyrDYN=RUNiyr
+
+ IF (DATtim.eq.DATfin) THEN
+ jdh_LB=0
+ ELSE
+ jdh_LB=DAT_dt
+ ENDIF
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---PREPARATION OF VARIABLES TO BE WRITTEN
+C + ======================================
+
+
+C +---Surface characteristics
+C + -----------------------
+
+ DO j=1,my
+ DO i=1,mx
+ d1_SL (i,j) =NST_d1(i,j)
+ alb0SL(i,j) =NSTalb(i,j)
+ eps0SL(i,j) =NSTeps(i,j)
+ DO n=1,mw
+ SL_z0 (i,j,n)=NST_z0(i,j)
+ SL_r0 (i,j,n)=NST_r0(i,j)
+ ENDDO
+ rsurSL(i,j) =NSTres(i,j)
+ ch0SL (i,j) =NSTch0(i,j)
+ ro_SL (i,j) =0.0
+ ENDDO
+ ENDDO
+
+
+C +---Surface layer variables
+C + -----------------------
+
+ DO j=1,my
+ DO i=1,mx
+ tairSL(i,j) =NST_st(i,j)
+ t2_SL (i,j) =NSTdst(i,j)
+ DO n=1,mw
+ tsrfSL(i,j,n)=NST_st(i,j) ! Bloc Temporaire, a modif
+ SLsrfl(i,j,n)=0.
+ SLuusl(i,j,n)=0.
+ SLutsl(i,j,n)=0.
+ ENDDO
+ nSLsrf(i,j) =1
+ SLsrfl(i,j,1)=1.
+C +
+ qvapSL(i,j) =1.e-5
+ w2_SL (i,j) =0.15
+ wg_SL (i,j) =0.15
+ roseSL(i,j) =0.
+ hmelSL(i,j) =0.
+ hsnoSL(i,j) =0.
+ SaltSL(i,j) =0.
+ ENDDO
+ ENDDO
+
+
+C +---Prognostic variables
+C + --------------------
+
+ DO j=1,my
+ DO i=1,mx
+ DO k=1,mz
+ NST_qv(i,j,k)=MAX(1.e-5,NST_qv(i,j,k))
+ NSTtmp(i,j,k)=NST_pt(i,j,k)/pcap
+ ENDDO
+ NSTtmp(i,j,mz+1)=NST_pt(i,j,mz)/pcap
+ pstDY (i,j) =NST_sp(i,j)-ptopDY
+ ENDDO
+ ENDDO
+
+C +...uairDY <-- NST__u
+C +...vairDY <-- NST__v
+C +...qvDY <-- NST_qv
+C +...pktaDY <-- NSTtmp
+
+
+C +---Boundary variables
+C + ------------------
+
+ IF (NSTmod.ne.'CPL') THEN
+
+ DO k=1,mzabso
+ DO j=1,my
+ DO i=1,mx
+ uairUB(i,j,k) = NST__u (i,j,k)
+ vairUB(i,j,k) = NST__v (i,j,k)
+ pktaUB(i,j,k) = NSTtmp (i,j,k)
+ ENDDO
+ ENDDO
+ ENDDO
+ DO k=1,mz
+ DO j=1,my
+ DO i=1,n7
+ vaxgLB(i,j,k,1) = NST__u (i,j,k)
+ vaxgLB(i,j,k,2) = NST__v (i,j,k)
+ vaxgLB(i,j,k,3) = NST_qv (i,j,k)
+ vaxgLB(i,j,k,4) = NSTtmp (i,j,k)
+ vaxgLB(i,j,1,5) = pstDY (i,j)
+ vaxgLB(i,j,mz,5)= tsrfSL (i,j,1)
+ ENDDO
+ DO i=mx-n6,mx
+ vaxdLB(i,j,k,1) = NST__u (i,j,k)
+ vaxdLB(i,j,k,2) = NST__v (i,j,k)
+ vaxdLB(i,j,k,3) = NST_qv (i,j,k)
+ vaxdLB(i,j,k,4) = NSTtmp (i,j,k)
+ vaxdLB(i,j,1,5) = pstDY (i,j)
+ vaxdLB(i,j,mz,5)= tsrfSL (i,j,1)
+ ENDDO
+ ENDDO
+ DO i=1,mx
+ DO j=1,n7
+ vayiLB(i,j,k,1) = NST__u (i,j,k)
+ vayiLB(i,j,k,2) = NST__v (i,j,k)
+ vayiLB(i,j,k,3) = NST_qv (i,j,k)
+ vayiLB(i,j,k,4) = NSTtmp (i,j,k)
+ vayiLB(i,j,1,5) = pstDY (i,j)
+ vayiLB(i,j,mz,5)= tsrfSL (i,j,1)
+ ENDDO
+ DO j=my-n6,my
+ vaysLB(i,j,k,1) = NST__u (i,j,k)
+ vaysLB(i,j,k,2) = NST__v (i,j,k)
+ vaysLB(i,j,k,3) = NST_qv (i,j,k)
+ vaysLB(i,j,k,4) = NSTtmp (i,j,k)
+ vaysLB(i,j,1,5) = pstDY (i,j)
+ vaysLB(i,j,mz,5)= tsrfSL (i,j,1)
+ ENDDO
+ ENDDO
+ ENDDO
+
+ ENDIF
+
+
+C +---Soil variables
+C + --------------
+
+ DO j=1,my
+ DO i=1,mx
+
+ isolSL(i,j)=NSTsol(i,j)
+c IF (region.eq."AFW") THEN
+ isolTV(i,j)=NSTtex(i,j)
+c ELSE
+c IF (NSTtex(i,j).eq.1) isolTV(i,j)=2 ! loamy sand
+c IF (NSTtex(i,j).eq.2) isolTV(i,j)=5 ! sand
+c IF (NSTtex(i,j).eq.3) isolTV(i,j)=11 ! clay
+c ENDIF
+
+ IF (region.eq."ANT") THEN
+ IF (NSTsol(i,j).le.2) isolTV(i,j)=0
+ IF (NSTsol(i,j).eq.4) isolTV(i,j)=4
+ IF (NSTsol(i,j).eq.3) isolTV(i,j)=12
+C +... Transform to SVAT (De Ridder) classification
+
+ ENDIF
+
+ ENDDO
+ ENDDO
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Some constants specific to MAR
+C + ==============================
+
+
+C +---Deardorff Soil Model Parameters
+C + -------------------------------
+
+ cs2SL = 86400.0
+ w20SL = 0.15
+ wg0SL = 0.10
+ wk0SL = 0.15
+ wx0SL = 0.20
+
+
+C +---Typical Roughness Lengths (m) for land, sea, snow
+C + -------------------------------------------------
+
+ zl_SL = 1.00e-1
+ zs_SL = 1.00e-3
+ zn_SL = 1.00e-4
+
+
+C +---Inversion surface temperature
+C + -----------------------------
+
+ dtagSL = 0.
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Parameters of the vertical grid
+C + ===============================
+
+
+C + ******
+ CALL SETsig (mz,zmin,aavu,bbvu,ccvu,ptopDY)
+C + ******
+
+C + ******
+C CALL GRDsig(mz,zmin,aavu,bbvu,ccvu,vertic,
+C . sst_SL,TUkhmx,sigma,WK2_1D)
+C + ******
+
+ DO k=1,mz
+ sigma(k)=MARsig(k)
+ ENDDO
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Specifications for horizontal grid and time step
+C + ================================================
+
+ dx = 1000. *dx
+ dy = dx
+ dt = 4.e-3 *dx
+
+ IF (NSTmod.eq.'M2D') THEN
+ mmx = mx
+ mmy = 1
+ ii1 = 1
+ ii2 = mx
+ jj1 = jmez
+ jj2 = jmez
+ jjmez = 1
+ ELSE
+ IF (NSTmod.eq.'CPL') THEN
+ mmx = 1
+ mmy = 1
+ ii1 = 2
+ ii2 = 2
+ jj1 = 2
+ jj2 = 2
+ jjmez = 1
+ ELSE
+ mmx = mx
+ mmy = my
+ ii1 = 1
+ ii2 = mx
+ jj1 = 1
+ jj2 = my
+ jjmez = jmez
+ ENDIF
+ ENDIF
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---1-D Topography
+C + ==============
+
+ IF (NSTmod.eq.'M2D'.and.mmx.gt.1) THEN
+
+ ic1 = MIN(2,mx)
+ ic2 = MAX(1,mx-1)
+
+ jc1 = MIN(2,my)
+ jc2 = MAX(1,my-1)
+
+ DO i=1,mx
+
+ compt1 = 0.
+ compt2 = 0.
+ SH_1D(i) = 0.
+ isol1D(i) = 1
+
+ DO j=jc1,jc2
+ compt1 = compt1 + 1.
+ SH_1D(i) = SH_1D(i) + NST_sh(i,j)
+ IF (NSTsol(i,j).ge.3) THEN
+ compt2 = compt2 + 1.
+ ENDIF
+ ENDDO
+
+ IF (compt1.ge.1.) THEN
+ SH_1D(i) = SH_1D(i) / compt1
+ ENDIF
+
+ IF (compt2.ge.(my/2)) isol1D(i) = 4
+
+ IF (isol1D(i).le.2) THEN
+ SH_1D(i) = 0.
+ ENDIF
+
+ ENDDO
+
+
+C +....Topography filtering
+C + --------------------
+
+ IF (TOPfilt) THEN
+
+C +... First filtering
+ DO i=ic1,ic2
+ IF (isol1D(i).ge.3) THEN
+ SH_1D(i) = (SH_1D(i-2)+SH_1D(i-1)+2.*SH_1D(i)
+ . +SH_1D(i+1)+SH_1D(i+2)) / 6.0
+ ENDIF
+ ENDDO
+
+C +... Second filtering
+ DO i=ic2,ic1,-1
+ IF (isol1D(i).ge.3) THEN
+ SH_1D(i) = (SH_1D(i-2)+SH_1D(i-1)+2.*SH_1D(i)
+ . +SH_1D(i+1)+SH_1D(i+2)) / 6.0
+ ENDIF
+ ENDDO
+
+C +... Third filtering
+ DO i=ic1,ic2
+ IF (isol1D(i).ge.3) THEN
+ SH_1D(i) = (SH_1D(i-2)+SH_1D(i-1)+2.*SH_1D(i)
+ . +SH_1D(i+1)+SH_1D(i+2)) / 6.0
+ ENDIF
+ ENDDO
+
+C +... Fourth filtering
+ DO i=ic2,ic1,-1
+ IF (isol1D(i).ge.3) THEN
+ SH_1D(i) = (SH_1D(i-2)+SH_1D(i-1)+2.*SH_1D(i)
+ . +SH_1D(i+1)+SH_1D(i+2)) / 6.0
+ ENDIF
+ ENDDO
+
+C +... Fifth filtering
+ DO i=ic1,ic2
+ IF (isol1D(i).ge.3) THEN
+ SH_1D(i) = (SH_1D(i-1)+2.*SH_1D(i)+SH_1D(i+1)) / 4.0
+ ENDIF
+ ENDDO
+
+C +... Sixth filtering
+ DO i=ic2,ic1,-1
+ IF (isol1D(i).ge.3) THEN
+ SH_1D(i) = (SH_1D(i-1)+2.*SH_1D(i)+SH_1D(i+1)) / 4.0
+ ENDIF
+ ENDDO
+
+ ENDIF
+
+
+ m1 = MIN(mx,n10)
+ DO i=1,m1-1
+ SH_1D(i)=SH_1D(m1)
+ ENDDO
+
+ m2 = MAX(1,mx-n10+1)
+ DO i=m2+1,mx
+ SH_1D(i)=SH_1D(m2)
+ ENDDO
+
+
+ ENDIF
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---1-D SST
+C + =======
+
+ IF (NSTmod.eq.'M2D') THEN
+
+ DO i=1,mx
+
+ compt = 0.
+ sst1D(i) = 0.
+
+ DO j=1,my
+ IF (NSTsol(i,j).le.2) THEN
+ IF (NSTsst(i,j).lt.1.) THEN
+ compt = compt + 1.
+ sst1D(i) = sst1D(i) + NST_st(i,j)
+ ELSE
+ compt = compt + 1.
+ sst1D(i) = sst1D(i) + NSTsst(i,j)
+ ENDIF
+ ENDIF
+ ENDDO
+
+ IF (compt.ge.1.) THEN
+ sst1D(i) = sst1D(i) / compt
+ ENDIF
+
+ IF (isol1D(i).ge.3) THEN
+ sst1D(i) = 0.
+ ENDIF
+
+ ENDDO
+
+ ENDIF
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---1-D Surface
+C + ===========
+
+ IF (NSTini.and.NSTmod.eq.'M2D'.and.LoutDA) THEN
+
+ DO i=1,mx
+
+ ch0_1D(i) = 0.
+ rsur1D(i) = 0.
+ alb01D(i) = 0.
+ eps01D(i) = 0.
+ d1__1D(i) = 0.
+ DO k=1,mw
+ z0__1D(i,k) = 0.
+ r0__1D(i,k) = 0.
+ ENDDO
+
+ DO j=1,my
+ ch0_1D(i) = ch0_1D(i) + NSTch0(i,j)
+ rsur1D(i) = rsur1D(i) + NSTres(i,j)
+ alb01D(i) = alb01D(i) + NSTalb(i,j)
+ eps01D(i) = eps01D(i) + NSTeps(i,j)
+ d1__1D(i) = d1__1D(i) + NST_d1(i,j)
+ DO k=1,mw
+ z0__1D(i,k) = z0__1D(i,k) + NST_z0(i,j)
+ r0__1D(i,k) = r0__1D(i,k) + NST_r0(i,j)
+ ENDDO
+ ENDDO
+
+ ch0_1D(i) = ch0_1D(i) / REAL(my)
+ rsur1D(i) = rsur1D(i) / REAL(my)
+ alb01D(i) = alb01D(i) / REAL(my)
+ eps01D(i) = eps01D(i) / REAL(my)
+ d1__1D(i) = d1__1D(i) / REAL(my)
+ DO k=1,mw
+ z0__1D(i,k) = z0__1D(i,k) / REAL(my)
+ r0__1D(i,k) = r0__1D(i,k) / REAL(my)
+ ENDDO
+
+ ENDDO
+
+
+ ENDIF
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---1-D SISVAT variables
+C + ====================
+
+ IF (NSTini.and.SVTmod.and.LoutDA.and.NSTmod.eq.'M2D') THEN
+
+ DO i=1,mx
+
+ compt1 = 0.
+
+ veg_1D(i) = 0
+ tmpveg = 0
+ iwf_1D(i) = 0
+ dsa_1D(i) = 0.
+ DO k=1,nvx
+ svt_1D(i,k) = 0
+ sfr_1D(i,k) = 0
+ lai_1D(i,k) = 0.
+ DO l=1,nsl
+ ts__1D(i,k,l) = 0.
+ sw__1D(i,k,l) = 0.
+ ENDDO
+ ENDDO
+
+ DO j=1,my
+ IF (NSTsol(i,j).ge.3) THEN
+ compt1 = compt1 + 1.
+ tmpveg = tmpveg + NSTtex(i,j)
+ iwf_1D(i) = iwf_1D(i) + NSTiwf(i,j)
+ dsa_1D(i) = dsa_1D(i) + NSTdsa(i,j)
+ DO k=1,nvx
+ svt_1D(i,k) = svt_1D(i,k) + NSTsvt(i,j,k)
+ sfr_1D(i,k) = sfr_1D(i,k) + NSTsfr(i,j,k)
+ lai_1D(i,k) = lai_1D(i,k) + NSTlai(i,j,k)
+ DO l=1,nsl
+ ts__1D(i,k,l) = ts__1D(i,k,l) + NST_ts(i,j,k,l)
+ sw__1D(i,k,l) = sw__1D(i,k,l) + NST_sw(i,j,k,l)
+ ENDDO
+ ENDDO
+ ENDIF
+ ENDDO
+
+ IF (compt1.ge.1.) THEN
+ tmpveg = NINT (REAL(tmpveg) / compt1)
+ iwf_1D(i) = NINT (REAL(iwf_1D(i)) / compt1)
+ dsa_1D(i) = dsa_1D(i) / compt1
+ veg_1D(i) = NINT (REAL(veg_1D(i)) / compt1)
+ IF (tmpveg.eq.1) veg_1D(i)=2 ! loamy sand
+ IF (tmpveg.eq.2) veg_1D(i)=5 ! sand
+ IF (tmpveg.eq.3) veg_1D(i)=11 ! clay
+ DO k=1,nvx
+ svt_1D(i,k) = NINT (REAL(svt_1D(i,k)) / compt1)
+ sfr_1D(i,k) = NINT (REAL(sfr_1D(i,k)) / compt1)
+ lai_1D(i,k) = lai_1D(i,k) / compt1
+ ENDDO
+ DO l=1,nsl
+ DO k=1,nvx
+ ts__1D(i,k,l) = ts__1D(i,k,l) / compt1
+ sw__1D(i,k,l) = sw__1D(i,k,l) / compt1
+ ENDDO
+ ENDDO
+ ENDIF
+
+ ENDDO
+
+ ENDIF
+
+
+ IF (NSTfor.and.SVTmod.and.LoutDA.and.NSTmod.eq.'M2D') THEN
+
+ DO i=1,mx
+
+ compt2 = 0.
+ DO k=1,nvx
+ glf_1D(i,k) = 0.
+ ENDDO
+
+ DO j=1,my
+ IF (NSTsol(i,j).ge.4) THEN
+ DO k=1,nvx
+ compt2 = compt2 + 1.
+ glf_1D(i,k) = glf_1D(i,k) + NSTlai(i,j,k)*NSTglf(i,j,k)
+ ENDDO
+ ENDIF
+ ENDDO
+
+ IF (compt2.ge.1.) THEN
+ DO k=1,nvx
+ IF (lai_1D(i,k).gt.0.) THEN
+ glf_1D(i,k) = glf_1D(i,k) / compt2 / lai_1D(i,k)
+ glf_1D(i,k) = MIN(1.0,glf_1D(i,k))
+ ELSE
+ glf_1D(i,k) = 0.0
+ ENDIF
+ ENDDO
+ ENDIF
+
+ ENDDO
+
+ ENDIF
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Filter parameters
+C + -----------------
+
+ CALL MARfil(my,dx,dt,FIslot,FIslou,FIslop,
+ . FIkhmn,TUkhff,TUkhmx)
+
+C Note (PhM): we give the opportunity to change FIslo* here
+C because standard value is high in comparison to
+C recomendations in
+C Raymond and Garder, MWR 116, Jan 1988, p209
+C (suggests 0.0075, while default is 0.05 in MARfil)
+C Note that we do not change FIlkhm, which
+C is computed in MARfil and used in MAR:TURhor_dyn.f
+C (i.e.: I don't know the reason for changing it
+C with the filter; of course it also smooth horizontal
+C fields, but may be physically based (?) in contrast to
+C the filter, which should only eliminates 2dx)
+
+ IF (NSTfis.GE.0.0001) THEN
+ FIslop= NSTfis
+ FIslou= FIslop
+ FIslot= FIslop
+ ENDIF
+
+ IF (vrbose) THEN
+ write(6,*) 'Write files :'
+ write(6,*) '~~~~~~~~~~~~~~'
+ ENDIF
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Output directory
+C + ================
+
+ nbchar=1
+
+ DO i=1,60
+ IF (NSTdir(i:i).ne.' ') nbchar=i
+ ENDDO
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---MAR include file : MARdim.inc
+C + =============================
+
+ IF (NSTini) THEN
+
+ open (1,status='unknown',file=NSTdir(1:nbchar)
+ . //'MARdim.inc')
+ open (2,status='unknown',file=NSTdir(1:nbchar)
+ . //'MARdim.inc_old')
+ rewind 1
+ rewind 2
+
+ ip11 = MIN(2,mmx)
+ jp11 = MIN(2,mmy)
+ mx1 = MAX(1,mmx-1)
+ my1 = MAX(1,mmy-1)
+ mx2 = MAX(1,mmx-2)
+ my2 = MAX(1,mmy-2)
+
+ IF (vector) THEN
+ cklon = 'mx2*my2'
+ ELSE
+ cklon = ' 1'
+ ENDIF
+
+ write(1,300) mmx,mmy,ip11,jp11,mz,mx1,mx2,my1,my2,mzabso,cklon,
+ . n6,n7,mw
+ write(2,400) mmx,mmy,ip11,jp11,mz,mx1,mx2,my1,my2,mzabso,cklon
+
+300 format(' integer mx ,my ,ip11 ,jp11',/,
+ . ' parameter(mx=',i4,',my=',i4,
+ . ',ip11=',i3,',jp11=',i3,')',/,
+ . ' integer mz ,mzir1 ,mzir',/,
+ . ' parameter(mz=',i4,',mzir1=mz+1,mzir=mz+2)',/,
+ . '! ... mzir1 may be chosen much larger than mz, ',/,
+ . '! if the model vertical domain covers a small',/,
+ . '! part of the air column',/,
+ . '! ',/,
+ . ' integer mx1 ,mx2',/,
+ . ' parameter(mx1=',i4,',mx2=',i4,')',/,
+ . ' integer my1 ,my2 ,myd2',/,
+ . ' parameter(my1=',i4,',my2=',i4,',myd2=1+my/2)',/,
+ . ' integer mz1 ,mzz',/,
+ . ' parameter(mz1=mz-1,mzz=mz+1)',/,
+ . ' integer i_2',/,
+ . ' parameter(i_2=mx-mx1+1) ',/,
+ . ' integer j_2',/,
+ . ' parameter(j_2=my-my1+1) ',/,
+ . ' integer mzabso ,mzhyd',/,
+ . ' parameter(mzabso = ',i2,',mzhyd=mzabso)',/,
+ . '! ',/,
+ . ' integer klon, klev',/,
+ . ' parameter(klon=',a7,',klev=mz)',/,
+ . '! +...if #NV removed (NO vectorization)',/,
+ . '! + then klon= 1',/,
+ . '! + ',/,
+ . ' integer kdlon, kflev',/,
+ . ' parameter(kdlon=klon ,kflev=klev)',/,
+ . '! + ',/,
+ . ' integer n6 ,n7',/,
+ . ' parameter(n6=',i2,',n7=',i2,')',/,
+ . '! +.. n6 et n7 determine a relaxation zone',
+ . 'towards lateral boundaries',/,
+ . '! + (large scale values of the variables).',/,
+ . '! + This zone extends over n6-1 points.',/,
+ . '! + Davies (1976) propose 5 points ',
+ . '(i.e. n6=6 and n7=7)',/,
+ . '! + ',/,
+ . ' integer mw',/,
+ . ' parameter(mw=',i3,')',/,
+ . '! +.. mw is the total number of mosaics',/,
+ . '! + ')
+
+400 format(' integer mx ,my ,ip11 ,jp11',/,
+ . ' parameter(mx=',i4,',my=',i4,
+ . ',ip11=',i3,',jp11=',i3,')',/,
+ . ' integer mz ,mzir1 ,mzir',/,
+ . ' parameter(mz=',i4,',mzir1=mz+1,mzir=mz+2)',/,
+ . '! ... mzir1 may be chosen much larger than mz, ',/,
+ . '! if the model vertical domain covers a small',/,
+ . '! part of the air column',/,
+ . '! ',/,
+ . ' integer mx1 ,mx2',/,
+ . ' parameter(mx1=',i4,',mx2=',i4,')',/,
+ . ' integer my1 ,my2 ,myd2',/,
+ . ' parameter(my1=',i4,',my2=',i4,',myd2=1+my/2)',/,
+ . ' integer mz1 ,mzz',/,
+ . ' parameter(mz1=mz-1,mzz=mz+1)',/,
+ . ' integer i_2',/,
+ . ' parameter(i_2=mx-mx1+1) ',/,
+ . ' integer j_2',/,
+ . ' parameter(j_2=my-my1+1) ',/,
+ . ' integer mzabso ,mzhyd',/,
+ . ' parameter(mzabso = ',i2,',mzhyd=mzabso+1)',/,
+ . '! ',/,
+ . ' integer klon, klev',/,
+ . ' parameter(klon=',a7,',klev=mz)',/,
+ . '! +...if #NV removed (NO vectorization)',/,
+ . '! + then klon= 1',/,
+ . '! + ',/,
+ . ' integer kdlon, kflev',/,
+ . ' parameter(kdlon=klon ,kflev=klev)' )
+
+ close (1)
+ close (2)
+
+ write(6,*) 'MAR include file MARdim.inc created'
+
+ ENDIF
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---MAR include file : MAR_TV.inc
+C + =============================
+
+ IF (NSTini) THEN
+
+ open (1,status='unknown',file=NSTdir(1:nbchar)
+ . //'MAR_TV.inc_old')
+ rewind 1
+
+ write (1,411) nvx,nsl
+411 format(' integer nvx ,llx ,iptx',/,
+ . ' parameter (nvx=',i3,',llx=',i3,',iptx=5)')
+
+ write (1,412)
+412 format(
+ . 'C +',/,
+ . 6x,'integer imx ,jmx',/,
+ . 6x,'parameter (imx=mx,jmx=my)',/,
+ . 'C +',/,
+ . 6x,'real deptTV(0:llx)',/,
+ . 'C +...',10x,'deptTV: Soil Level Depth',/,
+ . 'C +',/,
+ . 6x,'real dep2TV(0:llx)',/,
+ . 'C +...',10x,'dep2TV: Soil Layer Depth',/,
+ . 'C +',/,
+ . 6x,'real slopTV(imx,jmx)',/,
+ . 'C +...',10x,'slopTV: Surface Slope',/,
+ . 'C +',/,
+ . 6x,'real AlbSTV(imx,jmx)',/,
+ . 'C +...',10x,'AlbSTV: Dry Soil Albedo',/,
+ . 'C +',/,
+ . 6x,'real alaiTV(imx,jmx,nvx)',/,
+ . 'C +...',10x,'alaiTV: Leaf Area Index',/,
+ . 'C +',/,
+ . 6x,'real glf_TV(imx,jmx,nvx)',/,
+ . 'C +...',10x,'glf_TV: Green Leaf Fraction',/,
+ . 'C +',/,
+ . 6x,'real CaWaTV(imx,jmx,nvx)',/,
+ . 'C +...',10x,'CaWaTV: Canopy Intercepted Water Content',/,
+ . 'C +',/,
+ . 6x,'real CaSnTV(imx,jmx,nvx)',/,
+ . 'C +...',10x,'CaSnTV: Canopy Intercepted Snow Content',/,
+ . 'C +',/,
+ . 6x,'real TvegTV(imx,jmx,nvx)',/,
+ . 'C +...',10x,'TvegTV: Skin Vegetation Temperature',/,
+ . 'C +',/,
+ . 6x,'real TgrdTV(imx,jmx,nvx)',/,
+ . 'C +...',10x,'TgrdTV: Skin Soil Temperature',/,
+ . 'C +',/,
+ . 6x,'real TsolTV(imx,jmx,nvx,llx)',/,
+ . 'C +...',10x,'TsolTV: Layer Soil Temperature',/,
+ . 'C +',/,
+ . 6x,'real eta_TV(imx,jmx,nvx,llx)',/,
+ . 'C +...',10x,'eta_TV: Soil Moisture Content',/,
+ . 'C +',/,
+ . 6x,'real psigTV(imx,jmx,nvx)',/,
+ . 'C +...',10x,'psigTV: Soil Hydraulic Potential',/,
+ . 'C +',/,
+ . 6x,'real psivTV(imx,jmx,nvx)',/,
+ . 'C +...',10x,'psivTV: Vegetation Hydraulic Potential',/,
+ . 'C +',/,
+ . 6x,'real runoTV(imx,jmx)',/,
+ . 'C +...',10x,'runoTV: Time Integrated (Sub)surface Flow',/,
+ . 'C +',/,
+ . 6x,'real draiTV(imx,jmx)',/,
+ . 'C +...',10x,'draiTV: Time Integrated Drainage Flow',/,
+ . 'C +',/,
+ . 6x,'integer iWaFTV(imx,jmx)',/,
+ . 'C +...',9x,'(iWaFTV=0 ==> no Water Flux;',/,
+ . 'C + ',10x,'iWaFTV=1 ==> free drainage)',/,
+ . 'C +',/,
+ . 6x,'integer ivegTV(imx,jmx,nvx)',/,
+ . 'C +...',10x,'ivegTV: Vegetation Type Index',/,
+ . 'C +',/,
+ . 6x,'integer isolTV(imx,jmx)',/,
+ . 'C +...',10x,'isolTV: Soil Type Index',/,
+ . 'C +',/,
+ . 6x,'integer ifraTV(imx,jmx,nvx)',/,
+ . 'C +...',10x,'ifraTV: Vegetation Class Coverage',/,
+ . 'C + ',10x,' (3 Class, Last One is Open Water)',/,
+ . 'C +',/,
+ . 6x,'integer IOi_TV(iptx),IOj_TV(iptx)',/,
+ . 'C +...',10x,'IO Grid Indices',/,
+ . 'C +',/,
+ . 6x,'integer itx,ivg',/,
+ . 'C +',/,
+ . 5x,' common/rsvaTV/AlbSTV,alaiTV,glf_TV,CaWaTV,CaSnTV,',/,
+ . 5x,'. runoTV,draiTV,TvegTV,TgrdTV,TsolTV,',/,
+ . 5x,'. eta_TV,psigTV,psivTV,deptTV,dep2TV ',/,
+ . 5x,' common/isvaTV/iWaFTV,ivegTV,isolTV,ifraTV,IOi_TV,',/,
+ . 5x,'. IOj_TV,itx ,ivg')
+
+ close (1)
+
+ write(6,*) 'MAR include file MAR_TV.inc created'
+
+ ENDIF
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---MAR include file : MAR_SV.inc
+C + =============================
+
+ IF (NSTini) THEN
+
+ open (1,status='unknown',file=NSTdir(1:nbchar)//'MAR_SV.inc')
+ open (2,status='unknown',file=NSTdir(1:nbchar)//'MAR_SV.inc_nv')
+ rewind 1
+ rewind 2
+
+ write (1,410) nsl-1,nsno,nvx*5
+ write (2,409) nsl-1,nsno,nvx*5
+410 format(' integer klonv ,nsol ,nsno',/,
+ . ' parameter(klonv= 1,nsol=',i3,',nsno=',i4,')',/
+ . ' integer nb_wri',/,
+ . ' parameter(nb_wri=',i3,')',/)
+409 format(' integer klonv ,nsol ,nsno',/,
+ . ' parameter(klonv= 1,nsol=',i3,',nsno=',i4,')',/
+ . ' integer nb_wri',/,
+ . ' parameter(nb_wri=',i3,')',/)
+
+ close (1)
+ close (2)
+
+ write(6,*) 'MAR include file MAR_SV.inc created'
+
+ ENDIF
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---MAR include file : MAR_LB.inc
+C + =============================
+
+ IF (NSTini) THEN
+
+ open (1,status='unknown',file=NSTdir(1:nbchar)
+ . //'MAR_LB.inc_old')
+ rewind 1
+
+ write (1,420) n6,n7
+
+420 format(' integer n6 ,n7',/,
+ . ' parameter(n6=',i3,',n7=',i3,')',/,
+ . 'C +...n6 et n7 determine a relaxation zone towards ',/,
+ . 'C + lateral boundaries ',/,
+ . 'C + (large scale values of the variables). ',/,
+ . 'C + This zone extends over n6-1 points. ',/,
+ . 'C + Davies (1976) propose 5 points ',/,
+ . 'C + (i.e. n6=6 and n7=7)',/,
+ . 'C + ',/,
+ . ' integer iyr_LB,mma_LB,jda_LB,jhu_LB,jdh_LB',/,
+ . ' common/nudite/iyr_LB,mma_LB,jda_LB,jhu_LB,jdh_LB',/,
+ . 'C +... iyr_LB: Year',/,
+ . 'C + mma_LB: Month',/,
+ . 'C + jda_LB: Day',/,
+ . 'C + jhu_LB: Hour (UT)',/,
+ . 'C + jdh_LB: Time Interval before next ',/,
+ . 'C + GCM/NWP LBC (hour)',/,
+ . 'C + jdh_LB=0 ==> NO further GCM/NWP ',/,
+ . 'C + LBC available',/,
+ . ' integer tim1LB,tim2LB',/,
+ . ' common/nudtim/tim1LB,tim2LB',/,
+ . 'C +... tim1LB: Time of the previous LBC (second)',/,
+ . 'C + tim2LB: Time of the next LBC (second)',/,
+ . 'C + ',/,
+ . ' integer n40xLB, n50xLB, n5mxLB, n6mxLB, n7mxLB,',/,
+ . ' . n40yLB, n50yLB, n5myLB, n6myLB, n7myLB ',/,
+ . ' common/nudind/n40xLB, n50xLB, n5mxLB, n6mxLB, ',/,
+ . ' . n7mxLB, n40yLB, n50yLB, n5myLB, ',/,
+ . ' . n6myLB, n7myLB ',/,
+ . 'C +... ...n6mxLB, n7mxLB, n6myLB, n7myLB...',/,
+ . 'C + define the effective length of ',/,
+ . 'C + the lateral sponge',/,
+ . 'C + ',/,
+ . ' real*4 vaxgLB ,vaxdLB',/,
+ . ' real*4 v1xgLB ,v1xdLB',/,
+ . ' . ,v2xgLB ,v2xdLB',/,
+ . ' real tixgLB ,tixdLB',/,
+ . ' common/nuddax/vaxgLB(1:n7,my,mz,5),',/,
+ . ' . vaxdLB(mx-n6:mx ,my,mz,5),',/,
+ . ' . v1xgLB(1:n7,my,mz,5),',/,
+ . ' . v1xdLB(mx-n6:mx ,my,mz,5),',/,
+ . ' . v2xgLB(1:n7,my,mz,5),',/,
+ . ' . v2xdLB(mx-n6:mx ,my,mz,5),',/,
+ . ' . tixgLB(2:n7,my,mz ),',/,
+ . ' . tixdLB(mx-n6:mx1,my,mz )',/,
+ . 'C + ',/,
+ . ' real*4 vayiLB ,vaysLB',/,
+ . ' real*4 v1yiLB ,v1ysLB',/,
+ . ' . ,v2yiLB ,v2ysLB',/,
+ . ' real tiyiLB ,tiysLB',/,
+ . ' common/nudday/vayiLB(mx,1:n7,mz,5),',/,
+ . ' . vaysLB(mx,my-n6:my ,mz,5),',/,
+ . ' . v1yiLB(mx,1:n7,mz,5),',/,
+ . ' . v1ysLB(mx,my-n6:my ,mz,5),',/,
+ . ' . v2yiLB(mx,1:n7,mz,5),',/,
+ . ' . v2ysLB(mx,my-n6:my ,mz,5),',/,
+ . ' . tiyiLB(mx,2:n7,mz ),',/,
+ . ' . tiysLB(mx,my-n6:my1,mz )',/,
+ . 'C +... vaXX : large scale values of relevant ',/,
+ . 'C + dependant variables ',/,
+ . 'C + ^X=(x->x axis border, y->y axis border)',/,
+ . 'C + ^X=(g->x small, d->x large, ',/,
+ . 'C + b->y small, h->y large) ',/,
+ . 'C + tiXXLB : independant term of semi-implicit',/,
+ . 'C + numerical scheme',/,
+ . 'C + ',/,
+ . ' real wixgLB',/,
+ . ' . ,wixdLB',/,
+ . ' . ,wiyiLB',/,
+ . ' . ,wiysLB',/,
+ . ' common/nuddaw/wixgLB( 2: n7, 2: n7)',/,
+ . ' . ,wixdLB(mx-n6:mx1,mx-n6:mx1)',/,
+ . ' . ,wiyiLB( 2: n7, 2: n7)',/,
+ . ' . ,wiysLB(my-n6:my1,my-n6:my1)',/,
+ . 'C +... wiXXLB : coefficient used in',/,
+ . 'C + semi-implicit numerical scheme',/,
+ . 'C + ',/,
+ . ' real rxLB ,ryLB',/,
+ . ' common/nuddtk/rxLB(mx),ryLB(my)',/,
+ . 'C +... rXLB : nudging coefficients',/,
+ . 'C + of the relaxation zone',/,
+ . 'C + ',/,
+ . ' real*4 sst_LB',/,
+ . ' real*4 sst1LB,sst2LB',/,
+ . ' common/srfbnd/sst_LB(mx,my),',/,
+ . ' . sst1LB(mx,my),sst2LB(mx,my)',/,
+ . 'C +... sst_LB : external SST' )
+
+ close (1)
+
+ write(6,*) 'MAR include file MAR_LB.inc_old created'
+
+ ENDIF
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Output for surface characteristics : MARdom.dat
+C + ===============================================
+
+C +---Time zone
+ ifh = NINT(GElon0/15.)
+ if (ifh.gt. 12) ifh=ifh-24
+ if (ifh.lt.-12) ifh=ifh+24
+
+C +---i Indices (Surface Output)
+ igrdIO(1)= mx/4
+ igrdIO(2)= mx/4
+ igrdIO(3)= mx/2
+ igrdIO(4)=3*mx/4
+ igrdIO(5)=3*mx/4
+ IF (NSTmod.eq.'M2D') THEN
+ igrdIO(1)=1*mx/6
+ igrdIO(2)=2*mx/6
+ igrdIO(3)=3*mx/6
+ igrdIO(4)=4*mx/6
+ igrdIO(5)=5*mx/6
+ ENDIF
+
+C +---j Indices (Surface Output)
+ jgrdIO(1)= my/4
+ jgrdIO(2)=3*my/4
+ jgrdIO(3)= my/2
+ jgrdIO(4)= my/4
+ jgrdIO(5)=3*my/4
+
+C +---i/j Indices (Surface Output/Afr West)
+ IF (abs(GElat0).lt.15.d0.and.
+ . abs(GElon0).lt.15.d0.and.
+ . NSTmod.ne.'M2D' .and.
+ . NSTmod.ne.'CPL' ) THEN
+ DO i=1,5
+ igrdIO(i) = 4 *mx/5
+ jgrdIO(i) = my/2 + (i-1)*my/10
+ ENDDO
+ ENDIF
+
+ IF (mmx.eq.1) THEN
+ DO i=1,5
+ igrdIO(i) = 1
+ ENDDO
+ ENDIF
+
+ IF (mmy.eq.1) THEN
+ DO i=1,5
+ jgrdIO(i) = 1
+ ENDDO
+ ENDIF
+
+C +---Vertical adjustment time step
+ tequil = 0.
+ dtquil = dt
+
+ IF (NSTini) THEN
+
+ open (1,status='unknown',file=NSTdir(1:nbchar)//'MARdom.dat')
+ rewind 1
+
+ write (1,141) LABLio,mmx,mmy,mz
+141 format(a3, 15x,
+ . 'ON (mx,my,mz) = (',i4,' x',i4,' x',i3,' ) ',
+ . ' Label + GRID of Simulation')
+
+ write (1,1420) GElat0,GElon0,GEddxx
+1420 format(3d13.6, 14x,' Phi,Lam / x-Axis Direction')
+ write (1,1425) mmaDYN,jdaDYN,jhuDYN,ifh,iyrDYN
+1425 format(4i4,i4, 33x,' Month:Day:Hour / Time Zone')
+
+ write (1,1426) imez,jjmez,maptyp
+1426 format(3i4, 41x,' x,y Origin/Projection Type')
+ write (1,1427) igrdIO
+1427 format(5i4, 33x,' i Indices (Surface Output)')
+ write (1,1428) jgrdIO
+1428 format(5i4, 33x,' j Indices (Surface Output)')
+ write (1,1429) 2
+1429 format( i4, 49x,' Print Amount Parameter')
+ write (1,1421) 1,mmx,1
+1421 format(3i4, 41x,' i Output Indices (MARwri)')
+ write (1,1422) 1,mmy,1
+1422 format(3i4, 41x,' j Output Indices')
+ write (1,1423) 1,mz,1
+1423 format(3i4, 41x,' k Output Indices')
+ write (1,1424) mz,min(21,mz)
+1424 format(2i4, 45x,' Output Parameters / NetCDF')
+
+ write (1,145) dx,dy,dt
+145 format(3d13.6, 14x,' Hor. Grid Dist./ Time Step')
+ write (1,1450) vertic
+1450 format(l3, 50x,' Vertical Grid Type Paramet')
+ write (1,1455) ptopDY
+1455 format( d13.6, 40x,' Model Top Pressure (kPa)')
+ write (1,1451) zmin,aavu,bbvu,ccvu
+1451 format(4d13.6, ' Lowest k + 3Vert.Grid Par.')
+ write (1,1452) FIslot,FIslou,FIslop,FIkhmn
+1452 format(4d13.6, ' Filter Selectivity T, u, p')
+ write (1,1453) TUkhff,TUkhmx
+1453 format(2d13.6, 27x,' Horiz.vKar**2 / Up.Sponge')
+ write (1,1454) tequil,dtquil
+1454 format(2d13.6, 27x,' 1-D Initialis. Time + Step')
+ write (1,1456) zs_SL,zn_SL,zl_SL,cs2SL
+1456 format(4d13.6, ' z0 Par.Sea/Snow/Land-unused')
+ write (1,1457) sst_SL
+1457 format( d13.6, 40x,' SST:(for vert. grid only).')
+ write (1,1458) dtagSL
+1458 format( d13.6, 40x,' Initial T(Air)-T(Surface)')
+ write (1,1459) wk0SL,wx0SL,w20SL,wg0SL
+1459 format(4d13.6, ' Initial Soil Humid.Variab.')
+
+ write (1,1430)
+1430 format(' SOIL TYPES')
+ IF (NSTmod.eq.'M2D') THEN
+ write (1,143) isol1D
+ ELSE
+ write (1,143) ((isolSL(i,j),i=ii1,ii2),j=jj1,jj2)
+ ENDIF
+143 format((10i13))
+
+ write (1,1431)
+1431 format(' TOPOGRAPHY')
+ IF (NSTmod.eq.'M2D') THEN
+ write (1,1432) SH_1D
+ ELSE
+ write (1,1432) ((NST_sh(i,j),i=ii1,ii2),j=jj1,jj2)
+ ENDIF
+1432 format((10d13.6))
+
+ write (1,1433)
+1433 format(' ROUGHNESS LENGTH (MOMENTUM)')
+ IF (NSTmod.eq.'M2D') THEN
+ write (1,1432) z0__1D
+ ELSE
+ write (1,1432) (((SL_z0(i,j,k),i=ii1,ii2),j=jj1,jj2),k=1,mw)
+ ENDIF
+
+ write (1,1434)
+1434 format(' ROUGHNESS LENGTH (HEAT,HUMIDITY)')
+ IF (NSTmod.eq.'M2D') THEN
+ write (1,1432) r0__1D
+ ELSE
+ write (1,1432) (((SL_r0(i,j,k),i=ii1,ii2),j=jj1,jj2),k=1,mw)
+ ENDIF
+
+ write (1,1435)
+1435 format(' BULK COEFFICIENT (HUMIDITY)')
+ IF (NSTmod.eq.'M2D') THEN
+ write (1,1432) ch0_1D
+ ELSE
+ write (1,1432) ((ch0SL(i,j),i=ii1,ii2),j=jj1,jj2)
+ ENDIF
+
+ write (1,1436)
+1436 format(' LEAF SURFACE RESISTANCE')
+ IF (NSTmod.eq.'M2D') THEN
+ write (1,1432) rsur1D
+ ELSE
+ write (1,1432) ((rsurSL(i,j),i=ii1,ii2),j=jj1,jj2)
+ ENDIF
+
+ write (1,1437)
+1437 format(' SURFACE ALBEDO')
+ IF (NSTmod.eq.'M2D') THEN
+ write (1,1432) alb01D
+ ELSE
+ write (1,1432) ((alb0SL(i,j),i=ii1,ii2),j=jj1,jj2)
+ ENDIF
+
+ write (1,1438)
+1438 format(' SURFACE EMISSIVITY (IR)')
+ IF (NSTmod.eq.'M2D') THEN
+ write (1,1432) eps01D
+ ELSE
+ write (1,1432) ((eps0SL(i,j),i=ii1,ii2),j=jj1,jj2)
+ ENDIF
+
+ write (1,1440)
+1440 format(' Rhos Cs sqrt(kappas Tau1) (GROUND)')
+ IF (NSTmod.eq.'M2D') THEN
+ write (1,1432) d1__1D
+ ELSE
+ write (1,1432) ((d1_SL(i,j),i=ii1,ii2),j=jj1,jj2)
+ ENDIF
+
+c #IT write (1,1443)
+1443 format(' INITIAL GROUND TEMPERATURE ')
+c #IT write (1,1432) (((tsrfSL(i,j,k),i=ii1,ii2),j=jj1,jj2),k=1,mw)
+
+c #IT write (1,1444)
+1444 format(' INITIAL DEEP TEMPERATURE ')
+c #IT write (1,1432) ((t2_SL(i,j),i=ii1,ii2),j=jj1,jj2)
+
+c #po write (1,1447)
+1447 format(' OCEANIC CURRENT (x-Direction)')
+c #po write (1,1432) ((uocnPO(i,j),i=ii1,ii2),j=jj1,jj2)
+
+c #po write (1,1448)
+1448 format(' OCEANIC CURRENT (y-Direction)')
+c #po write (1,1432) ((vocnPO(i,j),i=ii1,ii2),j=jj1,jj2)
+
+c #po write (1,1449)
+1449 format(' LEAD CONCENTRATION')
+c #po write (1,1432) ((aPOlyn(i,j),i=ii1,ii2),j=jj1,jj2)
+
+ write (1,1650)
+1650 format(' LONGITUDE')
+ write (1,1432) ((NST__x(i,j),i=ii1,ii2),j=jj1,jj2)
+
+ write (1,1651)
+1651 format(' LATITUDE')
+ write (1,1432) ((NST__y(i,j),i=ii1,ii2),j=jj1,jj2)
+
+ write (1,1652)
+1652 format(' SIGMA')
+ write (1,1432) sigma
+
+ close (1)
+
+ write(6,*) 'Surface charact. file MARdom.dat created'
+
+ ENDIF
+
+
+C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Output file for dynamics : MARdyn.DAT
+C =====================================
+
+ IF (NSTini.and.LoutDA.and.NSTmod.ne.'M2D'.and.
+ . NSTmod.ne.'CPL') THEN
+
+ IF (ASCfor) THEN
+
+ open (unit=11,status='unknown',
+ . file=NSTdir(1:nbchar)//'MARdyn.DAT')
+ rewind 11
+ write (11,*) itexpe,jdh_LB
+ write (11,*) iyrDYN,mmaDYN,jdaDYN,jhuDYN
+ write (11,*) imez,jjmez
+ write (11,*) GElat0,GElon0
+ write (11,*) sigma,ptopDY,dx,dy
+ write (11,*) NST__u
+ write (11,*) NST__v
+ write (11,*) NSTtmp
+ write (11,*) pstDY
+ write (11,*) NST_qv
+ write (11,*) NST_sh
+ write (11,*) pstDY
+ write (11,*) iyrDYN,mmaDYN,jdaDYN,jhuDYN,jdh_LB
+ write (11,*) vaxgLB,vaxdLB,vayiLB,vaysLB
+ write (11,*) NST_st
+ write (11,*) uairUB,vairUB,pktaUB ! version MAR > 20/02/04
+ close(unit=11)
+
+ ELSE
+
+ open (unit=11,status='unknown',form='unformatted',
+ . file=NSTdir(1:nbchar)//'MARdyn.DAT')
+ rewind 11
+ write (11) itexpe,jdh_LB
+ write (11) iyrDYN,mmaDYN,jdaDYN,jhuDYN
+ write (11) imez,jjmez
+ write (11) GElat0,GElon0
+ write (11) sigma ,ptopDY,dx,dy
+ write (11) NST__u
+ write (11) NST__v
+ write (11) NSTtmp
+ write (11) pstDY
+ write (11) NST_qv
+ write (11) NST_sh
+ write (11) pstDY
+ write (11) iyrDYN,mmaDYN,jdaDYN,jhuDYN,jdh_LB
+ write (11) vaxgLB,vaxdLB,vayiLB,vaysLB
+ write (11) NST_st
+ write (11) uairUB,vairUB,pktaUB ! version MAR > 20/02/04
+ close(unit=11)
+
+ ENDIF
+
+ write(6,*) 'Initialization file MARdyn.DAT created'
+
+ ENDIF
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Output for soil and surface layer : MARsol.DAT
+C + ==============================================
+
+ IF (NSTini.and.LoutDA.and.NSTmod.ne.'M2D'.and.
+ . NSTmod.ne.'CPL') THEN
+
+ IF (ASCfor) THEN
+
+ open (unit=11,status='unknown',
+ . file=NSTdir(1:nbchar)//'MARsol.DAT')
+ rewind 11
+ write (11,*) itexpe
+ write (11,*) iyrDYN,mmaDYN,jdaDYN,jhuDYN
+ write (11,*) nSLsrf
+ write (11,*) SLsrfl
+ write (11,*) tairSL
+ write (11,*) tsrfSL
+ write (11,*) alb0SL,eps0SL
+ write (11,*) SaltSL
+ write (11,*) ro_SL
+ write (11,*) ro_SL
+ write (11,*) d1_SL
+ write (11,*) t2_SL
+ write (11,*) w2_SL,wg_SL
+ write (11,*) roseSL
+ write (11,*) qvapSL
+ write (11,*) hsnoSL
+ write (11,*) hmelSL
+ write (11,*) SLuusl,SL_z0
+ write (11,*) SLutsl,SL_r0
+ close(unit=11)
+
+ ELSE
+
+ open (unit=11,status='unknown',form='unformatted',
+ . file=NSTdir(1:nbchar)//'MARsol.DAT')
+ rewind 11
+ write (11) itexpe
+ write (11) iyrDYN,mmaDYN,jdaDYN,jhuDYN
+ write (11) nSLsrf
+ write (11) SLsrfl
+ write (11) tairSL
+ write (11) tsrfSL
+ write (11) alb0SL,eps0SL
+ write (11) SaltSL
+ write (11) ro_SL
+ write (11) ro_SL
+ write (11) d1_SL
+ write (11) t2_SL
+ write (11) w2_SL ,wg_SL
+ write (11) roseSL
+ write (11) qvapSL
+ write (11) hsnoSL
+ write (11) hmelSL
+ write (11) SLuusl,SL_z0
+ write (11) SLutsl,SL_r0
+ close(unit=11)
+
+ ENDIF
+
+ write(6,*) 'Initialization file MARsol.DAT created'
+
+ ENDIF
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Output for SVAT model : MARsvt.DAT
+C + ==================================
+
+ IF (NSTini.and.SVTmod.and.LoutDA) THEN
+
+ IF (ASCfor) THEN
+
+ open (unit=11,status='unknown',
+ . file=NSTdir(1:nbchar)//'MARsvt.DAT')
+ rewind 11
+ write (11,*) itexpe
+ write (11,*) iyrDYN,mmaDYN,jdaDYN,jhuDYN
+ write (11,*) igrdIO
+ write (11,*) jgrdIO
+ IF (NSTmod.eq.'M2D') THEN
+ write (11,*) veg_1D
+ write (11,*) iwf_1D
+ write (11,*) dsa_1D
+ write (11,*) svt_1D
+ write (11,*) sfr_1D
+ write (11,*) lai_1D
+ write (11,*) glf_1D
+ write (11,*) ts__1D
+ write (11,*) sw__1D
+ ELSE
+ write (11,*) ((isolTV(i,j) ,i=ii1,ii2),j=jj1,jj2)
+ write (11,*) ((NSTiwf(i,j) ,i=ii1,ii2),j=jj1,jj2)
+ write (11,*) ((NSTdsa(i,j) ,i=ii1,ii2),j=jj1,jj2)
+ write (11,*) (((NSTsvt(i,j,k),i=ii1,ii2),j=jj1,jj2),
+ . k=1,nvx)
+ write (11,*) (((NSTsfr(i,j,k),i=ii1,ii2),j=jj1,jj2),
+ . k=1,nvx)
+ write (11,*) (((NSTlai(i,j,k),i=ii1,ii2),j=jj1,jj2),
+ . k=1,nvx)
+ write (11,*) (((NSTglf(i,j,k),i=ii1,ii2),j=jj1,jj2),
+ . k=1,nvx)
+ write (11,*) ((((NST_ts(i,j,k,l),i=ii1,ii2),j=jj1,jj2),
+ . k=1,nvx),l=1,nsl)
+ write (11,*) ((((NST_sw(i,j,k,l),i=ii1,ii2),j=jj1,jj2),
+ . k=1,nvx),l=1,nsl)
+ ENDIF
+ close(unit=11)
+
+ ELSE
+
+ open (unit=11,status='unknown',form='unformatted',
+ . file=NSTdir(1:nbchar)//'MARsvt.DAT')
+ rewind 11
+ write (11) itexpe
+ write (11) iyrDYN,mmaDYN,jdaDYN,jhuDYN
+ write (11) igrdIO
+ write (11) jgrdIO
+ IF (NSTmod.eq.'M2D') THEN
+ write (11) veg_1D
+ write (11) iwf_1D
+ write (11) dsa_1D
+ write (11) svt_1D
+ write (11) sfr_1D
+ write (11) lai_1D
+ write (11) glf_1D
+ write (11) ts__1D
+ write (11) sw__1D
+ ELSE
+ write (11) ((isolTV(i,j) ,i=ii1,ii2),j=jj1,jj2)
+ write (11) ((NSTiwf(i,j) ,i=ii1,ii2),j=jj1,jj2)
+ write (11) ((NSTdsa(i,j) ,i=ii1,ii2),j=jj1,jj2)
+ write (11) (((NSTsvt(i,j,k) ,i=ii1,ii2),j=jj1,jj2),
+ . k=1,nvx)
+ write (11) (((NSTsfr(i,j,k) ,i=ii1,ii2),j=jj1,jj2),
+ . k=1,nvx)
+ write (11) (((NSTlai(i,j,k) ,i=ii1,ii2),j=jj1,jj2),
+ . k=1,nvx)
+ write (11) (((NSTglf(i,j,k) ,i=ii1,ii2),j=jj1,jj2),
+ . k=1,nvx)
+ write (11) ((((NST_ts(i,j,k,l),i=ii1,ii2),j=jj1,jj2),
+ . k=1,nvx) ,l=1,nsl)
+ write (11) ((((NST_sw(i,j,k,l),i=ii1,ii2),j=jj1,jj2),
+ . k=1,nvx) ,l=1,nsl)
+ ENDIF
+ close(unit=11)
+
+ ENDIF
+
+ write(6,*) 'Initialization file MARsvt.DAT created'
+
+ ENDIF
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Output for boundary forcing : MARglf.DAT
+C + ========================================
+
+ IF (NSTini.and.SVTmod.and.LoutDA) THEN
+
+ NSTinfo = 'NESTOR_3.3'
+
+ IF (ASCfor) THEN
+ open (unit=13,status='unknown',
+ . file=NSTdir(1:nbchar)//'MARglf.DAT')
+ rewind 13
+ ELSE
+ open (unit=13,status='unknown',form='unformatted',
+ . file=NSTdir(1:nbchar)//'MARglf.DAT')
+ rewind 13
+ ENDIF
+
+ write(6,*) 'SVAT evolutive file MARglf.DAT created'
+
+ ENDIF
+
+ IF (NSTfor.and.SVTmod.and.LoutDA) THEN
+ IF (ASCfor) THEN
+ write (13,*) iyrDYN,mmaDYN,jdaDYN,jhuDYN,jdh_LB
+c #NI. ,NSTinfo
+ IF (NSTmod.eq.'M2D') THEN
+ write (13,*) glf_1D
+ write (13,*) lai_1D
+ ELSE
+ write (13,*) (((NSTglf(i,j,k),i=ii1,ii2),j=jj1,jj2),
+ . k=1,nvx)
+ write (13,*) (((NSTlai(i,j,k),i=ii1,ii2),j=jj1,jj2),
+ . k=1,nvx)
+ ENDIF
+ ELSE
+ write (13) iyrDYN,mmaDYN,jdaDYN,jhuDYN,jdh_LB
+c #NI. ,NSTinfo
+ IF (NSTmod.eq.'M2D') THEN
+ write (13) glf_1D
+ write (13) lai_1D
+ ELSE
+ write (13) (((NSTglf(i,j,k),i=ii1,ii2),j=jj1,jj2),
+ . k=1,nvx)
+ write (13) (((NSTlai(i,j,k),i=ii1,ii2),j=jj1,jj2),
+ . k=1,nvx)
+
+ ENDIF
+ ENDIF
+ IF (vrbose) THEN
+ write(6,*) 'SVAT evolutive file MARglf.DAT appended'
+ ENDIF
+ ENDIF
+
+ IF (NSTend.and.SVTmod.and.LoutDA) THEN
+ CLOSE(unit=13)
+ ENDIF
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Output for boundary forcing : MARlbc.DAT
+C + ========================================
+
+ IF (NSTini.and.LoutDA.and.NSTmod.ne.'M2D'.and.
+ . NSTmod.ne.'CPL') THEN
+
+ IF (ASCfor) THEN
+ open (unit=12,status='unknown',
+ . file=NSTdir(1:nbchar)//'MARlbc.DAT')
+ rewind 12
+ ELSE
+ open (unit=12,status='unknown',form='unformatted',
+ . file=NSTdir(1:nbchar)//'MARlbc.DAT')
+ rewind 12
+ ENDIF
+
+ write(6,*) 'Boundary forcing file MARlbc.DAT created'
+
+ ENDIF
+
+ IF (NSTfor.and.LoutDA.and.NSTmod.ne.'M2D'.and.
+ . NSTmod.ne.'CPL') THEN
+ IF (ASCfor) THEN
+ write (12,*) iyrDYN,mmaDYN,jdaDYN,jhuDYN,jdh_LB
+ write (12,*) vaxgLB,vaxdLB,vayiLB,vaysLB
+ write (12,*) NST_st
+ ELSE
+ write (12) iyrDYN,mmaDYN,jdaDYN,jhuDYN,jdh_LB
+ write (12) vaxgLB,vaxdLB,vayiLB,vaysLB
+ write (12) NST_st
+ ENDIF
+ IF (vrbose) THEN
+ write(6,*) 'Boundary forcing file MARlbc.DAT appended'
+ ENDIF
+ ENDIF
+
+ IF (NSTend.and.LoutDA.and.NSTmod.ne.'M2D'.and.
+ . NSTmod.ne.'CPL') THEN
+ CLOSE(unit=12)
+ ENDIF
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Output for boundary forcing : MARubc.DAT (version MAR > 20/02/04)
+C + ========================================
+
+ IF (NSTini.and.LoutDA.and.NSTmod.ne.'M2D'.and.
+ . NSTmod.ne.'CPL') THEN
+
+ IF (ASCfor) THEN
+ open (unit=17,status='unknown',
+ . file=NSTdir(1:nbchar)//'MARubc.DAT')
+ rewind 17
+ ELSE
+ open (unit=17,status='unknown',form='unformatted',
+ . file=NSTdir(1:nbchar)//'MARubc.DAT')
+ rewind 17
+ ENDIF
+
+ write(6,*) 'Boundary forcing file MARubc.DAT created'
+
+ ENDIF
+
+ IF (NSTfor.and.LoutDA.and.NSTmod.ne.'M2D'.and.
+ . NSTmod.ne.'CPL') THEN
+ IF (ASCfor) THEN
+ write (17,*) iyrDYN,mmaDYN,jdaDYN,jhuDYN,jdh_LB
+ write (17,*) uairUB,vairUB,pktaUB
+ ELSE
+ write (17) iyrDYN,mmaDYN,jdaDYN,jhuDYN,jdh_LB
+ write (17) uairUB,vairUB,pktaUB
+ ENDIF
+ IF (vrbose) THEN
+ write(6,*) 'Boundary forcing file MARubc.DAT appended'
+ ENDIF
+ ENDIF
+
+ IF (NSTend.and.LoutDA.and.NSTmod.ne.'M2D'.and.
+ . NSTmod.ne.'CPL') THEN
+ CLOSE(unit=17)
+ ENDIF
+
+
+C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Output for boundary forcing : MARsic.DAT (version MAR > 20/02/04)
+C + ========================================
+
+ IF (NSTini.and.LoutDA.and.NSTmod.ne.'M2D'.and.
+ . NSTmod.ne.'CPL') THEN
+
+ IF (ASCfor) THEN
+ open (unit=16,status='unknown',
+ . file=NSTdir(1:nbchar)//'MARsic.DAT')
+ rewind 16
+ ELSE
+ open (unit=16,status='unknown',form='unformatted',
+ . file=NSTdir(1:nbchar)//'MARsic.DAT')
+ rewind 16
+ ENDIF
+
+ write(6,*) 'Boundary forcing file MARsic.DAT created'
+
+ ENDIF
+
+ IF (NSTfor.and.LoutDA.and.NSTmod.ne.'M2D'.and.
+ . NSTmod.ne.'CPL') THEN
+ IF (ASCfor) THEN
+ write (16,*) iyrDYN,mmaDYN,jdaDYN,jhuDYN,jdh_LB
+ write (16,*) NSTsic
+ ELSE
+ write (16) iyrDYN,mmaDYN,jdaDYN,jhuDYN,jdh_LB
+ write (16) NSTsic
+ ENDIF
+ IF (vrbose) THEN
+ write(6,*) 'Boundary forcing file MARsic.DAT appended'
+ ENDIF
+ ENDIF
+
+ IF (NSTend.and.LoutDA.and.NSTmod.ne.'M2D'.and.
+ . NSTmod.ne.'CPL') THEN
+ CLOSE(unit=16)
+ ENDIF
+
+
+C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Output for sea surface temperature : MARsst.dat
+C + ===============================================
+
+ IF (NSTini.and.LoutDA.and.NSTmod.eq.'M2D') THEN
+
+ open (unit=14,status='unknown',
+ . file=NSTdir(1:nbchar)//'MARsst.dat')
+ rewind 14
+ write(6,*) 'Sea surface temp file MARsst.dat created'
+
+ ENDIF
+
+ IF (NSTfor.and.LoutDA.and.NSTmod.eq.'M2D') THEN
+ DO i=1,mx
+ write(14,*) sst1D(i)
+ ENDDO
+ IF (vrbose) THEN
+ write(6,*) 'Sea surface temp file MARsst.dat appended'
+ ENDIF
+ ENDIF
+
+ IF (NSTend.and.LoutDA.and.NSTmod.eq.'M2D') THEN
+ CLOSE(unit=14)
+ ENDIF
+
+ IF (NSTini.or.vrbose) THEN
+ write(6,*)
+ ENDIF
+
+C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+ RETURN
+ END
diff --git a/MAR/code_nestor/src/MARvar.inc b/MAR/code_nestor/src/MARvar.inc
new file mode 100644
index 0000000000000000000000000000000000000000..3af5214ae74660391e2da164eaa8efc77d504516
--- /dev/null
+++ b/MAR/code_nestor/src/MARvar.inc
@@ -0,0 +1,255 @@
+!-SPECIFIC VARIABLES FOR MAR
+!-(Modele Atmospherique Regional)
+!-===============================
+
+!-Parameters
+! ----------
+
+ INTEGER mzz
+ PARAMETER (mzz=mz+1)
+
+
+!-Variables of MARgrd.inc
+! -----------------------
+
+ REAL dx,dy,dt,dtquil,tequil
+! .... dx : horizontal grid size (x direction)
+! .... dy : horizontal grid size (y direction)
+! .... dt : time step
+! .... dtquil: Time Step for 1-D Initialisation (s)
+! .... tequil: Time Span for 1-D Initialisation (s)
+
+ INTEGER imez,jmez
+! .... imez : reference grid point (x direction)
+! .... jmez : reference grid point (y direction)
+
+ REAL sigma(mz),sh(mx,my)
+! .... sigma : independant variable sigma on sigma levels (k)
+! .... sh : surface height (m)
+
+! #CO COMMON / MARgrd / dx,dy,dt,dtquil,tequil,imez,jmez,sigma,sh
+
+
+!-Variables of MAR_GE.inc
+! -----------------------
+
+ REAL GElat0,GElon0,GEddxx
+! .... GElat0: Latitude (Degrees)
+! .... GElon0: Longitude (Degrees)
+! .... GEddxx: Direction x-axis
+
+! #CO COMMON / MAR_GE1 / GElat0,GElon0
+ COMMON / MAR_GE2 / GEddxx
+
+!-Variables of MAR_DY.inc
+! -----------------------
+
+ INTEGER iyrDYN,mmaDYN,jdaDYN,jhuDYN
+! .... iyrDYN: Year
+! .... mmaDYN: Month
+! .... jdaDYN: Day
+! .... jhuDYN: Hour (UT)
+
+ REAL pstDY (mx,my) ,ptopDY , &
+ & fcorDY(mx,my)
+! ###& ,uairDY(mx,my,mz) ,vairDY(mx,my,mz), &
+! ###& ,pktaDY(mx,my,mzz),tairDY(mx,my,mz), &
+! ###& ,qvDY (mx,my,mz)
+! .... uairDY: x-wind speed component (m/s)
+! .... vairDY: y-wind speed component (m/s)
+! .... pktaDY: potential temperature divided by 100.[kPa]**(R/Cp)
+! .... tairDY: real temperature (K)
+! .... qvDY : Specific Humidity (kg/kg)
+! .... qsatDY: Saturation Specific Humidity (kg/kg)
+! .... pstDY1: Model Pressure Depth at INITIAL Time Step (kPa)
+! .... pstDY : Model Pressure Depth at current Time Step (kPa)
+! .... ptopDY: Pressure at Model Top (kPa)
+! .... fcorDY: Coriolis Parameter (s-1)
+
+! #CO COMMON / MAR_DY / iyrDYN,mmaDYN,jdaDYN,jhuDYN,uairDY,vairDY, &
+! #CO& pktaDY,tairDY,pkDY ,qvDY ,pstDY ,ptopDY, &
+! #CO& fcorDY
+
+
+!-Variables of MAR_SL.inc
+! -----------------------
+
+ INTEGER isolSL(mx,my),maskSL(mx,my),nSLsrf(mx,my)
+! .... isolSL : Surface Type : 1 -> open ocean
+! .... 2 -> glacier + ice sheet + snow
+! .... 3 -> sea ice (+ snow)
+! .... 4 -> soil (+ snow)
+! .... 5 -> soil + vegetation
+! .... maskSL : Land--Sea Mask 0 -> Continent
+! .... 1 -> Ocean
+! .... nSLsrf : Number of Sectors in a Grid Box
+
+ REAL zs_SL,zn_SL,zl_SL,cs2SL,sst_SL,dtagSL, &
+ & wk0SL,wx0SL,w20SL,wg0SL
+! .... zs_SL : Typical Sea Roughness Length (m)
+! .... zn_SL : Typical Snow Roughness Length (m)
+! .... zl_SL : Typical Land Roughness Length (m)
+! .... cs2SL : Soil Temperature Variation Time Scale (s)
+! .... (usually 86400 s, i.e. diurnal cycle)
+! .... sst_SL: Sea Surface Temperature
+! .... dtagSL: Air-Surface Temperature Difference (K)
+! .... w**SL : Initial soil humidity variables
+
+ REAL tairSL(mx,my) , &
+ & tsrfSL(mx,my,mw),qvapSL(mx,my) , &
+ & alb0SL(mx,my) ,albeSL(mx,my) , &
+ & albsSL(mx,my) ,eps0SL(mx,my) , &
+ & SLsrfl(mx,my,mw),SL_z0(mx,my,mw) , &
+ & SL_r0 (mx,my,mw),SLlmo(mx,my) , &
+ & SLlmol(mx,my,mw),SLuus(mx,my) , &
+ & SLuusl(mx,my,mw),SaltSL(mx,my) , &
+ & virSL (mx,my) ,fracSL , &
+ & SLuts (mx,my) ,SLutsl(mx,my,mw), &
+ & SLuqs (mx,my) ,SLuqsl(mx,my,mw), &
+ & ch0SL (mx,my) ,roseSL(mx,my) , &
+ & raerSL(mx,my) ,rsurSL(mx,my) , &
+ & hmelSL(mx,my) ,ro_SL0(mx,my) , &
+ & ro_SL (mx,my) ,d1_SL (mx,my) , &
+ & t2_SL (mx,my) ,w2_SL (mx,my) , &
+ & wg_SL (mx,my) ,hsnoSL(mx,my)
+! .... tairSL : Extrapolation of the sounding tempature to the surface.(K)
+! .... tsrfSL : Surface Temperature (K)
+! .... qvapSL : specific humidity close to the surface (kg/kg)
+! .... alb0SL : Background Surface Albedo
+! .... albeSL : Surface Albedo
+! .... albsSL : Underlaying Soil Albedo
+! .... eps0SL : Surface IR Emissivity
+! .... SLsrfl : Normalized Sector Area (m/s)
+! .... SL_z0 : Roughness Length for Momentum (m/s)
+! .... SL_r0 : Roughness Length for Heat (m/s)
+! .... SLlmo : Monin-Obukhov Length (Average) (m/s)
+! .... SLlmol : Monin-Obukhov Length (m/s)
+! .... SLuus : Friction Velocity (Average) (m/s)
+! .... SLuusl : Friction Velocity (m/s)
+! .... SaltSL : Friction Velocity Saltation Threshold (m/s)
+! .... virSL : Air Loading for SBL Parameterization
+! .... fracSL : Fractional Time used in Blowing Snow Surface Flux Computation
+! .... SLuts : Surface Potential Temperature Turbulent Flux (Average) (K.m/s)
+! .... SLutsl : Surface Potential Temperature Turbulent Flux (K.m/s)
+! .... SLuqs : Surface Specific Humidity Turbulent Flux (Av.) (kg/kg.m/s)
+! .... SLuqsl : Surface Specific Humidity Turbulent Flux (kg/kg.m/s)
+! .... ch0SL : Bulk Aerodynamic Coefficient Air/Surface Humidity Flux
+! .... roseSL : Depletion of water vapor in the surface layer (kg/kg)
+! .... due to deposition of dew or rime on ground
+! .... raerSL :`Bulk' Stomatal Resistance (Thom & Oliver, 1977, p. 347)
+! .... rsurSL : Aerodynamic Resistance
+! .... hmelSL : cumulative snowmelt height (m water equivalent)
+! .... hsnoSL : cumulative snow accumulation height (m water equivalent)
+! .... ro_SL : rhos (Surface Density) (kg/m3)
+! .... ro_SL0 : rhos (Initial Surface Density) (kg/m3)
+! .... d1_SL : rhos * cs *(Depth diurnal Wave) (J/m2/K)
+! .... t2_SL : Soil Deep Layers Temperature (K)
+! .... dtgSL : Soil Temperature Variation during time interval dt (K)
+! .... Is renewed every 6 minutes
+! .... wg_SL and w2_SL Adimensional Numbers measuring Soil Water Content
+! .... wg_SL : ... near the Surface
+! .... w2_SL : ... over a large Soil Thickness
+
+! #CO COMMON / MAR_SL / isolSL,maskSL,nSLsrf,zs_SL,zn_SL,zl_SL, &
+! #CO& cs2SL,sst_SL,dtagSL,wk0SL,wx0SL,w20SL, &
+! #CO& wg0SL,tairSL,tsrfSL,qvapSL,alb0SL,albeSL, &
+! #CO& albsSL,eps0SL,SLsrfl,SL_z0,SL_r0,SLlmo, &
+! #CO& SLlmol,SLuus,SLuusl,SaltSL,virSL,fracSL, &
+! #CO& SLuts,SLutsl,SLuqs,SLuqsl,ch0SL,roseSL, &
+! #CO& raerSL,rsurSL,hmelSL,ro_SL0,ro_SL,d1_SL, &
+! #CO& t2_SL,w2_SL,wg_SL
+
+
+!-Variables of MAR_TV.inc
+! -----------------------
+
+ INTEGER isolTV(mx,my)
+! .... isolTV : Texture Type : 2 -> loamy sand
+! .... 5 -> loam
+! .... 11 -> clay
+
+
+!-Variables of MAR_TU.inc
+! -----------------------
+
+ REAL TUkhff,TUkhmx
+! .... TUkhff: Horiz.vKar**2 (horizontal diffusion)
+! .... TUkhmx: Upper sponge
+
+! #CO COMMON / MAR_TU / TUkhff,TUkhmx
+
+
+!-Variables of MAR_LB.inc
+! -----------------------
+
+ INTEGER iyr_LB,mma_LB,jda_LB,jhu_LB,jdh_LB
+! .... iyr_LB: Year
+! .... mma_LB: Month
+! .... jda_LB: Day
+! .... jhu_LB: Hour (UT)
+! .... jdh_LB: Time Interval before next GCM/NWP LBC (hour)
+! .... jdh_LB=0 ==> NO further GCM/NWP LBC available
+
+ REAL vaxgLB(1:n7,my,mz,5),vaxdLB(mx-n6:mx ,my,mz,5), &
+ & vayiLB(mx,1:n7,mz,5),vaysLB(mx,my-n6:my ,mz,5)
+! .... vaXX : large scale values of relevant dependant variables
+! .... ^X=(x->x axis border, y->y axis border)
+! .... ^X=(g->x small, d->x large, b->y small, h->y large)
+
+! #CO COMMON / MAR_LB / iyr_LB,mma_LB,jda_LB,jhu_LB,jdh_LB, &
+! #CO& vaxgLB,vaxdLB,vayiLB,vaysLB
+
+
+!-Variables of MAR_PO.inc
+! -----------------------
+
+ REAL uocnPO(mx,my),vocnPO(mx,my),aPOlyn(mx,my)
+! .... uocnPO: Oceanic Current (prescribed, x-direction)
+! .... vocnPO: Oceanic Current (prescribed, y-direction)
+! .... aPOlyn: Initial (observed) lead fraction
+! .
+! #CO COMMON / MAR_PO / uocnPO,vocnPO,aPOlyn
+
+
+!-Variables of MAR_IO.inc
+! -----------------------
+
+ INTEGER igrdIO(5),jgrdIO(5)
+! .... igrdIO: i (x-direc.) Index Ref. Grid Point (for detailed Output)
+! .... jgrdIO: j (y-direc.) Index Ref. Grid Point (for detailed Output)
+
+ CHARACTER*3 explIO
+
+! #CO COMMON / MAR_IO / igrdIO,jgrdIO,explIO
+
+
+!-Variables of MAR_FI.inc
+! -----------------------
+
+ REAL FIslot,FIslou,FIslop,FIkhmn
+! .... FIslot: Implicit Filter Parameter (Temperature)
+! .... FIslou: Implicit Filter Parameter (Wind Speed)
+! .... FIslop: Implicit Filter Parameter (Pressure)
+! .... FIkhmn: Horizontal Diffusion Coefficient
+
+! #CO COMMON / MAR_FI / FIslot,FIslou,FIslop,FIkhmn
+
+
+!-Other variables
+! ---------------
+
+ INTEGER maptyp
+ INTEGER*8 itexpe
+! .... maptyp: Projection Type
+! .... itexpe: Iteration number
+
+ REAL zmin,aavu,bbvu,ccvu
+! .... zmin : height of the first model level from the surface (m)
+! .... aavu : grid parameter (geometric progression)
+! .... bbvu : grid parameter (geometric progression)
+! .... ccvu : grid parameter (geometric progression)
+
+ LOGICAL vertic
+
+! #CO COMMON / MARoth / itexpe,zmin,aavu,bbvu,ccvu,vertic
+ COMMON / MARmap / maptyp
diff --git a/MAR/code_nestor/src/MERlai.f b/MAR/code_nestor/src/MERlai.f
new file mode 100644
index 0000000000000000000000000000000000000000..7a6eea440a8a16687e8f47bf6c5e09004088d292
--- /dev/null
+++ b/MAR/code_nestor/src/MERlai.f
@@ -0,0 +1,239 @@
+C +-------------------------------------------------------------------+
+C | Subroutine MODlai Apr 2023 NESTING |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE MERlai
+
+ IMPLICIT none
+
+
+C +---General variables
+C + -----------------
+
+ INCLUDE 'NSTdim.inc'
+ INCLUDE 'NSTvar.inc'
+ INCLUDE 'LOCfil.inc'
+ INCLUDE 'NetCDF.inc'
+ INCLUDE 'NESTOR.inc'
+
+ real ,parameter :: reso_y=0.0042 !ny/cy
+ real ,parameter :: reso_x=0.0042 !nx/cx
+ real ,parameter :: MOD_lon=-0.4996
+ real ,parameter :: MOD_lat=46.9046
+
+
+ integer,parameter :: cx = 2750 ! I of MODIS
+ integer,parameter :: cy = 1700 ! J of MODIS
+
+ integer ii,jj,i,j,k,l, i1,i2,j1,j2
+ integer NET_ID_LAI,NET_ID_GLF,NETcid,Rcode,start(4),count(4)
+ integer nbr_day,i_cent,j_cent,G_nx,G_ny, nerror
+
+ real AUXlon,AUXlat,debug
+ real AUXlo1,AUXlo2,AUXla1,AUXla2
+ real MODIS_lai(cx,cy),nsamp, laisum
+
+ integer DATiyr,DATmma,DATjda,DATjhu
+
+ CALL DATcnv (DATiyr,DATmma,DATjda,DATjhu,DATtim,.false.)
+
+ nbr_day=0
+
+ do i=1,DATmma-1
+ if(i==1.or.i==3.or.i==5.or.i==7.or.i==8.or.i==10.or.i==12)
+ . nbr_day=nbr_day+31
+ if(i==4.or.i==6.or.i==9.or.i==11) nbr_day=nbr_day+30
+ if(i==2) nbr_day=nbr_day+28
+ enddo
+
+ nbr_day=nbr_day+DATjda
+
+!-----------------------------------------------------------------------
+
+ NETcid = NCOPN("input/VEGE/Climato_non_leap_year.nc"
+ . ,NCNOWRIT,Rcode)
+ NET_ID_LAI = NCVID(NETcid,'LAI',Rcode)
+
+ ! NET_ID_GLF = NCVID(NETcid,'GLF',Rcode) removed GLF for now and
+ ! it will be 0.93
+
+ start(1)=1
+ start(2)=1
+ start(3)=nbr_day ! time step
+ count(1)=cx
+ count(2)=cy
+ count(3)=1
+
+ Rcode = nf_get_vara_real(NETcid,NET_ID_LAI,start,count,MODIS_lai)
+ !Rcode = nf_get_vara_real(NETcid,NET_ID_GLF,start,count,MODIS_glf)
+
+ CALL NCCLOS(NETcid, RCODE)
+
+
+!-----------------------------------------------------------------------
+
+ write(6,*) 'MERRA2 LAI-GLF data set'
+ write(6,*) '~~~~~~~~~~~~~~~~~~~~~~~'
+ write(6,*) ' '
+
+ nerror = 0
+
+ DO j=1,my !Loop on each Y of MAR
+ DO i=1,mx !Loop on each x of MAR
+
+C + *****
+ IF(NSTsol(i,j)>=3.and.NST__y(i,j)>-60.)THEN !if not on ice
+C + *****
+
+ if(NSTsvt(i,j,1)<=0.or.NSTsvt(i,j,1)==13) then
+ DO l=1,nvx
+ NSTlai(i,j,l) = 0.0
+ NSTglf(i,j,l) = 0.0
+ enddo
+ else
+
+ AUXlon = NST__x(i,j)
+ AUXlat = NST__y(i,j)
+
+C +---Search for the closest point in data file
+C + -----------------------------------------
+
+ i_cent=NINT((AUXlon-REAL(MOD_lon))/reso_x)+1
+ j_cent=NINT((AUXlat-REAL(MOD_lat))/reso_y)+1
+
+
+C +---Compute the resolution of the considered NST cell
+C + -------------------------------------------------
+
+ ii = MAX(i,2)
+ jj = MAX(j,2)
+
+ AUXlo1 = NST__x(ii ,jj )
+ AUXla1 = NST__y(ii ,jj )
+ AUXlo2 = NST__x(ii-1,jj-1)
+ AUXla2 = NST__y(ii-1,jj-1)
+
+
+C +---Define the data points to be read around (i_cent,j_cent)
+C + --------------------------------------------------------
+
+
+ G_nx=MAX(NINT(ABS(AUXlo1-AUXlo2)/reso_x),0)
+ G_ny=MAX(NINT(ABS(AUXla1-AUXla2)/reso_y),0)
+
+ i1=i_cent-G_nx
+ i2=i_cent+G_nx
+ j1=j_cent-G_ny
+ j2=j_cent+G_ny
+
+ ! not to go out of domain
+ i1=MAX(i1,1)
+ i2=MIN(i2,cx)
+ j1=MAX(j1,1)
+ j2=MIN(j2,cy)
+
+
+C +---Read subset of data
+C + -------------------
+
+ nsamp =0
+ laisum=0.
+
+ DO l=j1,j2 ! Loop on data grid points
+ DO k=i1,i2 ! contained in the (i,j) NST cell
+
+
+ IF (MODIS_lai(k,cy-l+1).ge.0
+ . .and. MODIS_lai(k,cy-l+1).le.20) THEN
+ laisum=laisum+MAX(0.,MODIS_lai(k,cy-l+1))
+ nsamp =nsamp+1
+ ENDIF
+
+ ENDDO
+ ENDDO
+
+ IF (nsamp.eq.0) THEN
+ ! write(6,*) 'error at (', NST__x(i,j), NST__y(i,j),')'
+ ! write(6,*) "SVT:",NSTsvt(i,j,1)
+ nerror = nerror +1
+ ! debug = MOD_lon+ reso_x*i1
+ ! write(6,*)i1,i2,j1,j2
+ ! write(6,*) NST__x(i,j), debug
+ ! debug = MOD_lon+ reso_x*i2
+ ! write(6,*) NST__x(i,j), debug
+ ENDIF
+
+
+ DO l=1,nvx
+ NSTlai(i,j,l)=min(10.,laisum/nsamp) ! interpolate to NST grid
+ ENDDO
+! -----------------------------------------------
+
+ DO l=1,nvx
+ NSTglf(i,j,l)= 0.93 ! interpolate to NST grid
+ ENDDO
+
+! -----------------------------------------------
+
+ DO l=1,nvx !For each vegetation type, we define a LAI max --> is
+ !also in GLOveg.f
+ IF (NSTsvt(i,j,l).eq. 0) NSTlmx(i,j,l) = 0.0
+ IF (NSTsvt(i,j,l).eq. 1) NSTlmx(i,j,l) = 0.6
+ IF (NSTsvt(i,j,l).eq. 2) NSTlmx(i,j,l) = 0.9
+ IF (NSTsvt(i,j,l).eq. 3) NSTlmx(i,j,l) = 1.2
+ IF (NSTsvt(i,j,l).eq. 4) NSTlmx(i,j,l) = 0.7
+ IF (NSTsvt(i,j,l).eq. 5) NSTlmx(i,j,l) = 1.4
+ IF (NSTsvt(i,j,l).eq. 6) NSTlmx(i,j,l) = 2.0
+ IF (NSTsvt(i,j,l).eq. 7.or.NSTsvt(i,j,l).eq.10)
+ . NSTlmx(i,j,l) = 3.0
+ IF (NSTsvt(i,j,l).eq. 8.or.NSTsvt(i,j,l).eq.11)
+ . NSTlmx(i,j,l) = 4.5
+ IF (NSTsvt(i,j,l).eq. 9.or.NSTsvt(i,j,l).eq.12)
+ . NSTlmx(i,j,l) = 6.0
+
+ ENDDO
+
+! -----------------------------------------------
+
+ DO l=1,nvx
+
+ ! NSTlai(i,j,l) = NSTlai(i,j,l) *
+ !. max(1.,min(2.,(1.+(NSTlmx(i,j,l)-3.)/12.)))
+
+ ! MERRA lai = mean lai over 50 x 50 km2
+ ! it is a bit corrected here in fct of vegetation.
+
+ !NSTlai(i,j,l) =max(0.,min(1.25*NSTlmx(i,j,l),NSTlai(i,j,l)))
+ ! maximum values are a bit too low in respect to literature
+
+ if(NSTsvt(i,j,l)<=0.or.NSTsvt(i,j,l)==13) then
+ NSTlai(i,j,l) = 0.0
+ NSTglf(i,j,l) = 0.0
+ endif ! city or bare soil or ice
+
+ ENDDO
+ endif
+! -----------------------------------------------
+
+C + ****
+ ELSE ! Ocean, ice, snow
+C + ****
+
+ DO l=1,nvx
+ NSTlai(i,j,l) = 0.0
+ NSTglf(i,j,l) = 0.0
+ ENDDO
+
+C + *****
+ ENDIF ! Continental areas
+C + *****
+
+ ENDDO
+ ENDDO
+ write(6,*)"Number of errors", nerror
+
+ END SUBROUTINE
+
+!--------------------------------------------------------------------------------------------------------------------------
+
+
diff --git a/MAR/code_nestor/src/MRLvgd.f b/MAR/code_nestor/src/MRLvgd.f
new file mode 100644
index 0000000000000000000000000000000000000000..83e2ead3f750749e8a4ec3fc1bc6926d206191d3
--- /dev/null
+++ b/MAR/code_nestor/src/MRLvgd.f
@@ -0,0 +1,113 @@
+C +-------------------------------------------------------------------+
+C | Subroutine MRLvgd 13-04-2022 JFG |
+C +-------------------------------------------------------------------+
+C | |
+C | Creation of the vertical grid of the MAR model (as LSC source). |
+C | MRL stands for "MaR Lsc". This code was initially part of the |
+C | MARvgd original routine, but was separated in two routines |
+C | (MRLvgd and MRNvgd) for convenience and readability. |
+C | |
+C | Input : - fID : identificator of the Netcdf data file |
+C | ^^^^^^^ - nk : number of vertical levels |
+C | - baseI : minimum X index of the relevant LSC sub-region |
+C | - baseJ : minimum Y index of the relevant LSC sub-region |
+C | - maxI : maximum X index of the relevant LSC sub-region |
+C | - maxJ : maximum Y index of the relevant LSC sub-region |
+C | - klev : if specified, the level at which pressure and |
+C | hybrid coordinate has to be computed |
+C | - VGD_sp(ni,nj) : surface pressure (kPa) |
+C | |
+C | Output: Vertical grid of the MAR model in hybrid coordinates : |
+C | ^^^^^^^ - VGD__p(ni,nj,nk+1) : pressure coordinates (kPa) |
+C | - VGD_hp(ni,nj,nk+1) : local hybrid coord. for vertical |
+C | interpolation |
+C | |
+C | Remarks on optimization via sub-region selection (29/05/2022): |
+C | -to compute the vertical grid for the full LSC domain, use |
+C | baseI=1, baseJ=1, maxI=ni, maxJ=nj. |
+C | -code assumes that the user will use 1 <= baseI <= maxI <= ni and |
+C | 1 <= baseJ <= maxJ <= nj. |
+C | -if the variables baseI, baseJ, maxI and maxJ are set to delimit |
+C | a sub-region of the LSC grid, only this sub-region will be |
+C | completed in the output grids. |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE MRLvgd (fID,ni,nj,nk,baseI,baseJ,maxI,maxJ,klev,
+ . VGD_sp,VGD__p,VGD_hp)
+
+ IMPLICIT NONE
+
+C +---Local variables
+C + ---------------
+
+ INTEGER fID,ni,nj,baseI,baseJ,maxI,maxJ,nk,klev,i,j,k,k1,k2
+
+ REAL pp1,pps,ppm,dpsl,pp,hh,ppf,ptopDY,empty1(1)
+
+ REAL VGD_sp(ni,nj),VGD_hp(ni,nj,nk+1),VGD__p(ni,nj,nk+1),sigma(nk)
+
+ CHARACTER*10 var_units
+
+C +---CREATION OF SIGMA MAR GRID USING LSC NetCDF FILE
+C + ================================================
+
+C +---Read SIGMA in NetCDF file
+C + -------------------------
+
+ CALL UNsread (fID,'level',0,0,0,0,nk,1,1,var_units,sigma)
+
+C +---HYBRID AND PRESSURE COORDINATES (required by the nesting code)
+C + ===============================
+
+C +---Selection of vertical levels
+C + ----------------------------
+
+ IF ((klev.le.0).or.(klev.gt.nk)) THEN
+ k1=1
+ k2=nk
+ ELSE
+ k1=1
+ k2=klev
+ ENDIF
+
+C +---Reference levels for hybrid coordinates
+C + ---------------------------------------
+
+ pp1 = 105. ! Reference pressure (KPa)
+ dpsl = 20. ! "> boundary layer" (KPa)
+
+ ptopDY = 0.01
+
+C +---For each i,j pixel (start of grid traversal)
+C + --------------------------------------------
+C + 29/05/2022: added a small optimization; grid traversal now only
+C + takes account of the sub-region of the LSC domain which includes
+C + the NST domain.
+
+ DO i=baseI,maxI ! i=1,ni
+ DO j=baseJ,maxJ ! j=1,nj
+
+C +---Computation of hybrid coordinates used in vertic. interp.
+C + ---------------------------------------------------------
+
+ pps = VGD_sp(i,j)
+ ppm = pps - dpsl
+ DO k = k1,k2+1
+ IF (k.eq.(nk+1)) THEN
+ pp = VGD_sp(i,j)
+ ELSE
+ pp = sigma(k)*(VGD_sp(i,j)-ptopDY) + ptopDY
+ ENDIF
+ hh = pp/pp1
+ IF (pp.gt.ppm) THEN
+ ppf= (pp-ppm)/(pps-ppm)
+ hh = hh + (pp1-pps)/pp1 * ppf * ppf
+ ENDIF
+ VGD_hp(i,j,k) = LOG(hh)
+ VGD__p(i,j,k) = pp
+ ENDDO
+
+ END DO; END DO ! End of grid traversal
+
+ RETURN
+ END
diff --git a/MAR/code_nestor/src/MRNvgd.f b/MAR/code_nestor/src/MRNvgd.f
new file mode 100644
index 0000000000000000000000000000000000000000..86ac9a6c7259ff62c8cc630a4046df948e7f4567
--- /dev/null
+++ b/MAR/code_nestor/src/MRNvgd.f
@@ -0,0 +1,433 @@
+C +-------------------------------------------------------------------+
+C | Subroutine MRNvgd 13-04-2022 JFG |
+C +-------------------------------------------------------------------+
+C | |
+C | Creation of the vertical grid of the MAR model (as NST output). |
+C | MRN stands for "MaR Nst". This code was initially part of the |
+C | MARvgd original routine, but was separated in two routines |
+C | (MRLvgd and MRNvgd) for convenience and readability. |
+C | |
+C | Input : - nz : number of vertical levels (N.B.: nz rather |
+C | ^^^^^^^ than nk because nk already used in NSTdim.inc) |
+C | - klev : if specified, the level at which pressure and |
+C | hybrid coordinate has to be computed |
+C | - VGD_sp(mx,my) : surface pressure (kPa) |
+C | - parameters from MARgrd.ctr |
+C | - dimensions from NSTdim.inc (e.g. mx, my) |
+C | |
+C | Output: Vertical MAR grid given in hybrid coordinates : |
+C | ^^^^^^^ - VGD__p(mx,my,nz+1) : pressure coordinates (kPa) |
+C | - VGD_hp(mx,my,nz+1) : local hybrid coord. for vertical |
+C | interpolation |
+C | - VGDgdz(nz ) : model coordinates (sigma) |
+C | |
+C | J.-F. Grailet remark: contrary to LSCvgd and its associated |
+C | routines, VGDgdz has been kept because it appears to be actually |
+C | used in a meaningful way by NESTOR (could be checked thoroughly). |
+C | Only change here is the position of the parameter in the list. |
+C | |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE MRNvgd (nz,klev,VGD_sp,VGD__p,VGD_hp,VGDgdz)
+
+ IMPLICIT NONE
+
+ INCLUDE 'CTRvar.inc' ! For NSTfis (JFG remark: seems to be unused)
+ INCLUDE 'NSTdim.inc'
+
+C +---Local variables
+C + ---------------
+
+ INTEGER nz,klev,i,j,k,k1,k2,maptyp,imez,jmez
+
+ ! J.-F. Grailet remark: GElat0 and GElon0 appear to be unused.
+ REAL pp1,pps,ppm,dpsl,pp,hh,ppf,GElat0,GElon0,dx,GEddxx,
+ . ptopDY,zmin,aavu,bbvu,ccvu,sst_SL,TUkhmx
+
+ REAL VGD_sp(mx,my),VGD__p(mx,my,nz+1),VGD_hp(mx,my,nz+1),
+ . VGDgdz(nz),sigma(nz)
+
+ LOGICAL vertic
+
+ CHARACTER*10 var_units
+
+ REAL MARsig(mz)
+ COMMON/cMARvgd/MARsig
+C See MARout.f
+
+ IF (mz.NE.nz) THEN
+ write(*,*) 'Wrong #levels in MRNvgd ?'
+ STOP
+ ENDIF
+
+C +---CREATION OF SIGMA MAR GRID USING PARAMETERS IN MARgrd.ctr
+C + =========================================================
+
+C +---Read grid parameters in MARgrd.ctr
+C + ----------------------------------
+
+ OPEN (unit=51,status='old',file='MARgrd.ctr')
+
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) maptyp
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) GElon0
+ read (51,*) imez
+ read (51,*) GElat0
+ read (51,*) jmez
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) dx
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) GEddxx
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) ptopDY
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) zmin
+ read (51,*) aavu
+ read (51,*) bbvu
+ read (51,*) ccvu
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,'(l4)') vertic
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) sst_SL
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) NSTfis
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+
+
+ CLOSE(unit=51)
+
+C +---Sets the standard values of vertical grid parameters
+C + ----------------------------------------------------
+
+ CALL SETsig(nz,zmin,aavu,bbvu,ccvu,ptopDY)
+
+C +---Computation of vertical grid
+C + ----------------------------
+
+ CALL GRDsig(nz,zmin,aavu,bbvu,ccvu,vertic,sst_SL,TUkhmx,sigma)
+
+C +---Sigma coordinates
+C + -----------------
+
+ DO k=1,nz
+ VGDgdz(k)=sigma(k)
+ MARsig(k)=sigma(k)
+ ENDDO
+
+C +---HYBRID AND PRESSURE COORDINATES (required by the nesting code)
+C + ===============================
+
+C +---Selection of vertical levels
+C + ----------------------------
+
+ IF ((klev.le.0).or.(klev.gt.nz)) THEN
+ k1=1
+ k2=nz
+ ELSE
+ k1=1
+ k2=klev
+ ENDIF
+
+C +---Reference levels for hybrid coordinates
+C + ---------------------------------------
+
+ pp1 = 105. ! Reference pressure (KPa)
+ dpsl = 20. ! "> boundary layer" (KPa)
+
+ IF (ptopDY.LT.1.0E-10) THEN
+ write(*,*) 'Something is probably going wrong in MRNvgd'
+ write(*,*) 'ptopDY= ',ptopDY
+ write(*,*)
+ ENDIF
+
+C +---For each i,j pixel (start of grid traversal)
+C + --------------------------------------------
+
+ DO i=1,mx
+ DO j=1,my
+
+C +---Computation of hybrid coordinates used in vertic. interp.
+C + ---------------------------------------------------------
+
+ pps = VGD_sp(i,j)
+ ppm = pps - dpsl
+ DO k = k1,k2+1
+ IF (k.eq.(nz+1)) THEN
+ pp = VGD_sp(i,j)
+ ELSE
+ pp = VGDgdz(k)*(VGD_sp(i,j)-ptopDY) + ptopDY
+ ENDIF
+ hh = pp/pp1
+ IF (pp.gt.ppm) THEN
+ ppf= (pp-ppm)/(pps-ppm)
+ hh = hh + (pp1-pps)/pp1 * ppf * ppf
+ END IF
+ VGD_hp(i,j,k) = LOG(hh)
+ VGD__p(i,j,k) = pp
+ ENDDO
+
+ END DO; END DO ! End of grid traversal
+
+ RETURN
+ END
+
+C +------------------------------------------------------------------------+
+C | 19-06-2004 MAR ? |
+C | SubRoutine SETsig sets the standard values of vert grid parameters |
+C | |
+C +------------------------------------------------------------------------+
+C | INPUT : mz, + all other arguments if not equal to '0' |
+C | ^^^^^^^^ |
+C | |
+C | OUTPUT : zmin : Height above Surface / 1st sigma level (m) |
+C | ^^^^^^^^ aavu,bbvu,ccvu : Vertical Discretization Parameters |
+C | pt : Pressure at the top of the model (kPa) |
+C | |
+C | J.-F. Grailet remark: this routine has been kept unchanged. |
+C | |
+C +------------------------------------------------------------------------+
+
+ subroutine SETsig (mz,zmin,aavu,bbvu,ccvu,pt)
+
+ IMPLICIT NONE
+
+ INTEGER mz,mmz
+
+ REAL aavu,bbvu,ccvu,zmin,pt,INzmin,INaavu,INbbvu,INccvu
+
+ mmz = mz
+ INzmin = zmin
+ INaavu = aavu
+ INbbvu = bbvu
+ INccvu = ccvu
+
+C Prescribed values for vertical grid parameters
+C ----------------------------------------------
+
+ IF (mmz.eq.10) THEN
+ zmin = 10.
+ aavu = 2.0
+ bbvu = 1.25
+ ccvu = 2000.
+ ENDIF
+
+ IF (mmz.eq.18.or.mmz.eq.19) THEN
+ zmin = 10.
+ aavu = 2.0
+ bbvu = 1.17
+ ccvu = 1200.
+ ENDIF
+
+ IF (mmz.eq.20.or.mmz.eq.29) THEN
+ zmin = 3.
+ aavu = 1.8
+ bbvu = 1.13
+ ccvu = 1000.
+ ENDIF
+
+ IF (mmz.eq.30.or.mmz.eq.31) THEN
+ zmin = 5.
+ aavu = 2.0
+ bbvu = 1.11
+ ccvu = 900.
+ ENDIF
+
+ IF (mmz.eq.40) THEN
+ zmin = 5.
+ aavu = 2.0
+ bbvu = 1.06
+ ccvu = 2500.
+ ENDIF
+
+ IF (mmz.eq.60) THEN
+ zmin = 2.
+ aavu = 2.0
+ bbvu = 1.10
+ ccvu = 70.
+ ENDIF
+
+C Forcing with values given in MARgrd.ctr
+C ---------------------------------------
+
+ IF (INzmin.ne.0.) zmin=INzmin
+ IF (INaavu.ne.0.) aavu=INaavu
+ IF (INbbvu.ne.0.) bbvu=INbbvu
+ IF (INccvu.ne.0.) ccvu=INccvu
+
+C If insufficient informations ...
+C --------------------------------
+
+ IF (zmin.eq.0..or.aavu.eq.0..or.bbvu.eq.0..or.ccvu.eq.0.) THEN
+ WRITE(6,*) 'Chooses other parameters for z-grid Set-Up!'
+ WRITE(6,*) 'Program is stopped in SETsig!'
+ STOP
+ ENDIF
+
+ RETURN
+ END
+
+C +------------------------------------------------------------------------+
+C | MAR GRID 19-06-2004 MAR |
+C | SubRoutine GRDsig is used to initialize the vertical grid |
+C | |
+C +------------------------------------------------------------------------+
+C | |
+C | ASSUMPTION: Sigma is calculated from initial level height amsl |
+C | ^^^^^^^^^^^ assumig that T(msl) = SST |
+C | dT/dz = -0.0065 K/m |
+C | p_s = 100 hPa |
+C | |
+C | INPUT : zmin : Height above Surface / 1st Sigma Level (m) |
+C | ^^^^^^^^ aavu,bbvu,ccvu : Vertical Discretization Parameters |
+C | vertic : Logical Variable caracteris.vertic.discris.|
+C | |
+C | OUTPUT : Variable which is initialized is: |
+C | ^^^^^^^^ sigma(mz): Independant Variable (Normalized Pressure) |
+C | |
+C | J.-F. Grailet remark: zpbl is no longer an output variable, as I |
+C | realized it was not used in any meaningful way by the NESTOR code I |
+C | was provided with. The corresponding parameter has been simply |
+C | commented for the record; the rest of the routine has not been edited. |
+C | |
+C +------------------------------------------------------------------------+
+
+ subroutine GRDsig(mz,zmin,aavu,bbvu,ccvu,vertic,
+ . sst_SL,TUkhmx,sigma) ! ,zpbl
+
+ implicit none
+C +
+C +
+C +--General Variables
+C + =================
+C +
+ integer k,kk,mzz,mz
+C +
+ real zmin,aavu,bbvu,ccvu,zpbl(mz),sigma(mz),ps_sig,ga,
+ . ga0,aa,bb,cc,vu,ra,gravit,unun,sst_SL,dzz,rz,rzb,
+ . TUkhmx,zzo,zero,epsi
+C +
+ logical vertic
+
+C +
+C +--DATA
+C + ====
+C +
+ data ps_sig / 101.3d0 /
+C +
+ data ga0 / 0.0065d0/
+C +... ga0 : Standard Atmospheric Lapse Rate
+ data ra / 287.d0 /
+ data gravit / 9.81d0 /
+ data unun / 1.d0 /
+ data zero / 0.d0 /
+ data epsi / 1.0d-6 /
+
+C +
+C +--Initialization
+C + ==============
+C +
+ mzz=mz+1
+ DO k=1,mz
+ zpbl(k)=0.
+ ENDDO
+C +
+C +--Temperature Vertical Profile
+C + ============================
+C +
+ ga = ga0
+C +
+C +--Sigma Levels
+C + ============
+C +
+C +- 1) Coarse Resolution of the Surface Layer
+C + -----------------------------------------
+C +
+ if (.not.vertic) then
+C +
+C + aa = 0.5
+C + bb = 1.5
+C + cc =-1.0
+C +... Reference : E. Richard, these, 1991, p.29
+C +
+ vu = 0.0d0
+ do k=1,mz
+ vu = vu + 1.0d0/dble(mzz)
+ sigma(k) = aavu*vu + bbvu*vu*vu + ccvu*vu*vu*vu
+C +
+ if (abs(ga).gt.1.d-5) then
+ zpbl(k) =-( sst_SL /ga) * ((1.d0+(sigma(k)-1.d0)
+ . *(1.d2/ps_sig))
+ . **(ra*ga/gravit)-1.d0)
+ else
+ zpbl(k) =-(ra*sst_SL /gravit ) *log((unun+(sigma(k)-unun)
+ . *(1.d2/ps_sig)))
+ end if
+ enddo
+C +
+C +
+C +- 2) Fine Resolution of the Surface Layer
+C + -----------------------------------------
+C +
+ else
+C +
+ ga =max(ga,epsi)
+C +
+ zpbl(1)= zmin
+ zpbl(2)=2.d0*zmin
+C +
+ dzz =0.d0
+
+ do k=3,mz
+ rz =zmin*aavu **FLOAT(k-1)
+ rzb =ccvu*bbvu **FLOAT(k-1)
+ zpbl(k)=rzb *rz /(rz + rzb )
+C +
+ zzo = zpbl(k)
+ zpbl(k)= max(zpbl(k),zpbl(k-1)+zpbl(2))
+ dzz = max(zpbl(k)-zzo, zero ) + dzz
+ enddo
+
+ do k=1,mz
+ kk=mz+1-k
+
+C + sigma(kk)=(ps_sig/100.d0)
+C + Arbitraire et pas utile a mon avis (PhM)
+C +
+ sigma(kk)= 1.0d0
+ . *((1.0d0-ga*zpbl(k)/sst_SL)**(gravit/(ga*ra))-1.d0)+1.d0
+
+C +... sigma(kk): the fine resolution of the surface layer is computed
+C + using a geometric progression
+C +
+ enddo
+ end if
+C +
+ do k=1,mz
+ if (sigma(k).le.0.0)then
+
+ print *, "ERROR in MRNvgd.f: sigma < 0."
+
+ do kk=1,mz
+ print *,kk,sigma(mz+1-kk),zpbl(kk)
+ enddo
+
+ print *, "Change aavu, bbvu, ccvu in MARgrd.ctr or mz"
+ print *, "For example: try to decrease ccvu in MARgrd.ctr"
+ stop
+
+ endif
+ enddo
+C +
+C +... JFG remark: not sure these messages are useful. I commented
+C + them just in case rather than removing them.
+C +
+C write(*,*) 'MAR vertical grid created'
+C write(*,*) '~~~~~~~~~~~~~~~~~~~~~~~~~ '
+C write(*,*) ' '
+
+ return
+ end
diff --git a/MAR/code_nestor/src/NESTOR.f b/MAR/code_nestor/src/NESTOR.f
new file mode 100644
index 0000000000000000000000000000000000000000..a60eb62d73c45ade51bde0b50832f698506b5ee8
--- /dev/null
+++ b/MAR/code_nestor/src/NESTOR.f
@@ -0,0 +1,830 @@
+C +************************************************************************+
+C | |
+C | |
+C | ************************************ |
+C | * * |
+C | * N E S T O R * |
+C | * * |
+C | ************************************ |
+C | |
+C | |
+C | NESTing Organization for the preparation of |
+C | meteorological and surface fields in Regional models |
+C | |
+C | \__ _ ____ / |
+C | \_/ **** / \ |
+C | / \ ****** / / \ |
+C | / \ ****** | / | |
+C | .... \ / / UCL-IAG |
+C | ..... \/___/ LGGE |
+C | ..... / LTHE |
+C | |
+C | |
+C | Institut d'Astronomie et de Geophysique Georges Lemaitre |
+C | |
+C | Universite catholique de Louvain |
+C | Chemin du Cyclotron, 2 |
+C | 1348 Louvain-la-Neuve - BELGIUM |
+C | |
+C | - - - - - - - - - - - - - - - - - |
+C | |
+C | L. G. G. E. - G R E N O B L E |
+C | |
+C | Laboratoire de Glaciologie et de Geophysique de l'Environnement |
+C | Rue Moliere, 54 - BP 96 |
+C | 38402 St-Martin d'Heres CEDEX |
+C | |
+C | |
+C | - - - - - - - - - - - - - - - - - |
+C | |
+C | L. T. H. E. - G R E N O B L E |
+C | |
+C | Laboratoire d'Etude des Transferts en Hydrologie et Environnement |
+C | Domaine Universitaire - BP 53 |
+C | Rue de la Piscine 1023-1025 |
+C | 38041 Grenoble Cedex 9 - FRANCE |
+C | |
+C +************************************************************************+
+C | |
+C | NESTOR 4.1.5 Date : 25 Jan 2022 |
+C | ------------ ------ |
+C | |
+C | Development : |
+C | |
+C | Olivier Brasseur (brasseur@oma.be): |
+C | General structure, development (several components). |
+C | |
+C | Hubert Gallee (gallee@lgge.obs.ujf-grenoble.fr): |
+C | General structure, MAR team manager. |
+C | |
+C | Philippe Marbaix (marbaix@astr.ucl.ac.be): |
+C | Development (1st version, atmospheric data interpolation) |
+C | |
+C | Xavier Fettweis (xavier.fettweis@uliege.be) |
+C | Maintainer: version NESTOR > 4.0.0 |
+C | |
+C | J.-F; Grailet (Jean-Francois.Grailet@uliege.be) |
+C | 2022 optimization (version 4.x.y TODO) |
+C | |
+C +************************************************************************+
+
+ PROGRAM NESTOR
+
+C +************************************************************************+
+
+ IMPLICIT NONE
+
+C +---LSC and NST domain dimensions
+C + -----------------------------
+
+ INCLUDE 'NSTdim.inc'
+
+C +---LSC,INT,NST variables
+C + ---------------------
+
+ INCLUDE 'CTRvar.inc'
+ INCLUDE 'LSCvar.inc'
+ INCLUDE 'INTvar.inc'
+ INCLUDE 'NSTvar.inc'
+ INCLUDE 'LSCmod.inc'
+ INCLUDE 'DESvar.inc'
+ INCLUDE 'NESTOR.inc'
+
+C +---Soil and surface data files locations
+C + -------------------------------------
+ INCLUDE 'LOCfil.inc'
+
+C +---Local variables
+C + ---------------
+
+ INTEGER VARSIZE
+ EXTERNAL VARSIZE
+
+ LOGICAL Vtrue
+
+C +---Additions by J.-F. Grailet (warnings about unusable parameters)
+C + ---------------------------------------------------------------
+
+ INTEGER selMod !, rainDg, metWGE
+ LOGICAL useSnd, SSTrey
+
+C +---Data
+C + ----
+
+ DATA Vtrue / .true. /
+
+C +---Soil and surface data files locations
+C + -------------------------------------
+C + (code to actually set the paths)
+ INCLUDE 'LOCset.inc'
+
+C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+C +---START MESSAGE
+C + =============
+
+ write(6,*)
+ write(6,*)
+ write(6,*) ' ***********************************************'
+ write(6,*) ' * *'
+ write(6,*) ' * N E S T O R *'
+ write(6,*) ' * *'
+ write(6,*) ' * NESTing Organization for the preparation *'
+ write(6,*) ' * of meteorological and surface fields in *'
+ write(6,*) ' * 3-D Regional models. *'
+ write(6,*) ' * *'
+C +---J.-F. Grailet (02/05/2022): as rain disagregation and wind gust
+C + estimate moves have been removed (temporarily ?), the next four
+C + lines have been commented for accuracy.
+C write(6,*) ' * Rain disagregation models *'
+C write(6,*) ' * *'
+C write(6,*) ' * Wind gust estimate methods *'
+C write(6,*) ' * *'
+ write(6,*) ' ***********************************************'
+ write(6,*)
+ write(6,*) ' --- Version 4.1.8 --- '
+ write(6,*) ' --- 20/06/2004 --- '
+ write(6,*)
+ write(6,*)
+
+C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+C + Reading of control file
+C + =======================
+
+ OPEN (unit=20,status='old',file='NSTing.ctr')
+
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,'(i4)') selMod
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,'(A3)') LABLio
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,'(A60)') NSTdir
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,'(A3)') LSCmod
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,'(A3)') NSTmod
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,'(A3)') region
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,'(i4,3(x,i2))') RUNiyr,RUNmma,RUNjda,RUNjhu
+ read (20,'(i10,x,i2)') DURjda,DURjhu
+ read (20,'(i13)') FORjhu
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,'(l4)') LoutDA
+ read (20,'(l4)') ASCfor
+ read (20,'(l4)') LoutLS
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,'(l4)') SPHgrd
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,*) HORint
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,*) VERint
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,'(l4)') TOPetopo
+ read (20,'(a4)') TOP30 ! WARNING: string on purpose !!!
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,'(l4)') TOPcst
+ read (20,'(l4)') TOPcstLSC
+ read (20,'(l4)') TOPdomLSC
+ read (20,'(l4)') TOPcst0
+ read (20,'(l4)') TOPfilt
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,'(l4)') CORzz6
+ read (20,'(l4)') CORsurf
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,'(l4)') RUGdat
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,'(l4)') VEGdat
+ read (20,'(l4)') VEGcor
+ read (20,'(l4)') VEGcov
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,'(l4)') NDV1km
+ read (20,'(l4)') MERRA_lai ; NDV8km=.false.
+ if(MERRA_lai) NDV1km=.false.
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,'(l4)') SVTmod
+ read (20,*) SVTwet
+ read (20,'(l4)') SVTlsc
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,'(l4)') SSTrey
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,'(l4)') useSnd
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,*) ! Ignored | read (20,'(A57)') SNDfil
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,'(l4)') CLDcor
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,*) ! Ignored | read (20,'(i4)') rainDg
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,*) ! Ignored | read (20,'(i4)') metWGE
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+ read (20,*) !- - - - - - - - - - - - - - - - - -
+
+ ! Add this when NSTing.ctr files will be updated
+ ! read (20,*) !- - - - - - - - - - - - - - - - - -
+ ! read (20,*) !- - - - - - - - - - - - - - - - - -
+ ! read (20,'(l4)') vrbose
+ ! read (20,*) !- - - - - - - - - - - - - - - - - -
+
+ CLOSE(unit=20)
+
+ vrbose=.false. ! Hard-coded for now
+
+C + ******
+ CALL WARNms
+C + ******
+
+C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+C + Special message(s) (J.-F. Grailet): updated or removed features
+C + ===============================================================
+
+ WRITE(6,*) 'NOTA BENE: this version of NESTOR provides minimal'
+ WRITE(6,*) 'output for each time step (except for the first).'
+ WRITE(6,*) 'To have the whole console output provided by former'
+ WRITE(6,*) 'versions of NESTOR, please set the vrbose variable'
+ WRITE(6,*) 'to true in NESTOR.f. Activation of the verbose mode'
+ WRITE(6,*) 'via NST script and NSTing.ctr files will be made'
+ WRITE(6,*) 'possible later.'
+
+ IF ((selMod.NE.1).or.useSnd.or.TOP30.eq.'T '.or.SSTrey) THEN
+ WRITE(6,*)
+ WRITE(6,*) 'WARNING: your NSTing.ctr file is providing values'
+ WRITE(6,*) 'corresponding to features that are no longer'
+ WRITE(6,*) 'usable in NESTOR. The execution will stop now to'
+ WRITE(6,*) 'let you review the deprecated features you wanted'
+ WRITE(6,*) 'to use (see below) and modify your control file'
+ WRITE(6,*) 'accordingly. NST script and NSTing.ctr control'
+ WRITE(6,*) 'will be updated later.'
+ WRITE(6,*)
+ IF (selMod.NE.1) THEN
+ WRITE(6,*) 'Rain disagregation and wind gust estimation modes'
+ WRITE(6,*) 'are deprecated.'
+ ENDIF
+ IF (useSnd) THEN
+ WRITE(6,*) 'Initialization with sounding is deprecated.'
+ ENDIF
+ IF (TOP30.eq.'T ') THEN
+ WRITE(6,*) 'GTOPO dataset (ETOPOg routine) is deprecated.'
+ ENDIF
+ IF (SSTrey) THEN
+ WRITE(6,*) 'Imposed Reynolds SST is deprecated.'
+ ENDIF
+ STOP
+ ENDIF
+
+ IF (VERint.EQ.3.AND.nk.lt.mz) THEN
+ VERint=1
+ WRITE(6,*)
+ WRITE(6,*) 'WARNING: vertical cubic interpolation is not'
+ WRITE(6,*) 'recommended with nk < mz. The number of vertical'
+ WRITE(6,*) 'levels in the source data should be greater than'
+ WRITE(6,*) 'or equal to the number of vertical levels in the'
+ WRITE(6,*) 'output. Otherwise, results may be unsatisfying.'
+ WRITE(6,*) 'To enforce VERint=3 with nk < mz, edit the NESTOR.f'
+ WRITE(6,*) 'source file and re-compile NESTOR.'
+ ENDIF
+
+ IF (.not.SVTmod) THEN
+ SVTmod = .true.
+ WRITE(6,*)
+ WRITE(6,*) 'WARNING: the De Ridder and Schayes soil model is'
+ WRITE(6,*) 'imposed in the current NESTOR version. To enforce'
+ WRITE(6,*) 'it, please modify NESTOR.f and re-compile NESTOR.'
+ ENDIF
+
+ WRITE(6,*)
+
+C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ WRITE(6,*) "NESTOR characteristics"
+ WRITE(6,*) "~~~~~~~~~~~~~~~~~~~~~~"
+
+C +---MODELS
+C + ======
+
+ WRITE(6,'(A,$)') ' Forcing fields (LSC) : '
+
+ IF (LSCmod.eq.'ECM') WRITE(6,*) 'ECMWF - Hybrid levels'
+ IF (LSCmod.eq.'E15') WRITE(6,*) 'ERA-15 - Hybrid levels'
+ IF (LSCmod.eq.'E40') WRITE(6,*) 'ERA-40 - Hybrid levels'
+ IF (LSCmod.eq.'E20') WRITE(6,*) 'ERA-20C - Hybrid levels'
+ IF (LSCmod.eq.'ER5') WRITE(6,*) 'ERA5 - Hybrid levels'
+ IF (LSCmod.eq.'EIN') WRITE(6,*) 'ERA-Interim - Hybrid levels'
+ IF (LSCmod.eq.'ECP') WRITE(6,*) 'ECMWF - Pressure levels'
+ IF (LSCmod.eq.'MAR') WRITE(6,*) 'MAR'
+ IF (LSCmod.eq.'NCP') WRITE(6,*) 'NCEP'
+ IF (LSCmod.eq.'GFS') WRITE(6,*) 'GFS'
+ IF (LSCmod.eq.'ALA') WRITE(6,*) 'ALADIN'
+ IF (LSCmod.eq.'CAN') WRITE(6,*) 'CanESM2 (CMIP5)'
+ IF (LSCmod.eq.'CM3') WRITE(6,*) 'HadCM3 (ICE2SEA)'
+ IF (LSCmod.eq.'EM5') WRITE(6,*) 'ECHAM5 (ICE2SEA)'
+ IF (LSCmod.eq.'NOR') WRITE(6,*) 'NorESM1 (CMIP5)'
+ IF (LSCmod.eq.'CSI') WRITE(6,*) 'CSIRO-Mk3 (CMIP5)'
+ IF (LSCmod.eq.'BCC') WRITE(6,*) 'BCC-CSM1-1 (CMIP5)'
+ IF (LSCmod.eq.'20C') WRITE(6,*)
+ . '20th Century Reanalysis V2 (NOAA-CIRES)'
+ IF (LSCmod.eq.'MIR') WRITE(6,*) 'MIROC5 (CMIP5)'
+ IF (LSCmod.eq.'CM5') WRITE(6,*) 'CNRM-CM5 (CMIP5)'
+ IF (LSCmod.eq.'AC3') WRITE(6,*) 'ACCESS1-3 (CMIP5)'
+ IF (LSCmod.eq.'NC1') WRITE(6,*) 'NCEP-NCAPv1'
+ IF (LSCmod.eq.'NC2') WRITE(6,*) 'NCEP-NCAPv2'
+ IF (LSCmod.eq.'JRA') WRITE(6,*) 'JRA-55'
+ IF (LSCmod.eq.'ME2') WRITE(6,*) 'MERRA2 (NASA)'
+
+
+ WRITE(6,'(A,$)') ' Nested model (NST) : '
+
+ IF (NSTmod.eq.'MAR') WRITE(6,*) 'MAR'
+ IF (NSTmod.eq.'M2D') WRITE(6,*) 'MAR - 2D version'
+ IF (NSTmod.eq.'GRA') WRITE(6,*) 'GRADS'
+ IF (NSTmod.eq.'CPL') WRITE(6,*) 'SVAT - Coupling'
+
+ WRITE(6,*)
+
+ IF (LSCmod.eq.'MAR') THEN
+ REGgrd=.false. ! Non-regular input grid (lat/long)
+ ELSE
+ REGgrd=.true. ! Regular input grid (lat/long)
+ ENDIF
+
+ f28d=.false.
+ IF (LSCmod.EQ.'CM3') M30d=.true.
+ IF (LSCmod.EQ.'CAN') f28d=.true.
+ IF (LSCmod.EQ.'NOR') f28d=.true.
+ IF (LSCmod.EQ.'MIR') f28d=.true.
+ IF (LSCmod.EQ.'CSI') f28d=.true.
+ IF (LSCmod.EQ.'BCC') f28d=.true.
+
+C +---REGION
+C + ======
+
+ WRITE(6,'(A,$)') ' Region : '
+
+ IF (mw.EQ.1) STOP '#@!& mw badly specified / must be > 1'
+
+ IF (region.eq.'GRD') then
+ WRITE(6,*) 'GRD (Greenland)'
+ USRreg='GRD'
+ ENDIF
+ IF (region.eq.'ANT') then
+ WRITE(6,*) 'ANT (Antarctic)'
+ IF (mw.NE.2) STOP '#@!& mw badly specified / must be = 2'
+ region='GRD'
+ USRreg='ANT'
+ ENDIF
+ IF (region.eq.'EUR') WRITE(6,*) 'EUR (Europe)'
+ IF (region.eq.'WAF') region="AFW"
+ IF (region.eq.'AFW') THEN
+ WRITE(6,*) 'AFW (West Africa)'
+ END IF
+ IF (region.eq.' NO') WRITE(6,*) 'No specified'
+
+C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+C +---CONTROL OF DATES
+C + ================
+
+C +---Initial, incremental, and final dates of run
+C + --------------------------------------------
+
+C + ******
+ CALL DATcnv (RUNiyr,RUNmma,RUNjda,RUNjhu,DATini,Vtrue)
+C + ******
+C +...Initial date of run
+
+ DAT_dt=FORjhu
+C +...Time interval
+
+ DATfin=DATini+24*DURjda+DURjhu
+C +...End date of run
+
+C +---Number of steps
+C + ---------------
+
+ DATstp=(DATfin-DATini)/DAT_dt + 1
+
+C +---Initialisation
+C + --------------
+
+ DATtim=DATini
+
+C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+C +---HORIZONTAL GRID IN NESTED MODEL
+C + ===============================
+
+C +---Modele Atmospherique Regional (MAR)
+C + -----------------------------------
+
+ IF (NSTmod.eq.'MAR'.or.NSTmod.eq.'M2D') THEN
+
+C + ******
+ CALL MARhgd
+C + ******
+
+ ENDIF
+
+C +---GRADS graphic output
+C + --------------------
+
+ IF (NSTmod.eq.'GRA') THEN
+
+C + ******
+ CALL GRAhgd
+C + ******
+
+ ENDIF
+
+C +---Hydrology - meteo coupling
+C + --------------------------
+
+ IF (NSTmod.eq.'CPL') THEN
+
+C + ******
+ CALL CPLhgd
+C + ******
+
+ ENDIF
+
+C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+C +---TOPOGRAPHY SOURCES
+C + ==================
+C +
+C +---Bamber data set (1 km)/Racmo2 topo
+C + ----------------------------------
+ IF (USRreg.eq."ANT" ) THEN
+
+C + ******
+ CALL ETOPO1 ! ETOPO 1min
+ CALL ICEmsk !
+C + ******
+
+ IF (TOP30.eq."NSID" .OR. TOP30.eq."nsid") THEN
+
+C + ******
+ CALL USRann('NSIDC ') !+ NSIDC (2009) +!
+C + ******
+
+ ELSE
+
+C + ******
+ CALL USRant('bedmac') !+ 'Bamber' (2009)/'bedmap' (2013)/'Racmo2' / 'bedmac' 'Bedmachinev2,2019) +!
+C + ******
+
+ END IF
+C +
+C +---ETOPO data set (1/5 minutes)
+C + ----------------------------
+ ELSE IF (TOPetopo) THEN
+
+C + ******
+ CALL ETOPO1 ! ETOPO 1min
+ CALL ICEmsk
+C + ******
+
+ ENDIF ! GTOPO removed (old unmaintained code)
+
+C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---CORRECTION OF PRESCRIBED TOPOGRAPHY
+C + ===================================
+
+C +---Border of constant NST topography at boundaries
+C + -----------------------------------------------
+
+ IF (TOPcst) THEN
+
+ TOPopt=1
+C + ******
+ CALL TOPcor (TOPopt)
+C + ******
+
+ ENDIF
+
+
+C +---Zero topography in the relaxation zone
+C + --------------------------------------
+
+ IF (TOPcst0) THEN
+
+ TOPopt=4
+C + ******
+ CALL TOPcor (TOPopt)
+C + ******
+
+ ENDIF
+
+
+C +---Topography filtering (2D and 3D)
+C + --------------------------------
+
+ IF (TOPfilt) THEN
+
+ TOPopt=5
+
+ CALL LSCinp
+ CALL NSTint !! for having INT_sh
+
+ ! Additional line return outside verbose mode (prettier display)
+ IF (.not.vrbose) THEN
+ WRITE(6,*)
+ ENDIF
+
+C + ******
+ CALL TOPcor (TOPopt)
+C + ******
+
+ ELSE
+
+ print *,"Are you sure to not filter the topo"
+ . //" at the boundaries ???" ; stop
+
+ ENDIF
+
+C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---VEGETATION CHACTERISTICS
+C + ========================
+
+
+C +---Global land cover - IGBP (only Africa and Europe)
+C + -------------------------------------------------
+
+ IF (VEGdat.or.NDV1km) THEN
+
+C + ******
+ CALL GLOveg
+C + ******
+
+ ENDIF
+
+
+C +---Vegetation cover in Europe (Corine)
+C + -----------------------------------
+
+ IF (VEGcor) THEN
+
+C + ******
+ CALL CORveg
+C + ******
+
+ ENDIF
+
+
+C +---Vegetation cover in Belgium
+C + ---------------------------
+
+ IF (VEGbel) THEN
+
+C + ******
+ CALL BELveg
+C + ******
+
+ ENDIF
+
+C +---Global Vegetation cover
+C + -----------------------
+
+ IF (VEGcov) THEN
+
+C + ******
+ CALL GLOveg
+ CALL GLOcov
+C + ******
+
+ ENDIF
+
+C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---SOIL CHACTERISTICS
+C + ==================
+
+
+C +---FAO soil types classification
+C + -----------------------------
+
+C + ******
+c CALL FAOsol
+C + ******
+
+C +---GSWP soil types classification
+C + ------------------------------
+
+C + ******
+ CALL GSWPsl
+ CALL HWSDsl
+C + ******
+
+C +---Surface characteristics
+C + -----------------------
+
+C + ******
+ CALL SOLdom
+C + ******
+
+
+C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+C +---CORRECTED VEGETATION FRACTION WITH MAX. NDVI INDEX
+C + ==================================================
+
+
+C +---NDVI index (1 or 8 km resolution)
+C + ---------------------------------
+
+ IF (NDV1km.or.NDV8km) THEN
+
+C + ******
+ CALL GLOfrc
+C + ******
+
+ ENDIF
+
+ IF (USRreg.eq."ANT" ) THEN
+ IF (TOP30.eq."NSID" .OR. TOP30.eq."nsid") THEN
+C + ******
+ CALL USRann('NSIDC ') !+ NSIDC (2009) +!
+C + ******
+ ELSE
+C + ******
+ CALL USRant('bedmac') !+ 'Bamber' (2009)/'bedmap' (2013)/'Racmo2' / 'bedmac' 'Bedmachinev2,2019) +!
+C + ******
+ END IF
+ END IF
+
+C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ DO iter=1,DATstp ! TEMPORAL ITERATION
+
+C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+C +---SELECT A LSC DATA FILE
+C + ======================
+
+ IF (SVTmod) THEN
+
+C + ******
+ CALL LSCinp
+C + ******
+
+ ENDIF
+
+C +---MAIN TREATMENT
+C + ==============
+
+C +---1. Interpolation forcing fields for NST model
+C + ---------------------------------------------
+
+ IF (SVTmod) THEN
+
+C + ******
+ CALL NSTint
+C + ******
+
+ ENDIF
+
+C +---CORRECTION OF SURFACE CHARACTERISTICS
+C + =====================================
+
+ IF (iter.eq.1) THEN
+
+ ! Additional line return outside verbose mode (prettier display)
+ IF (.not.vrbose) THEN
+ WRITE(6,*)
+ ENDIF
+
+C + ******
+ CALL SOLdom
+C + ******
+
+ ENDIF
+
+C +...Note : this call is useful only if NSTint subroutine has
+C + modified the surface types (specified in NSTsol variable)
+
+C +---CORRECTION OF FIELDS IN THE SURFACE LAYER
+C + =========================================
+
+ IF (CORsurf) THEN
+
+C + ******
+ CALL SL_cor
+C + ******
+
+ ENDIF
+
+C +---PROGNOSTIC AND ADDITIONAL VARIABLES FOR SVAT MODEL
+C + ==================================================
+
+ IF (SVTmod) THEN
+
+C + ******
+ CALL SVTpar
+C + ******
+
+ ENDIF
+
+C +---CORRECTED GREEN LEAF FRACTION WITH NDVI INDEX
+C + =============================================
+
+C +---NDVI index (1 or 8-km resolution)
+C + ---------------------------------
+
+ IF (NDV1km.or.NDV8km) THEN
+
+C + ******
+ CALL GLOglf
+C + ******
+
+ ENDIF
+
+ IF(MERRA_lai) CALL MERlai
+
+C +---OUTPUT FILES
+C + ============
+
+C +---Modele Atmospherique Regional (MAR)
+C + -----------------------------------
+
+ IF (NSTmod.eq.'MAR'.or.NSTmod.eq.'M2D'.or.NSTmod.eq.'CPL') THEN
+
+C + ******
+ CALL MARout
+C + ******
+
+ ENDIF
+
+C +---GRAPHIC (NetCDF) FILES
+C + ======================
+
+C +---Standard fields
+C + ---------------
+
+ IF (LoutLS) THEN
+
+C + ******
+ CALL NSTout
+C + ******
+
+ ENDIF
+
+C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ DATtim=DATtim+DAT_dt
+
+ ENDDO ! TEMPORAL ITERATION
+
+C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+C + ******
+ CALL DATcnv (RUNiyr,RUNmma,RUNjda,RUNjhu,DATtim,Vtrue)
+C + ******
+
+ open (unit=1,status='replace',file='NST.OK')
+ write (1,111) RUNjda,RUNmma,RUNiyr,RUNjhu
+ 111 format("NESTOR execution stopped normaly the",i2,"/",i2,"/",i4,
+ . " at ",i2,"h.")
+ close(1)
+
+ write(6,*)
+ write(6,*)
+ write(6,*) ' ***********************************************'
+ write(6,*)
+ write(6,*) ' END OF N E S T O R '
+ write(6,*)
+ write(6,*)
+
+ END
diff --git a/MAR/code_nestor/src/NESTOR.inc b/MAR/code_nestor/src/NESTOR.inc
new file mode 100644
index 0000000000000000000000000000000000000000..e176ee985d1327c3fa6acafd1a5026612a8bee14
--- /dev/null
+++ b/MAR/code_nestor/src/NESTOR.inc
@@ -0,0 +1,41 @@
+
+! NESTOR.inc
+! ----------
+
+ CHARACTER*3 LABLio
+ CHARACTER*3 region !+ GRD for polar config +!
+ CHARACTER*3 USRreg !+ user region = GRD,ANT,KER,... +!
+ CHARACTER*4 TOP30
+ CHARACTER*60 NSTdir
+ CHARACTER*100 LSCfil
+
+ INTEGER RUNiyr,RUNmma,RUNjda,RUNjhu,I_time,DURjda, &
+ & DURjhu,FORjhu,HORint,VERint,TOPopt,DATstp, &
+ & iter
+
+ INTEGER*4 DATini,DAT_dt,DATfin,DATtim
+
+ REAL SVTwet,NDVmin(nbdom),NDVmax(nbdom)
+
+ LOGICAL LoutDA,LoutLS,VEGdat,VEGbel,TOPBE,VEGcov, &
+ & TOPetopo,TOPcst,TOPcstLSC,TOPdomLSC, &
+ & TOPcst0,TOPfilt,CORzz6,CORsurf,SVTmod, &
+ & ASCfor,CLDcor,VEGcor,NDV1km,NDV8km,SVTlsc, &
+ & RUGdat,MERRA_lai,vrbose
+
+
+ COMMON/NESTOR_c /LABLio,TOP30,NSTdir,LSCfil,region,USRreg
+
+ COMMON/NESTOR_i1/RUNiyr,RUNmma,RUNjda,RUNjhu,I_time,DURjda, &
+ & DURjhu,FORjhu,HORint,VERint,TOPopt,DATstp, &
+ & iter
+
+ COMMON/NESTOR_i2/DATini,DAT_dt,DATfin,DATtim
+
+ COMMON/NESTOR_l /LoutDA,LoutLS,VEGdat,VEGbel,TOPBE,VEGcov, &
+ & TOPetopo,TOPcst,TOPcstLSC,TOPdomLSC, &
+ & TOPcst0,TOPfilt,CORzz6,CORsurf,SVTmod, &
+ & ASCfor,CLDcor,VEGcor,NDV1km,NDV8km,SVTlsc, &
+ & RUGdat,MERRA_lai,vrbose
+
+ COMMON/NESTOR_r /NDVmin,NDVmax,SVTwet
diff --git a/MAR/code_nestor/src/NESTOR.stereo b/MAR/code_nestor/src/NESTOR.stereo
new file mode 100644
index 0000000000000000000000000000000000000000..6050156c5b7e6c0a92b1dad223f30c2329ac1ac9
--- /dev/null
+++ b/MAR/code_nestor/src/NESTOR.stereo
@@ -0,0 +1 @@
+ NSTrcl = 0.
diff --git a/MAR/code_nestor/src/NSTdim.inc b/MAR/code_nestor/src/NSTdim.inc
new file mode 100644
index 0000000000000000000000000000000000000000..2f0d6028ba25643a4ab0ab6bb13b2680f134be6c
--- /dev/null
+++ b/MAR/code_nestor/src/NSTdim.inc
@@ -0,0 +1,103 @@
+
+!-NST domain dimensions
+! ---------------------
+
+ INTEGER mx,my,mz,mzabso,mw,nvx,nsl,nsno,nbdom
+
+ PARAMETER (mx = 165) ! X-grid
+ PARAMETER (my = 150) ! Y-grid
+ PARAMETER (mz = 24) ! Z-grid
+
+ PARAMETER (mzabso= 3) ! Z-grid
+ ! can be higher on large domain
+
+ PARAMETER (nvx = 2) ! Sub-division of grid cell (SVAT)
+ ! nvx = 2 if GRD or ANT, nvx = 3 if EUR
+
+ PARAMETER (nsno = 21) ! Snow layers (Snow model)
+ ! nsno=30 if GRD or ANT, nsno=10 if EUR
+
+! ------------------------------------------
+
+ ! Don't touch to these parameters !!
+ PARAMETER (mw = nvx) ! Sub-division of grid cell (Deardorff)
+ PARAMETER (nsl = 7) ! Soil layers (SVAT)
+ PARAMETER (nbdom = 2) ! Number of continents ("GLOveg.f")
+
+!-Selector for vectorization of the MAR code
+! ------------------------------------------
+
+ LOGICAL vector
+
+ PARAMETER (vector = .false.)
+
+! "vector" is true only if the MAR code is run on vectorial computer
+
+
+
+!-LSC domain dimensions
+! ---------------------
+
+ INTEGER ni,nj,njv,nk,bi,bj,isLMz
+
+! A sub-region of the external large-scale domain is defined in order to
+! reduced the CPU cost and the memory requirement for the interpolation.
+
+!-1. SIZE of the SUB-REGION (in grid points)
+
+ PARAMETER (isLMz = 0)
+
+ PARAMETER (ni = 1200)
+ PARAMETER (nj = 137)
+ PARAMETER (njv= nj-isLMz)
+ PARAMETER (nk = 40)
+
+! Warning:
+! For LMDz, you may use the scalar grid size, nj= size(lat_s)
+! but in that case, you must set isLMz=1 (njv = nj-1)
+! For all other models, please set isLMz=0 (njv = nj )
+
+!-2. BEGINNING INDEX of the SUB-REGION
+
+ PARAMETER (bi = 1)
+ PARAMETER (bj = 1)
+
+
+!-Dimensions of the RELAXATION ZONE towards LATERAL BOUNDARIES
+! ------------------------------------------------------------
+
+ INTEGER n6,n7,n8,n9,n10
+ PARAMETER(n7 = 7)
+! ......... ^ number of grid points of the relaxation zone
+
+ PARAMETER(n10= 2)
+! ......... ^ number of grid points of constant topo. zone
+
+ PARAMETER(n8 = 3)
+! ......... ^ number of grid points of the topography
+! transition zone (valid if using LS constant
+! topography at boundaries).
+
+ PARAMETER(n6 =n7 -1)
+ PARAMETER(n9 =n10-1)
+
+
+! Explanation of boundary structure :
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+!
+! 1. TOPOGRAPHY
+! -------------
+!
+! | Constant | Transition | Computation | Transition | Constant |
+! | topography | zone | domain | zone | topography |
+! | zone | (LS -> MAR)| | (LS -> MAR)| zone |
+! ^ ^ ^ ^ ^ ^
+! 1 ... n10 ... n10+n8+1 ... mx-n9-n8-1 ... mx-n9 ... mx
+!
+! 2. RELAXATION LSC --> NST
+! -------------------------
+!
+! | Relaxation | Computation | Relaxation |
+! | zone | domain | zone |
+! ^ ^ ^ ^
+! 1 ... n7 ... mx-n6 ... mx
diff --git a/MAR/code_nestor/src/NSTint.f b/MAR/code_nestor/src/NSTint.f
new file mode 100644
index 0000000000000000000000000000000000000000..7f40b13cc70b47e2a1ab1855f136615def849a6a
--- /dev/null
+++ b/MAR/code_nestor/src/NSTint.f
@@ -0,0 +1,2017 @@
+C +-------------------------------------------------------------------+
+C | Subroutine NSTint 20/09/2012 NESTING |
+C +-------------------------------------------------------------------+
+C | |
+C | Interpolation of large-scale data to nested grid. |
+C | |
+C | INPUT : I_time: time for which the data is requested |
+C | ^^^^^^^^ HORint: horizontal interp. type (1= bilin, 3= bicub) |
+C | VERint: vertical interp. type (1= lin. , 3= cubic) |
+C | NST_sh: topography in nested model |
+C | NST_dx: horizontal resolution |
+C | LSCfil: input LSC data file (path+name) |
+C | NSTmod: nested model (used for the vertical grid) |
+C | TOPcstLSC,TOPdomLSC,TOPfilt : LSC corrected topography |
+C | SPHgrd: true if spherical coordinates for LSC model |
+C | CLDcor: true if parameterized cloud water at boundaries |
+C | |
+C | INPUT FILE: a LSRD - Large Scale Raw Data file (NetCDF) |
+C | ^^^^^^^^^^^ |
+C | *file name = {LSCmodel}.YY.MM.DD.nC |
+C | where YYMMDD = Year, Month, and Day of file begin |
+C | *'time' variable = Universal time from 0 hour the YYMMDD day |
+C | (unit = DAYS) |
+C | *file contents: |
+C | - - - - - - - + - - + - - - + - - - - - |
+C | variable |Unit |
+C | in atm.| 10m | |
+C | - - - - - - - + - - + - - - + - - - - - |
+C | Wind |U |U10 |m/s |
+C | " |V |V10 |m/s |
+C | Specif. humid.|Q |Q10 |Kg/Kg |
+C | Temperature |T |T10 |K |
+C | | | | |
+C | Pressure | |SP |hPa |
+C | Surf. height |- |SH |m |
+C | - - - - - - - + - - + - - - + - - - - - |
+C | |
+C | OUTPUT : NST__u: U-wind ( m/s ) |
+C | ^^^^^^^^ NST__v: V-wind ( m/s ) |
+C | NST__t: real temperature ( K ) |
+C | NST_pt: potential temperature ( K ) |
+C | NST_qv: specific humidity (kg/kg) |
+C | NST_sp: surface pressure ( kPa ) |
+C | NSTsic: sea-ice fraction ( - ) |
+C | NSTsst: sea surface temperature ( K ) |
+C | NST_st: surface temperature ( K ) |
+C | NSTdst: soil temperature ( K ) |
+C | NST__p: pressure at each lev. ( kPa ) |
+C | NST_zz: levels height ( m ) |
+C | NSTgdz: sigma coordinate |
+C | NSTsol: soil types (ice taken into account) |
+C | NSTtke: turbulent kinetic energy (m2/s2) |
+C | NSTuts: surface heat flux (K.m/s) |
+C | NST_qt: total cloud water (kg/kg) |
+C | |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE NSTint
+
+ IMPLICIT NONE
+
+C +---Include files
+C + -------------
+
+ INCLUDE 'NSTdim.inc'
+ INCLUDE 'NESTOR.inc'
+ INCLUDE 'CTRvar.inc'
+ INCLUDE 'LSCvar.inc'
+ INCLUDE 'INTvar.inc'
+ INCLUDE 'NSTvar.inc'
+ INCLUDE 'MARvar.inc'
+
+C +---Local variables
+C + ---------------
+
+ INTEGER i,j,k,it,fID,ierror,zero,kl,mmx,mmy
+
+ INTEGER pos_Ox(mx,my),pos_Oy(mx,my)
+
+ REAL exxpo,gamTz,empty1(1),cap,ra,grav,humrel,erzmax,
+ . qsat,cp,h2olv,thr_rh,qwater,qsuppl,qclmax,nul,
+ . auxz,auxu,auxv,auxt,auxq,auxe, getpkt, fcort,
+ . lwblon,upblon,lwblat,upblat,lwb_SH,upb_SH,
+ . lwb_SP,upb_SP,lwbST1,upbST1,lwbST2,upbST2,
+ . lwbSW1,upbSW1,lwb10U,upb10U,lwb10V,upb10V,
+ . lwbTCC,upbTCC,lwb__U,upb__U,lwb__V,upb__V,
+ . lwb__T,upb__T,lwb__Q,upb__Q,lwbTKE,upbTKE,
+ . lwbUTS,upbUTS,lwbSIC,upbSIC,lwbSST,upbSST
+
+ REAL INtmp1(mx,my),INtmp2(mx,my),INtmp3(mx,my),
+ . NSTpk6(mx,my),NSTpx1(mx,my),NSTlp1(mx,my),
+ . LSC_z6(ni,nj),INT_z6(mx,my),NST_z6(mx,my),
+ . LSCpk1(ni,nj),LSCpx1(ni,nj),LSClp1(ni,nj),
+ . INT1sp,qv_sat(mz),rhoair(mz),deltaz(mz),EQtemp(mz),
+ . WK1Dq(nk+1),WK1Du(nk+1),WK1Dv(nk+1),WK1Dt(nk+1),
+ . qv_max(mz),qcloud(mz),
+ . WK1De(nk+1),WK1Dh(nk+1),correction
+
+ ! Additional variables added by J.-F. G. to speed up some steps
+ INTEGER baseI,baseJ,maxI,maxJ
+ REAL AUXlon,AUXlat,MINlon,MINlat,MAXlon,MAXlat
+
+ LOGICAL CORsat,LSCiZp(mx,my), NSTiZp(mx,my), iZterm
+ LOGICAL decreaseSIC
+
+ CHARACTER*3 emptyC
+ CHARACTER*7 nam_SH,nam_SP,namST1,namST2,namSW1,nam10U,nam10V,
+ . nam__U,nam__V,nam__T,nam__Q,namTCC,namlon,namlat,
+ . namTKE,namUTS,nam_QW,nam_QR,nam_QI,nam_QS,namSIC,
+ . namSST
+ CHARACTER*10 var_units
+ CHARACTER*100 LSCtit
+ INTEGER icheck, ipchk, jpchk
+ INTEGER im1,ip1,jm1,jp1
+
+C +---Physical constants
+C + ------------------
+
+ DATA ra / 287. d0/
+ DATA cp / 1004. d0/
+ DATA h2olv / 2.5000d+6/
+ DATA cap / 0.28586d0/
+ DATA grav / 9.81 d0/
+ DATA emptyC/ ' ' /
+ DATA zero / 0 /
+ DATA nul / 0. /
+
+ getpkt= exp(-cap*log(100.))
+C +... getpkt: 1. / (100. (kPa) ** cap)
+
+C +---Debug verbose level (0=silent - 3=flood):
+C + -------------------
+ icheck=2
+C +---Horizontal point for extended check:
+ ipchk =39
+ jpchk =22
+
+C +---Initialisation
+C + --------------
+
+ lfirst_LSC = .true.
+ lfirst_NST = .true.
+
+ IF (NSTmod.eq.'GRA') TOPdomLSC = .true.
+
+ mmx = mx
+ mmy = my
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+C +---Open NetCDF file containing LSC data
+C + ====================================
+
+C + *******
+ CALL UNropen (LSCfil,fID,LSCtit)
+C + *******
+
+C +---Time for data extraction
+C + ------------------------
+
+ it = I_time
+
+C +---Screen message
+C + --------------
+
+ IF (vrbose) THEN
+ write(6,*) 'Horizontal and vertical interpolations'
+ write(6,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+ IF (NSTmod.eq.'GRA') THEN
+ write(6,*) 'Output for GRADS : imposed LSC topography'
+ ENDIF
+ ENDIF
+
+ ! These messages are printed in all cases, regardless of vrbose
+ write(6,'(A,A)') 'File: ',LSCfil
+ write(6,'(A,i4)') 'Time step: ',I_time
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+C +---Specification of valid interval for LSC values
+C + ==============================================
+
+ lwblon = -400.0
+ upblon = 400.0
+ lwblat = -100.0
+ upblat = 100.0
+ lwb_SH = -1000.0
+ upb_SH = 10000.0
+ lwb_SP = 10000.0
+ upb_SP = 130000.0
+ lwbSIC = 0.0
+ upbSIC = 10.e20
+ lwbSST = 100.0
+ upbSST = 10.e20
+ lwbST1 = 100.0
+ upbST1 = 370.0
+ lwbST2 = 100.0
+ upbST2 = 370.0
+ lwbSW1 = -0.1
+ upbSW1 = 1.0
+ lwb10U = -100.0
+ upb10U = 100.0
+ lwb10V = -100.0
+ upb10V = 100.0
+ lwbTCC = -0.1
+ upbTCC = 1.1
+ lwb__U = -300.0
+ upb__U = 300.0
+ lwb__V = -300.0
+ upb__V = 300.0
+ lwb__T = 100.0
+ upb__T = 370.0
+ lwb__Q = -0.01
+ upb__Q = 1.0
+ lwbTKE = -0.1
+ upbTKE = 10000.0
+ lwbUTS = -100.0
+ upbUTS = 100.0
+
+ IF (LSCmod.eq.'MAR') THEN
+ lwb_SP = 10.0
+ upb_SP = 130.0
+ ENDIF
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+C +---Define variable names
+C + =====================
+
+ IF (LSCmod.eq.'MAR') THEN
+ namlon='lon'
+ namlat='lat'
+ nam_SH='sh'
+ nam_SP='pstar'
+ namST1='tairSL'
+ namST2='tairSL'
+ namSST='tairSL'
+ namSIC='sicSL'
+ namSW1='-'
+ nam10U='-'
+ nam10V='-'
+ namTCC='-'
+ nam__U='uairDY'
+ nam__V='vairDY'
+ nam__T='tairDY'
+ nam__Q='qvDY'
+ namTKE='ect_TE'
+ namUTS='SLutsl'
+ nam_QW='qwHY'
+ nam_QR='qrHY'
+ nam_QS='qsHY'
+ nam_QI='qiHY'
+ ENDIF
+ ! models from ERA family
+ IF (LSCmod.eq.'ECM'.or.LSCmod.eq.'E15'.or.LSCmod.eq.'E20'
+ ..or.LSCmod.eq.'E40'.or.LSCmod.eq.'EIN'.or.LSCmod.eq.'ER5')THEN
+ LSCmod="ECM"
+ namlon='lon'
+ namlat='lat'
+ nam_SH='SH'
+ nam_SP='SP'
+ namSST='SSTK'
+ namSIC='CI'
+ namST1='STL1'
+ namST2='STL1' ! STL2 not in ERA5
+ namSW1='SWVL1'
+ if (LSCmod.eq.'E15') namSW1='SWL1'
+ nam10U='-'
+ nam10V='-'
+ namTCC='-'
+ nam__U='U'
+ nam__V='V'
+ nam__T='T'
+ nam__Q='Q'
+ namTKE='-'
+ namUTS='-'
+ nam_QW='CLWC'
+ nam_QR='-'
+ nam_QS='-'
+ nam_QI='CIWC'
+ ENDIF
+ ! models with sigma levels
+ IF (LSCmod.eq.'CM3'.or.LSCmod.eq.'EM5'.or.LSCmod.eq.'CAN'.or.
+ . LSCmod.eq.'NOR'.or.LSCmod.eq.'CSI'.or.LSCmod.eq.'BCC'.or.
+ . LSCmod.eq.'MIR'.or.LSCmod.eq.'CM5'.or.LSCmod.eq.'AC3'.or.
+ . LSCmod.eq.'CM6'.or.
+ . LSCmod.eq.'GCM') then
+ namlon='lon'
+ namlat='lat'
+ nam_SH='SH'
+ nam_SP='SP'
+ namSST='SST2'
+ namSIC='CI'
+ namST1='SST1'
+ namST2='SST1'
+ namSW1='-'
+ nam10U='-'
+ nam10V='-'
+ namTCC='-'
+ nam__U='U'
+ nam__V='V'
+ nam__T='T'
+ nam__Q='Q'
+ namTKE='-'
+ namUTS='-'
+ nam_QW='-'
+ nam_QR='-'
+ nam_QS='-'
+ nam_QI='-'
+ LSCmod='GCM'
+ ENDIF
+ ! models with pressure levels
+ IF (LSCmod.eq.'20C'.or.LSCmod.eq.'NCP'.or.LSCmod.eq.'ME2'.or.
+ . LSCmod.eq.'NC1'.or.LSCmod.eq.'NC2'.or.LSCmod.eq.'JRA'.or.
+ . LSCmod.eq.'GFS') then
+ namlon='lon'
+ namlat='lat'
+ nam_SH='SH'
+ nam_SP='SP'
+ namSST='SST2'
+ namSIC='CI'
+ namST1='SST1'
+ namST2='SST1'
+ if (LSCmod.eq.'GFS') then
+ namSST='SST' ; namST1='SST' ; namST2='SST'
+ endif
+ namSW1='-'
+ nam10U='-'
+ nam10V='-'
+ namTCC='-'
+ nam__U='U'
+ nam__V='V'
+ nam__T='T'
+ nam__Q='Q'
+ namTKE='-'
+ namUTS='-'
+ nam_QW='-'
+ nam_QR='-'
+ nam_QS='-'
+ nam_QI='-'
+ LSCmod='NCP'
+ ENDIF
+
+ IF (LSCmod.eq.'ECP')THEN
+ namlon='lon'
+ namlat='lat'
+ nam_SH='SH'
+ nam_SP='SP'
+ namSST='SSTK'
+ namSIC='CI'
+ namST1='SKT'
+ namST2='SKT'
+ namSW1='-'
+ nam10U='-'
+ nam10V='-'
+ namTCC='-'
+ nam__U='U'
+ nam__V='V'
+ nam__T='T'
+ nam__Q='Q'
+ namTKE='-'
+ namUTS='-'
+ nam_QW='-'
+ nam_QR='-'
+ nam_QS='-'
+ nam_QI='-'
+ ENDIF
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+C +---Horizontal coordinates
+C + ======================
+
+ DO j=1,my
+ DO i=1,mx
+ pos_Ox(i,j)=0
+ pos_Oy(i,j)=0
+ ENDDO
+ ENDDO
+
+ IF (REGgrd) THEN
+
+C + ******
+ CALL UNread (fID,nam_SH,it,1,bi,bj,ni,nj,1,
+ . LSC1Dx,LSC1Dy,empty1,var_units,LSC_sh)
+C + ******
+ CALL VALchk (nam_SH,ni,nj,LSC_sh,lwb_SH,upb_SH)
+C + ******
+
+ DO j=1,nj
+ DO i=1,ni
+ LSC__x(i,j)=LSC1Dx(i)
+ LSC__y(i,j)=LSC1Dy(j)
+ ENDDO
+ ENDDO
+
+ ELSE
+
+C + ******
+ CALL UNread (fID,namlon,it,1,bi,bj,ni,nj,1,
+ . LSC1Dx,LSC1Dy,empty1,var_units,LSC__x)
+
+ do i=1,ni ; do j=1,nj
+ if(LSC__x(i,j)>180) LSC__x(i,j)=LSC__x(i,j)-360.
+ enddo ; enddo
+
+C + ******
+ CALL VALchk (namlon,ni,nj,LSC__x,lwblon,upblon)
+C + ******
+ CALL UNread (fID,namlat,it,1,bi,bj,ni,nj,1,
+ . LSC1Dx,LSC1Dy,empty1,var_units,LSC__y)
+C + ******
+ CALL VALchk (namlat,ni,nj,LSC__y,lwblat,upblat)
+C + ******
+
+ ENDIF
+
+ IF (icheck.GE.3.and.vrbose) THEN
+ write(*,*) 'NSTint: input coordinates:'
+ write(*,*) (LSC__x(i,1),i=1,ni)
+ write(*,*) (LSC__y(1,j),j=1,nj)
+ IF (REGgrd) write(*,*) 'Grid is assumed rectangular'
+ ENDIF
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+C +---J.-F. Grailet (29/05/2022): to speed up some steps that have to
+C + go through the LSC grid (in particular, calls to the LSCvgd and
+C + NSTzz6 subroutines), indexes delimiting a sub-region of the LSC
+C + grid are computed here. Determining such indexes is carried out
+C + here, re-using some code from INTERp.f in the process to find
+C + the limits of the MAR grid in longitude and latitude. Please
+C + note that this code assumes that the MAR domain does not overlap
+C + the LSC domain borders.
+
+ IF (REGgrd) THEN
+
+ ! Determines max/min longitudes and latitudes of the MAR grid
+ AUXlon = NST__x(1,1)
+ AUXlat = NST__y(1,1)
+C + ******
+ CALL SPHERC (SPHgrd,AUXlon,AUXlat)
+C + ******
+ MINlon = AUXlon
+ MAXlon = AUXlon
+ MINlat = AUXlat
+ MAXlat = AUXlat
+
+ DO j=1,my
+ DO i=1,mx
+ AUXlon = NST__x(i,j)
+ AUXlat = NST__y(i,j)
+C + ******
+ CALL SPHERC (SPHgrd,AUXlon,AUXlat)
+C + ******
+ MINlon = min(AUXlon,MINlon)
+ MAXlon = max(AUXlon,MAXlon)
+ MINlat = min(AUXlat,MINlat)
+ MAXlat = max(AUXlat,MAXlat)
+ ENDDO
+ ENDDO
+
+ ! Determines the limit indexes within LSC grid for this sub-area
+ baseI = -1
+ baseJ = -1
+ maxI = ni+1
+ maxJ = nj+1
+
+ ! baseI, maxI
+ DO i=1,ni
+ IF ((baseI.eq.-1).and.LSC1Dx(ni-i).lt.MINlon) THEN
+ baseI = ni-i-5 ! -5 to add some sponge
+ IF (baseI.lt.1) THEN
+ baseI = 1
+ ENDIF
+ END IF
+ IF ((maxI.eq.(ni+1)).and.LSC1Dx(i).gt.MAXlon) THEN
+ maxI = i+5 ! +5 to add some sponge
+ IF (maxI.gt.ni) THEN
+ maxI = ni
+ ENDIF
+ ENDIF
+ END DO
+
+ ! baseJ, maxJ
+ DO j=1,nj
+ IF ((baseJ.eq.-1).and.LSC1Dy(nj-j).lt.MINlat) THEN
+ baseJ = nj-j-5 ! -5 to add some sponge
+ IF (baseJ.lt.1) THEN
+ baseJ = 1
+ ENDIF
+ END IF
+ IF ((maxJ.eq.(nj+1)).and.LSC1Dy(j).gt.MAXlat) THEN
+ maxJ = j+5 ! +5 to add some sponge
+ IF (maxJ.gt.nj) THEN
+ maxJ = nj
+ ENDIF
+ ENDIF
+ END DO
+
+ ELSE
+
+ ! JFG: this is left for future work (MAR on MAR forcing)
+ baseI = 1
+ baseJ = 1
+ maxI = ni
+ maxJ = nj
+
+ ENDIF
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+C +---Topography
+C + ==========
+
+C + ******
+ CALL UNread (fID,nam_SH,it,1,bi,bj,ni,nj,1,
+ . LSC1Dx,LSC1Dy,empty1,var_units,LSC_sh)
+C + ******
+ CALL VALchk (nam_SH,ni,nj,LSC_sh,lwb_SH,upb_SH)
+C + ******
+
+C + ******
+ CALL intHor (HORint,LSC__x,LSC__y,LSC_sh,
+ . SPHgrd,NST__x,NST__y,INT_sh,
+ . REGgrd,pos_Ox,pos_Oy)
+C + ******
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+C +---CORRECTION OF PRESCRIBED TOPOGRAPHY WITH LSC TOPOGRAPHY
+C + =======================================================
+
+C +---Imposed LSC topography in the relaxation zone
+C + ---------------------------------------------
+
+ IF (TOPcstLSC) THEN
+
+ TOPopt=2
+C + ******
+ CALL TOPcor (TOPopt,NST__x,NST__y,NST_sh,INT_sh)
+C + ******
+
+ ENDIF
+
+C +---Imposed LSC topography in the whole domain
+C + ------------------------------------------
+
+ IF (TOPdomLSC) THEN
+
+ TOPopt=3
+C + ******
+ CALL TOPcor (TOPopt,NST__x,NST__y,NST_sh,INT_sh)
+C + ******
+
+ ENDIF
+
+C +---Topography filtering (2D and 3D)
+C + --------------------------------
+
+ IF (TOPdomLSC.and.TOPfilt) THEN
+
+ TOPopt=5
+C + ******
+ CALL TOPcor (TOPopt,NST__x,NST__y,NST_sh,INT_sh)
+C + ******
+
+ ENDIF
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+C +---Horizontal interpolation of surface fields
+C + ==========================================
+
+C +---Surface Pressure
+C + ----------------
+
+ IF (vrbose) THEN
+ WRITE(6,'(A,$)') ' 2-D fields : '//nam_SH//'- '//nam_SP
+ ENDIF
+
+C + ******
+ CALL UNread (fID,nam_SP,it,1,bi,bj,ni,nj,1,
+ . LSC1Dx,LSC1Dy,empty1,var_units,LSC_sp)
+C + ******
+ CALL VALchk (nam_SP,ni,nj,LSC_sp,lwb_SP,upb_SP)
+C + ******
+
+ IF (LSCmod.ne.'MAR') THEN
+C + ******
+ CALL LSuCHG (LSC_sp,1.E-3) !(Change units: Pa-->kPa)
+C + ******
+ ENDIF
+
+C + ******
+ CALL intHor (HORint,LSC__x,LSC__y,LSC_sp,
+ . SPHgrd,NST__x,NST__y,INT_sp,
+ . REGgrd,pos_Ox,pos_Oy)
+C + ******
+
+C +---Sea-Ice Fraction
+C + ----------------
+
+ IF (LSCmod.eq.'E40'.or.LSCmod.eq.'ECM'.or.LSCmod.eq.'GCM'
+ . .or.LSCmod.eq.'MAR'.or.LSCmod.eq.'NCP'
+ . .or.LSCmod.eq.'ECP') THEN
+
+ IF (vrbose) THEN
+ WRITE(6,'(A,$)') '- '//namSIC
+ ENDIF
+
+C + ******
+ CALL UNread (fID,namSIC,it,1,bi,bj,ni,nj,1,
+ . LSC1Dx,LSC1Dy,empty1,var_units,LSCsic)
+C + ******
+ LSCsic=0 ! Suggestion de Xavier pour forcage MAR sur MAR
+ CALL VALchk (namSIC,ni,nj,LSCsic,lwbSIC,upbSIC)
+C + ******
+
+ if (LSCmod.eq.'MAR') then
+
+ CALL UNread (fID,"isol",it,1,bi,bj,ni,nj,1,
+ . LSC1Dx,LSC1Dy,empty1,var_units,LSClsm)
+ do i=1,ni ; do j=1,nj
+ if(LSClsm(i,j)>=3) then
+ LSClsm(i,j)=1
+ LSCsic(i,j)=10e20
+ else
+ LSClsm(i,j)=0
+ endif
+ enddo ; enddo
+ endif
+
+C + ******
+ CALL INTmsk (LSCsic)
+C + ******
+
+ do i=1,ni ; do j=1,nj
+ if(abs(LSCsic(i,j))>9e20) then
+ LSCsic(i,j)=0.
+ endif
+ enddo ; enddo
+
+C + ******
+ CALL intHor (HORint,LSC__x,LSC__y,LSCsic,
+ . SPHgrd,NST__x,NST__y,INTsic,
+ . REGgrd,pos_Ox,pos_Oy)
+C + ******
+
+ DO i=1,mx
+ DO j=1,my
+ IF (NSTsol(i,j).GE.3) INTsic(i,j) = 0.
+ INTsic(i,j) = max(0.,min(INTsic(i,j),1.0))
+ ENDDO
+ ENDDO
+
+ END IF
+
+C +---Soil or Sea surface temperature
+C + -------------------------------
+
+ IF (vrbose) THEN
+ WRITE(6,'(A,$)') '- '//namST1
+ ENDIF
+
+C + ******
+ CALL UNread (fID,namST1,it,1,bi,bj,ni,nj,1,
+ . LSC1Dx,LSC1Dy,empty1,var_units,LSC_st)
+C + ******
+ CALL VALchk (namST1,ni,nj,LSC_st,lwbST1,upbST1)
+C + ******
+
+C + ******
+ CALL intHor (HORint,LSC__x,LSC__y,LSC_st,
+ . SPHgrd,NST__x,NST__y,INT_st,
+ . REGgrd,pos_Ox,pos_Oy)
+C + ******
+
+C +---Sea surface temperature
+C + -----------------------
+
+ IF (LSCmod.eq.'E40'.or.LSCmod.eq.'ECM'.or.LSCmod.eq.'GCM'
+ . .or.LSCmod.eq.'MAR'.or.LSCmod.eq.'NCP'
+ . .or.LSCmod.eq.'ECP') THEN
+
+ IF (vrbose) THEN
+ WRITE(6,'(A,$)') '- '//namSST
+ ENDIF
+
+C + ******
+ CALL UNread (fID,namSST,it,1,bi,bj,ni,nj,1,
+ . LSC1Dx,LSC1Dy,empty1,var_units,LSCsst)
+C + ******
+ CALL VALchk (namSST,ni,nj,LSCsst,lwbSST,upbSST)
+C + ******
+
+ if (LSCmod.eq.'MAR') then
+ do i=1,ni ; do j=1,nj
+ if(LSClsm(i,j)==1) then
+ LSCsst(i,j)=10e20
+ endif
+ enddo ; enddo
+ endif
+
+ IF(LSCmod.eq.'E40'.or.LSCmod.eq.'ECM'.or.LSCmod.eq.'ECP') THEN
+ DO i = 1,ni
+ DO j = 1,nj
+ if(LSCsst(i,j)>=250..and.LSCsst(i,j)<=350.) then
+ !+ ---------------------------------------------------------- +!
+ !+ http://www.ecmwf.int/research/ifsdocs/CY28r1/Assimilation/
+ !+ Assimilation-14-4.html
+ !+ For grid boxes characterized by sea-ice concentrations
+ !+ exceeding 20% the SST is set to -1.7 degC.
+ !+ ---------------------------------------------------------- +!
+ LSCsst(i,j)=LSC_st(i,j)
+ endif
+ ENDDO ; ENDDO
+ ENDIF
+
+C + ******
+ CALL INTmsk (LSCsst)
+C + ******
+
+ do i=1,ni ; do j=1,nj
+ if(abs(LSCsst(i,j))>9e20) then
+ LSCsst(i,j)=LSC_st(i,j)
+ endif
+ enddo ; enddo
+
+C + ******
+ CALL intHor (HORint,LSC__x,LSC__y,LSCsst,
+ . SPHgrd,NST__x,NST__y,INTsst,
+ . REGgrd,pos_Ox,pos_Oy)
+C + ******
+
+ DO j = 1,my
+ DO i = 1,mx
+
+ IF (NSTsol(i,j).le.2) THEN
+
+ INT_st(i,j)=INTsst(i,j)
+
+ ENDIF
+
+ ENDDO
+ ENDDO
+
+ END IF
+
+C +---Soil or Sea temperature
+C + -----------------------
+
+ IF (vrbose) THEN
+ WRITE(6,'(A,$)') '- '//namST2
+ ENDIF
+
+C + ******
+ CALL UNread (fID,namST2,it,1,bi,bj,ni,nj,1,
+ . LSC1Dx,LSC1Dy,empty1,var_units,LSCdst)
+C + ******
+ CALL VALchk (namST2,ni,nj,LSCdst,lwbST2,upbST2)
+C + ******
+
+C + ******
+ CALL intHor (HORint,LSC__x,LSC__y,LSCdst,
+ . SPHgrd,NST__x,NST__y,INTdst,
+ . REGgrd,pos_Ox,pos_Oy)
+C + ******
+
+C +---Total Cloud Cover
+C + -----------------
+
+ IF (namTCC.ne.'-') THEN
+
+ IF (vrbose) THEN
+ WRITE(6,'(A,$)') '- '//namTCC
+ ENDIF
+
+C + ******
+ CALL UNread (fID,namTCC,it,1,bi,bj,ni,nj,1,
+ . LSC1Dx,LSC1Dy,empty1,var_units,LSCtcc)
+C + ******
+ CALL VALchk (namTCC,ni,nj,LSCtcc,lwbTCC,upbTCC)
+C + ******
+
+C + ******
+ CALL intHor (HORint,LSC__x,LSC__y,LSCtcc,
+ . SPHgrd,NST__x,NST__y,INTtcc,
+ . REGgrd,pos_Ox,pos_Oy)
+C + ******
+
+ ENDIF
+
+C +---Temperature difference between 1st atm. level and soil/sea
+C + ----------------------------------------------------------
+
+ IF (vrbose) THEN
+ WRITE(6,'(A,$)') '- '//nam__T
+ ENDIF
+
+C + ******
+ CALL UNread (fID,nam__T,it,nk,bi,bj,ni,nj,1,
+ . LSC1Dx,LSC1Dy,empty1,var_units,LSC__t)
+C + ******
+ CALL VALchk (nam__T,ni,nj,LSC__t,lwb__T,upb__T)
+C + ******
+
+ DO j=1,nj
+ DO i=1,ni
+ LSC_dt(i,j)=LSC__t(i,j)-LSC_st(i,j)
+ ENDDO
+ ENDDO
+
+C + ******
+ CALL intHor (HORint,LSC__x,LSC__y,LSC_dt,
+ . SPHgrd,NST__x,NST__y,INT_dt,
+ . REGgrd,pos_Ox,pos_Oy)
+C + ******
+
+ DO j=1,nj
+ DO i=1,ni
+ LSC_pt(i,j)=LSC__t(i,j)*(100./LSC_sp(i,j))**cap
+ ENDDO
+ ENDDO
+
+C + ******
+ CALL intHor (HORint,LSC__x,LSC__y,LSC_pt,
+ . SPHgrd,NST__x,NST__y,INtmp1,
+ . REGgrd,pos_Ox,pos_Oy)
+C + ******
+
+C + ******
+ CALL PUT2D3 (INtmp1,nk,INT_pt)
+C + ******
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+C +---Correction of surface pressure according to topography change
+C + =============================================================
+
+C +...Computation of a surface pressure adapted to MAR topography,
+C +...using 2 simple assumptions : - constant T gradient = gamTz
+C +... - basic T = 1st level near surface
+
+C +---Constants
+C + ---------
+
+ gamTz = - 6.5E-3
+ exxpo = - grav / (gamTz * ra)
+
+C +---Compute surface pressure according to topography changes
+C + --------------------------------------------------------
+
+ DO j = 1,my
+ DO i = 1,mx
+ NST_sp(i,j)= INT_sp(i,j)
+ . * (1.+gamTz*(NST_sh(i,j)-INT_sh(i,j))/INT_st(i,j))**exxpo
+ END DO
+ END DO
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+C +---Correction of Sea-Ice Fraction
+C + ==============================
+
+ IF (LSCmod.eq.'E40'.or.LSCmod.eq.'ECM'.or.LSCmod.eq.'GCM'
+ . .or.LSCmod.eq.'MAR'.or.LSCmod.eq.'NCP'
+ . .or.LSCmod.eq.'ECP')THEN
+
+ DO j = 1,my
+ DO i = 1,mx
+ NSTsic(i,j)= INTsic(i,j)
+ NSTsst(i,j)= INTsst(i,j)
+ END DO
+ END DO
+ ELSE
+ DO j = 1,my
+ DO i = 1,mx
+ NSTsic(i,j)= -1. ! Feeds MAR with nitroglycerine
+ NSTsst(i,j)= -99.9
+ END DO
+ END DO
+ END IF
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+C +---Correction of soil temperature according to topography change
+C + =============================================================
+
+ DO j = 1,my
+ DO i = 1,mx
+
+ IF (NST_sh(i,j).gt.1..and.NSTsol(i,j).ge.3) THEN
+
+ NST_st(i,j)=INT_pt(i,j,nk)/(100./NST_sp(i,j))**cap
+ . -INT_dt(i,j)
+
+C +... Temperature diff. between 1st level and surface is conserved
+
+ ELSE
+
+ NST_st(i,j)=INT_st(i,j)
+
+C +... No correction for the sea surface temperature
+C Possible correction for SST-Reynolds in SSTint.f
+
+ ENDIF
+
+C +... No correction for the sea surface temperature
+
+ fcort = gamTz * (NST_sh(i,j)-INT_sh(i,j))
+ NSTdst(i,j)= INTdst(i,j) + fcort
+
+ ENDDO
+ ENDDO
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+C +---Atmospheric variables at surface:
+C + (bottom boundary for vertic. interpolation)
+C + ===========================================
+
+C +---10-m U-wind
+C + -----------
+
+ IF (nam10U.ne.'-') THEN
+C + (if 10m wind not available, 0 will be used for interpolation)
+
+ IF (vrbose) THEN
+ WRITE(6,'(A,$)') '- '//nam10U
+ ENDIF
+
+C + ******
+ CALL UNread (fID,nam10U,it,1,bi,bj,ni,nj,1,
+ . LSC1Dx,LSC1Dy,empty1,var_units,LSC__u)
+C + ******
+ CALL VALchk (nam10U,ni,nj,LSC__u,lwb__U,upb__U)
+C + ******
+
+C + ******
+ CALL intHor (HORint,LSC__x,LSC__y,LSC__u,
+ . SPHgrd,NST__x,NST__y,INtmp2,
+ . REGgrd,pos_Ox,pos_Oy)
+C + ******
+
+ ENDIF
+
+C +---10-m V-wind
+C + -----------
+
+ IF (nam10V.NE.'-') THEN
+C + (if 10m wind not available, 0 will be used for interpolation)
+
+ IF (vrbose) THEN
+ WRITE(6,'(A,$)') '- '//nam10V
+ ENDIF
+
+C + ******
+ CALL UNread (fID,nam10V,it,1,bi,bj,ni,nj,1,
+ . LSC1Dx,LSC1Dy,empty1,var_units,LSC__v)
+C + ******
+ CALL VALchk (nam10V,ni,nj,LSC__v,lwb__V,upb__V)
+C + ******
+
+C + ******
+ CALL intHor (HORint,LSC__x,LSC__y,LSC__v,
+ . SPHgrd,NST__x,NST__y,INtmp3,
+ . REGgrd,pos_Ox,pos_Oy)
+C + ******
+ ENDIF
+
+C +---Wind vector rotation (according to projection)
+C + --------------------
+
+ IF (nam10U.NE.'-'.AND.nam10V.NE.'-') THEN
+ IF (NST_dx.gt.0.01.and.NSTmod.ne.'GRA') then
+ if (maptyp.ge.1) then
+C + ******
+ CALL VecRot (NST__x,NST__y,NST_dx,INtmp2,INtmp3)
+C + ******
+ else
+C ->Polar Stereographic Projection
+C + ******************
+ CALL VecRot_StereoSouth (GEddxx,NST__x,NST__y,INtmp2,INtmp3)
+C + ******************
+ endif
+ ENDIF
+
+C + ******
+ CALL PUT2D3 (INtmp2,nk+1,INT__u)
+C + ******
+
+C + ******
+ CALL PUT2D3 (INtmp3,nk+1,INT__v)
+C + ******
+ ENDIF
+
+C +---Potential temperature
+C + ---------------------
+
+ IF (namST1.eq.'-') THEN
+
+ IF (vrbose) THEN
+ WRITE(6,'(A,$)') '- '//nam__T
+ ENDIF
+
+C + ******
+ CALL UNread (fID,nam__T,it,nk,bi,bj,ni,nj,1,
+ . LSC1Dx,LSC1Dy,empty1,var_units,LSC__t)
+C + ******
+ CALL VALchk (nam__T,ni,nj,LSC__t,lwb__T,upb__T)
+C + ******
+
+ ELSE
+
+ IF (vrbose) THEN
+ WRITE(6,'(A,$)') '- '//namST1
+ ENDIF
+
+C + ******
+ CALL UNread (fID,namST1,it,1,bi,bj,ni,nj,1,
+ . LSC1Dx,LSC1Dy,empty1,var_units,LSC__t)
+C + ******
+ CALL VALchk (namST1,ni,nj,LSC__t,lwbST1,upbST1)
+C + ******
+
+ ENDIF
+
+ DO j=1,nj
+ DO i=1,ni
+ LSC_pt(i,j)=LSC__t(i,j)*(100./LSC_sp(i,j))**cap
+ ENDDO
+ ENDDO
+
+C + ******
+ CALL intHor (HORint,LSC__x,LSC__y,LSC_pt,
+ . SPHgrd,NST__x,NST__y,INtmp1,
+ . REGgrd,pos_Ox,pos_Oy)
+C + ******
+
+C + ******
+ CALL PUT2D3 (INtmp1,nk+1,INT_pt)
+C + ******
+
+C +---Water vapour
+C + ------------
+
+ IF (namSW1.eq.'-') THEN
+
+ IF (vrbose) THEN
+ WRITE(6,*)
+ WRITE(6,'(A,$)') ' '//nam__Q
+ ENDIF
+
+C + ******
+ CALL UNread (fID,nam__Q,it,nk,bi,bj,ni,nj,1,
+ . LSC1Dx,LSC1Dy,empty1,var_units,LSC_qv)
+C + ******
+ CALL VALchk (nam__Q,ni,nj,LSC_qv,lwb__Q,upb__Q)
+C + ******
+
+ ELSE
+
+ IF (vrbose) THEN
+ WRITE(6,*)
+ WRITE(6,'(A,$)') ' '//namSW1
+ ENDIF
+
+C + ******
+ CALL UNread (fID,namSW1,it,1,bi,bj,ni,nj,1,
+ . LSC1Dx,LSC1Dy,empty1,var_units,LSC_qv)
+C + ******
+
+ IF (LSCmod.eq.'E40'.or.LSCmod.eq.'ECM') THEN
+ do i=1,ni
+ do j=1,nj
+c LSC_qv(i,j) = max(0.,LSC_qv(i,j))/0.47
+c . * qsat(LSC__t(i,j),LSC_sp(i,j))
+ LSC_qv(i,j) = LSC_qv(i,j) * 0.07
+ enddo
+ enddo
+ ENDIF
+
+c http://www.ecmwf.int/products/data/technical/soil/discret_soil_lay.html
+
+C + ******
+ CALL VALchk (namSW1,ni,nj,LSC_qv,lwbSW1,upbSW1)
+C + ******
+
+ ENDIF
+
+C + ******
+ CALL intHor (HORint,LSC__x,LSC__y,LSC_qv,
+ . SPHgrd,NST__x,NST__y,INtmp1,
+ . REGgrd,pos_Ox,pos_Oy)
+C + ******
+
+C + ******
+ CALL PUT2D3 (INtmp1,nk+1,INT_qv)
+C + ******
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+C +---Reading and horizontal interpolation (+rotation)
+C + (for each atm. prognostic variable and each level)
+C + ==================================================
+
+ IF (CLDcor .AND. nam_QW.NE.'-'.and.vrbose) THEN
+ WRITE(6,*)
+ WRITE(6,'(A)') ' LSC Cloud water will be added to Qv'
+ ENDIF
+
+C WARNING increase of specific humidity
+C + =====================================
+
+ correction = 1.005 ! by default +0.05 %
+
+ if(NST_dx<=15000) correction = 1.01 ! correction minimum +1%
+ if(NST_dx<=10000) correction = 1.05 ! correction minimum +5%
+ if(NST_dx<=7500) correction = 1.075 ! correction minimum +7.5%
+ if(NST_dx<=5000) correction = 1.10 ! correction minimum +10%
+
+ correction = min(1.2,max(0.8,correction))
+
+c correction=1.08* (1950.-RUNiyr)**1.5/(1950.-1871.+1.)**1.5
+c . +0.95 * (1.-(1950.-RUNiyr)**1.5/(1950.-1871.+1.)**1.5)
+c if( RUNiyr >= 1950) correction=0.95
+c correction=min(1.05,max(0.95,correction))
+
+ if ((correction/=1.0).and.vrbose) then
+ print *,"WARNING: correction specific humidity : ",
+ . correction*100.-100.,"%"
+ endif
+
+ IF (vrbose) THEN
+ WRITE(6,*)
+ WRITE(6,'(A,$)') ' 3-D fields :'
+ ENDIF
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ DO k = nk,1,-1 !*BEGIN LOOP on vertical levels
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ IF (vrbose) THEN
+ WRITE(6,'(I3,$)') k
+ IF (MOD(nk-k+1,20).eq.0) THEN
+ WRITE(6,*)
+ WRITE(6,'(A,$)') ' '
+ ENDIF
+ ENDIF
+
+C +----U-Wind
+C + ------
+
+C + ******
+ CALL UNread (fID,nam__U,it,k,bi,bj,ni,nj,1,
+ . LSC1Dx,LSC1Dy,empty1,var_units,LSC__u)
+C + ******
+ CALL VALchk (nam__U,ni,nj,LSC__u,lwb__U,upb__U)
+C + ******
+
+C + ******
+ CALL intHor (HORint,LSC__x,LSC__y,LSC__u,
+ . SPHgrd,NST__x,NST__y,INtmp2,
+ . REGgrd,pos_Ox,pos_Oy)
+C + ******
+
+C +----V-Wind
+C + ------
+
+C + ******
+ CALL UNread (fID,nam__V,it,k,bi,bj,ni,nj,1,
+ . LSC1Dx,LSC1Dy,empty1,var_units,LSC__v)
+C + ******
+ CALL VALchk (nam__V,ni,nj,LSC__v,lwb__V,upb__V)
+C + ******
+
+C + ******
+ CALL intHor (HORint,LSC__x,LSC__y,LSC__v,
+ . SPHgrd,NST__x,NST__y,INtmp3,
+ . REGgrd,pos_Ox,pos_Oy)
+C + ******
+
+C +----Wind vector rotation (according to projection)
+C + --------------------
+
+ IF (NST_dx.gt.0.01.and.NSTmod.ne.'GRA'
+ . .and.mmx.ne.1.and.mmy.ne.1) then
+ if (maptyp.ge.1) then
+C + ******
+ CALL VecRot (NST__x,NST__y,NST_dx,INtmp2,INtmp3)
+C + ******
+ else
+C ->Polar Stereographic Projection
+C + ******************
+ CALL VecRot_StereoSouth (GEddxx,NST__x,NST__y,INtmp2,INtmp3)
+C + ******************
+ endif
+ ENDIF
+
+C + ******
+ CALL PUT2D3 (INtmp2,k,INT__u)
+C + ******
+
+C + ******
+ CALL PUT2D3 (INtmp3,k,INT__v)
+C + ******
+
+C +----Water vapour I : read
+C + ----------------------
+
+C + ******
+ CALL UNread (fID,nam__Q,it,k,bi,bj,ni,nj,1,
+ . LSC1Dx,LSC1Dy,empty1,var_units,LSC_qv)
+C + ******
+ CALL VALchk (nam__Q,ni,nj,LSC_qv,lwb__Q,upb__Q)
+C + ******
+
+C +----Add cloud water vapour to Qv -> clouds at boundaries
+C + ----------------------------------------------------
+C + Only if cloud water is available in LSC fields:
+C + Note : Qv is added in the LSC variables because this is
+C + somewhat more consistent for the 600 hPa correction, which
+C + compares LSC and interpolated output fields
+
+ IF (CLDcor) THEN
+
+ IF (nam_QW.NE.'-') THEN
+
+C + ******
+ CALL UNread (fID,nam_QW,it,k,bi,bj,ni,nj,1,
+ . LSC1Dx,LSC1Dy,empty1,var_units,LSCtmp)
+ CALL VALchk (nam_QW,ni,nj,LSCtmp,lwb__Q,upb__Q)
+C + ******
+
+ DO j=1,nj
+ DO i=1,ni
+ LSC_qv(i,j) = LSC_qv(i,j) + LSCtmp(i,j)
+ ENDDO
+ ENDDO
+ ENDIF
+
+ IF (nam_QI.NE.'-') THEN
+
+C + ******
+ CALL UNread (fID,nam_QI,it,k,bi,bj,ni,nj,1,
+ . LSC1Dx,LSC1Dy,empty1,var_units,LSCtmp)
+ CALL VALchk (nam_QI,ni,nj,LSCtmp,lwb__Q,upb__Q)
+C + ******
+
+ DO j=1,nj
+ DO i=1,ni
+ LSC_qv(i,j) = LSC_qv(i,j) + LSCtmp(i,j)
+ ENDDO
+ ENDDO
+ ENDIF
+
+ ENDIF
+
+C WARNING increase of specific humidity
+
+ LSC_qv = LSC_qv * correction
+
+C +----Water vapour II : interpolate / store
+C + -------------------------------------
+
+C + ******
+ CALL intHor (HORint,LSC__x,LSC__y,LSC_qv,
+ . SPHgrd,NST__x,NST__y,INtmp1,
+ . REGgrd,pos_Ox,pos_Oy)
+C + ******
+
+C + ******
+ CALL PUT2D3 (INtmp1,k,INT_qv)
+C + ******
+
+C +--- Pressure (required here for theta and geop. correction)
+C + --------
+
+ CALL LSCvgd (LSCmod,fID,ni,nj,nk,baseI,baseJ,maxI,maxJ,k,
+ . LSC_sp,LSC_pp,LSC_zz)
+
+ ! Saves surface pressure
+ IF (k.EQ.1) THEN
+ DO j=baseJ,maxJ ! j=1,nj
+ DO i=baseI,maxI ! i=1,ni
+ LSC__p(i,j)=LSC_pp(i,j,k)
+ END DO; END DO
+ END IF
+
+ CALL LSCvgd (LSCmod,fID,mx,my,nk,1,1,mx,my,k,
+ . INT_sp,INT__p,INT1zz)
+
+C +--- Potential temperature
+C + ---------------------
+
+C + ******
+ CALL UNread (fID,nam__T,it,k,bi,bj,ni,nj,1,
+ . LSC1Dx,LSC1Dy,empty1,var_units,LSC__t)
+C + ******
+ CALL VALchk (nam__T,ni,nj,LSC__t,lwb__T,upb__T)
+C + ******
+
+c Temperature + 1°C at the MAR boundary conditions.
+c DO j=1,nj
+c DO i=1,ni
+c LSC_rh(i,j)=LSC_qv(i,j) / qsat(LSC__t(i,j),LSC__p(i,j))
+c LSC__t(i,j)=LSC__t(i,j) + 1.0 ! WARNING WARNING
+c LSC_qv(i,j)=LSC_rh(i,j) * qsat(LSC__t(i,j),LSC__p(i,j))
+c ENDDO
+c ENDDO
+C + ******
+c CALL intHor (HORint,LSC__x,LSC__y,LSC_qv,
+c . SPHgrd,NST__x,NST__y,INtmp1,
+c . REGgrd,pos_Ox,pos_Oy)
+C + ******
+C + ******
+c CALL PUT2D3 (INtmp1,k,INT_qv)
+C + ******
+
+ DO i=baseI,maxI ! i=1,ni
+ DO j=baseJ,maxJ ! j=1,nj
+
+ LSC_pt(i,j)=LSC__t(i,j)*(100./LSC_pp(i,j,k))**cap
+
+ ENDDO
+ ENDDO
+
+C + ******
+ CALL intHor (HORint,LSC__x,LSC__y,LSC_pt,
+ . SPHgrd,NST__x,NST__y,INtmp1,
+ . REGgrd,pos_Ox,pos_Oy)
+C + ******
+
+C + ******
+ CALL PUT2D3 (INtmp1,k,INT_pt)
+C + ******
+
+C +--- Geopotential of 600 hPa level (for later use)
+C + ---------------------------------------------
+C + (must be done for each k starting from nk->1)
+
+ IF (CORzz6) THEN
+C + ******
+ CALL NSTzz6(LSC_pt, LSC_qv, LSC_sh, LSC_sp, LSC_pp(:,:,k),
+ . k, ni, nj, nk, baseI, baseJ, maxI, maxJ,
+ . LSCpk1, LSCpx1, LSClp1, LSCiZp, iZterm, LSC_z6)
+C + ******
+ ENDIF
+
+C +--- Relative Humidity
+C + -----------------
+
+ DO i=baseI,maxI ! i=1,ni
+ DO j=baseJ,maxJ ! j=1,nj
+
+ LSC_rh(i,j)=LSC_qv(i,j)/qsat(LSC__t(i,j),LSC_pp(i,j,k))
+
+ ENDDO
+ ENDDO
+
+C + ******
+ CALL intHor (HORint,LSC__x,LSC__y,LSC_rh,
+ . SPHgrd,NST__x,NST__y,INtmp1,
+ . REGgrd,pos_Ox,pos_Oy)
+C + ******
+
+C + ******
+ CALL PUT2D3 (INtmp1,k,INT_rh)
+C + ******
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ENDDO ! END LOOP ON VERTICAL LEVELS
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ IF (vrbose) THEN
+ WRITE(6,*)
+ WRITE(6,*)
+ ENDIF
+
+C +---Interpolate Z600 to MAR grid (for later use)
+C + --------------------------------------------
+C + (must be done after calls to NSTzz6 for all k)
+
+ IF (CORzz6) THEN
+C + ******
+ CALL intHor (HORint,LSC__x,LSC__y,LSC_z6,
+ . SPHgrd,NST__x,NST__y,INT_z6,
+ . REGgrd,pos_Ox,pos_Oy)
+C + ******
+ ENDIF
+
+C +---Vertical grid in the NST model (depend on SP)
+C + ==============================
+
+ CALL NSTvgd (NSTmod,mz,zero,NST_sp,NST__p,NST_hp,NSTgdz)
+
+C +---Vertical interpolation
+C + ======================
+
+C +---Prepare LSC vertical grid and data
+C + ----------------------------------
+
+ IF (VERint.ne.1.and.VERint.ne.3) THEN
+ IF (vrbose) THEN
+ write(6,*) 'CAUTION :'
+ write(6,*) 'Vertical interpolation order incorrectly'
+ write(6,*) 'specified. Default is set to linear.'
+ ENDIF
+ VERint=1
+ ENDIF
+
+ DO j=1,my
+ DO i=1,mx
+
+ DO k=1,nk
+ INT1Du(k)=INT__u(i,j,k)
+ INT1Dv(k)=INT__v(i,j,k)
+ INT1Dt(k)=INT_pt(i,j,k)
+ INT1Dq(k)=INT_qv(i,j,k)
+ INT1Dp(k)=INT__p(i,j,k)
+ INT1Dh(k)=INT_rh(i,j,k)
+ ENDDO
+
+ INT1Du(nk+1)=0.
+ INT1Dv(nk+1)=0.
+ INT1Dt(nk+1)=INT_pt(i,j,nk)
+ INT1Dq(nk+1)=INT_qv(i,j,nk)
+ INT1Dh(nk+1)=INT_rh(i,j,nk)
+
+ INT1sp=INT_sp(i,j)
+ INT1Dp(nk+1)=INT_sp(i,j)
+
+C + ******
+ CALL VERhyb (nk, INT1sp, INT1Dp, INT1Dz)
+C + ******
+
+C +---Linear interpolation (default)
+C + ------------------------------
+
+ IF (VERint.eq.1) THEN
+
+ DO k=1,mz
+ auxz = NST_hp(i,j,k)
+ CALL intLin(INT1Dz,INT1Du,nk+1,auxz,auxu)
+ CALL intLin(INT1Dz,INT1Dv,nk+1,auxz,auxv)
+ CALL intLin(INT1Dz,INT1Dt,nk+1,auxz,auxt)
+ CALL intLin(INT1Dz,INT1Dq,nk+1,auxz,auxq)
+ NST__u(i,j,k) = auxu
+ NST__v(i,j,k) = auxv
+ NST_pt(i,j,k) = auxt
+ NST_qv(i,j,k) = auxq
+ CALL intLin(INT1Dz,INT1Dh,nk+1,auxz,auxq)
+ NST_rh(i,j,k) = auxq
+ ENDDO
+
+ ENDIF
+
+C +---Natural cubic spline (optional)
+C + -------------------------------
+
+ IF (VERint.eq.3.and.NSTmod.ne.'GRA') THEN
+
+C +---Important remark on SPLINE (J.-F. Grailet, 10/05/2022)
+C + ------------------------------------------------------
+C + Before upgrading NESTOR, the code used nk+1 as the third arg for
+C + the SPLINE subroutine. However, this caused the WK1 vectors to
+C + be filled with NaN values because the last two values of INT1Dz
+C + are typically equal to zero, and having two consecutive zero's
+C + cause a division by zero at some point in SPLINE. To fix this,
+C + I restricted the use of SPLINE/SPLINT on the nk first values.
+
+ CALL SPLINE(INT1Dz,INT1Du,nk,1.E30,1.E30,WK1Du)
+ CALL SPLINE(INT1Dz,INT1Dv,nk,1.E30,1.E30,WK1Dv)
+ CALL SPLINE(INT1Dz,INT1Dt,nk,1.E30,1.E30,WK1Dt)
+ CALL SPLINE(INT1Dz,INT1Dq,nk,1.E30,1.E30,WK1Dq)
+ CALL SPLINE(INT1Dz,INT1Dh,nk,1.E30,1.E30,WK1Dh)
+
+ DO k=1,mz
+ auxz = NST_hp(i,j,k)
+ CALL SPLINT(INT1Dz,INT1Du,WK1Du,nk,auxz,auxu)
+ CALL SPLINT(INT1Dz,INT1Dv,WK1Dv,nk,auxz,auxv)
+ CALL SPLINT(INT1Dz,INT1Dt,WK1Dt,nk,auxz,auxt)
+ CALL SPLINT(INT1Dz,INT1Dq,WK1Dq,nk,auxz,auxq)
+ NST__u(i,j,k) = auxu
+ NST__v(i,j,k) = auxv
+ NST_pt(i,j,k) = auxt
+ NST_qv(i,j,k) = auxq
+ CALL SPLINT(INT1Dz,INT1Dh,WK1Dh,nk,auxz,auxq)
+ NST_rh(i,j,k) = auxq
+ ENDDO
+
+ ENDIF
+
+C +---Linear interpolation (pressure coord.) for GRADS output
+C + -------------------------------------------------------
+
+ IF (NSTmod.eq.'GRA') THEN
+
+ IF (i.eq.1.and.j.eq.1) THEN
+ DO k=1,mz
+ NSTgdz(k) = NST__p(i,j,k)
+ ENDDO
+ ENDIF
+
+ DO k=1,mz
+ auxz = NST__p(i,j,k)
+ CALL intLin(INT1Dp,INT1Du,nk+1,auxz,auxu)
+ CALL intLin(INT1Dp,INT1Dv,nk+1,auxz,auxv)
+ CALL intLin(INT1Dp,INT1Dt,nk+1,auxz,auxt)
+ CALL intLin(INT1Dp,INT1Dq,nk+1,auxz,auxq)
+ IF (auxz.le.INT1Dp(nk+1)) THEN
+ NST__u(i,j,k) = auxu
+ NST__v(i,j,k) = auxv
+ NST_pt(i,j,k) = auxt
+ NST_qv(i,j,k) = auxq
+ NST__t(i,j,k) = NST_pt(i,j,k)*(NST__p(i,j,k)/100.)**cap
+ ELSE
+ NST__u(i,j,k) = 999.999 ! Missing value
+ NST__v(i,j,k) = 999.999 ! Avoid extrapolation
+ NST_pt(i,j,k) = 999.999
+ NST_qv(i,j,k) = 999.999
+ NST__t(i,j,k) = 999.999
+ ENDIF
+ ENDDO
+
+ ENDIF
+
+ ENDDO
+ ENDDO
+
+C +---Impose stability of layers for the equiv. potential temp.
+C + ---------------------------------------------------------
+
+c DO j=1,my
+c DO i=1,mx
+c DO k=1,mz
+c NST__t(i,j,k)=NST_pt(i,j,k)/(100./NST__p(i,j,k))**cap
+c EQtemp(k) =NST_pt(i,j,k)
+c . *EXP(h2olv*NST_qv(i,j,k)/cp/NST__t(i,j,k))
+c ENDDO
+c
+c DO k=mz-1,1,-1
+c IF (EQtemp(k).lt.EQtemp(k+1)) THEN
+c EQtemp(k) =EQtemp(k+1)
+c NST_pt(i,j,k)=MAX(NST_pt(i,j,k),EQtemp(k))
+c NST__t(i,j,k)=NST_pt(i,j,k)/(100./NST__p(i,j,k))**cap
+c NST_qv(i,j,k)=cp*NST__t(i,j,k)/h2olv
+c . *LOG(EQtemp(k)/NST_pt(i,j,k))
+c ENDIF
+c ENDDO
+c ENDDO
+c ENDDO
+
+C +---Compute real temperature
+C + ------------------------
+ DO j=1,my
+ DO i=1,mx
+
+ DO k=1,mz
+ NST__t(i,j,k)=NST_pt(i,j,k)*exp(cap*log(NST__p(i,j,k)/100.))
+ ENDDO
+
+ ENDDO
+ ENDDO
+
+C +---Filtering of the surface temperature above sea ice and land
+C + -----------------------------------------------------------
+ DO j=1,my
+ DO i=1,mx
+
+ ! Filtering of STL1 from the ECMWF reanalysis
+
+ if(LSCmod.eq.'E40'.or.LSCmod.eq.'ECM'.or.LSCmod.eq.'GCM'
+ . .or.LSCmod.eq.'MAR'.or.LSCmod.eq.'NCP'
+ . .or.LSCmod.eq.'ECP') then
+
+ if (NSTsol(i,j).ge.3) then
+ NST_st(i,j) = max(NST_st(i,j),NST__t(i,j,mz)-10.)
+ NST_st(i,j) = min(NST_st(i,j),NST__t(i,j,mz)+10.)
+ endif
+
+ if (NSTsol(i,j).le.2) then
+ NST_st(i,j) = max(NST_st(i,j),NST__t(i,j,mz)-15.)
+ NST_st(i,j) = min(NST_st(i,j),NST__t(i,j,mz)+15.)
+ NST_st(i,j) = NSTsic(i,j) * min(273.15,NST_st(i,j))
+ . + (1.-NSTsic(i,j)) * max(270.15,NST_st(i,j))
+ NST_st(i,j) = max(273.15-1.8,NST_st(i,j))
+ endif
+ endif
+
+ if (NSTsol(i,j).ge.3) NSTsst(i,j) = NST_st(i,j)
+
+ ENDDO
+ ENDDO
+
+C!+CA NOR / decreaseSIC : decrease sea-ice extent > WARNING
+ decreaseSIC=.false.
+ if (decreaseSIC) then
+ Do k=1,10
+
+ Do j=1,my
+ Do i=1,mx
+ INtmp1(i,j)=0
+ im1=max(i-1,1)
+ ip1=min(i+1,mx)
+ jm1=max(j-1,1)
+ jp1=min(j+1,my)
+ if (NSTsol(i,j).le.2) then ! sea
+ INtmp1(i,j)=NSTsic(i,j)
+ if (NSTsol(im1,j).le.2) then
+ INtmp1(i,j)=min(INtmp1(i,j),NSTsic(im1,j))
+ endif
+ if (NSTsol(ip1,j).le.2) then
+ INtmp1(i,j)=min(INtmp1(i,j),NSTsic(ip1,j))
+ endif
+ if (NSTsol(i,jm1).le.2) then
+ INtmp1(i,j)=min(INtmp1(i,j),NSTsic(i,jm1))
+ endif
+ if (NSTsol(i,jp1).le.2) then
+ INtmp1(i,j)=min(INtmp1(i,j),NSTsic(i,jp1))
+ endif
+ endif
+ EndDo
+ EndDo
+
+ Do j=1,my
+ Do i=1,mx
+ NSTsic(i,j) = INtmp1(i,j)
+ EndDo
+ EndDo
+
+ EndDo
+ endif
+
+C +---Correct surface pressure <==> Z600 NST = Z600 LSC
+C + =================================================
+ IF (CORzz6.and.NSTmod.ne.'GRA') THEN
+
+C +---Geopotential of 600 hPa level in the NST data
+C + ---------------------------------------------
+
+ DO k = mz,1,-1 !(begin at surface)
+ DO j = 1,my
+ DO i = 1,mx
+ INtmp1(i,j)=NST_pt(i,j,k)
+ INtmp2(i,j)=NST_qv(i,j,k)
+ INtmp3(i,j)=NST__p(i,j,k)
+ END DO
+ END DO
+
+ CALL NSTzz6(INtmp1,INtmp2,NST_sh,NST_sp,INtmp3,k,mx,my,mz,
+ . NSTpk6, NSTpx1, NSTlp1, NSTiZp, iZterm, NST_z6)
+
+ ENDDO
+
+ IF(icheck.ge.1.and.vrbose) THEN
+ WRITE(*,*) 'NST surf press at chk pt', NST_sp(ipchk,jpchk)
+ WRITE(*,*) 'INT Z600 at chk pt', INT_z6(ipchk,jpchk)
+ WRITE(*,*) 'NST Z600 at chk pt', NST_z6(ipchk,jpchk)
+ WRITE(*,*)
+ ENDIF
+
+C +---Correct surface pressure
+C + ------------------------
+ DO j = 1,my
+ DO i = 1,mx
+ NST_sp (i,j)= NST_sp(i,j) * (1.0 +
+ . (INT_z6(i,j)-NST_z6(i,j)) * grav
+ . / (ra*NSTpk6(i,j)*exp(cap*log(60.)) ))
+
+C +.. From Marbaix(2000), Thesis, chapter 3,
+C but with conserverd real temperature as
+C explained in footnote 4 (not as proposed in
+C the thesis, this one is better !)
+
+ END DO
+ END DO
+
+C +---Update p in atm (3D)
+C + --------------------
+
+ CALL NSTvgd (NSTmod,mz,zero,NST_sp,NST__p,NST_hp,NSTgdz)
+
+C +---Update potential temperature
+C + ----------------------------
+ DO j=1,my
+ DO i=1,mx
+
+ DO k=1,mz
+ NST_pt(i,j,k)=NST__t(i,j,k)*exp(cap*log(100./NST__p(i,j,k)))
+ ENDDO
+
+ ENDDO
+ ENDDO
+
+
+C +---Option: Check correction
+C + ------------------------
+
+ IF(icheck.ge.1) THEN
+ DO k = mz,1,-1 !(begin at surface)
+ DO j = 1,my
+ DO i = 1,mx
+ INtmp1(i,j)=NST_pt(i,j,k)
+ INtmp2(i,j)=NST_qv(i,j,k)
+ INtmp3(i,j)=NST__p(i,j,k)
+ END DO
+ END DO
+
+ CALL NSTzz6(INtmp1,INtmp2,NST_sh,NST_sp,INtmp3,k,mx,my,mz,
+ . NSTpk6, NSTpx1, NSTlp1, NSTiZp, iZterm, NST_z6)
+
+ ENDDO
+ erzmax=0.0
+ DO j = 1,my
+ DO i = 1,mx
+ erzmax = max(erzmax, abs(INT_z6(i,j)-NST_z6(i,j)) )
+ END DO
+ END DO
+ IF (erzmax.GE.1.0.and.vrbose) THEN
+ write(*,*) 'WARNING (NSTint): '
+ write(*,*) 'Z600 error remains after correction: ',erzmax
+ write(*,*) ' (this should not occur)'
+ ENDIF
+ ENDIF
+
+ IF(icheck.ge.2.and.vrbose) THEN
+ WRITE(*,*) 'new surf press at chk pt',NST_sp(ipchk,jpchk)
+ WRITE(*,*) 'new Z600 at chk pt',NST_z6(ipchk,jpchk)
+ WRITE(*,*) 'Z600 error after correction (control): ',erzmax
+ WRITE(*,*)
+ ENDIF
+
+ ENDIF ! END CORzz6 section
+
+ IF (NSTmod.ne.'GRA') THEN
+
+C +---Remove all sursaturations
+C + -------------------------
+
+ CORsat = .false.
+
+ DO j=1,my
+ DO i=1,mx
+
+ IF (CORsat) THEN
+ DO k=1,mz
+ qv_max( k)=0.999*qsat(NST__t(i,j,k),NST__p(i,j,k))
+ NST_qv(i,j,k)=MIN(NST_qv(i,j,k),qv_max(k))
+ ENDDO
+ ENDIF
+
+ ENDDO
+ ENDDO
+
+ IF (CORsat.and.vrbose) THEN
+ write(*,*) 'WARNING (NSTint): Sursaturation corr.'
+ write(*,*)
+ ENDIF
+
+C +---Compute levels height
+C + ---------------------
+
+C + ******
+ CALL VERhyd(NST_pt, NST_qv, NST_sh, NST_sp, NST__p,
+ . getpkt, mx, my, mz, NST_zz)
+C + ******
+
+C +---Compute layer depths
+C + --------------------
+
+ DO j=1,my
+ DO i=1,mx
+
+ DO k=1,mz
+ qv_sat(k) = qsat(NST__t(i,j,k),NST__p(i,j,k))
+ rhoair(k) = NST__p(i,j,k)*1000./287./NST__t(i,j,k)
+ ENDDO
+
+ deltaz(mz) = 0.5*(NST_zz(i,j,k-1)-NST_sh(i,j))
+ DO k=2,mz-1
+ deltaz(k) = 0.5*(NST_zz(i,j,k-1)-NST_zz(i,j,k+1))
+ ENDDO
+ deltaz(1) = deltaz(2)
+
+ ENDDO
+ ENDDO
+
+C +---Increase of specific humidity to take into account cloud cover
+C + --------------------------------------------------------------
+
+ IF (CLDcor .AND. nam_QW.EQ.'-') THEN
+
+ IF (vrbose) THEN
+ WRITE(6,'(A)') ' Adding parameterized cloud water to Qv'
+ ENDIF
+
+ DO j=1,my
+ DO i=1,mx
+
+ thr_rh = 0.8
+ qclmax = 0.0005
+ DO k=mz,1,-1
+ qv_sat(k) = qsat(NST__t(i,j,k),NST__p(i,j,k))
+ qv_max(k) = 0.999*qv_sat(k)
+ humrel = NST_qv(i,j,k) / qv_sat(k)
+ qcloud(k) = qclmax * exp(-(1.-humrel)/(1.-thr_rh)*3.)
+ qwater = qcloud(k)*rhoair(k)*deltaz(k)
+ DO kl=k,mz
+ qsuppl = qwater/rhoair(kl)/deltaz(kl)
+ IF ((NST_qv(i,j,kl)+qsuppl).gt.qv_max(kl)) THEN
+ qwater = qwater - (qv_max(kl)-NST_qv(i,j,kl))
+ . *rhoair(kl)*deltaz(kl)
+ qwater = MAX(qwater,nul)
+ NST_qv(i,j,kl) = max(NST_qv(i,j,kl),qv_max(kl))
+ ENDIF
+ ENDDO
+ ENDDO
+
+ ENDDO
+ ENDDO
+
+ ENDIF
+
+C +---Increase of specific humidity to take into the interpolated relative humidity
+C + -----------------------------------------------------------------------------
+
+ DO j=1,my
+ DO i=1,mx
+
+ DO k=1,mz
+ qv_max( k)=qsat(NST__t(i,j,k),NST__p(i,j,k))
+ NST_qv(i,j,k)=max(NST_qv(i,j,k),NST_rh(i,j,k)*qv_max(k))
+ ENDDO
+
+ ENDDO
+ ENDDO
+
+C +---Compute equivalent water content
+C + --------------------------------
+ DO j=1,my
+ DO i=1,mx
+
+ NSTewc(i,j) = 0.
+ DO k=1,mz
+ NSTewc(i,j)= NSTewc(i,j) + NST_qv(i,j,k)*rhoair(k)*deltaz(k)
+ ENDDO
+
+ ENDDO
+ ENDDO
+
+ ENDIF ! {NSTmod.ne.'GRA'}
+
+C +---Close the NetCDF file
+C + =====================
+
+C + *******
+ CALL UNclose (fID)
+C + *******
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ RETURN
+ END
+
+C +--------------------------------------------------------------+
+ SUBROUTINE put2D3 (var2D,lev,var3D)
+C +--------------------------------------------------------------+
+
+C + ** variables dimensions
+ include 'NSTdim.inc'
+
+ REAL var2D (mx,my)
+ REAL var3D (mx,my,nk+1)
+
+ DO j=1,my
+ DO i=1,mx
+ ! No vrbose check: this is mandatory to understand the error.
+ IF (ABS(var2D(i,j)).gt.1.E+29) THEN
+C ... Look for strange values : wrong input file ?
+C ... (side effect of this routine)
+ WRITE(*,*) 'LSget - put2D3 control :'
+ WRITE(*,*) 'Strange value at i,j,lev ='
+ WRITE(*,*) ' ',i,j,lev
+ WRITE(*,*) 'Value = ',var2D (i,j)
+ STOP
+ ENDIF
+ var3D (i,j,lev) = var2D (i,j)
+ ENDDO
+ ENDDO
+
+ RETURN
+ END
+
+C +--------------------------------------------------------------+
+ SUBROUTINE LSuCHG (var2D,unitfact)
+C +--------------------------------------------------------------+
+
+ include 'NSTdim.inc'
+
+ REAL var2D (ni,nj)
+ REAL unitfact
+
+ DO j=1,nj
+ DO i=1,ni
+ var2D (i,j) = var2D (i,j) * unitfact
+ ENDDO
+ ENDDO
+
+ RETURN
+ END
+
+C +--------------------------------------------------------------+
+ FUNCTION qsat(tt,pr)
+C +--------------------------------------------------------------+
+
+C Function qsat computes the Saturation Specific Humidity (kg/kg)
+
+ DATA r273p1/273.16/
+
+ IF (tt.ge.273.16) THEN
+
+ esat = 6.1078 * exp (5.138*log(r273p1/tt))
+ . * exp (6827.*(1.0/r273p1-1.0/tt))
+
+C +... esat : saturated vapor pressure with respect to water
+C +... Dudhia (1989) MWR, (B1) and (B2) p.3103
+C +... See also Pielke (1984), p.234 and Stull (1988), p.276
+
+ ELSE
+
+ esat = 6.107 * exp (6150.*(1.0/r273p1-1.0/tt))
+
+C +... esat : saturated vapor pressure with respect to ice
+C +... Dudhia (1989) MWR, 1989, (B1) and (B2) p.3103
+
+ ENDIF
+
+ qsat = 0.622*esat/(10.*pr-0.378*esat)
+C +...pr : pressure (kPa) multiplied by 10. -> hPa
+
+ RETURN
+ END
+
+C +--------------------------------------------------------------+
+ FUNCTION esat(tt,pr) ! hPa
+C +--------------------------------------------------------------+
+
+C Function qsat computes the Saturation Specific Humidity (kg/kg)
+
+ DATA r273p1/273.16/
+
+ IF (tt.ge.273.16) THEN
+
+ esat = 6.1078 * exp (5.138*log(r273p1/tt))
+ . * exp (6827.*(1.0/r273p1-1.0/tt))
+
+C +... esat : saturated vapor pressure with respect to water
+C +... Dudhia (1989) MWR, (B1) and (B2) p.3103
+C +... See also Pielke (1984), p.234 and Stull (1988), p.276
+
+ ELSE
+
+ esat = 6.107 * exp (6150.*(1.0/r273p1-1.0/tt))
+
+C +... esat : saturated vapor pressure with respect to ice
+C +... Dudhia (1989) MWR, 1989, (B1) and (B2) p.3103
+
+ ENDIF
+
+ RETURN
+ END
+
+C +--------------------------------------------------------------+
+ SUBROUTINE VALchk (varname,nx,ny,var,lwb,upb)
+C +--------------------------------------------------------------+
+
+ IMPLICIT NONE
+
+ INTEGER nx,ny,i,j,ierror,ipe,jpe
+ REAL var (nx,ny)
+ REAL lwb,upb
+ CHARACTER*7 varname
+
+ ierror = 0
+
+ DO j=1,ny
+ DO i=1,nx
+ IF (var(i,j).lt.lwb .or.
+ . var(i,j).gt.upb) THEN
+ ierror = ierror+1
+ ipe = i
+ jpe = j
+ ENDIF
+ ENDDO
+ ENDDO
+
+ ! No vrbose check: this is mandatory to understand the error.
+ IF (ierror.ge.1) THEN
+ write(6,*)
+ write(6,*)
+ write(6,*) 'The range of values for the variable'
+ write(6,*) ' ',varname,' in large-scale fields'
+ write(6,*) 'is probably incorrect (out of specified'
+ write(6,*) 'bounds). Please check it before running'
+ write(6,*) 'Error is found on',ierror,'points'
+ write(6,*) 'such as (i,j)=', ipe,jpe
+ write(6,*) 'value =', var(ipe,jpe)
+ write(6,*)
+ write(6,*) 'NESTOR. --- STOP'
+ write(6,*)
+ STOP
+ ENDIF
+
+ RETURN
+ END
diff --git a/MAR/code_nestor/src/NSTout.f b/MAR/code_nestor/src/NSTout.f
new file mode 100644
index 0000000000000000000000000000000000000000..1c99e02ef194264a8f9bb7fb0e9ccf6841246018
--- /dev/null
+++ b/MAR/code_nestor/src/NSTout.f
@@ -0,0 +1,529 @@
+C +-------------------------------------------------------------------+
+C | Subroutine NSTout January 2004 NESTING |
+C +-------------------------------------------------------------------+
+C | |
+C | Input : Interpolated LSC (large-scale) fields |
+C | ^^^^^^^ |
+C | |
+C | Output: Creation of Netcdf file containing most of interpolated |
+C | ^^^^^^^ meteorological fields (wind, temperature, humidity, ...) |
+C | This NetCDF File is adapted to IDL Graphic Software. |
+C | |
+C | Note that this routine requires the usual NetCDF library, and a |
+C | complementary access to the library named 'libUN.a'. |
+C | |
+C +-------------------------------------------------------------------+
+
+
+ SUBROUTINE NSTout
+
+
+ IMPLICIT NONE
+
+
+C +---General variables
+C + =================
+
+ include 'NSTdim.inc'
+ include 'NSTvar.inc'
+ include 'NESTOR.inc'
+
+C +---Parameters
+C + ==========
+
+ INTEGER i,j,k,it,NdimNC,MXdim,MX_var,NattNC,nnsl
+
+ PARAMETER (NdimNC = 5)
+C +...Number of defined spatial dimensions (exact)
+
+ PARAMETER (MXdim = 20000)
+C +...Maximum Number of all dims: recorded Time Steps
+C + and also maximum of spatial grid points for each direction.
+
+ PARAMETER (MX_var = 200)
+C +...Maximum Number of Variables
+
+ PARAMETER (NattNC = 2)
+C +...Number of real attributes given to all variables
+
+
+C +---Local variables
+C + ===============
+
+ INTEGER nbchar,ID__nc,Rcode,ipr_nc,NtotNC,npr_nc,
+ . INImma,INIjda,INIjhu,MMXstp,itotNC,year_1,year_2
+
+ INTEGER*4 TMPdat
+
+ INTEGER nDFdim(0:NdimNC),NvatNC(NattNC)
+
+ REAL dateNC(MXdim),VALdim(MXdim,0:NdimNC),
+ . WK2D_1(mx,my),WK2D_2(mx,my),WK2D_3(mx,my),
+ . WK2D_4(mx,my),WK2D_5(mx,my),WK2D_6(mx,my),
+ . WK2D_7(mx,my),WK2D_8(mx,my),timeNC(MXdim),
+ . WK2D_9(mx,my,nvx),WK2D10(mx,my,nvx)
+
+ CHARACTER*2 nustri(0:99)
+ CHARACTER*13 NAMdim(0:NdimNC),nameNC(MX_var),
+ . SdimNC(4,MX_var),NAMrat(NattNC)
+ CHARACTER*31 UNIdim(0:NdimNC),unitNC(MX_var)
+ CHARACTER*17 suffix
+ CHARACTER*50 lnamNC(MX_var)
+ CHARACTER*90 fnamNC,fnam_U,fnam_V,fnam_T,fnam_Q,
+ . fnamSP,fnamSH
+ CHARACTER*100 tit_NC
+ CHARACTER*120 tmpINP
+
+ LOGICAL Vfalse,Tferret
+ common/NSTvou_r/timeNC
+
+C +---Data
+C + ====
+
+ DATA Tferret / .true. / ! Time base for FERRET graphic tools
+
+ DATA Vfalse / .false. /
+
+ DATA (nustri(i),i=0,99)
+ . /'00','01','02','03','04','05','06','07','08','09',
+ . '10','11','12','13','14','15','16','17','18','19',
+ . '20','21','22','23','24','25','26','27','28','29',
+ . '30','31','32','33','34','35','36','37','38','39',
+ . '40','41','42','43','44','45','46','47','48','49',
+ . '50','51','52','53','54','55','56','57','58','59',
+ . '60','61','62','63','64','65','66','67','68','69',
+ . '70','71','72','73','74','75','76','77','78','79',
+ . '80','81','82','83','84','85','86','87','88','89',
+ . '90','91','92','93','94','95','96','97','98','99'/
+
+ nnsl = nsl
+
+
+C +---Initial date of run
+C + ===================
+
+C + ******
+ CALL DATcnv (RUNiyr,INImma,INIjda,INIjhu,DATini,Vfalse)
+C + ******
+
+
+C +---Output directory
+C + ================
+
+ nbchar=1
+
+ DO i=1,60
+ IF (NSTdir(i:i).ne.' ') nbchar=i
+ ENDDO
+
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ IF (NSTmod.ne.'GRA') THEN
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Output file name
+C + ================
+
+ year_1 = INT(AINT(REAL(RUNiyr)/100.))
+ year_2 = RUNiyr-(year_1*100)
+
+ fnamNC = NSTdir(1:nbchar)// 'NST' // '.'
+ . // nustri(year_1) // nustri(year_2) // '.'
+ . // nustri(INImma) // '.'
+ . // nustri(INIjda) // '.'
+ . // nustri(INIjhu) // '.'
+ . // LABlio // '.nc'
+
+ ! JFG 02/05/2022: added "vrbose" check (new verbose mode).
+ ! Note: next lines are still printed the first time (creation).
+ IF ((DATini.eq.DATtim).or.vrbose) THEN
+ write(6,*) 'Graphic output'
+ write(6,*) '~~~~~~~~~~~~~~'
+ write(6,*) 'File : ',fnamNC
+ write(6,*)
+ ENDIF
+
+C +---NetCDF File Initialization
+C + ==========================
+
+ IF (DATini.eq.DATtim) THEN
+
+C +---Output Title
+C + ------------
+
+ tit_NC = 'NESTOR output'
+ . // ' - Mod: ' // NSTmod
+ . // ' - Exp: ' // LABlio
+ . // ' - '
+ . // nustri(year_1) // nustri(year_2) // '/'
+ . // nustri(INImma) // '/'
+ . // nustri(INIjda) // '/'
+ . // nustri(INIjhu)
+
+
+C +---Number of time steps
+C + --------------------
+
+ npr_nc = DATstp
+
+
+C +---Check of size of temporary arrays
+C + ---------------------------------
+
+ MMXstp = MXdim
+
+ IF (npr_nc.gt.MMXstp)
+ . STOP '*** NSTout - ERROR : MXdim to low (temporally)***'
+
+ IF (mx.gt.MMXstp.or.my.gt.MMXstp.or.(mz+1).gt.MMXstp)
+ . STOP '*** NSTout - ERROR : MXdim to low (spatially) ***'
+
+
+C +---Time Variable (date)
+C + --------------------
+
+ DO it=1,npr_nc
+
+ TMPdat = DATini + (it-1)*DAT_dt
+
+ timeNC(it)=REAL(TMPdat - 16664520+15*24)
+C +... HOURS since 1901-01-15 00:00:00
+
+C + ******
+ CALL DATcnv (RUNiyr,RUNmma,RUNjda,RUNjhu,TMPdat,Vfalse)
+C + ******
+ dateNC(it)=REAL(RUNjhu)+1.d2*REAL(RUNjda)+1.d4*REAL(RUNmma)
+
+ ENDDO
+
+
+C +---Define temporal and spatial dimensions
+C + --------------------------------------
+
+ DO it = 1,npr_nc
+ VALdim(it,0) = REAL(INIjhu + (it-1)*DAT_dt) ! hours
+ ENDDO
+ IF (Tferret) THEN
+ DO it = 1,npr_nc
+ VALdim(it,0) = timeNC(it) ! Hours since 1901-01-15
+ ENDDO
+ ENDIF
+ nDFdim(0)= npr_nc
+ nDFdim(0)= 0
+ NAMdim(0)= 'time'
+ UNIdim(0)= 'HOURS since 1901-01-15 00:00:00'
+
+ DO i=1,mx
+ VALdim(i,1) = NSTgdx(i)
+ ENDDO
+ nDFdim(1)= mx
+ NAMdim(1)= 'x'
+ UNIdim(1)= 'km'
+
+ DO j=1,my
+ VALdim(j,2) = NSTgdy(j)
+ ENDDO
+ nDFdim(2)= my
+ NAMdim(2)= 'y'
+ UNIdim(2)= 'km'
+
+ DO k=1,mz
+ VALdim(k,3) = NSTgdz(k)
+ ENDDO
+ nDFdim(3)= mz
+ NAMdim(3)= 'level'
+ UNIdim(3)= '[sigma]'
+
+ DO k = 1,nvx
+ VALdim(k,4) = k
+ ENDDO
+ nDFdim(4)= nvx
+ NAMdim(4)= 'sector'
+ UNIdim(4)= '[index]'
+
+ DO k = 1,nsl
+ VALdim(k,5) = k
+ ENDDO
+ nDFdim(5)= nsl
+ NAMdim(5)= 'soil'
+ UNIdim(5)= '[index]'
+
+
+C +---Variable's Choice (Table LSMvou.dat)
+C + ------------------------------------
+
+ OPEN(unit=15,status='unknown',file='NSTvou.dat')
+
+ itotNC = 0
+
+980 CONTINUE
+ READ (15,'(A120)',end=990) tmpINP
+
+ IF (tmpINP(1:4).eq.' ') THEN
+ itotNC = itotNC + 1
+ READ (tmpINP,'(4x,5A9,A12,A25)')
+ . nameNC(itotNC) ,SdimNC(1,itotNC),SdimNC(2,itotNC),
+ . SdimNC(3,itotNC),SdimNC(4,itotNC),unitNC(itotNC) ,
+ . lnamNC(itotNC)
+C +... - nameNC: Name
+C +... - SdimNC: Names of Selected Dimensions (max.4/variable)
+C +... - unitNC: Units
+C +... - lnamNC: Long_name, a description of the variable
+ ENDIF
+
+ GOTO 980
+990 CONTINUE
+
+ NtotNC = itotNC
+C +... NtotNC : Total number of variables writen in NetCDF file
+
+
+C +---List of NetCDF attributes given to all variables
+C + ------------------------------------------------
+
+ NAMrat(1) = 'actual_range'
+ NvatNC(1) = 2
+
+ NAMrat(2) = 'valid_range'
+ NvatNC(2) = 2
+
+C NAMrat(NattNC) = '[var]_range'
+C NvatNC(NattNC) = 2
+C Used by IDL/INA but probably not by ferret...
+C (purpose was to create animations)
+
+
+C +---Automatic Generation of the NetCDF File Structure
+C + -------------------------------------------------
+
+C + *********
+ CALL UNscreate (fnamNC,tit_NC,NdimNC,nDFdim,MXdim ,NAMdim,
+ . UNIdim,VALdim,MX_var,NtotNC,nameNC,SdimNC,
+ . unitNC,lnamNC,NattNC,NAMrat,NvatNC,ID__nc)
+C + *********
+
+
+C +---Write Time - Constants fields
+C + -----------------------------
+
+ DO j=1,my
+ DO i=1,mx
+ WK2D_3(i,j)=NST_ts(i,j,1,1)
+ WK2D_4(i,j)=NST_ts(i,j,1,2)
+ WK2D_5(i,j)=NST_sw(i,j,1,1)
+ WK2D_6(i,j)=NST_sw(i,j,1,2)
+ WK2D_7(i,j)=REAL(NSTsol(i,j))
+ WK2D_8(i,j)=REAL(NSTtex(i,j))
+ DO k=1,nvx
+ WK2D_9(i,j,k)=REAL(NSTveg(i,j,k))
+ WK2D10(i,j,k)=REAL(NSTsvt(i,j,k))
+ ENDDO
+ ENDDO
+ ENDDO
+
+C + *******
+ CALL UNwrite (ID__nc, 'DATE ', 1 , npr_nc, 1 , 1 , dateNC)
+ CALL UNwrite (ID__nc, 'LON ', 1 , mx , my, 1 , NST__x)
+ CALL UNwrite (ID__nc, 'LAT ', 1 , mx , my, 1 , NST__y)
+ CALL UNwrite (ID__nc, 'SH ', 1 , mx , my, 1 , NST_sh)
+ CALL UNwrite (ID__nc, 'SOL ', 1 , mx , my, 1 , WK2D_7)
+ CALL UNwrite (ID__nc, 'TEX ', 1 , mx , my, 1 , WK2D_8)
+ CALL UNwrite (ID__nc, 'Z0 ', 1 , mx , my, 1 , NST_z0)
+ CALL UNwrite (ID__nc, 'R0 ', 1 , mx , my, 1 , NST_r0)
+
+ CALL UNwrite (ID__nc, 'VEG ', 1 , mx , my, nvx, WK2D_9)
+ CALL UNwrite (ID__nc, 'SVT ', 1 , mx , my, nvx, WK2D10)
+
+ CALL UNwrite (ID__nc, 'ALB ', 1 , mx , my, 1 , NSTalb)
+ CALL UNwrite (ID__nc, 'DSA ', 1 , mx , my, 1 , NSTdsa)
+
+ CALL UNwrite (ID__nc, 'DV1 ', 1 , mx , my, 1 , NSTdv1)
+ CALL UNwrite (ID__nc, 'DV2 ', 1 , mx , my, 1 , NSTdv2)
+
+ CALL UNwrite (ID__nc, 'TS ', 1 , mx , my, nsl, NST_ts)
+ CALL UNwrite (ID__nc, 'SW ', 1 , mx , my, nsl, NST_sw)
+
+ CALL UNwrite (ID__nc, 'RES ', 1 , mx , my, 1 , NSTres)
+C + *******
+
+ DO j=1,my
+ DO i=1,mx
+ DO k=1,nvx
+ WK2D_9(i,j,k)=REAL(NSTvfr(i,j,k))
+ WK2D10(i,j,k)=REAL(NSTsfr(i,j,k))
+ ENDDO
+ ENDDO
+ ENDDO
+
+C + *******
+ CALL UNwrite (ID__nc, 'FRC ', 1 , mx , my, 1 , NSTfrc)
+ CALL UNwrite (ID__nc, 'VFR ', 1 , mx , my, nvx, WK2D_9)
+ CALL UNwrite (ID__nc, 'SFR ', 1 , mx , my, nvx, WK2D10)
+C + *******
+
+ ELSE
+
+C +---Re-Open file if already created.
+C + ================================
+
+
+C + *******
+ CALL UNwopen (fnamNC,ID__nc)
+C + *******
+
+ END IF
+
+
+C +---Write time-dependent variables
+C + ==============================
+
+ ipr_nc=(DATtim-DATini)/DAT_dt + 1
+
+ DO j=1,my
+ DO i=1,mx
+ WK2D_1(i,j) = 0.0
+ WK2D_2(i,j) = 0.0
+ DO k=1,nvx-1
+ WK2D_1(i,j) = WK2D_1(i,j)
+ . + NSTglf(i,j,k)*REAL(NSTsfr(i,j,k))/100.
+ WK2D_2(i,j) = WK2D_2(i,j)
+ . + NSTlai(i,j,k)
+ . *NSTglf(i,j,k)*REAL(NSTsfr(i,j,k))/100.
+ ENDDO
+ ENDDO
+ ENDDO
+
+
+C + *******
+ CALL UNwrite (ID__nc, 'time' , ipr_nc, 1, 1, 1 ,
+ . timeNC(ipr_nc))
+ CALL UNwrite (ID__nc, 'UU ', ipr_nc, mx, my, mz , NST__u)
+ CALL UNwrite (ID__nc, 'VV ', ipr_nc, mx, my, mz , NST__v)
+ CALL UNwrite (ID__nc, 'TT ', ipr_nc, mx, my, mz , NST__t)
+ CALL UNwrite (ID__nc, 'PT ', ipr_nc, mx, my, mz , NST_pt)
+ CALL UNwrite (ID__nc, 'RH ', ipr_nc, mx, my, mz , NST_rh)
+ CALL UNwrite (ID__nc, 'QQ ', ipr_nc, mx, my, mz , NST_qv)
+ CALL UNwrite (ID__nc, 'ZZ ', ipr_nc, mx, my, mz , NST_zz)
+ CALL UNwrite (ID__nc, 'SP ', ipr_nc, mx, my, 1 , NST_sp)
+ CALL UNwrite (ID__nc, 'ST ', ipr_nc, mx, my, 1 , NST_st)
+ CALL UNwrite (ID__nc, 'SST ', ipr_nc, mx, my, 1 , NSTsst)
+ CALL UNwrite (ID__nc, 'SIC ', ipr_nc, mx, my, 1 , NSTsic)
+ CALL UNwrite (ID__nc, 'EWC ', ipr_nc, mx, my, 1 , NSTewc)
+ CALL UNwrite (ID__nc, 'NDV ', ipr_nc, mx, my, 1 , NSTndv)
+ CALL UNwrite (ID__nc, 'LAI ', ipr_nc, mx, my, nvx, NSTlai)
+ CALL UNwrite (ID__nc, 'GLF ', ipr_nc, mx, my, nvx, NSTglf)
+ CALL UNwrite (ID__nc, 'EFRV ', ipr_nc, mx, my, 1 , WK2D_1)
+ CALL UNwrite (ID__nc, 'ELAI ', ipr_nc, mx, my, 1 , WK2D_2)
+ CALL UNwrite (ID__nc, 'ICE ', ipr_nc, mx, my, 1 , NSTice)
+ CALL UNwrite (ID__nc, 'GROUND ', ipr_nc, mx, my, 1 , NSTgrd)
+ CALL UNwrite (ID__nc, 'ROCK ', ipr_nc, mx, my, 1 , NSTrck)
+ CALL UNwrite (ID__nc, 'AREA ', ipr_nc, mx, my, 1 , NSTarea)
+C + *******
+
+
+C +---NetCDF File Closure
+C + ===================
+
+C + ******
+ CALL NCCLOS (ID__nc, Rcode)
+C + ******
+
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ ENDIF
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ ! JFG remark (02/05/2022): is this still useful ?
+ IF (NSTmod.eq.'GRA') THEN
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Open unformatted files
+C + ======================
+
+ IF (DATini.eq.DATtim) THEN
+
+ year_1 = INT(AINT(REAL(RUNiyr)/100.))
+ year_2 = RUNiyr-(year_1*100)
+
+ suffix = nustri(year_1) // nustri(year_2) // '.'
+ . // nustri(INImma) // '.'
+ . // nustri(INIjda) // '.'
+ . // nustri(INIjhu) // '.bin'
+
+ fnam_U = NSTdir(1:nbchar)// 'U__' // suffix
+ fnam_V = NSTdir(1:nbchar)// 'V__' // suffix
+ fnam_T = NSTdir(1:nbchar)// 'T__' // suffix
+ fnam_Q = NSTdir(1:nbchar)// 'Q__' // suffix
+ fnamSP = NSTdir(1:nbchar)// 'SP_' // suffix
+ fnamSH = NSTdir(1:nbchar)// 'SH_' // suffix
+
+ IF (vrbose) THEN
+ write(6,*) 'Graphic output'
+ write(6,*) '~~~~~~~~~~~~~~'
+ write(6,*) 'Files : ',fnam_U
+ write(6,*) ' ',fnam_V
+ write(6,*) ' ',fnam_T
+ write(6,*) ' ',fnam_Q
+ write(6,*) ' ',fnamSP
+ write(6,*) ' ',fnamSH
+ write(6,*)
+ ENDIF
+
+ OPEN (unit=61,status='unknown',form='unformatted',file=fnam_U)
+ OPEN (unit=62,status='unknown',form='unformatted',file=fnam_V)
+ OPEN (unit=63,status='unknown',form='unformatted',file=fnam_T)
+ OPEN (unit=64,status='unknown',form='unformatted',file=fnam_Q)
+ OPEN (unit=65,status='unknown',form='unformatted',file=fnamSP)
+ OPEN (unit=66,status='unknown',form='unformatted',file=fnamSH)
+
+ ENDIF
+
+
+C +---Write variables in output file
+C + ==============================
+
+ IF (vrbose) THEN
+ write(6,*) 'Graphic output'
+ write(6,*) '~~~~~~~~~~~~~~'
+ write(6,*) 'Append unformatted files'
+ write(6,*)
+ ENDIF
+
+ WRITE(61) NST__u
+ WRITE(62) NST__v
+ WRITE(63) NST__t
+ WRITE(64) NST_qv
+ WRITE(65) NST_sp
+ WRITE(66) NST_sh
+
+
+C +---Close unformatted files
+C + =======================
+
+ IF (DATtim.eq.DATfin) THEN
+ CLOSE (unit=61)
+ CLOSE (unit=62)
+ CLOSE (unit=63)
+ CLOSE (unit=64)
+ CLOSE (unit=65)
+ CLOSE (unit=66)
+ ENDIF
+
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ ENDIF
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+ RETURN
+ END
diff --git a/MAR/code_nestor/src/NSTphy.inc b/MAR/code_nestor/src/NSTphy.inc
new file mode 100644
index 0000000000000000000000000000000000000000..19acded405d78581be569e623eeb7427e93252af
--- /dev/null
+++ b/MAR/code_nestor/src/NSTphy.inc
@@ -0,0 +1,35 @@
+C +...*Physical constants (NESTOR & MAPOST)
+C + -------------------------------------
+
+ REAL cp, cap, ra, grav, gamTz
+ REAL pi, epsi, earthr, degrad, hourad
+
+
+ PARAMETER (pi= 3.14159265358979d0)
+C +... The well known value of acos(-1) ;-).
+
+ PARAMETER (degrad= pi / 180.d0)
+ PARAMETER (hourad= pi / 12.d0)
+C +... From deg to rad, and hour to rad.
+
+ PARAMETER (epsi= 1.0d-6)
+C +... The definition of "little" by Hub.
+
+ PARAMETER (earthr= 6371.229d+3)
+C +... The radius of the little blue ball.
+
+ PARAMETER (ra= 287.d0)
+C +... Perfect Gas Law Constant (J/kg/K)
+
+ PARAMETER (cp= 1004.d0)
+C +... Air Specific Heat (J/kg/K)
+
+ PARAMETER (cap= 0.28586d0)
+C +... Kappa = R/Cp
+
+ PARAMETER (grav= 9.81 d0)
+C +... The way we are falling (m/s2)
+
+ PARAMETER (gamTz = - 6.5E-3)
+C +... Mean temperature gradient (K/m)
+
diff --git a/MAR/code_nestor/src/NSTvar.inc b/MAR/code_nestor/src/NSTvar.inc
new file mode 100644
index 0000000000000000000000000000000000000000..3235d5e369eceaf296f1c733d5a9aba2acb0e9e6
--- /dev/null
+++ b/MAR/code_nestor/src/NSTvar.inc
@@ -0,0 +1,144 @@
+
+!-Nested model
+! ------------
+
+ CHARACTER*3 NSTmod
+
+! ....NSTmod : acronym of the nested model
+
+
+!-Horizontal and vertical grid
+! ----------------------------
+
+ REAL NST__x(mx,my),NST__y(mx,my), &
+ & NSTgdx(mx) ,NSTgdy(my) ,NSTgdz(mz) , &
+ & NST_dx,NSTrcl
+
+ LOGICAL NSTinc(mx,my,nbdom)
+
+! ....NST__x : X-coordinates (longitude)
+! ....NST__y : Y-coordinates (latitude)
+! ....NSTgdx : simple X-grid (specific to each model)
+! ....NSTgdy : simple Y-grid (specific to each model)
+! ....NSTgdz : simple Z-grid (specific to each model)
+! ....NST_dx : horizontal resolution for regular grid
+! ....NSTinc : Check the location (continent) of a grid point
+
+
+!-2-D surface variables
+! ---------------------
+
+ REAL NST_st(mx,my),NSTdst(mx,my),NST_sp(mx,my), &
+ & NST_sh(mx,my),NST_pr(mx,my),NST_sn(mx,my), &
+ & NST_z0(mx,my),NST_r0(mx,my),NST_d1(mx,my), &
+ & NSTalb(mx,my),NSTeps(mx,my),NSTres(mx,my), &
+ & NSTch0(mx,my),NSTIpr(mx,my),NSTewc(mx,my), &
+ & NSTsst(mx,my),NSTuts(mx,my),NSTpr1(mx,my), &
+ & NSTpr2(mx,my),NSTpr3(mx,my),NSTsic(mx,my), &
+ & NSTzor(mx,my)
+
+ INTEGER NSTveg(mx,my,nvx),NSTsvt(mx,my,nvx), &
+ & NSTiwf(mx,my ),NSTsol(mx,my ), &
+ & NSTtex(mx,my )
+
+ REAL NSTlai(mx,my,nvx),NSTglf(mx,my,nvx), &
+ & NSTvfr(mx,my,nvx),NSTsfr(mx,my,nvx), &
+ & NSTdsa(mx,my ),NSTlmx(mx,my,nvx), &
+ & NSTfrc(mx,my ),NSTdv1(mx,my ), &
+ & NSTdv2(mx,my ),NSTndv(mx,my ), &
+ & NSTice(mx,my ),NSTgrd(mx,my ), &
+ & NSTrck(mx,my ),NSTarea(mx,my)
+
+! ....NST_st : soil or sea surface temperature
+! ....NSTsst : sea surface temperature (Reynolds)
+! ....NSTdst : deep soil temperature
+! ....NST_sp : surface pressure
+! ....NST_sh : surface elevation
+! ....NSTpr1 : desaggregated precipitation (without conservation)
+! ....NSTpr2 : desaggregated precipitation (with global conservation)
+! ....NSTpr3 : desaggregated precipitation (with local and global conservation)
+! ....NSTsic : Sea-Ice Fraction
+! ....NSTIpr : rain precipitation (non desaggregated)
+! ....NSTewc : equivalent water content (water vapor)
+! ....NST_sn : snow precipitation
+! ....NSTsol : soil types (water,ice,snow,land,...)
+! ....NST_z0 : roughness length for momentum
+! ....NST_r0 : roughness length for heat
+! ....NSTtex : soil texture
+! ....NST_d1 : surface heat capacity (Deardorff, 1978)
+! ....NSTalb : surface albedo
+! ....NSTeps : surface IR emissivity
+! ....NSTres : aerodynamic resistance
+! ....NSTch0 : bulk aerodynamic coefficient air/surface
+! .... humidity flux
+! ....NSTveg : vegetation type (IGBP classification)
+! ....NSTvfr : fraction of vegetation grid cells (IGBP)
+! ....NSTsvt : vegetation type (SVAT classification)
+! ....NSTsfr : fraction of vegetation grid cells (SVAT)
+! ....NSTfrc : fraction of vegetation cover (from NDVI)
+! ....NSTndv : NDVI index
+! ....NSTdv1 : minimum NDVI index
+! ....NSTdv2 : maximum NDVI index
+! ....NSTlai : leaf area index
+! ....NSTglf : green leaf fraction
+! ....NSTdsa : dry soil albedo
+! ....NSTiwf : 0=no water flux, 1=free drainage
+! ....NSTuts : surface heat flux
+! ....NSTzor : roughness length for momentum / orography contribution
+! ....NSTice : ice(land-ice+ice-sheves)/sea(ocean+sea-ice) fraction
+! ....NSTgrd : fraction of land ice that is grounded
+! ....NSTrck : fraction of cell containing rock
+! ....NSTarea: cell area
+
+
+!-2.5-D surface variables
+! -----------------------
+
+ REAL NST_ts(mx,my,nvx,nsl),NST_sw(mx,my,nvx,nsl)
+
+! ....NST_ts : soil temperature
+! ....NST_sw : soil moisture content
+
+
+!-3-D atmospheric variables
+! -------------------------
+ REAL NST_hp(mx,my,mz)
+! ....NST_hp : Local vertic coordinate for interpolation
+
+ REAL NST__u(mx,my,mz),NST__v(mx,my,mz),NST__w(mx,my,mz), &
+ & NST_pt(mx,my,mz),NST__t(mx,my,mz),NST_qv(mx,my,mz), &
+ & NST_zz(mx,my,mz),NST__p(mx,my,mz),NSTtke(mx,my,mz), &
+ & NST_qt(mx,my,mz),NSTtmp(mx,my,mz+1),NST_rh(mx,my,mz)
+
+! ....NST__u : U-wind
+! ....NST__v : V-wind
+! ....NST__w : W-wind
+! ....NST_pt : potential temperature
+! ....NST__t : real temperature
+! ....NST_qv : specific humidity
+! ....NST_rh : relative humidity
+! ....NST_zz : geopotential height
+! ....NST__p : pressure at each level
+! ....NSTtke : turbulent kinetic energy
+! ....NST_qt : total cloud water content
+! ....NSTtmp : temporary array
+
+
+ COMMON/NSTvar_c/NSTmod
+
+ COMMON/NSTvar_i/NSTveg,NSTsvt,NSTiwf,NSTsol, &
+ & NSTtex
+
+ COMMON/NSTvar_l/NSTinc
+
+ COMMON/NSTvar_r/NST__x,NST__y,NSTgdx,NSTgdy,NSTgdz,NST_dx, &
+ & NST_st,NSTdst,NST_sp,NST_sh,NST_pr,NST_sn, &
+ & NST_z0,NST_r0,NST_d1,NSTalb,NSTeps,NSTres, &
+ & NSTch0,NSTIpr,NSTewc,NSTsst,NSTuts,NSTpr1, &
+ & NSTpr2,NSTpr3,NSTlai,NSTglf,NSTdsa,NSTlmx, &
+ & NSTfrc,NSTdv1,NSTdv2,NSTndv,NST_ts,NST_sw, &
+ & NST_hp,NST__u,NST__v,NST__w,NST_pt,NST__t, &
+ & NST_qv,NST_zz,NST__p,NSTtke,NST_qt,NSTtmp, &
+ & NSTsic,NST_rh,NSTvfr,NSTsfr,NSTice,NSTzor, &
+ & NSTrcl, NSTgrd,NSTrck,NSTarea
+
diff --git a/MAR/code_nestor/src/NSTvgd.f b/MAR/code_nestor/src/NSTvgd.f
new file mode 100644
index 0000000000000000000000000000000000000000..313366ef28ad21d4d21bf775c9175bf2f15a2bd3
--- /dev/null
+++ b/MAR/code_nestor/src/NSTvgd.f
@@ -0,0 +1,74 @@
+C +-------------------------------------------------------------------+
+C | Subroutine NSTvgd 13-04-2022 JFG |
+C +-------------------------------------------------------------------+
+C | |
+C | Creation of the (nested) vertical grid of a given model. |
+C | |
+C | Input : - NSTmod : selected NST (nested) model |
+C | ^^^^^^^ - nz : number of vertical levels (N.B.: nz rather |
+C | than nk because nk already used in NSTdim.inc) |
+C | - k : if specified, the level at which pressure and |
+C | hybrid coordinate has to be computed |
+C | - VGD_sp(mx,my) : surface pressure |
+C | |
+C | Output: Vertical grid of the LSC model : |
+C | ^^^^^^^ - VGD__p(mx,my,nz+1) : pressure at each level [kPa] |
+C | - VGD_hp(mx,my,nz+1) : local hybrid coord. for vertical |
+C | interpolation |
+C | - VGDgdz(nz ) : model coordinates (sigma) |
+C | |
+C | J.-F. Grailet remarks: |
+C | ^^^^^^^^^^^^^^^^^^^^^^ |
+C | 1) Contrary to LSCvgd, this routine does not require the complete |
+C | dimensions of the input grids as parameters. This is because |
+C | NSTvgd is exclusively used in practice with the dimensions of |
+C | the nested grid (LSCvgd can be used with both). |
+C | 2) There is also no fID parameter either, because subroutines |
+C | read mandatory files (e.g., MARgrd.ctr) or hard-codes the |
+C | pressure levels (see GRAvgd.f). |
+C | |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE NSTvgd (NSTmod,nz,k,VGD_sp,VGD__p,VGD_hp,VGDgdz)
+
+ IMPLICIT NONE
+
+ INCLUDE 'NSTdim.inc' ! Provides mx, my
+
+C +---Local variables
+C + ===============
+
+ INTEGER nz,k
+
+ REAL VGD_sp(mx,my),VGD__p(mx,my,nz+1),VGD_hp(mx,my,nz+1),
+ . VGDgdz(nz)
+
+ CHARACTER*3 NSTmod
+
+C +---Creation of the vertical grid depending on the specified model
+C + ==============================================================
+
+C +---Modele Atmospherique Regional (MAR)
+C + -----------------------------------
+
+ IF (NSTmod.eq.'MAR'.or.NSTmod.eq.'M2D')
+
+ . CALL MRNvgd (nz,k,VGD_sp,VGD__p,VGD_hp,VGDgdz)
+
+C +---GRADS output analysis
+C + ---------------------
+
+ ! J.-F. G. remark: also no VGDgdz as argument in original code
+ IF (NSTmod.eq.'GRA')
+
+ . CALL GRAvgd (nz,k,VGD_sp,VGD__p,VGD_hp)
+
+C +---Output for SVAT coupling
+C + ------------------------
+
+ IF (NSTmod.eq.'CPL')
+
+ . CALL CPLvgd (nz,k,VGD_sp,VGD__p,VGD_hp,VGDgdz)
+
+ RETURN
+ END
diff --git a/MAR/code_nestor/src/NSTzz6.f b/MAR/code_nestor/src/NSTzz6.f
new file mode 100644
index 0000000000000000000000000000000000000000..fe18f0630a98544dd30a3c9d0445283517951f5b
--- /dev/null
+++ b/MAR/code_nestor/src/NSTzz6.f
@@ -0,0 +1,159 @@
+C +------------------------------------------------------------------------+
+C | NSTzz6 NESTOR - January 02 |
+C | (created: 08/97) |
+C | Computation of geopotential at a given pressure level. |
+C | => NSTint will correct the NST field to obtain same Z as in LSC |
+C +------------------------------------------------------------------------+
+C | |
+C | METHOD: |
+C | ^^^^^^^ |
+C | Must be called for all levels (decreasing from nk) until |
+C | the requested pressure is reached for every horizontal position. |
+C | (objective of this: save mem. because T,Q,p are known only in 2D) |
+C | |
+C | Hydrostatic relation is integrated as in MAR (theta * dExner) |
+C | (small simplification: theta assumed constant between surf-lev1) |
+C | |
+C | INPUT: ni,nj,nk : Grid size |
+C | ^^^^^^ |
+C | sp (ni,nj) : surface pressure (kPa) |
+C | sh (ni,nj) : surface height (m) |
+C | on the k-th level: |
+C | pp (ni,nj) : pressure (kPa) |
+C | qv (ni,nj) : Specific Humidity (kg/kg) |
+C | pt (ni,nj) : potential temperature (K) |
+C | |
+C | INPUT / OUTPUT (temporary arrays): |
+C | ^^^^^^^^^^^^^^^ |
+C | pktv1(), pex1(), |
+C | lpres1(): retains informations for the successive calls |
+C | (values below current level) |
+C | iZp(mx,my) : .TRUE. after the completition of all iteration |
+C | necessary to find the geopotential Zpl at a given |
+C | horizontal position. |
+C | iZterm : .TRUE. idem, but for completition of all grid pts.|
+C | |
+C | OUTPUT: |
+C | ^^^^^^^ |
+C | Zpl : Computed geopotential (= at the requested |
+C | pressure level after all iterations) |
+C | |
+C | J.-F. Grailet on 29/05/2022: added the same optimization mechanism as |
+C | in LSCvgd (and associated subroutines) for consistency, hence the four |
+C | variables baseI, baseJ, maxI and maxJ (see also LSCvgd.f). |
+C +------------------------------------------------------------------------+
+ SUBROUTINE NSTzz6(pt, qv, sh, sp, pp,
+ . k, ni, nj, nk, baseI, baseJ, maxI, maxJ,
+ . pktv1, pex1, lpres1, iZp, iZterm, Zpl)
+
+ IMPLICIT NONE
+
+C +.. *Input and/or Output
+ INTEGER k, ni, nj, baseI, baseJ, maxI, maxJ, nk
+ REAL pt (ni, nj), qv (ni, nj)
+ REAL sh (ni, nj), sp (ni, nj), pp (ni, nj)
+ REAL pktv1(ni, nj), pex1(ni, nj), lpres1(ni,nj)
+ REAL Zpl (ni, nj)
+ LOGICAL iZp (ni,nj)
+ LOGICAL iZterm
+
+C +.. *Internal
+ INTEGER i,j
+ REAL pres, pex, pktv, RefPL
+ REAL lpres, lpres2, cpl1, cpl2
+
+C +...*Physical constants
+ REAL cp, cap, ra, grav, getpkt
+
+ data ra / 287. d0/
+C +... ra : Perfect Gas Law Constant (J/kg/K)
+ data cp /1004.d0/
+C +... cp : Air Specific Heat (J/kg/K)
+ data cap / 0.28586d0/
+ data grav / 9.81 d0/
+
+ getpkt= exp(-cap*log(100.))
+C +... getpkt: 1. / (100. (kPa) ** cap)
+
+
+c +..Initialisation phase : compute functions at surface
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ IF (k.EQ.nk) THEN
+C +.. *when 1st level is requested
+
+ DO i=baseI,maxI ! i=1,ni
+ DO j=baseJ,maxJ ! j=1,nj
+ lpres1(i,j)= log(sp(i,j))
+
+ pex1(i,j) = cp *exp(cap * lpres1(i,j))
+C +.. *Exner potential (Cp*p**cap)
+
+ pktv1(i,j) = pt(i,j) * getpkt * (1.d0+qv(i,j)*0.608d0)
+C +.. *Assume constant pkt and qv between surf. - nearest lev.
+C Please note that 0.608 is the correct coefficient,
+C as you may find from fundamental textbooks such as
+C "Triplet et Roche" (see def of virtual temperature)
+
+ iZp(i,j) = .FALSE.
+
+ Zpl(i,j) = sh(i,j)
+C +.. *Begin Z integration at surface.
+
+ ENDDO
+ ENDDO
+
+ iZterm = .FALSE.
+c +.. *Requested level is not yet reached (everywhere).
+
+ ENDIF
+C +
+C +..Compute geopotential increment between levels.
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ IF (.NOT.iZterm) THEN ! (work not terminated )
+ iZterm= .TRUE. ! (...but might be now )
+ DO i=baseI,maxI ! i=1, ni
+ DO j=baseJ,maxJ ! j=1, nj
+ IF (.NOT.iZp(i,j)) THEN
+
+C +..If current level (k) pressure > RefPL pressure,
+C +..compute Z of RefPL. Otherwise compute Z of level.
+
+ RefPL = 60. ! kPa
+
+ pres = pp(i,j)
+ lpres2= log(pres)
+
+ pktv= pt(i,j) * getpkt * (1.d0+qv(i,j)*0.608d0)
+
+ IF (pres.GT.RefPL) THEN
+ iZterm = .FALSE. ! (some work not terminated)
+ ELSE
+ iZp(i,j) = .TRUE. ! (work terminated at (i,j) )
+ pres = RefPL
+ lpres = log(pres)
+C +.. *Interpolate pkt to final pres:
+ cpl2 = (lpres -lpres1(i,j))/(lpres2-lpres1(i,j))
+ cpl1 = (lpres2-lpres )/(lpres2-lpres1(i,j))
+ pktv = cpl1*pktv1(i,j)+cpl2*pktv
+ ENDIF
+
+ pex = cp *exp(cap *log(pres))
+C +.. *Exner potential (Cp*p**cap)
+
+ Zpl(i,j) = Zpl(i,j) + (pex1 (i,j)-pex )
+ . *(pktv1(i,j)+pktv)*0.5d0/grav
+
+ pktv1 (i,j) = pktv
+ pex1 (i,j) = pex
+ lpres1(i,j) = lpres2
+
+
+ ENDIF
+ ENDDO
+ ENDDO
+
+ ENDIF
+
+ RETURN
+ END
diff --git a/MAR/code_nestor/src/NetCDF.inc b/MAR/code_nestor/src/NetCDF.inc
new file mode 100644
index 0000000000000000000000000000000000000000..1371bcb52d841c5e815043e2637b74296ad1c059
--- /dev/null
+++ b/MAR/code_nestor/src/NetCDF.inc
@@ -0,0 +1,1740 @@
+! NetCDF-3.
+!
+! netcdf version 3 fortran interface:
+!
+
+!
+! external netcdf data types:
+!
+ integer nf_byte
+ integer nf_int1
+ integer nf_char
+ integer nf_short
+ integer nf_int2
+ integer nf_int
+ integer nf_float
+ integer nf_real
+ integer nf_double
+
+ parameter (nf_byte = 1)
+ parameter (nf_int1 = nf_byte)
+ parameter (nf_char = 2)
+ parameter (nf_short = 3)
+ parameter (nf_int2 = nf_short)
+ parameter (nf_int = 4)
+ parameter (nf_float = 5)
+ parameter (nf_real = nf_float)
+ parameter (nf_double = 6)
+
+!
+! default fill values:
+!
+ integer nf_fill_byte
+ integer nf_fill_int1
+ integer nf_fill_char
+ integer nf_fill_short
+ integer nf_fill_int2
+ integer nf_fill_int
+ real nf_fill_float
+ real nf_fill_real
+ doubleprecision nf_fill_double
+
+ parameter (nf_fill_byte = -127)
+ parameter (nf_fill_int1 = nf_fill_byte)
+ parameter (nf_fill_char = 0)
+ parameter (nf_fill_short = -32767)
+ parameter (nf_fill_int2 = nf_fill_short)
+ parameter (nf_fill_int = -2147483647)
+ parameter (nf_fill_float = 9.9692099683868690e+36)
+ parameter (nf_fill_real = nf_fill_float)
+ parameter (nf_fill_double = 9.9692099683868690d+36)
+
+!
+! mode flags for opening and creating a netcdf dataset:
+!
+ integer nf_nowrite
+ integer nf_write
+ integer nf_clobber
+ integer nf_noclobber
+ integer nf_fill
+ integer nf_nofill
+ integer nf_lock
+ integer nf_share
+ integer nf_64bit_offset
+ integer nf_sizehint_default
+ integer nf_align_chunk
+ integer nf_format_classic
+ integer nf_format_64bit
+ integer nf_diskless
+ integer nf_mmap
+
+ parameter (nf_nowrite = 0)
+ parameter (nf_write = 1)
+ parameter (nf_clobber = 0)
+ parameter (nf_noclobber = 4)
+ parameter (nf_fill = 0)
+ parameter (nf_nofill = 256)
+ parameter (nf_lock = 1024)
+ parameter (nf_share = 2048)
+ parameter (nf_64bit_offset = 512)
+ parameter (nf_sizehint_default = 0)
+ parameter (nf_align_chunk = -1)
+ parameter (nf_format_classic = 1)
+ parameter (nf_format_64bit = 2)
+ parameter (nf_diskless = 8)
+ parameter (nf_mmap = 16)
+
+!
+! size argument for defining an unlimited dimension:
+!
+ integer nf_unlimited
+ parameter (nf_unlimited = 0)
+
+!
+! global attribute id:
+!
+ integer nf_global
+ parameter (nf_global = 0)
+
+!
+! implementation limits:
+!
+ integer nf_max_dims
+ integer nf_max_attrs
+ integer nf_max_vars
+ integer nf_max_name
+ integer nf_max_var_dims
+
+ parameter (nf_max_dims = 1024)
+ parameter (nf_max_attrs = 8192)
+ parameter (nf_max_vars = 8192)
+ parameter (nf_max_name = 256)
+ parameter (nf_max_var_dims = nf_max_dims)
+
+!
+! error codes:
+!
+ integer nf_noerr
+ integer nf_ebadid
+ integer nf_eexist
+ integer nf_einval
+ integer nf_eperm
+ integer nf_enotindefine
+ integer nf_eindefine
+ integer nf_einvalcoords
+ integer nf_emaxdims
+ integer nf_enameinuse
+ integer nf_enotatt
+ integer nf_emaxatts
+ integer nf_ebadtype
+ integer nf_ebaddim
+ integer nf_eunlimpos
+ integer nf_emaxvars
+ integer nf_enotvar
+ integer nf_eglobal
+ integer nf_enotnc
+ integer nf_ests
+ integer nf_emaxname
+ integer nf_eunlimit
+ integer nf_enorecvars
+ integer nf_echar
+ integer nf_eedge
+ integer nf_estride
+ integer nf_ebadname
+ integer nf_erange
+ integer nf_enomem
+ integer nf_evarsize
+ integer nf_edimsize
+ integer nf_etrunc
+
+ parameter (nf_noerr = 0)
+ parameter (nf_ebadid = -33)
+ parameter (nf_eexist = -35)
+ parameter (nf_einval = -36)
+ parameter (nf_eperm = -37)
+ parameter (nf_enotindefine = -38)
+ parameter (nf_eindefine = -39)
+ parameter (nf_einvalcoords = -40)
+ parameter (nf_emaxdims = -41)
+ parameter (nf_enameinuse = -42)
+ parameter (nf_enotatt = -43)
+ parameter (nf_emaxatts = -44)
+ parameter (nf_ebadtype = -45)
+ parameter (nf_ebaddim = -46)
+ parameter (nf_eunlimpos = -47)
+ parameter (nf_emaxvars = -48)
+ parameter (nf_enotvar = -49)
+ parameter (nf_eglobal = -50)
+ parameter (nf_enotnc = -51)
+ parameter (nf_ests = -52)
+ parameter (nf_emaxname = -53)
+ parameter (nf_eunlimit = -54)
+ parameter (nf_enorecvars = -55)
+ parameter (nf_echar = -56)
+ parameter (nf_eedge = -57)
+ parameter (nf_estride = -58)
+ parameter (nf_ebadname = -59)
+ parameter (nf_erange = -60)
+ parameter (nf_enomem = -61)
+ parameter (nf_evarsize = -62)
+ parameter (nf_edimsize = -63)
+ parameter (nf_etrunc = -64)
+!
+! error handling modes:
+!
+ integer nf_fatal
+ integer nf_verbose
+
+ parameter (nf_fatal = 1)
+ parameter (nf_verbose = 2)
+
+!
+! miscellaneous routines:
+!
+ character*80 nf_inq_libvers
+ external nf_inq_libvers
+
+ character*80 nf_strerror
+! (integer ncerr)
+ external nf_strerror
+
+ logical nf_issyserr
+! (integer ncerr)
+ external nf_issyserr
+
+!
+! control routines:
+!
+ integer nf_inq_base_pe
+! (integer ncid,
+! integer pe)
+ external nf_inq_base_pe
+
+ integer nf_set_base_pe
+! (integer ncid,
+! integer pe)
+ external nf_set_base_pe
+
+ integer nf_create
+! (character*(*) path,
+! integer cmode,
+! integer ncid)
+ external nf_create
+
+ integer nf__create
+! (character*(*) path,
+! integer cmode,
+! integer initialsz,
+! integer chunksizehint,
+! integer ncid)
+ external nf__create
+
+ integer nf__create_mp
+! (character*(*) path,
+! integer cmode,
+! integer initialsz,
+! integer basepe,
+! integer chunksizehint,
+! integer ncid)
+ external nf__create_mp
+
+ integer nf_open
+! (character*(*) path,
+! integer mode,
+! integer ncid)
+ external nf_open
+
+ integer nf__open
+! (character*(*) path,
+! integer mode,
+! integer chunksizehint,
+! integer ncid)
+ external nf__open
+
+ integer nf__open_mp
+! (character*(*) path,
+! integer mode,
+! integer basepe,
+! integer chunksizehint,
+! integer ncid)
+ external nf__open_mp
+
+ integer nf_set_fill
+! (integer ncid,
+! integer fillmode,
+! integer old_mode)
+ external nf_set_fill
+
+ integer nf_set_default_format
+! (integer format,
+! integer old_format)
+ external nf_set_default_format
+
+ integer nf_redef
+! (integer ncid)
+ external nf_redef
+
+ integer nf_enddef
+! (integer ncid)
+ external nf_enddef
+
+ integer nf__enddef
+! (integer ncid,
+! integer h_minfree,
+! integer v_align,
+! integer v_minfree,
+! integer r_align)
+ external nf__enddef
+
+ integer nf_sync
+! (integer ncid)
+ external nf_sync
+
+ integer nf_abort
+! (integer ncid)
+ external nf_abort
+
+ integer nf_close
+! (integer ncid)
+ external nf_close
+
+ integer nf_delete
+! (character*(*) ncid)
+ external nf_delete
+
+!
+! general inquiry routines:
+!
+
+ integer nf_inq
+! (integer ncid,
+! integer ndims,
+! integer nvars,
+! integer ngatts,
+! integer unlimdimid)
+ external nf_inq
+
+! new inquire path
+
+ integer nf_inq_path
+ external nf_inq_path
+
+ integer nf_inq_ndims
+! (integer ncid,
+! integer ndims)
+ external nf_inq_ndims
+
+ integer nf_inq_nvars
+! (integer ncid,
+! integer nvars)
+ external nf_inq_nvars
+
+ integer nf_inq_natts
+! (integer ncid,
+! integer ngatts)
+ external nf_inq_natts
+
+ integer nf_inq_unlimdim
+! (integer ncid,
+! integer unlimdimid)
+ external nf_inq_unlimdim
+
+ integer nf_inq_format
+! (integer ncid,
+! integer format)
+ external nf_inq_format
+
+!
+! dimension routines:
+!
+
+ integer nf_def_dim
+! (integer ncid,
+! character(*) name,
+! integer len,
+! integer dimid)
+ external nf_def_dim
+
+ integer nf_inq_dimid
+! (integer ncid,
+! character(*) name,
+! integer dimid)
+ external nf_inq_dimid
+
+ integer nf_inq_dim
+! (integer ncid,
+! integer dimid,
+! character(*) name,
+! integer len)
+ external nf_inq_dim
+
+ integer nf_inq_dimname
+! (integer ncid,
+! integer dimid,
+! character(*) name)
+ external nf_inq_dimname
+
+ integer nf_inq_dimlen
+! (integer ncid,
+! integer dimid,
+! integer len)
+ external nf_inq_dimlen
+
+ integer nf_rename_dim
+! (integer ncid,
+! integer dimid,
+! character(*) name)
+ external nf_rename_dim
+
+!
+! general attribute routines:
+!
+
+ integer nf_inq_att
+! (integer ncid,
+! integer varid,
+! character(*) name,
+! integer xtype,
+! integer len)
+ external nf_inq_att
+
+ integer nf_inq_attid
+! (integer ncid,
+! integer varid,
+! character(*) name,
+! integer attnum)
+ external nf_inq_attid
+
+ integer nf_inq_atttype
+! (integer ncid,
+! integer varid,
+! character(*) name,
+! integer xtype)
+ external nf_inq_atttype
+
+ integer nf_inq_attlen
+! (integer ncid,
+! integer varid,
+! character(*) name,
+! integer len)
+ external nf_inq_attlen
+
+ integer nf_inq_attname
+! (integer ncid,
+! integer varid,
+! integer attnum,
+! character(*) name)
+ external nf_inq_attname
+
+ integer nf_copy_att
+! (integer ncid_in,
+! integer varid_in,
+! character(*) name,
+! integer ncid_out,
+! integer varid_out)
+ external nf_copy_att
+
+ integer nf_rename_att
+! (integer ncid,
+! integer varid,
+! character(*) curname,
+! character(*) newname)
+ external nf_rename_att
+
+ integer nf_del_att
+! (integer ncid,
+! integer varid,
+! character(*) name)
+ external nf_del_att
+
+!
+! attribute put/get routines:
+!
+
+ integer nf_put_att_text
+! (integer ncid,
+! integer varid,
+! character(*) name,
+! integer len,
+! character(*) text)
+ external nf_put_att_text
+
+ integer nf_get_att_text
+! (integer ncid,
+! integer varid,
+! character(*) name,
+! character(*) text)
+ external nf_get_att_text
+
+ integer nf_put_att_int1
+! (integer ncid,
+! integer varid,
+! character(*) name,
+! integer xtype,
+! integer len,
+! nf_int1_t i1vals(1))
+ external nf_put_att_int1
+
+ integer nf_get_att_int1
+! (integer ncid,
+! integer varid,
+! character(*) name,
+! nf_int1_t i1vals(1))
+ external nf_get_att_int1
+
+ integer nf_put_att_int2
+! (integer ncid,
+! integer varid,
+! character(*) name,
+! integer xtype,
+! integer len,
+! nf_int2_t i2vals(1))
+ external nf_put_att_int2
+
+ integer nf_get_att_int2
+! (integer ncid,
+! integer varid,
+! character(*) name,
+! nf_int2_t i2vals(1))
+ external nf_get_att_int2
+
+ integer nf_put_att_int
+! (integer ncid,
+! integer varid,
+! character(*) name,
+! integer xtype,
+! integer len,
+! integer ivals(1))
+ external nf_put_att_int
+
+ integer nf_get_att_int
+! (integer ncid,
+! integer varid,
+! character(*) name,
+! integer ivals(1))
+ external nf_get_att_int
+
+ integer nf_put_att_real
+! (integer ncid,
+! integer varid,
+! character(*) name,
+! integer xtype,
+! integer len,
+! real rvals(1))
+ external nf_put_att_real
+
+ integer nf_get_att_real
+! (integer ncid,
+! integer varid,
+! character(*) name,
+! real rvals(1))
+ external nf_get_att_real
+
+ integer nf_put_att_double
+! (integer ncid,
+! integer varid,
+! character(*) name,
+! integer xtype,
+! integer len,
+! double dvals(1))
+ external nf_put_att_double
+
+ integer nf_get_att_double
+! (integer ncid,
+! integer varid,
+! character(*) name,
+! double dvals(1))
+ external nf_get_att_double
+
+!
+! general variable routines:
+!
+
+ integer nf_def_var
+! (integer ncid,
+! character(*) name,
+! integer datatype,
+! integer ndims,
+! integer dimids(1),
+! integer varid)
+ external nf_def_var
+
+ integer nf_inq_var
+! (integer ncid,
+! integer varid,
+! character(*) name,
+! integer datatype,
+! integer ndims,
+! integer dimids(1),
+! integer natts)
+ external nf_inq_var
+
+ integer nf_inq_varid
+! (integer ncid,
+! character(*) name,
+! integer varid)
+ external nf_inq_varid
+
+ integer nf_inq_varname
+! (integer ncid,
+! integer varid,
+! character(*) name)
+ external nf_inq_varname
+
+ integer nf_inq_vartype
+! (integer ncid,
+! integer varid,
+! integer xtype)
+ external nf_inq_vartype
+
+ integer nf_inq_varndims
+! (integer ncid,
+! integer varid,
+! integer ndims)
+ external nf_inq_varndims
+
+ integer nf_inq_vardimid
+! (integer ncid,
+! integer varid,
+! integer dimids(1))
+ external nf_inq_vardimid
+
+ integer nf_inq_varnatts
+! (integer ncid,
+! integer varid,
+! integer natts)
+ external nf_inq_varnatts
+
+ integer nf_rename_var
+! (integer ncid,
+! integer varid,
+! character(*) name)
+ external nf_rename_var
+
+ integer nf_copy_var
+! (integer ncid_in,
+! integer varid,
+! integer ncid_out)
+ external nf_copy_var
+
+!
+! entire variable put/get routines:
+!
+
+ integer nf_put_var_text
+! (integer ncid,
+! integer varid,
+! character(*) text)
+ external nf_put_var_text
+
+ integer nf_get_var_text
+! (integer ncid,
+! integer varid,
+! character(*) text)
+ external nf_get_var_text
+
+ integer nf_put_var_int1
+! (integer ncid,
+! integer varid,
+! nf_int1_t i1vals(1))
+ external nf_put_var_int1
+
+ integer nf_get_var_int1
+! (integer ncid,
+! integer varid,
+! nf_int1_t i1vals(1))
+ external nf_get_var_int1
+
+ integer nf_put_var_int2
+! (integer ncid,
+! integer varid,
+! nf_int2_t i2vals(1))
+ external nf_put_var_int2
+
+ integer nf_get_var_int2
+! (integer ncid,
+! integer varid,
+! nf_int2_t i2vals(1))
+ external nf_get_var_int2
+
+ integer nf_put_var_int
+! (integer ncid,
+! integer varid,
+! integer ivals(1))
+ external nf_put_var_int
+
+ integer nf_get_var_int
+! (integer ncid,
+! integer varid,
+! integer ivals(1))
+ external nf_get_var_int
+
+ integer nf_put_var_real
+! (integer ncid,
+! integer varid,
+! real rvals(1))
+ external nf_put_var_real
+
+ integer nf_get_var_real
+! (integer ncid,
+! integer varid,
+! real rvals(1))
+ external nf_get_var_real
+
+ integer nf_put_var_double
+! (integer ncid,
+! integer varid,
+! doubleprecision dvals(1))
+ external nf_put_var_double
+
+ integer nf_get_var_double
+! (integer ncid,
+! integer varid,
+! doubleprecision dvals(1))
+ external nf_get_var_double
+
+!
+! single variable put/get routines:
+!
+
+ integer nf_put_var1_text
+! (integer ncid,
+! integer varid,
+! integer index(1),
+! character*1 text)
+ external nf_put_var1_text
+
+ integer nf_get_var1_text
+! (integer ncid,
+! integer varid,
+! integer index(1),
+! character*1 text)
+ external nf_get_var1_text
+
+ integer nf_put_var1_int1
+! (integer ncid,
+! integer varid,
+! integer index(1),
+! nf_int1_t i1val)
+ external nf_put_var1_int1
+
+ integer nf_get_var1_int1
+! (integer ncid,
+! integer varid,
+! integer index(1),
+! nf_int1_t i1val)
+ external nf_get_var1_int1
+
+ integer nf_put_var1_int2
+! (integer ncid,
+! integer varid,
+! integer index(1),
+! nf_int2_t i2val)
+ external nf_put_var1_int2
+
+ integer nf_get_var1_int2
+! (integer ncid,
+! integer varid,
+! integer index(1),
+! nf_int2_t i2val)
+ external nf_get_var1_int2
+
+ integer nf_put_var1_int
+! (integer ncid,
+! integer varid,
+! integer index(1),
+! integer ival)
+ external nf_put_var1_int
+
+ integer nf_get_var1_int
+! (integer ncid,
+! integer varid,
+! integer index(1),
+! integer ival)
+ external nf_get_var1_int
+
+ integer nf_put_var1_real
+! (integer ncid,
+! integer varid,
+! integer index(1),
+! real rval)
+ external nf_put_var1_real
+
+ integer nf_get_var1_real
+! (integer ncid,
+! integer varid,
+! integer index(1),
+! real rval)
+ external nf_get_var1_real
+
+ integer nf_put_var1_double
+! (integer ncid,
+! integer varid,
+! integer index(1),
+! doubleprecision dval)
+ external nf_put_var1_double
+
+ integer nf_get_var1_double
+! (integer ncid,
+! integer varid,
+! integer index(1),
+! doubleprecision dval)
+ external nf_get_var1_double
+
+!
+! variable array put/get routines:
+!
+
+ integer nf_put_vara_text
+! (integer ncid,
+! integer varid,
+! integer start(1),
+! integer count(1),
+! character(*) text)
+ external nf_put_vara_text
+
+ integer nf_get_vara_text
+! (integer ncid,
+! integer varid,
+! integer start(1),
+! integer count(1),
+! character(*) text)
+ external nf_get_vara_text
+
+ integer nf_put_vara_int1
+! (integer ncid,
+! integer varid,
+! integer start(1),
+! integer count(1),
+! nf_int1_t i1vals(1))
+ external nf_put_vara_int1
+
+ integer nf_get_vara_int1
+! (integer ncid,
+! integer varid,
+! integer start(1),
+! integer count(1),
+! nf_int1_t i1vals(1))
+ external nf_get_vara_int1
+
+ integer nf_put_vara_int2
+! (integer ncid,
+! integer varid,
+! integer start(1),
+! integer count(1),
+! nf_int2_t i2vals(1))
+ external nf_put_vara_int2
+
+ integer nf_get_vara_int2
+! (integer ncid,
+! integer varid,
+! integer start(1),
+! integer count(1),
+! nf_int2_t i2vals(1))
+ external nf_get_vara_int2
+
+ integer nf_put_vara_int
+! (integer ncid,
+! integer varid,
+! integer start(1),
+! integer count(1),
+! integer ivals(1))
+ external nf_put_vara_int
+
+ integer nf_get_vara_int
+! (integer ncid,
+! integer varid,
+! integer start(1),
+! integer count(1),
+! integer ivals(1))
+ external nf_get_vara_int
+
+ integer nf_put_vara_real
+! (integer ncid,
+! integer varid,
+! integer start(1),
+! integer count(1),
+! real rvals(1))
+ external nf_put_vara_real
+
+ integer nf_get_vara_real
+! (integer ncid,
+! integer varid,
+! integer start(1),
+! integer count(1),
+! real rvals(1))
+ external nf_get_vara_real
+
+ integer nf_put_vara_double
+! (integer ncid,
+! integer varid,
+! integer start(1),
+! integer count(1),
+! doubleprecision dvals(1))
+ external nf_put_vara_double
+
+ integer nf_get_vara_double
+! (integer ncid,
+! integer varid,
+! integer start(1),
+! integer count(1),
+! doubleprecision dvals(1))
+ external nf_get_vara_double
+
+!
+! strided variable put/get routines:
+!
+
+ integer nf_put_vars_text
+! (integer ncid,
+! integer varid,
+! integer start(1),
+! integer count(1),
+! integer stride(1),
+! character(*) text)
+ external nf_put_vars_text
+
+ integer nf_get_vars_text
+! (integer ncid,
+! integer varid,
+! integer start(1),
+! integer count(1),
+! integer stride(1),
+! character(*) text)
+ external nf_get_vars_text
+
+ integer nf_put_vars_int1
+! (integer ncid,
+! integer varid,
+! integer start(1),
+! integer count(1),
+! integer stride(1),
+! nf_int1_t i1vals(1))
+ external nf_put_vars_int1
+
+ integer nf_get_vars_int1
+! (integer ncid,
+! integer varid,
+! integer start(1),
+! integer count(1),
+! integer stride(1),
+! nf_int1_t i1vals(1))
+ external nf_get_vars_int1
+
+ integer nf_put_vars_int2
+! (integer ncid,
+! integer varid,
+! integer start(1),
+! integer count(1),
+! integer stride(1),
+! nf_int2_t i2vals(1))
+ external nf_put_vars_int2
+
+ integer nf_get_vars_int2
+! (integer ncid,
+! integer varid,
+! integer start(1),
+! integer count(1),
+! integer stride(1),
+! nf_int2_t i2vals(1))
+ external nf_get_vars_int2
+
+ integer nf_put_vars_int
+! (integer ncid,
+! integer varid,
+! integer start(1),
+! integer count(1),
+! integer stride(1),
+! integer ivals(1))
+ external nf_put_vars_int
+
+ integer nf_get_vars_int
+! (integer ncid,
+! integer varid,
+! integer start(1),
+! integer count(1),
+! integer stride(1),
+! integer ivals(1))
+ external nf_get_vars_int
+
+ integer nf_put_vars_real
+! (integer ncid,
+! integer varid,
+! integer start(1),
+! integer count(1),
+! integer stride(1),
+! real rvals(1))
+ external nf_put_vars_real
+
+ integer nf_get_vars_real
+! (integer ncid,
+! integer varid,
+! integer start(1),
+! integer count(1),
+! integer stride(1),
+! real rvals(1))
+ external nf_get_vars_real
+
+ integer nf_put_vars_double
+! (integer ncid,
+! integer varid,
+! integer start(1),
+! integer count(1),
+! integer stride(1),
+! doubleprecision dvals(1))
+ external nf_put_vars_double
+
+ integer nf_get_vars_double
+! (integer ncid,
+! integer varid,
+! integer start(1),
+! integer count(1),
+! integer stride(1),
+! doubleprecision dvals(1))
+ external nf_get_vars_double
+
+!
+! mapped variable put/get routines:
+!
+
+ integer nf_put_varm_text
+! (integer ncid,
+! integer varid,
+! integer start(1),
+! integer count(1),
+! integer stride(1),
+! integer imap(1),
+! character(*) text)
+ external nf_put_varm_text
+
+ integer nf_get_varm_text
+! (integer ncid,
+! integer varid,
+! integer start(1),
+! integer count(1),
+! integer stride(1),
+! integer imap(1),
+! character(*) text)
+ external nf_get_varm_text
+
+ integer nf_put_varm_int1
+! (integer ncid,
+! integer varid,
+! integer start(1),
+! integer count(1),
+! integer stride(1),
+! integer imap(1),
+! nf_int1_t i1vals(1))
+ external nf_put_varm_int1
+
+ integer nf_get_varm_int1
+! (integer ncid,
+! integer varid,
+! integer start(1),
+! integer count(1),
+! integer stride(1),
+! integer imap(1),
+! nf_int1_t i1vals(1))
+ external nf_get_varm_int1
+
+ integer nf_put_varm_int2
+! (integer ncid,
+! integer varid,
+! integer start(1),
+! integer count(1),
+! integer stride(1),
+! integer imap(1),
+! nf_int2_t i2vals(1))
+ external nf_put_varm_int2
+
+ integer nf_get_varm_int2
+! (integer ncid,
+! integer varid,
+! integer start(1),
+! integer count(1),
+! integer stride(1),
+! integer imap(1),
+! nf_int2_t i2vals(1))
+ external nf_get_varm_int2
+
+ integer nf_put_varm_int
+! (integer ncid,
+! integer varid,
+! integer start(1),
+! integer count(1),
+! integer stride(1),
+! integer imap(1),
+! integer ivals(1))
+ external nf_put_varm_int
+
+ integer nf_get_varm_int
+! (integer ncid,
+! integer varid,
+! integer start(1),
+! integer count(1),
+! integer stride(1),
+! integer imap(1),
+! integer ivals(1))
+ external nf_get_varm_int
+
+ integer nf_put_varm_real
+! (integer ncid,
+! integer varid,
+! integer start(1),
+! integer count(1),
+! integer stride(1),
+! integer imap(1),
+! real rvals(1))
+ external nf_put_varm_real
+
+ integer nf_get_varm_real
+! (integer ncid,
+! integer varid,
+! integer start(1),
+! integer count(1),
+! integer stride(1),
+! integer imap(1),
+! real rvals(1))
+ external nf_get_varm_real
+
+ integer nf_put_varm_double
+! (integer ncid,
+! integer varid,
+! integer start(1),
+! integer count(1),
+! integer stride(1),
+! integer imap(1),
+! doubleprecision dvals(1))
+ external nf_put_varm_double
+
+ integer nf_get_varm_double
+! (integer ncid,
+! integer varid,
+! integer start(1),
+! integer count(1),
+! integer stride(1),
+! integer imap(1),
+! doubleprecision dvals(1))
+ external nf_get_varm_double
+
+
+! NetCDF-4.
+! This is part of netCDF-4. Copyright 2006, UCAR, See COPYRIGHT
+! file for distribution information.
+
+! Netcdf version 4 fortran interface.
+
+! $Id: netcdf4.inc,v 1.28 2010/05/25 13:53:02 ed Exp $
+
+! New netCDF-4 types.
+ integer nf_ubyte
+ integer nf_ushort
+ integer nf_uint
+ integer nf_int64
+ integer nf_uint64
+ integer nf_string
+ integer nf_vlen
+ integer nf_opaque
+ integer nf_enum
+ integer nf_compound
+
+ parameter (nf_ubyte = 7)
+ parameter (nf_ushort = 8)
+ parameter (nf_uint = 9)
+ parameter (nf_int64 = 10)
+ parameter (nf_uint64 = 11)
+ parameter (nf_string = 12)
+ parameter (nf_vlen = 13)
+ parameter (nf_opaque = 14)
+ parameter (nf_enum = 15)
+ parameter (nf_compound = 16)
+
+! New netCDF-4 fill values.
+ integer nf_fill_ubyte
+ integer nf_fill_ushort
+! real nf_fill_uint
+! real nf_fill_int64
+! real nf_fill_uint64
+ parameter (nf_fill_ubyte = 255)
+ parameter (nf_fill_ushort = 65535)
+
+! New constants.
+ integer nf_format_netcdf4
+ parameter (nf_format_netcdf4 = 3)
+
+ integer nf_format_netcdf4_classic
+ parameter (nf_format_netcdf4_classic = 4)
+
+ integer nf_netcdf4
+ parameter (nf_netcdf4 = 4096)
+
+ integer nf_classic_model
+ parameter (nf_classic_model = 256)
+
+ integer nf_chunk_seq
+ parameter (nf_chunk_seq = 0)
+ integer nf_chunk_sub
+ parameter (nf_chunk_sub = 1)
+ integer nf_chunk_sizes
+ parameter (nf_chunk_sizes = 2)
+
+ integer nf_endian_native
+ parameter (nf_endian_native = 0)
+ integer nf_endian_little
+ parameter (nf_endian_little = 1)
+ integer nf_endian_big
+ parameter (nf_endian_big = 2)
+
+! For NF_DEF_VAR_CHUNKING
+ integer nf_chunked
+ parameter (nf_chunked = 0)
+ integer nf_contiguous
+ parameter (nf_contiguous = 1)
+
+! For NF_DEF_VAR_FLETCHER32
+ integer nf_nochecksum
+ parameter (nf_nochecksum = 0)
+ integer nf_fletcher32
+ parameter (nf_fletcher32 = 1)
+
+! For NF_DEF_VAR_DEFLATE
+ integer nf_noshuffle
+ parameter (nf_noshuffle = 0)
+ integer nf_shuffle
+ parameter (nf_shuffle = 1)
+
+! For NF_DEF_VAR_SZIP
+ integer nf_szip_ec_option_mask
+ parameter (nf_szip_ec_option_mask = 4)
+ integer nf_szip_nn_option_mask
+ parameter (nf_szip_nn_option_mask = 32)
+
+! For parallel I/O.
+ integer nf_mpiio
+ parameter (nf_mpiio = 8192)
+ integer nf_mpiposix
+ parameter (nf_mpiposix = 16384)
+ integer nf_pnetcdf
+ parameter (nf_pnetcdf = 32768)
+
+! For NF_VAR_PAR_ACCESS.
+ integer nf_independent
+ parameter (nf_independent = 0)
+ integer nf_collective
+ parameter (nf_collective = 1)
+
+! New error codes.
+ integer nf_ehdferr ! Error at HDF5 layer.
+ parameter (nf_ehdferr = -101)
+ integer nf_ecantread ! Can't read.
+ parameter (nf_ecantread = -102)
+ integer nf_ecantwrite ! Can't write.
+ parameter (nf_ecantwrite = -103)
+ integer nf_ecantcreate ! Can't create.
+ parameter (nf_ecantcreate = -104)
+ integer nf_efilemeta ! Problem with file metadata.
+ parameter (nf_efilemeta = -105)
+ integer nf_edimmeta ! Problem with dimension metadata.
+ parameter (nf_edimmeta = -106)
+ integer nf_eattmeta ! Problem with attribute metadata.
+ parameter (nf_eattmeta = -107)
+ integer nf_evarmeta ! Problem with variable metadata.
+ parameter (nf_evarmeta = -108)
+ integer nf_enocompound ! Not a compound type.
+ parameter (nf_enocompound = -109)
+ integer nf_eattexists ! Attribute already exists.
+ parameter (nf_eattexists = -110)
+ integer nf_enotnc4 ! Attempting netcdf-4 operation on netcdf-3 file.
+ parameter (nf_enotnc4 = -111)
+ integer nf_estrictnc3 ! Attempting netcdf-4 operation on strict nc3 netcdf-4 file.
+ parameter (nf_estrictnc3 = -112)
+ integer nf_enotnc3 ! Attempting netcdf-3 operation on netcdf-4 file.
+ parameter (nf_enotnc3 = -113)
+ integer nf_enopar ! Parallel operation on file opened for non-parallel access.
+ parameter (nf_enopar = -114)
+ integer nf_eparinit ! Error initializing for parallel access.
+ parameter (nf_eparinit = -115)
+ integer nf_ebadgrpid ! Bad group ID.
+ parameter (nf_ebadgrpid = -116)
+ integer nf_ebadtypid ! Bad type ID.
+ parameter (nf_ebadtypid = -117)
+ integer nf_etypdefined ! Type has already been defined and may not be edited.
+ parameter (nf_etypdefined = -118)
+ integer nf_ebadfield ! Bad field ID.
+ parameter (nf_ebadfield = -119)
+ integer nf_ebadclass ! Bad class.
+ parameter (nf_ebadclass = -120)
+ integer nf_emaptype ! Mapped access for atomic types only.
+ parameter (nf_emaptype = -121)
+ integer nf_elatefill ! Attempt to define fill value when data already exists.
+ parameter (nf_elatefill = -122)
+ integer nf_elatedef ! Attempt to define var properties, like deflate, after enddef.
+ parameter (nf_elatedef = -123)
+ integer nf_edimscale ! Probem with HDF5 dimscales.
+ parameter (nf_edimscale = -124)
+ integer nf_enogrp ! No group found.
+ parameter (nf_enogrp = -125)
+
+
+! New functions.
+
+! Parallel I/O.
+ integer nf_create_par
+ external nf_create_par
+
+ integer nf_open_par
+ external nf_open_par
+
+ integer nf_var_par_access
+ external nf_var_par_access
+
+! Functions to handle groups.
+ integer nf_inq_ncid
+ external nf_inq_ncid
+
+ integer nf_inq_grps
+ external nf_inq_grps
+
+ integer nf_inq_grpname
+ external nf_inq_grpname
+
+ integer nf_inq_grpname_full
+ external nf_inq_grpname_full
+
+ integer nf_inq_grpname_len
+ external nf_inq_grpname_len
+
+ integer nf_inq_grp_parent
+ external nf_inq_grp_parent
+
+ integer nf_inq_grp_ncid
+ external nf_inq_grp_ncid
+
+ integer nf_inq_grp_full_ncid
+ external nf_inq_grp_full_ncid
+
+ integer nf_inq_varids
+ external nf_inq_varids
+
+ integer nf_inq_dimids
+ external nf_inq_dimids
+
+ integer nf_def_grp
+ external nf_def_grp
+
+! New rename grp function
+
+ integer nf_rename_grp
+ external nf_rename_grp
+
+! New options for netCDF variables.
+ integer nf_def_var_deflate
+ external nf_def_var_deflate
+
+ integer nf_inq_var_deflate
+ external nf_inq_var_deflate
+
+ integer nf_def_var_fletcher32
+ external nf_def_var_fletcher32
+
+ integer nf_inq_var_fletcher32
+ external nf_inq_var_fletcher32
+
+ integer nf_def_var_chunking
+ external nf_def_var_chunking
+
+ integer nf_inq_var_chunking
+ external nf_inq_var_chunking
+
+ integer nf_def_var_fill
+ external nf_def_var_fill
+
+ integer nf_inq_var_fill
+ external nf_inq_var_fill
+
+ integer nf_def_var_endian
+ external nf_def_var_endian
+
+ integer nf_inq_var_endian
+ external nf_inq_var_endian
+
+! User defined types.
+ integer nf_inq_typeids
+ external nf_inq_typeids
+
+ integer nf_inq_typeid
+ external nf_inq_typeid
+
+ integer nf_inq_type
+ external nf_inq_type
+
+ integer nf_inq_user_type
+ external nf_inq_user_type
+
+! User defined types - compound types.
+ integer nf_def_compound
+ external nf_def_compound
+
+ integer nf_insert_compound
+ external nf_insert_compound
+
+ integer nf_insert_array_compound
+ external nf_insert_array_compound
+
+ integer nf_inq_compound
+ external nf_inq_compound
+
+ integer nf_inq_compound_name
+ external nf_inq_compound_name
+
+ integer nf_inq_compound_size
+ external nf_inq_compound_size
+
+ integer nf_inq_compound_nfields
+ external nf_inq_compound_nfields
+
+ integer nf_inq_compound_field
+ external nf_inq_compound_field
+
+ integer nf_inq_compound_fieldname
+ external nf_inq_compound_fieldname
+
+ integer nf_inq_compound_fieldindex
+ external nf_inq_compound_fieldindex
+
+ integer nf_inq_compound_fieldoffset
+ external nf_inq_compound_fieldoffset
+
+ integer nf_inq_compound_fieldtype
+ external nf_inq_compound_fieldtype
+
+ integer nf_inq_compound_fieldndims
+ external nf_inq_compound_fieldndims
+
+ integer nf_inq_compound_fielddim_sizes
+ external nf_inq_compound_fielddim_sizes
+
+! User defined types - variable length arrays.
+ integer nf_def_vlen
+ external nf_def_vlen
+
+ integer nf_inq_vlen
+ external nf_inq_vlen
+
+ integer nf_free_vlen
+ external nf_free_vlen
+
+! User defined types - enums.
+ integer nf_def_enum
+ external nf_def_enum
+
+ integer nf_insert_enum
+ external nf_insert_enum
+
+ integer nf_inq_enum
+ external nf_inq_enum
+
+ integer nf_inq_enum_member
+ external nf_inq_enum_member
+
+ integer nf_inq_enum_ident
+ external nf_inq_enum_ident
+
+! User defined types - opaque.
+ integer nf_def_opaque
+ external nf_def_opaque
+
+ integer nf_inq_opaque
+ external nf_inq_opaque
+
+! Write and read attributes of any type, including user defined
+! types.
+ integer nf_put_att
+ external nf_put_att
+ integer nf_get_att
+ external nf_get_att
+
+! Write and read variables of any type, including user defined
+! types.
+ integer nf_put_var
+ external nf_put_var
+ integer nf_put_var1
+ external nf_put_var1
+ integer nf_put_vara
+ external nf_put_vara
+ integer nf_put_vars
+ external nf_put_vars
+ integer nf_get_var
+ external nf_get_var
+ integer nf_get_var1
+ external nf_get_var1
+ integer nf_get_vara
+ external nf_get_vara
+ integer nf_get_vars
+ external nf_get_vars
+
+! 64-bit int functions.
+ integer nf_put_var1_int64
+ external nf_put_var1_int64
+ integer nf_put_vara_int64
+ external nf_put_vara_int64
+ integer nf_put_vars_int64
+ external nf_put_vars_int64
+ integer nf_put_varm_int64
+ external nf_put_varm_int64
+ integer nf_put_var_int64
+ external nf_put_var_int64
+ integer nf_get_var1_int64
+ external nf_get_var1_int64
+ integer nf_get_vara_int64
+ external nf_get_vara_int64
+ integer nf_get_vars_int64
+ external nf_get_vars_int64
+ integer nf_get_varm_int64
+ external nf_get_varm_int64
+ integer nf_get_var_int64
+ external nf_get_var_int64
+
+! For helping F77 users with VLENs.
+ integer nf_get_vlen_element
+ external nf_get_vlen_element
+ integer nf_put_vlen_element
+ external nf_put_vlen_element
+
+! For dealing with file level chunk cache.
+ integer nf_set_chunk_cache
+ external nf_set_chunk_cache
+ integer nf_get_chunk_cache
+ external nf_get_chunk_cache
+
+! For dealing with per variable chunk cache.
+ integer nf_set_var_chunk_cache
+ external nf_set_var_chunk_cache
+ integer nf_get_var_chunk_cache
+ external nf_get_var_chunk_cache
+
+! NetCDF-2.
+!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+! begin netcdf 2.4 backward compatibility:
+!
+
+!
+! functions in the fortran interface
+!
+ integer nccre
+ integer ncopn
+ integer ncddef
+ integer ncdid
+ integer ncvdef
+ integer ncvid
+ integer nctlen
+ integer ncsfil
+
+ external nccre
+ external ncopn
+ external ncddef
+ external ncdid
+ external ncvdef
+ external ncvid
+ external nctlen
+ external ncsfil
+
+
+ integer ncrdwr
+ integer nccreat
+ integer ncexcl
+ integer ncindef
+ integer ncnsync
+ integer nchsync
+ integer ncndirty
+ integer nchdirty
+ integer nclink
+ integer ncnowrit
+ integer ncwrite
+ integer ncclob
+ integer ncnoclob
+ integer ncglobal
+ integer ncfill
+ integer ncnofill
+ integer maxncop
+ integer maxncdim
+ integer maxncatt
+ integer maxncvar
+ integer maxncnam
+ integer maxvdims
+ integer ncnoerr
+ integer ncebadid
+ integer ncenfile
+ integer nceexist
+ integer nceinval
+ integer nceperm
+ integer ncenotin
+ integer nceindef
+ integer ncecoord
+ integer ncemaxds
+ integer ncename
+ integer ncenoatt
+ integer ncemaxat
+ integer ncebadty
+ integer ncebadd
+ integer ncests
+ integer nceunlim
+ integer ncemaxvs
+ integer ncenotvr
+ integer nceglob
+ integer ncenotnc
+ integer ncfoobar
+ integer ncsyserr
+ integer ncfatal
+ integer ncverbos
+ integer ncentool
+
+
+!
+! netcdf data types:
+!
+ integer ncbyte
+ integer ncchar
+ integer ncshort
+ integer nclong
+ integer ncfloat
+ integer ncdouble
+
+ parameter(ncbyte = 1)
+ parameter(ncchar = 2)
+ parameter(ncshort = 3)
+ parameter(nclong = 4)
+ parameter(ncfloat = 5)
+ parameter(ncdouble = 6)
+
+!
+! masks for the struct nc flag field; passed in as 'mode' arg to
+! nccreate and ncopen.
+!
+
+! read/write, 0 => readonly
+ parameter(ncrdwr = 1)
+! in create phase, cleared by ncendef
+ parameter(nccreat = 2)
+! on create destroy existing file
+ parameter(ncexcl = 4)
+! in define mode, cleared by ncendef
+ parameter(ncindef = 8)
+! synchronise numrecs on change (x'10')
+ parameter(ncnsync = 16)
+! synchronise whole header on change (x'20')
+ parameter(nchsync = 32)
+! numrecs has changed (x'40')
+ parameter(ncndirty = 64)
+! header info has changed (x'80')
+ parameter(nchdirty = 128)
+! prefill vars on endef and increase of record, the default behavior
+ parameter(ncfill = 0)
+! do not fill vars on endef and increase of record (x'100')
+ parameter(ncnofill = 256)
+! isa link (x'8000')
+ parameter(nclink = 32768)
+
+!
+! 'mode' arguments for nccreate and ncopen
+!
+ parameter(ncnowrit = 0)
+ parameter(ncwrite = ncrdwr)
+ parameter(ncclob = nf_clobber)
+ parameter(ncnoclob = nf_noclobber)
+
+!
+! 'size' argument to ncdimdef for an unlimited dimension
+!
+ integer ncunlim
+ parameter(ncunlim = 0)
+
+!
+! attribute id to put/get a global attribute
+!
+ parameter(ncglobal = 0)
+
+!
+! advisory maximums:
+!
+ parameter(maxncop = 64)
+ parameter(maxncdim = 1024)
+ parameter(maxncatt = 8192)
+ parameter(maxncvar = 8192)
+! not enforced
+ parameter(maxncnam = 256)
+ parameter(maxvdims = maxncdim)
+
+!
+! global netcdf error status variable
+! initialized in error.c
+!
+
+! no error
+ parameter(ncnoerr = nf_noerr)
+! not a netcdf id
+ parameter(ncebadid = nf_ebadid)
+! too many netcdfs open
+ parameter(ncenfile = -31) ! nc_syserr
+! netcdf file exists && ncnoclob
+ parameter(nceexist = nf_eexist)
+! invalid argument
+ parameter(nceinval = nf_einval)
+! write to read only
+ parameter(nceperm = nf_eperm)
+! operation not allowed in data mode
+ parameter(ncenotin = nf_enotindefine )
+! operation not allowed in define mode
+ parameter(nceindef = nf_eindefine)
+! coordinates out of domain
+ parameter(ncecoord = nf_einvalcoords)
+! maxncdims exceeded
+ parameter(ncemaxds = nf_emaxdims)
+! string match to name in use
+ parameter(ncename = nf_enameinuse)
+! attribute not found
+ parameter(ncenoatt = nf_enotatt)
+! maxncattrs exceeded
+ parameter(ncemaxat = nf_emaxatts)
+! not a netcdf data type
+ parameter(ncebadty = nf_ebadtype)
+! invalid dimension id
+ parameter(ncebadd = nf_ebaddim)
+! ncunlimited in the wrong index
+ parameter(nceunlim = nf_eunlimpos)
+! maxncvars exceeded
+ parameter(ncemaxvs = nf_emaxvars)
+! variable not found
+ parameter(ncenotvr = nf_enotvar)
+! action prohibited on ncglobal varid
+ parameter(nceglob = nf_eglobal)
+! not a netcdf file
+ parameter(ncenotnc = nf_enotnc)
+ parameter(ncests = nf_ests)
+ parameter (ncentool = nf_emaxname)
+ parameter(ncfoobar = 32)
+ parameter(ncsyserr = -31)
+
+!
+! global options variable. used to determine behavior of error handler.
+! initialized in lerror.c
+!
+ parameter(ncfatal = 1)
+ parameter(ncverbos = 2)
+
+!
+! default fill values. these must be the same as in the c interface.
+!
+ integer filbyte
+ integer filchar
+ integer filshort
+ integer fillong
+ real filfloat
+ doubleprecision fildoub
+
+ parameter (filbyte = -127)
+ parameter (filchar = 0)
+ parameter (filshort = -32767)
+ parameter (fillong = -2147483647)
+ parameter (filfloat = 9.9692099683868690e+36)
+ parameter (fildoub = 9.9692099683868690e+36)
diff --git a/MAR/code_nestor/src/PRJctr.f b/MAR/code_nestor/src/PRJctr.f
new file mode 100644
index 0000000000000000000000000000000000000000..075ff70eb4d5e41dc210e49bc76d3f83b069c303
--- /dev/null
+++ b/MAR/code_nestor/src/PRJctr.f
@@ -0,0 +1,249 @@
+C +-------------------------------------------------------------------+
+C | Subroutine lamphi2laea April 2001 NESTING |
+C +-------------------------------------------------------------------+
+C | |
+C | Convertion of lat./long. coordinates into Lambert coordinates |
+C | => Lambert-Azimuthal Equal-Area Projection on Spheroid |
+C | |
+C | Input : - lam, phi : coordinates in latitude and longitude |
+C | ^^^^^^^ |
+C | |
+C | Output: - xl, yl : Lambert coordinates |
+C | ^^^^^^^ |
+C | |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE lamphi2laea (xl,yl,lam,phi,lam0,phi0,r)
+
+
+ IMPLICIT NONE
+
+
+C +---General and local variables
+C + ---------------------------
+
+ REAL xl,yl,lam,phi,lam0,phi0,r,kprim
+
+
+C +---Convert to Lambert coordinates
+C + ------------------------------
+
+ kprim = SQRT(2./(1+SIN(phi0)*SIN(phi)
+ . +COS(phi0)*COS(phi)*COS(lam-lam0)))
+
+ xl = r * kprim * COS(phi )*SIN(lam-lam0)
+ yl = r * kprim * (COS(phi0)*SIN(phi)
+ . -SIN(phi0)*COS(phi)*COS(lam-lam0))
+
+
+ RETURN
+ END
+
+
+C +-------------------------------------------------------------------+
+C | Subroutine laea2lamphi April 2001 NESTING |
+C +-------------------------------------------------------------------+
+C | |
+C | Convertion of Lambert coordinates into lat./long. coordinates |
+C | => Lambert-Azimuthal Equal-Area Projection on Spheroid |
+C | |
+C | Input : - xl, yl : Lambert coordinates |
+C | ^^^^^^^ |
+C | |
+C | Output: - lam, phi : coordinates in latitude and longitude |
+C | ^^^^^^^ |
+C | |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE laea2lamphi (xl,yl,lam,phi,lam0,phi0,r)
+
+
+ IMPLICIT NONE
+
+
+C +---General and local variables
+C + ---------------------------
+
+ REAL xl,yl,lam,phi,lam0,phi0,r,EPS10,rho,c
+
+ DATA EPS10 / 1.E-10 /
+
+
+C +---Convert Lambert coordinates
+C + ---------------------------
+
+ rho = SQRT(xl*xl+yl*yl)
+ c = 2. * ASIN(rho/(2.*r))
+
+ IF (rho.lt.EPS10) THEN
+ phi = 0.
+ lam = 0.
+ ELSE
+ phi = ASIN(COS(c)*SIN(phi0)+(yl*SIN(c)*COS(phi0)/rho))
+ lam = lam0
+ . + ATAN(xl*SIN(c)/(rho*COS(phi0)*COS(c)-yl*SIN(phi0)*SIN(c)))
+ ENDIF
+
+
+ RETURN
+ END
+
+
+C +-------------------------------------------------------------------+
+C | Subroutine lambel2geo April 2001 NESTING |
+C +-------------------------------------------------------------------+
+C | |
+C | Convertion of Lambert coordinates into lat./long. coordinates |
+C | => Lambert-Azimuthal Equal-Area Projection on Spheroid |
+C | |
+C | Input : - lam, phi : coordinates in latitude and longitude |
+C | ^^^^^^^ |
+C | |
+C | Output: - xl, yl : Lambert coordinates |
+C | ^^^^^^^ |
+C | |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE lambel2geo (xl,yl,lam,phi)
+
+
+ IMPLICIT NONE
+
+
+C +---General and local variables
+C + ---------------------------
+
+ INTEGER i
+
+ REAL xl,yl,lam,phi,a,p,phi1,phi2,pi,lambbr,rad,e,gam1,gam2,
+ . e2,w1,w2,z1,z2,n,n1,k,lamdif,gam,teta,rho,dx,dy,dz,
+ . fact
+
+
+C +---Initialization
+C + --------------
+
+ a = 6378388.
+ p = 297.
+ phi1 = 2990.
+ phi2 = 3070.
+ pi = 3.14159265358979
+ lambbr = 4.3680
+ rad = pi / 180.
+
+ p = 1. / p
+ e = SQRT(2. * p - p * p)
+ phi1 = phi1 * rad/60.
+ phi2 = phi2 * rad/60.
+ gam1 = pi/2. - phi1
+ gam2 = pi/2. - phi2
+ e2 = e/2.
+ w1 = SQRT(1.-(e * COS(gam1))**2.)
+ w2 = SQRT(1.-(e * COS(gam2))**2.)
+ z1 = TAN(gam1/2.) * (((1.+e*COS(gam1))
+ . /(1.-e*COS(gam1)))**e2)
+ z2 = TAN(gam2/2.) * (((1.+e*COS(gam2))
+ . /(1.-e*COS(gam2)))**e2)
+ n = (ALOG10(w2)-ALOG10(w1)+ALOG10(SIN(gam1))
+ . - ALOG10(SIN(gam2))) / (ALOG10(z1)-ALOG10(z2))
+ n1 = 1./n
+
+ k = a*SIN(gam1)/(n*w1*(z1**n))
+
+ dx = xl - 150000.
+ dy = 5400000. - yl
+ rho = SQRT(dx*dx+dy*dy)
+ teta = ATAN(dx/dy)
+ lamdif = teta/(n*rad)
+ dz = (rho/k)**n1
+
+ gam = dz
+ DO i=1,3
+ fact = ((1.+e+(1.-e)*gam*gam) / (1.-e+(1.+e)*gam*gam))**e2
+ gam = dz/fact
+ ENDDO
+ gam = 2.*ATAN(gam)
+
+ phi = (pi/2.-gam) / rad
+ lam = lambbr + lamdif
+
+
+ RETURN
+ END
+
+
+C +-------------------------------------------------------------------+
+C | Subroutine geo2lambel April 2001 NESTING |
+C +-------------------------------------------------------------------+
+C | |
+C | Convertion of Lambert coordinates into lat./long. coordinates |
+C | => Lambert-Azimuthal Equal-Area Projection on Spheroid |
+C | |
+C | Input : - xl, yl : Lambert coordinates |
+C | ^^^^^^^ |
+C | |
+C | Output: - lam, phi : coordinates in latitude and longitude |
+C | ^^^^^^^ |
+C | |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE geo2lambel (xl,yl,lam,phi)
+
+
+ IMPLICIT NONE
+
+
+C +---General and local variables
+C + ---------------------------
+
+ REAL xl,yl,lam,phi,a,p,phi1,phi2,pi,lambbr,rad,e,gam1,gam2,
+ . e2,w1,w2,z1,z2,n,k,expn,lamdif,gam,teta,rho
+
+
+C +---Initialization
+C + --------------
+
+ a = 6378388.
+ p = 297.
+ phi1 = 2990.
+ phi2 = 3070.
+ pi = 3.14159265358979
+ lambbr = 4.3680
+ rad = pi / 180.
+
+
+C +---Convert Lambert coordinates
+C + ---------------------------
+
+ p = 1./p
+ e = SQRT(2.*p-p*p)
+ phi1 = phi1 * rad / 60.
+ phi2 = phi2 * rad / 60.
+ gam1 = pi/2. - phi1
+ gam2 = pi/2. - phi2
+ e2 = e/2.
+ w1 = SQRT(1.-(e*COS(gam1))**2.)
+ w2 = SQRT(1.-(e*COS(gam2))**2.)
+ z1 = TAN(gam1 / 2.)
+ . * (((1.+e*COS(gam1)) / (1.-e*COS(gam1)))**e2)
+ z2 = TAN(gam2 / 2.)
+ . * (((1.+e*COS(gam2)) / (1.-e*COS(gam2)))**e2)
+ n = (ALOG10(w2) - ALOG10(w1) + ALOG10(SIN(gam1))
+ . - ALOG10(SIN(gam2))) / (ALOG10(z1) - ALOG10(z2))
+
+ k = a * SIN(gam1) / (n * w1 * (z1**n))
+ expn = e2*n
+
+ lamdif = lam - lambbr
+ gam = pi / 2. - phi * rad
+ teta = n * lamdif * rad
+ rho = k * (TAN(gam/2.)**n)
+ . * (((1.+e*COS(gam)) / (1.-e*COS(gam)))**expn)
+
+ xl = 150000. + rho * SIN(teta)
+ yl = 5400000. - rho * COS(teta)
+
+
+ RETURN
+ END
+
diff --git a/MAR/code_nestor/src/SL_cor.f b/MAR/code_nestor/src/SL_cor.f
new file mode 100644
index 0000000000000000000000000000000000000000..81034728344c2052d820b292566e6c79ad7a826a
--- /dev/null
+++ b/MAR/code_nestor/src/SL_cor.f
@@ -0,0 +1,151 @@
+C +-------------------------------------------------------------------+
+C | Subroutine SL_cor Sept 99 NESTING |
+C +-------------------------------------------------------------------+
+C | |
+C | This routine is designed to correct the vertical profile of wind, |
+C | temperature and moisture in the surface layer. |
+C | |
+C | Input : NST_pt : potential temperature (K) |
+C | ^^^^^^^ NST_st : surface temperature (K) |
+C | NST_qv : specific humidity (kg/kg) |
+C | NST_z0 : roughness length (m) |
+C | NST__u : U-wind (m/s) |
+C | NST__v : V-wind (m/s) |
+C | NST_sp : surface pressure (kPa) |
+C | NST__p : pressure at each level (kPa) |
+C | |
+C | Output: Corrected NST__u, NST__v, and NST_pt in the surface layer.|
+C | ^^^^^^^ Optional (#QV) for NST_qv. |
+C | |
+C +-------------------------------------------------------------------+
+
+
+ SUBROUTINE SL_cor
+
+
+ IMPLICIT NONE
+
+
+C +---General and local variables
+C + ---------------------------
+
+ INCLUDE 'NSTdim.inc'
+ INCLUDE 'NSTvar.inc'
+
+ INTEGER i,j,k,level
+
+ REAL tair(mz),diff,karman,ustar,vstar,SLheight,deltaz,
+ . plevel,ra,gravit,cap
+
+
+C +---Data
+C + ----
+
+ DATA karman / 0.4 /
+ DATA ra / 287. /
+ DATA gravit / 9.81 /
+ DATA SLheight / 40. /
+ DATA cap / 0.285856574 /
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ DO j=1,my ! horizontal loop on grid points
+ DO i=1,mx ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Compute real temperature
+C + ========================
+
+ DO k=1,mz
+ tair(k)=NST_pt(i,j,k)/(100./NST__p(i,j,k))**cap
+ ENDDO
+
+
+C +---Search for the top level in the surface layer
+C + =============================================
+
+ plevel=NST_sp(i,j)*exp(-gravit/ra/tair(mz)*SLheight)
+
+ diff=100.
+
+ level=1
+
+ DO k=1,mz
+ IF (abs(NST__p(i,j,k)-plevel).lt.diff) THEN
+ level=k
+ diff =abs(NST__p(i,j,k)-plevel)
+ ENDIF
+ ENDDO
+
+ level=min(level,mz-1)
+ level=max(level,1)
+
+
+C +---Compute friction velocity in neutral atmosphere
+C + ===============================================
+
+ ustar=karman*NST__u(i,j,level)/log(SLheight/NST_z0(i,j))
+ vstar=karman*NST__v(i,j,level)/log(SLheight/NST_z0(i,j))
+
+
+C +---CORRECTION OF WIND, TEMPERATURE AND SPECIFIC HUMIDITY IN SL
+C + ===========================================================
+
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ DO k=level+1,mz ! loop on levels in the surface layer
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+ deltaz=-ra*tair(k)/gravit*log(NST__p(i,j,k)/NST_sp(i,j))
+C +... Height above the surface for the level k
+
+ IF (deltaz.lt.SLheight) THEN
+
+
+C +---LOG vertical profile for velocities in the surface layer
+C + --------------------------------------------------------
+
+ NST__u(i,j,k)=ustar/karman*log(deltaz/NST_z0(i,j))
+ NST__v(i,j,k)=vstar/karman*log(deltaz/NST_z0(i,j))
+
+
+C +---Vertical temperature profile in the surface layer
+C + -------------------------------------------------
+
+ IF (NST_pt(i,j,level).lt.NST_st(i,j)) THEN
+
+C + ... Constant potential temperature if unstable layer
+
+ NST_pt(i,j,k)=NST_pt(i,j,level)
+
+ ENDIF
+
+
+C +---Vertical profile of specific humidity (constant Qv)
+C + ---------------------------------------------------
+
+c #QV NST_qv(i,j,k)=NST_qv(i,j,level)
+
+ ENDIF
+
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ ENDDO ! loop on levels in the surface layer
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ ENDDO ! horizontal loop on grid points
+ ENDDO ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+ RETURN
+ END
+
diff --git a/MAR/code_nestor/src/SOLdom.f b/MAR/code_nestor/src/SOLdom.f
new file mode 100644
index 0000000000000000000000000000000000000000..d740ad130edaeacb2dc8a56c25c76aa6b78ee750
--- /dev/null
+++ b/MAR/code_nestor/src/SOLdom.f
@@ -0,0 +1,256 @@
+C +-------------------------------------------------------------------+
+C | Subroutine SOLdom June 2003 NESTING |
+C +-------------------------------------------------------------------+
+C | |
+C | Input : NSTsol : surface type (ocean, ice, snow, land) |
+C | ^^^^^^^ NSTtex : soil texture (fine, medium, coarse) |
+C | |
+C | Output: NST_d1 : surface heat capacity |
+C | ^^^^^^^ NSTalb : surface albedo |
+C | NSTeps : surface IR emissivity |
+C | NST_z0 : roughness length (momentum) |
+C | NST_r0 : roughness length (heat) |
+C | NSTres : aerodynamic resistance |
+C | NSTch0 : bulk aerodynamic coefficient air/surface |
+C | humidity flux |
+C | |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE SOLdom
+
+ IMPLICIT NONE
+
+C +---General and local variables
+C + ---------------------------
+
+ INCLUDE 'NSTdim.inc'
+ INCLUDE 'NSTvar.inc'
+ INCLUDE 'NESTOR.inc'
+
+ INTEGER i,j
+
+ REAL zl_SL,zs_SL,zn_SL,argLAT,sinLAT,Amn,Rmin,zero,Shelfb,
+ . Rmax,rsurSL,SH1,SH2,minz0
+
+C +---Data
+C + ----
+
+ zero = 0.0
+ Amn = 0.1
+ Rmin = 200.
+ Rmax = 900.
+
+ SH1 = 1500. ! Up to this height : normal vegetation
+ SH2 = 2000. ! Between SH1 and SH2 : decrease of vegetation
+
+C +---Screen message
+C + --------------
+
+ WRITE(6,*) 'Specification of surface characteristics'
+ WRITE(6,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+ WRITE(6,*)
+
+C +---SURFACE CHARACTERISTICS
+C + =======================
+
+C +---Typical Roughness Lengths (m) for land, sea, snow
+C + -------------------------------------------------
+
+ zl_SL = 1.00e-1
+ zs_SL = 1.00e-3
+ zn_SL = 1.00e-4
+ minz0 = 1.00e-4
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+C +---CORRECTION OF PRESCRIBED SURFACE TYPE
+C + =====================================
+
+ IF (TOP30.ne.'a '.AND.TOP30 .ne.'A '
+ . .AND..not.TOPetopo)THEN
+
+ DO j=1,my
+ DO i=1,mx
+
+
+C +---ANTARCTICA
+C + ----------
+
+ IF (NSTsol(i,j).ge.3.and.NST__y(i,j).lt. -60.d0) THEN
+ NSTsol(i,j) = 3
+ ENDIF
+
+C +---Weddel Sea Sector (ANTARCTICA)
+C + ------------------------------
+
+ IF (NST__x(i,j) .gt.-45..and.NST__x(i,j).lt. -30.d0) THEN
+ Shelfb = -76.5 + (NST__x(i,j)+30.d0) /10.
+ IF (NST__y(i,j).lt.Shelfb) THEN
+ NSTsol(i,j) = 3
+ NST_sh(i,j) = max(NST_sh(i,j),10.)
+ ENDIF
+ ENDIF
+ IF (NST__x(i,j) .gt.-70..and.NST__x(i,j).lt. -45.d0) THEN
+ Shelfb = -77.0 - (NST__x(i,j)+45.d0)*2./15.
+ IF (NST__y(i,j).lt.Shelfb) THEN
+ NSTsol(i,j) = 3
+ NST_sh(i,j) = max(NST_sh(i,j),10.)
+ ENDIF
+ ENDIF
+ IF (NST__x(i,j) .gt.-90..and.NST__x(i,j).lt. -70.d0) THEN
+ Shelfb = -75.
+ IF (NST__y(i,j).lt.Shelfb) THEN
+ NSTsol(i,j) = 3
+ NST_sh(i,j) = max(NST_sh(i,j),10.)
+ ENDIF
+ ENDIF
+
+C +---Ross Sea Sector (ANTARCTICA)
+C + ----------------------------
+
+ IF (abs(NST__x(i,j)).gt.120..and.NST__y(i,j).lt. -77.d0) THEN
+ NSTsol(i,j) = 3
+ NST_sh(i,j) = max(NST_sh(i,j),10.)
+ ENDIF
+
+ ENDDO
+ ENDDO
+ ENDIF
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ DO j=1,my
+ DO i=1,mx
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ GO TO (100,200,300,400,400) NSTsol(i,j)
+
+C +---1. Ocean
+C + --------
+
+100 NST_d1(i,j) = 0.
+ NSTalb(i,j) = 0.15
+ NSTeps(i,j) = 0.97
+ IF (NST_z0(i,j).lt.minz0) THEN
+ NST_z0(i,j) = zs_SL
+ ENDIF
+ NST_r0(i,j) = 0.1*zs_SL
+ NSTch0(i,j) = 0.00132
+ NSTres(i,j) = 0.0
+C +
+ IF(region.eq."GRD".or.region.eq."ANT") THEN
+ NST_d1(i,j) = 2.09d+8
+ NSTalb(i,j) = 0.10d0
+ ENDIF
+C +
+ GOTO 500
+
+C +---2. Sea Ice
+C + ----------
+
+200 NST_d1(i,j) = 1.05d+5
+ NSTalb(i,j) = 0.85d00
+ NSTeps(i,j) = 0.97d00
+ IF (NST_z0(i,j).lt.minz0) THEN
+ NST_z0(i,j) = zn_SL
+ ENDIF
+ NST_r0(i,j) = 0.1*zn_SL
+ NSTch0(i,j) = 0.0021
+C +... (Kondo and Yamazaki, 1990, JAM 29, p.376)
+ NSTres(i,j) = 0.0
+
+ IF(region.eq."GRD".or.region.eq."ANT") THEN
+c NSTalb(i,j) = 0.70d0
+ NSTalb(i,j) = 0.10d0 ! To no have problem
+ ! when snow ice melt
+ ENDIF
+C +
+ GOTO 500
+
+C +---3. Snow Field
+C + -------------
+
+300 NST_d1(i,j) = 1.05e+5
+ NSTalb(i,j) = 0.85
+ NSTeps(i,j) = 0.97
+ IF (NST_z0(i,j).lt.minz0) THEN
+ NST_z0(i,j) = zn_SL
+ ENDIF
+ NST_r0(i,j) = 0.1*zn_SL
+ NSTch0(i,j) = 0.0021
+C +... (Kondo and Yamazaki, 1990, JAM 29, p.376)
+ NSTres(i,j) = 0.0
+ GOTO 500
+
+
+C +---4. Continent
+C + ------------
+
+400 CONTINUE
+
+ IF (NSTtex(i,j).eq.1) THEN
+ NST_d1(i,j) = 1.65e+5
+ NSTalb(i,j) = 0.40
+C +... Dry Quartz Sand (Deardorff 1978 JGR p.1891)
+ ELSE IF (NSTtex(i,j).eq.3) THEN
+ NST_d1(i,j) = 7.55e+5
+ NSTalb(i,j) = 0.15
+C +... Clay Pasture (Deardorff 1978 JGR p.1891)
+ ELSE
+ NST_d1(i,j) = 2.88e+5
+ NSTalb(i,j) = 0.25
+C +... O'Neill average (Deardorff 1978 JGR p.1891)
+ ENDIF
+C +
+ argLAT = 0.0628 * NST__y(i,j)
+ sinLAT = max(zero,sin(argLAT))
+C +
+ NSTeps(i,j) = 0.97
+C +
+ NST_r0(i,j) = zl_SL
+ NST_r0(i,j) =-0.9d-1*sinLAT + zl_SL
+ NST_r0(i,j) = min(zl_SL,NST_r0(i,j))
+ NST_r0(i,j) = 0.1000 * NST_r0(i,j)
+C +
+ IF (NST_z0(i,j).lt.minz0) THEN
+ NST_z0(i,j) = 10.0 * NST_r0(i,j)
+ ENDIF
+C +
+ NSTch0(i,j) = 0.0025
+C +
+ NSTalb(i,j) = 3.0d-1 * sinLAT +0.5d-1
+ NSTalb(i,j) = max(Amn ,NSTalb(i,j))
+C +
+ NSTres(i,j) = 5.0d+3 * sinLAT -1.6d+3
+ NSTres(i,j) = max(Rmin ,NSTres(i,j))
+ IF (NST_sh(i,j).le.SH1) THEN
+ rsurSL = Rmin
+ ELSE
+ IF (NST_sh(i,j).gt.SH2) THEN
+ rsurSL = Rmax
+ ELSE
+ rsurSL = Rmin
+ . + (NST_sh(i,j)-SH1)/(SH2-SH1)*(Rmax-Rmin)
+ ENDIF
+ ENDIF
+ NSTres(i,j) = max(rsurSL,NSTres(i,j))
+C +
+ IF(region.eq."GRD".or.region.eq."ANT") THEN
+ NST_d1(i,j) = 1.74d+5
+ NSTalb(i,j) = 0.2d0
+ ENDIF
+C +
+ GOTO 500
+
+500 CONTINUE
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ ENDDO
+ ENDDO
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ RETURN
+ END
diff --git a/MAR/code_nestor/src/SVTpar.f b/MAR/code_nestor/src/SVTpar.f
new file mode 100644
index 0000000000000000000000000000000000000000..8f034dbf26d520929ef2e818322a10ff822a7aae
--- /dev/null
+++ b/MAR/code_nestor/src/SVTpar.f
@@ -0,0 +1,427 @@
+C +-------------------------------------------------------------------+
+C | Subroutine SVTpar February 2004 NESTING |
+C +-------------------------------------------------------------------+
+C | |
+C | Interpolation of large-scale wetness fields to nested grid. |
+C | SVTpar completes the current data sets (surface characteristics |
+C | and prognostic variables) for the SVAT model. |
+C | |
+C | INPUT : - I_time: time for which the data is requested |
+C | ^^^^^^^^ - HORint: horizontal interp. type (1= bilin, 3= bicub) |
+C | - LSCfil: input LSC data file (path+name) |
+C | - SPHgrd: true if spherical coordinates for LSC model |
+C | - NST__x, NST__y : NST grid coordinates (lat./long.) |
+C | - NST_sh: topography in nested model |
+C | - NSTsol: soil type |
+C | - NSTtex: soil texture over land |
+C | - NST_st: soil or sea surface temperature |
+C | - NSTdst: deep soil temperature |
+C | - NSTsvt: vegetation type (SVATclassification) |
+C | - NSTsfr: fraction of vegetation in the grid cell (SVAT) |
+C | - NST__t: real temperature |
+C | - SVTwet: imposed soil moisture in all layers (%) |
+C | - SVTlsc: soil wetness computed from ECMWF fields |
+C | |
+C | OUTPUT : - NST_ts: soil temperature ( K ) |
+C | ^^^^^^^^ - NST_sw: soil water content ( m/s ) |
+C | - NSTglf: green leaf fraction |
+C | - NSTiwf: 0=no water flux, 1=free drainage |
+C | |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE SVTpar
+
+ IMPLICIT NONE
+
+C +---General variables
+C + -----------------
+
+ INCLUDE 'NSTdim.inc'
+ INCLUDE 'NESTOR.inc'
+ INCLUDE 'NSTvar.inc'
+ INCLUDE 'LSCvar.inc'
+
+C +---Local variables
+C + ---------------
+
+ INTEGER i,j,k,l,it,fID,ierror,SOLtex
+
+ INTEGER pos_Ox(mx,my),pos_Oy(mx,my)
+
+ REAL empty1(1),SW_dry(0:12),SW_wet(0:12),relSW1,relSW2,relSW3,
+ . SW_max,zero,unun,aux1,aux2,aux3,totvfr,tmpvfr
+
+ REAL INT_sw(mx,my),INTdsw(mx,my)
+
+C +---Remarks on additional LSC variables (27/04/2022, J.-F. Grailet)
+C + ---------------------------------------------------------------
+C Initially, this routine had its own versions of LSC1Dx, LSC1Dy,
+C LSC__x and LSC__y, all suffixed with s. It turned out these
+C arrays/grids loaded the same values as in the LSC variables used
+C in NSTint (same LSCfil) and were used in the exact same manner.
+C I therefore replaced them with the LSCvar.inc equivalents. Other
+C variables were left unchanged.
+
+ REAL LSC_sws(ni,nj),LSCdsws(ni,nj),LSC_shs(ni,nj)
+
+ CHARACTER*10 var_units
+ CHARACTER*100 LSCtit
+
+C +---Data
+C + ----
+
+ DATA zero / 0. /
+ DATA unun / 1. /
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+C +---Screen message
+C + --------------
+
+ ! Minimalized console output outside verbose mode (JFG)
+ IF (vrbose) THEN
+ write(6,*) 'Initialisation of soil prognostic variables'
+ write(6,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+ ENDIF
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+C +---Dry and nearly saturated water contents
+C =======================================
+
+ SW_dry( 0)=1.04e-5 !
+ SW_dry( 1)=1.38e-2 !
+ SW_dry( 2)=1.72e-2 ! values in agreement with those of SVAT
+ SW_dry( 3)=3.07e-2 !
+ SW_dry( 4)=5.32e-2 !
+ SW_dry( 5)=4.68e-2 !
+ SW_dry( 6)=7.08e-2 !
+ SW_dry( 7)=9.50e-2 !
+ SW_dry( 8)=0.1173 !
+ SW_dry( 9)=0.1180 !
+ SW_dry(10)=0.1526 !
+ SW_dry(11)=0.1628 !
+ SW_dry(12)=0.0 !
+
+ SW_wet( 0)=1.000 !
+ SW_wet( 1)=0.395 !
+ SW_wet( 2)=0.410 ! values in agreement with those of SVAT
+ SW_wet( 3)=0.435 !
+ SW_wet( 4)=0.485 !
+ SW_wet( 5)=0.451 !
+ SW_wet( 6)=0.420 !
+ SW_wet( 7)=0.477 !
+ SW_wet( 8)=0.476 !
+ SW_wet( 9)=0.426 !
+ SW_wet(10)=0.492 !
+ SW_wet(11)=0.482 !
+ SW_wet(12)=0.001 !
+
+
+ SW_max =0.032 ! Soil water content corresponding
+ ! to saturation in ERA-15
+
+ IF(LSCmod.eq.'E40'.or.LSCmod.eq.'ECM')
+ .SW_max =0.47 ! Soil water content corresponding
+ ! to saturation in ERA-40
+
+C http://www.ecmwf.int/products/data/technical/soil/discret_soil_lay.html
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+C +---Completion of surface characteristics data set
+C + ==============================================
+
+ DO j=1,my
+ DO i=1,mx
+
+ IF (NSTsol(i,j).ge.4) THEN
+
+ NSTiwf(i,j)=1
+
+ DO k=1,nvx
+ NSTglf(i,j,k)=1.
+ ENDDO
+
+C + ... Check fractions of vegetation
+
+ totvfr=0
+ DO l=1,nvx
+ totvfr=totvfr+NSTsfr(i,j,l)
+ ENDDO
+ IF (totvfr.ne.100) THEN
+ totvfr=totvfr-NSTsfr(i,j,nvx)
+ IF (totvfr.ne.0) THEN
+ DO l=2,nvx-1
+ aux1 =REAL(NSTsfr(i,j,l))
+ aux2 =REAL(totvfr)
+ aux3 =REAL(NSTsfr(i,j,nvx))
+ NSTsfr(i,j,l)=aux1/aux2*(100.-aux3)
+ ENDDO
+ tmpvfr=0.
+ DO l=2,nvx
+ tmpvfr=tmpvfr+NSTsfr(i,j,l)
+ ENDDO
+ NSTsfr(i,j,1) = 100. - tmpvfr
+ ELSE
+ DO l=1,nvx
+ NSTsfr(i,j,l) =0.
+ ENDDO
+ NSTsfr(i,j,nvx)=100.
+ ENDIF
+ ENDIF
+
+ ELSE
+
+ NSTiwf(i,j)=0.
+
+ DO k=1,nvx
+ NSTglf(i,j,k)=0.
+ ENDDO
+
+ DO k=1,nvx
+ NSTsfr(i,j,k)=0.
+ NSTsvt(i,j,k)=0.
+ ENDDO
+ NSTsfr(i,j,1) = 100.
+
+ ENDIF
+
+ ENDDO
+ ENDDO
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ IF (SVTlsc) THEN
+
+C +---Open NetCDF file containing LSC data
+C + ====================================
+
+ IF (vrbose) THEN
+ write(6,*) 'Open file : ',LSCfil
+ write(6,*) 'Time step : ',I_time
+ ENDIF
+
+C + *******
+ CALL UNropen (LSCfil,fID,LSCtit)
+C + *******
+
+C +---Time for data extraction
+C + ------------------------
+
+ it = I_time
+
+C +---Horizontal coordinates
+C + ----------------------
+
+ DO j=1,my
+ DO i=1,mx
+ pos_Ox(i,j)=0
+ pos_Oy(i,j)=0
+ ENDDO
+ ENDDO
+
+ IF (REGgrd) THEN
+
+C + ******
+ CALL UNread (fID,'SH' ,it,1,bi,bj,ni,nj,1,
+ . LSC1Dx,LSC1Dy,empty1,var_units,LSC_shs)
+C + ******
+
+ DO j=1,nj
+ DO i=1,ni
+ LSC__x(i,j)=LSC1Dx(i)
+ LSC__y(i,j)=LSC1Dy(j)
+ ENDDO
+ ENDDO
+
+ ELSE
+
+C + ******
+ CALL UNread (fID,'lon' ,it,1,bi,bj,ni,nj,1,
+ . LSC1Dx,LSC1Dy,empty1,var_units,LSC__x)
+C + ******
+
+ ! JFG 27/04/22: initially, these instructions were used in
+ ! NSTint but not here. Since the values come from the same
+ ! file, the instructions were copy/pasted.
+ do i=1,ni ; do j=1,nj
+ if(LSC__x(i,j)>180) LSC__x(i,j)=LSC__x(i,j)-360.
+ enddo ; enddo
+
+C + ******
+ CALL UNread (fID,'lat' ,it,1,bi,bj,ni,nj,1,
+ . LSC1Dx,LSC1Dy,empty1,var_units,LSC__y)
+C + ******
+
+ ENDIF
+
+C +---Soil wetness
+C + ------------
+
+ IF (LSCmod.ne.'E40'.and.LSCmod.ne.'ECM') THEN
+
+ IF (vrbose) THEN
+ write(6,'(A,$)') ' 2-D fields : SWL1'
+ ENDIF
+
+C + ******
+ CALL UNread (fID,'SWL1' ,it,1,bi,bj,ni,nj,1,
+ . LSC1Dx,LSC1Dy,empty1,var_units,LSC_sws)
+C + ******
+ ELSE
+
+ IF (vrbose) THEN
+ write(6,'(A,$)') ' 2-D fields : SWVL1'
+ ENDIF
+
+C + ******
+ CALL UNread (fID,'SWVL1' ,it,1,bi,bj,ni,nj,1,
+ . LSC1Dx,LSC1Dy,empty1,var_units,LSC_sws)
+
+
+ ENDIF
+
+C + ******
+ CALL intHor (HORint,LSC__x,LSC__y,LSC_sws,
+ . SPHgrd,NST__x,NST__y,INT_sw,
+ . REGgrd,pos_Ox,pos_Oy)
+C + ******
+
+C +---Deep soil wetness
+C + -----------------
+
+ IF (LSCmod.ne.'E40'.and.LSCmod.ne.'ECM') THEN
+
+ IF (vrbose) THEN
+ write(6,'(A,$)') ' - SWL2'
+ write(6,*)
+ ENDIF
+
+C + ******
+ CALL UNread (fID,'SWL2' ,it,1,bi,bj,ni,nj,1,
+ . LSC1Dx,LSC1Dy,empty1,var_units,LSCdsws)
+C + ******
+ ELSE
+
+ IF (vrbose) THEN
+ write(6,'(A,$)') ' - SWVL2'
+ write(6,*)
+ ENDIF
+
+C + ******
+ CALL UNread (fID,'SWVL2' ,it,1,bi,bj,ni,nj,1,
+ . LSC1Dx,LSC1Dy,empty1,var_units,LSCdsws)
+C + ******
+
+ ENDIF
+
+C + ******
+ CALL intHor (HORint,LSC__x,LSC__y,LSCdsws,
+ . SPHgrd,NST__x,NST__y,INTdsw,
+ . REGgrd,pos_Ox,pos_Oy)
+C + ******
+
+C +---Close the NetCDF file
+C + =====================
+
+C + ******
+ CALL NCCLOS (fID,ierror)
+C + ******
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ ELSE
+
+ IF (vrbose) THEN
+ write(6,*) 'Imposed soil wetness'
+ ENDIF
+
+ ENDIF ! (SVTlsc)
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+C +---Soil temperature
+C + ================
+
+ DO l=1,nvx
+ DO j=1,my
+ DO i=1,mx
+ IF (NSTsol(i,j).ge.4) THEN
+ DO k=1,nsl
+ NST_ts(i,j,l,k)= NSTdst(i,j)
+ ENDDO
+ NST_ts(i,j,l,1)= NST_st(i,j)
+ NST_ts(i,j,l,2)=(NST_st(i,j)+NSTdst(i,j))*0.5
+ ELSE
+ DO k=1,nsl
+ NST_ts(i,j,l,k)= NST_st(i,j)
+ ENDDO
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+C +---Soil water content
+C + ==================
+
+ DO l=1,nvx
+ DO j=1,my
+ DO i=1,mx
+
+ IF (SVTlsc) THEN
+ relSW1=INT_sw(i,j)/SW_max
+ relSW3=INTdsw(i,j)/SW_max
+ relSW2=0.5*(relSW1+relSW3)
+ ELSE
+ relSW1=SVTwet/100.
+ relSW2=SVTwet/100.
+ relSW3=SVTwet/100.
+ ENDIF
+
+ relSW1=MAX(zero,relSW1)
+ relSW2=MAX(zero,relSW2)
+ relSW3=MAX(zero,relSW3)
+ relSW1=MIN(unun,relSW1)
+ relSW2=MIN(unun,relSW2)
+ relSW3=MIN(unun,relSW3)
+
+ IF (NSTsol(i,j).ge.4) THEN
+
+ SOLtex=NSTtex(i,j)
+
+ IF (SOLtex.eq.0) SOLtex=2
+
+ DO k=1,nsl-3
+ NST_sw(i,j,l, k)=SW_dry(SOLtex)
+ . +relSW1*(SW_wet(SOLtex)-SW_dry(SOLtex))
+ ENDDO
+ NST_sw(i,j,l,nsl-2)=SW_dry(SOLtex)
+ . +relSW2*(SW_wet(SOLtex)-SW_dry(SOLtex))
+ DO k=nsl-1,nsl
+ NST_sw(i,j,l, k)=SW_dry(SOLtex)
+ . +relSW3*(SW_wet(SOLtex)-SW_dry(SOLtex))
+ ENDDO
+
+ ELSE
+
+ DO k=1,nsl
+ NST_sw(i,j,l,k)=1.
+ ENDDO
+
+ ENDIF
+
+ ENDDO
+ ENDDO
+ ENDDO
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ IF (vrbose) THEN
+ write(6,*) ' '
+ ENDIF
+
+ RETURN
+ END
diff --git a/MAR/code_nestor/src/TOPcor.f b/MAR/code_nestor/src/TOPcor.f
new file mode 100644
index 0000000000000000000000000000000000000000..4f9137d81c176300a0ead038605512dd4d9128ef
--- /dev/null
+++ b/MAR/code_nestor/src/TOPcor.f
@@ -0,0 +1,608 @@
+C +-------------------------------------------------------------------+
+C | Subroutine TOPcor 16/08/19 NESTING |
+C +-------------------------------------------------------------------+
+C | |
+C | Input : NST_sh : Topography prescribed from data sets |
+C | ^^^^^^^ |
+C | |
+C | Output : NST_sh : Corrected topography |
+C | ^^^^^^^ |
+C | |
+C | Options: values given to TOPopt : |
+C | ^^^^^^^ 1 = Border of constant NST topography at boundaries |
+C | 2 = Imposed LSC topography in the const. border at bound.|
+C | 3 = Imposed LSC topography in the whole domain |
+C | 4 = Zero topography in the constant border |
+C | 5 = Topography filtering (2D and 3D) |
+C | Note that these options can be combined. |
+C | |
+C | |
+C | Explanations of boundary structure : see parameters in NSTdim.inc |
+C | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |
+C | |
+C | 1. TOPOGRAPHY |
+C | ------------- |
+C | Constant | Transition | Computation | Transition | Constant |
+C | topography | zone | domain | zone | topography |
+C | zone | (LS -> MAR)| | (LS -> MAR)| zone |
+C ^ ^ ^ ^ ^ ^
+C 1 ... n10 ... n10+n8+1 ... mx-n9-n8-1 ... mx-n9 ... mx
+C | |
+C | 2. RELAXATION LSC --> NST |
+C | ------------------------- |
+C | Relaxation | Computation | Relaxation |
+C | zone | domain | zone |
+C ^ ^ ^ ^
+C 1 ... n7 ... mx-n6 ... mx
+C | |
+C +-------------------------------------------------------------------+
+
+
+ SUBROUTINE TOPcor (TOPopt)
+
+
+ IMPLICIT NONE
+
+
+C +---General and local variables
+C + ---------------------------
+
+ INCLUDE 'NSTdim.inc'
+ INCLUDE 'NSTvar.inc'
+ INCLUDE 'INTvar.inc'
+ INCLUDE 'LSCvar.inc'
+
+ INTEGER i,j,mmx,mmy,n88,n9x,n9y,n10x,n10y,TOPopt,ind,ii2,jj2,m
+ INTEGER boundary
+
+ REAL TMP_sh (mx,my),aux ,ww
+ REAL cpt,tmp,tmp1
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---Define temporary variables related to array sizes
+C + -------------------------------------------------
+
+ n9x = MIN(n9,mx-1)
+ n9y = MIN(n9,my-1)
+ n10x = MIN(n10,mx)
+ n10y = MIN(n10,my)
+
+ mmx = mx
+ mmy = my
+
+ IF (mmx.eq.1) THEN
+ n9x = 0
+ n10x = 1
+ ENDIF
+
+ IF (mmy.eq.1) THEN
+ n9y = 0
+ n10y = 1
+ ENDIF
+
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---OPTION 1
+C + ********
+
+
+C +---Border of constant NST topography at boundaries
+C ===============================================
+
+C +...Topography in the relaxation zone of the mesoscale domain
+C +...is given by topography from data sets and has constant
+C +...value in this region.
+
+ IF (TOPopt.eq.1) THEN
+
+ WRITE(6,*) 'Border of constant NST topography'
+ WRITE(6,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+ WRITE(6,*)
+
+ DO j=1,my
+ DO i=1,n9x
+ NST_sh( i ,j) = NST_sh( n10x,j)
+ NST_sh(mx-i+1,j) = NST_sh(mx- n9x,j)
+ END DO
+ END DO
+
+ DO j=1,n9y
+ DO i=1,mx
+ NST_sh(i, j ) = NST_sh(i, n10y)
+ NST_sh(i,my-j+1) = NST_sh(i,my-n9y)
+ END DO
+ END DO
+
+ ENDIF
+
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---OPTION 2
+C + ********
+
+
+C +---Imposed LSC topography in the relaxation zone at the boundaries
+C + ===============================================================
+
+C +...Topography in the relaxation zone of the mesoscale domain is
+C +...given by the LSC topography. A transition zone (size=n8)
+C +...avoids strong changes of the surface elevation.
+
+ IF (TOPopt.eq.2) THEN
+
+ WRITE(6,*) 'Imposed LSC topography in the relax. zone'
+ WRITE(6,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+ WRITE(6,*)
+
+
+C +---Transition area
+C + ---------------
+
+ n88=MAX(1,n8)+1
+
+ IF (mmx.eq.1.or.mmy.eq.1) n88=0
+
+
+C +---Bottom and top boundaries (corners included)
+C + --------------------------------------------
+
+ DO i=n10x,mx-n9x
+
+ DO j=1,n10y
+ NST_sh(i,j) = INT_sh(i,n10y)
+ ENDDO
+
+ DO j=my-n9y,my
+ NST_sh(i,j) = INT_sh(i,my-n9y)
+ ENDDO
+
+ ENDDO
+
+
+C +---Left and right boundaries (corners not included)
+C + ------------------------------------------------
+
+ DO j=1,my
+
+ ind=min(j,my-n9y)
+ ind=max(ind,n10y)
+
+ DO i=1,n10x
+ NST_sh(i,j) = INT_sh(n10x,ind)
+ ENDDO
+
+ DO i=mx-n9x,mx
+ NST_sh(i,j) = INT_sh(mx-n9x,ind)
+ ENDDO
+
+ ENDDO
+
+
+C +---Treatment of transition area between large-scale
+C + topography and mesoscale topography ------------
+C + -----------------------------------
+
+ DO i=n10x+1,mx-n9x-1
+
+ ind = min(i,mx-n9x-n88)
+ ind = max(ind,n10x+n88 )
+
+ DO j=n10y+1,n10y+n88-1
+ aux = real(j-n10y)/real(n88)
+ IF (i.ge.j.and.(mx-i).ge.j)
+ . NST_sh(i,j) = (1.-aux)*NST_sh(i,n10y)
+ . +aux *NST_sh(ind,n10y+n88)
+ ENDDO
+
+ DO j=my-n9y-n88+1,my-n9y-1
+ aux = real(j-(my-n9y-n88))/real(n88)
+ IF (i.le.j.and.(mx-i).le.j)
+ . NST_sh(i,j) = (1.-aux)*NST_sh(i,my-n9y-n88)
+ . +aux*NST_sh(ind,my-n9y)
+ ENDDO
+
+ ENDDO
+
+
+ DO j=n10y+1,my-n9y-1
+
+ ind = min(j,my-n9y-n88)
+ ind = max(ind,n10y+n88)
+
+ DO i=n10x+1,n10x+n88-1
+ aux = real(i-n10x)/real(n88)
+ IF (i.le.j.and.(mx-i).ge.j)
+ . NST_sh(i,j) = (1.-aux)*NST_sh(n10x,j)
+ . +aux *NST_sh(n10x+n88,ind)
+ ENDDO
+
+ DO i=mx-n9x-n88+1,mx-n9x-1
+ aux = real(i-(mx-n9x-n88))/real(n88)
+ IF (i.ge.j.and.(mx-i).le.j)
+ . NST_sh(i,j) = (1.-aux)*NST_sh(mx-n9x-n88,ind)
+ . +aux*NST_sh(mx-n9x,j)
+ ENDDO
+
+ ENDDO
+
+ ENDIF
+
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---OPTION 3
+C + ********
+
+
+C +---Imposed LSC topography in the whole domain
+C + ==========================================
+
+C +...LSC topography is imposed for each NST grid point.
+
+ IF (TOPopt.eq.3) THEN
+
+ WRITE(6,*) 'Imposed LSC topography in the whole domain'
+ WRITE(6,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+ WRITE(6,*)
+
+C +---NST topography = LSC topography
+C + -------------------------------
+
+ DO j=1,my
+ DO i=1,mx
+ NST_sh(i,j) = INT_sh(i,j)
+ ENDDO
+ ENDDO
+
+ ENDIF
+
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---OPTION 4
+C + ********
+
+
+C +---Zero topography in the relaxation zone
+C + ======================================
+
+C +...Topography in the relaxation zone of the NST domain is set to
+C +...zero (mean sea level). A transition zone (size=n8) avoids strong
+C +...changes between the relaxation area and the computation domain.
+
+ IF (TOPopt.eq.4) THEN
+
+ WRITE(6,*) 'Zero topography in the relaxation zone'
+ WRITE(6,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+ WRITE(6,*)
+
+C +---Transition area
+C + ---------------
+
+ n88=MAX(1,n8)+1
+
+C +---Bottom and top boundaries (corners included)
+C + --------------------------------------------
+
+ DO i=n10x,mx-n9x
+
+ DO j=1,n10y
+ NST_sh(i,j) = 0.
+ ENDDO
+
+ DO j=my-n9y,my
+ NST_sh(i,j) = 0.
+ ENDDO
+
+ ENDDO
+
+
+C +---Left and right boundaries (corners not included)
+C + ------------------------------------------------
+
+ DO j=1,my
+
+ ind=min(j,my-n9y)
+ ind=max(ind,n10y)
+
+ DO i=1,n10x
+ NST_sh(i,j) = 0.
+ ENDDO
+
+ DO i=mx-n9x,mx
+ NST_sh(i,j) = 0.
+ ENDDO
+
+ ENDDO
+
+
+C +---Treatment of transition area between large-scale
+C + topography and mesoscale topography ------------
+C + -----------------------------------
+
+ DO i=n10x+1,mx-n9x-1
+
+ ind = min(i,mx-n9x-n88)
+ ind = max(ind,n10x+n88 )
+
+ DO j=n10y+1,n10y+n88-1
+ aux = real(j-n10y)/real(n88)
+ IF (i.ge.j.and.(mx-i).ge.j)
+ . NST_sh(i,j) = (1.-aux)*NST_sh(i,n10y)
+ . +aux *NST_sh(ind,n10y+n88)
+ ENDDO
+
+ DO j=my-n9y-n88+1,my-n9y-1
+ aux = real(j-(my-n9y-n88))/real(n88)
+ IF (i.le.j.and.(mx-i).le.j)
+ . NST_sh(i,j) = (1.-aux)*NST_sh(i,my-n9y-n88)
+ . +aux*NST_sh(ind,my-n9y)
+ ENDDO
+
+ ENDDO
+
+
+ DO j=n10y+1,my-n9y-1
+
+ ind = min(j,my-n9y-n88)
+ ind = max(ind,n10y+n88)
+
+ DO i=n10x+1,n10x+n88-1
+ aux = real(i-n10x)/real(n88)
+ IF (i.le.j.and.(mx-i).ge.j)
+ . NST_sh(i,j) = (1.-aux)*NST_sh(n10x,j)
+ . +aux *NST_sh(n10x+n88,ind)
+ ENDDO
+
+ DO i=mx-n9x-n88+1,mx-n9x-1
+ aux = real(i-(mx-n9x-n88))/real(n88)
+ IF (i.ge.j.and.(mx-i).le.j)
+ . NST_sh(i,j) = (1.-aux)*NST_sh(mx-n9x-n88,ind)
+ . +aux*NST_sh(mx-n9x,j)
+ ENDDO
+
+ ENDDO
+
+ ENDIF
+
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C +---OPTION 5
+C + ********
+
+
+C +---Topography filtering (2D and 3D)
+C + ================================
+
+ IF (TOPopt.eq.5) THEN
+
+ ww =72
+ boundary=10
+ if(NST_dx<=10000) boundary=15
+
+ WRITE(6,*) 'Topography filtering with a weight of',ww
+
+ IF (mmx.gt.1) THEN
+
+
+! large scale topography at the boundaries (16/08/2019)
+! ----------------------------------------
+
+
+ print *,"Large scale topography at the boundaries in TOPcor.f"
+ print *,""
+ print *,"WARNING: must be commented if you use ERA-40"
+ print *," and after ERA5 for example"
+ print *,""
+
+ if(LSCmod.eq.'E40') stop
+ if(LSCmod.eq.'GFS') stop
+
+ do i = 1,mx
+ do j = 1,my
+
+ tmp=min(min(i-1,mx-i),min(j-1,my-j))
+ tmp=min(1.,max(0.,tmp/boundary))
+ tmp=tmp**2
+
+ if(NST_sh (i,j)>10) then
+ NST_sh (i,j) = NST_sh(i,j)*tmp+max(0.,INT_sh(i,j)*(1-tmp))
+ endif
+
+ enddo
+ enddo
+
+ !This could be a suggestion:
+ ! 1. run NESTOR with ERA5
+ ! 2. keep an output file with SH
+ ! 3. read this file when ERA40 is used
+ ! 4. WARNING: the filtering will be applied 2 times if NST_SH is read here
+ ! instead of at the end of TOPcor.f
+
+ !print *,"read1 of NST_sh.nc"
+ !call CF_READ2D( "NST_sh.nc",'SH',1,mx,my, 1,NST_sh)
+
+! filtering everywhere
+! --------------------
+ IF (mmy.gt.1) THEN
+
+ DO j = 2,mmy-1
+ DO i = 2,mmx-1
+ TMP_sh(i,j)=NST_sh(i-1,j+1)+2.*NST_sh(i,j+1)+ NST_sh(i+1,j+1)
+ . +2.*NST_sh(i-1,j )+ww*NST_sh(i,j )+2.*NST_sh(i+1,j )
+ . + NST_sh(i-1,j-1)+2.*NST_sh(i,j-1)+ NST_sh(i+1,j-1)
+ ENDDO
+ ENDDO
+
+ DO j = 2,mmy-1
+ DO i = 2,mmx-1
+ NST_sh (i,j) = TMP_sh(i,j) / (12.+ww)
+ ENDDO
+ ENDDO
+
+c jj2 = 2
+c DO i=1,mx
+c NST_sh (i, 1) = NST_sh(i, jj2)
+c NST_sh (i,my) = NST_sh(i,mmy-1)
+c ENDDO
+
+c ii2 = 2
+c DO j=1,my
+c NST_sh ( 1,j) = NST_sh( ii2,j)
+c NST_sh (mx,j) = NST_sh(mmx-1,j)
+c ENDDO
+
+! filtering top/down boundary
+! -----------------------------
+
+ ww=4
+
+ WRITE(6,*) 'Topography filtering with a weight of',ww,'at bound'
+ WRITE(6,*) 'Topography filtering with a boundary of',boundary
+ WRITE(6,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+
+ DO j = 1,my
+ DO i = mx-boundary+1,mx
+ TMP_sh(i,j)= NST_sh(max(1,i-1) ,min(j+1,my))
+ . +2. *NST_sh(i, min(j+1,my))
+ . + NST_sh(min(mx,i+1),min(j+1,my))
+ . +2. *NST_sh(max(1,i-1) ,j)
+ . +ww *NST_sh(i ,j)
+ . +2. *NST_sh(min(mx,i+1),j)
+ . + NST_sh(max(1,i-1) ,max(1,j-1))
+ . +2. *NST_sh(i, max(1,j-1))
+ . + NST_sh(min(mx,i+1),max(1,j-1))
+ ENDDO
+ DO i = 1,boundary
+ TMP_sh(i,j)= NST_sh(max(1,i-1) ,min(j+1,my))
+ . +2. *NST_sh(i, min(j+1,my))
+ . + NST_sh(min(mx,i+1),min(j+1,my))
+ . +2. *NST_sh(max(1,i-1) ,j)
+ . +ww *NST_sh(i ,j)
+ . +2. *NST_sh(min(mx,i+1),j)
+ . + NST_sh(max(1,i-1) ,max(1,j-1))
+ . +2. *NST_sh(i, max(1,j-1))
+ . + NST_sh(min(mx,i+1),max(1,j-1))
+ ENDDO
+ ENDDO
+
+ DO j = 1,my
+ DO i = mx-boundary+1,mx
+ NST_sh (i,j) = TMP_sh(i,j) / (12.+ww)
+ ENDDO
+ DO i = 1,boundary
+ NST_sh (i,j) = TMP_sh(i,j) / (12.+ww)
+ ENDDO
+ ENDDO
+
+! filtering right/left boundary
+! -----------------------------
+
+ DO i = 1,mx
+ DO j = my-boundary+1,my
+ TMP_sh(i,j)= NST_sh(max(1,i-1) ,min(j+1,my))
+ . +2. *NST_sh(i, min(j+1,my))
+ . + NST_sh(min(mx,i+1),min(j+1,my))
+ . +2. *NST_sh(max(1,i-1) ,j)
+ . +ww *NST_sh(i ,j)
+ . +2. *NST_sh(min(mx,i+1),j)
+ . + NST_sh(max(1,i-1) ,max(1,j-1))
+ . +2. *NST_sh(i, max(1,j-1))
+ . + NST_sh(min(mx,i+1),max(1,j-1))
+ ENDDO
+ DO j = 1,boundary
+ TMP_sh(i,j)= NST_sh(max(1,i-1) ,min(j+1,my))
+ . +2. *NST_sh(i, min(j+1,my))
+ . + NST_sh(min(mx,i+1),min(j+1,my))
+ . +2. *NST_sh(max(1,i-1) ,j)
+ . +ww *NST_sh(i ,j)
+ . +2. *NST_sh(min(mx,i+1),j)
+ . + NST_sh(max(1,i-1) ,max(1,j-1))
+ . +2. *NST_sh(i, max(1,j-1))
+ . + NST_sh(min(mx,i+1),max(1,j-1))
+ ENDDO
+ ENDDO
+
+ DO i = 1,mx
+ DO j = my-boundary+1,my
+ NST_sh (i,j) = TMP_sh(i,j) / (12.+ww)
+ ENDDO
+ DO j = 1,boundary
+ NST_sh (i,j) = TMP_sh(i,j) / (12.+ww)
+ ENDDO
+ ENDDO
+
+
+ ELSE
+
+ j = 1
+
+ DO i=2,mmx-1
+ TMP_sh(i,j)=NST_sh(i-1,j)+2.*NST_sh(i,j)+NST_sh(i+1,j)
+ ENDDO
+
+ DO i=2,mmx-1
+ NST_sh(i,j)=TMP_sh(i,j) / 4.
+ ENDDO
+
+ ENDIF
+
+ ENDIF
+
+! filtering of "lakes" in topography
+! ----------------------------------
+
+c do m=1,1000000
+c
+c cpt=0 ; tmp=0
+c do i=2,mx-1 ; do j=2,my-1
+c
+c if(NSTsol(i,j)>=0) then
+c
+c cpt=0
+c if(NST_sh(i+1,j )<NST_sh(i,j)-1) cpt=cpt+1
+c if(NST_sh(i-1,j )<NST_sh(i,j)-1) cpt=cpt+1
+c if(NST_sh(i ,j+1)<NST_sh(i,j)-1) cpt=cpt+1
+c if(NST_sh(i ,j-1)<NST_sh(i,j)-1) cpt=cpt+1
+c
+c tmp1=min(NST_sh(i+1,j),NST_sh(i-1,j),
+c . NST_sh(i,j+1),NST_sh(i,j-1))
+c
+c if(cpt==0.and.tmp1>0) then
+c print *,m,i,j,NST_sh(i,j),NST_sh(i,j)
+c
+c NST_sh(i,j)=tmp1+2.
+c if(NSTsol(i,j)<=4) NST_sh(i,j)=tmp1+4.
+c tmp=tmp+1
+c endif
+c endif
+c enddo ; enddo
+c
+c if (tmp==0) goto 1001
+c
+c enddo
+c
+c1001 continue
+
+c call CF_READ2D("NST_sh.nc",'SH',1,mx,my, 1,NST_sh)
+c print *, "read of NST_sh.nc"
+
+
+ ENDIF
+
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+ RETURN
+ END
diff --git a/MAR/code_nestor/src/UPScor.f b/MAR/code_nestor/src/UPScor.f
new file mode 100644
index 0000000000000000000000000000000000000000..79a8934553bb2edf572a88fcbdf8611e656cdbdd
--- /dev/null
+++ b/MAR/code_nestor/src/UPScor.f
@@ -0,0 +1,217 @@
+C +-------------------------------------------------------------------+
+C | Subroutine UPScor 08/2004 NESTING |
+C +-------------------------------------------------------------------+
+C | |
+C | "Upscaling" from 250m CORINE land-cover data to MAR |
+C | |
+C | Output : |
+C | CORfrc(i,j,class Fraction of MAR mesh covered by type "class"|
+C | |
+C | Method : |
+C | MAR mesh is approximated by a quadrilateral in the input grid,|
+C | all points in this quadrilateral are counted in the fraction |
+C | Note: this is a fairly general upscaling technique; |
+C | some modest changes may provide accurate upscaling for other |
+C | fields. |
+C +-------------------------------------------------------------------+
+ SUBROUTINE UPScor (ainX, ainY, imx, imy, nclass,
+ . in_FID, inVNAM, out_X, out_Y, CORfrc)
+
+ IMPLICIT NONE
+
+
+C +---General variables
+C + -----------------
+
+ INCLUDE 'NSTdim.inc'
+ INCLUDE 'NetCDF.inc'
+
+ INTEGER VARSIZE
+ EXTERNAL VARSIZE
+
+C +---Arguments
+C + ---------------
+ INTEGER imx,imy, nclass, in_FID
+ CHARACTER(*) inVNAM
+ REAL ainX(imx), ainY(imy)
+ REAL out_X(0:mx,0:my), out_Y(0:mx,0:my)
+ REAL CORfrc(mx,my,nclass)
+
+C +---Local variables
+C + ---------------
+ INTEGER ii,jj,ki,kn,kc,Ierror,nsubFR,itmp
+ INTEGER iin,jin,iinL,iinH,jinL,jinH,jin1,jin2,idint
+ INTEGER idxsPt(2), icoVAL, corVID
+ INTEGER iP(4), jP(4)
+ REAL outPX(4), outPY(4)
+ REAL outTOP,outBOT
+ REAL outLFT,outRHT,pti(4)
+ REAL*8 RXin, RYin
+ REAL linY
+ REAL AAA,BBB,XXX,XX1,XX2,YY1,YY2,YMIN,YMAX
+ INTEGER meshFR(50)
+
+ IF(nclass.GT.50) THEN
+ STOP
+ ENDIF
+
+C Input grid resolution
+C (this simplifies the problem a bit, but you may generalize !)
+C + ---------------------
+ RXin = ainX(2)-ainX(1)
+ RYin = ainY(2)-ainY(1)
+
+C + Get NetCDF variable ID
+ itmp =VARSIZE(inVNAM)
+ Ierror=NF_INQ_VARID(in_FID, inVNAM(1:itmp), corVID)
+
+C + ===============================================================
+C MAIN LOOP : on output grid points
+ DO jj=1,my
+ DO ii=1,mx
+
+C Initialisations :
+ DO kc=1,nclass
+ CORfrc(ii,jj,kc) =0.0
+ meshFR(kc)=0
+ ENDDO
+ nsubfr=0
+
+C We work in an output mesh defined as:
+C 1 2
+C
+C 4 3 (quadrilateral)
+C
+C The position of the point are assumed to follow simple rules,
+C but a more general case may be implemented here...
+C (should search e.g. "the points which have
+C at least two under them..." to construct the quadrilateral)
+
+ iP(1)=ii-1
+ iP(2)=ii
+ iP(3)=ii
+ iP(4)=ii-1
+
+ jP(1)=jj
+ jP(2)=jj
+ jP(3)=jj-1
+ jP(4)=jj-1
+ DO ki=1,4
+ outPX(ki)=out_X(iP(ki),jP(ki))
+ outPY(ki)=out_Y(iP(ki),jP(ki))
+ ENDDO
+
+C Find first + end line pos. indexes in input grid (jinL,jinH)
+C + ------------------------------------------------------------
+
+ outTOP = max(outPY(1),outPY(2))
+ outBOT = min(outPY(4),outPY(3))
+
+ jin1 = 1 + FLOOR ( (outBOT - ainY(1) + 0.01D01) / RYin )
+ jin2 = 1 + FLOOR ( (outTOP - ainY(1) - 0.01D01) / RYin )
+ jinL = min(jin1,jin2) + 1 ! inside pts, no double counting
+ jinH = max(jin1,jin2)
+C This is because corine indexes are from N to S,
+C while corine coordinates are (appropriately) from S to N
+
+ IF(jinH.GT.imy.OR.jinL.LT.1)THEN
+ write(*,*)'UPScor: ERROR - NST dom out of CORINE grid'
+ ENDIF
+
+C + --------------------------=======----------------------------
+C Loop on lines in the input grid
+ DO jin= jinL,jinH
+ linY = ainY(jin)
+
+C + Search the intersections of output mesh / input lines
+C (4 segments of the output quadrilateral mesh)
+C -----------------------------------------------------
+ idint=0 ! index of the intersection found
+ DO ki=1,4
+ kn=mod(ki,4)+1
+ YY1=outPY(ki)
+ YY2=outPY(kn)
+ XX1=outPX(ki)
+ XX2=outPX(kn)
+ YMIN=min(YY1,YY2)
+ YMAX=max(YY1,YY2)
+ IF (YMIN.LE.linY.AND.linY.LE.YMAX.AND.YY2.NE.YY1) THEN
+ idint=idint+1
+ IF (XX2.EQ.XX1) THEN
+ pti(idint)=XX1
+ write(*,*) 'EQ pts'
+ ELSE
+ AAA=(YY2-YY1)/(XX2-XX1)
+ BBB= YY1- AAA*XX1
+ XXX=(linY - BBB) / AAA
+ pti(idint)=XXX
+ ENDIF
+ ENDIF
+ ENDDO
+ outLFT= min(pti(1),pti(2))
+ outRHT= max(pti(1),pti(2))
+ IF(idint.NE.2)THEN
+ IF(idint.LT.2)THEN
+ write(*,*) 'UPScor : internal error;'
+ write(*,*) '(number of line intersections: ',idint,')'
+ write(*,*) (outPX(ki),outPY(ki),ki=1,4)
+ write(*,*) linY,jin1,jin2,jin
+ write(*,*) ainY(jin-1),ainY(jin),ainY(jin+1)
+ STOP
+ ELSE
+ outLFT= min(outLFT,pti(3))
+ outRHT= max(outRHT,pti(3))
+ IF(idint.GT.3)THEN
+ write(*,*) 'UPScor : WARNING - something strange'
+ write(*,*) '(4 intersect. = 2 peaks ?', idint
+ write(*,*) XX1,YY1,XX2,YY2
+ write(*,*) linY,jin1,jin2,jin
+ write(*,*) 'Please check UPScor / CORINE'
+ ENDIF
+ ENDIF
+ ENDIF
+
+C Find first + end index along line in input grid (iinL,iinH)
+C + -----------------------------------------------------------
+ iinL = 2 + FLOOR ( (outLFT - ainX(1)) / RXin )
+ iinH = 1 + FLOOR ( (outRHT - ainX(1)) / RXin )
+
+C Loop on points in the input grid line
+C -------------------------------------
+ DO iin= iinL,iinH
+
+C Read data and update class fractions
+C ------------------------------------
+ idxsPt(1)=iin
+ idxsPt(2)=jin
+ Ierror=NF_GET_VAR1_INT(in_FID, corVID, idxsPt, kc)
+ IF (Ierror.NE.0) THEN
+ write(*,*) 'UPScor: CORINE reading error'
+ write(*,*) ' Req point was ',iin,jin
+ ENDIF
+ IF (kc.GT.nclass) THEN
+ write(*,*) 'Error: CORINE nclass / file (UPScor)'
+ write(*,*) 'i,j,read val,nclass: ',iin,jin,kc,nclass
+ STOP
+ ENDIF
+ nsubFR =nsubFR+1
+ meshFR(kc) =meshFR(kc)+1
+
+ ENDDO
+ ENDDO
+C Loop on lines in the input grid (END)
+C + --------------------------=======----------------------------
+
+ DO kc=1,nclass
+ CORfrc(ii,jj,kc) = FLOAT(meshFR(kc)) / FLOAT(nsubFR)
+ ENDDO
+
+
+C MAIN LOOP : on output grid points (END)
+ ENDDO
+ ENDDO
+C + ===============================================================
+
+
+ RETURN
+ END
diff --git a/MAR/code_nestor/src/USRann.f b/MAR/code_nestor/src/USRann.f
new file mode 100644
index 0000000000000000000000000000000000000000..f2b0f095ea11d0b6626d76ab986813ac8eb74005
--- /dev/null
+++ b/MAR/code_nestor/src/USRann.f
@@ -0,0 +1,635 @@
+C +-------------------------------------------------------------------+
+C | Subroutine USRann June 03 NESTING |
+C +-------------------------------------------------------------------+
+C | USRant adapt NESTOR to Antarctic region |
+C | |
+C | Input : - subnam : Name of the subroutine |
+C | ^^^^^^^ where USRann is called |
+C | |
+C | Maintainer : Hubert Gallee |
+C | ^^^^^^^^^^^^ |
+C | |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE USRann (subnam)
+
+
+ IMPLICIT NONE
+
+C +---General variables
+C + -----------------
+
+ INCLUDE 'NSTdim.inc'
+ INCLUDE 'NSTvar.inc'
+ INCLUDE 'NESTOR.inc'
+ INCLUDE 'LSCvar.inc'
+
+C +---local variables
+C + ---------------
+
+ CHARACTER*6 subnam
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+C +---Topography for Antarctic
+C + ========================
+
+ IF (subnam.eq.'NSIDC ') THEN
+
+C + ******
+! CALL GTOP30
+C + ******
+
+C + ******
+ CALL A_TOPO
+C + ******
+
+ END IF
+
+
+ END SUBROUTINE
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+C +-------------------------------------------------------------------+
+C | Subroutine A_TOPO 19 June 2009 NESTING |
+C | ANTARCTIC TOPOGRAPHY specific Assimilation |
+C +-------------------------------------------------------------------+
+C | |
+C | Input : NST__x : longitude (degree) of the NST grid |
+C | ^^^^^^^ NST__y : latitude (degree) of the NST grid |
+C | |
+C | Output: NST_sh: surface elevation |
+C | ^^^^^^^ NSTsol: land (4) / sea (1) mask |
+C | |
+C | Method: Divide each nested Grid Cell in elementary Meshes |
+C | ^^^^^^^ much small than either the nested or the DTM Mesh |
+C | Compute geographic Coordinates of each elementary Mesh |
+C | Compute Distance of this Mesh to 4 closest DTM Meshes |
+C | Compute Height of this Mesh by kriging |
+C | Nested Grid Cell Height is the Average |
+C | of the elementary Meshes Heights |
+C | |
+C | DATA Source: Radarsat Antarctic Mapping Project Digital |
+C | ^^^^^^^^^^^^ Digital Elevation Model Version 2 |
+C | ftp site : sidads.colorado.edu |
+C | directory: /pub/DATASETS/RAMP/DEM_V2/1KM/ASCII |
+C | file : ramp1kmdem_wgsosu_v2.txt.gz |
+C | |
+C | Reference: Liu, H., K. Jezek, B. Li, and Z. Zhao. 2001. |
+C | ^^^^^^^^^^ Radarsat Antarctic Mapping Project |
+C | Digital Elevation Model Version 2. |
+C | Boulder, CO: National Snow and Ice Data Center. |
+C | Digital media. |
+C | |
+C | Modifications: |
+C | ^^^^^^^^^^^^^^ |
+C | nico: 19/07/2005 |
+C | little change in the mask calculation (NSTsol) to |
+C | allow the coupling with the ocean model OPA. |
+C | hub: 19/06/2009 |
+C | interpolation made on the stereographic plane |
+C | not on the sphere |
+C | |
+C +-------------------------------------------------------------------+
+
+
+ SUBROUTINE A_TOPO
+
+
+ IMPLICIT NONE
+
+
+C + General and local variables
+C + ---------------------------
+
+ INCLUDE 'NSTdim.inc'
+ INCLUDE 'NSTvar.inc'
+ INCLUDE 'NESTOR.inc'
+ INCLUDE 'MARvar.inc'
+ INCLUDE 'LOCfil.inc'
+ INCLUDE 'NetCDF.inc'
+ INCLUDE 'for2nc.inc'
+ INCLUDE 'for2cdf.inc'
+
+ LOGICAL OUTrmp,ROTdom
+
+ character*20 OROcdf
+ character*31 x0unit,y0unit,z0unit,w0unit
+ character*90 Title0
+
+ integer ID_cdf,ID__nc,idx
+
+ REAL aux_z0(mx,my)
+
+ INTEGER nxdata,nydata ,nwdata,nndata
+ PARAMETER(nxdata=13670204)
+ INTEGER ii ,jj ,i,j,nn
+ REAL x_RAMP(mx,my),y_RAMP(mx,my)
+
+ REAL*4 ANT_sh
+ REAL*4 ANTlat
+ REAL*4 ANTlon
+ REAL xdista ,ydista ,ddista
+ REAL xdisto ,ydisto ,TruRCL
+ REAL xx_min ,yy_min
+ REAL xx_max ,yy_max
+
+ REAL pi ,degrad ,t_grad ,t__rad
+ REAL pidemi ,earthr
+ INTEGER inx ,jny
+ INTEGER in ,jn
+ INTEGER ir ,jr
+ INTEGER i__rot ,j__rot
+
+ INTEGER imxx ,jmyy
+ PARAMETER(imxx=100,jmyy=100)
+ REAL ddxxi ,ddxxj
+ REAL xx( imxx, jmyy),yy( imxx, jmyy)
+ REAL xxii ,yyii
+ REAL x0(-imxx:imxx,-jmyy:jmyy),y0(-imxx:imxx,-jmyy:jmyy)
+ REAL x1(-imxx:imxx,-jmyy:jmyy),y1(-imxx:imxx,-jmyy:jmyy)
+ REAL hh(imxx,jmyy)
+ REAL x__A ,y__A
+ REAL sinA ,cosA ,hypA
+
+
+ DATA OUTrmp/.true. / ! RAMP OUTPUT switch
+ DATA ROTdom/.false. / ! Rotation switch
+ DATA earthr/6396.990e3/ ! Earth Radius
+ DATA t_grad/ 360. / !
+c #DDUDATA i__rot/ 210 / ! DDU closest MAR grid pt
+c #DDUDATA j__rot/ 40 / ! DDU closest MAR grid pt
+ DATA i__rot/ 217 / ! PrE closest MAR grid pt
+ DATA j__rot/ 233 / ! PrE closest MAR grid pt
+
+
+C + INITIALIZATION
+C + ==============
+
+ pi = acos( -1.0d0)
+ pidemi = pi * 0.5d0
+ degrad = pi / 180.0d0
+ t__rad = pi * 2.0d0
+ nndata = 0
+
+ DO j=1,ny
+ DO i=1,nx
+ SolTyp(i,j) = 1.
+ ENDDO
+ ENDDO
+
+
+C + TOPOGRAPHY INPUT (already interpolated)
+C + ================
+
+ IF (TOP30.eq.'nsid') THEN
+ write(6,*) 'A_TOPO: INPUT File rampxkmdem_wgsosu_v2.dat OPENING'
+ open(unit=1,status='unknown',file='rampxkmdem_wgsosu_v2.dat')
+ rewind 1
+ DO j=1,my
+ DO i=1,mx
+ read(1,100) NST_sh(i,j),NSTsol(i,j),NSTzor(i,j)
+ 100 format(e15.6,i15,e15.6)
+ END DO
+ END DO
+ read(1,101) TruRCL
+ 101 format(e15.6)
+ IF (TruRCL.NE.NSTrcl) THEN
+ write(6,102)TruRCL,NSTrcl
+ 102 format(' The relative colatitude',f6.1,
+ . ' of this TOPO is NOT that (',f6.1,') what is requested')
+ STOP '#¹@#&!! Relative Colatitude is inconsistent'
+ END IF
+ write(6,*) 'A_TOPO: INPUT File rampxkmdem_wgsosu_v2.dat IN'
+ close(unit=1)
+ ELSE
+
+
+C + TOPOGRAPHY INPUT (to be interpolated, )
+C + ================
+
+ write(6,*) 'A_TOPO: INPUT File ramp1kmdem_wgsosu_v2.bin OPENING'
+ write(6,*) ' '
+ write(6,*) ' NST_dx = ',NST_dx
+ write(6,*) ' '
+ open(unit=1,status='old',file='ramp1kmdem_wgsosu_v2.bin',
+ . form='unformatted')
+ rewind 1
+
+ ii= 0
+ xx_min = 1.e9
+ xx_max =-1.e9
+ yy_min = 1.e9
+ yy_max =-1.e9
+ 1001 CONTINUE
+
+c #WR IF (mod(ii,10).EQ.0) write(6,6000)
+ 6000 format(12x,8x,'Lat',12x,'Lon',14x,'z',
+ . 14x,'d',14x,'x',13x,'dx',14x,'y',13x,'dy')
+
+ ii=1+ii
+c #DO DO ii=1,nxdata
+ read(1,end=1000) ANTlat,ANTlon,ANT_sh
+
+
+C + Cartesian coordinates of the INPUT TOPOGRAPHY (polar stereographic
+C + --------------------------------------------- reference plane: 71°S)
+
+ ddista = earthr *(sin( 71.d0 *degrad) + 1.d0)
+ . * tan((45.d0+ANTlat*0.5d0)*degrad)
+ xdista = ddista * cos((90.d0-ANTlon) *degrad)
+ ydista = ddista * sin((90.d0-ANTlon) *degrad)
+
+c #WR IF (ii.GT.1)
+c #WR. write(6,6001) ii,ANTlat,ANTlon,ANT_sh,1.e-3*ddista
+c #WR. ,1.e-3*xdista,1.e-3*(xdista-xdisto)
+c #WR. ,1.e-3*ydista,1.e-3*(ydista-ydisto)
+ 6001 format(' TEST:',i6,3f15.9,5f15.3)
+
+c #WR xdisto = xdista
+c #WR ydisto = ydista
+
+c #WR IF (ii.EQ.50) STOP "Arrêt TEST"
+
+ xx_min = min(xdista,xx_min)
+ yy_min = min(ydista,yy_min)
+ xx_max = max(xdista,xx_max)
+ yy_max = max(ydista,yy_max)
+
+
+C + Index Coordinates
+C + ---------------------
+
+ i = xdista *1.e-3 + 2750
+ j = ydista *1.e-3 + 2250
+ Latitu(i,j)= ANTlat
+ Longit(i,j)= ANTlon
+ OroOBS(i,j)= ANT_sh
+ SolTyp(i,j)= 3.
+
+
+ GO TO 1001
+ 1000 CONTINUE
+
+c #DO END DO
+ nwdata = ii
+ close(unit=1)
+
+
+C + OUTPUT
+C + ------
+
+ IF (OUTrmp) THEN
+ x0unit = 'km'
+ y0unit = 'km'
+ z0unit = 'm'
+ w0unit = '-'
+ OROcdf = 'RAntMP_1_km_DEM.cdf'
+ Title0( 1:40) = 'Radarsat Antarctic Mapping Project 1 km '
+ Title0(41:80) = 'DEM, version 2, NSIDC, Liu et al., 2001 '
+C + 1234567890123456789012345678901234567890
+
+ DO i=1,nx
+ x_axis(i) = i - 2750.
+ ENDDO
+
+ DO j=1,ny
+ y_axis(j) = j - 2250.
+ ENDDO
+
+C + *******
+ call for2cdf(1,1,ID_cdf,2001,12,31,0,0,0
+ . , x0unit , y0unit , z0unit , w0unit
+ . ,' ',' ',' ',' ',' '
+ . ,' ',' ',' ',' ',' '
+ . ,' ',' ',' ',' ',' '
+ . ,' ',' ',' ',' ',' '
+ . , OROcdf ,Title0,'ANToro.dat')
+C + *******
+
+ END IF
+
+ write(6,6011) xx_min*1.e-3
+ 6011 format( ' xx_min = ',f15.3)
+ write(6,6012) yy_min*1.e-3
+ 6012 format( ' yy_min = ',f15.3)
+ write(6,6021) xx_max*1.e-3
+ 6021 format( ' xx_max = ',f15.3)
+ write(6,6022) yy_max*1.e-3
+ 6022 format( ' yy_max = ',f15.3)
+ write(6,*) 'A_TOPO: INPUT File ramp1kmdem_wgsosu_v2.bin IN'
+ write(6,*) ' Nb DATA: ',nwdata
+ write(6,*) ' '
+
+
+C + Antarctic Topography in MAR
+C + ===========================
+
+ idx = NST_dx*0.5e-3 ! 1/2 maille, passage m --> km
+ inx = idx*2+1
+ jny = idx*2+1
+ ddxxi = 1.d0
+ ddxxj = 1.d0
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ DO j=1,my ! Loop on NST grid points
+ DO i=1,mx
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C + Cartesian coordinates of MAR/ANTAR TOPOGRAPHY (polar stereographic
+C + --------------------------------------------- reference plane: 71°S)
+
+ IF (NST__y(i,j).GE.0.) THEN
+ write(6,6003) NST__x(i,j),NST__y(i,j)
+ 6003 format(/,' *** LON, LAT =',2f12.4,' ***',/,1x)
+ STOP 'Latitude: empty data'
+ END IF
+
+ ddista = earthr *(sin( 71.d0 *degrad) + 1.d0)
+ . * tan((45.d0+NST__y(i,j)*0.5d0)*degrad)
+ xdista = ddista * cos((90.d0-NST__x(i,j)) *degrad)
+ ydista = ddista * sin((90.d0-NST__x(i,j)) *degrad)
+
+ x_RAMP(i,j)= xdista
+ y_RAMP(i,j)= ydista
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ ENDDO ! Loop on NST grid points
+ ENDDO
+
+ DO j=1,my ! Loop on NST grid points
+ DO i=1,mx
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ IF (NST__y(i,j).LT.-60.00) THEN ! South of Drake Passage
+
+
+C + Interpolation/Average
+C + ---------------------
+
+ ii = x_RAMP(i,j) *1.e-3 + 2750
+ jj = y_RAMP(i,j) *1.e-3 + 2250
+
+ NST_sh(i,j) = 0.
+ nydata = 0
+
+C + Rotation
+C + ~~~~~~~~
+ IF (ROTdom) THEN
+ IF (i.LT.mx) THEN
+ y__A = y_RAMP(i+1,j)-y_RAMP(i ,j)
+ x__A = x_RAMP(i+1,j)-x_RAMP(i ,j)
+ ELSE
+ y__A = y_RAMP(i ,j)-y_RAMP(i-1,j)
+ x__A = x_RAMP(i ,j)-x_RAMP(i-1,j)
+ END IF
+
+ hypA = sqrt(x__A*x__A + y__A*y__A)
+ cosA = x__A/hypA
+ sinA = y__A/hypA
+
+ DO jr=-idx,idx
+ DO ir=-idx,idx
+ x0(ir,jr) = ir
+ y0(ir,jr) = jr
+ ENDDO
+ ENDDO
+
+ DO jr=-idx,idx
+ DO ir=-idx,idx
+ x1(ir,jr) = cosA * x0(ir,jr) - sinA * y0(ir,jr)
+ y1(ir,jr) = sinA * x0(ir,jr) + cosA * y0(ir,jr)
+ ENDDO
+ ENDDO
+
+C + OUTPUT for VERIFICATION
+C + ~~~~~~~~~~~~~~~~~~~~~~~
+ IF (i.EQ.i__rot .AND. j.EQ.j__rot) THEN
+ OROcdf = 'MARdom_1_km_VER.JNL'
+ write(OROcdf(7:9),'(i3)') idx *2
+ IF (OROcdf(7:7).EQ.' ') OROcdf(7:7) = '_'
+ IF (OROcdf(8:8).EQ.' ') OROcdf(8:8) = '_'
+
+ open(unit=2,status='unknown',file=OROcdf)
+ rewind 2
+ END IF
+
+ DO jr=-idx,idx
+ DO ir=-idx,idx
+ in = x1(ir,jr) + ii
+ jn = y1(ir,jr) + jj
+ xx(ir +idx+1,jr +idx+1) = in
+ yy(ir +idx+1,jr +idx+1) = jn
+ IF (in.GT.0.AND.in.LE.nx .AND. jn.GT.0.AND.jn.LE.ny) THEN
+ hh(ir +idx+1,jr +idx+1) = OroOBS(in,jn)
+ ELSE
+ hh(ir +idx+1,jr +idx+1) = 0.
+ END IF
+
+ NST_sh(i,j) = NST_sh(i,j) + hh(ir +idx+1,jr +idx+1)
+ nydata = nydata + 1
+
+C + OUTPUT for VERIFICATION
+C + ~~~~~~~~~~~~~~~~~~~~~~~
+ IF (i.EQ.i__rot .AND. j.EQ.j__rot) THEN
+ write(2,21) x_RAMP(i,j)*1.e-3+x1(ir,jr)
+ . ,y_RAMP(i,j)*1.e-3+y1(ir,jr)
+ 21 format('LABEL ',2(f8.0,','),' 0,0,.08 @P5+')
+ END IF
+ ENDDO
+ ENDDO
+ IF (i.EQ.i__rot .AND. j.EQ.j__rot) THEN
+ write(2,22) x_RAMP(i ,j ) *1.e-3,y_RAMP(i ,j ) *1.e-3
+ . ,x_RAMP(i-1,j ) *1.e-3,y_RAMP(i-1,j ) *1.e-3
+ . ,x_RAMP(i ,j-1) *1.e-3,y_RAMP(i ,j-1) *1.e-3
+ . ,x_RAMP(i-1,j-1) *1.e-3,y_RAMP(i-1,j-1) *1.e-3
+ 22 format('LABEL ',2(f8.0,','),' 0,0,.15 @P7x'
+ . , /,'LABEL ',2(f8.0,','),' 0,0,.12 @P7x'
+ . ,2(/,'LABEL ',2(f8.0,','),' 0,0,.10 @P7x'))
+
+ close(unit=2)
+ END IF
+
+C + No Rotation
+C + ~~~~~~~~~~~
+ ELSE
+ DO jn=jj-idx,jj+idx
+ DO in=ii-idx,ii+idx
+ xx(in-ii+idx+1,jn-jj+idx+1) = in
+ yy(in-ii+idx+1,jn-jj+idx+1) = jn
+ IF (in.GT.0.AND.in.LE.nx .AND. jn.GT.0.AND.jn.LE.ny) THEN
+ hh(in-ii+idx+1,jn-jj+idx+1) = OroOBS(in,jn)
+ ELSE
+ hh(in-ii+idx+1,jn-jj+idx+1) = 0.
+ END IF
+
+ NST_sh(i,j) = NST_sh(i,j) + hh(in-ii+idx+1,jn-jj+idx+1)
+ nydata = nydata + 1
+ ENDDO
+ ENDDO
+ END IF
+
+C + Nested Grid Cell Average
+C + ~~~~~~~~~~~~~~~~~~~~~~~~
+ NST_sh(i,j) = NST_sh(i,j) / nydata
+c #WR write(6,6004) NST__x(i,j),NST__y(i,j),NST_sh(i,j),ii,jj
+ 6004 format(3f15.3,2i6)
+
+C + No Topography below Sea Level...
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ IF (NST_sh(i,j).lt.0.0) THEN
+ NST_sh(i,j) = 0.0
+ ENDIF
+
+C + Orography Roughness
+C + ~~~~~~~~~~~~~~~~~~~
+
+C + ******
+ call z_orog(inx ,jny ,xx,yy,ddxxi,hh,
+ . NST_dx,NST_sh(i,j),NSTsol(i,j),NSTzor(i,j))
+C + ******
+
+c #WR IF (NSTzor(i,j).GT.0.)
+c #WR. write(6,*) 'Before smooth ',i,j,NSTzor(i,j)
+
+C + Distinction between land and sea (further refined)
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ IF (NST_sh(i,j).lt.0.01) THEN
+ NSTsol(i,j) = 1
+ ELSE
+ NSTsol(i,j) = 3
+ ENDIF
+
+
+ ENDIF ! South of Drake Passage
+
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ ENDDO ! Loop on NST grid points
+ ENDDO
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C + OUTPUT (ASCII)
+C + ------
+
+ write(6,*)'A_TOPO: OUTPUT File rampxkmdem_wgsosu_v2.dat OPENING'
+ open(unit=2,status='new',file='rampxkmdem_wgsosu_v2.dat')
+ rewind 2
+
+C + nico: Fill in of the bays (sea mesh with 3 neighbouring land mesh )
+C + (the ocean model OPA needs this to allow exchanges between meshes)
+
+C ---------------------------------------------------------------------
+ DO nn=1,2 !the fill-in is processed 2 times
+ DO j=2,my-1
+ DO i=2,mx-1
+ IF((NSTsol(i,j) .ne.3) .AND.
+ . ((NSTsol(i-1,j)+NSTsol(i+1,j)
+ . +NSTsol(i,j-1)+NSTsol(i,j+1)).ge.9)) THEN
+ NSTsol(i,j)=3 !the detected bay is filled in
+ write(6,*) i,j,':this bay is filled in-----------------'
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+C ---------------------------------------------------------------------
+
+
+ DO j=2,my-1
+ DO i=2,mx-1
+ aux_z0(i,j) = 0.0625
+ . *( NSTzor(i+1,j-1) + 2.*NSTzor(i+1,j) + NSTzor(i+1,j+1)
+ . + 2.*NSTzor(i ,j-1) + 4.*NSTzor(i ,j) + 2.*NSTzor(i ,j+1)
+ . + NSTzor(i-1,j-1) + 2.*NSTzor(i-1,j) + NSTzor(i-1,j+1))
+c #WR IF (aux_z0(i,j).GT.0.)
+c #WR. write(6,*) 'After smooth ',i,j,aux_z0(i,j)
+ ENDDO
+ ENDDO
+
+ DO j=1,my
+ DO i=1,mx
+ NSTzor(i,j) = aux_z0(i,j)
+ write(2,100) NST_sh(i,j),NSTsol(i,j),NSTzor(i,j)
+c #WR IF (NSTzor(i,j).GT.0.)
+c #WR. write(6,*) 'After smooth ',i,j,NSTzor(i,j)
+
+ END DO
+ END DO
+ write(2,201) NSTrcl
+ 201 format(e15.6,' is the relative colatitude',
+ . ' where the distances on the projection plane',
+ . ' are true')
+
+ close(unit=2)
+ write(6,*)'A_TOPO: OUTPUT File rampxkmdem_wgsosu_v2.dat OUT'
+ write(6,*)' '
+ write(6,*)' '
+
+
+C + OUTPUT (netcdf)
+C + ------
+
+ x0unit = 'km'
+ y0unit = 'km'
+ z0unit = 'm'
+ w0unit = '-'
+ OROcdf = 'MARdom_1_km_DEM.cdf'
+ write(OROcdf(8:9),'(i2)') idx *2
+ IF (OROcdf(8:8).EQ.' ') OROcdf(8:8) = '_'
+ Title0( 1:40) = 'MAR Antarctic Topography from RAMP 1 km '
+ Title0(41:80) = 'DEM, version 2, NSIDC, Liu et al., 2001 '
+C + 1234567890123456789012345678901234567890
+
+ DO i=1,mx
+ x__MAR(i) = NSTgdx(i)
+ ENDDO
+
+ DO j=1,my
+ y__MAR(j) = NSTgdy(j)
+ ENDDO
+
+ DO j=1,my
+ DO i=1,mx
+ LonMAR(i,j) = NST__x(i,j)
+ LatMAR(i,j) = NST__y(i,j)
+ OroMAR(i,j) = NST_sh(i,j)
+ Oro_z0(i,j) = NSTzor(i,j)
+ SolMAR(i,j) = NSTsol(i,j)
+ ENDDO
+ ENDDO
+
+C + ******
+ call for2nc(1,1,ID__nc,2001,12,31,0,0,0
+ . , x0unit , y0unit , z0unit , w0unit
+ . ,' ',' ',' ',' ',' '
+ . ,' ',' ',' ',' ',' '
+ . ,' ',' ',' ',' ',' '
+ . ,' ',' ',' ',' ',' '
+ . , OROcdf ,Title0,'MARoro.dat')
+C + ******
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+C + AWS MAR-Coordinates
+C + ===================
+
+C + ******
+ call AWSgeo(x_RAMP,y_RAMP)
+C + ******
+
+c #WR STOP "Arret TEST"
+
+ END IF
+
+ RETURN
+ END
diff --git a/MAR/code_nestor/src/USRant.f90 b/MAR/code_nestor/src/USRant.f90
new file mode 100644
index 0000000000000000000000000000000000000000..809e0f2953e67bfc36526e7ed036ffa67845006c
--- /dev/null
+++ b/MAR/code_nestor/src/USRant.f90
@@ -0,0 +1,996 @@
+!-------------------------------------------------------------------+
+! subroutine USRant June 2003 (HG) Oct 2014 (CA) NESTING |
+!-------------------------------------------------------------------+
+! USRant adapt NESTOR to Antarctic region |
+! See bellow a new version (AntTOPO) with Bamber (2009) |
+! f77 --> f90 by H.Gallee, 25-Apr-2017 |
+! |
+! Input : - subnam : Name of the subroutine |
+! ^^^^^^^ where USRant is called |
+! |
+! Maintainer : Hubert Gallée, Cécile Agosta |
+! ^^^^^^^^^^^^ |
+! |
+!-------------------------------------------------------------------+
+
+ subroutine USRant(subnam)
+
+
+ implicit none
+
+
+!-General variables
+! -----------------
+
+ include 'NSTdim.inc'
+ include 'NSTvar.inc'
+ include 'NESTOR.inc'
+ include 'LSCvar.inc'
+
+!-local variables
+! ---------------
+
+ CHARACTER*6 subnam
+
+
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+!-Topography for Antarctic
+! ========================
+print *, subnam
+
+ if (subnam.eq.'NESTOR') call ANTOPO
+
+ if (subnam.eq.'Bamber' .or. subnam.eq.'bedmap' .or. subnam .eq. 'bedmac') then
+ print *, "imhere"
+ call AntTOPO(subnam) !+ CA +!
+ endif
+
+ if (subnam.eq.'Racmo2') call AntRACMO !+ CA +!
+
+ END subroutine USRant
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+!-------------------------------------------------------------------+
+ subroutine AntRACMO
+!-------------------------------------------------------------------+
+
+!-Netcdf specifications
+! ---------------------
+ include 'NetCDF.inc'
+
+!-NST variables
+! -------------
+
+ include 'NSTdim.inc'
+ include 'NSTvar.inc'
+ include 'NESTOR.inc'
+ include 'LOCfil.inc'
+
+ real NST_dh
+
+!.Reading dem file
+ integer fID
+ character*80 dem_file
+ integer dem_mx,dem_my
+ parameter(dem_mx=110,dem_my=91)
+ integer dem_xmin,dem_ymin,dem_xmax,dem_ymax
+ parameter(dem_xmin=-2600,dem_ymin=-2200)
+ parameter(dem_xmax= 2850,dem_ymax= 2300)
+ character*80 var_units
+ real dem_sh(dem_mx,dem_mx),dem_msk(dem_mx,dem_mx)
+
+ integer i,j,ii,jj,m
+
+ NST_dh = NST_dx/1000.
+
+ write(6,*) 'Topography : RACMO-27 interpolated on 50km MAR grid'
+ write(6,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+
+ dem_file = trim(PFXdir)//'AntTOPO/RACMO-ANT27onMAR-50km.sh.nc'
+ write(6,*) "> Read ", dem_file," ..."
+ write(6,*)
+
+ CALL UNropen (dem_file,fID,title)
+ CALL UNsread(fID,'sh',1,1,1,1, &
+ & dem_mx,dem_my,1, &
+ & var_units,dem_sh)
+
+ CALL UNsread(fID,'msk',1,1,1,1, &
+ & dem_mx,dem_my,1, &
+ & var_units,dem_msk)
+
+ do j=1,my
+ do i=1,mx
+ if ( NSTgdx(i).ge.dem_xmin .and. NSTgdy(j).ge.dem_ymin &
+ & .and.NSTgdx(i).le.dem_xmax .and. NSTgdy(j).le.dem_ymax) then
+ ii = int((NSTgdx(i)-dem_xmin)/NST_dh) +1
+ jj = int((NSTgdy(j)-dem_ymin)/NST_dh) +1
+! print*,i,j,ii,jj
+ NST_sh(i,j)=dem_sh (ii,jj)
+ NSTice(i,j)=dem_msk(ii,jj)*100.
+ else
+ NST_sh(i,j)=0
+ NSTice(i,j)=0.
+ endif
+ ! +---No atmosphere below sea level
+ ! + -----------------------------
+ NST_sh(i,j) = max(NST_sh(i,j),0.)
+ if (NSTice(i,j).gt.50.) then
+ NSTsol(i,j) = 3
+ else
+ NSTsol(i,j) = 1
+ endif
+ enddo
+ enddo
+
+ end subroutine AntRACMO
+!-------------------------------------------------------------------+
+
+
+!-------------------------------------------------------------------+
+! subroutine ANTOPO October 2002 NESTING |
+! ANTARTIC TOPOGRAPHY specific Assimilation |
+!-------------------------------------------------------------------+
+! |
+! Input : NST__x : longitude (degree) of the NST grid |
+! ^^^^^^^ NST__y : latitude (degree) of the NST grid |
+! |
+! Output: NST_sh: surface elevation |
+! ^^^^^^^ NSTsol: land (4) / sea (1) mask |
+! |
+! Method: Divide each nested Grid Cell in elementary Meshes |
+! ^^^^^^^ much small than either the nested or the DTM Mesh |
+! Compute geographic Coordinates of each elementary Mesh |
+! Compute Distance of this Mesh to 4 closest DTM Meshes |
+! Compute Height of this Mesh by kriging |
+! Nested Grid Cell Height is the Average |
+! of the elementary Meshes Heights |
+! |
+! DATA Source: Radarsat Antarctic Mapping Project Digital |
+! ^^^^^^^^^^^^ Digital Elevation Model Version 2 |
+! ftp site : sidads.colorado.edu |
+! directory: /pub/DATASETS/RAMP/DEM_V2/1KM/ASCII |
+! file : ramp1kmdem_wgsosu_v2.txt.gz |
+! Reference: Liu, H., K. Jezek, B. Li, and Z. Zhao. 2001. |
+! ^^^^^^^^^^ Radarsat Antarctic Mapping Project |
+! Digital Elevation Model Version 2. |
+! Boulder, CO: National Snow and Ice Data Center. |
+! Digital media. |
+! |
+!-------------------------------------------------------------------+
+
+
+ subroutine ANTOPO
+
+
+ implicit none
+
+
+!-General and local variables
+! ---------------------------
+
+ include 'NSTdim.inc'
+ include 'NSTvar.inc'
+ include 'NESTOR.inc'
+ include 'MARvar.inc'
+ include 'LOCfil.inc'
+ include 'NetCDF.inc'
+
+ INTEGER nxdata,nydata ,nwdata,nndata
+!HG PARAMETER(nxdata=13670204)
+ INTEGER ii,i,j
+
+!HGal--v
+!HG REAL ANT_sh(nxdata)
+!HG REAL ANTlat(nxdata),ANTlon(nxdata)
+
+ REAL, allocatable :: ANT_sh(:)
+ REAL, allocatable :: ANTlat(:) ,ANTlon(:)
+!HGal--^
+
+ REAL LOC_sh(100000),ddxx ,ddll ,dd_min
+ REAL LOC__x(100000),LOC__y(100000)
+
+ REAL pi ,degrad ,t_grad ,t__rad
+ REAL phi ,angl
+ REAL x_st_i ,y_st_j ,x_st_n ,y_st_n
+ REAL x_st_d ,y_st_d
+ REAL di_lon ,di_lat ,dj_lon ,dj_lat
+ REAL inilon ,inilat
+ REAL curlon ,curlat ,earthr
+ REAL minLON ,minLAT ,difLON ,difLAT
+ INTEGER inx ,jny
+ INTEGER in ,jn
+
+ LOGICAL dd00
+ INTEGER nn ,iinn(4) ,jjnn(4) ,n0
+ REAL x0 ,y0 ,ddxxi ,ddxxj
+ REAL xx ,yy ,xxii ,yyii
+ REAL dd ,ddnn(4) ,hh
+
+
+ DATA earthr/6371.e3/ ! Earth Radius
+ DATA t_grad/ 360. / !
+
+
+ pi = acos( -1.)
+ degrad = pi / 180.
+ t__rad = pi * 2.
+ nndata = 0
+
+!HGal--v
+ nxdata = 13670204
+ allocate (ANT_sh(nxdata))
+ allocate (ANTlat(nxdata))
+ allocate (ANTlon(nxdata))
+!HGal--^
+
+
+!-INPUT
+! -----
+
+ if (TOP30.eq.'a ') THEN
+ write(6,*) 'ANTOPO: INPUT File rampxkmdem_wgsosu_v2.dat openING'
+ open (unit=1,status='old',file='rampxkmdem_wgsosu_v2.dat')
+ rewind 1
+ DO j=1,my
+ DO i=1,mx
+ read(1,100) NST_sh(i,j),NSTsol(i,j)
+ 100 format(e15.6,i15)
+ END DO
+ END DO
+ write(6,*) 'ANTOPO: INPUT File rampxkmdem_wgsosu_v2.dat IN'
+ close(unit=1)
+ ELSE
+ write(6,*) 'ANTOPO: INPUT File ramp1kmdem_wgsosu_v2.bin openING'
+ open (unit=1,status='old',file='ramp1kmdem_wgsosu_v2.bin', &
+ & form='unformatted')
+ rewind 1
+ ii= 0
+ 1001 CONTINUE
+ ii=1+ii
+! #DO DO ii=1,nxdata
+ read(1,end=1000) ANTlat(ii),ANTlon(ii),ANT_sh(ii)
+ GO TO 1001
+ 1000 CONTINUE
+! #DO END DO
+ nwdata = ii
+ close(unit=1)
+ write(6,*) 'ANTOPO: INPUT File ramp1kmdem_wgsosu_v2.bin IN'
+ write(6,*) ' Nb DATA: ',nwdata
+ write(6,*) ' '
+
+
+!-Finest Resolution
+! -----------------
+
+ ddll= abs(NST__x(2,2)-NST__x(2,1))
+ if (ddll .GT. t_grad) &
+ & ddll=ddll-t_grad
+ ddxx = &
+ & ((ddll*cos(NST__y(2,2)*degrad )*degrad)**2 &
+ & +( abs(NST__y(2,2)-NST__y(2,1))*degrad)**2)
+ ddxx = sqrt(ddxx) *earthr
+ inx = ddxx *1.e-3
+ jny = ddxx *1.e-3
+ write(6,600) ddxx *1.e-3,inx
+ 600 format(8x,'dx =',f9.3,'km inx =',i6)
+
+
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ DO j=1,my ! Loop on NST grid points
+ DO i=1,mx
+
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+!-Interpolation/Average
+! ---------------------
+ ddll = earthr * cos(NST__y(i,j)*degrad)
+ angl = 0.5*pi - NST__x(i,j)*degrad
+ x_st_i = ddll * cos(angl)
+ y_st_j = ddll * sin(angl)
+
+
+!-Interpolation/Average
+! ---------------------
+
+!-Relevant Points
+! ~~~~~~~~~~~~~~~
+ nndata = nndata + 1
+ nydata = 0
+ dd_min = 1.e15
+ DO ii=1,nwdata
+ phi = ANTlat(ii) *degrad
+ ddll = earthr * cos(phi)
+ angl = 0.5*pi - ANTlon(ii) *degrad
+ x_st_n = ddll * cos(angl)
+ y_st_n = ddll * sin(angl)
+ x_st_d =(x_st_n - x_st_i)
+ y_st_d =(y_st_n - y_st_j)
+ ddll = x_st_d * x_st_d &
+ & + y_st_d * y_st_d
+ ddll = sqrt(ddll)
+ dd_min = min(ddll,dd_min)
+ if (ddll .LT. max(0.71*ddxx,4.e3)) THEN
+ nydata = nydata + 1
+ LOC__x(nydata) = x_st_n
+ LOC__y(nydata) = y_st_n
+ LOC_sh(nydata) = ANT_sh(ii)
+ END if
+ ENDDO
+ if (mod(nndata,20).eq.1) &
+ & write(6,601) NST__x(i,j),x_st_i*1.e-3, &
+ & NST__y(i,j),y_st_j*1.e-3, &
+ & dd_min*1.e-3,nydata
+ 601 format(9x,'LON,LAT =',2(f12.3,' (',f9.3,')'), &
+ & ' (',f9.3,')',i8,' Points')
+
+
+!-Elementary Meshes characteristics
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ NST_sh(i,j) = 0.
+
+ x0 = x_st_i - 0.5 *ddxx
+ y0 = y_st_j - 0.5 *ddxx
+ ddxxi = ddxx/inx
+ ddxxj = ddxx/jny
+ DO jn=1,jny
+ DO in=1,inx
+ xx = x0 + in*ddxxi
+ yy = y0 + jn*ddxxj
+
+!-Distances to the current elementary Mesh
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ DO nn=1,4
+ ddnn(nn)=nn*earthr ! arbitrary large distance
+ END DO
+ DO ii=1,nydata
+ xxii = xx - LOC__x(ii)
+ yyii = yy - LOC__y(ii)
+ dd = xxii*xxii + yyii*yyii
+ dd = sqrt(dd)
+
+!-closest DTM points
+! ~~~~~~~~~~~~~~~~~~
+ dd00 =.true.
+ DO nn=1,4
+ if (dd.lt.ddnn(nn).AND.dd00) THEN
+ if (nn.lt.4) THEN
+ DO n0=4,nn+1,-1
+ ddnn(n0) = ddnn(n0-1)
+ iinn(n0) = iinn(n0-1)
+ END DO
+ END if
+ ddnn(nn) = dd
+ iinn(nn) = ii
+ dd00 =.false.
+ END if
+ END DO
+ ENDDO
+
+
+!-Kriging
+! ~~~~~~~
+ dd = 0.
+ hh = 0.
+ DO nn=1,4
+ if (ddnn(nn).LT.1500.) THEN
+ hh = hh &
+ & + LOC_sh(iinn(nn))/ddnn(nn)
+ dd = dd + 1. /ddnn(nn)
+ END if
+ END DO
+ if (dd .GT. 0.) &
+ & hh = hh /dd
+ NST_sh(i,j) = NST_sh(i,j) +hh
+ ENDDO
+ ENDDO
+
+!-Nested Grid Cell Average
+! ~~~~~~~~~~~~~~~~~~~~~~~~
+ NST_sh(i,j) = NST_sh(i,j) / (inx*jny)
+ if (mod(nndata,20).eq.1) &
+ & write(6,602) i,j, NST_sh(i,j)
+ 602 format(9x,i3,i4,f14.3)
+
+
+!-Distinction between land and sea (further refined)
+! --------------------------------
+
+ if (NST_sh(i,j).lt.0.01) THEN
+ NSTsol(i,j)=1
+ ELSE
+ NSTsol(i,j)=3
+ ENDif
+
+
+!-No atmosphere below sea level...
+! --------------------------------
+
+ if (NST_sh(i,j).lt.0.0) THEN
+ NST_sh(i,j)= 0.0
+ ENDif
+
+
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ ENDDO ! Loop on NST grid points
+ ENDDO
+
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+!-OUTPUT
+! ------
+
+ write(6,*) 'ANTOPO: OUTPUT File rampxkmdem_wgsosu_v2.dat openING'
+ open (unit=2,status='new',file='rampxkmdem_wgsosu_v2.dat')
+ rewind 2
+ DO j=1,my
+ DO i=1,mx
+ write(2,100) NST_sh(i,j),NSTsol(i,j)
+ END DO
+ END DO
+ close(unit=1)
+ write(6,*) 'ANTOPO: OUTPUT File rampxkmdem_wgsosu_v2.dat OUT'
+ write(6,*) ' '
+ write(6,*) ' '
+
+
+ END if
+
+!HGal--v
+ deallocate (ANT_sh)
+ deallocate (ANTlat)
+ deallocate (ANTlon)
+!HGal--^
+
+
+ return
+ END subroutine ANTOPO
+
+!-------------------------------------------------------------------+
+ subroutine AntTOPO(name)
+! ANTARTIC TOPOGRAPHY specific Assimilation - Bamber 2009 |
+!-------------------------------------------------------------------+
+! Cecile Agosta, October 2012 |
+! Input : NST__x : longitude (degree) of the NST grid |
+! ^^^^^^^ NST__y : latitude (degree) of the NST grid |
+! |
+! Output: NST_sh: surface elevation |
+! ^^^^^^^ NSTsol: land (4) / ice(3) / sea (1) mask |
+! NSTice: percentage of grid cell covered by ice [0-100] |
+! |
+! Data : name = 'Bamber' |
+! ^^^^^^^ |
+! File name : krigged_dem_nsidc.bin |
+! Dataset Title : Antarctic 1 km Digital Elevation Model (DEM) |
+! from Combined ERS-1 Radar |
+! and ICESat Laser Satellite Altimetry |
+! Dataset Creator : Bamber, Jonathan L., Jose Luis Gomez-Dans, |
+! and Jennifer A. Griggs |
+! Dataset Release Place: Boulder, Colorado USA |
+! Dataset Publisher: NSIDC > National Snow and Ice Data Center |
+! Online Resource : http://nsidc.org/data/nsidc-0422.html |
+! |
+! Reference: Bamber, J.L., J.L. Gomez-Dans, and J.A. Griggs. 2009. |
+! A New 1 km Digital Elevation Model of the Antarctic |
+! Derived from Combined Satellite Radar and Laser Data |
+! Part 1: Data and Methods. |
+! The Cryosphere, 3, 101-111. |
+! |
+! Griggs, J. A. and J. L. Bamber. 2009. |
+! A New 1 km Digital Elevation Model of Antarctica |
+! Derived from Combined SatelliteRadar and Laser Data |
+! Part 2: Validation and Error Estimates. |
+! The Cryosphere, 3, 113-123. |
+! |
+! Metadata : krigged_dem_nsidc.bin.hdr |
+! description = { File Imported into ENVI.} |
+! samples = 5601 |
+! lines = 5601 |
+! bands = 1 |
+! header offset = 0 |
+! file type = ENVI Standard |
+! data type = 4 |
+! interleave = bsq |
+! sensor type = Unknown |
+! byte order = 0 |
+! map info = {Polar Stereographic South, 1, 1, |
+! -2800500., 2800500., 1000., 1000., WGS-84, units=Meters}|
+! projection info = {31, 6378137.0, 6356752.3, -71., 0., |
+! 0.0, 0.0, WGS-84, Polar Stereographic South, units=Meters}|
+! |
+! Data : name = 'bedmap' |
+! ^^^^^^^ |
+! File name : bedmap2.nc |
+! Dataset Title : Bedmap2 |
+! |
+! Dataset Creator : British Antarctic Survey |
+! |
+! Dataset Release Place: Cambridge, United Kingdom |
+! Dataset Publisher: British Antarctic Survey |
+! Online Resource : http://www.antarctica.ac.uk//bas_research/ |
+! our_research/az/bedmap2/ |
+! |
+! Reference: Fretwell P., Pritchard H.D., Vaughan D.G., Bamber J.L.,|
+! Barrand N.E., Bell R.E., Bianchi C., Bingham R.G.,|
+! Blankenship D.D.,Casassa G., Catania G., Callens D.,|
+! Conway H., Cook A.J., Corr H.F.J., Damaske D., Damm V.,|
+! Ferraccioli F., Forsberg R., Fujita S., Gim Y.,|
+! Gogineni P., Griggs J.A., Hindmarsh R.C.A., Holmlund P.,|
+! Holt J.W., Jacobel R.W., Jenkins A., Jokat W., Jordan T.,|
+! King E.C., Kohler J., Krabill W., Riger-Kusk M.,|
+! Langley K.A., Leitchenkov G., Leuschen C., Luyendyk B.P.,|
+! Matsuoka K., Mouginot J., Nitsche F.O., Nogi Y., Nost O.A.,|
+! Popov S.V., Rignot E., Rippin D.M., Rivera A., Roberts J.,|
+! Ross N., Siegert M.J., Smith A.M., Steinhage D., Studinger M.,|
+! Sun B., Tinto B.K., Welch B.C., Wilson D., Young D.A.,|
+! Xiangbin C., & Zirizzotti A. (2013)|
+! Bedmap2: improved ice bed, surface and thickness datasets for|
+! Antarctica. The Cryosphere, 7, 375-393.|
+! http://www.the-cryosphere.net/7/375/2013/tc-7-375-2013.pdf |
+! |
+! |
+! Data : name = 'bedmac' |
+! ^^^^^^^ |
+! File name : BedMachine_v02.nc3 |
+! Dataset Title : BedMachinev2 |
+! |
+! Dataset Creator : British Antarctic Survey |
+! |
+! Dataset Release Place: Cambridge, United Kingdom |
+! Dataset Publisher: British Antarctic Survey |
+! Online Resource : https://nsidc.org/data/NSIDC-0756/versions/2 |
+! |
+! |
+! Reference: Morlighem, M., E. Rignot, T. Binder, D. D. Blankenship,|
+! R. Drews, G. Eagles, O. Eisen, F. Ferraccioli, R.,|
+! Forsberg, P. Fretwell, V. Goel, J. S. Greenbaum, H. Gudmundsson,|
+! J. Guo, V. Helm, C. Hofstede, I. Howat, A. Humbert, W.Jokat,|
+! N. B. Karlsson, W. Lee, K. Matsuoka, R. Millan, J. Mouginot,|
+! J. Paden, F. Pattyn, J. L. Roberts, S. Rosier, A. Ruppel,|
+! H. Seroussi, E. C.Smith, D. Steinhage, B.Sun, M. R.van den Broeke,|
+! T. van Ommen, M. van Wessem, and D. A. Young. 2020. |
+! Deep glacial troughs and stabilizing ridges unveiled beneath |
+! the margins of the Antarctic ice sheet, Nature Geoscience. 13. |
+! 132-137. https://doi.org/10.1038/s41561-019-0510-8 |
+!-------------------------------------------------------------------+
+
+ implicit none
+
+!-Netcdf specifications
+! ---------------------
+
+ include 'NetCDF.inc'
+
+
+!-NST variables
+! -------------
+
+ include 'NSTdim.inc'
+ include 'NSTvar.inc'
+ include 'NESTOR.inc'
+ include 'LOCfil.inc'
+
+ character*6, intent(in)::name
+
+!-Local variables
+! ---------------
+ integer k,i,j,in,jn,ii,jj,maptyp
+ integer dem_ii,dem_jj,di0,dj0,ndh
+ integer imez,jmez,m
+ real xx_max,xx_min
+ real dem_dh
+ real dem_x0,dem_y0
+ real lon,lat,GEddxx,xx,yy
+ real sh,ice,grd,rck
+ real nul
+ real x0,y0
+ real xl,xr,yl,yu
+ real ref_area,area,sh_correction,tmp,tmp1,cpt
+! ....Size of full dem file
+ integer dem_mx,dem_my
+! ....dem variables
+ real*4, allocatable::dem_sh(:,:), dem_msk(:,:), dem_rck(:,:), dem_tmp(:,:)
+! ....Reading dem file
+ character*80 dem_file, var_units
+ integer recl, fID ! Record length, file ID
+! ....Reading constant file
+ character*80 file
+ logical exist
+ character*3 dhc,mxc,myc
+ character*10 TypeGL
+! ....Local NST variables
+ real NST_dh
+ real NST_xx(mx,my),NST_yy(mx,my),NSTsol_tmp(mx,my)
+
+ NST_dh = NST_dx/1000.
+
+ if(mw>=3) stop "mw>2"
+! I: REUSE PRECOMPUTED TOPO
+ ! file name
+ write(mxc,'(i3)') mx
+ if(mx<100) write(mxc,'(i2)') mx
+ write(myc,'(i3)') my
+ if(my<100) write(myc,'(i2)') my
+ write(dhc,'(i3)') int(NST_dh)
+ if(NST_dh<100) write(dhc,'(i2)') int(NST_dh)
+ if(NST_dh<10) write(dhc,'(i1)') int(NST_dh)
+
+ TypeGL="AN"//trim(dhc)//"km"
+ file=trim(PFXdir)//'AntTOPO/MARcst-' &
+ & //trim(TypeGL)//'-'// &
+ & trim(mxc)//'x'//trim(myc)//'.cdf'
+
+ inquire(file=file, exist=exist)
+ if (exist) then
+ write(6,*) 'Reading topography and masks'
+ write(6,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+ write(6,*) "> Read ", file
+ write(6,*)
+ call UNropen (file,fID,file)
+ call UNsread(fID,'SH',1,1,1,1, &
+ & mx,my,1, &
+ & var_units,NST_sh)
+ call UNsread(fID,'ICE',1,1,1,1, &
+ & mx,my,1, &
+ & var_units,NSTice)
+ call UNsread(fID,'SOL',1,1,1,1, &
+ & mx,my,1, &
+ & var_units,NSTsol_tmp)
+ NSTsol = int(NSTsol_tmp)
+ call UNsread(fID,'GROUND',1,1,1,1, &
+ & mx,my,1, &
+ & var_units,NSTgrd)
+ call UNsread(fID,'AREA',1,1,1,1, &
+ & mx,my,1, &
+ & var_units,NSTarea)
+ call UNsread(fID,'ROCK',1,1,1,1, &
+ & mx,my,1, &
+ & var_units,NSTrck)
+ else
+
+! II: If not precomputed topo, read input DEM
+!-open BSQ binary file
+! --------------------
+
+!-characteristics of the DEM grid
+! -------------------------------
+ if (name.eq.'Bamber') then
+ dem_mx = 5601
+ dem_my = 5601
+ dem_x0 = -2800.
+ dem_y0 = 2800.
+ dem_dh = 1.
+ else if (name.eq.'bedmap') then
+ dem_mx = 6667
+ dem_my = 6667
+ dem_x0 = -3333.
+ dem_y0 = -3333.
+ dem_dh = 1.
+ else if (name.eq.'bedmac') then
+ print *, name
+ dem_mx = 13333.
+ dem_my = 13333.
+ dem_x0 = -3333.
+ dem_y0 = -3333.
+ dem_dh = 0.5
+
+ endif
+ allocate(dem_sh(dem_mx,dem_my))
+ allocate(dem_msk(dem_mx,dem_my))
+ allocate(dem_rck(dem_mx,dem_my))
+ allocate(dem_tmp(dem_mx,dem_my))
+
+ if (name.eq.'Bamber') then
+
+!- opening and reading Bamber 2009 data file
+! =========================================
+ write(6,*) 'Topography : Bamber(2009) Antarctic 1km DEM'
+ write(6,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+ dem_file = trim(PFXdir)//'AntTOPO/krigged_dem_nsidc.bin'
+ write(6,*) "> Read ", dem_file
+ write(6,*)
+ Inquire(iolength=recl) dem_sh
+ open (unit=10,status='old',file=dem_file, &
+ & form='unformatted',access='direct',recl=recl)
+ Read (10,rec=1) dem_sh
+ close(10)
+ dem_msk = 0.
+ dem_rck = 0.
+ else if (name.eq.'bedmap') then
+!- opening and reading bedmap2 data file
+! =========================================
+ write(6,*) 'Topography : bedmap2 Antarctic 1km DEM'
+ write(6,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+ dem_file = trim(PFXdir)//'AntTOPO/bedmap2.nc'
+ write(6,*) "> Read ", dem_file
+ write(6,*)
+ call UNropen (dem_file,fID,dem_file)
+ call UNsread(fID,'sh',1,1,1,1, &
+ & dem_mx,dem_my,1, &
+ & var_units,dem_sh)
+ call UNsread(fID,'icemask',1,1,1,1, &
+ & dem_mx,dem_my,1, &
+ & var_units,dem_msk)
+ call UNsread(fID,'rockmask',1,1,1,1, &
+ & dem_mx,dem_my,1, &
+ & var_units,dem_rck)
+ do jj=1,dem_my
+ do ii=1,dem_mx
+ if (dem_msk(ii,jj).lt.-999) then
+ dem_msk(ii,jj) = 0.
+ else if (dem_msk(ii,jj).eq.0.) then
+ dem_msk(ii,jj) = 1.
+ else if (dem_msk(ii,jj).eq.1.) then
+ dem_msk(ii,jj) = 0.
+ endif
+ if (dem_rck(ii,jj).lt.-999) then
+ dem_rck(ii,jj) = 0.
+ else if (dem_rck(ii,jj).eq.0.) then
+ dem_rck(ii,jj) = 1.
+ endif
+ enddo
+ enddo
+ else if (name.eq.'bedmac') then
+!- opening and reading bedmachinev2 data file
+ write(6,*) 'Topography : bedmachinev2 Antarctic 0.5km DEM'
+ write(6,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+ dem_file = trim(PFXdir)//'AntTOPO/BedMachine_v02.nc3'
+ write(6,*) "> Read ", dem_file
+ write(6,*)
+ call UNropen (dem_file,fID,dem_file)
+
+ call UNsread(fID,'mask',1,1,1,1, &
+ & dem_mx,dem_my,1, &
+ & var_units,dem_msk)
+ call UNsread(fID,'SH',1,1,1,1, &
+ & dem_mx,dem_my,1, &
+ & var_units,dem_sh)
+ call UNsread(fID,'ROCKMASK',1,1,1,1, &
+ & dem_mx,dem_my,1, &
+ & var_units,dem_rck)
+
+
+
+
+
+
+
+
+ do jj=1,dem_my
+ do ii=1,dem_mx
+ if (dem_msk(ii,jj).lt.-900) then
+ dem_msk(ii,jj) = 0.
+ else if (dem_msk(ii,jj).eq.0.) then
+ dem_msk(ii,jj) = 1.
+ else if (dem_msk(ii,jj).eq.1.) then
+ dem_msk(ii,jj) = 0.
+ endif
+ if (dem_rck(ii,jj).lt.-900) then
+ dem_rck(ii,jj) = 0.
+ else if (dem_rck(ii,jj).eq.0.) then
+ dem_rck(ii,jj) = 1.
+ endif
+ enddo
+ enddo
+
+
+ endif
+!-Verify than the map projection used for MAR
+! is the same than in the DEM
+! ============================================
+ open (unit=51,status='old',file='MARgrd.ctr')
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) maptyp
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) nul
+ read (51,*) imez
+ read (51,*) nul
+ read (51,*) jmez
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) nul
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ read (51,*) GEddxx
+ read (51,*) !- - - - - - - - - - - - - - - - - -
+ close(unit=51)
+
+ if (maptyp.ne.0) then
+ Print*, "++++++++++++++++++++++++++++++++++"
+ Print*, "Routine USRant.f ----> Warning !!!"
+ Print*, "For Antarctica, "
+ Print*, "choose map type = 0 in MARgrd.ctr "
+ Print*, "(Standard stereo south projection)"
+ Print*, "NESTOR stopped NOW !!! "
+ Print*, "++++++++++++++++++++++++++++++++++"
+ STOP
+ endif
+
+ if (GEddxx.eq.90) then
+ do j=1,my
+ do i=1,mx
+ NST_yy(i,j) = NSTgdy(j)
+ NST_xx(i,j) = NSTgdx(i)
+ enddo
+ enddo
+ else
+ do j=1,my
+ do i=1,mx
+ lon = NST__x(i,j)
+ lat = NST__y(i,j)
+ call StereoSouth_inverse(lon,lat,90.,xx,yy)
+ NST_xx(i,j) = xx
+ NST_yy(i,j) = yy
+ enddo
+ enddo
+ endif
+
+ call StereoSouth_inverse(0.,-71.,GEddxx,x0,y0)
+ xl = x0 - NST_dh/2.
+ xr = x0 + NST_dh/2.
+ yl = y0 - NST_dh/2.
+ yu = y0 + NST_dh/2.
+ call areaLambertAzimuthal(xl,xr,yl,yu,GEddxx,ref_area)
+ do j=1,my
+ do i=1,mx
+ xl = NSTgdx(i) - NST_dh/2.
+ xr = NSTgdx(i) + NST_dh/2.
+ yl = NSTgdy(j) - NST_dh/2.
+ yu = NSTgdy(j) + NST_dh/2.
+ call areaLambertAzimuthal(xl,xr,yl,yu,GEddxx,area)
+ NSTarea(i,j) = area/ref_area
+ enddo
+ enddo
+!-Average the DEM on the MAR grid
+! ===============================
+ ndh = nint(NST_dh/dem_dh)
+ di0 = int((ndh-1)/2.)
+ dj0 = int((ndh-1)/2.)
+ xx_min = dem_x0 + NST_dh/2.
+ xx_max = -dem_x0 - NST_dh/2.
+ print*, ndh,di0,dj0,xx_min,xx_max
+ do j=1,my
+ do i=1,mx
+
+ if (NST__y(i,j).lt.-58) then !ckittel /Bedmap2 over Antarctica, ETOPOGO elsewhere
+ sh = 0.
+ grd = 0.
+ rck = 0.
+ ice = 0.
+ if ( NST_xx(i,j).lt.xx_min &
+ & .or. NST_xx(i,j).gt.xx_max &
+ & .or. NST_yy(i,j).lt.xx_min &
+ & .or. NST_yy(i,j).gt.xx_max) then
+ NSTgrd(i,j) = 0.
+ NST_sh(i,j) = 0.
+ NSTice(i,j) = 0.
+ NSTrck(i,j) = 0.
+ NSTsol(i,j) = 1
+ else
+
+ dem_ii = nint((NST_xx(i,j) - dem_x0)/dem_dh)
+
+ if (name.eq.'Bamber') then
+ dem_jj = nint(dem_y0 - NST_yy(i,j))
+ else if (name.eq.'bedmap' .or. name .eq. 'bedmac') then
+ dem_jj = nint((NST_yy(i,j) - dem_y0)/dem_dh)
+ endif
+ do jn=1,ndh
+ do in=1,ndh
+ ii = dem_ii - di0 + in
+ jj = dem_jj - dj0 + jn
+ if (dem_sh(ii,jj).ge.-990.) then
+ ice = ice + 1
+ sh = sh + dem_sh(ii,jj)
+ endif
+ grd = grd + dem_msk(ii,jj)
+ rck = rck + dem_rck(ii,jj)
+ enddo
+ enddo
+ NST_sh(i,j) = sh / (ndh*ndh)
+ ! +---No atmosphere below sea level
+ ! + -----------------------------
+ NST_sh(i,j) = max(NST_sh(i,j),0.)
+ NSTice(i,j) = ice / (ndh*ndh) *100.
+ NSTgrd(i,j) = grd / (ndh*ndh) *100.
+ NSTrck(i,j) = rck / (ndh*ndh) *100.
+ if (NSTice(i,j) + NSTrck(i,j) .ge.30) then
+ NSTsol(i,j) = 4.
+ NSTice(i,j) = 100.-NSTrck(i,j)
+ NSTgrd(i,j) = max(NSTgrd(i,j)-NSTrck(i,j),0.)
+ if( NSTice(i,j)>95) then
+ NSTice(i,j) = 100.
+ if(NSTgrd(i,j) >95) NSTgrd(i,j) = 100.
+ endif
+ NSTsfr(i,j,1) = NSTice(i,j)
+ NSTsfr(i,j,2) = 100. - NSTice(i,j)
+ NSTtex(i,j) = 3
+ NSTdsa(i,j) = 0.20
+ do k=1,2
+ NSTsvt(i,j,k) = 0.
+ NSTvfr(i,j,k) = NSTsfr(i,j,k)
+ enddo
+ endif
+
+ if(NSTice(i,j) + NSTrck(i,j) .lt.30.) then
+! if (NSTrck(i,j) .ge. 10. ) then
+! NSTsol(i,j) = 4.
+! NSTice(i,j) = 0.
+! NSTgrd(i,j) = 0.
+! NSTsfr(i,j,1) = NSTice(i,j)
+! NSTsfr(i,j,2) = 100. - NSTice(i,j)
+! NSTtex(i,j) = 3
+! NSTdsa(i,j) = 0.20
+! do k=1,2
+! NSTsvt(i,j,k) = 0.
+! NSTvfr(i,j,k) = NSTsfr(i,j,k)
+! enddo
+! else
+ NSTsol(i,j) = 1.
+ NSTice(i,j) = 0.
+ NSTgrd(i,j) = 0.
+ NSTrck(i,j) = 0.
+ NST_sh(i,j) = 0.
+ NSTsfr(i,j,1) = 0.
+ NSTsfr(i,j,2) = 100.
+ NSTtex(i,j) = 0
+ NSTdsa(i,j) = 0.2
+ do k=1,2
+ NSTsvt(i,j,k) = 0.
+ NSTvfr(i,j,k) = NSTsfr(i,j,k)
+ enddo
+! endif
+ endif
+ endif
+ endif
+ enddo
+ enddo
+ endif
+
+print *
+print *
+!!!vidange du shelf
+
+!sh_correction=1
+!
+!do m=1,100!1000000
+!
+! cpt=0 ; tmp=0
+!!do i=71,97; do j=30,70
+!do i=2,mx-1; do j=2,my-1
+!
+!!k=j-int(disto)
+! cpt=0 ; tmp=0
+!if (nstsol(i,j) .ge. 3 .and. nstgrd(i,j) .le. 50) then
+!
+! cpt=0
+! if(nst_SH(i+1,j )<nst_SH(i,j)-sh_correction) cpt=cpt+1
+! if(nst_SH(i-1,j )<nst_SH(i,j)-sh_correction) cpt=cpt+1
+! if(nst_SH(i ,j+1)<nst_SH(i,j)-sh_correction) cpt=cpt+1
+! if(nst_SH(i ,j-1)<nst_SH(i,j)-sh_correction) cpt=cpt+1
+!
+!tmp1=min(nst_SH(i+1,j),nst_SH(i-1,j),nst_SH(i,j+1),nst_SH(i,j-1))
+!
+! if(cpt==0.and.tmp1>0) then
+! print *,m,i,j,nst_SH(i,j)
+!
+!nst_SH(i,j)=tmp1+1.1*sh_correction
+! tmp=tmp+1
+! endif
+! endif
+! enddo ; enddo
+!
+! !if (tmp==0) goto 1000
+!
+!enddo
+
+
+ return
+ END subroutine AntTOPO
diff --git a/MAR/code_nestor/src/USRant.offset b/MAR/code_nestor/src/USRant.offset
new file mode 100644
index 0000000000000000000000000000000000000000..efb4989e9a083e4d81df57cf2989eb493c050aa6
--- /dev/null
+++ b/MAR/code_nestor/src/USRant.offset
@@ -0,0 +1 @@
+ offset = 20.
diff --git a/MAR/code_nestor/src/USReur.f b/MAR/code_nestor/src/USReur.f
new file mode 100644
index 0000000000000000000000000000000000000000..39558541b47f4ae9cba5275c9485e39c09ec7190
--- /dev/null
+++ b/MAR/code_nestor/src/USReur.f
@@ -0,0 +1,346 @@
+C +-------------------------------------------------------------------+
+C | Subroutine USRgrd February 04 NESTING |
+C +-------------------------------------------------------------------+
+C | USRgrd adapt NESTOR to Greenland region |
+C | |
+C | Input : - subnam : Name of the subroutine |
+C | ^^^^^^^ where USRgrd is called |
+C | |
+C | Maintainer : Emilie Vanvyve |
+C | ^^^^^^^^^^^^ |
+C | |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE USReur (subnam)
+
+
+ IMPLICIT NONE
+
+C +---General variables
+C + -----------------
+
+ INCLUDE 'NSTdim.inc'
+ INCLUDE 'NSTvar.inc'
+ INCLUDE 'NESTOR.inc'
+ INCLUDE 'LSCvar.inc'
+
+C +---local variables
+C + ---------------
+
+ CHARACTER*6 subnam
+
+ INTEGER nsvat,nigbp,frac_tot
+ PARAMETER (nsvat=12)
+ PARAMETER (nigbp=17)
+
+ INTEGER i,j,k,l,svat_class(3),ii,jj
+
+ REAL SVAT(0:nsvat),IGBP(nigbp),convert(nigbp,0:nsvat),
+ . svat_frac (3),iIGBP(nigbp),igbp_z0(nigbp),
+ . tmp1,tmp2,ELA,ww,var1(mx,my)
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ IF (subnam.eq.'noETOPO1') THEN
+
+
+ write (*,*) 'Special topo for Belgium (NCEP1)'
+ write (*,*)
+
+c call CF_READ2D("input/TOPO/MAR5km-nc1-BE.cdf"
+c . ,'SH',1,mx,my, 1,var1)
+
+c do i=1,mx ; do j=1,my
+c NST_sh(i,j)=var1(i+0,j+0)
+c enddo ; enddo
+
+ ii=69 ; jj=34
+
+ if(NST_sh(ii,jj)<400) then
+ print *,"change of topo for Croix_scaille",NST_sh(ii,jj)
+ do i=-1,1 ; do j=-1,1
+ ww=1.05
+ if (i==0.or. j==0) ww=1.1
+ if (i==0.and.j==0) ww=1.15
+ NST_sh(ii+i,jj+j)=NST_sh(ii+i,jj+j)*ww
+ enddo ; enddo
+ print *,"change of topo for Croix_scaille NEW",NST_sh(ii,jj)
+ endif
+
+ ii=78 ; jj=53 ! Mt Rigi
+
+ if(NST_sh(ii,jj)<600) then
+ print *,"change of topo for Mt Rigi",NST_sh(ii,jj)
+ do i=-1,1 ; do j=-1,1
+ ww=1.05
+ if (i==0.or. j==0) ww=1.1
+ if (i==0.and.j==0) ww=1.15
+ NST_sh(ii+i,jj+j)=NST_sh(ii+i,jj+j)*ww
+ enddo ; enddo
+ print *,"change of topo for Mt Rigi NEW",NST_sh(ii,jj)
+ endif
+
+ ii=75 ; jj=39
+
+ if(NST_sh(ii,jj)<500) then
+ print *,"change of topo for SThub",NST_sh(ii,jj)
+ do i=-1,1 ; do j=-1,1
+ ww=1.04
+ if (i==0.or. j==0) ww=1.09
+ if (i==0.and.j==0) ww=1.14
+ NST_sh(ii+i,jj+j)=NST_sh(ii+i,jj+j)*ww
+ enddo ; enddo
+ print *,"change of topo for ST Hub NEW",NST_sh(ii,jj)
+ endif
+
+
+ ii=78 ; jj=38
+
+ if(NST_sh(ii,jj)<510) then
+ print *,"change of topo for Wideumont",NST_sh(ii,jj)
+ do i=-1,1 ; do j=-1,1
+ ww=1.025
+ if (i==0.or. j==0) ww=1.05
+ if (i==0.and.j==0) ww=1.10
+ NST_sh(ii+i,jj+j)=NST_sh(ii+i,jj+j)*ww
+ enddo ; enddo
+ print *,"change of topo for Wideu. NEW",NST_sh(ii,jj)
+ endif
+
+ ii=72 ; jj=41
+
+ if(NST_sh(ii,jj)<270) then
+ print *,"change of topo for Humain",NST_sh(ii,jj)
+ do i=-1,1 ; do j=-1,1
+ ww=1.025
+ if (i==0.or. j==0) ww=1.05
+ if (i==0.and.j==0) ww=1.10
+ NST_sh(ii+i,jj+j)=NST_sh(ii+i,jj+j)*ww
+ enddo ; enddo
+ print *,"change of topo for humain NEW",NST_sh(ii,jj)
+ endif
+
+ ii=77 ; jj=45
+
+ if(NST_sh(ii,jj)<550) then
+ print *,"change of topo for Ba. Frai.",NST_sh(ii,jj)
+ do i=-1,1 ; do j=-1,1
+ ww=1.05
+ if (i==0.or. j==0) ww=1.1
+ if (i==0.and.j==0) ww=1.15
+ NST_sh(ii+i,jj+j)=NST_sh(ii+i,jj+j)*ww
+ enddo ; enddo
+ print *,"change of topo for Ba. Frai. NEW",NST_sh(ii,jj)
+ endif
+
+ call CF_READ2D("NST_sh.nc",'SH',1,mx,my, 1,NST_sh)
+ print *, "read of NST_sh.nc"
+
+
+
+ endif
+
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+C +---Soil Type for GLOveg
+C + ====================~
+
+C +---GRD 1: Initialisation of surface variables
+C + ..........................................
+
+ IF (subnam.eq.'no_GLOveg') THEN
+
+
+C +---IGBP Surface variables
+C + ======================
+
+ DO j=2,my-1
+ DO i=2,mx-1
+
+ IF(NSTsol(i,j)==3) NSTsol(i,j)=4
+
+ IF (NSTsol(i,j) .ge. 4 .and.
+ . NST__x(i,j) .ge. -30. .and.
+ . NST__x(i,j) .le. -10. .and.
+ . NST__y(i,j) .ge. 60. .and.
+ . NST__y(i,j) .le. 70.) THEN
+
+ DO k=1,nigbp
+ DO l=0,nsvat
+ SVAT(l) = 0.
+ IGBP(k) = 0.
+ convert(k,l) = 0.
+ ENDDO
+ ENDDO
+
+ ELA=5000
+
+ If (NST_sh(i,j).ge.ELA) NSTsol(i,j)=3
+
+ IF (nvx .eq. 3) THEN
+
+ convert( 7, 5) = 30. ! grass medium
+ convert( 7, 7) = 40. ! broadleaf low TUNDRA
+ convert( 7, 8) = 30. ! broadleaf medium
+ igbp_z0( 7 ) = 0.33
+
+ convert(16, 4) = 20. ! grass low
+ convert(16, 7) = 5. ! broadleaf low MOUNTAIN
+ convert(16, 0) = 75. ! barren soil
+ igbp_z0(16 ) = 0.022
+ NSTveg(i,j,nvx)= -1
+ NSTvfr(i,j,nvx)= 0
+
+ if (NST_sh(i,j) .le. ELA) then
+ NSTveg(i,j,1) = 7
+ NSTveg(i,j,2) = 16
+ NSTvfr(i,j,1) = 100.0 * (1- NST_sh(i,j)/ ELA)
+ NSTvfr(i,j,2) = 100.0 - NSTvfr(i,j,1)
+ else
+ NSTveg(i,j,1) = 7
+ NSTveg(i,j,2) = 16
+ NSTvfr(i,j,1) = 0.0
+ NSTvfr(i,j,2) = 100.0
+ end if
+
+ if (NSTvfr(i,j,2) .gt. NSTvfr(i,j,1)) then
+ NSTveg(i,j,1) = 16
+ NSTveg(i,j,2) = 7
+ tmp1 = NSTvfr(i,j,1)
+ NSTvfr(i,j,1) = NSTvfr(i,j,2)
+ NSTvfr(i,j,2) = tmp1
+ IGBP(7) = NSTvfr(i,j,2) / 100.0
+ IGBP(16) = NSTvfr(i,j,1) / 100.0
+ else
+ IGBP(7) = NSTvfr(i,j,1) / 100.0
+ IGBP(16) = NSTvfr(i,j,2) / 100.0
+ end if
+
+ END IF
+
+ IF (nvx .eq. 2) THEN
+
+ convert(16, 4) = 50. ! grass low
+ convert(16, 0) = 50. ! barren soil
+ igbp_z0(16 ) = 0.022
+
+ convert(15, 4) = 10. ! grass low
+ convert(15, 0) = 90. ! barren soil
+ igbp_z0(15 ) = 0.001
+
+ if(NST_sh(i,j).le.ELA) then
+ NSTveg(i,j,1) = 15
+ NSTveg(i,j,2) = 16
+ NSTvfr(i,j,2) = 100.0 * (1- NST_sh(i,j)/ ELA)
+ NSTvfr(i,j,1) = 100.0 - NSTvfr(i,j,2)
+ else
+ NSTveg(i,j,1) = 15
+ NSTvfr(i,j,1) = 100.0
+ NSTvfr(i,j,2) = 0.0
+ end if
+
+ IGBP(15) = NSTvfr(i,j,1) / 100.0
+ IGBP(16) = NSTvfr(i,j,2) / 100.0
+
+ END IF
+
+C +... convertion to SVAT
+C + ~~~~~~~~~~~~~~~~~~
+ DO k=1,nigbp
+ DO l=0,nsvat
+ SVAT(l)=SVAT(l)+convert(k,l)*IGBP(k)
+ ENDDO
+ ENDDO
+
+C +... retain the (nvx-1) dominant classes
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ DO k=2,nvx
+ svat_class(k)=1
+ svat_frac (k)=SVAT(1)
+ DO l=1,nsvat
+ IF (svat_frac(k).lt.SVAT(l)) THEN
+ svat_class(k)=l
+ svat_frac (k)=SVAT(l)
+ ENDIF
+ SVAT(svat_class(k))=0.
+ ENDDO
+ ENDDO
+
+C +... class (nvx) is reserved for barren soil
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ svat_class(1) = 0
+ svat_frac (1) = SVAT(0)
+
+C +... normalizing the three dominant fractions
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ frac_tot=0.
+ DO l=1,nvx
+ frac_tot=frac_tot+svat_frac(l)
+ ENDDO
+ IF (frac_tot.ne.0.) THEN
+ DO l=1,nvx
+ svat_frac(l)=svat_frac(l)/frac_tot
+ ENDDO
+ ENDIF
+C +... attribute classes and fractions to NST variables
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ DO k=1,nvx
+ NSTsvt(i,j,k)= svat_class(k)
+ NSTsfr(i,j,k)=NINT(svat_frac (k)*100.)
+ ENDDO
+
+
+ DO l=1,nvx
+
+ IF (NSTsvt(i,j,l).eq. 0) NSTlmx(i,j,l) = 0.0
+ IF (NSTsvt(i,j,l).eq. 1) NSTlmx(i,j,l) = 0.6
+ IF (NSTsvt(i,j,l).eq. 2) NSTlmx(i,j,l) = 0.9
+ IF (NSTsvt(i,j,l).eq. 3) NSTlmx(i,j,l) = 1.2
+ IF (NSTsvt(i,j,l).eq. 4) NSTlmx(i,j,l) = 0.7
+ IF (NSTsvt(i,j,l).eq. 5) NSTlmx(i,j,l) = 1.4
+ IF (NSTsvt(i,j,l).eq. 6) NSTlmx(i,j,l) = 2.0
+ IF (NSTsvt(i,j,l).eq. 7.or.NSTsvt(i,j,l).eq.10)
+ . NSTlmx(i,j,l) = 3.0
+ IF (NSTsvt(i,j,l).eq. 8.or.NSTsvt(i,j,l).eq.11)
+ . NSTlmx(i,j,l) = 4.5
+ IF (NSTsvt(i,j,l).eq. 9.or.NSTsvt(i,j,l).eq.12)
+ . NSTlmx(i,j,l) = 6.0
+
+ NSTlai(i,j,l) = NSTlmx(i,j,l)
+ NSTglf(i,j,l) = 1.0
+
+ ENDDO
+
+
+ END IF
+ END DO
+ END DO
+
+ ENDIF
+
+ DO j=2,my-1
+ DO i=2,mx-1
+ IF (NSTsol(i,j).eq.3) THEN
+
+ DO k=1,nvx
+ NSTsvt(i,j,k) = 0
+ NSTsfr(i,j,k) = 0
+ NSTveg(i,j,k) = 0
+ NSTvfr(i,j,k) = 0
+ NSTlai(i,j,k) = 0
+ NSTglf(i,j,k) = 0
+ ENDDO
+
+ NSTsvt(i,j,nvx)= 0
+ NSTsfr(i,j,nvx)=100
+ NSTveg(i,j,nvx)= -1
+ NSTvfr(i,j,nvx)=100
+
+ END IF
+ END DO
+ END DO
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ END SUBROUTINE
diff --git a/MAR/code_nestor/src/USRgrd.f b/MAR/code_nestor/src/USRgrd.f
new file mode 100644
index 0000000000000000000000000000000000000000..2848517646c2ffdb88bea6fe4b707ef62116a882
--- /dev/null
+++ b/MAR/code_nestor/src/USRgrd.f
@@ -0,0 +1,303 @@
+C +-------------------------------------------------------------------+
+C | Subroutine USRgrd July 2012 NESTING |
+C +-------------------------------------------------------------------+
+C | USRgrd adapt NESTOR to Greenland region |
+C | |
+C | Input : - subnam : Name of the subroutine |
+C | ^^^^^^^ where USRgrd is called |
+C | |
+C | Maintainer : Xavier Fettweis |
+C | ^^^^^^^^^^^^ |
+C | |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE USRgrd (subnam)
+
+
+ IMPLICIT NONE
+
+C +---General variables
+C + -----------------
+
+ INCLUDE 'NSTdim.inc'
+ INCLUDE 'NSTvar.inc'
+ INCLUDE 'NESTOR.inc'
+ INCLUDE 'LSCvar.inc'
+
+C +---local variables
+C + ---------------
+
+ CHARACTER*6 subnam
+
+ INTEGER nsvat,nigbp
+ PARAMETER (nsvat=12)
+ PARAMETER (nigbp=17)
+
+ INTEGER i,j,k,l,var2(mx,my)
+
+ REAL SVAT(0:nsvat),IGBP(nigbp),convert(nigbp,0:nsvat),
+ . svat_frac (3),iIGBP(nigbp),igbp_z0(nigbp),
+ . tmp1,tmp2,ELA,var1(mx,my), svat_class(3),frac_tot
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+C +---Topography for ETOPOg
+C + =====================
+
+ IF (subnam.eq.'noETOPOg'.or.subnam.eq.'noGLOcov') THEN
+
+ write (*,*) 'Special topo for Greenland Simulation'
+ write (*,*)
+
+ call CF_READ2D("input/TOPO/GRD-12_5km-240x270.cdf"
+ . ,'MSK',1,mx,my, 1,var1)
+
+ do i=10,mx-10 ; do j=10,my-10
+ if(var1(i+0,j+0)==1) then
+ NSTsol(i,j)=4
+ else
+ NSTsol(i,j)=1
+ endif
+ enddo ; enddo
+
+ call CF_READ2D("input/TOPO/GRD-12_5km-240x270.cdf"
+ . ,'ICE',1,mx,my, 1,var1)
+
+ do i=1,mx ; do j=1,my
+ NSTice(i,j)=var1(i+0,j+0)*100.
+
+ if(NSTice(i,j)>10) then
+
+ NSTsfr(i,j,1) = NSTice(i,j)
+ NSTsfr(i,j,2) = min(100.,max(0.,100. - NSTsfr(i,j,1)))
+
+ NSTsvt(i,j,1) =-1
+ NSTsvt(i,j,2) = 1
+
+ endif
+
+c if(NSTice(i,j)<=10.and.NSTsvt(i,j,1)<0) then
+
+c print *,"corr1",i,j,NSTsvt(i,j,1),NSTsfr(i,j,1)
+
+c NSTsvt(i,j,1) = 1
+c NSTsvt(i,j,2) = 1
+
+c NSTsfr(i,j,1) = 0
+c NSTsfr(i,j,2) = min(100.,max(0.,100. - NSTsfr(i,j,1)))
+
+c endif
+
+ if(NSTice(i,j)<=10.and.NSTsvt(i,j,1)>=0) then ! only 1 vege type over Tundra
+
+ if(i<=10.or.i>=mx-10.or.j<=10.or.j>=my-10) then
+ if(NSTsvt(i,j,1)<NSTsvt(i,j,2)) NSTsvt(i,j,2)=NSTsvt(i,j,1)
+ else
+ if(NSTsfr(i,j,1)>NSTsfr(i,j,2)) NSTsvt(i,j,2)=NSTsvt(i,j,1)
+ endif
+
+ NSTsvt(i,j,1) = 1
+
+ NSTsfr(i,j,1) = 0
+ NSTsfr(i,j,2) = min(100.,max(0.,100. - NSTsfr(i,j,1)))
+
+ endif
+
+ enddo ; enddo
+
+ call CF_READ2D("input/TOPO/GRD-12_5km-240x270.cdf"
+ . ,'SRF',1,mx,my, 1,var1)
+
+ do i=10,mx-10 ; do j=10,my-10
+ NST_sh(i,j)=var1(i+0,j+0)
+ enddo ; enddo
+
+ do l=1,mw
+ NSTveg(i,j,k) = NSTsvt(i,j,k)
+ NSTvfr(i,j,k) = NSTsfr(i,j,k)
+ enddo
+
+ ENDIF
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+C +---Soil Type for GLOveg
+C + ====================~
+
+C +---GRD 1: Initialisation of surface variables
+C + ..........................................
+
+ IF (subnam.eq.'no_GLOveg') THEN
+
+ write(6,*) 'Global land cover (IGBP) over Greenland Region'
+ write(6,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+
+ DO j=2,my-1
+ DO i=2,mx-1
+
+ NSTfrc(i,j) = 0.
+
+ DO k=1,nvx
+ NSTsvt(i,j,k) = 0
+ NSTsfr(i,j,k) = 0
+ NSTveg(i,j,k) = 0
+ NSTvfr(i,j,k) = 0
+ END DO
+
+ IF (NSTsol(i,j).ge.4) THEN
+
+ NSTsvt(i,j,1) = 4
+ NSTsfr(i,j,1) = 100
+ NSTveg(i,j,1) = 9
+ NSTvfr(i,j,1) = 100
+
+ DO k=1,nvx
+ NSTlai(i,j,k) = 2.0
+ NSTglf(i,j,k) = 1.0
+ END DO
+
+ ELSE
+
+ NSTsvt(i,j,1) = 0
+ NSTsfr(i,j,1) = 100
+ NSTveg(i,j,1) = -1
+ NSTvfr(i,j,1) = 100
+
+ DO k=1,nvx
+ NSTlai(i,j,k) = 0.0
+ NSTglf(i,j,k) = 0.0
+ END DO
+
+ NST_z0(i,j) = 0.0013
+
+ ENDIF
+
+ END DO
+ END DO
+
+C +---IGBP Surface variables
+C + ======================
+
+ DO j=2,my-1
+ DO i=2,mx-1
+ IF (NSTsol(i,j) .ge. 4 ) THEN
+
+ DO k=1,nigbp
+ DO l=0,nsvat
+ SVAT(l) = 0.
+ IGBP(k) = 0.
+ convert(k,l) = 0.
+ ENDDO
+ ENDDO
+
+ IF(NST__x(i,j).gt.-43) then ! Equilibrium line (m)
+ ELA = -32759.680d0 + 1001.782d0 * NST__y(i,j)
+ . - 7.331d0 * NST__y(i,j) * NST__y(i,j)
+ ELSE
+ ELA = -23201.445d0 + 746.249d0 * NST__y(i,j)
+ . - 5.640d0 * NST__y(i,j) * NST__y(i,j)
+ END IF
+
+ IF (nvx .eq. 2) THEN
+
+ convert(16, 4) = 100. ! grass low
+ convert(16, 0) = 0. ! barren soil
+ igbp_z0(16 ) = 0.022
+
+ convert(15, 4) = 0. ! grass low
+ convert(15, 0) = 100. ! barren soil
+ igbp_z0(15 ) = 0.001
+
+ if(NSTice(i,j).ge.0) then
+ NSTveg(i,j,1) = 15
+ NSTveg(i,j,2) = 16
+ NSTvfr(i,j,1) = NSTice(i,j)
+ NSTvfr(i,j,2) = 100.0 - NSTvfr(i,j,1)
+ else
+ NSTveg(i,j,1) = 15
+ NSTvfr(i,j,1) = 100.0
+ NSTvfr(i,j,2) = 0.0
+ end if
+
+ IGBP(15) = NSTvfr(i,j,1) / 100.0
+ IGBP(16) = NSTvfr(i,j,2) / 100.0
+
+ END IF
+
+C +... convertion to SVAT
+C + ~~~~~~~~~~~~~~~~~~
+ DO k=1,nigbp
+ DO l=0,nsvat
+ SVAT(l)=SVAT(l)+convert(k,l)*IGBP(k)
+ ENDDO
+ ENDDO
+
+C +... retain the (nvx-1) dominant classes
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ DO k=2,nvx
+ svat_class(k)=1
+ svat_frac (k)=SVAT(1)
+ DO l=1,nsvat
+ IF (svat_frac(k).lt.SVAT(l)) THEN
+ svat_class(k)=l
+ svat_frac (k)=SVAT(l)
+ ENDIF
+ SVAT(svat_class(k))=0.
+ ENDDO
+ ENDDO
+
+C +... class (nvx) is reserved for barren soil
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ svat_class(1) = 0
+ svat_frac (1) = SVAT(0)
+
+C +... normalizing the three dominant fractions
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ frac_tot=0.
+ DO l=1,nvx
+ frac_tot=frac_tot+svat_frac(l)
+ ENDDO
+ IF (frac_tot.ne.0.) THEN
+ DO l=1,nvx
+ svat_frac(l)=svat_frac(l)/frac_tot
+ ENDDO
+ ENDIF
+C +... attribute classes and fractions to NST variables
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ DO k=1,nvx
+ NSTsvt(i,j,k)= svat_class(k)
+ NSTsfr(i,j,k)=min(100.,svat_frac (k)*100.)
+ ENDDO
+
+ DO l=1,nvx
+
+ IF (NSTsvt(i,j,l).eq. 0) NSTlmx(i,j,l) = 0.0
+ IF (NSTsvt(i,j,l).eq. 1) NSTlmx(i,j,l) = 0.6
+ IF (NSTsvt(i,j,l).eq. 2) NSTlmx(i,j,l) = 0.9
+ IF (NSTsvt(i,j,l).eq. 3) NSTlmx(i,j,l) = 1.2
+ IF (NSTsvt(i,j,l).eq. 4) NSTlmx(i,j,l) = 0.7
+ IF (NSTsvt(i,j,l).eq. 5) NSTlmx(i,j,l) = 1.4
+ IF (NSTsvt(i,j,l).eq. 6) NSTlmx(i,j,l) = 2.0
+ IF (NSTsvt(i,j,l).eq. 7.or.NSTsvt(i,j,l).eq.10)
+ . NSTlmx(i,j,l) = 3.0
+ IF (NSTsvt(i,j,l).eq. 8.or.NSTsvt(i,j,l).eq.11)
+ . NSTlmx(i,j,l) = 4.5
+ IF (NSTsvt(i,j,l).eq. 9.or.NSTsvt(i,j,l).eq.12)
+ . NSTlmx(i,j,l) = 6.0
+
+ NSTlai(i,j,l) = NSTlmx(i,j,l)
+ NSTglf(i,j,l) = 1.0
+
+ ENDDO
+
+
+ END IF
+ END DO
+ END DO
+
+ ENDIF
+
+C + ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ END SUBROUTINE
+
diff --git a/MAR/code_nestor/src/VERhyb.f b/MAR/code_nestor/src/VERhyb.f
new file mode 100644
index 0000000000000000000000000000000000000000..755c354c4c595986f24c91aada4c7e616e96bee8
--- /dev/null
+++ b/MAR/code_nestor/src/VERhyb.f
@@ -0,0 +1,47 @@
+C +-------------------------------------------------------------------+
+C | Subroutine VERhyb May 2002 NESTING |
+C +-------------------------------------------------------------------+
+C | Computes local hybrid coordinate used for vertical interpolation. |
+C | |
+C | Input : |
+C | ^^^^^^^ - nk : number of vertical levels |
+C | - LSC_sp : surface pressure |
+C | - LSC__p(nk+1) : pressure on the levels |
+C | |
+C | Output: |
+C | ^^^^^^^ |
+C | - LSC_hp(nk+1) : local hybrid coord. for vertic. interp. |
+C | |
+C | Note that vertical coordinates are computed only at given (i,j) |
+C | horizontal grid point in order to limit memory requirements. |
+C | |
+C +-------------------------------------------------------------------+
+ SUBROUTINE VERhyb (nk,LSC_sp,LSC__p,LSC_hp)
+
+
+ IMPLICIT NONE
+
+ INTEGER k,nk
+
+ REAL pp,ppm,pps,ppf,pp1,dpsl,hh,
+ . LSC_sp,LSC__p(nk+1),LSC_hp(nk+1)
+
+
+ pp1 = 105. ! Reference pressure (KPa)
+ dpsl = 20. ! "> boundary layer" (KPa)
+C +...Local hybrid coordinate: set parameters
+
+ pps = LSC_sp
+ ppm = pps - dpsl
+ DO k = 1,nk+1
+ pp = LSC__p(k)
+ hh = pp/pp1
+ IF (pp.gt.ppm) THEN
+ ppf= (pp-ppm)/(pps-ppm)
+ hh = hh + (pp1-pps)/pp1 * ppf * ppf
+ END IF
+ LSC_hp(k) = LOG(hh)
+ ENDDO
+
+ RETURN
+ END
diff --git a/MAR/code_nestor/src/VERhyd.f b/MAR/code_nestor/src/VERhyd.f
new file mode 100644
index 0000000000000000000000000000000000000000..a99b77ac5e9abe419c4f6bb7db3bc9ab9de35a40
--- /dev/null
+++ b/MAR/code_nestor/src/VERhyd.f
@@ -0,0 +1,102 @@
+C +------------------------------------------------------------------------+
+C | VERhyd NESTOR/MAPOST January 02 |
+C | Computation of geopotential height by HYDrostatic relation |
+C +------------------------------------------------------------------------+
+C | |
+C | METHOD: |
+C | ^^^^^^^ |
+C | Hydrostatic relation is integrated as in MAR (theta * dExner) |
+C | (small simplification: theta assumed constant between surf-lev1 |
+C | unless a T and q is given for the surface) |
+C | |
+C | This is a "simplified" version of the Zplev routine from LSMARIN |
+C | (i.e. there is no interpolation to pressure levels, but the method |
+C | is exactly the same). |
+C | |
+C | INPUT: ni,nj,nk : Grid size |
+C | ^^^^^^ Note: nk is 1st level above surface |
+C | OR the surface itself |
+C | |
+C | |
+C | MOD__p(ni,nj,nk) : pressure |
+C | MOD_sp(ni,nj) : surface pressure; MOD_sp units: kPa. |
+C | |
+C | MOD_qv(ni,nj,nk) : Specific Humidity (kg/kg) |
+C | MOD_pt(ni,nj,nk) : potential temp. |
+C | getpkt : If MOD_pt = true potential temp, |
+C | set getpkt to 100**(-cap). For mar, set getpkt=1|
+C | MOD_sh(ni,nj) : surface height (m) |
+C | |
+C | OUTPUT: |
+C | ^^^^^^^ |
+C | MOD_zz(ni,nj,nk): Computed geopotential |
+C | NOTE: levels with p < sp |
+C | are set to MOD_zz=MOD_sh |
+C +------------------------------------------------------------------------+
+ SUBROUTINE VERhyd(MOD_pt, MOD_qv, MOD_sh, MOD_sp, MOD__p,
+ . getpkt, ni, nj, nk, MOD_zz)
+
+ IMPLICIT NONE
+
+ INCLUDE 'NSTphy.inc'
+
+C +.. *Input / Output
+ INTEGER ni, nj, nk
+ REAL MOD__p (ni, nj, nk)
+ REAL MOD_pt (ni, nj, nk), MOD_qv (ni, nj, nk)
+ REAL pktv1, pex1
+ REAL MOD_sh (ni, nj), MOD_sp (ni, nj)
+ REAL MOD_zz (ni, nj, nk)
+ REAL getpkt
+
+C +.. *Internal
+ INTEGER i,j,k
+ REAL pex, pktv, zzcalc
+
+
+ DO j=1,nj
+ DO i=1,ni
+
+c +..Initialisation phase : compute functions at surface
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+C +.. *Exner potential (Cp*p**cap):
+ pex1 = cp*exp(cap*log(MOD_sp(i,j)))
+C Note: use of surface pressure is ok for both MAR and
+C data defined on hybrid or constant p-levels.
+
+ pktv1= MOD_pt(i,j,nk)*getpkt*(1.d0+MOD_qv(i,j,nk)*0.608d0)
+C +.. *Assume constant MOD_pt and MOD_qv between surf. - nearest lev.
+
+ zzcalc= MOD_sh(i,j)
+C +.. *Begin Z integration at surface.
+
+C +
+C +..Compute geopotential (integrate hydrostat. relation)
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ DO k=nk,1,-1
+
+C +.. *Exner potential (Cp*p**cap):
+ pex = cp *exp(cap *log(MOD__p(i,j,k)))
+
+ pktv= MOD_pt(i,j,k)*getpkt*(1.d0+MOD_qv(i,j,k)*0.608d0)
+C (0.608 -> 0.85 dans MAR;
+C mailto:philippe.marbaix@advalvas.be for info)
+
+ IF (pex1.GT.pex) THEN
+ zzcalc= zzcalc + (pex1-pex)
+ . *(pktv1+pktv)*0.5d0/grav
+ pex1 = pex
+ ENDIF
+
+ pktv1 = pktv
+
+C +.. *output Z of level:
+ MOD_zz(i,j,k) = zzcalc
+
+ ENDDO
+ ENDDO
+ ENDDO
+
+ RETURN
+ END
diff --git a/MAR/code_nestor/src/VecRot.f b/MAR/code_nestor/src/VecRot.f
new file mode 100644
index 0000000000000000000000000000000000000000..1be9b688900af639f374a053be50e0ea80150ef1
--- /dev/null
+++ b/MAR/code_nestor/src/VecRot.f
@@ -0,0 +1,234 @@
+C +-------------------------------------------------------------------+
+C | Subroutine VecRot Sept 99 NESTING |
+C +-------------------------------------------------------------------+
+C | |
+C | Rotates vector (wind) following the rotation of the reference |
+C | frame that occurs on a map projection. |
+C | A special treatment is done for grid points close to N/S pole. |
+C | |
+C | References : Map projections and equations of motion suitable |
+C | ^^^^^^^^^^^^ for mesoscale alpha simulations by the MAR model. |
+C | |
+C | Input : - grd_lon (mx, my) : grid positions lon(i,j) |
+C | ^^^^^^^ - grd_lat (mx, my) : grid positions lat(i,j) |
+C | - dx : mesh size : the grid is assumed to be square |
+C | and fully regullar |
+C | - var_1 (mx, my) : "x" component of the vector |
+C | - var_2 (mx, my) : "y" component of the vector |
+C | (local cartesian on the sphere) |
+C | |
+C | Output: - var_1 (mx, my) : x component of the vector |
+C | ^^^^^^^ - var_2 (mx, my) : y component of the vector |
+C | (cartesian frame on the map) |
+C | |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE VecRot (grd_lon,grd_lat,dx,var_1,var_2)
+
+
+ IMPLICIT NONE
+
+
+C +---Dimensions
+C + ----------
+
+ INCLUDE 'NSTdim.inc'
+
+
+C +---Input
+C + -----
+ REAL grd_lon(mx,my),grd_lat(mx,my)
+ REAL dx
+
+
+C +---Input and output
+C + ----------------
+
+ REAL var_1(mx,my),var_2(mx,my)
+
+
+C +---Local variables
+C + ---------------
+
+ INTEGER i,j,ii,jj,iii,jjj,cmpt
+ REAL m11,m12,m21,m22,vx,vy,rayter,DtR,dist_sp,dist_np,
+ . dist_dx,d_sp,d_np,aux_v1,aux_v2,dlamx,dphix,dlamy,
+ . dphiy,auxi1_lon,auxi2_lon,auxj1_lon,auxj2_lon,
+ . auxi1_lat,auxi2_lat,auxj1_lat,auxj2_lat
+
+
+C +---Data
+C + ----
+
+ DATA rayter / 6371229.0 /
+ DtR = ACOS(-1.)/180.
+
+
+C +---Correction on wind direction (stereog. grid only)
+C + =================================================
+
+ DO j = 1,my
+ jj = j
+ IF (j.eq.1 ) jj=2
+ IF (j.eq.my) jj=my-1
+
+ DO i = 1,mx
+ ii = i
+ IF (i.eq.1) ii = 2
+ IF (i.eq.mx)ii = mx-1
+
+ auxi1_lon = grd_lon(ii+1,jj )
+ auxi2_lon = grd_lon(ii-1,jj )
+ auxj1_lon = grd_lon(ii ,jj+1)
+ auxj2_lon = grd_lon(ii ,jj-1)
+ auxi1_lat = grd_lat(ii+1,jj )
+ auxi2_lat = grd_lat(ii-1,jj )
+ auxj1_lat = grd_lat(ii ,jj+1)
+ auxj2_lat = grd_lat(ii ,jj-1)
+ IF ((auxi1_lon-auxi2_lon).gt.180.) auxi2_lon=auxi2_lon+360.
+ IF ((auxi2_lon-auxi1_lon).gt.180.) auxi1_lon=auxi1_lon+360.
+ IF ((auxj1_lon-auxj2_lon).gt.180.) auxj2_lon=auxj2_lon+360.
+ IF ((auxj2_lon-auxj1_lon).gt.180.) auxj1_lon=auxj1_lon+360.
+ IF ((auxi1_lat-auxi2_lat).gt. 90.) auxi2_lat=auxi2_lat+180.
+ IF ((auxi2_lat-auxi1_lat).gt. 90.) auxi1_lat=auxi1_lat+180.
+ IF ((auxj1_lat-auxj2_lat).gt. 90.) auxj2_lat=auxj2_lat+180.
+ IF ((auxj2_lat-auxj1_lat).gt. 90.) auxj1_lat=auxj1_lat+180.
+
+C +---Correction for latitude and longitude
+C + -------------------------------------
+
+ dlamx = (auxi1_lon-auxi2_lon)/(2*dx)
+ dphix = (auxi1_lat-auxi2_lat)/(2*dx)
+ dlamy = (auxj1_lon-auxj2_lon)/(2*dx)
+ dphiy = (auxj1_lat-auxj2_lat)/(2*dx)
+
+ m11 = dphiy * DtR * rayter
+ m12 = -dlamy * DtR * rayter * cos(grd_lat(ii,jj) * DtR)
+ m21 = -dphix * DtR * rayter
+ m22 = dlamx * DtR * rayter * cos(grd_lat(ii,jj) * DtR)
+
+C +...equivalent to:
+C +... m11 = dlamx * DtR * rayter * cos(grd_lat(ii,jj) * DtR)
+C +... m12 = dphix * DtR * rayter
+C +... m21 = dlamy * DtR * rayter * cos(grd_lat(ii,jj) * DtR)
+C +... m22 = dphiy * DtR * rayter
+C +...
+C +...or (simplier):
+C +... m11 = dphiy * DtR * rayter
+C +... m12 = dphix * DtR * rayter
+C +... m21 = -dphix * DtR * rayter
+C +... m22 = dphiy * DtR * rayter
+
+C +---Corrected wind direction
+C + ------------------------
+
+ vx = m11 * var_1(i,j) + m12 * var_2(i,j)
+ vy = m21 * var_1(i,j) + m22 * var_2(i,j)
+ var_1(i,j) = vx
+ var_2(i,j) = vy
+
+ ENDDO
+ ENDDO
+
+
+C +---Special treatment close to North/South pole
+C + ===========================================
+
+ DO j = 1,my
+ jj = j
+ IF (j.eq.1 ) jj=2
+ IF (j.eq.my) jj=my-1
+
+ DO i = 1,mx
+ ii = i
+ IF (i.eq.1) ii = 2
+ IF (i.eq.mx)ii = mx-1
+
+ dist_sp=ABS(grd_lat(i,j)+90.) * 111111.1
+ dist_np=ABS(grd_lat(i,j)-90.) * 111111.1
+ dist_dx=dx
+
+ IF (dist_sp.lt.dist_dx .or. dist_np.lt.dist_dx) THEN
+
+C +...For grid points whose distance with the pole is less than
+C +...Dx, no satisfying wind direction can be computed using the
+C +...above-mentioned formula. Therefore a "mean wind" is computed
+C +...considering the 8 closest grid points around (i,j).
+
+ cmpt =0
+ aux_v1=0.
+ aux_v2=0.
+ DO jjj=jj-1,jj+1
+ DO iii=ii-1,ii+1
+ d_sp=ABS(grd_lat(iii,jjj)+90.) * 111111.1
+ d_np=ABS(grd_lat(iii,jjj)-90.) * 111111.1
+ IF (d_sp.gt.dist_dx .and. d_np.gt.dist_dx) THEN
+ aux_v1=aux_v1+var_1(iii,jjj)
+ aux_v2=aux_v2+var_2(iii,jjj)
+ cmpt =cmpt+1
+ ENDIF
+ ENDDO
+ ENDDO
+ IF (cmpt.gt.0) THEN
+ var_1(i,j)=aux_v1/REAL(cmpt)
+ var_2(i,j)=aux_v2/REAL(cmpt)
+ ENDIF
+ ENDIF
+
+ ENDDO
+ ENDDO
+
+
+ RETURN
+ END
+
+
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !
+
+C +---------------------------------------------------------------------+
+C | Subroutine VecRot_StereoSouth Fev 2021 C.Agosta |
+C +---------------------------------------------------------------------+
+C | Projection of the wind vectors in the polar south stereo. grid |
+C | lon0 : lon-Direction (2D runs only ; 90 = East, clockwise) |
+C | MAR : lon0 = GEddxx = 75 |
+C +---------------------------------------------------------------------+
+
+ Subroutine VecRot_StereoSouth(lon0,NSTlon,NSTlat,INT_uu,INT_vv)
+
+ Implicit None
+
+ Include 'NSTdim.inc'
+ Real, Intent(in) :: lon0
+ Real, Intent(in) :: NSTlon(mx,my),NSTlat(mx,my)
+ Real, Intent(inout) :: INT_uu(mx,my)
+ Real, Intent(inout) :: INT_vv(mx,my)
+
+ Integer i,j
+ Real pi, dr, phi, cphi, sphi, deltaphi
+ Real uu, vv
+
+ pi = 4.e0*atan(1.)
+ dr = pi/180.
+
+ deltaphi = 90. - lon0
+
+ Do j=1,my
+ Do i=1,mx
+ if(NSTlat(i,j)<=0) then
+ phi = (-1.) * (NSTlon(i,j)+deltaphi) * dr
+ else
+ phi = ( 1.) * (NSTlon(i,j)+deltaphi) * dr
+ endif
+ cphi = cos( phi )
+ sphi = sin( phi )
+ uu = cphi*INT_uu(i,j) - sphi*INT_vv(i,j)
+ vv = sphi*INT_uu(i,j) + cphi*INT_vv(i,j)
+ INT_uu(i,j) = uu
+ INT_vv(i,j) = vv
+ EndDo
+ EndDo
+
+ Return
+ End Subroutine VecRot_StereoSouth
+
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !
diff --git a/MAR/code_nestor/src/WARNms.f b/MAR/code_nestor/src/WARNms.f
new file mode 100644
index 0000000000000000000000000000000000000000..708f5574d538c5e9f9fbd3af4c45d4b3113016b4
--- /dev/null
+++ b/MAR/code_nestor/src/WARNms.f
@@ -0,0 +1,83 @@
+C +-------------------------------------------------------------------+
+C | Subroutine WARNms July 99 NESTING |
+C +-------------------------------------------------------------------+
+C | |
+C | Input : Some variables which have to be carrefully specified. |
+C | ^^^^^^^ |
+C | |
+C | Output: Warnings to prevent inadapted use of the code. |
+C | ^^^^^^^ |
+C | |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE WARNms
+
+ IMPLICIT NONE
+
+C +---General variables
+C + -----------------
+
+ include 'NSTdim.inc'
+ include 'LSCvar.inc'
+ include 'NESTOR.inc'
+
+C +---Horizontal interpolation
+C + ------------------------
+
+ IF (SPHgrd.and.(HORint.gt.1)) THEN
+ WRITE(6,*) 'Warning : first order for horizontal interpolation'
+ WRITE(6,*) '~~~~~~~ is recommended if the simulation domain '
+ WRITE(6,*) ' is cyclic or includes North/South pole. '
+ WRITE(6,*)
+ ENDIF
+
+C +---Vertical interpolation
+C + ----------------------
+
+ IF (VERint.eq.3) THEN
+ WRITE(6,*) 'Warning : third order for vertical interpolation '
+ WRITE(6,*) '~~~~~~~ is not recommended since it could induce'
+ WRITE(6,*) ' strange variations in vertical profiles.'
+ WRITE(6,*)
+ ENDIF
+
+C +---Correction of 600-hPa geopotential
+C + ----------------------------------
+
+ IF (CORzz6) THEN
+ WRITE(6,*) 'Note : 600hPa-based correction activated'
+ WRITE(6,*) '~~~~ (NST height = LSC height at 600 hPa)'
+ WRITE(6,*)
+ ELSE
+ WRITE(6,*) 'Note : 600hPa-based correction NOT activated'
+ WRITE(6,*) '~~~~ (bad idea, at least if you have'
+ WRITE(6,*) ' mountains near the boundaries)'
+ WRITE(6,*)
+ ENDIF
+
+C +---NDVI Databases
+C + --------------
+
+ IF (NDV1km.and.NDV8km) THEN
+ WRITE(6,*) 'NDVI databases : select either 1-km resolution or'
+ WRITE(6,*) '~~~~~~~~~~~~~~ 8-km resolution in NSTing.ctr file'
+ WRITE(6,*)
+ WRITE(6,*) 'STOP.'
+ WRITE(6,*)
+ ENDIF
+
+C +---Prognostic variables of SVAT
+C + ----------------------------
+c J.-F. Grailet remark (13/04/22): sounding is no longer used.
+c
+c IF (SNDing.and.SVTlsc) THEN
+c WRITE(6,*) 'Warning : sounding and soil wetness estimated '
+c WRITE(6,*) '~~~~~~~ from ECMWF fields are not compatible. '
+c WRITE(6,*) ' Imposed relative wetness in all layers'
+c WRITE(6,*) ' is then considered. '
+c WRITE(6,*)
+c ENDIF
+
+ RETURN
+ END
+
diff --git a/MAR/code_nestor/src/XCPvgd.f b/MAR/code_nestor/src/XCPvgd.f
new file mode 100644
index 0000000000000000000000000000000000000000..5117840b8bf704495848cb241625404d818af42c
--- /dev/null
+++ b/MAR/code_nestor/src/XCPvgd.f
@@ -0,0 +1,136 @@
+C +-------------------------------------------------------------------+
+C | Subroutine XCPvgd 12-04-2022 JFG |
+C +-------------------------------------------------------------------+
+C | |
+C | Vertical grid of the ECMWF/NCEP models. Tailored for a 2D grid. |
+C | There were initially separate routines for both ECP and NCP modes |
+C | (see calls in LSCvgd.f), but due to the code being nearly |
+C | identical, one logical parameter was added to distinguish both |
+C | modes when coming across the set of instructions that differ |
+C | between the original routines. The XCPvgd name refers to how both |
+C | modes share the same suffix -CP. |
+C | |
+C | Input : - fID : identificator of the Netcdf data file |
+C | ^^^^^^^ - nk : number of vertical levels |
+C | - baseI : minimum X index of the relevant LSC sub-region |
+C | - baseJ : minimum Y index of the relevant LSC sub-region |
+C | - maxI : maximum X index of the relevant LSC sub-region |
+C | - maxJ : maximum Y index of the relevant LSC sub-region |
+C | - klev : if specified, the level at which pressure and |
+C | hybrid coordinate has to be computed |
+C | - isNCP : true if using the NCEP model |
+C | - XCP_sp(ni,nj) : surface pressure |
+C | |
+C | Output: Vertical grid of the ECMWF model : |
+C | ^^^^^^^ - XCP__p(ni,nj,nk+1) : pressure at each level [kPa] |
+C | - XCP__z(ni,nj,nk+1) : hybrid coordinates |
+C | |
+C | Remarks on optimization via sub-region selection (29/05/2022): |
+C | -to compute the vertical grid for the full LSC domain, use |
+C | baseI=1, baseJ=1, maxI=ni, maxJ=nj. |
+C | -code assumes that the user will use 1 <= baseI <= maxI <= ni and |
+C | 1 <= baseJ <= maxJ <= nj. |
+C | -if the variables baseI, baseJ, maxI and maxJ are set to delimit |
+C | a sub-region of the LSC grid, only this sub-region will be |
+C | completed in the output grids. |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE XCPvgd(fID,ni,nj,nk,baseI,baseJ,maxI,maxJ,klev,isNCP,
+ . XCP_sp,XCP__p,XCP__z)
+
+ IMPLICIT NONE
+
+C +---Local variables
+C + ---------------
+
+ INTEGER fID,ni,nj,baseI,baseJ,maxI,maxJ,nk,klev,i,j,k,k1,k2
+
+ REAL pp,ppm,pps,ppf,pp1,dpsl,hh,empty0(nk+1),empty1(1),
+ . XCP_sp(ni,nj),XCP__p(ni,nj,nk+1),XCP__z(ni,nj,nk+1),
+ . plevel(nk)
+
+ CHARACTER*10 var_units
+
+ LOGICAL isNCP
+
+C +---Atmospheric levels: pressure levels
+C + -----------------------------------
+
+C + ******
+C +---J.-F. Grailet: in the original code, the vector used as the
+C +---tenth argument was not used in any meaningful way, hence why
+C +---it was replaced with empty0.
+C +--- ******
+ CALL UNread (fID,'level',0,0,0,0,nk,1,1,empty0,empty1,empty1,
+ . var_units,plevel)
+C + ******
+
+
+C +---Computation for a given level or all levels ?
+C + ---------------------------------------------
+
+ IF ((klev.le.0).or.(klev.gt.nk)) THEN
+ k1=1
+ k2=nk
+ ELSE
+ k1=1
+ k2=klev
+ ENDIF
+
+ pp1 = 105. ! Reference pressure (KPa)
+ dpsl = 20. ! "> boundary layer" (KPa)
+
+C +---For each i,j pixel (start of grid traversal)
+C + --------------------------------------------
+C + 29/05/2022: added a small optimization; grid traversal now only
+C + takes account of the sub-region of the LSC domain which includes
+C + the NST domain.
+
+ DO i=baseI,maxI ! i=1,ni
+ DO j=baseJ,maxJ ! j=1,nj
+
+C +---Compute pressure at each levels
+C + -------------------------------
+
+ DO k=k1,k2
+ XCP__p(i,j,k)=plevel(k)/10. ! (kPa)
+c IF (XCP__p(i,j,k).gt.XCP_sp(i,j)) THEN
+c IF (isNCP) THEN
+c XCP__p(i,j,k)=XCP_sp(i,j)-REAL(k)*0.1
+c ELSE
+c XCP__p(i,j,k)=XCP_sp(i,j)-REAL(k)*0.01
+c ENDIF
+c ENDIF
+ ENDDO
+
+ IF (isNCP) THEN
+ ! WARNING (X. Fettweis)
+ ! The NCEP and MERRA2 files are built with the surface
+ ! variable at the first pressure level
+ ! Q2,U10,V10,T2
+ XCP__p(i,j,nk)=XCP_sp(i,j)
+ XCP__p(i,j,nk+1)=XCP_sp(i,j)
+ ELSE
+ XCP__p(i,j,nk+1)=105.
+ ENDIF
+
+C +---Compute hybrid coordinates (required by nesting procedure)
+C + --------------------------
+C +...Local hybrid coordinate: set parameters:
+
+ pps = XCP_sp(i,j)
+ ppm = pps - dpsl
+ DO k = k1,k2+1
+ pp = XCP__p(i,j,k)
+ hh = pp/pp1
+ IF (pp.gt.ppm) THEN
+ ppf= (pp-ppm)/(pps-ppm)
+ hh = hh + (pp1-pps)/pp1 * ppf * ppf
+ END IF
+ XCP__z(i,j,k) = LOG(hh)
+ ENDDO
+
+ END DO; END DO ! End of grid traversal
+
+ RETURN
+ END
diff --git a/MAR/code_nestor/src/bufLim.f b/MAR/code_nestor/src/bufLim.f
new file mode 100644
index 0000000000000000000000000000000000000000..890e1ffe50846f6b612a17cdeb66381bd2361a21
--- /dev/null
+++ b/MAR/code_nestor/src/bufLim.f
@@ -0,0 +1,51 @@
+C +-------------------------------------------------------------------+
+C | Subroutine bufLim 16-04-2022 JFG |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE bufLim (cy, difLat, minLat, dimLat)
+
+ IMPLICIT NONE
+
+ INCLUDE 'NSTdim.inc' ! Gets mx, my
+ INCLUDE 'NSTvar.inc' ! Gets NST__y
+
+ real, parameter :: reso=0.00833333
+
+ ! cy and difLat differ depending on the calling routine
+ integer :: cy
+ real :: difLat
+
+ integer :: i, jns, idTop, idBot ! id = index, bot = bottom
+ integer :: minLat, maxLat, dimLat
+ real :: degY
+
+ ! J.-F. Grailet: this code considers MAR pixels cannot be larger
+ ! than 1° in latitude in order to buffer enough pixels top and
+ ! bottom of the selected band.
+
+ degY = (cy / 360) / 2 ! 0.5 degree
+
+ minLat = cy
+ maxLat = 0
+
+ DO i=1,mx
+ jns = nint((NST__y(i,1) + difLat) / reso)
+ idTop = jns - nint(degY)
+ if (idTop < minLat) minLat = idTop
+ ENDDO
+
+ DO i=1,mx
+ jns = nint((NST__y(i,my) + difLat) / reso)
+ idBot = jns + nint(degY)
+ if (idBot > maxLat) maxLat = idBot
+ ENDDO
+
+ ! Cuts latitude to 1 or cy if minLat/maxLat are too low/high
+ if (minLat < 1) minLat = 1 ! Northernmost point of the grid
+ if (maxLat > cy) maxLat = cy ! Southernmost point of the grid
+
+ dimLat = maxLat - minLat
+
+ RETURN
+
+ END SUBROUTINE
diff --git a/MAR/code_nestor/src/for2bam.f b/MAR/code_nestor/src/for2bam.f
new file mode 100644
index 0000000000000000000000000000000000000000..65e1e1560f6d2047aeacfbc17a77fadd8399c627
--- /dev/null
+++ b/MAR/code_nestor/src/for2bam.f
@@ -0,0 +1,365 @@
+ subroutine for2bam(iprint,nprint,ID__nc
+ . ,iyrrGE,mmarGE,jdarGE,jhurGE,minuGE,jsecGE
+ . ,x_unit,y_unit,z_unit,w_unit
+ . ,lxyz_0,lxyz_1,lxyz_2,lxyz_3,lxyz_4
+ . ,lxyz_5,lxyz_6,lxyz_7,lxyz_8,lxyz_9
+ . ,lxyw_0,lxyw_1,lxyw_2,lxyw_3,lxyw_4
+ . ,lxyw_5,lxyw_6,lxyw_7,lxyw_8,lxyw_9
+ . ,filnam,title ,fildat)
+
+C +------------------------------------------------------------------------+
+C | MAR OUTPUT 03-02-2005 MAR |
+C | SubRoutine for2nc is used to write x-D OUTPUTS |
+C | on a NetCDF file |
+C | |
+C +------------------------------------------------------------------------+
+C | |
+C | INPUT: iprint: Current time step number |
+C | ^^^^^^ (starting from iprint=1, which => new file creation) |
+C | nprint: Total 'time slices' number (max value of iprint) |
+C | iyrrGE: Year |
+C | mmarGE: Month |
+C | jdarGE: Day |
+C | jhurGE: Hour [UT] |
+C | minuGE: Minute |
+C | jsecGE: Second |
+C | x_unit,y_unit,z_unit,w_unit : x, y, z, w axes unities |
+C | lxyz_0,lxyz_1,lxyz_2,lxyz_3,lxyz_4: variables attributes |
+C | lxyz_5,lxyz_6,lxyz_7,lxyz_8,lxyz_9: variables attributes |
+C | lxyw_0,lxyw_1,lxyw_2,lxyw_3,lxyw_4: variables attributes |
+C | lxyw_5,lxyw_6,lxyw_7,lxyw_8,lxyw_9: variables attributes |
+C | filnam: 1st Label of the OUTPUT File Name |
+C | title : Title of the OUTPUT File |
+C | fildat: Table of Variables of the OUTPUT File |
+C | |
+C | INPUT(via for2nc.inc): OUTPUT dimensions |
+C | ^^^^^^ OUTPUT variables |
+C | |
+C | OUTPUT: NetCDF File adapted to IDL Graphic Software |
+C | ^^^^^^ |
+C | |
+C | CAUTION: 1) This Routine requires the usual NetCDF library, |
+C | ^^^^^^^^ and the complementary access library 'libUN.a' |
+C | |
+C +------------------------------------------------------------------------+
+
+
+ IMPLICIT NONE
+
+
+C +--General Variables
+C + =================
+
+ include 'for2bam.inc'
+
+ integer iprint,nprint,ID__nc
+ integer iyrrGE,mmarGE,jdarGE,jhurGE,minuGE,jsecGE
+
+ character*20 filnam
+ character*90 title
+ character*31 x_unit,y_unit,z_unit,w_unit
+ character*10 fildat
+
+ character*7 lxyz_0,lxyz_1,lxyz_2,lxyz_3,lxyz_4
+ character*7 lxyz_5,lxyz_6,lxyz_7,lxyz_8,lxyz_9
+ character*7 lxyw_0,lxyw_1,lxyw_2,lxyw_3,lxyw_4
+ character*7 lxyw_5,lxyw_6,lxyw_7,lxyw_8,lxyw_9
+
+
+C +--Local Variables
+C + =================
+
+ integer nzz,i,j,k
+ PARAMETER (nzz = nz+1)
+
+ integer njmoGE(0:12),njmbGE(0:12)
+ integer njyrGE(0:12),njybGE(0:12)
+
+ integer Lfnam, Ltit, Luni, Lnam, Llnam
+ PARAMETER (Lfnam= 40, Ltit= 90, Luni= 31, Lnam= 13, Llnam=50)
+C +...Length of char strings
+
+ CHARACTER*(Lfnam) fnamNC
+ common/for2nc_loc/ fnamNC
+C +... fnamNC: To retain file name.
+
+ integer NdimNC
+ PARAMETER (NdimNC = 5)
+C +...Number of defined spatial dimensions (exact)
+
+ integer MXdim
+ PARAMETER (MXdim = 6000)
+C +...Maximum Number of all dims: recorded Time Steps
+C + and also maximum of spatial grid points for each direction.
+
+ integer MX_var
+ PARAMETER (MX_var = 80)
+C +...Maximum Number of Variables
+
+ integer NattNC
+ PARAMETER (NattNC = 2)
+C +...Number of REAL attributes given to all variables
+
+ INTEGER RCODE
+
+ integer jourNC(MXdim)
+ integer moisNC(MXdim)
+ real yearNC(MXdim)
+ real dateNC(MXdim)
+ real timeNC(MXdim)
+ common/OUT2nc_r/ yearNC,dateNC
+ real VALdim(MXdim,0:NdimNC)
+ integer nDFdim( 0:NdimNC)
+ common/OUT2nc_d/ nDFdim
+ integer NvatNC(NattNC)
+ CHARACTER*(Lnam) NAMdim( 0:NdimNC)
+ CHARACTER*(Luni) UNIdim( 0:NdimNC)
+ CHARACTER*(Lnam) SdimNC(4,MX_var)
+ CHARACTER*(Luni) unitNC(MX_var)
+ CHARACTER*(Lnam) nameNC(MX_var)
+ CHARACTER*(Llnam) lnamNC(MX_var)
+ CHARACTER*(Ltit ) tit_NC
+ CHARACTER*(Lnam) NAMrat(NattNC)
+c #TC CHARACTER*9 labelc
+ CHARACTER*120 tmpINP
+
+ integer n1000 ,n100a ,n100 ,n10_a ,n10 ,n1
+ integer m10 , jd10 ,jd1
+ integer MMXstp,it ,mois ,mill ,iu
+ integer itotNC,NtotNC
+ real starta(1)
+
+ data njmoGE ! Nb of Days
+ . /0,31,28,31,30, 31, 30, 31, 31, 30, 31, 30, 31/ ! in each Month
+ data njmbGE ! Leap Year
+ . /0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ ! Correction
+ data njyrGE ! Nb of Days
+ . /0, 0,31,59,90,120,151,181,212,243,273,304,334/ ! since 1st Jan
+ data njybGE ! Leap Year
+ . /0, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1/ ! Correction
+
+
+C +--NetCDF File Initialization
+C + ==========================
+
+
+ IF (iprint.eq.1) THEN
+
+
+C +--Output File Label
+C + -----------------
+
+ fnamNC = filnam
+
+
+C +--Output Title
+C + ------------
+
+ tit_NC = title
+
+
+C +--Create File / Write Constants
+C + -----------------------------
+ MMXstp = MXdim
+C +... To check array bounds... silently
+
+C +--Time Variable (hour)
+C + ~~~~~~~~~~~~~~~~~~~~
+
+C +... To define a NetCDF dimension (size, name, unit):
+c _UL nDFdim(0)= nprint
+ nDFdim(0)= 0
+ NAMdim(0)= 'time'
+ UNIdim(0)= 'HOURS since 1901-01-15 00:00:00'
+
+C +... Check temporary arrays: large enough ?
+ IF (nprint.gt.MMXstp)
+ & STOP '*** for_2D - ERROR : MXdim to low ***'
+
+
+C +--Define horizontal spatial dimensions :
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+C +... Check temporary arrays: large enough ?
+ IF ( nx .gt.MMXstp.or.ny.gt.MMXstp
+ & .or.nzz.gt.MMXstp.or.nw.gt.MMXstp)
+ & STOP '*** for_2D - ERROR : MXdim to low ***'
+
+C +...To define NetCDF dimensions (size, name, unit):
+
+ DO i = 1, nx
+ VALdim(i,1) = x_axis(i)
+ END DO
+ nDFdim(1) = nx
+ NAMdim(1) = 'x'
+ UNIdim(1) = x_unit
+
+ DO j = 1, ny
+ VALdim(j,2) = y_axis(j)
+ END DO
+ nDFdim(2) = ny
+ NAMdim(2) = 'y'
+ UNIdim(2) = y_unit
+
+ do k = 1, nz
+ VALdim(1,3) = z_axis(k)
+ enddo
+ nDFdim(3) = nz
+ NAMdim(3) = 'level'
+ UNIdim(3) = z_unit
+C +... For levels k
+
+ do k = 1, nz
+ VALdim(k,4) = z_axis(k)
+ enddo
+ nDFdim(4) = nz
+ NAMdim(4) = 'level2'
+ UNIdim(4) = z_unit
+C +... For levels k+1/2
+
+ do k = 1, nw
+ VALdim(k,5) = w_axis(k)
+ enddo
+ nDFdim(5) = nw
+ NAMdim(5) = 'sector'
+ UNIdim(5) = w_unit
+C +... For Surface Sectors
+
+C +--Variable's Choice (Table xxxxxx.dat)
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ OPEN(unit=10,status='unknown',file=fildat)
+
+ itotNC = 0
+ 980 CONTINUE
+ READ (10,'(A120)',end=990) tmpINP
+ IF (tmpINP(1:4).eq.' ') THEN
+ itotNC = itotNC + 1
+ READ (tmpINP,'(4x,5A9,A12,A50)')
+ & nameNC(itotNC) ,SdimNC(1,itotNC),SdimNC(2,itotNC),
+ & SdimNC(3,itotNC),SdimNC(4,itotNC),
+ & unitNC(itotNC) ,lnamNC(itotNC)
+C +... nameNC: Name
+C + SdimNC: Names of Selected Dimensions (max.4/variable)
+C + unitNC: Units
+C + lnamNC: Long_name, a description of the variable
+
+ ENDIF
+ GOTO 980
+ 990 CONTINUE
+
+ CLOSE(unit=10)
+
+ NtotNC = itotNC
+C +... NtotNC : Total number of variables writen in NetCDF file.
+
+C +--List of NetCDF attributes given to all variables:
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+C +... The "actual_range" is the (min,max)
+C + of all data for each variable:
+ NAMrat(1) = 'actual_range'
+ NvatNC(1) = 2
+
+C +... The "[var]_range" is NOT of attribute type,
+C + it is a true variable containing the (min,max) for
+C + each level, for 4D (space+time) variables only
+C + (automatic handling by UN library;
+C + must be the LAST attribute)
+ NAMrat(NattNC) = '[var]_range'
+ NvatNC(NattNC) = 2
+
+C +--Automatic Generation of the NetCDF File Structure
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+C + **************
+ CALL UNscreate (fnamNC, tit_NC,
+ & NdimNC, nDFdim, MXdim , NAMdim, UNIdim, VALdim,
+ & MX_var, NtotNC, nameNC, SdimNC, unitNC, lnamNC,
+ & NattNC, NAMrat, NvatNC,
+ & ID__nc)
+C + **************
+
+
+C +--Write Time - Constants
+C + ~~~~~~~~~~~~~~~~~~~~~~
+
+C + ************
+ CALL UNwrite (ID__nc, 'LON ', 1 , nx , ny, 1 , Longit)
+ CALL UNwrite (ID__nc, 'LAT ', 1 , nx , ny, 1 , Latitu)
+ CALL UNwrite (ID__nc, 'ANT1km', 1 , nx , ny, 1 , OroOBS)
+c #2D CALL UNwrite (ID__nc, 'sh_MAR', 1 , nx , ny, 1 , OroSIM)
+ CALL UNwrite (ID__nc, 'SOL ', 1 , nx , ny, 1 , SolTyp)
+C + ************
+
+
+C +--Re-Open file if already created.
+C + ================================
+
+
+ ELSE
+
+C + ************
+ CALL UNwopen (fnamNC,ID__nc)
+C + ************
+
+ END IF
+
+
+C +--Write Time-dependent variables:
+C + ===============================
+
+
+C +--UNLIMITED Time Dimension
+C + ------------------------
+
+ IF (nDFdim(0).eq.0) THEN !
+ starta = (351+(iyrrGE -1902) *365 ! Nb Days before iyrrGE
+ . +(iyrrGE -1901) / 4 ! Nb Leap Years
+ . + njyrGE(mmarGE) ! Nb Days before mmarGE
+ . + njybGE(mmarGE) ! (including Leap Day)
+ . *max(0,1-mod(iyrrGE,4)) !
+ . + jdarGE -1 )* 24 !
+ . +jhurGE !
+ . + (minuGE *60 +jsecGE )/3600.!
+
+C + ************
+ CALL UNwrite (ID__nc, 'time ',iprint, 1, 1, 1, starta)
+C + ************
+
+ END IF
+
+
+C + ************
+c #3D CALL UNwrite (ID__nc,lxyz_0,iprint,nx,ny,nz , fxyz_0)
+c #3D CALL UNwrite (ID__nc,lxyz_1,iprint,nx,ny,nz , fxyz_1)
+c #3D CALL UNwrite (ID__nc,lxyz_2,iprint,nx,ny,nz , fxyz_2)
+c #3D CALL UNwrite (ID__nc,lxyz_3,iprint,nx,ny,nz , fxyz_3)
+c #3D CALL UNwrite (ID__nc,lxyz_4,iprint,nx,ny,nz , fxyz_4)
+c #3D CALL UNwrite (ID__nc,lxyz_5,iprint,nx,ny,nz , fxyz_5)
+c #3D CALL UNwrite (ID__nc,lxyz_6,iprint,nx,ny,nz , fxyz_6)
+c #3D CALL UNwrite (ID__nc,lxyz_7,iprint,nx,ny,nz , fxyz_7)
+c #3D CALL UNwrite (ID__nc,lxyz_8,iprint,nx,ny,nz , fxyz_8)
+c #3D CALL UNwrite (ID__nc,lxyz_9,iprint,nx,ny,nz , fxyz_9)
+c #3D CALL UNwrite (ID__nc,lxyw_0,iprint,nx,ny,nw , fxyw_0)
+c #3D CALL UNwrite (ID__nc,lxyw_1,iprint,nx,ny,nw , fxyw_1)
+c #3D CALL UNwrite (ID__nc,lxyw_2,iprint,nx,ny,nw , fxyw_2)
+c #3D CALL UNwrite (ID__nc,lxyw_3,iprint,nx,ny,nw , fxyw_3)
+c #3D CALL UNwrite (ID__nc,lxyw_4,iprint,nx,ny,nw , fxyw_4)
+c #3D CALL UNwrite (ID__nc,lxyw_5,iprint,nx,ny,nw , fxyw_5)
+c #3D CALL UNwrite (ID__nc,lxyw_6,iprint,nx,ny,nw , fxyw_6)
+c #3D CALL UNwrite (ID__nc,lxyw_7,iprint,nx,ny,nw , fxyw_7)
+c #3D CALL UNwrite (ID__nc,lxyw_8,iprint,nx,ny,nw , fxyw_8)
+c #3D CALL UNwrite (ID__nc,lxyw_9,iprint,nx,ny,nw , fxyw_9)
+C + ************
+
+
+C +--That 's all, folks: NetCDF File Closure
+C + =======================================
+
+C + ***********
+ CALL NCCLOS (ID__nc,RCODE)
+C + ***********
+
+
+ return
+ end
diff --git a/MAR/code_nestor/src/for2bam.inc b/MAR/code_nestor/src/for2bam.inc
new file mode 100644
index 0000000000000000000000000000000000000000..1c78a013abf4d1ea235fe405e9cb9340763a842b
--- /dev/null
+++ b/MAR/code_nestor/src/for2bam.inc
@@ -0,0 +1,40 @@
+C + BEGIN for2bam.inc
+ integer nx ,ny ,nz ,nw
+ parameter(nx=5601,ny=5601,nz=001,nw=100)
+ real x_axis(nx )
+ real y_axis( ny)
+ real z_axis( nz)
+ real w_axis( nw)
+ real Longit(nx,ny)
+ real Latitu(nx,ny)
+ real OroOBS(nx,ny)
+c #2D real OroSIM(nx,ny)
+ real SolTyp(nx,ny)
+c #3D real fxyz_0(nx,ny,nz)
+c #3D real fxyz_1(nx,ny,nz)
+c #3D real fxyz_2(nx,ny,nz)
+c #3D real fxyz_3(nx,ny,nz)
+c #3D real fxyz_4(nx,ny,nz)
+c #3D real fxyz_5(nx,ny,nz)
+c #3D real fxyz_6(nx,ny,nz)
+c #3D real fxyz_7(nx,ny,nz)
+c #3D real fxyz_8(nx,ny,nz)
+c #3D real fxyz_9(nx,ny,nz)
+c #3D real fxyw_0(nx,ny,nw)
+c #3D real fxyw_1(nx,ny,nw)
+c #3D real fxyw_2(nx,ny,nw)
+c #3D real fxyw_3(nx,ny,nw)
+c #3D real fxyw_4(nx,ny,nw)
+c #3D real fxyw_5(nx,ny,nw)
+c #3D real fxyw_6(nx,ny,nw)
+c #3D real fxyw_7(nx,ny,nw)
+c #3D real fxyw_8(nx,ny,nw)
+c #3D real fxyw_9(nx,ny,nw)
+ common /for2cdf_var/x_axis,y_axis,z_axis,w_axis
+ . ,Longit,Latitu,OroOBS
+c #3D. ,OroSIM,SolTyp
+c #3D. ,fxyz_0,fxyz_1,fxyz_2,fxyz_3,fxyz_4
+c #3D. ,fxyz_5,fxyz_6,fxyz_7,fxyz_8,fxyz_9
+c #3D. ,fxyw_0,fxyw_1,fxyw_2,fxyw_3,fxyw_4
+c #3D. ,fxyw_5,fxyw_6,fxyw_7,fxyw_8,fxyw_9
+C + END for2bam.inc
diff --git a/MAR/code_nestor/src/for2cdf.f b/MAR/code_nestor/src/for2cdf.f
new file mode 100644
index 0000000000000000000000000000000000000000..1208e3b14b0e8bdf5904fdd5ab2d43a4a68d90c0
--- /dev/null
+++ b/MAR/code_nestor/src/for2cdf.f
@@ -0,0 +1,365 @@
+ subroutine for2cdf(iprint,nprint,ID__nc
+ . ,iyrrGE,mmarGE,jdarGE,jhurGE,minuGE,jsecGE
+ . ,x_unit,y_unit,z_unit,w_unit
+ . ,lxyz_0,lxyz_1,lxyz_2,lxyz_3,lxyz_4
+ . ,lxyz_5,lxyz_6,lxyz_7,lxyz_8,lxyz_9
+ . ,lxyw_0,lxyw_1,lxyw_2,lxyw_3,lxyw_4
+ . ,lxyw_5,lxyw_6,lxyw_7,lxyw_8,lxyw_9
+ . ,filnam,title ,fildat)
+
+C +------------------------------------------------------------------------+
+C | MAR OUTPUT 03-02-2005 MAR |
+C | SubRoutine for2nc is used to write x-D OUTPUTS |
+C | on a NetCDF file |
+C | |
+C +------------------------------------------------------------------------+
+C | |
+C | INPUT: iprint: Current time step number |
+C | ^^^^^^ (starting from iprint=1, which => new file creation) |
+C | nprint: Total 'time slices' number (max value of iprint) |
+C | iyrrGE: Year |
+C | mmarGE: Month |
+C | jdarGE: Day |
+C | jhurGE: Hour [UT] |
+C | minuGE: Minute |
+C | jsecGE: Second |
+C | x_unit,y_unit,z_unit,w_unit : x, y, z, w axes unities |
+C | lxyz_0,lxyz_1,lxyz_2,lxyz_3,lxyz_4: variables attributes |
+C | lxyz_5,lxyz_6,lxyz_7,lxyz_8,lxyz_9: variables attributes |
+C | lxyw_0,lxyw_1,lxyw_2,lxyw_3,lxyw_4: variables attributes |
+C | lxyw_5,lxyw_6,lxyw_7,lxyw_8,lxyw_9: variables attributes |
+C | filnam: 1st Label of the OUTPUT File Name |
+C | title : Title of the OUTPUT File |
+C | fildat: Table of Variables of the OUTPUT File |
+C | |
+C | INPUT(via for2nc.inc): OUTPUT dimensions |
+C | ^^^^^^ OUTPUT variables |
+C | |
+C | OUTPUT: NetCDF File adapted to IDL Graphic Software |
+C | ^^^^^^ |
+C | |
+C | CAUTION: 1) This Routine requires the usual NetCDF library, |
+C | ^^^^^^^^ and the complementary access library 'libUN.a' |
+C | |
+C +------------------------------------------------------------------------+
+
+
+ IMPLICIT NONE
+
+
+C +--General Variables
+C + =================
+
+ include 'for2cdf.inc'
+
+ integer iprint,nprint,ID__nc
+ integer iyrrGE,mmarGE,jdarGE,jhurGE,minuGE,jsecGE
+
+ character*20 filnam
+ character*90 title
+ character*31 x_unit,y_unit,z_unit,w_unit
+ character*10 fildat
+
+ character*7 lxyz_0,lxyz_1,lxyz_2,lxyz_3,lxyz_4
+ character*7 lxyz_5,lxyz_6,lxyz_7,lxyz_8,lxyz_9
+ character*7 lxyw_0,lxyw_1,lxyw_2,lxyw_3,lxyw_4
+ character*7 lxyw_5,lxyw_6,lxyw_7,lxyw_8,lxyw_9
+
+
+C +--Local Variables
+C + =================
+
+ integer nzz,i,j,k
+ PARAMETER (nzz = nz+1)
+
+ integer njmoGE(0:12),njmbGE(0:12)
+ integer njyrGE(0:12),njybGE(0:12)
+
+ integer Lfnam, Ltit, Luni, Lnam, Llnam
+ PARAMETER (Lfnam= 40, Ltit= 90, Luni= 31, Lnam= 13, Llnam=50)
+C +...Length of char strings
+
+ CHARACTER*(Lfnam) fnamNC
+ common/for2nc_loc/ fnamNC
+C +... fnamNC: To retain file name.
+
+ integer NdimNC
+ PARAMETER (NdimNC = 5)
+C +...Number of defined spatial dimensions (exact)
+
+ integer MXdim
+ PARAMETER (MXdim = 6000)
+C +...Maximum Number of all dims: recorded Time Steps
+C + and also maximum of spatial grid points for each direction.
+
+ integer MX_var
+ PARAMETER (MX_var = 80)
+C +...Maximum Number of Variables
+
+ integer NattNC
+ PARAMETER (NattNC = 2)
+C +...Number of REAL attributes given to all variables
+
+ INTEGER RCODE
+
+ integer jourNC(MXdim)
+ integer moisNC(MXdim)
+ real yearNC(MXdim)
+ real dateNC(MXdim)
+ real timeNC(MXdim)
+ common/OUT2nc_r/ yearNC,dateNC
+ real VALdim(MXdim,0:NdimNC)
+ integer nDFdim( 0:NdimNC)
+ common/OUT2nc_d/ nDFdim
+ integer NvatNC(NattNC)
+ CHARACTER*(Lnam) NAMdim( 0:NdimNC)
+ CHARACTER*(Luni) UNIdim( 0:NdimNC)
+ CHARACTER*(Lnam) SdimNC(4,MX_var)
+ CHARACTER*(Luni) unitNC(MX_var)
+ CHARACTER*(Lnam) nameNC(MX_var)
+ CHARACTER*(Llnam) lnamNC(MX_var)
+ CHARACTER*(Ltit ) tit_NC
+ CHARACTER*(Lnam) NAMrat(NattNC)
+c #TC CHARACTER*9 labelc
+ CHARACTER*120 tmpINP
+
+ integer n1000 ,n100a ,n100 ,n10_a ,n10 ,n1
+ integer m10 , jd10 ,jd1
+ integer MMXstp,it ,mois ,mill ,iu
+ integer itotNC,NtotNC
+ real starta(1)
+
+ data njmoGE ! Nb of Days
+ . /0,31,28,31,30, 31, 30, 31, 31, 30, 31, 30, 31/ ! in each Month
+ data njmbGE ! Leap Year
+ . /0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ ! Correction
+ data njyrGE ! Nb of Days
+ . /0, 0,31,59,90,120,151,181,212,243,273,304,334/ ! since 1st Jan
+ data njybGE ! Leap Year
+ . /0, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1/ ! Correction
+
+
+C +--NetCDF File Initialization
+C + ==========================
+
+
+ IF (iprint.eq.1) THEN
+
+
+C +--Output File Label
+C + -----------------
+
+ fnamNC = filnam
+
+
+C +--Output Title
+C + ------------
+
+ tit_NC = title
+
+
+C +--Create File / Write Constants
+C + -----------------------------
+ MMXstp = MXdim
+C +... To check array bounds... silently
+
+C +--Time Variable (hour)
+C + ~~~~~~~~~~~~~~~~~~~~
+
+C +... To define a NetCDF dimension (size, name, unit):
+c _UL nDFdim(0)= nprint
+ nDFdim(0)= 0
+ NAMdim(0)= 'time'
+ UNIdim(0)= 'HOURS since 1901-01-15 00:00:00'
+
+C +... Check temporary arrays: large enough ?
+ IF (nprint.gt.MMXstp)
+ & STOP '*** for_2D - ERROR : MXdim to low ***'
+
+
+C +--Define horizontal spatial dimensions :
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+C +... Check temporary arrays: large enough ?
+ IF ( nx .gt.MMXstp.or.ny.gt.MMXstp
+ & .or.nzz.gt.MMXstp.or.nw.gt.MMXstp)
+ & STOP '*** for_2D - ERROR : MXdim to low ***'
+
+C +...To define NetCDF dimensions (size, name, unit):
+
+ DO i = 1, nx
+ VALdim(i,1) = x_axis(i)
+ END DO
+ nDFdim(1) = nx
+ NAMdim(1) = 'x'
+ UNIdim(1) = x_unit
+
+ DO j = 1, ny
+ VALdim(j,2) = y_axis(j)
+ END DO
+ nDFdim(2) = ny
+ NAMdim(2) = 'y'
+ UNIdim(2) = y_unit
+
+ do k = 1, nz
+ VALdim(1,3) = z_axis(k)
+ enddo
+ nDFdim(3) = nz
+ NAMdim(3) = 'level'
+ UNIdim(3) = z_unit
+C +... For levels k
+
+ do k = 1, nz
+ VALdim(k,4) = z_axis(k)
+ enddo
+ nDFdim(4) = nz
+ NAMdim(4) = 'level2'
+ UNIdim(4) = z_unit
+C +... For levels k+1/2
+
+ do k = 1, nw
+ VALdim(k,5) = w_axis(k)
+ enddo
+ nDFdim(5) = nw
+ NAMdim(5) = 'sector'
+ UNIdim(5) = w_unit
+C +... For Surface Sectors
+
+C +--Variable's Choice (Table xxxxxx.dat)
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ OPEN(unit=10,status='unknown',file=fildat)
+
+ itotNC = 0
+ 980 CONTINUE
+ READ (10,'(A120)',end=990) tmpINP
+ IF (tmpINP(1:4).eq.' ') THEN
+ itotNC = itotNC + 1
+ READ (tmpINP,'(4x,5A9,A12,A50)')
+ & nameNC(itotNC) ,SdimNC(1,itotNC),SdimNC(2,itotNC),
+ & SdimNC(3,itotNC),SdimNC(4,itotNC),
+ & unitNC(itotNC) ,lnamNC(itotNC)
+C +... nameNC: Name
+C + SdimNC: Names of Selected Dimensions (max.4/variable)
+C + unitNC: Units
+C + lnamNC: Long_name, a description of the variable
+
+ ENDIF
+ GOTO 980
+ 990 CONTINUE
+
+ CLOSE(unit=10)
+
+ NtotNC = itotNC
+C +... NtotNC : Total number of variables writen in NetCDF file.
+
+C +--List of NetCDF attributes given to all variables:
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+C +... The "actual_range" is the (min,max)
+C + of all data for each variable:
+ NAMrat(1) = 'actual_range'
+ NvatNC(1) = 2
+
+C +... The "[var]_range" is NOT of attribute type,
+C + it is a true variable containing the (min,max) for
+C + each level, for 4D (space+time) variables only
+C + (automatic handling by UN library;
+C + must be the LAST attribute)
+ NAMrat(NattNC) = '[var]_range'
+ NvatNC(NattNC) = 2
+
+C +--Automatic Generation of the NetCDF File Structure
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+C + **************
+ CALL UNscreate (fnamNC, tit_NC,
+ & NdimNC, nDFdim, MXdim , NAMdim, UNIdim, VALdim,
+ & MX_var, NtotNC, nameNC, SdimNC, unitNC, lnamNC,
+ & NattNC, NAMrat, NvatNC,
+ & ID__nc)
+C + **************
+
+
+C +--Write Time - Constants
+C + ~~~~~~~~~~~~~~~~~~~~~~
+
+C + ************
+ CALL UNwrite (ID__nc, 'LON ', 1 , nx , ny, 1 , Longit)
+ CALL UNwrite (ID__nc, 'LAT ', 1 , nx , ny, 1 , Latitu)
+ CALL UNwrite (ID__nc, 'ANT1km', 1 , nx , ny, 1 , OroOBS)
+c #2D CALL UNwrite (ID__nc, 'sh_MAR', 1 , nx , ny, 1 , OroSIM)
+ CALL UNwrite (ID__nc, 'SOL ', 1 , nx , ny, 1 , SolTyp)
+C + ************
+
+
+C +--Re-Open file if already created.
+C + ================================
+
+
+ ELSE
+
+C + ************
+ CALL UNwopen (fnamNC,ID__nc)
+C + ************
+
+ END IF
+
+
+C +--Write Time-dependent variables:
+C + ===============================
+
+
+C +--UNLIMITED Time Dimension
+C + ------------------------
+
+ IF (nDFdim(0).eq.0) THEN !
+ starta = (351+(iyrrGE -1902) *365 ! Nb Days before iyrrGE
+ . +(iyrrGE -1901) / 4 ! Nb Leap Years
+ . + njyrGE(mmarGE) ! Nb Days before mmarGE
+ . + njybGE(mmarGE) ! (including Leap Day)
+ . *max(0,1-mod(iyrrGE,4)) !
+ . + jdarGE -1 )* 24 !
+ . +jhurGE !
+ . + (minuGE *60 +jsecGE )/3600.!
+
+C + ************
+ CALL UNwrite (ID__nc, 'time ',iprint, 1, 1, 1, starta)
+C + ************
+
+ END IF
+
+
+C + ************
+c #3D CALL UNwrite (ID__nc,lxyz_0,iprint,nx,ny,nz , fxyz_0)
+c #3D CALL UNwrite (ID__nc,lxyz_1,iprint,nx,ny,nz , fxyz_1)
+c #3D CALL UNwrite (ID__nc,lxyz_2,iprint,nx,ny,nz , fxyz_2)
+c #3D CALL UNwrite (ID__nc,lxyz_3,iprint,nx,ny,nz , fxyz_3)
+c #3D CALL UNwrite (ID__nc,lxyz_4,iprint,nx,ny,nz , fxyz_4)
+c #3D CALL UNwrite (ID__nc,lxyz_5,iprint,nx,ny,nz , fxyz_5)
+c #3D CALL UNwrite (ID__nc,lxyz_6,iprint,nx,ny,nz , fxyz_6)
+c #3D CALL UNwrite (ID__nc,lxyz_7,iprint,nx,ny,nz , fxyz_7)
+c #3D CALL UNwrite (ID__nc,lxyz_8,iprint,nx,ny,nz , fxyz_8)
+c #3D CALL UNwrite (ID__nc,lxyz_9,iprint,nx,ny,nz , fxyz_9)
+c #3D CALL UNwrite (ID__nc,lxyw_0,iprint,nx,ny,nw , fxyw_0)
+c #3D CALL UNwrite (ID__nc,lxyw_1,iprint,nx,ny,nw , fxyw_1)
+c #3D CALL UNwrite (ID__nc,lxyw_2,iprint,nx,ny,nw , fxyw_2)
+c #3D CALL UNwrite (ID__nc,lxyw_3,iprint,nx,ny,nw , fxyw_3)
+c #3D CALL UNwrite (ID__nc,lxyw_4,iprint,nx,ny,nw , fxyw_4)
+c #3D CALL UNwrite (ID__nc,lxyw_5,iprint,nx,ny,nw , fxyw_5)
+c #3D CALL UNwrite (ID__nc,lxyw_6,iprint,nx,ny,nw , fxyw_6)
+c #3D CALL UNwrite (ID__nc,lxyw_7,iprint,nx,ny,nw , fxyw_7)
+c #3D CALL UNwrite (ID__nc,lxyw_8,iprint,nx,ny,nw , fxyw_8)
+c #3D CALL UNwrite (ID__nc,lxyw_9,iprint,nx,ny,nw , fxyw_9)
+C + ************
+
+
+C +--That 's all, folks: NetCDF File Closure
+C + =======================================
+
+C + ***********
+ CALL NCCLOS (ID__nc,RCODE)
+C + ***********
+
+
+ return
+ end
diff --git a/MAR/code_nestor/src/for2cdf.inc b/MAR/code_nestor/src/for2cdf.inc
new file mode 100644
index 0000000000000000000000000000000000000000..0f8b1f9f7e0f08318950773d6fc15eb9d14ecc69
--- /dev/null
+++ b/MAR/code_nestor/src/for2cdf.inc
@@ -0,0 +1,40 @@
+C + BEGIN for2cdf.inc
+ integer nx ,ny ,nz ,nw
+ parameter(nx=5501,ny=4501,nz=001,nw=100)
+ real x_axis(nx )
+ real y_axis( ny)
+ real z_axis( nz)
+ real w_axis( nw)
+ real Longit(nx,ny)
+ real Latitu(nx,ny)
+ real OroOBS(nx,ny)
+c #2D real OroSIM(nx,ny)
+ real SolTyp(nx,ny)
+c #3D real fxyz_0(nx,ny,nz)
+c #3D real fxyz_1(nx,ny,nz)
+c #3D real fxyz_2(nx,ny,nz)
+c #3D real fxyz_3(nx,ny,nz)
+c #3D real fxyz_4(nx,ny,nz)
+c #3D real fxyz_5(nx,ny,nz)
+c #3D real fxyz_6(nx,ny,nz)
+c #3D real fxyz_7(nx,ny,nz)
+c #3D real fxyz_8(nx,ny,nz)
+c #3D real fxyz_9(nx,ny,nz)
+c #3D real fxyw_0(nx,ny,nw)
+c #3D real fxyw_1(nx,ny,nw)
+c #3D real fxyw_2(nx,ny,nw)
+c #3D real fxyw_3(nx,ny,nw)
+c #3D real fxyw_4(nx,ny,nw)
+c #3D real fxyw_5(nx,ny,nw)
+c #3D real fxyw_6(nx,ny,nw)
+c #3D real fxyw_7(nx,ny,nw)
+c #3D real fxyw_8(nx,ny,nw)
+c #3D real fxyw_9(nx,ny,nw)
+ common /for2cdf_var/x_axis,y_axis,z_axis,w_axis
+ . ,Longit,Latitu,OroOBS
+c #3D. ,OroSIM,SolTyp
+c #3D. ,fxyz_0,fxyz_1,fxyz_2,fxyz_3,fxyz_4
+c #3D. ,fxyz_5,fxyz_6,fxyz_7,fxyz_8,fxyz_9
+c #3D. ,fxyw_0,fxyw_1,fxyw_2,fxyw_3,fxyw_4
+c #3D. ,fxyw_5,fxyw_6,fxyw_7,fxyw_8,fxyw_9
+C + END for2cdf.inc
diff --git a/MAR/code_nestor/src/for2nc.f b/MAR/code_nestor/src/for2nc.f
new file mode 100644
index 0000000000000000000000000000000000000000..07b784a699669b4b41dbf1a9b85e34aa4e169964
--- /dev/null
+++ b/MAR/code_nestor/src/for2nc.f
@@ -0,0 +1,365 @@
+ subroutine for2nc(iprint,nprint,ID__nc
+ . ,iyrrGE,mmarGE,jdarGE,jhurGE,minuGE,jsecGE
+ . ,x_unit,y_unit,z_unit,w_unit
+ . ,lxyz_0,lxyz_1,lxyz_2,lxyz_3,lxyz_4
+ . ,lxyz_5,lxyz_6,lxyz_7,lxyz_8,lxyz_9
+ . ,lxyw_0,lxyw_1,lxyw_2,lxyw_3,lxyw_4
+ . ,lxyw_5,lxyw_6,lxyw_7,lxyw_8,lxyw_9
+ . ,filnam,title ,fildat)
+
+C +------------------------------------------------------------------------+
+C | MAR OUTPUT 03-02-2005 MAR |
+C | SubRoutine for2nc is used to write x-D OUTPUTS |
+C | on a NetCDF file |
+C | |
+C +------------------------------------------------------------------------+
+C | |
+C | INPUT: iprint: Current time step number |
+C | ^^^^^^ (starting from iprint=1, which => new file creation) |
+C | nprint: Total 'time slices' number (max value of iprint) |
+C | iyrrGE: Year |
+C | mmarGE: Month |
+C | jdarGE: Day |
+C | jhurGE: Hour [UT] |
+C | minuGE: Minute |
+C | jsecGE: Second |
+C | x_unit,y_unit,z_unit,w_unit : x, y, z, w axes unities |
+C | lxyz_0,lxyz_1,lxyz_2,lxyz_3,lxyz_4: variables attributes |
+C | lxyz_5,lxyz_6,lxyz_7,lxyz_8,lxyz_9: variables attributes |
+C | lxyw_0,lxyw_1,lxyw_2,lxyw_3,lxyw_4: variables attributes |
+C | lxyw_5,lxyw_6,lxyw_7,lxyw_8,lxyw_9: variables attributes |
+C | filnam: 1st Label of the OUTPUT File Name |
+C | title : Title of the OUTPUT File |
+C | fildat: Table of Variables of the OUTPUT File |
+C | |
+C | INPUT(via for2nc.inc): OUTPUT dimensions |
+C | ^^^^^^ OUTPUT variables |
+C | |
+C | OUTPUT: NetCDF File adapted to IDL Graphic Software |
+C | ^^^^^^ |
+C | |
+C | CAUTION: 1) This Routine requires the usual NetCDF library, |
+C | ^^^^^^^^ and the complementary access library 'libUN.a' |
+C | |
+C +------------------------------------------------------------------------+
+
+
+ IMPLICIT NONE
+
+
+C +--General Variables
+C + =================
+
+ include 'NSTdim.inc'
+ include 'for2nc.inc'
+
+ integer iprint,nprint,ID__nc
+ integer iyrrGE,mmarGE,jdarGE,jhurGE,minuGE,jsecGE
+
+ character*20 filnam
+ character*90 title
+ character*31 x_unit,y_unit,z_unit,w_unit
+ character*10 fildat
+
+ character*7 lxyz_0,lxyz_1,lxyz_2,lxyz_3,lxyz_4
+ character*7 lxyz_5,lxyz_6,lxyz_7,lxyz_8,lxyz_9
+ character*7 lxyw_0,lxyw_1,lxyw_2,lxyw_3,lxyw_4
+ character*7 lxyw_5,lxyw_6,lxyw_7,lxyw_8,lxyw_9
+
+
+C +--Local Variables
+C + =================
+
+ integer mzz,i,j,k
+ PARAMETER (mzz = mz+1)
+
+ integer njmoGE(0:12),njmbGE(0:12)
+ integer njyrGE(0:12),njybGE(0:12)
+
+ integer Lfnam, Ltit, Luni, Lnam, Llnam
+ PARAMETER (Lfnam= 40, Ltit= 90, Luni= 31, Lnam= 13, Llnam=50)
+C +...Length of char strings
+
+ CHARACTER*(Lfnam) fnamNC
+ common/for2nc_loc/ fnamNC
+C +... fnamNC: To retain file name.
+
+ integer NdimNC
+ PARAMETER (NdimNC = 5)
+C +...Number of defined spatial dimensions (exact)
+
+ integer MXdim
+ PARAMETER (MXdim = 6000)
+C +...Maximum Number of all dims: recorded Time Steps
+C + and also maximum of spatial grid points for each direction.
+
+ integer MX_var
+ PARAMETER (MX_var = 80)
+C +...Maximum Number of Variables
+
+ integer NattNC
+ PARAMETER (NattNC = 2)
+C +...Number of REAL attributes given to all variables
+
+ INTEGER RCODE
+
+ integer jourNC(MXdim)
+ integer moisNC(MXdim)
+ real yearNC(MXdim)
+ real dateNC(MXdim)
+ real timeNC(MXdim)
+ common/OUT2nc_r/ yearNC,dateNC
+ real VALdim(MXdim,0:NdimNC)
+ integer nDFdim( 0:NdimNC)
+ common/OUT2nc_d/ nDFdim
+ integer NvatNC(NattNC)
+ CHARACTER*(Lnam) NAMdim( 0:NdimNC)
+ CHARACTER*(Luni) UNIdim( 0:NdimNC)
+ CHARACTER*(Lnam) SdimNC(4,MX_var)
+ CHARACTER*(Luni) unitNC(MX_var)
+ CHARACTER*(Lnam) nameNC(MX_var)
+ CHARACTER*(Llnam) lnamNC(MX_var)
+ CHARACTER*(Ltit ) tit_NC
+ CHARACTER*(Lnam) NAMrat(NattNC)
+c #TC CHARACTER*9 labelc
+ CHARACTER*120 tmpINP
+
+ integer m10 , jd10 ,jd1
+ integer MMXstp,it ,mois ,mill ,iu
+ integer itotNC,NtotNC
+ real starta(1)
+
+ data njmoGE ! Nb of Days
+ . /0,31,28,31,30, 31, 30, 31, 31, 30, 31, 30, 31/ ! in each Month
+ data njmbGE ! Leap Year
+ . /0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ ! Correction
+ data njyrGE ! Nb of Days
+ . /0, 0,31,59,90,120,151,181,212,243,273,304,334/ ! since 1st Jan
+ data njybGE ! Leap Year
+ . /0, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1/ ! Correction
+
+
+C +--NetCDF File Initialization
+C + ==========================
+
+
+ IF (iprint.eq.1) THEN
+
+
+C +--Output File Label
+C + -----------------
+
+ fnamNC = filnam
+
+
+C +--Output Title
+C + ------------
+
+ tit_NC = title
+
+
+C +--Create File / Write Constants
+C + -----------------------------
+ MMXstp = MXdim
+C +... To check array bounds... silently
+
+C +--Time Variable (hour)
+C + ~~~~~~~~~~~~~~~~~~~~
+
+C +... To define a NetCDF dimension (size, name, unit):
+c _UL nDFdim(0)= nprint
+ nDFdim(0)= 0
+ NAMdim(0)= 'time'
+ UNIdim(0)= 'HOURS since 1901-01-15 00:00:00'
+
+C +... Check temporary arrays: large enough ?
+ IF (nprint.gt.MMXstp)
+ & STOP '*** for_2D - ERROR : MXdim to low ***'
+
+
+C +--Define horizontal spatial dimensions :
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+C +... Check temporary arrays: large enough ?
+ IF ( mx .gt.MMXstp.or.my.gt.MMXstp
+ & .or.mzz.gt.MMXstp.or.mw.gt.MMXstp)
+ & STOP '*** for_2D - ERROR : MXdim to low ***'
+
+C +...To define NetCDF dimensions (size, name, unit):
+
+ DO i = 1, mx
+ VALdim(i,1) = x__MAR(i)
+ END DO
+ nDFdim(1) = mx
+ NAMdim(1) = 'x'
+ UNIdim(1) = x_unit
+
+ DO j = 1, my
+ VALdim(j,2) = y__MAR(j)
+ END DO
+ nDFdim(2) = my
+ NAMdim(2) = 'y'
+ UNIdim(2) = y_unit
+
+ do k = 1, mz
+ VALdim(1,3) = z__MAR(k)
+ enddo
+ nDFdim(3) = mz
+ NAMdim(3) = 'level'
+ UNIdim(3) = z_unit
+C +... For levels k
+
+ do k = 1, mz
+ VALdim(k,4) = z__MAR(k)
+ enddo
+ nDFdim(4) = mz
+ NAMdim(4) = 'level2'
+ UNIdim(4) = z_unit
+C +... For levels k+1/2
+
+ do k = 1, mw
+ VALdim(k,5) = w__MAR(k)
+ enddo
+ nDFdim(5) = mw
+ NAMdim(5) = 'sector'
+ UNIdim(5) = w_unit
+C +... For Surface Sectors
+
+C +--Variable's Choice (Table xxxxxx.dat)
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ OPEN(unit=10,status='unknown',file=fildat)
+
+ itotNC = 0
+ 980 CONTINUE
+ READ (10,'(A120)',end=990) tmpINP
+ IF (tmpINP(1:4).eq.' ') THEN
+ itotNC = itotNC + 1
+ READ (tmpINP,'(4x,5A9,A12,A50)')
+ & nameNC(itotNC) ,SdimNC(1,itotNC),SdimNC(2,itotNC),
+ & SdimNC(3,itotNC),SdimNC(4,itotNC),
+ & unitNC(itotNC) ,lnamNC(itotNC)
+C +... nameNC: Name
+C + SdimNC: Names of Selected Dimensions (max.4/variable)
+C + unitNC: Units
+C + lnamNC: Long_name, a description of the variable
+
+ ENDIF
+ GOTO 980
+ 990 CONTINUE
+
+ CLOSE(unit=10)
+
+ NtotNC = itotNC
+C +... NtotNC : Total number of variables writen in NetCDF file.
+
+C +--List of NetCDF attributes given to all variables:
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+C +... The "actual_range" is the (min,max)
+C + of all data for each variable:
+ NAMrat(1) = 'actual_range'
+ NvatNC(1) = 2
+
+C +... The "[var]_range" is NOT of attribute type,
+C + it is a true variable containing the (min,max) for
+C + each level, for 4D (space+time) variables only
+C + (automatic handling by UN library;
+C + must be the LAST attribute)
+ NAMrat(NattNC) = '[var]_range'
+ NvatNC(NattNC) = 2
+
+C +--Automatic Generation of the NetCDF File Structure
+C + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+C + **************
+ CALL UNscreate (fnamNC, tit_NC,
+ & NdimNC, nDFdim, MXdim , NAMdim, UNIdim, VALdim,
+ & MX_var, NtotNC, nameNC, SdimNC, unitNC, lnamNC,
+ & NattNC, NAMrat, NvatNC,
+ & ID__nc)
+C + **************
+
+
+C +--Write Time - Constants
+C + ~~~~~~~~~~~~~~~~~~~~~~
+
+C + ************
+ CALL UNwrite (ID__nc, 'LON ', 1 , mx , my, 1 , LonMAR)
+ CALL UNwrite (ID__nc, 'LAT ', 1 , mx , my, 1 , LatMAR)
+ CALL UNwrite (ID__nc, 'ANTxkm', 1 , mx , my, 1 , OroMAR)
+ CALL UNwrite (ID__nc, 'z0_oro', 1 , mx , my, 1 , Oro_z0)
+ CALL UNwrite (ID__nc, 'SOL ', 1 , mx , my, 1 , SolMAR)
+C + ************
+
+
+C +--Re-Open file if already created.
+C + ================================
+
+
+ ELSE
+
+C + ************
+ CALL UNwopen (fnamNC,ID__nc)
+C + ************
+
+ END IF
+
+
+C +--Write Time-dependent variables:
+C + ===============================
+
+
+C +--UNLIMITED Time Dimension
+C + ------------------------
+
+ IF (nDFdim(0).eq.0) THEN !
+ starta = (351+(iyrrGE -1902) *365 ! Nb Days before iyrrGE
+ . +(iyrrGE -1901) / 4 ! Nb Leap Years
+ . + njyrGE(mmarGE) ! Nb Days before mmarGE
+ . + njybGE(mmarGE) ! (including Leap Day)
+ . *max(0,1-mod(iyrrGE,4)) !
+ . + jdarGE -1 )* 24 !
+ . +jhurGE !
+ . + (minuGE *60 +jsecGE )/3600.!
+
+C + ************
+ CALL UNwrite (ID__nc, 'time ',iprint, 1, 1, 1, starta)
+C + ************
+
+ END IF
+
+
+C + ************
+c #3D CALL UNwrite (ID__nc,lxyz_0,iprint,mx,my,mz , gxyz_0)
+c #3D CALL UNwrite (ID__nc,lxyz_1,iprint,mx,my,mz , gxyz_1)
+c #3D CALL UNwrite (ID__nc,lxyz_2,iprint,mx,my,mz , gxyz_2)
+c #3D CALL UNwrite (ID__nc,lxyz_3,iprint,mx,my,mz , gxyz_3)
+c #3D CALL UNwrite (ID__nc,lxyz_4,iprint,mx,my,mz , gxyz_4)
+c #3D CALL UNwrite (ID__nc,lxyz_5,iprint,mx,my,mz , gxyz_5)
+c #3D CALL UNwrite (ID__nc,lxyz_6,iprint,mx,my,mz , gxyz_6)
+c #3D CALL UNwrite (ID__nc,lxyz_7,iprint,mx,my,mz , gxyz_7)
+c #3D CALL UNwrite (ID__nc,lxyz_8,iprint,mx,my,mz , gxyz_8)
+c #3D CALL UNwrite (ID__nc,lxyz_9,iprint,mx,my,mz , gxyz_9)
+c #3D CALL UNwrite (ID__nc,lxyw_0,iprint,mx,my,mw , gxyw_0)
+c #3D CALL UNwrite (ID__nc,lxyw_1,iprint,mx,my,mw , gxyw_1)
+c #3D CALL UNwrite (ID__nc,lxyw_2,iprint,mx,my,mw , gxyw_2)
+c #3D CALL UNwrite (ID__nc,lxyw_3,iprint,mx,my,mw , gxyw_3)
+c #3D CALL UNwrite (ID__nc,lxyw_4,iprint,mx,my,mw , gxyw_4)
+c #3D CALL UNwrite (ID__nc,lxyw_5,iprint,mx,my,mw , gxyw_5)
+c #3D CALL UNwrite (ID__nc,lxyw_6,iprint,mx,my,mw , gxyw_6)
+c #3D CALL UNwrite (ID__nc,lxyw_7,iprint,mx,my,mw , gxyw_7)
+c #3D CALL UNwrite (ID__nc,lxyw_8,iprint,mx,my,mw , gxyw_8)
+c #3D CALL UNwrite (ID__nc,lxyw_9,iprint,mx,my,mw , gxyw_9)
+C + ************
+
+
+C +--That 's all, folks: NetCDF File Closure
+C + =======================================
+
+C + ***********
+ CALL NCCLOS (ID__nc,RCODE)
+C + ***********
+
+
+ return
+ end
diff --git a/MAR/code_nestor/src/for2nc.inc b/MAR/code_nestor/src/for2nc.inc
new file mode 100644
index 0000000000000000000000000000000000000000..8253605e2a0a44b3def1b1bee708900a6c67b004
--- /dev/null
+++ b/MAR/code_nestor/src/for2nc.inc
@@ -0,0 +1,37 @@
+C + BEGIN for2nc.inc
+ real x__MAR(mx )
+ real y__MAR( my)
+ real z__MAR( mz)
+ real w__MAR( mw)
+ real LonMAR(mx,my)
+ real LatMAR(mx,my)
+ real OroMAR(mx,my)
+ real Oro_z0(mx,my)
+ real SolMAR(mx,my)
+c #3D real gxyz_0(mx,my,mz)
+c #3D real gxyz_1(mx,my,mz)
+c #3D real gxyz_2(mx,my,mz)
+c #3D real gxyz_3(mx,my,mz)
+c #3D real gxyz_4(mx,my,mz)
+c #3D real gxyz_5(mx,my,mz)
+c #3D real gxyz_6(mx,my,mz)
+c #3D real gxyz_7(mx,my,mz)
+c #3D real gxyz_8(mx,my,mz)
+c #3D real gxyz_9(mx,my,mz)
+c #3D real gxyw_0(mx,my,mw)
+c #3D real gxyw_1(mx,my,mw)
+c #3D real gxyw_2(mx,my,mw)
+c #3D real gxyw_3(mx,my,mw)
+c #3D real gxyw_4(mx,my,mw)
+c #3D real gxyw_5(mx,my,mw)
+c #3D real gxyw_6(mx,my,mw)
+c #3D real gxyw_7(mx,my,mw)
+c #3D real gxyw_8(mx,my,mw)
+c #3D real gxyw_9(mx,my,mw)
+ common /for2nc_var/x__MAR,y__MAR,z__MAR,w__MAR
+ . ,LonMAR,LatMAR,OroMAR,Oro_z0,SolMAR
+c #3D. ,gxyz_0,gxyz_1,gxyz_2,gxyz_3,gxyz_4
+c #3D. ,gxyz_5,gxyz_6,gxyz_7,gxyz_8,gxyz_9
+c #3D. ,gxyw_0,gxyw_1,gxyw_2,gxyw_3,gxyw_4
+c #3D. ,gxyw_5,gxyw_6,gxyw_7,gxyw_8,gxyw_9
+C + END for2nc.inc
diff --git a/MAR/code_nestor/src/intBic.f b/MAR/code_nestor/src/intBic.f
new file mode 100644
index 0000000000000000000000000000000000000000..e9f913721298bf00683e76a40afeca015501cb63
--- /dev/null
+++ b/MAR/code_nestor/src/intBic.f
@@ -0,0 +1,325 @@
+C +-------------------------------------------------------------------+
+C | Subroutine bicSet 10-05-2022 JFG |
+C +-------------------------------------------------------------------+
+C | |
+C | Pre-computes the data for bicubic interpolation, i.e., finds for |
+C | each NST cell the closest 4x4 square found in the LSC domain. |
+C | |
+C | Input : with dimensions provided by NSTdim.inc: |
+C | ^^^^^^^ grd_Ix (ni) : Input grid points position x(i) |
+C | grd_Iy (nj) : " " " " y(j) |
+C | grd_Ox (mx, my) : Output grid positions x(i,j) |
+C | grd_Oy (mx, my) : Output grid positions y(i,j) |
+C | |
+C | Output: stored via intBic.inc: |
+C | ^^^^^^^ bicNb : Number of useful sampling points for O(i,j) (in |
+C | practice, 1 or 16, 1 being used if LSC grid is |
+C | 4x4 or smaller) |
+C | bicSqr (mx, my, 2) : For each NST point, stores the |
+C | indexes in the LSC grid of the top |
+C | left cell of the sampling square |
+C | (4x4 region in the LSC grid). If |
+C | bicNb is set to 1, this will be the |
+C | sole cell used by the interpolation. |
+C | |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE bicSet (grd_Ix, grd_Iy, grd_Ox, grd_Oy)
+
+ IMPLICIT NONE
+
+ INCLUDE 'NSTdim.inc' ! Dimensions of LSC and NST domains
+ INCLUDE 'intBic.inc' ! To save interpolation data
+
+ INTEGER i,j,k,l,imin,jmin,sqimin,sqimax,sqjmin,sqjmax,corner
+ REAL grd_Ix(ni),grd_Iy(nj),grd_Ox(mx,my),grd_Oy(mx,my),
+ . tmp_Ix(ni),tmp_Iy(nj),dist,curDst,minDst,dists(4),crnDst
+ LOGICAL border
+
+ border = .false.
+
+ IF ((ni.le.4).or.(nj.le.4)) THEN
+ bicNb = 1
+ ELSE
+ bicNb = 16
+ ENDIF
+
+ ! For each NST pixel
+ DO i=1,mx; DO j=1,my
+
+ ! Finds closest LSC pixel
+ minDst = 10000.
+ DO k=1,ni; DO l=1,nj
+
+ curDst = dist(grd_Ix(k),grd_Iy(l),grd_Ox(i,j),grd_Oy(i,j))
+ IF (curDst.lt.minDst) THEN
+
+ minDst = curDst
+ imin = k
+ jmin = l
+
+ END IF
+
+ ENDDO; ENDDO
+
+ ! Extreme case: very small grid (unlikely), uses closest pixel
+ IF (bicNb.eq.1) THEN
+
+ bicSqr(i,j,1) = imin
+ bicSqr(i,j,2) = jmin
+
+ ELSE
+
+ ! Important remark for the next instructions: the closest
+ ! pixel is by default considered to be the bottom right pixel
+ ! of the top left 2x2. I.e. (- = pixel, x = closest pixel):
+ !
+ ! - - - -
+ ! - x - -
+ ! - - - -
+ ! - - - -
+
+ ! Evaluates if encompassing 4x4 crosses borders of LSC grid.
+ sqimin = imin-1
+ sqimax = imin+2
+ sqjmin = jmin-1
+ sqjmax = jmin+2
+
+ IF (sqimin.lt.1.or.sqimax.gt.ni.or.
+ . sqjmin.lt.1.or.sqjmax.gt.nj) THEN
+ border = .true.
+ ENDIF
+
+ IF (sqimin.lt.1) THEN
+ sqimin = sqimin+1
+ ELSE IF (sqimax.gt.ni) THEN
+ sqimin = sqimin-(sqimax-ni)
+ ENDIF
+
+ IF (sqjmin.lt.1) THEN
+ sqjmin = sqjmin+1
+ ELSE IF (sqjmax.gt.nj) THEN
+ sqjmin = sqjmin-(sqjmax-nj)
+ ENDIF
+
+ ! If 4x4 initially crossed borders or is right next to them
+ IF (border.or.sqimin.eq.1.or.sqjmin.eq.1) THEN
+
+ ! Saves top left corner of the resulting 4x4 square
+ bicSqr(i,j,1) = sqimin
+ bicSqr(i,j,2) = sqjmin
+
+ ! Else, finds the closest corner of the encompassing 5x5
+ ELSE
+
+ ! 1 = top left, 2 = top right, 3 = bot right, 4 = bot left
+ dists(1) = dist(grd_Ix(sqimin-1),grd_Iy(sqjmin-1),
+ . grd_Ox(i,j),grd_Oy(i,j))
+ dists(2) = dist(grd_Ix(sqimax),grd_Iy(sqjmin-1),
+ . grd_Ox(i,j),grd_Oy(i,j))
+ dists(3) = dist(grd_Ix(sqimax),grd_Iy(sqjmax),
+ . grd_Ox(i,j),grd_Oy(i,j))
+ dists(4) = dist(grd_Ix(sqimin-1),grd_Iy(sqjmax),
+ . grd_Ox(i,j),grd_Oy(i,j))
+
+ ! Finds closest corner to adjust sqimin,sqjmin
+ corner = 1
+ crnDst = dists(1)
+
+ DO k=2,4
+
+ IF (dists(k).lt.crnDst) THEN
+
+ corner = k
+ crnDst = dists(k)
+
+ ENDIF
+
+ ENDDO
+
+ ! Adjusts sqimin, sqjmin based on the closest corner
+ IF (corner.eq.1) THEN
+
+ sqimin = sqimin-1
+ sqjmin = sqjmin-1
+
+ ELSE IF (corner.eq.2) THEN
+ sqjmin = sqjmin-1
+ ELSE IF (corner.eq.4) THEN
+ sqimin = sqimin-1
+ ENDIF
+
+ ! Saves top left corner of the final 4x4 square
+ bicSqr(i,j,1) = sqimin
+ bicSqr(i,j,2) = sqjmin
+
+ ENDIF
+
+ ENDIF
+
+ ENDDO; ENDDO
+
+ RETURN
+ END
+
+C +-------------------------------------------------------------------+
+C | Subroutine bicDo 10-05-2022 JFG |
+C +-------------------------------------------------------------------+
+C | |
+C | Performs the bicubic interpolation with the 4x4 sampling square |
+C | that has previously been precomputed for each O(i,j) by bicSet. |
+C | |
+C | Input : with dimensions provided by NSTdim.inc: |
+C | ^^^^^^^ grd_Ix (ni) : Input grid points position x(i) |
+C | grd_Iy (nj) : " " " " y(j) |
+C | var_I (ni, nj) : Input field values |
+C | grd_Ox (mx, my) : Output grid positions x(i,j) |
+C | grd_Oy (mx, my) : Output grid positions y(i,j) |
+C | bicNb : Number of sampling points (from bicSet; integer) |
+C | bicSqr (mx, my, 2) : Indexes of the top left corner of |
+C | the 4x4 sampling square (in LSC |
+C | grid) as selected by bicSet |
+C | The last two are provided by intBic.inc. |
+C | |
+C | Output: var_O (mx, my) : Output field values |
+C | ^^^^^^^ |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE bicDo (grd_Ix, grd_Iy, var_I, grd_Ox, grd_Oy, var_O)
+
+ IMPLICIT NONE
+
+ INCLUDE 'NSTdim.inc' ! Dimensions of LSC and NST domains
+ INCLUDE 'intBic.inc' ! Buffered interpolation data
+
+ INTEGER i,j,k,l
+ REAL grd_Ix(ni),grd_Iy(nj),var_I(ni,nj),
+ . grd_Ox(mx,my),grd_Oy(mx,my),var_O(mx,my),
+ . axLon(4), axLat(4), square(4,4), coeffs(4,4)
+
+ ! For each NST pixel
+ DO i=1,mx; DO j=1,my
+
+ IF (bicNb.eq.1) THEN
+ var_O(i,j) = var_I(bicSqr(i,j,1),bicSqr(i,j,2))
+ ELSE
+
+ ! Buffers longitudes, latitudes, values
+ DO k=1,4
+ axLon(k) = grd_Ix(bicSqr(i,j,1)+k-1)
+ ENDDO
+
+ DO k=1,4
+ axLat(k) = grd_Iy(bicSqr(i,j,2)+k-1)
+ ENDDO
+
+ DO k=1,4; DO l=1,4
+ square(k,l) = var_I(bicSqr(i,j,1)+k-1,bicSqr(i,j,2)+l-1)
+ ENDDO; ENDDO
+
+ ! Inverts data to comply with Numerical Recipes requirements.
+ ! I.e., x(1) < x(2) < ... => revert if necessary.
+
+C +---Revert axLon (1) <--> axLon (4) ?
+C + ---------------------------------
+
+ IF (axLon(4).lt.axLon(1)) THEN
+ DO k=1,4
+ DO l=1,4
+ square(k,l)=square(4-k+1,l)
+ ENDDO
+ axLon(k)=axLon(4-k+1)
+ ENDDO
+ ENDIF
+
+C +---Revert axLat (1) <--> axLat (4) ?
+C + ---------------------------------
+
+ IF (axLat(4).lt.axLat(1)) THEN
+ DO l=1,4
+ DO k=1,4
+ square(k,l)=square(k,4-l+1)
+ ENDDO
+ axLat(l)=axLat(4-l+1)
+ ENDDO
+ ENDIF
+
+ ! Performs the bicubic interpolation on the 4x4 sampling square
+ CALL SPLIE2(axLon,axLat,square,4,4,coeffs)
+ CALL SPLIN2(axLon,axLat,square,coeffs,4,4,
+ . grd_Ox(i,j),grd_Oy(i,j),var_O(i,j))
+
+ ENDIF
+
+ ENDDO; ENDDO
+
+ RETURN
+ END
+
+C +--------------------------------------------------------------+
+C | * From numerical recipes (H. Press et al., 1992) |
+C +--------------------------------------------------------------+
+
+ SUBROUTINE SPLIE2(X1A,X2A,YA,M,N,Y2A)
+
+ PARAMETER (NN=4)
+C +...NN = max value allowed for N (for 1D arrays only -> overdim.)
+
+ DIMENSION X1A(M),X2A(N),YA(M,N),Y2A(M,N)
+ DIMENSION YTMP(NN),Y2TMP(NN)
+
+ DO 13 J=1,M
+
+ DO 11 K=1,N
+ YTMP(K)=YA(J,K)
+11 CONTINUE
+
+C + ******
+ CALL SPLINE(X2A,YTMP,N,1.E30,1.E30,Y2TMP)
+C + ******
+C +... NB : 1.E30 = switch value to select "natural" bicub spline
+
+ DO 12 K=1,N
+ Y2A(J,K)=Y2TMP(K)
+12 CONTINUE
+
+13 CONTINUE
+
+ RETURN
+ END
+
+C +--------------------------------------------------------------+
+C | * From numerical recipes (H. Press et al., 1992) |
+C +--------------------------------------------------------------+
+
+ SUBROUTINE SPLIN2(X1A,X2A,YA,Y2A,M,N,X1,X2,Y)
+
+ PARAMETER (NN=4)
+C + NN = max value allowed for N (for 1D arrays only -> overdim.)
+
+ DIMENSION X1A(M),X2A(N),YA(M,N),Y2A(M,N),YTMP(NN),Y2TMP(NN)
+ DIMENSION YYTMP(NN)
+
+ DO 12 J=1,M
+
+ DO 11 K=1,N
+
+ YTMP(K)=YA(J,K)
+ Y2TMP(K)=Y2A(J,K)
+
+11 CONTINUE
+
+C + ******
+ CALL SPLINT(X2A,YTMP,Y2TMP,N,X2,YYTMP(j))
+C + ******
+
+12 CONTINUE
+
+C + ******
+ CALL SPLINE(X1A,YYTMP,M,1.E30,1.E30,Y2TMP)
+C + ******
+ CALL SPLINT(X1A,YYTMP,Y2TMP,M,X1,Y)
+C + ******
+
+ RETURN
+ END
diff --git a/MAR/code_nestor/src/intBic.inc b/MAR/code_nestor/src/intBic.inc
new file mode 100644
index 0000000000000000000000000000000000000000..a4bfe3b200e8e269580eb17224493a8e090ea7ca
--- /dev/null
+++ b/MAR/code_nestor/src/intBic.inc
@@ -0,0 +1,20 @@
+
+C +---Buffered data for bicubic interpolation (10/05/2022 JFG)
+C + --------------------------------------------------------
+C + Additional variables used to buffer sampling data in order to
+C + speed up bicubic horizontal interpolation operations in NESTOR.
+C + The idea is to keep track of the 4x4 squares that will be used
+C + to compute the splines for each pixel during the interpolation,
+C + as the real costly operation for this mode of horizontal
+C + interpolation is to find, for each NST pixel, the square in the
+C + LSC domain that is the closest. For the sake of simplicity, only
+C + the indexes of the top-left corner pixel of each square is kept.
+C + Note also the bicNb variable, which is set to either 1 or 16,
+C + the former being an extreme situation (where the LSC grid is
+C + unusually small), much like bilNb in intBil.inc.
+
+ INTEGER bicNb ! One or 16 (4x4) square
+ INTEGER bicSqr(mx,my,2) ! Stores indexes of top-left corner
+
+ COMMON/intBic_i/bicNb,bicSqr
+
diff --git a/MAR/code_nestor/src/intBil.f b/MAR/code_nestor/src/intBil.f
new file mode 100644
index 0000000000000000000000000000000000000000..2c980530b8d904f7946b6375b315f5e2e7e4720a
--- /dev/null
+++ b/MAR/code_nestor/src/intBil.f
@@ -0,0 +1,559 @@
+C +-------------------------------------------------------------------+
+C | Subroutine bilSet 30-03-2022 JFG |
+C +-------------------------------------------------------------------+
+C | |
+C | Pre-computes data for bilinear interpolation for each NST point. |
+C | If the interpolation is repeatedly performed on grids which share |
+C | the same dimensions and positions, the sampling points and other |
+C | values can be buffered to avoid searching again said sampling |
+C | points throughout the execution of NESTOR. |
+C | |
+C | Input : with dimensions provided by NSTdim.inc: |
+C | ^^^^^^^ grd_Ix (ni) : Input grid points position x(i) |
+C | grd_Iy (nj) : " " " " y(j) |
+C | SPHgrd (T/F) : If true, spherical coordinates for |
+C | input fields |
+C | grd_Ox (mx, my) : Output grid positions x(i,j) |
+C | grd_Oy (mx, my) : Output grid positions y(i,j) |
+C | |
+C | Output: stored via intBil.inc: |
+C | ^^^^^^^ bilNb : Number of useful sampling points for O(i,j) |
+C | bilPix (mx, my, 5, 2) : 2 indexes (x and y) for each |
+C | sampling point (x then y) |
+C | bilDat (mx, my, 5, 6) : 6 values for each sampling point |
+C | of O(i,j) involved in the |
+C | interpolation (see routine end) |
+C | |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE bilSet (grd_Ix, grd_Iy, SPHgrd, grd_Ox, grd_Oy)
+
+ IMPLICIT NONE
+
+ INCLUDE 'NSTdim.inc' ! Dimensions of LSC and NST domains
+ INCLUDE 'intBil.inc'
+
+C +---General and local variables
+C + ---------------------------
+
+ ! sm = max samples
+ INTEGER sm,LocDim,mmx,mmy,icent1,jcent1,icent2,jcent2,i,j,ii,jj,
+ . p,q,is,i1(4),j1(4),i2
+ REAL dist_O,dist_I,AUXlo1,AUXlo2,AUXla1,AUXla2,dx,dy,degrad,x,y,
+ . epsi,AUXlon,MINlon,MAXlon,AUXlat,MINlat,MAXlat
+
+ PARAMETER (sm=5) ! "Sample points maximum" (number of)
+ PARAMETER (LocDim=21601) ! Dim. of local 1D arrays
+
+ REAL grd_Ix(ni),grd_Iy(nj),grd_Ox(mx,my),grd_Oy(mx,my),
+ . tmp_Ix(0:LocDim+1),tmp_Iy(0:LocDim+1),samOx(sm),
+ . samOy(sm)
+
+ LOGICAL SPHgrd
+
+C +---Data
+C + ----
+
+ DATA epsi / 1.d-4 /
+ DATA degrad / 1.745329252d-2 /
+
+C +---Check dimensions of temporary arrays
+C + ====================================
+
+ IF (ni.gt.LocDim .or. nj.gt.LocDim) THEN
+ WRITE(6,*) 'bilSet - fatal error: dimension',LocDim
+ WRITE(6,*) 'Please change LocDim - STOP'
+ STOP
+ ENDIF
+
+C +---Check if the sampling technique is required
+C + ===========================================
+
+ mmx = mx
+ mmy = my
+
+ dx =(grd_Ix(ni/2)-grd_Ix(ni/2-1))*111111.
+ . *COS(grd_Iy(nj/2)*degrad)
+ dy =(grd_Iy(nj/2)-grd_Iy(nj/2-1))*111111.
+ dist_I=SQRT(dx*dx+dy*dy)
+
+ icent1=MAX(1,mx/2)
+ icent2=MAX(1,mx/2-1)
+ jcent1=MAX(1,my/2)
+ jcent2=MAX(1,my/2-1)
+ IF (mmx.eq.2) icent1=2
+ IF (mmy.eq.2) jcent1=2
+
+ AUXlo1=grd_Ox(icent1,jcent1)
+CWARNINGXla1=grd_Oy(icent1,icent1)
+ AUXla1=grd_Oy(icent1,jcent1)
+ AUXlo2=grd_Ox(icent2,jcent2)
+ AUXla2=grd_Oy(icent2,jcent2)
+
+C + ******
+ CALL SPHERC (SPHgrd,AUXlo1,AUXla1)
+ CALL SPHERC (SPHgrd,AUXlo2,AUXla2)
+C + ******
+
+ dx =(AUXlo1-AUXlo2)*111111.*COS(AUXla1*degrad)
+ IF (mmx.le.1) dx = 1000.
+ dy =(AUXla1-AUXla2)*111111.
+ IF (mmy.le.1) dy = 1000.
+ dist_O=SQRT(dx*dx+dy*dy)
+
+ IF (dist_I.lt.dist_O) THEN
+ bilNb=sm
+ ELSE
+ bilNb=1
+ ENDIF
+
+C +---Coordinates indexes inversion (if necessary)
+C + ============================================
+
+C +---Storage in temporary arrays
+C + ---------------------------
+
+ DO ii=1,ni
+ tmp_Ix(ii)=grd_Ix(ii)
+ if(grd_Ix(ii)>180) grd_Ix(ii)=grd_Ix(ii)-360.
+ ENDDO
+
+ DO jj=1,nj
+ tmp_Iy(jj)=grd_Iy(jj)
+ ENDDO
+
+C +---Revert grd_Ix (1) <--> grd_Ix (n), ... ?
+C + ----------------------------------------
+
+ IF (grd_Ix(ni).lt.grd_Ix(1)) THEN
+ DO ii=1,ni
+ tmp_Ix(ii)=grd_Ix(ni-ii+1)
+ ENDDO
+ ENDIF
+
+C +---Revert grd_Iy (1) <--> grd_Iy (n), ... ?
+C + ----------------------------------------
+
+ IF (grd_Iy(nj).lt.grd_Iy(1)) THEN
+ DO jj=1,nj
+ tmp_Iy(jj)=grd_Iy(nj-jj+1)
+ ENDDO
+ ENDIF
+
+C +---Extended coordinates in longitude and latitude
+C + ==============================================
+
+C +---Check validity of longitude
+C + ---------------------------
+
+ IF (SPHgrd) THEN
+ IF ((tmp_Ix(1).lt.(-180.)).or.(tmp_Ix(ni).gt.180.)) THEN
+ WRITE(6,*) 'Longitudes of data fields are not between'
+ WRITE(6,*) '-180 and +180 deg. (as required by bilSet)'
+ WRITE(6,*) 'but rather between : '
+ WRITE(6,*) tmp_Ix(1),tmp_Ix(ni)
+ WRITE(6,*) '--- STOP in bilSet ---'
+ STOP
+ ENDIF
+ ENDIF
+
+C +---Extended left/right boundaries (longitude if SPHgrd)
+C + ----------------------------------------------------
+
+ tmp_Ix(0) =2.*tmp_Ix( 1)-tmp_Ix(2)
+ tmp_Ix(ni+1)=2.*tmp_Ix(ni)-tmp_Ix(ni-1)
+
+
+C +---Extended bottom/top boundaries (latitude if SPHgrd)
+C + ---------------------------------------------------
+
+ tmp_Iy(0) =2.*tmp_Iy( 1)-tmp_Iy(2)
+ tmp_Iy(nj+1)=2.*tmp_Iy(nj)-tmp_Iy(nj-1)
+
+
+C +---Define extra lower and upper boundaries (latitude)
+C + --------------------------------------------------
+
+ IF (SPHgrd) THEN ! Stereographic coordinates
+
+ IF (tmp_Iy(0).lt.(-90.))
+ . tmp_Iy(0)=MIN(-90.,tmp_Iy(1)-epsi)
+
+ IF (tmp_Iy(nj+1).gt.90.)
+ . tmp_Iy(nj+1)=MAX(90.,tmp_Iy(nj)+epsi)
+
+ ENDIF
+
+
+C +---Check the extension of the sub-domain to be read
+C ================================================
+
+ AUXlon = grd_Ox(1,1)
+ AUXlat = grd_Oy(1,1)
+C + ******
+ CALL SPHERC (SPHgrd,AUXlon,AUXlat)
+C + ******
+ MINlon = AUXlon
+ MAXlon = AUXlon
+ MINlat = AUXlat
+ MAXlat = AUXlat
+
+ DO j=1,my
+ DO i=1,mx
+ AUXlon = grd_Ox(i,j)
+ AUXlat = grd_Oy(i,j)
+C + ******
+ CALL SPHERC (SPHgrd,AUXlon,AUXlat)
+C + ******
+
+ MINlon = min(AUXlon,MINlon)
+ MAXlon = max(AUXlon,MAXlon)
+ MINlat = min(AUXlat,MINlat)
+ MAXlat = max(AUXlat,MAXlat)
+ ENDDO
+ ENDDO
+
+ IF ((tmp_Ix( 0).gt.MINlon) .or.
+ . (tmp_Ix(ni+1).lt.MAXlon) .or.
+ . (tmp_Iy( 0).gt.MINlat) .or.
+ . (tmp_Iy(nj+1).lt.MAXlat)) THEN
+ WRITE(6,*) 'Output domain is not (fully) included in'
+ WRITE(6,*) 'the input domain.'
+ WRITE(6,*) 'Input domain :'
+ WRITE(6,*) tmp_Ix(0),tmp_Ix(ni+1),tmp_Iy(0),tmp_Iy(nj+1)
+ WRITE(6,*) 'Output domain :'
+ WRITE(6,*) MINlon,MAXlon,MINlat,MAXlat
+ WRITE(6,*) '--- STOP in bilSet ---'
+ ENDIF
+
+C +---Bi-linear interpolation
+C + =======================
+
+C +---Some initialisations
+C + --------------------
+
+ p=0
+ q=0
+
+ i1(1)=-1 ; j1(1)=+1
+ i1(2)=+1 ; j1(2)=-1
+ i1(3)=-1 ; j1(3)=-1
+ i1(4)=+1 ; j1(4)=+1
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ DO i=1,mx ! LOOP on output grid-points : BEGIN
+ DO j=1,my
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+C +---Define sampling point positions
+C + -------------------------------
+
+ IF (i.ne.1.and.i.ne.mx.and.j.ne.1.and.j.ne.my) THEN
+
+ samOx(1)= grd_Ox(i,j)
+ samOy(1)= grd_Oy(i,j)
+
+ do i2=1,sm-1
+ samOx(i2+1)=0.6*grd_Ox(i,j)+0.4*grd_Ox(i+i1(i2),j+j1(i2))
+ samOy(i2+1)=0.6*grd_Oy(i,j)+0.4*grd_Oy(i+i1(i2),j+j1(i2))
+
+ if(sign(1.,grd_Ox(i,j)) .ne.
+ . sign(1.,grd_Ox(i+i1(i2),j+j1(i2))).and.
+ . abs( grd_Ox(i,j)) .ge. 170.0 ) then
+ samOx(i2+1)=grd_Ox(i,j)
+ endif
+
+ enddo
+
+ ELSE
+ DO is=1,sm ! Boundaries : no sampling
+ samOx(is)=grd_Ox(i,j)
+ samOy(is)=grd_Oy(i,j)
+ ENDDO
+ ENDIF
+
+ DO is=1,bilNb ! Loop on the sampling points: BEGIN
+
+ x=samOx(is)
+ y=samOy(is)
+
+
+C +---Check the range of latitude and longitude
+C + -----------------------------------------
+
+C + ******
+ CALL SPHERC (SPHgrd,x,y)
+C + ******
+
+C +---Search for the bottom-left corner of the surrounding mesh
+C + ---------------------------------------------------------
+
+C +...This simple method accounts for the fact that two successive
+C +...requests usually refer to neighbour points
+
+C +---Search for dimension 1 value
+C + ----------------------------
+
+ IF (tmp_Ix(p).le.x) THEN ! Search upwards
+ DO WHILE (tmp_Ix(p+1).lt.x)
+ p=p+1
+ ENDDO
+ ELSE ! Search downwards
+ DO WHILE (tmp_Ix(p).gt.x)
+ p=p-1
+ ENDDO
+ ENDIF
+
+C +---Search for dimension 2 value
+C + ----------------------------
+
+ IF (tmp_Iy(q).le.y) THEN ! Search upwards
+ DO WHILE (tmp_Iy(q+1).lt.y)
+ q=q+1
+ ENDDO
+ ELSE ! Search downwards
+ DO WHILE (tmp_Iy(q).gt.y)
+ q=q-1
+ ENDDO
+ ENDIF
+
+C +---Check the validity of p/q indexes
+C + ---------------------------------
+
+ IF ((p.lt. 0).or.(q.lt. 0).or.
+ . (p.gt.(ni+1)).or.(q.gt.(nj+1))) THEN
+ WRITE (6,*) 'Inconsistency between input and output'
+ WRITE (6,*) 'domains.'
+ WRITE (6,*) 'p and q = ',p,q
+ WRITE (6,*) '--- STOP in bilSet ---'
+ STOP
+ ENDIF
+
+C +---Storing values for the linear interpolation
+C + -------------------------------------------
+
+ bilPix(i,j,is,1) = p ! (Bottom-left) X index from input array
+ bilPix(i,j,is,2) = q ! (Bottom-left) Y index from input array
+
+ bilDat(i,j,is,1) = x ! Longitude for sampling point in O(i,j)
+ bilDat(i,j,is,2) = tmp_Ix(p) ! x0
+ bilDat(i,j,is,3) = tmp_Ix(p+1) ! x1
+ bilDat(i,j,is,4) = y ! Latitude for sampling point in O(i,j)
+ bilDat(i,j,is,5) = tmp_Iy(q) ! y0
+ bilDat(i,j,is,6) = tmp_Iy(q+1) ! y1
+
+ ENDDO ! LOOP on the sampling points: END
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ ENDDO
+ ENDDO ! Loop on output grid-points : END
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ RETURN
+ END
+
+C +-------------------------------------------------------------------+
+C | Subroutine bilDo 30-03-2022 JFG |
+C +-------------------------------------------------------------------+
+C | |
+C | Performs the bilinear interpolation with the data that has been |
+C | previously prepared by the bicSet subroutine. |
+C | |
+C | Input : grd_Ix (ni) : Input grid points position x(i) |
+C | ^^^^^^^ grd_Iy (nj) : " " " " y(j) |
+C | var_I (ni, nj) : Input field values |
+C | SPHgrd (T/F) : If true, spherical coordinates for |
+C | input fields |
+C | bilNb : Number of useful sampling points (output from |
+C | bilSet; integer) |
+C | bilPix (mx, my, 5, 2) : Indexes of sampling points |
+C | selected by bilSet |
+C | bilDat (mx, my, 5, 6) : Values precomputed by bilSet |
+C | The last three are provided by intBil.inc. |
+C | |
+C | Output: var_O (mx, my) : Output field values |
+C | ^^^^^^^ |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE bilDo (grd_Ix, grd_Iy, var_I, SPHgrd, var_O)
+
+ IMPLICIT NONE
+
+ INCLUDE 'NSTdim.inc' ! Dimensions of LSC and NST domains
+ INCLUDE 'intBil.inc'
+
+C +---General and local variables
+C + ---------------------------
+
+ INTEGER i,j,ii,jj,p,q,is,ind0,ind1,LocDim,sm
+
+ PARAMETER (sm=5) ! "Samples maximum" (number of)
+ PARAMETER (LocDim=21601) ! Dim. of local 1D arrays
+
+ REAL x,y,tmp,tmp2,x0,x1,y0,y1,epsi,AUXlon,MINlon,MAXlon,
+ . AUXlat,MINlat,MAXlat
+
+ REAL grd_Ix(ni),grd_Iy(nj),tmp_in(0:ni+1,0:nj+1),
+ . tmp_Ix(0:LocDim+1),tmp_Iy(0:LocDim+1),var_I(ni,nj),
+ . var_O(mx,my)
+
+ LOGICAL SPHgrd
+
+C +---Data
+C + ----
+
+ DATA epsi / 1.d-4 /
+
+C +---Check dimensions of temporary arrays
+C + ====================================
+
+ IF (ni.gt.LocDim .or. nj.gt.LocDim) THEN
+ WRITE(6,*) 'bilDo - fatal error: dimension',LocDim
+ WRITE(6,*) 'Please change LocDim - STOP'
+ STOP
+ ENDIF
+
+C +---Coordinates indexes inversion (if necessary)
+C + ============================================
+
+C +---Storage in temporary arrays
+C + ---------------------------
+
+ DO jj=1,nj
+ DO ii=1,ni
+ tmp_in(ii,jj)=var_I(ii,jj)
+ ENDDO
+ ENDDO
+
+C +---Revert grd_Ix (1) <--> grd_Ix (n), ... ?
+C + ----------------------------------------
+
+ IF (grd_Ix(ni).lt.grd_Ix(1)) THEN
+ DO ii=1,ni
+ DO jj=1,nj
+ tmp_in(ii,jj)=var_I(ni-ii+1, jj)
+ ENDDO
+ tmp_Ix(ii)=grd_Ix(ni-ii+1)
+ ENDDO
+ ENDIF
+
+C +---Revert grd_Iy (1) <--> grd_Iy (n), ... ?
+C + ----------------------------------------
+
+ IF (grd_Iy(nj).lt.grd_Iy(1)) THEN
+ DO jj=1,nj
+ DO ii=1,ni
+ tmp_in(ii,jj)=var_I(ii,nj-jj+1)
+ ENDDO
+ tmp_Iy(jj)=grd_Iy(nj-jj+1)
+ ENDDO
+ ENDIF
+
+C +---Extended coordinates in longitude and latitude
+C + ==============================================
+
+C +---Extended left/right boundaries (longitude if SPHgrd)
+C + ----------------------------------------------------
+
+ tmp_Ix(0) =2.*tmp_Ix( 1)-tmp_Ix(2)
+ tmp_Ix(ni+1)=2.*tmp_Ix(ni)-tmp_Ix(ni-1)
+
+C +---Extended bottom/top boundaries (latitude if SPHgrd)
+C + ---------------------------------------------------
+
+ tmp_Iy(0) =2.*tmp_Iy( 1)-tmp_Iy(2)
+ tmp_Iy(nj+1)=2.*tmp_Iy(nj)-tmp_Iy(nj-1)
+
+C +---Define the cyclic field in longitude
+C + ------------------------------------
+
+ IF (SPHgrd) THEN ! Stereographic coordinates
+
+ ind0=-1
+ ind1=-1
+
+ AUXlon=tmp_Ix(0)+360.
+ DO i=1,ni
+ IF (ABS(AUXlon-tmp_Ix(i)).lt.epsi) ind0=i
+ ENDDO
+
+ AUXlon=tmp_Ix(ni+1)-360.
+ DO i=1,ni
+ IF (ABS(AUXlon-tmp_Ix(i)).lt.epsi) ind1=i
+ ENDDO
+
+ IF (NOT(ind0.gt.(-1).and.ind1.gt.(-1))) THEN
+ ind0=ni
+ ind1= 1
+ ENDIF
+
+ ELSE ! Non spherical coordinates
+
+ ind0=ni
+ ind1= 1
+
+ ENDIF
+
+ DO j=1,nj
+ tmp_in( 0,j)=tmp_in(ind0,j)
+ tmp_in(ni+1,j)=tmp_in(ind1,j)
+ ENDDO
+
+C +---Define extra lower and upper boundaries (latitude)
+C + --------------------------------------------------
+
+ DO i=0,ni+1
+ tmp_in(i, 0)=tmp_in(i, 1)
+ tmp_in(i,nj+1)=tmp_in(i,nj)
+ ENDDO
+
+C +---Bi-linear interpolation (prepared by bilSet)
+C + ============================================
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ DO i=1,mx ! LOOP on output grid-points : BEGIN
+ DO j=1,my
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ tmp2=0.0 ! Initialisation of sum of sampled values
+
+ DO is=1,bilNb ! Loop on the sampling points: BEGIN
+
+ p = bilPix(i,j,is,1)
+ q = bilPix(i,j,is,2)
+
+ x = bilDat(i,j,is,1)
+ y = bilDat(i,j,is,4)
+ x0 = bilDat(i,j,is,2)
+ x1 = bilDat(i,j,is,3)
+ y0 = bilDat(i,j,is,5)
+ y1 = bilDat(i,j,is,6)
+
+ tmp=(x-x0)*((y-y0)*tmp_in(p+1,q+1)
+ . +(y1-y)*tmp_in(p+1,q ))
+ . +(x1-x)*((y-y0)*tmp_in(p ,q+1)
+ . +(y1-y)*tmp_in(p ,q ))
+ tmp2=tmp2+tmp/((x1-x0)*(y1-y0))
+
+ ENDDO ! LOOP on the sampling points: END
+
+C +---Output value given by the average of the samplings
+C + --------------------------------------------------
+
+ var_O(i,j)=tmp2/REAL(bilNb)
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ ENDDO
+ ENDDO ! Loop on output grid-points : END
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ RETURN
+ END
diff --git a/MAR/code_nestor/src/intBil.inc b/MAR/code_nestor/src/intBil.inc
new file mode 100644
index 0000000000000000000000000000000000000000..06e8bc60922adb1c309c15af191dd2a9a7883cd6
--- /dev/null
+++ b/MAR/code_nestor/src/intBil.inc
@@ -0,0 +1,28 @@
+
+C +---Buffered data for bilinear interpolation (25/04/2022 JFG)
+C + ---------------------------------------------------------
+C + Additional variables used to buffer sampling data in order to
+C + minimize redundant operations while performing interpolation of
+C + an input grid towards an output grid. E.g., the pixels selected
+C + at each interpolation are not supposed to change if the grids
+C + themselves don't change. Made by J.-F. Grailet.
+
+ INTEGER bilNb
+
+C +...bilNb : number of sampling points actually considered. In
+C + practice, one or five depending on the dimensions of
+C + the input grid.
+
+ INTEGER bilPix(mx,my,5,2)
+ REAL bilDat(mx,my,5,6)
+
+C +...For each (i,j) pixel of the output grid,
+C +...bilPix : 5 sets of 2 indexes corresponding to the five pixels
+C + picked in the input grid for the interpolation.
+C +...bilDat : 5 sets of 6 values corresponding to pre-computed values
+C + associated to each of the five pixels from the input
+C + grid to perform the interpolation.
+
+ COMMON/intBil_i/bilNb,bilPix
+ COMMON/intBil_r/bilDat
+
diff --git a/MAR/code_nestor/src/intMAR.f b/MAR/code_nestor/src/intMAR.f
new file mode 100644
index 0000000000000000000000000000000000000000..6a3763978759d6d3c3f9d0798d7c825139f3be23
--- /dev/null
+++ b/MAR/code_nestor/src/intMAR.f
@@ -0,0 +1,148 @@
+C +-------------------------------------------------------------------+
+C | Subroutine intMAR 31/08/2004 NESTING |
+C +-------------------------------------------------------------------+
+C | |
+C | This routine is a linear interpolation of a 2D scalar fields from |
+C | a non-regular grid to a non-regular grid. It is designed to force |
+C | MAR data on another MAR grid. |
+C | |
+C | Input : grd_Ix (ni, nj) : Input grid points position x(i,j) |
+C | ^^^^^^^ grd_Iy (ni, nj) : " " " " y(i,j) |
+C | var_I (ni, nj) : Input field values |
+C | grd_Ox (mx, my) : Output grid positions x(i,j) |
+C | grd_Oy (mx, my) : Output grid positions y(i,j) |
+C | |
+C | Output: var_O (mx, my) : Output field values |
+C | ^^^^^^^ |
+C | |
+C | J.-F. Grailet remark (28/04/2022): renamed the routine given its |
+C | practical use in NESTOR (INTnrg2 -> intMAR) and removed ni2, nj2, |
+C | mx2 and my2 (all four were unused). |
+C | |
+C +-------------------------------------------------------------------+
+
+ SUBROUTINE intMAR (grd_Ix,grd_Iy,var_I,grd_Ox,grd_Oy,var_O,
+ . pos_Ox,pos_Oy)
+
+ IMPLICIT NONE
+
+ include "NSTdim.inc"
+ include "NESTOR.inc"
+
+C +---General and local variables
+C + ---------------------------
+
+ INTEGER i,j,k,l,k1,k2,l1,l2,ii,jj
+
+ INTEGER pos_Ox(mx,my),pos_Oy(mx,my)
+
+ INTEGER ii_min(mx,my),ii_max(mx,my)
+ INTEGER jj_min(mx,my),jj_max(mx,my)
+
+ REAL grd_Ix(ni,nj),grd_Iy(ni,nj),grd_Ox(mx,my),grd_Oy(mx,my),
+ . var_I(ni,nj) ,var_O (mx,my),int_O (mx,my),nbr_meshes,epsi,
+ . delta_lat(mx,my),delta_lon(mx,my),xx,dist,dist_O
+
+ DATA epsi / 0.1 /
+
+ common/intMAR_I/ii_min,ii_max,jj_min,jj_max
+ common/intMAR_I/delta_lat,delta_lon
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ if(I_time.le.1.and.pos_Ox(mx,my).eq.0)then
+
+ ii_min = ni ; ii_max = 1
+ jj_min = nj ; jj_max = 1
+
+ DO k=1,mx
+ DO l=1,my
+
+
+ k1=max(1,min(mx,k+1))
+ k2=max(1,min(mx,k-1))
+
+ l1=max(1,min(my,l+1))
+ l2=max(1,min(my,l-1))
+
+ delta_lat(k,l)=max(abs(grd_Oy(k,l1)-grd_Oy(k,l)),
+ . abs(grd_Oy(k,l2)-grd_Oy(k,l)),
+ . abs(grd_Oy(k1,l)-grd_Oy(k,l)),
+ . abs(grd_Oy(k2,l)-grd_Oy(k,l)))
+
+ delta_lon(k,l)=max(abs(grd_Oy(k,l1)-grd_Oy(k,l)),
+ . abs(grd_Oy(k,l2)-grd_Oy(k,l)),
+ . abs(grd_Oy(k1,l)-grd_Oy(k,l)),
+ . abs(grd_Oy(k2,l)-grd_Oy(k,l)))
+
+ int_O(k,l)=0.
+
+ xx=0.05
+
+ do while (int_O(k,l).le.3.)
+
+ delta_lat(k,l)=delta_lat(k,l)*(1+xx)
+ delta_lon(k,l)=delta_lon(k,l)*(1+xx)
+ xx=xx+0.05
+
+ do i = 1, ni
+ do j = 1, nj
+ IF(abs(grd_Ox(k,l)-grd_Ix(i,j)).le.delta_lon(k,l).and.
+ . abs(grd_Oy(k,l)-grd_Iy(i,j)).le.delta_lat(k,l))then
+ int_O(k,l) = int_O(k,l)+1
+ jj_min(k,l) = min(j,jj_min(k,l))
+ ii_min(k,l) = min(i,ii_min(k,l))
+ jj_max(k,l) = max(j,jj_max(k,l))
+ ii_max(k,l) = max(i,ii_max(k,l))
+ ENDIF
+ end do
+ end do
+
+ if(xx.ge.5) then
+ WRITE(6,*) 'No cell of input grid includes an output grid'
+ WRITE(6,*) 'point. --- STOP in INTnrg.'
+ stop
+ endif
+
+ enddo
+
+ pos_Ox(k,l)=jj_min(k,l)
+
+ ENDDO
+ ENDDO
+
+ endif
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ DO k=1,mx
+ DO l=1,my
+
+ int_O(k,l)=0.
+ var_O(k,l)=0.
+
+ do i = ii_min(k,l),ii_max(k,l)
+ do j = jj_min(k,l),jj_max(k,l)
+
+ IF(abs(grd_Ox(k,l)-grd_Ix(i,j)).le.delta_lon(k,l).and.
+ . abs(grd_Oy(k,l)-grd_Iy(i,j)).le.delta_lat(k,l))then
+
+ dist_O = dist(grd_Ox(k,l),grd_Oy(k,l),
+ . grd_Ix(i,j),grd_Iy(i,j))
+
+ int_O(k,l) = int_O(k,l)+ 1./max(1.,dist_O)
+ var_O(k,l) = var_O(k,l)+var_I(i,j)*1./max(1.,dist_O)
+ ENDIF
+
+ end do
+ end do
+
+ var_O(k,l)=var_O(k,l)/int_O(k,l)
+
+ ENDDO
+ ENDDO
+
+C + +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ RETURN
+ END
diff --git a/MAR/code_nestor/src/libUN.f b/MAR/code_nestor/src/libUN.f
new file mode 100644
index 0000000000000000000000000000000000000000..5fd5faff7bdb60e1e7b4f0a889e1f59dc9ba032c
--- /dev/null
+++ b/MAR/code_nestor/src/libUN.f
@@ -0,0 +1,3053 @@
+C--VERSION:2005.04.08
+
+C -----------------------------------------------------------------------
+C libUN : User level NetCDF READ / WRITE routines
+C
+C by Philippe Marbaix and Xavier Fettweis
+C
+C Compatible with NetCDF version 3.x (or above).
+C -----------------------------------------------------------------------
+
+C User-frendly interface :
+C ------------------------
+
+c CF_INI_FILE : Initialization of the netcf file
+c CF_CREATE_DIM : Create axis/dimensions
+c CF_CREATE_VAR : Create variables
+c CF_CREATE_FILE: Write the netcdf file
+c CF_WRITE : Write variables
+c CF_READ3D/2D : Read variables
+c CF_OPEN : Open netcdf file
+c CF_CLOSE : Close netcdf file
+
+C Main routines :
+C ---------------
+
+c UNscreate : General file creation routine,
+c defining multiple dimensions + attributes
+
+c UNwrite : General variables writting routine
+c (also updates 'range' attribute and variable if present)
+c Note: Use UNlwrite to write 2D planes in 3D variables
+
+c UN(s)read : Reading routine (grid coordinates + variable)
+
+C Complementary routines :
+C ------------------------
+
+c UNparam : set optional parameters of libUN functions
+c UNwopen : re-open file for writting
+c UNropen : open file for reading
+c UNgtime : Find time index for a given time value
+c UNgindx : Generalization of UNgtime: find value in any 1D data.
+c UNfindx : modified version of UNgindx safe for non-monotonic data
+c UNclose : close the NetCDF file
+c UNwratt : Real attributes writting
+c UNwcatt : Characters attributes creation & writing
+
+C Double Precision :
+C ------------------
+
+c To be in double precision, type this
+c > sed "s/REAL\*4/REAL\*8/g" libUN.f > libUN1.f
+c > sed "s/\_REAL/\_DOUBLE/g" libUN1.f > libUN2.f
+c > sed "s/NF\_FLOAT/NF\_DOUBLE/g" libUN2.f > libUNd.f
+c > rm -f libUN1.f libUN2.f
+
+C -----------------------------------------------------------------------
+
+
+C +---------------------------+---------------------------------------+
+C + Subroutine CD_INI_FILE : + Initialize the netcdf file +
+C +---------------------------+---------------------------------------+
+
+ SUBROUTINE CF_INI_FILE (filename, filetitle)
+
+c Input :
+c =======
+
+c filename = name of the netcdf file
+c filetitle = title in the netcdf file
+
+ IMPLICIT NONE
+
+ INCLUDE 'libUN.inc'
+
+ CHARACTER *(*) filename,filetitle
+
+ CF_attnam(1) = 'actual_range'
+ CF_attnum(1) = 2
+
+ CF_varnbrtot = 0 ! Initialization
+ CF_dimnbrtot = -1 ! Initialization
+
+ CF_filenam = filename
+ CF_filetit = filetitle
+
+ END SUBROUTINE CF_INI_FILE
+
+
+C +-----------------------------+-------------------------------------+
+C + Subroutine CF_CREATE_DIM : + Create dimensions/axis +
+C +-----------------------------+-------------------------------------+
+
+ SUBROUTINE CF_CREATE_DIM (dimname,dimunits,dimdim,vallues)
+
+c Input :
+c =======
+
+c dimname = name of the axis/dimension
+c dimunits = units of the axis/dimension
+c dimdim = dimensions of the axis/dimension
+c vallues = vallues of the axis/dimension
+
+ IMPLICIT NONE
+
+ INCLUDE 'libUN.inc'
+
+ CHARACTER *(*) dimname,dimunits
+
+ INTEGER dimdim,i
+ REAL*4 vallues(dimdim)
+
+ CF_dimnbrtot = CF_dimnbrtot + 1
+
+ CF_dimnbrtot = max(0,CF_dimnbrtot)
+
+ CF_dimnam(CF_dimnbrtot) = dimname
+ CF_dimnamuni(CF_dimnbrtot) = dimunits
+ CF_dim(CF_dimnbrtot) = dimdim
+
+ do i = 1,dimdim
+ CF_dimval(i,CF_dimnbrtot) = vallues(i)
+ enddo
+
+ END SUBROUTINE CF_CREATE_DIM
+
+C +-----------------------------+-------------------------------------+
+C + Subroutine CF_CREATE_VAR : + Create variables +
+C +-----------------------------+-------------------------------------+
+
+ SUBROUTINE CF_CREATE_VAR (varname,vartitle,varunits,varaxe4,
+ . varaxe1,varaxe2,varaxe3)
+
+c Input :
+c =======
+
+c varname = name of the variable
+c vartitle = title of the variable
+c varunits = units of the variable
+c varaxeX = axes used by the variable (T,X,Y,Z)
+
+ IMPLICIT NONE
+
+ INCLUDE 'libUN.inc'
+
+ CHARACTER *(*) varname,vartitle,varunits
+ CHARACTER *(*) varaxe1,varaxe2,varaxe3,varaxe4
+
+ CF_varnbrtot = max (0,CF_varnbrtot + 1)
+
+ CF_varnam(CF_varnbrtot) = varname
+ CF_varnamdim(1,CF_varnbrtot) = varaxe1
+ CF_varnamdim(2,CF_varnbrtot) = varaxe2
+ CF_varnamdim(3,CF_varnbrtot) = varaxe3
+ CF_varnamdim(4,CF_varnbrtot) = varaxe4
+ CF_varnamuni(CF_varnbrtot) = varunits
+ CF_vardes(CF_varnbrtot) = vartitle
+
+ END SUBROUTINE CF_CREATE_VAR
+
+C +--------------------------------------+----------------------------+
+C + Subroutine CF_CREATE_VAR_VIA_FILE : + Create variables +
+C +--------------------------------------+----------------------------+
+
+ SUBROUTINE CF_CREATE_VAR_VIA_FILE (filename)
+
+c Input :
+c =======
+
+c filename = name of the file containing informations
+c about the variables
+
+ IMPLICIT NONE
+
+ INCLUDE 'libUN.inc'
+
+ CHARACTER*200 filename
+
+ CHARACTER*120 tmpvar
+
+ OPEN(unit=999,status='old',file=filename)
+
+980 CONTINUE
+ READ (999,'(A120)',end=990) tmpvar
+
+ IF (tmpvar(1:4).eq.' ') THEN
+ CF_varnbrtot = max (0,CF_varnbrtot + 1)
+ READ (tmpvar,'(4x,5A9,A12,A50)')
+ . CF_varnam(CF_varnbrtot),
+ . CF_varnamdim(1,CF_varnbrtot),
+ . CF_varnamdim(2,CF_varnbrtot),
+ . CF_varnamdim(3,CF_varnbrtot),
+ . CF_varnamdim(4,CF_varnbrtot),
+ . CF_varnamuni(CF_varnbrtot),
+ . CF_vardes(CF_varnbrtot)
+ ENDIF
+
+ GOTO 980
+990 CONTINUE
+
+ END SUBROUTINE CF_CREATE_VAR_VIA_FILE
+
+C +------------------------------+------------------------------------+
+C + Subroutine CF_CREATE_FILE : + Create the netcdf file +
+C +------------------------------+------------------------------------+
+
+ SUBROUTINE CF_CREATE_FILE (filename)
+
+c Input :
+c =======
+
+c filename = name of the netcdf file
+
+ IMPLICIT NONE
+
+ INCLUDE 'libUN.inc'
+
+ CHARACTER *(*) filename
+
+ INTEGER i,j,id
+
+ INTEGER UN1_dim(0:CF_dimnbrtot)
+
+ REAL UN1_dimval(CF_dimmaxlen,0:CF_dimnbrtot)
+
+ CHARACTER*31 UN1_dimnam(0:CF_dimnbrtot),
+ . UN1_dimnamuni(0:CF_dimnbrtot)
+
+ if(filename.ne.CF_filenam)then
+ write(6,*) "ERROR: not "//CF_filenam
+ stop
+ endif
+
+ do i=0,CF_dimnbrtot
+ UN1_dim(i) = CF_dim(i)
+ UN1_dimnam(i) = CF_dimnam(i)
+ UN1_dimnamuni(i) = CF_dimnamuni(i)
+ do j=1,CF_dim(i)
+ UN1_dimval(j,i) = CF_dimval(j,i)
+ end do
+ enddo
+
+ call UNscreate (CF_filenam,CF_filetit,CF_dimnbrtot,UN1_dim,
+ . CF_dimmaxlen, UN1_dimnam ,UN1_dimnamuni,
+ . UN1_dimval,
+ . CF_varmaxnbr,CF_varnbrtot,CF_varnam,
+ . CF_varnamdim,CF_varnamuni,CF_vardes,
+ . CF_attnbr,CF_attnam,CF_attnum,id)
+
+ call UNclose (id)
+
+
+ END SUBROUTINE CF_CREATE_FILE
+
+C +------------------------+------------------------------------------+
+C + Subroutine CF_WRITE : + Writes variables +
+C +------------------------+------------------------------------------+
+
+
+ SUBROUTINE CF_WRITE (FILEname, VARname , itime,
+ & Ni, Nj, Nlev, var)
+
+c Input :
+c =======
+
+c FILEname = name of the netcdf file
+c VARname = name of variables
+c itime = index on time axis
+c Ni,Nj,Nlev = X,Y,Z dimension
+c var = array of vallues of the variable
+
+ IMPLICIT NONE
+
+ INCLUDE 'libUN.inc'
+
+ CHARACTER *(*) FILEname,VARname
+ INTEGER itime
+ INTEGER Ni, Nj, Nlev,fileid
+ REAL*4 var(Ni, Nj, Nlev)
+
+ if(CF_filenamopened.ne.FILEname) then
+ CALL UNwopen (FILEname,fileid)
+ else
+ fileid = CF_fileidopened
+ endif
+
+ CALL UNwrite (fileid,VARname ,itime,Ni, Nj, Nlev, var)
+
+ if(CF_filenamopened.ne.FILEname) then
+ call UNclose (fileid)
+ endif
+
+ END SUBROUTINE CF_WRITE
+
+C** +-------------------------+-----------------------------------------+
+C** + Subroutine CF_READ2D : + Read variables +
+C** +-------------------------+-----------------------------------------+
+
+ SUBROUTINE CF_READ2D (FILEname, VARname , itime,
+ . Ni, Nj, Nlev, var)
+
+
+c Input :
+c =======
+
+c FILEname = name of the netcdf file
+c VARname = name of variables
+c itime = index on time axis
+c Ni,Nj,Nlev = X,Y,Z dimension
+
+c Output :
+c ========
+
+c var = array of vallues of the variable
+
+ IMPLICIT NONE
+
+ INCLUDE 'libUN.inc'
+
+ CHARACTER *(*) FILEname,VARname
+ CHARACTER*32 var_units,filetitle
+ INTEGER Ni, Nj, Nlev,itime,level
+ REAL*4 var(Ni, Nj)
+
+ INTEGER i,j,fileid
+
+ if(CF_filenamopened.ne.FILEname) then
+ CALL UNropen (FILEname,fileid,filetitle)
+ else
+ fileid = CF_fileidopened
+ endif
+
+ CALL UNsread (fileid, VARname, itime, Nlev, 1, 1,
+ & Ni , Nj , 1,var_units, var)
+
+ if(CF_filenamopened.ne.FILEname) then
+ call UNclose (fileid)
+ endif
+
+ END SUBROUTINE CF_READ2D
+
+C +-------------------------+-----------------------------------------+
+C + Subroutine CF_READ3D : + Read variables +
+C +-------------------------+-----------------------------------------+
+
+
+ SUBROUTINE CF_READ3D (FILEname, VARname , itime,
+ . Ni, Nj, Nlev, var)
+
+c Input :
+c =======
+
+c FILEname = name of the netcdf file
+c VARname = name of variables
+c itime = index on time axis
+c Ni,Nj,Nlev = X,Y,Z dimension
+
+c Output :
+c ========
+
+c var = array of vallues of the variable
+
+ IMPLICIT NONE
+
+ INCLUDE 'libUN.inc'
+
+ CHARACTER *(*) FILEname,VARname
+ CHARACTER*32 var_units,filetitle
+ INTEGER Ni, Nj, Nlev,itime,level
+ REAL*4 var(Ni, Nj,Nlev)
+
+ INTEGER i,j,fileid
+
+ if(CF_filenamopened.ne.FILEname) then
+ CALL UNropen (FILEname,fileid,filetitle)
+ else
+ fileid = CF_fileidopened
+ endif
+
+ CALL UNsread (fileid, VARname, itime, 0, 1, 1,
+ & Ni , Nj , Nlev,var_units, var)
+
+ if(CF_filenamopened.ne.FILEname) then
+ call UNclose (fileid)
+ endif
+
+ END SUBROUTINE CF_READ3D
+
+C** +------------------------+------------------------------------------+
+C** + Subroutine CF_CLOSE : + Close the file +
+C** +------------------------+------------------------------------------+
+
+ SUBROUTINE CF_CLOSE (FILEname)
+
+ IMPLICIT NONE
+
+ INCLUDE 'libUN.inc'
+
+ CHARACTER*(*) FILEname
+
+ if(FILEname.eq.CF_filenamopened)then
+ call UNclose (CF_fileidopened)
+ else
+ print *,FILEname//" not opened"
+ endif
+
+ CF_filenamopened = ""
+ CF_fileidopened = 0
+
+ END SUBROUTINE CF_CLOSE
+
+C** +-----------------------+-------------------------------------------+
+C** + Subroutine CF_OPEN : + open the file +
+C** +-----------------------+-------------------------------------------+
+
+ SUBROUTINE CF_OPEN (FILEname,FILEid)
+
+ IMPLICIT NONE
+
+ INCLUDE 'libUN.inc'
+
+ INTEGER FILEid
+
+ CHARACTER*(*) FILEname
+
+ call UNwopen (FILEname,FILEid)
+
+ CF_filenamopened = FILEname
+
+ CF_fileidopened = FILEid
+
+ END SUBROUTINE CF_OPEN
+
+C** +-------------------------+-----------------------------------------+
+C** + Subroutine UNscreate : + +
+C** +-------------------------+ +
+C** + * Purpose : +
+C** + Create a NetCDF file, general version. +
+C** + (Staggered grids + other extensions to UNcreate) +
+C** + +
+C** + * How it works : calling routine must provide +
+C** + -a list of dimensions +
+C** + (size of each dimens., names, units and values of coordinates)+
+C** + -a list of variables +
+C** + (units, number of dimensions, names of selected dimensions) +
+C** + +
+C** + INPUT : +
+C** + ------- +
+C** + +
+C** + General : +
+C** + FILEnam [char]: Name of the file to be created. +
+C** + title [char]: Title attribute +
+C** + +
+C** + Dimensions: +
+C** + TND : Total Number of SPATIAL dimensions +
+C** + Notice : Set "time" to dimension No 0 +
+C** + DFdim(0:TND) : # discrete values for each dimension +
+C** + Notice : DFdim(0).eq.0 +
+C** + -> UNLIMITED TIME (coord. not defined) +
+C** + WARNING: In this case, the NetCDF +
+C** + use a temporary space to duplicate +
+C** + the file -> NOT RECOMMENDED +
+C** + MXdim : Maximum value of DFdim, = arrays size +
+C** + NAMdim(0:TND) [char]: Name of dimensions, except time +
+C** + UNIdim(0:TND) [char]: Units of dimensions (attribute) +
+C** + VALdim(MXdim,0:TND)[R4]: Values of coordinate for each dimension+
+C** + +
+C** + Variables: +
+C** + Dvs : Variable's definitions array sizes, +
+C** + Nvs : Number of defined variables(Nvs.le.Dvs)+
+C** + name_vs (Dvs) [char]: name of variable. +
+C** + unit_vs (Dvs) [char]: physical units of variable (attribute) +
+C** + Sdim_vs (4,Dvs) [char]: name of Selected dims (in above list) +
+C** + Blanked or '-' elements = not used +
+C** + lnam_vs (Dvs) [char]: Long_name attribute (descript. of var.)+
+C** + +
+C** + List of real attributes to all variables: +
+C** + Nra : Number of Real Attributes (.ge.1 !) +
+C** + NAMrat(Nra) [char]: NAMes of Real ATtributes (''=none) +
+C** + (initial value= 0; set it with UNwratt)+
+C** + Nvals(Nra) : Number of values of these attributes. +
+C** + ! Currently limited to 1 value (scalar) or 2 (2 elements vector)+
+C** + ! EXCEPTION: Setting the last attribute name to '[var]_range' +
+C** + does create a variable (!) for level-by-level range+
+C** + (very usefull for 3D + time fields) +
+C** + +
+C** + NB : [char] variables may have any length. +
+C** + blanks characters are NOT ALLOWED in any variable, +
+C** + except the "title". +
+C** + and the NetCDF variables defined here are always real*4 +
+C** + +
+C** + OUTPUT : +
+C** + -------- +
+C** + FILEid : Index of the NetCDF file (remains open)+
+C** +-------------------------------------------------------------------+
+
+ SUBROUTINE UNscreate (FILEnam, title,
+ & TND, DFdim, MXdim, NAMdim, UNIdim, VALdim,
+ & Dvs, Nvs, name_vs, Sdim_vs, unit_vs, lnam_vs,
+ & Nra, NAMrat, Nvals,
+ & FILEid )
+
+C +
+ IMPLICIT NONE
+
+ INCLUDE 'libUN.inc'
+
+C +
+ INTEGER icheck, MXND
+C ** Maximum number of dimensions
+ parameter (MXND = 100)
+
+C + INPUT:
+C + - - -
+ CHARACTER *(*) FILEnam
+ CHARACTER *(*) title
+
+ INTEGER TND, DFdim(0:TND), MXdim
+ CHARACTER *(*) NAMdim(0:TND)
+ CHARACTER *(*) UNIdim(0:TND)
+ REAL*4 VALdim(MXdim,0:TND)
+
+ INTEGER Nvs, Dvs
+ CHARACTER *(*) name_vs(Dvs)
+ CHARACTER *(*) Sdim_vs(4,Dvs)
+ CHARACTER *(*) unit_vs(Dvs)
+ CHARACTER *(*) lnam_vs(Dvs)
+
+ INTEGER Nra
+ CHARACTER *(*) NAMrat(Nra)
+ CHARACTER*24 Host,Fdate
+ CHARACTER*200 tmpchar
+ INTEGER Nvals(Nra)
+
+C + OUTPUT:
+C + - - - -
+ INTEGER FILEid
+
+C + LOCAL:
+C + - - -
+ INTEGER VARSIZE
+ EXTERNAL VARSIZE
+ CHARACTER*(30) tmpchr
+ INTEGER dimDID(0:MXND)
+ INTEGER dimVID(0:MXND), vsVID, vrVID
+ INTEGER dID(4), start(4), count(4), rdID(2)
+ INTEGER mimaID
+ INTEGER stride(4),imap(4)
+ INTEGER Ndim_vs
+ INTEGER ivs, igd, idi, ira, itmp
+ INTEGER Nlen
+ INTEGER dNlen(0:MXND)
+ INTEGER Ierro, TTerr, ii,jj
+ REAL*4 zero1(1), zero2(2)
+
+ icheck= 0 !Debugging level
+
+C* 0. Initialisations
+C ------------------
+ IF (icheck.ge.1) WRITE(*,*) 'UNscreate : Begin'
+
+C + Routines which opens a file must reset libUN internals:
+ CALL UNparam('RESET_PARAMS_',0.0)
+
+ DO ii = 1,4
+ stride(ii) = 1
+ ENDDO
+ zero1(1) = 0.
+ zero2(1) = 0.
+ zero2(2) = 0.
+ TTerr = 0 !Total of error flags
+
+ IF (TND .gt. MXND) THEN
+ write(*,*)'UNscreate - Error: so much dimensions ?',TND
+ END IF
+
+C Create a NetCDF file and enter define mode :
+C --------------------------------------------
+ IF (icheck.ge.2) WRITE(*,*) 'FILEnam :', FILEnam
+
+C ** getting FILEnam [char] size :
+ Nlen = VARSIZE(FILEnam)
+
+ Ierro=NF_CREATE(FILEnam(1:Nlen), NF_CLOBBER , FILEid)
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNscreate', Ierro)
+C ** identif. =>overwrite =error
+
+C* Time coordinate definition.
+C ---------------------------
+
+C ** Define dimension :
+ IF (icheck.ge.3) WRITE(*,*) '# time iters.:', DFdim(0)
+ IF (DFdim(0).eq.0.) THEN
+ Ierro=NF_DEF_DIM(FILEid , 'time', NF_UNLIMITED, dimDID(0))
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNscreate', Ierro)
+ TTerr = TTerr + ABS(Ierro)
+ ELSE
+ Ierro=NF_DEF_DIM(FILEid , 'time', DFdim(0), dimDID(0))
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNscreate', Ierro)
+ TTerr = TTerr + ABS(Ierro)
+ END IF
+ dNlen(0)= 4 ! 4 characters in the name 'time'...
+ IF (NAMdim(0)(1:4).ne.'time') THEN
+ WRITE(*,*) 'Sorry, NAMdim(0) must be ''time'' .'
+ STOP
+ END IF
+
+C ** Define variable for the time coordinate values :
+ dID(1) = dimDID(0)
+ Ierro=NF_DEF_VAR(FILEid , 'time', NF_FLOAT,1 , dID, dimVID(0))
+C ** ^^^^^^^^^^ FILEid var name type dims DIMid VARid
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNscreate', Ierro)
+ TTerr = TTerr + ABS(Ierro)
+
+
+C Spatial coordinates definitions : DIMS and VARs (locations).
+C ------------------------------------------------------------
+C
+ DO igd = 1,TND !** BEGIN LOOP over all spatial dims
+ IF (icheck.ge.3) WRITE(*,*) ' spatial dim:', NAMdim(igd)
+
+C ** getting NAMdim [char] size :
+ Nlen = VARSIZE(NAMdim(igd))
+ dNlen(igd) = Nlen !For further use of NAMdim
+
+ Ierro=NF_DEF_DIM(FILEid , NAMdim(igd)(1:Nlen),
+ & DFdim(igd),dimDID(igd))
+C **line1 ^^^^^^^^^^ FILEid | dim name
+C **line2 # values | VARid
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNscreate', Ierro)
+ TTerr = TTerr + ABS(Ierro)
+
+ dID(1) = dimDID(igd)
+ Ierro=NF_DEF_VAR(FILEid , NAMdim(igd)(1:Nlen),
+ & NF_FLOAT , 1 , dID ,dimVID(igd))
+C **line1 ^^^^^^^^^^ FILEid | dim name
+C **line2 type | #dims | dimsIDs | VARid
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNscreate', Ierro)
+ TTerr = TTerr + ABS(Ierro)
+
+ END DO !** END LOOP over all spatial dims
+
+C Special coordinate definition: MinMax (for [var]_range)
+C -------------------------------------------------------
+ IF (NAMrat(Nra)(1:11).eq.'[var]_range') THEN
+
+ Ierro=NF_DEF_DIM(FILEid, 'MinMax', 2, mimaID)
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNscreate', Ierro)
+ ENDIF
+
+C Define the fields.
+C ------------------
+
+ DO ivs = 1,Nvs !**BEGIN LOOP on var. num.
+ IF (icheck.ge.3)
+ & WRITE (*,*) 'Defining variable ',name_vs(ivs)
+
+
+C Set space and time dimensions
+C - - - - - - - - - - - - - - -
+C ** Initialise number of dimensions :
+ Ndim_vs= 0
+
+ DO idi = 1, 4 !** BEGIN LOOP on var dims.
+ IF (Sdim_vs(idi,ivs)(1:1).ne.' '
+ & .and.Sdim_vs(idi,ivs)(1:1).ne.'-') THEN !**skip undefined.
+
+C ** getting Sdim_vs [char] size :
+ Nlen = VARSIZE(Sdim_vs(idi,ivs))
+
+C ** Searching for the dimension index from its name (Sdim_vs)
+ igd = 0
+ DO WHILE (Sdim_vs(idi,ivs)(1:Nlen)
+ & .ne. NAMdim(igd)(1:dNlen(igd)) )
+ IF (igd.eq.TND) THEN
+ write(*,*)'UNscreate-ERROR: Dimension not found:',
+ & Sdim_vs(idi,ivs)(1:Nlen)
+ STOP
+ END IF
+ igd = igd + 1
+ END DO
+C ** Construct the dimensions id's for that variable (ivs):
+ IF (icheck.ge.3)
+ & WRITE (*,*) 'using dimension ',NAMdim(igd), dimDID(igd)
+ Ndim_vs = Ndim_vs + 1
+ dID(Ndim_vs) = dimDID(igd)
+
+ END IF
+ END DO !** END LOOP on var dims.
+
+C Define our special [var]_range field for 4D variables
+C - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ IF (Ndim_vs.eq.4
+ & .and.NAMrat(Nra)(1:11).eq.'[var]_range') THEN
+
+ Nlen = VARSIZE(name_vs(ivs))
+ rdID(1) = dID (3) !(4D variable, 3th dim = level)
+ rdID(2) = mimaID !(for min, max)
+ tmpchr = name_vs(ivs)(1:Nlen)//'_range'
+ itmp = Nlen + 6
+ Ierro = NF_DEF_VAR(FILEid,tmpchr(1:itmp),
+ & NF_FLOAT, 2, rdID, vrVID)
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNscreate', Ierro)
+ TTerr = TTerr + ABS(Ierro)
+
+ ENDIF
+
+C Define fields :
+C - - - - - - - -
+ Nlen = VARSIZE(name_vs(ivs))
+ Ierro=NF_DEF_VAR(FILEid , name_vs(ivs)(1:Nlen),
+ & NF_FLOAT, Ndim_vs, dID , vsVID)
+C **line1 ^^^^^^^^^^ FILEid | variable name
+C **line2 type | #dims | dimsIDs | VARid
+ IF (Ierro.NE.NF_NOERR)
+ & CALL HANDLE_ERR('UNscreate (field)', Ierro)
+ TTerr = TTerr + ABS(Ierro)
+
+
+C Set the variable's attributes :
+C -------------------------------
+
+C ** Units:
+C - - - - -
+C ** getting unit_vs [char] size :
+ Nlen = VARSIZE(unit_vs(ivs))
+
+ Ierro= NF_PUT_ATT_TEXT(FILEid , vsVID ,'units',
+ & Nlen ,unit_vs(ivs)(1:Nlen))
+c **line1 ^^^^^^^^^^^^^^^ FILEid |var.id | attr.name
+C **line2 length | attr.value
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNscreate', Ierro)
+ TTerr = TTerr + ABS(Ierro)
+
+C ** Special case : units = sigma
+C - - - - - - - - - - - - - - - -
+C In this case, CV convention advises to write the following
+C attribute : positive = down
+C
+ Nlen = VARSIZE(lnam_vs(ivs))
+
+ IF ( unit_vs(ivs)(1:Nlen) .EQ. '[sigma]'
+ & .OR. unit_vs(ivs)(1:Nlen) .EQ. 'sigma_level' ) THEN
+ IF (icheck.ge.3) THEN
+ WRITE(*,*) 'Unit = sigma -> setting positive attr'
+ ENDIF
+
+ Ierro= NF_PUT_ATT_TEXT(FILEid , vsVID ,'positive',
+ & 4 ,'down')
+c **line1 ^^^^^^^^^^^^^^^ FILEid |var.id | attr.name
+C **line2 length | attr.value
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNscreate', Ierro)
+ ENDIF
+
+C ** "long_name":
+C - - - - - - - -
+ Nlen = VARSIZE(lnam_vs(ivs))
+
+ IF (icheck.ge.3)
+ & WRITE (*,*) 'Write long_name ',lnam_vs(ivs)(1:Nlen)
+
+ Ierro=NF_PUT_ATT_TEXT(FILEid , vsVID ,'long_name',
+ & Nlen ,lnam_vs(ivs)(1:Nlen) )
+
+ do jj=1,Nlen
+ if(lnam_vs(ivs)(jj:jj).eq." ") lnam_vs(ivs)(jj:jj)="_"
+ if(lnam_vs(ivs)(jj:jj).eq.".") lnam_vs(ivs)(jj:jj)="_"
+ if(lnam_vs(ivs)(jj:jj).eq."(") lnam_vs(ivs)(jj:jj)="_"
+ if(lnam_vs(ivs)(jj:jj).eq.")") lnam_vs(ivs)(jj:jj)="_"
+ if(lnam_vs(ivs)(jj:jj).eq."/") lnam_vs(ivs)(jj:jj)="_"
+ enddo
+
+ Ierro=NF_PUT_ATT_TEXT(FILEid , vsVID ,'standard_name',
+ & Nlen ,lnam_vs(ivs)(1:Nlen) )
+
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNscreate', Ierro)
+ TTerr = TTerr + ABS(Ierro)
+
+
+C ** From the list of real attributes (input argument) :
+C - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C
+ DO ira = 1, Nra
+ IF (NAMrat(ira)(1:1).ne.' ') THEN
+ IF (NAMrat(ira)(1:11).eq.'valid_range') THEN
+
+C ** The "valid_range" special attribute :
+ Ierro=NF_PUT_ATT_REAL(FILEid ,vsVID ,'valid_range' ,
+ & NF_FLOAT,2 , ValRange)
+ TTerr = TTerr + ABS(Ierro)
+
+ ELSE IF (NAMrat(ira)(1:11).ne.'[var]_range') THEN
+
+C ** All "regular" attributes :
+ Nlen = VARSIZE(NAMrat(ira))
+ IF (Nvals(ira).eq.1) THEN
+ Ierro=NF_PUT_ATT_REAL(FILEid,vsVID,NAMrat(ira)(1:Nlen),
+ & NF_FLOAT, Nvals , zero1 )
+ TTerr = TTerr + ABS(Ierro)
+ ELSE IF (Nvals(ira).eq.2) THEN
+ Ierro=NF_PUT_ATT_REAL(FILEid,vsVID,NAMrat(ira)(1:Nlen),
+ & NF_FLOAT, Nvals , zero2 )
+ TTerr = TTerr + ABS(Ierro)
+c
+ END IF
+ END IF
+ END IF
+ END DO
+
+ END DO ! **END LOOP on var. num.
+
+C Set 'unit' attribute for the dimensions:
+C ----------------------------------------
+
+ DO igd = 0,TND !** BEGIN LOOP over all spatial dims
+
+C ** getting NAMdim [char] size :
+ Nlen = VARSIZE(UNIdim(igd))
+
+ Ierro=NF_PUT_ATT_TEXT(FILEid , dimVID(igd),'units',
+ & Nlen , UNIdim(igd) )
+
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNscreate', Ierro)
+
+ Nlen = VARSIZE(NAMdim(igd))
+
+ Ierro=NF_PUT_ATT_TEXT(FILEid , dimVID(igd),'long_name',
+ & Nlen , NAMdim(igd) )
+
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNscreate', Ierro)
+
+ Ierro=NF_PUT_ATT_TEXT(FILEid , dimVID(igd),'standard_name',
+ & Nlen , NAMdim(igd) )
+
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNscreate', Ierro)
+ TTerr = TTerr + ABS(Ierro)
+
+ ENDDO
+
+C Global attribute(s).
+C --------------------
+
+C ** Title (some general file descriptor) :
+C ** getting unit_vs [char] size :
+
+ Nlen = VARSIZE(title)
+
+ Ierro=NF_PUT_ATT_TEXT(FILEid ,NF_GLOBAL,'title',
+ & Nlen ,title(1:Nlen) )
+
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNscreate', Ierro)
+
+
+ Nlen = VARSIZE(CF_institution)
+
+ Ierro=NF_PUT_ATT_TEXT(FILEid ,NF_GLOBAL,'institution',
+ & Nlen ,CF_institution)
+
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNscreate', Ierro)
+
+c CALL HostNm(Host, Ierro)
+
+ tmpchar="libUN ("//CF_libUN_version//") - "//FDate()
+c & " - "//Host
+
+ Nlen = VARSIZE(tmpchar)
+
+ Ierro=NF_PUT_ATT_TEXT(FILEid ,NF_GLOBAL,'history',
+ & Nlen ,tmpchar)
+
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNscreate', Ierro)
+
+
+ Nlen = VARSIZE(NF_INQ_LIBVERS())
+
+ Ierro=NF_PUT_ATT_TEXT(FILEid ,NF_GLOBAL,'netcdf',
+ & Nlen ,NF_INQ_LIBVERS())
+
+
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNscreate', Ierro)
+ TTerr = TTerr + ABS(Ierro)
+
+
+C Leave define mode (!file remains open )
+C ---------------------------------------
+ Ierro=NF_ENDDEF(FILEid)
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNscreate', Ierro)
+ TTerr = TTerr + ABS(Ierro)
+
+
+C Writing of dimensions coordinates.
+C ----------------------------------
+
+C ** Time :
+C - - - - -
+
+ start(1)= 1 !Vector of starting indexes values
+ count(1)= DFdim(0) !Vector of total # indexes values
+ IF (icheck.ge.3)
+ & WRITE (*,*) 'Write coords for ',NAMdim(0),count(1)
+
+C ** Set 'imap' to write with NCVPTG; NCVPT could be enough ?
+C ** (imap tells NetCDF about the memory locations of var,
+C ** we choose NCVPTG because
+C ** only a portion of VALdim is written.)
+ imap(1) = 1
+ imap(2) = 0 ! Not used : write only 1 coord.
+
+ Ierro=NF_PUT_VARM_REAL(FILEid ,dimVID(0), start , count,
+ & stride , imap , VALdim(1,0) )
+C **line 1 ^^^^^^^^^^^^^^^ ID file| id var. |read from... |#data
+C **line 2 step |re-arrang|variable(beg.)
+C ** (^^^^stride is not used)
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNscreate', Ierro)
+
+
+C ** Space coordinates :
+C - - - - - - - - - - - -
+
+ DO igd = 1,TND !** BEGIN LOOP over all spatial dims
+
+ start(1)= 1
+ count(1)= DFdim(igd)
+ IF (icheck.ge.3)
+ & WRITE (*,*) 'Write coords for ',NAMdim(igd),count(1)
+
+
+ Ierro=NF_PUT_VARM_REAL(FILEid ,dimVID(igd),start , count,
+ & stride , imap ,VALdim(1,igd))
+C ** ^^^^^^^^^^^^^^^^ see above
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNscreate', Ierro)
+
+ TTerr = TTerr + ABS(Ierro)
+
+ END DO !** END LOOP over all spatial dims
+
+C Stop if an error occured.
+C -------------------------
+
+ IF (TTerr.ne.0) THEN
+ STOP 'UNscreate : Sorry, an error occured.'
+ ENDIF
+
+C +
+ RETURN
+ END SUBROUTINE UNscreate
+
+C** +-------------------------+-----------------------------------------+
+C** + Subroutine UNwrite : + +
+C** +-------------------------+ +
+C** + * Writes a variable into a NetCDF file, +
+C** + (the NetCDF file must have been created (or re-opened) and +
+C** + closed after all writing operations). +
+C** + * Automatically updates attribute 'actual_range' if available +
+C** + " " special var. '[var]_range' " +
+C** + +
+C** + INPUT : +
+C** + FILEid : input file identifier (from UNcreate OR NetCDF open) +
+C** + VARname : name given to the variable to write (must be in file)+
+C** + itime : No of time step to write to +
+C** + Ni,Nj,Nlev: dimensions of 'var' +
+C** + ! Nlev= 1 for 2D and 1D input variables. +
+C** + Nj = 1 for 1D input variables. +
+C** + NB: can not write 1 level of 3D var only (->UNlwrite)+
+C** + +
+C** + var : The variable to be writen +
+C** + +
+C** + REMARK : +
+C** + Truncation of input data is permited: +
+C** + If the dim of "var" > dim in the NetCDF file, +
+C** + "var" is automatically truncted. However, this => WARNING +
+C** + message, UNLESS a specific truncation was "announced" +
+C** + in var: +
+C** + To truncate the first dim to Li, let var(Ni,1,1) = Li +
+C** + To truncate the 2nd dim to Lj, let var(1,Nj,1) = Lj +
+C** + ... (this has no effect exept cancel the "WARNING" message) +
+C** +-------------------------------------------------------------------+
+
+ SUBROUTINE UNwrite (FILEid , VARname , itime,
+ & Ni, Nj, Nlev, var)
+
+ IMPLICIT NONE
+
+ INCLUDE 'libUN.inc'
+
+ INTEGER icheck
+
+ INTEGER Lvnam
+ PARAMETER (Lvnam=20)
+
+C ** input
+ INTEGER FILEid
+ INTEGER itime
+ INTEGER Ni, Nj, Nlev
+ CHARACTER *(*) VARname
+ REAL*4 var(Ni, Nj, Nlev)
+
+C ** local :
+ INTEGER MXlv
+ PARAMETER (MXlv=500)
+C ^^^^Maximal # levels for a special output
+ INTEGER VARSIZE
+ EXTERNAL VARSIZE
+ INTEGER NVRi, NVRj, NVRlev
+ INTEGER Ierro, TTerr, Nvatts, vtype
+ INTEGER dimID(4), dimSIZ(4), count(4)
+ INTEGER start(4),stride(4),imap(4)
+ CHARACTER*(Lvnam) dimNAM(4)
+ CHARACTER*(Lvnam) recname
+ CHARACTER*(30) tmpchr
+ INTEGER varVID
+ INTEGER VNlen, NDIMvar, NSDIvar, tiDI, itmp
+ INTEGER iz, ii, jj, ll
+ INTEGER iUNLIMDIM
+ REAL*4 chkdim
+ REAL*4 Arange(2),sValRange(2)
+ REAL*4 Srange(MXlv,2)
+ LOGICAL OkRange
+
+ icheck= 0 !** 'debugging' level
+ TTerr = 0 !** 'total number of errors
+
+ IF (icheck.ge.1) WRITE(*,*) 'UNwrite : Begin'
+
+C* 1. Get the variable field and dims IDs
+C ----------------------------------------
+
+ IF (icheck.ge.2) WRITE(*,*) 'FILEid :', FILEid
+
+C ** getting VARname size :
+ VNlen = VARSIZE (VARname)
+ IF (icheck.ge.3) WRITE(*,*) 'VNlen :', VNlen
+ IF (icheck.ge.2) WRITE(*,*) 'VARname :', VARname (1:VNlen)
+
+C ** variable field ID :
+ Ierro=NF_INQ_VARID (FILEid, VARname (1:VNlen), varVID)
+
+C ** Cancel writing if an error occured : variable undefined ?
+ IF (Ierro.ne.0.and.icheck.ge.1) THEN
+ WRITE(*,*) 'UNwrite Info : Variable ',VARname(1:VNlen)
+ & ,' not found -> not written.'
+ END IF
+ IF (Ierro.ne.0) GOTO 9999 !** UNwrite_end
+
+
+C ** Inquire about the number of dimensions in var :
+C **
+ Ierro=NF_INQ_VAR(FILEid , varVID, recname, vtype,
+ & NDIMvar, dimID, Nvatts)
+C ** line1 id/file id/var var name var type
+C ** line2 # dims id/dims #attributes
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNwrite', Ierro)
+
+ IF (icheck.ge.2) WRITE(*,*) 'Ierro1. ', Ierro
+
+
+C* 2. Dimensions : inquire about file + compare with input data.
+C -------------------------------------------------------------
+
+C 2.1 Inquire dimensions names and sizes :
+C + - - - - - - - - - - - - - - - - - - - - -
+ DO iz = 1,4
+ dimSIZ(iz)=0
+ dimNAM(iz)=' '
+C ** Set any unused dimension to "0" size / no name
+ END DO
+ DO iz = 1,NDIMvar
+ Ierro=NF_INQ_DIM(FILEid , dimID(iz), dimNAM(iz), dimSIZ(iz))
+C ** id/file id/dim dimname dimsize
+C ** !output output
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNwrite', Ierro)
+ END DO
+ IF (icheck.ge.3) WRITE(*,*) 'NDIMvar ',NDIMvar
+ IF (icheck.ge.3) WRITE(*,*) 'Ierro 2.0',Ierro
+
+C 2.2 Set writing region according to field dimension : 2D or 3D
+C + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C ** Set horizontal dimensions (default, for most data) :
+ count(1) = Ni
+ count(2) = Nj
+C + ** Other default values:
+ count(3) = 0
+ count(4) = 0
+ start(1) = 1
+ start(2) = 1
+ start(3) = 1
+ start(4) = 1
+
+C +- ------3D+time variable in file-----------
+ IF (NDIMvar.eq.4) THEN
+C ** 3D space + time:
+ NSDIvar = 3 ! # space dims
+ tiDI = 4 ! No. of the time dim
+C ** write 3D space:
+ start(3) = 1 ! Start of index 3 in var (here = vert. levs)
+ count(3) = Nlev ! # values of index 3 in var
+C ** write one time step:
+ start(4) = itime
+ count(4) = 1
+C +- ------3D *OR* 2D+time var in file--------
+ ELSE IF (NDIMvar.eq.3) THEN
+ IF (Nlev.EQ.1) THEN
+C ** 2D space + time (standard use of UNlib):
+ NSDIvar = 2
+ tiDI = 3
+C ** ...write one time step:
+ start(3) = itime
+ count(3) = 1
+ ELSE
+C ** 3D (no time slice):
+ NSDIvar = 3
+ tiDI = 0
+C ** ...write 3rd dimension:
+ start(3) = 1
+ count(3) = Nlev
+ ENDIF
+C +- ------2D *OR* 1D+time var in file--------
+ ELSE IF (NDIMvar.eq.2) THEN
+ IF (Nj.EQ.1 .AND. dimNAM(2)(1:4).EQ.'time') THEN
+C ** Write a 1D vector at time= itime:
+ NSDIvar = 1
+ tiDI = 2
+ start(2) = itime
+ count(2) = 1
+ ELSE
+C ** Usual MAR 2D space (no time):
+ NSDIvar = 2
+ tiDI = 0
+ END IF
+C +- ------1D *OR* 0D+time var in file--------
+ ELSE IF (NDIMvar.eq.1) THEN
+C ** 1D space or time
+ IF (Ni.eq.1) THEN
+C ** Write a single element (at itime)
+ start(1) = itime
+ count(1) = 1
+ count(2) = 0
+ NSDIvar = 0
+ tiDI = 1
+ ELSE
+C ** Write a vector (use only "space" dim 1)
+ NSDIvar = 1
+ tiDI = 0
+ count(2)= 0
+ END IF
+ ELSE
+ WRITE(*,*) 'UNwrite ERROR : data field dimension ?'
+ STOP
+ END IF
+
+C 2.3 Compare file dimensions to input data.
+C + - - - - - - - - - - - - - - - - - - - - - -
+C ** Save variable size for use as "valid" size (-> range):
+ NVRi = Ni
+ NVRj = Nj
+ NVRlev = Nlev
+C ** Space dimensions :
+ IF (NSDIvar.GT.0) THEN
+ DO iz = 1,NSDIvar
+ IF (dimSIZ(iz).gt.count(iz)) THEN
+ write(*,*) 'UNwrite - WARNING: '
+ write(*,*) ' Your field ',VARname,' has an empty part.'
+ write(*,*) ' (for the dimension:',dimNAM(iz),')'
+ ELSE IF (dimSIZ(iz).lt.count(iz)) THEN
+C ** Do display "warning" only if truncation
+C was not "correctly announced" (see header)
+C (NVR... => stop here when updating the range attribute)
+ IF (iz.EQ.1) THEN
+ chkdim = var(Ni,1,1)
+ NVRi = dimSIZ(1)
+ ELSE IF (iz.EQ.2) THEN
+ chkdim = var(1,Nj,1)
+ NVRj = dimSIZ(2)
+ ELSE IF (iz.EQ.3) THEN
+ chkdim = var(1,1,Nlev)
+ NVRlev = dimSIZ(3)
+ ELSE
+ chkdim = 0.0
+ ENDIF
+ Ierro= NF_INQ_UNLIMDIM (FILEid, iUNLIMDIM)
+ IF (dimID(iz).NE.iUNLIMDIM) THEN
+ IF (ABS(chkdim-dimSIZ(iz)).GT. 0.1 ) THEN
+ write(*,*) 'UNwrite - WARNING: '
+ write(*,*) ' Your field ',VARname,' will be truncated.'
+ write(*,*) ' (for the dimension:',dimNAM(iz),')'
+ ENDIF
+ count(iz) = dimSIZ(iz)
+ ENDIF
+ END IF
+ END DO
+ END IF
+
+C ** Time dimension (when defined):
+ IF (tiDI.ne.0) THEN
+ IF (itime.gt.dimSIZ(tiDI)) THEN
+ IF (icheck.ge.1) WRITE(*,*) 'Time limit, ID', dimID(tiDI)
+ Ierro= NF_INQ_UNLIMDIM (FILEid, iUNLIMDIM)
+ IF (dimID(tiDI).NE.iUNLIMDIM) THEN
+ WRITE(*,*) 'UNwrite - ERROR: '
+ WRITE(*,*) ' Time index out of range '
+ STOP
+ ENDIF
+ END IF
+ END IF
+
+ IF (icheck.ge.2) WRITE(*,*) 'Ierro2. ', Ierro
+ IF (icheck.ge.2) WRITE(*,*) 'Dimension names :',dimNAM
+ IF (icheck.ge.2) WRITE(*,*) 'dimSIZ :',dimSIZ
+ IF (icheck.ge.2) WRITE(*,*) 'count :',count
+ IF (icheck.ge.2) WRITE(*,*) 'start :',start
+ IF (icheck.ge.2) WRITE(*,*) 'dimID :',dimID
+
+C* 3. Write variable.
+C ------------------
+
+C ** Set 'imap' and WRITE with NCVPTG:
+C ** NOTE : since the arrays (grid_*) may be over-dimensionned,
+C ** we use the 'generalised' writing routine NCVPTG
+C ** (imap tells NetCDF about the memory locations of var)
+ imap(1) = 1
+ imap(2) = imap(1) * Ni ! 1st dim of var = Ni
+ imap(3) = imap(2) * Nj ! 2nd dim of var = Nj
+ imap(4) = 0 ! (not used: 0 or 1 time step)
+ DO iz=1,4
+ stride(iz)=1
+ END DO
+C ** NOTE: stride is not used.
+
+ Ierro=NF_PUT_VARM_REAL(FILEid , varVID , start , count,
+ & stride , imap , var(1,1,1) )
+C ** line1: id/file | id/var |read from...|#data
+C ** line2: step |re-arrang|variable(beg.)
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNwrite', Ierro)
+
+ IF (icheck.ge.2) WRITE(*,*) 'Ierro3.2', Ierro
+
+C* 4a. Update 'actual_range' attribute.
+C ------------------------------------
+
+C If 'actual_range' available, get its current value:
+C - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+C ** Get the old min and max values:
+ Ierro=NF_GET_ATT_REAL(FILEid ,varVID ,'actual_range' ,
+ & Arange )
+c **line1 ^^^^^^^^^^^^^^ FILEid |var.id | attr.name
+C **line2 value
+
+C ** Cancel if an error occured : attribute undefined ?
+ IF (Ierro.ne.0.and.icheck.ge.1) THEN
+ WRITE(*,*) 'UNwrite Info : attribute actual_range '
+ & ,' not found -> not written.'
+ END IF
+ IF (Ierro.ne.0) GOTO 9990 !** Next section
+
+C If 'valid_range' available, get its current value:
+C - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+C ** Get the min/max valid range (outside = missing val):
+ Ierro=NF_GET_ATT_REAL(FILEid ,varVID ,'valid_range' ,
+ & sValRange)
+ IF (Ierro.ne.0) THEN
+ sValRange(1)=ValRange(1)
+ sValRange(2)=ValRange(2)
+ END IF
+
+C Update the min an max
+C - - - - - - - - - - -
+
+C **If this is the first pass, initialise min and max:
+ IF ( Arange(1).EQ. NF_FILL_REAL
+ . .OR. (Arange(1).EQ. 0.0 .AND. Arange(2).EQ. 0.0) ) THEN
+ OkRange = .false.
+ ELSE
+ OkRange = .true.
+ ENDIF
+
+ DO ll=1, NVRlev
+ DO jj=1, NVRj
+ DO ii=1, NVRi
+ IF ( var(ii,jj,ll).GE.sValRange(1)
+ & .AND. var(ii,jj,ll).LE.sValRange(2)) THEN
+ IF (OkRange) THEN
+ Arange(1) = MIN(Arange(1), var(ii,jj,ll))
+ Arange(2) = MAX(Arange(2), var(ii,jj,ll))
+ ELSE
+ Arange(1) = var(ii,jj,ll)
+ Arange(2) = var(ii,jj,ll)
+ OkRange = .true.
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+ IF (icheck.ge.2) WRITE(*,*) 'Arange',Arange
+
+C Set attribute.
+C - - - - - - - -
+
+ Ierro=NF_PUT_ATT_REAL(FILEid ,varVID ,'actual_range' ,
+ & NF_FLOAT,2 ,Arange)
+c **line1 ^^^^^^^^^^^^^^^ FILEid |var.id | attr.name
+C **line2 type |len | attr.value
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNwrite', Ierro)
+ TTerr = TTerr + ABS(Ierro)
+
+C ** Next section:
+ 9990 CONTINUE
+
+C* 5. Update the optional '[var]_range' special variable.
+C ------------------------------------------------------
+ IF (NDIMvar.eq.4.and.Nlev.lt.MXlv) THEN
+
+C If '[var]_range' available, get its current value:
+C - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+C ** Get ID of variable [var]_range :
+ tmpchr = VARname(1:VNlen)//'_range'
+ itmp = VNlen + 6
+ Ierro=NF_INQ_VARID(FILEid, tmpchr(1:itmp), varVID)
+
+C ** Cancel if an error occured : undefined ?
+ IF (Ierro.ne.0.and.icheck.ge.1) THEN
+ WRITE(*,*) 'UNwrite Info : [var]_range '
+ & ,' not found -> not written.'
+ END IF
+ IF (Ierro.ne.0) GOTO 9999 !** UNwrite_end
+
+C ** Get the old min and max values:
+C ** NOTE :
+C ** we use the 'generalised' reading routine NCVGTG
+C ** (imap tells NetCDF about the memory locations of var)
+ imap(1) = 1
+ imap(2) = imap(1) * MXlv
+ start(1)= 1
+ start(2)= 1
+ count(1)= Nlev
+ count(2)= 2
+
+C ** (See UNread for explanations about NCVGTG)
+ Ierro=NF_GET_VARM_REAL(FILEid, varVID, start, count,
+ & stride, imap , Srange(1,1) )
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNwrite', Ierro)
+
+C Update the min an max
+C - - - - - - - - - - -
+C **If this is the first pass, initialise min and max:
+C **(Constant fields shall not be accounted for)
+ DO ll=1, Nlev
+ IF (Srange(ll,1).eq.Srange(ll,2)) THEN
+ Srange(ll,1) = var(1,1,ll)
+ Srange(ll,2) = var(1,1,ll)
+ ENDIF
+ ENDDO
+
+ DO jj=1, NVRj
+ DO ii=1, NVRi
+ DO ll=1, NVRlev
+ Srange(ll,1) = MIN(Srange(ll,1), var(ii,jj,ll))
+ Srange(ll,2) = MAX(Srange(ll,2), var(ii,jj,ll))
+ ENDDO
+ ENDDO
+ ENDDO
+ IF (icheck.ge.4) WRITE(*,*) 'Srange',Srange
+
+
+C Set special variable [var]_range
+C - - - - - - - - - - - - - - - - -
+C **(See UNread for explanations abtout NCVPTG)
+
+ Ierro=NF_PUT_VARM_REAL(FILEid , varVID , start, count,
+ & stride , imap , Srange(1,1) )
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNwrite', Ierro)
+
+ ENDIF ! End Section 5.
+
+C UNwrite_end
+C -----------
+ IF (icheck.ge.2) WRITE(*,*) 'Errors count:',TTerr
+ IF (icheck.ge.2) WRITE(*,*) 'UNwrite : End'
+ 9999 CONTINUE
+ RETURN
+ END
+C**
+C** +-------------------------+-----------------------------------------+
+C** + Subroutine UNlwrite : + +
+C** +-------------------------+ +
+C** + * Writes a 2D horizontal LEVEL into a 3D+time NetCDF variable +
+C** + OR a 1D vector into a 2D+time +
+C** + -- ---- -- +
+C** + (SEE ALSO : UNwrite, for all dimensions - this a pecular case +
+C** + Note: 1D vectors are writen in the 1st dim of 2D+time) +
+C** + +
+C** + * Automatically updates attribute 'actual_range' if available +
+C** + " " special var. '[var]_range' " +
+C** + +
+C** + INPUT : +
+C** + FILEid : input file identifier (from UNcreate OR NetCDF open) +
+C** + VARname : name given to the variable to write (must be in file)+
+C** + itime : No of time step to write to +
+C** + level : No of level to write to +
+C** + Ni, Nj : dimensions of 'var'... +
+C** + var : A 2D variable to be writen +
+C** +-------------------------------------------------------------------+
+
+ SUBROUTINE UNlwrite (FILEid , VARname , itime,
+ & ilev, Ni, Nj, var)
+
+ IMPLICIT NONE
+
+ INCLUDE 'libUN.inc'
+
+ INTEGER icheck
+
+ INTEGER Lvnam
+ PARAMETER (Lvnam=20)
+
+C ** input
+ INTEGER FILEid
+ INTEGER itime, ilev
+ INTEGER Ni, Nj
+ CHARACTER *(*) VARname
+ REAL*4 var(Ni, Nj)
+
+C ** local :
+ INTEGER VARSIZE
+ EXTERNAL VARSIZE
+ INTEGER Ierro, TTerr, Nvatts, vtype
+ INTEGER dimID(4), dimSIZ(4), count(4)
+ INTEGER start(4),stride(4),imap(4)
+ INTEGER iUNLIMDIM
+ CHARACTER*(Lvnam) dimNAM(4)
+ CHARACTER*(Lvnam) recname
+ CHARACTER*(30) tmpchr
+ INTEGER varVID
+ INTEGER VNlen, NDIMvar, NSDIvar, tiDI, ilDI, itmp
+ INTEGER iz, ii, jj
+ LOGICAL OkRange
+ REAL*4 Arange(2), sValRange(2)
+ REAL*4 Srange(2)
+
+ icheck= 0 !** 'debugging' level
+ TTerr = 0 !** 'total numbe of errors
+
+ IF (icheck.ge.1) WRITE(*,*) 'UNlwrite : Begin'
+
+C* 1. Get the variable field and dims IDs
+C ----------------------------------------
+
+ IF (icheck.ge.2) WRITE(*,*) 'FILEid :', FILEid
+
+C ** getting VARname size :
+ VNlen = VARSIZE (VARname)
+ IF (icheck.ge.3) WRITE(*,*) 'VNlen :',VNlen
+ IF (icheck.ge.2) WRITE(*,*) 'VARname :', VARname (1:VNlen)
+
+C ** variable field ID :
+ Ierro=NF_INQ_VARID (FILEid, VARname (1:VNlen), varVID)
+
+C ** Cancel writing if an error occured : variable undefined ?
+ IF (Ierro.ne.0.and.icheck.ge.1) THEN
+ WRITE(*,*) 'UNlwrite Info : Variable ',VARname(1:VNlen)
+ & ,' not found -> not written.'
+ END IF
+ IF (Ierro.ne.0) GOTO 9999 !** UNlwrite_end
+
+
+C ** Inquire about the number of dimensions in var :
+C **
+ Ierro=NF_INQ_VAR(FILEid , varVID, recname, vtype,
+ & NDIMvar, dimID, Nvatts)
+C ** line1 id/file id/var var name var type
+C ** line2 # dims id/dims #attributes
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNlwrite', Ierro)
+
+ IF (icheck.ge.2) WRITE(*,*) 'Ierro1. ', Ierro
+
+
+C* 2. Dimensions : inquire about file + compare with input data.
+C -------------------------------------------------------------
+
+C 2.1 Inquire dimensions names and sizes :
+C + - - - - - - - - - - - - - - - - - - - - -
+ DO iz = 1,4
+ dimSIZ(iz)=0
+ dimNAM(iz)=' '
+C ** Set any unused dimension to "0" size / no name
+ END DO
+
+ DO iz = 1,NDIMvar
+ Ierro=NF_INQ_DIM(FILEid , dimID(iz), dimNAM(iz), dimSIZ(iz))
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNlwrite', Ierro)
+C ** id/file id/dim dimname dimsize error
+C ** !output output
+ END DO
+ IF (icheck.ge.3) WRITE(*,*) 'NDIMvar ',NDIMvar
+ IF (icheck.ge.3) WRITE(*,*) 'Ierro 2.0',Ierro
+
+C 2.2 Set writing region according to field dimension : 3D
+C + - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C ** Set horizontal dimensions (all field dims):
+ count(1) = Ni
+ count(2) = Nj
+ start(1) = 1
+ start(2) = 1
+C +- ------ 3D+time var in file--------
+ IF (NDIMvar.eq.4) THEN
+ NSDIvar = 2 ! # input space dims (for a 2D level)
+ tiDI = 4 ! No. of the time dim
+C ** write one level (set the level No) :
+ start(3) = ilev ! Start of index 3 in var
+ count(3) = 1 ! # values of index 3 in var
+ ilDI = 3
+C ** write one time step:
+ start(4) = itime
+ count(4) = 1
+C +- ------ 2D+time var in file--------
+ ELSE IF (NDIMvar.eq.3) THEN
+ NSDIvar = 1 ! # input space dims (for a 1D vector)
+ tiDI = 3 ! No. of the time dim
+C ** write one "level" - here a 1D vector in the 1st dim.
+ start(2) = ilev ! Start of index 2 in var
+ count(2) = 1 ! # values of index 3 in var
+ ilDI = 2
+C ** write one time step:
+ start(3) = itime
+ count(3) = 1
+ ELSE
+ WRITE(*,*) 'UNlwrite ERROR : data field dimension ?'
+ WRITE(*,*) ' NB: UNlwrite = only for (2 or) 3D +time.'
+ STOP
+ END IF
+
+C 2.3 Compare file dimensions to input data.
+C + - - - - - - - - - - - - - - - - - - - - - -
+C ** Space dimensions :
+ DO iz = 1,NSDIvar
+ IF (dimSIZ(iz).gt.count(iz)) THEN
+ write(*,*) 'UNlwrite - WARNING: '
+ write(*,*) ' Your field ',VARname,' has an empty part.'
+ write(*,*) ' (for the dimension:',dimNAM(iz),')'
+ ELSE IF (dimSIZ(iz).lt.count(iz)) THEN
+ write(*,*) 'UNlwrite - WARNING: '
+ write(*,*) ' Your field ',VARname,' will be truncated.'
+ write(*,*) ' (for the dimension:',dimNAM(iz),')'
+ count(iz) = dimSIZ(iz)
+ END IF
+ END DO
+
+C ** Space dimensions - check if requested level exists:
+ IF (dimSIZ(ilDI).lt.ilev) THEN
+ write(*,*) 'UNlwrite - ERROR: '
+ write(*,*) ' The requested level =',ilev
+ write(*,*) ' does not exist in the field ',VARname
+ write(*,*) ' (for the dimension:',dimNAM(ilDI),')'
+ STOP
+ END IF
+
+C ** Time dimension (when defined):
+ IF (tiDI.ne.0) THEN
+ IF (itime.gt.dimSIZ(tiDI)) THEN
+ IF (icheck.ge.1) WRITE(*,*) 'Time limit, ID', dimID(tiDI)
+ Ierro= NF_INQ_UNLIMDIM (FILEid, iUNLIMDIM)
+ IF (dimID(tiDI).NE.iUNLIMDIM) THEN
+ WRITE(*,*) 'UNlwrite - ERROR: '
+ WRITE(*,*) ' Time index out of range '
+ STOP
+ ENDIF
+ END IF
+ END IF
+
+ IF (icheck.ge.2) WRITE(*,*) 'Ierro2. ', Ierro
+ IF (icheck.ge.2) WRITE(*,*) 'Dimension names :',dimNAM
+ IF (icheck.ge.3) WRITE(*,*) 'dimSIZ :',dimSIZ
+ IF (icheck.ge.3) WRITE(*,*) 'count :',count
+ IF (icheck.ge.3) WRITE(*,*) 'start :',start
+ IF (icheck.ge.3) WRITE(*,*) 'dimID :',dimID
+
+C* 3. Write variable.
+C ------------------
+
+C ** Set 'imap' and WRITE with NCVPTG:
+C ** NOTE : since the arrays (grid_*) may be over-dimensionned,
+C ** we use the 'generalised' writing routine NCVPTG
+C ** (imap tells NetCDF about the memory locations of var)
+ imap(1) = 1
+ imap(2) = imap(1) * Ni ! 1st dim of var = Ni
+ imap(3) = imap(2) * Nj ! (not used: 1 level...)
+ imap(4) = 0 ! (not used: 0 or 1 time step)
+ DO iz=1,4
+ stride(iz)=1
+ END DO
+C ** NOTE: stride is not used.
+
+ Ierro=NF_PUT_VARM_REAL (FILEid , varVID , start , count,
+ & stride , imap , var(1,1) )
+C ** line1: id/file | id/var |read from...|#data
+C ** line2: step |re-arrang|variable(beg.)
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNlwrite', Ierro)
+
+ IF (icheck.ge.2) WRITE(*,*) 'Ierro3.2', Ierro
+
+C* 4a. Update 'actual_range' attribute.
+C ------------------------------------
+
+C If 'actual_range' available, get its current value:
+C - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+C ** Get the old min and max values:
+ Ierro=NF_GET_ATT_REAL(FILEid ,varVID ,'actual_range' ,
+ & Arange )
+c **line1 ^^^^^^^^^^^^^^^ FILEid |var.id | attr.name
+C **line2 value
+
+C ** Cancel if an error occured : attribute undefined ?
+ IF (Ierro.ne.0.and.icheck.ge.1) THEN
+ WRITE(*,*) 'UNlwrite Info : attribute actual_range '
+ & ,' not found -> not written.'
+ END IF
+ IF (Ierro.ne.0) GOTO 9990 !** Next section
+
+C If 'valid_range' available, get its current value:
+C - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+C ** Get the min/max valid range (outside = missing val):
+ Ierro=NF_GET_ATT_REAL(FILEid ,varVID ,'valid_range' ,
+ & sValRange)
+ IF (Ierro.ne.0) THEN
+ sValRange(1)=ValRange(1)
+ sValRange(1)=ValRange(2)
+ END IF
+
+C Update the min an max
+C - - - - - - - - - - -
+
+C **If this is the first pass, initialise min and max:
+ IF ( Arange(1).EQ. NF_FILL_REAL
+ . .OR. (Arange(1).EQ. 0.0 .AND. Arange(2).EQ. 0.0) ) THEN
+ OkRange = .false.
+ ELSE
+ OkRange = .true.
+ ENDIF
+
+ DO jj=1, Nj
+ DO ii=1, Ni
+ IF ( var(ii,jj).GE.sValRange(1)
+ & .AND. var(ii,jj).LE.sValRange(2)) THEN
+ IF (OkRange) THEN
+ Arange(1) = MIN(Arange(1), var(ii,jj))
+ Arange(2) = MAX(Arange(2), var(ii,jj))
+ ELSE
+ Arange(1) = var(ii,jj)
+ Arange(2) = var(ii,jj)
+ OkRange = .true.
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDDO
+ IF (icheck.ge.2) WRITE(*,*) 'Arange',Arange
+
+C Set attribute.
+C - - - - - - - -
+
+ Ierro=NF_PUT_ATT_REAL(FILEid ,varVID ,'actual_range' ,
+ & NF_FLOAT,2 ,Arange )
+c **line1 ^^^^^^^^^^^^^^^ FILEid |var.id | attr.name
+C **line2 type |len | attr.value
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNlwrite', Ierro)
+ TTerr = TTerr + ABS(Ierro)
+
+C ** Next section:
+ 9990 CONTINUE
+
+
+C* 5. Update the optional '[var]_range' special variable.
+C ------------------------------------------------------
+ IF (NDIMvar.eq.4) THEN
+
+C If '[var]_range' available, get its current value:
+C - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+C ** Get ID of variable [var]_range :
+ tmpchr = VARname(1:VNlen)//'_range'
+ itmp = VNlen + 6
+ Ierro=NF_INQ_VARID (FILEid, tmpchr(1:itmp), varVID)
+
+C ** Cancel if an error occured : undefined ?
+ IF (Ierro.ne.0.and.icheck.ge.1) THEN
+ WRITE(*,*) 'UNlwrite Info : [var]_range '
+ & ,' not found -> not written.'
+ END IF
+ IF (Ierro.ne.0) GOTO 9999 !** UNlwrite_end
+
+C ** Get the old min and max values:
+C ** NOTE :
+C ** we use the 'generalised' reading routine NCVGTG
+C ** (imap tells NetCDF about the memory locations of var)
+ imap(1) = 1
+ imap(2) = 0 ! Not used (write only 1 lev)
+ start(1)= ilev
+ count(1)= 1
+ start(2)= 1
+ count(2)= 2
+
+C ** (See UNread for explanations abtout NCVGTG)
+ Ierro=NF_GET_VARM_REAL(FILEid, varVID, start ,count,
+ & stride, imap , Srange(1) )
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNlwrite', Ierro)
+
+C Update the min an max
+C - - - - - - - - - - -
+C **If this is the first pass, initialise min and max:
+C **(Constant fields shall not be accounted for)
+ IF (Srange(1).eq.Srange(2)) THEN
+ Srange(1) = var(1,1)
+ Srange(2) = var(1,1)
+ ENDIF
+
+ DO jj=1, Nj
+ DO ii=1, Ni
+ Srange(1) = MIN(Srange(1), var(ii,jj))
+ Srange(2) = MAX(Srange(2), var(ii,jj))
+ ENDDO
+ ENDDO
+ IF (icheck.ge.4) WRITE(*,*) 'Srange',Srange
+
+
+C Set special variable [var]_range
+C - - - - - - - - - - - - - - - - -
+C **(See UNread for explanations abtout NCVPTG)
+
+ Ierro=NF_PUT_VARM_REAL(FILEid , varVID , start , count,
+ & stride , imap , Srange(1) )
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNlwrite', Ierro)
+
+ ENDIF ! End Section 5.
+
+C UNlwrite_end
+C -----------
+ IF (icheck.ge.2) WRITE(*,*) 'Errors count:',TTerr
+ IF (icheck.ge.2) WRITE(*,*) 'UNlwrite : End'
+ 9999 CONTINUE
+ RETURN
+ END
+C**
+C** +-------------------------+-----------------------------------------+
+C** + Subroutine UNread : + +
+C** +-------------------------+ +
+C** + * Reads a model variable from a NetCDF file, +
+C** + and reads the coordinates of the grid upon wich it is defined. +
+C** + (the NetCDF file must have been opened and must be closed +
+C** + after all reading operations). May read an x-y subregion. +
+C** + +
+C** + INPUT : +
+C** + FILEid : input file identifier (from NetCDF open) +
+C** + VARname : name of the requested variable. +
+C** + time : [integer*4] is the time index of the data field to read +
+C** + level: [integer*4] (usefull for 3D-space fields only) : +
+C** + if not=0 --> = no of the level +
+C** + -> output is 2D (l_dim = 1) +
+C** + if =0 --> read ALL levels +
+C** + -> output is 3D +
+C** + i_dbeg, j_dbeg : horizontal indexes of requested region +
+C** + in input data file +
+C** + i_dim, j_dim, l_dim : ...the dimensions of 'var', +
+C** + = the dimensions of the sub-region to read +
+C** + ! l_dim = 1 if level not=0 +
+C** + ! j_dim = 1 if var is 1D +
+C** + OUTPUT : +
+C** + varax1[i_dim] (real ) +
+C** + varax2[j_dim]: Horizontal coordinates in the file (lat/lon,...)+
+C** + varlev[l_dim]: vertical coordinate of the levels +
+C** + (! when level not=0, only varlev(1) is defined) +
+C** + var_units : physical units of var. +
+C** + var[i_dim,j_dim,l_dim] : +
+C** + data field values +
+C** + (var must be defined, and is REAL ) +
+C** + +
+C** +-------------------------------------------------------------------+
+
+ SUBROUTINE UNread
+ & (FILEid , VARname , time, level, i_dbeg, j_dbeg,
+ & i_dim , j_dim , l_dim ,
+ & varax1 , varax2 , varlev,
+ & var_units, var)
+ use netcdf
+ IMPLICIT NONE
+ INCLUDE 'libUN.inc'
+
+ INTEGER icheck
+
+ INTEGER Lvnam
+ PARAMETER (Lvnam=21)
+
+C ** input
+ INTEGER FILEid
+ INTEGER time, level, i_dbeg, j_dbeg
+ INTEGER i_dim, j_dim, l_dim
+ CHARACTER *(*) VARname
+
+C ** output
+ REAL*4 varax1(i_dim), varax2(j_dim), varlev(l_dim)
+ CHARACTER *(*) var_units
+ REAL*4 var (i_dim, j_dim, l_dim)
+
+C ** local :
+ INTEGER VARSIZE
+ EXTERNAL VARSIZE
+ REAL*4 varmin,varmax
+ REAL*8 add_offset,scale_factor
+ INTEGER Ierro, Nvatts, vtype
+ INTEGER dimID(4), dimSIZ(4), dimREG(4)
+ INTEGER start(4),begREG(4),count(4),stride(4),imap(4)
+ CHARACTER*(Lvnam) dimNAM(4)
+ CHARACTER*(Lvnam) dNAMver, dNAMtim
+ CHARACTER*(Lvnam) recname
+ CHARACTER*(10) Routine
+ INTEGER ax1VID, ax2VID, verVID, timVID, varVID
+ INTEGER VNlen, varNUMDIM
+ INTEGER ii,jj,ll,z
+
+ icheck= 0
+C* 0. Initialisations
+C ------------------
+ Routine= 'UNread'
+ IF (icheck.ge.1) WRITE(*,*) 'UNread : Begin'
+
+ DO ii = 1,4
+ stride(ii) = 1
+ begREG(ii) = 1
+ start (ii) = 1
+ ENDDO
+
+C* 1. Get the variable field and dims IDs
+C ----------------------------------------
+
+ IF (icheck.ge.3) WRITE(*,*) 'FILEid :', FILEid
+
+C ** getting VARname size :
+ VNlen = VARSIZE(VARname)
+ IF (icheck.ge.3) WRITE(*,*) 'VNlen :',VNlen
+ IF (icheck.ge.2) WRITE(*,*) 'VARname :', VARname (1:VNlen)
+
+C ** variable field ID :
+ Ierro=NF_INQ_VARID (FILEid, VARname (1:VNlen), varVID)
+
+C* 1b. Handle non-existing variables
+C ---------------------------------
+ IF (Ierro.NE.NF_NOERR) THEN
+ IF (Ierro.EQ.NF_ENOTVAR .AND. iVarWarn.LE.1) THEN
+ IF (iVarWarn.EQ.1) THEN
+ write(*,*) 'WARNING (UNsread): variable not found:'
+ write(*,*) ' ',varName
+ ENDIF
+ DO ll=1,l_dim
+ DO jj=1,j_dim
+ DO ii=1,i_dim
+ var (ii,jj,ll)=VarRepl
+ ENDDO
+ ENDDO
+ ENDDO
+ RETURN ! EXIT SUBROUTINE, read nothing
+ ENDIF
+ WRITE(*,*) 'Error reading variable: ', VARname(1:VNlen)
+ CALL HANDLE_ERR('UNsread',Ierro)
+ ENDIF
+
+C 1c. Inquire about the number of dimensions in var
+C -------------------------------------------------
+
+ Ierro=NF_INQ_VAR(FILEid , varVID, recname, vtype,
+ & varNUMDIM, dimID, Nvatts )
+C ** line1 id/file id/var var name var type
+C ** line2 # dims id/dims #attributes
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNsread', Ierro)
+
+ IF (icheck.ge.3) WRITE(*,*) 'Ierro1. ', Ierro
+
+
+C* 2. Dimensions : in the reading region and in the file.
+C ------------------------------------------------------
+
+C ** inquire dimensions names and sizes :
+ DO z = 1,varNUMDIM
+ Ierro=NF_INQ_DIM(FILEid , dimID(z), dimNAM(z), dimSIZ(z))
+C ** id/file id/dim dimname dimsize
+C ** !output output
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR(Routine, Ierro)
+ END DO
+
+
+C ** In this version, we read only a xy subregion of the file :
+ dimREG(1) = i_dim
+ dimREG(2) = j_dim
+ begREG(1) = i_dbeg
+ begREG(2) = j_dbeg
+ IF (begREG(1).lt.1) begREG(1) = 1
+ IF (begREG(2).lt.1) begREG(2) = 1
+
+C ** Set reading region according to field dimension : 2D or 3D
+ IF (varNUMDIM.eq.4) THEN
+C ** for 3D fields :
+ IF (level.gt.0) THEN
+C ** one level is read :
+ dimREG(3) = 1
+ begREG(3) = level
+ dNAMver = dimNAM(3)
+ ELSE
+C ** all levels are read :
+ dimREG(3) = l_dim
+ begREG(3) = 1
+ dNAMver = dimNAM(3)
+ END IF
+C ** one time step is read:
+ dimREG(4) = 1
+ begREG(4) = time
+ dNAMtim = dimNAM(4)
+ ELSE IF (varNUMDIM.eq.3) THEN
+C ** for 2D space fields + time:
+C ** one time step is read:
+ dimREG(3) = 1
+ begREG(3) = time
+ dNAMtim = dimNAM(3)
+ dimREG(4) = 0
+ begREG(4) = 0
+ dimNAM(4) = 'none'
+ ELSE IF (varNUMDIM.eq.2) THEN
+C ** for 2D fields :
+C ** no time step is read:
+ dimREG(3) = 0
+ begREG(3) = 0
+ dNAMtim = 'none'
+ dimNAM(3) = 'none'
+ dimREG(4) = 0
+ begREG(4) = 0
+ dimNAM(4) = 'none'
+ ELSE IF (varNUMDIM.eq.1) THEN
+C ** for 1D variable :
+C ** not assumed to be on a XYZ grid,
+C ** just read a vector
+ dimREG(2) = 0
+ begREG(2) = 0
+ dimNAM(2) = 'none'
+ dimREG(3) = 0
+ begREG(3) = 0
+ dimNAM(3) = 'none'
+ dNAMtim = 'none'
+ dimREG(4) = 0
+ begREG(4) = 0
+ dimNAM(4) = 'none'
+ ELSE
+ WRITE(*,*) 'UNread ERROR : data field dimension ?'
+ STOP
+ END IF
+
+ DO z = 1,varNUMDIM
+ IF (begREG(z).gt.dimSIZ(z)) THEN
+ write(*,*) 'UNread - ERROR : requested area out '
+ write(*,*) ' of file area. '
+ write(*,*) ' (for the dimension:' , dimNAM(z) , ')'
+ STOP
+ END IF
+ IF (dimSIZ(z).lt.(dimREG(z)+begREG(z)- 1) ) THEN
+ write(*,*) 'UNread - WARNING : empty portion in field, '
+ write(*,*) ' requested region > file contents '
+ write(*,*) ' (for the dimension:' , dimNAM(z) , ')'
+ dimREG(z) = dimSIZ(z) - begREG(z) + 1
+ END IF
+ END DO
+
+ IF (icheck.ge.3) WRITE(*,*) 'Ierro2. ', Ierro
+ IF (icheck.ge.2) WRITE(*,*) 'Dimension names :',dimNAM
+ IF (icheck.ge.2) WRITE(*,*) 'dimSIZ :',dimSIZ
+ IF (icheck.ge.2) WRITE(*,*) 'dimREG :',dimREG
+ IF (icheck.ge.2) WRITE(*,*) 'begREG :',begREG
+ IF (icheck.ge.3) WRITE(*,*) 'dimID :',dimID
+
+C* 3. Get the variables IDs for the grid points locations.
+C -------------------------------------------------------
+
+ IF (varNUMDIM.ge.2) THEN
+ Ierro=NF_INQ_VARID (FILEid, dimNAM(1), ax1VID)
+ IF (Ierro.NE.NF_NOERR) THEN
+ IF (Ierro.EQ.NF_ENOTVAR) THEN
+ WRITE(*,*) 'Coordinate values not found:',dimNAM(1)
+ ENDIF
+ CALL HANDLE_ERR(Routine, Ierro)
+ ENDIF
+ Ierro=NF_INQ_VARID (FILEid, dimNAM(2), ax2VID)
+ IF (Ierro.NE.NF_NOERR) THEN
+ IF (Ierro.EQ.NF_ENOTVAR) THEN
+ WRITE(*,*) 'Coordinate values not found:',dimNAM(2)
+ ENDIF
+ CALL HANDLE_ERR(Routine, Ierro)
+ ENDIF
+ ENDIF
+ IF (varNUMDIM.ge.3) THEN
+ Ierro=NF_INQ_VARID (FILEid, dNAMtim, timVID)
+ IF (Ierro.NE.NF_NOERR) THEN
+ IF (Ierro.EQ.NF_ENOTVAR) THEN
+ WRITE(*,*) 'Coordinate values not found:',dNAMtim
+ ENDIF
+ CALL HANDLE_ERR(Routine, Ierro)
+ ENDIF
+ END IF
+ IF (varNUMDIM.eq.4) THEN
+ Ierro=NF_INQ_VARID (FILEid, dNAMver, verVID)
+ IF (Ierro.NE.NF_NOERR) THEN
+ IF (Ierro.EQ.NF_ENOTVAR) THEN
+ WRITE(*,*) 'Coordinate values not found:',dNAMver
+ ENDIF
+ CALL HANDLE_ERR(Routine, Ierro)
+ ENDIF
+ END IF
+C ** id/file name id/var
+
+ IF (icheck.ge.3) WRITE(*,*) 'Ierro3. ', Ierro
+
+C* 4. Get attributes.
+C ------------------
+
+ IF (varNUMDIM.ge.2) THEN !Not for 1D vectors (special case)
+C ** units attribute
+ Ierro=NF_GET_ATT_TEXT (FILEid , varVID, 'units',
+ & var_units)
+ IF (Ierro.NE.NF_NOERR) THEN
+ IF (Ierro.EQ.NF_ENOTATT) THEN
+ write(*,*) 'Note (UNread): units not found for'
+ write(*,*) ' ',varName
+ var_units=' '
+ ELSE
+ CALL HANDLE_ERR('UNread',Ierro)
+ ENDIF
+ ENDIF
+
+ IF (icheck.ge.2) WRITE(*,*) 'var_units :', var_units
+ ENDIF
+
+ Ierro=NF_GET_ATT_DOUBLE (FILEid , varVID, 'scale_factor',
+ & scale_factor )
+
+ Ierro=NF_GET_ATT_DOUBLE (FILEid , varVID, 'add_offset',
+ & add_offset )
+
+ if (Ierro.NE.NF_NOERR.and.Ierro.EQ.NF_ENOTATT) THEN
+ scale_factor=1.
+ add_offset =0.
+ ELSE
+ IF (icheck.ge.2)
+ & print *,VARname (1:VNlen)//" scale_factor",scale_factor
+ IF (icheck.ge.2)
+ & print *,VARname (1:VNlen)//" add_offset",add_offset
+ ENDIF
+
+C* 5. Get values.
+C --------------
+C* 5.1 ...for the grid points locations.
+C -------------------------------------
+
+C ** Horizontal : always read, except for 1D vectors
+ IF (varNUMDIM.ge.2) THEN
+ count(1)=dimREG(1)
+ start(1)=begREG(1)
+ Ierro=NF_GET_VARA_REAL(FILEid ,ax1VID,start,count,varax1)
+C ** id/file id/var from #data data
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR(Routine, Ierro)
+ count(1)=dimREG(2)
+ start(1)=begREG(2)
+ Ierro=NF_GET_VARA_REAL(FILEid ,ax2VID,start,count,varax2)
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR(Routine, Ierro)
+ ENDIF
+
+C ** vertical : only for 3D fields.
+ IF (varNUMDIM.eq.4) THEN
+ start(1) =begREG(3)
+ count(1) =dimREG(3)
+ Ierro = NF_GET_VARA_REAL(FILEid ,verVID,start,count,varlev)
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR(Routine, Ierro)
+ END IF
+
+ IF (icheck.ge.3) WRITE(*,*) 'Ierro5.1', Ierro
+
+C* 5.2 ...for the the variable.
+C ----------------------------
+
+C ** Set 'imap' and READ with NCVGTG:
+C ** NOTE :
+C ** we use the 'generalised' reading routine NCVGTG
+C ** (imap tells NetCDF about the memory locations of var)
+ imap(1) = 1
+ imap(2) = imap(1) * i_dim ! 1st dim of var = i_dim
+ imap(3) = imap(2) * j_dim ! 2nd dim of var = j_dim
+ imap(4) = 0 ! Should NEVER be used
+
+ Ierro=nf90_get_var(FILEid,varVID,var,begREG,dimREG)
+
+c Ierro=NF_GET_VARM_REAL(FILEid , varVID ,begREG , dimREG,
+c & stride , imap ,var(1,1,1) )
+C ** line1: id/file | id/var |read from...|#data
+C ** line2: step |re-arrang|variable(beg.)
+C ** NOTE: stride is not used here.
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR(Routine, Ierro)
+
+ IF (icheck.ge.3) WRITE(*,*) 'Ierro5.2', Ierro
+
+
+ DO ll=1,l_dim
+ DO jj=1,j_dim
+ DO ii=1,i_dim
+ var(ii,jj,ll)=var(ii,jj,ll)*scale_factor
+ & +add_offset
+ ENDDO
+ ENDDO
+ ENDDO
+
+C* 6. Check data
+C -------------
+ IF (ireadchk.GE.1) THEN
+ varmax = var (1,1,1)
+ varmin = var (1,1,1)
+ DO ll=1,l_dim
+ DO jj=1,j_dim
+ DO ii=1,i_dim
+ var(ii,jj,ll)=var(ii,jj,ll)+0.
+C This fixes underflow values but must compile with -fpe1
+ varmax = MAX(var (ii,jj,ll),varmax)
+ varmin = MIN(var (ii,jj,ll),varmin)
+ ENDDO
+ ENDDO
+ ENDDO
+ IF (varmin.LT.vReadMin .OR. varmax.GT.vReadMax) THEN
+ write(*,*) 'WARNING (UNread): variable ', VARname
+ write(*,*) ' is out of specified bounds;'
+ write(*,*) ' min is:', varmin
+ write(*,*) ' max is:', varmax
+ ENDIF
+ ENDIF
+
+ IF (icheck.ge.2) WRITE(*,*) 'UNread : End'
+
+ END SUBROUTINE UNread
+
+C**
+C** +-------------------------+-----------------------------------------+
+C** + Subroutine UNsread : + +
+C** +-------------------------+ +
+C** + * Reads a model variable from a NetCDF file, +
+C** + SIMPLIFIED VERSION of UNread : does NOT read coordinates. +
+C** + +
+C** + +
+C** + INPUT : +
+C** + FILEid : input file identifier (from NetCDF open) +
+C** + VARname : name of the requested variable. +
+C** + time : [integer*4] is the time index of the data field to read +
+C** + level: [integer*4] (usefull for 3D-space fields only) : +
+C** + if not=0 --> = no of the level +
+C** + -> output is 2D (l_dim = 1) +
+C** + if =0 --> read ALL levels +
+C** + -> output is 3D +
+C** + i_dbeg, j_dbeg : horizontal indexes of requested region +
+C** + in input data file +
+C** + i_dim, j_dim, l_dim : ...the dimensions of 'var', +
+C** + = the dimensions of the sub-region to read +
+C** + ! l_dim = 1 if level not=0 +
+C** + ! j_dim = 1 if var is 1D +
+C** + OUTPUT : +
+C** + var_units : physical units of var. +
+C** + var[i_dim,j_dim,l_dim] : +
+C** + data field values +
+C** + (var must be defined, and is REAL ) +
+C** + +
+C** +-------------------------------------------------------------------+
+
+ SUBROUTINE UNsread
+ & (FILEid, VARname, time, level, i_dbeg, j_dbeg,
+ & i_dim , j_dim , l_dim,
+ & var_units, var)
+ use netcdf
+
+ IMPLICIT NONE
+
+C ** input
+ INTEGER FILEid
+ INTEGER time, level, i_dbeg, j_dbeg
+ INTEGER i_dim, j_dim, l_dim
+ CHARACTER *(*) VARname
+
+C ** output
+ CHARACTER *(*) var_units
+ REAL*4 var (i_dim, j_dim, l_dim)
+ REAL*4 varax1(i_dim), varax2(j_dim), varlev(l_dim)
+
+
+ call UNread (FILEid , VARname , time, level, i_dbeg, j_dbeg,
+ & i_dim , j_dim , l_dim ,
+ & varax1 , varax2 , varlev,
+ & var_units, var)
+
+
+ END SUBROUTINE UNsread
+
+C** +-------------------------+-----------------------------------------+
+C** + Subroutine UNwcatt : + +
+C** +-------------------------+ +
+C** + *Character Attributes creation and (over)writing +
+C** + (the NetCDF file must be open, in data mode) +
+C** + *WARNING: this routine (may?) use a temporary disk space +
+C** + equal to the file length (duplicate the file) +
+C** + +
+C** + INPUT : +
+C** + FILEid : input file identifier (from UNcreate OR NetCDF open) +
+C** + varnam : name of variable to which attribute shall be attached+
+C** + or 'GLOBAL_ATT' +
+C** + attnam : name of writen attribute. +
+C** + attval : string to be assigned to attribute. +
+C** + (never inclulde more than 3 consecutive blanks !) +
+c** + +
+C** + Note : all arguments except FILEid are strings of any length +
+C** +-------------------------------------------------------------------+
+
+ SUBROUTINE UNwcatt (FILEid , varnam, attnam, attval)
+
+ INCLUDE 'libUN.inc'
+
+C **Input:
+
+ INTEGER FILEid
+ CHARACTER*(*) varnam
+ CHARACTER*(*) attnam
+ CHARACTER*(*) attval
+
+C **Local:
+ INTEGER VARSIZE
+ EXTERNAL VARSIZE
+ INTEGER Nlen, Ierro, varVID, Vlen, TTerr
+ INTEGER icheck
+ icheck= 0 !** 'debugging' level
+
+ IF (icheck.ge.1) WRITE(*,*) 'UNwcatt : Begin'
+
+C* Get the variable ID
+C -------------------
+
+ IF (icheck.ge.2) WRITE(*,*) 'FILEid :', FILEid
+
+C ** getting varnam size :
+ Nlen = VARSIZE(varnam)
+
+C ** Case of global attributes:
+ IF (varnam(1:Nlen).EQ.'GLOBAL_ATT') THEN
+ varVID=NF_GLOBAL
+
+ ELSE
+
+C ** Get variable ID to which att is attached to:
+ Ierro=NF_INQ_VARID (FILEid , varnam(1:Nlen), varVID)
+ TTerr = ABS(Ierro)
+
+C ** Cancel writing if an error occured : variable undefined ?
+ IF (Ierro.ne.0) THEN
+ WRITE(*,*) 'UNwcatt -ERROR : Variable ',varnam(1:Nlen)
+ & ,' not found -> not written.'
+ END IF
+ IF (Ierro.ne.0) RETURN !** UNwcatt_end
+
+ ENDIF
+
+C Switch to Define Mode,
+C because attribute may be created or change size.
+C --------------------------------------------------
+ Ierro=NF_REDEF (FILEid)
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNwcatt', Ierro)
+
+C Set attribute.
+C --------------
+
+C ** getting attnam [char] size :
+ Nlen = VARSIZE(attnam)
+C ** getting attval [char] size :
+ Vlen = VARSIZE(attval)
+
+ Ierro=NF_PUT_ATT_TEXT(FILEid ,varVID ,attnam(1:Nlen),
+ & Vlen ,attval(1:Vlen) )
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNwcatt', Ierro)
+c **line1^^^^ FILEid |var.id | attr.name
+C **line2 type | len | attr.value | flag
+ TTerr = TTerr + ABS(Ierro)
+
+
+C Leave define mode (!file remains open )
+C ---------------------------------------
+ Ierro=NF_ENDDEF(FILEid )
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNwcatt', Ierro)
+
+ RETURN
+ END
+
+C** +-------------------------+-----------------------------------------+
+C** + Subroutine UNwratt : + +
+C** +-------------------------+ +
+C** + *Real attributes writing - ! Can not create new attrib ! +
+C** + (the NetCDF file must be open) +
+C** + +
+C** + INPUT : +
+C** + FILEid : input file identifier (from UNcreate OR NetCDF open) +
+C** + varnam : name given to the variable to write (must be in file)+
+C** + attnam : name of treated attribute. +
+c** + Nvals : Number of values of that attribute +
+C** + atvalsi(Nvals) : Real vector of values for attribute. +
+c** + +
+C** +-------------------------------------------------------------------+
+
+C WARNING: this routine uses a temporary disk space
+C equal to the file length (duplicate the file)
+C (its use is NOT recommended)
+
+ SUBROUTINE UNwratt (FILEid , varnam, attnam, Nvals, atvals)
+
+ INCLUDE 'libUN.inc'
+
+C **Input:
+
+ INTEGER FILEid , Nvals
+ CHARACTER*(*) varnam
+ CHARACTER*(*) attnam
+ REAL*4 atvals(Nvals)
+
+C **Local:
+ INTEGER VARSIZE
+ EXTERNAL VARSIZE
+ INTEGER Nlen, Ierro, varVID
+ INTEGER icheck, TTerr
+ icheck= 0 !** 'debugging' level
+ TTerr = 0
+
+ IF (icheck.ge.1) WRITE(*,*) 'UNwratt : Begin'
+
+C* Get the variable ID
+C -------------------
+ IF (icheck.ge.2) WRITE(*,*) 'FILEid :', FILEid
+
+C ** getting varnam size :
+ Nlen = VARSIZE(varnam)
+
+C ** variable ID :
+ Ierro=NF_INQ_VARID(FILEid , varnam(1:Nlen), varVID)
+ TTerr = TTerr + ABS(Ierro)
+
+C ** Cancel writing if an error occured : variable undefined ?
+ IF (Ierro.ne.0) THEN
+ WRITE(*,*) 'UNwratt -ERROR : Variable ',varnam(1:Nlen)
+ & ,' not found -> not written.'
+ END IF
+ IF (Ierro.ne.0) GOTO 9999 !** UNwratt_end
+
+
+C Set attribute.
+C --------------
+
+C ** getting attnam [char] size :
+ Nlen = VARSIZE(attnam)
+
+ Ierro=NF_PUT_ATT_REAL(FILEid ,varVID ,attnam(1:Nlen),
+ & NF_FLOAT,nvals ,atvals )
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNwratt', Ierro)
+c **line1^^^^FILEid |var.id | attr.name
+C **line2 type | attr.value | flag
+ TTerr = TTerr + ABS(Ierro)
+
+
+ 9999 continue
+ RETURN
+ END
+
+C** +-------------------------+-----------------------------------------+
+C** + Subroutine UNwopen : + libUN (0896) +
+C** +-------------------------+-----------------------------------------+
+C** + * Open a NetCDF file for writing. +
+C** + +
+C** + INPUT : +
+C** + FILEnam : file name +
+C** + +
+C** + OUTPUT : +
+C** + FILEid : NetCDF file identifier ('logical unit') +
+C** +---------------------------------------------------------------7++++
+
+ SUBROUTINE UNwopen (FILEnam, FILEid )
+
+ IMPLICIT NONE
+ INCLUDE 'libUN.inc'
+
+C ** input
+ CHARACTER*(*) FILEnam
+
+C ** output
+ INTEGER FILEid
+
+C ** local :
+ INTEGER Ierro
+ INTEGER icheck
+
+ icheck=0
+
+C + Routines which opens a file must reset libUN internals:
+ CALL UNparam('RESET_PARAMS_',0.0)
+
+C ** Open NetCDF file, for read-only:
+C -----------------------------------
+ Ierro=NF_OPEN(FILEnam,NF_WRITE,FILEid)
+ IF (Ierro.NE.NF_NOERR) THEN
+ WRITE(*,*) 'Error opening file: ', FILEnam
+ CALL HANDLE_ERR('UNwopen', Ierro)
+ ENDIF
+
+
+9999 continue
+ RETURN
+ END
+
+
+
+C** +-------------------------+-----------------------------------------+
+C** + Subroutine UNropen : + libUN (0896) +
+C** +-------------------------+-----------------------------------------+
+C** + * Open a NetCDF file for reading, +
+C** + +
+C** + INPUT : +
+C** + FILEnam : file name +
+C** + +
+C** + OUTPUT : +
+C** + FILEid : NetCDF file identifier ('logical unit') +
+C** + FILEtit : title of the NetCDF file +
+C** + ! [CHAR], must be defined (length > length(title) !) +
+C** +---------------------------------------------------------------7++++
+
+ SUBROUTINE UNropen (FILEnam, FILEid , FILEtit)
+
+ IMPLICIT NONE
+ INCLUDE 'libUN.inc'
+
+C ** input
+ CHARACTER*(*) FILEnam
+
+C ** output
+ INTEGER FILEid
+ CHARACTER*(*) FILEtit
+
+C ** local :
+ INTEGER Ierro
+ INTEGER icheck
+
+ icheck=0
+
+ IF (icheck.ge.2) WRITE(*,*) 'UNropen: Begin'
+ IF (icheck.ge.2) WRITE(*,*) 'FILEnam: ', FILEnam
+
+C + Routines which opens a file must reset libUN internals:
+ CALL UNparam('RESET_PARAMS_',0.0)
+
+C ** Open NetCDF file, for read-only:
+C -----------------------------------
+ Ierro=NF_OPEN(FILEnam,NF_NOWRITE,FILEid)
+ IF (Ierro.NE.NF_NOERR) THEN
+ WRITE(*,*) 'Error opening file: ', FILEnam
+ CALL HANDLE_ERR('UNropen', Ierro)
+ ENDIF
+
+
+C ** Read title attribute,
+C ------------------------
+
+C ** Read attribute:
+ Ierro=NF_GET_ATT_TEXT(FILEid, NF_GLOBAL, 'title',
+ & FILEtit)
+
+C ** Display message if an error occured :
+C ** no title or title too long ?
+ !IF (Ierro.ne.0) THEN
+ ! WRITE(*,*) 'UNropen WARNING: no title or title too long'
+ !END IF
+ IF (icheck.ge.2) WRITE(*,*) 'UNropen: End'
+
+9999 continue
+ RETURN
+ END
+
+C** +-------------------------+-----------------------------------------+
+C** + Subroutine UNgtime : + libUN (0896) +
+C** +-------------------------+-----------------------------------------+
+C** + * From a given value of desired 'time' coordinate, +
+C** + gets the coordinate index ('iteration no') + found time value +
+C** + +
+C** + INPUT : +
+C** + FILEid : NetCDF file identifier (from UNropen) +
+C** + RQtime : ReQuested time +
+C** + +
+C** + OUTPUT : +
+C** + RDtime : The last time for wich RDtime .le. RQtime +
+C** + Ftime : The next time value Following RDtime +
+C** + (-1 if it would be after end-of-file) +
+C** + it : The time index : RDtime = time(it) +
+C** +---------------------------------------------------------------7++++
+
+ SUBROUTINE UNgtime (FILEid, RQtime, RDtime, Ftime, it)
+
+ IMPLICIT NONE
+ INCLUDE 'libUN.inc'
+
+ INTEGER Lvnam
+ PARAMETER (Lvnam=20)
+
+C ** input
+ INTEGER FILEid
+ REAL*4 RQtime
+
+C ** output
+ REAL*4 RDtime, Ftime
+ INTEGER it
+
+C ** local :
+ INTEGER Ierro, timVID
+ INTEGER timDID
+ REAL*4 gtim
+ INTEGER K, KHI, KLO, Kmax
+ INTEGER Mindex(1)
+ INTEGER icheck
+ CHARACTER*(Lvnam) dimNAM(1)
+
+ icheck= 0
+
+C ** Kmax= nb pas de temps dans le fichier, = dim(time):
+C ** - - - - - - - - - - - - - - - - - - - - - - - - - -
+C
+ Ierro=NF_INQ_DIMID(FILEid, 'time', timDID)
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNgtime', Ierro)
+C **^^ Dimension'time' NetCDF index
+
+ Ierro=NF_INQ_DIM(FILEid, timDID , dimNAM, Kmax )
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNgtime', Ierro)
+C ** id/file id/dim dimname dimsize error
+C ** !output output
+
+C ** Read/Search the requested time step.
+C ** - - - - - - - - - - - - - - - - - - -
+
+ Ierro=NF_INQ_VARID(FILEid, 'time',timVID)
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNgtime', Ierro)
+C **^^ Variable 'time' NetCDF index
+
+ KLO=1
+ KHI=Kmax
+
+ 1 IF (KHI-KLO.GT.1) THEN
+ K=(KHI+KLO)/2
+
+C ** Set the position of the needed time step:
+ Mindex(1)= K
+C ** Get 1 time value (gtim = time(K)):
+ Ierro=NF_GET_VAR1_REAL(FILEid, timVID, Mindex, gtim)
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNgtime', Ierro)
+
+ IF(gtim.GT.RQtime)THEN
+ KHI=K
+ ELSE
+ KLO=K
+ ENDIF
+ GOTO 1
+ ENDIF
+ it= KLO
+C ** read RDtime= time(KLO)
+ Mindex(1)= KLO
+ Ierro=NF_GET_VAR1_REAL(FILEid, timVID, Mindex, RDtime)
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNgtime', Ierro)
+C ** read Ftime= time(KHI)
+ Mindex(1)= KHI
+ Ierro=NF_GET_VAR1_REAL(FILEid, timVID, Mindex, Ftime)
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNgtime', Ierro)
+
+C ** IF the last available time step is before
+C ** the requested time, then KHI and KLO are the
+C ** two last available time step. Correct this :
+ IF (RQtime.ge.Ftime) THEN
+ RDtime= Ftime
+ it = KHI
+ Ftime= -1.0
+ ENDIF
+
+ RETURN
+ END
+
+C** +-------------------------+-----------------------------------------+
+C** + Subroutine UNgindx : + libUN (0199) +
+C** +-------------------------+-----------------------------------------+
+C** + * From a given value of a desired coordinate, +
+C** + gets the coordinate index + found the coresp. coordinate value +
+C** + +
+C** + INPUT : +
+C** + FILEid : NetCDF file identifier (from UNropen) +
+C** + Cname : The name of the coordinate +
+C** + RQval : The requested value for that coordinate +
+C** + +
+C** + OUTPUT : +
+C** + RDval : The last value for wich RDval .le. RQval +
+C** + Fval : The next val value Following RDval +
+C** + (-1 if it would be after end-of-file) +
+C** + indx : The val index : RDval = value_of_Cname(it) +
+C** +---------------------------------------------------------------7++++
+
+ SUBROUTINE UNgindx (FILEid, Cname, RQval, RDval, Fval, indx)
+
+ IMPLICIT NONE
+ INCLUDE 'libUN.inc'
+
+ INTEGER Lvnam
+ PARAMETER (Lvnam=20)
+
+C ** input
+ INTEGER FILEid
+ CHARACTER *(*) Cname
+ REAL*4 RQval
+
+C ** output
+ REAL*4 RDval, Fval
+ INTEGER indx
+
+C ** local :
+ INTEGER VARSIZE
+ EXTERNAL VARSIZE
+ REAL*4 gval
+ INTEGER Ierro
+ INTEGER varDID, VNlen, varVID, varNUMDIM
+ INTEGER Nvatts, vtype
+ INTEGER K, KHI, KLO, Kmax
+ INTEGER Mindex(1), dimID(4)
+ INTEGER icheck
+ CHARACTER*(Lvnam) dimNAM(4)
+ CHARACTER*13 recname
+
+ icheck= 0
+
+C ** Kmax= nb pas de temps dans le fichier, = dim(val):
+C ** - - - - - - - - - - - - - - - - - - - - - - - - - -
+C ** get Cname string size :
+ VNlen = VARSIZE (Cname)
+C
+C ** get variable ID :
+ Ierro=NF_INQ_VARID(FILEid , Cname (1:VNlen), varVID)
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNgindex', Ierro)
+C
+C ** Inquire about the id of the dimension:
+C **
+ Ierro=NF_INQ_VAR(FILEid , varVID, recname, vtype,
+ & varNUMDIM, dimID , Nvatts)
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNgindex', Ierro)
+C ** line1 id/file id/var var name var type
+C ** line2 # dims id/dims #attributes
+ varDID = dimID(1)
+C ^^^At last, the id of the relevant dimension.
+
+ Ierro=NF_INQ_DIM(FILEid, varDID , dimNAM, Kmax )
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNgindex', Ierro)
+C ** id/file id/dim dimname dimsize error
+C ** !output output
+C ** (Kmax is what we needed: size of the dimension)
+
+C ** Read/Search the requested val step.
+C ** - - - - - - - - - - - - - - - - - - -
+
+ KLO=1
+ KHI=Kmax
+
+ 1 IF (KHI-KLO.GT.1) THEN
+ K=(KHI+KLO)/2
+
+C ** Set the position of the needed val step:
+ Mindex(1)= K
+C ** Get 1 val value (gval = val(K)):
+ Ierro=NF_GET_VAR1_REAL(FILEid, varVID, Mindex, gval)
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNgindex', Ierro)
+
+ IF(gval.GT.RQval)THEN
+ KHI=K
+ ELSE
+ KLO=K
+ ENDIF
+ GOTO 1
+ ENDIF
+ indx= KLO
+C ** read RDval= val(KLO)
+ Mindex(1)= KLO
+ Ierro=NF_GET_VAR1_REAL(FILEid, varVID, Mindex, RDval)
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNgindex', Ierro)
+C ** read Fval= val(KHI)
+ Mindex(1)= KHI
+ Ierro=NF_GET_VAR1_REAL(FILEid, varVID, Mindex, Fval)
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNgindex', Ierro)
+
+C ** IF the last available val step is before
+C ** the requested val, then KHI and KLO are the
+C ** two last available val step. Correct this :
+ IF (RQval.ge.Fval) THEN
+ RDval= Fval
+ indx = KHI
+ Fval= -1.0
+ ENDIF
+
+ RETURN
+ END
+
+C** +-------------------------+-----------------------------------------+
+C** + Subroutine UNfindx : + (libUN 2003)+
+C** +-------------------------+-----------------------------------------+
+C** + * Intended to replace UNgindx or UNgtime +
+C** + From a given value of a desired coordinate, +
+C** + gets the coordinate index + the coresp. coordinate value +
+C** + This version solves the issue of Dates at year change +
+C** + occuring because 1 jan is < 31 dec. Not optimised. +
+C** + +
+C** + INPUT : +
+C** + FILEid : NetCDF file identifier (from UNropen) +
+C** + Cname : The name of the coordinate +
+C** + RQval : The requested value for that coordinate +
+C** + +
+C** + OUTPUT : +
+C** + RDval : The file value closest to RQval +
+C** + Fval : The next value in the file +
+C** + (-1 if after file end) +
+C** + (This is mainly for compatibility with older version)+
+C** + indx : The val index : RDval = value_of_Cname(it) +
+C** + (-1 may be returned if the value can't be found) +
+C** +---------------------------------------------------------------7++++
+
+ SUBROUTINE UNfindx (FILEid, Cname, RQval, RDval, Fval, indx)
+
+ IMPLICIT NONE
+ INCLUDE 'libUN.inc'
+
+ INTEGER Lvnam
+ PARAMETER (Lvnam=20)
+
+C ** input
+ INTEGER FILEid
+ CHARACTER *(*) Cname
+ REAL*4 RQval
+
+C ** output
+ REAL*4 RDval, Fval
+ INTEGER indx
+
+C ** local :
+ INTEGER VARSIZE
+ EXTERNAL VARSIZE
+ REAL*4 gval, bmatch, gdist
+ INTEGER Ierro
+ INTEGER varDID, VNlen, varVID, varNUMDIM
+ INTEGER Nvatts, vtype
+ INTEGER K, KHI, KLO, Kmax
+ INTEGER Mindex(1), dimID(4)
+ INTEGER icheck
+ CHARACTER*(Lvnam) dimNAM(4)
+ CHARACTER*13 recname
+
+ icheck= 0
+
+C ** Kmax= nb pas de temps dans le fichier, = dim(val):
+C ** - - - - - - - - - - - - - - - - - - - - - - - - - -
+C ** get Cname string size :
+ VNlen = VARSIZE (Cname)
+C
+C ** get variable ID :
+ Ierro=NF_INQ_VARID(FILEid , Cname (1:VNlen), varVID)
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNfindex', Ierro)
+C
+C ** Inquire about the id of the dimension:
+C **
+ Ierro=NF_INQ_VAR(FILEid , varVID, recname, vtype,
+ & varNUMDIM, dimID , Nvatts)
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNfindex', Ierro)
+C ** line1 id/file id/var var name var type
+C ** line2 # dims id/dims #attributes
+ varDID = dimID(1)
+C ^^^At last, the id of the relevant dimension.
+
+ Ierro=NF_INQ_DIM(FILEid, varDID , dimNAM, Kmax )
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNfindex', Ierro)
+C ** id/file id/dim dimname dimsize error
+C ** !output output
+C ** (Kmax is what we needed: size of the dimension)
+
+C ** Read/Search the requested val step.
+C ** - - - - - - - - - - - - - - - - - - -
+
+C This is a workaround, not optimised as stated above.
+C We simply look at all values sequencially.
+C
+ bmatch=1.E10
+ KLO=-1
+
+ DO K=1,KMAX
+
+C ** Get 1 val value (gval = val(K)):
+ Mindex(1)= K
+ Ierro=NF_GET_VAR1_REAL(FILEid, varVID, Mindex, gval)
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNfindex', Ierro)
+
+ gdist=ABS(gval-RQval)
+ IF (gdist.LT.bmatch) THEN
+
+ bmatch=gdist
+ KLO=K
+
+ ENDIF
+
+ ENDDO
+
+ indx= KLO
+
+ KHI = min((KLO+1),KMAX)
+
+C ** read values...
+
+ Mindex(1)= KLO
+ Ierro=NF_GET_VAR1_REAL(FILEid, varVID, Mindex, RDval)
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNfindex', Ierro)
+C ** read Fval= val(KHI)
+ Mindex(1)= KHI
+ Ierro=NF_GET_VAR1_REAL(FILEid, varVID, Mindex, Fval)
+ IF (Ierro.NE.NF_NOERR) CALL HANDLE_ERR('UNfindex', Ierro)
+
+ IF (KHI.EQ.KLO) THEN
+ Fval= -1.0
+ ENDIF
+
+ IF (bmatch.GT.1.E9) THEN
+ Fval= -1.0
+ indx= -1
+ ENDIF
+
+ RETURN
+ END
+
+C** +-------------------------+-----------------------------------------+
+C** + Subroutine UNclose : + libUN (0300) +
+C** +-------------------------+-----------------------------------------+
+C** + * Close the desired file +
+C** + Created to suppress the need the directly call a netcdf +
+C** + routine from a program +
+C** + +
+C** + INPUT : +
+C** + FILEid : NetCDF file identifier (from UNropen) +
+C** +---------------------------------------------------------------7++++
+
+ SUBROUTINE UNCLOSE(FILEid)
+
+ IMPLICIT NONE
+ INCLUDE 'libUN.inc'
+
+ integer Ierro, FILEid
+
+ Ierro=NF_CLOSE(FILEid)
+ IF (Ierro.NE.NF_NOERR) THEN
+ CALL HANDLE_ERR('UNclose', Ierro)
+ ENDIF
+
+ END
+
+C** +-------------------------+-----------------------------------------+
+C** + Subroutine UNparam : + libUN (0202) +
+C** +-------------------------+-----------------------------------------+
+C** + Changes some global libUN parameters +
+C** + NB: default values are set at first libUN call +
+C** + +
+C** + +
+C** + INPUT : pname name of the parameters to set +
+C** + pvalue the requested new value +
+C** + +
+C** +---------------------------------------------------------------7++++
+
+ SUBROUTINE UNparam(pname,pvalue)
+
+ IMPLICIT NONE
+
+ INCLUDE 'libUN.inc'
+
+ CHARACTER*(*) pname
+ REAL*4 pvalue
+
+ LOGICAL Lstart
+ SAVE Lstart
+ DATA Lstart /.true./
+
+ IF (pname.EQ.'RESET_PARAMS_') THEN
+ IF (Lstart.OR.pvalue.GT.0.5) THEN
+ vMissVal= 1.0E21 ! for missing values
+ VarRepl = vMissVal ! for missing VARIABLES
+ ValRange(1)= -vMissVal/10.
+ ValRange(2)= vMissVal/10.
+ iVarWarn= 2
+ vReadMin = 0.0
+ vReadMax = 0.0
+ ireadchk = 0
+ Lstart = .false.
+ ENDIF
+
+ ELSE IF (pname.EQ.'NOVAR_REPLACE') THEN
+ VarRepl = pvalue
+
+ ELSE IF (pname.EQ.'NOVAR_WARNING') THEN
+ iVarWarn= NINT(pvalue)
+
+ ELSE IF (pname.EQ.'VALID_RANGE_MIN') THEN
+ ValRange(1) = pvalue
+
+ ELSE IF (pname.EQ.'VALID_RANGE_MAX') THEN
+ ValRange(2) = pvalue
+
+ ELSE IF (pname.EQ.'READOVER_WARN') THEN
+ vReadMin = - pvalue
+ vReadMax = pvalue
+ ireadchk = 1
+
+ ELSE IF (pname.EQ.'READ_MIN_WARN') THEN
+ vReadMin = pvalue
+ ireadchk = 1
+
+ ELSE IF (pname.EQ.'READ_MAX_WARN') THEN
+ vReadMax = pvalue
+ ireadchk = 1
+
+ ELSE
+ write(*,*) 'UNparam (libUN) Error: '
+ write(*,*) ' parameter undefined:', pname
+
+ ENDIF
+
+ END
+
+C** +-------------------------+-----------------------------------------+
+ SUBROUTINE UNversion(UNver,NCDFver)
+C** +-------------------------+-----------------------------------------+
+
+ IMPLICIT NONE
+ INCLUDE 'libUN.inc'
+
+ CHARACTER*80 UNver,NCDFver
+
+ UNver = '2005.03.31'
+ NCDFver= NF_INQ_LIBVERS()
+
+ END
+
+C** +-------------------------------------------------------------------+
+ FUNCTION VARSIZE(CHAvar)
+C** +-------------------------------------------------------------------+
+ IMPLICIT NONE
+ integer maxcha,iz,VARSIZE
+ parameter (maxcha=512)
+ character*(*) CHAvar
+ character*(maxcha) CHAtmp
+
+ WRITE(CHAtmp,'(A)') CHAvar
+ iz = 0
+ do while ((CHAtmp(iz+1:iz+3).ne.' ').and.(iz+3.le.maxcha))
+ iz = iz + 1
+ end do
+ VARSIZE = iz
+
+ RETURN
+ END
+
+
+C** +-------------------------------------------------------------------+
+ SUBROUTINE HANDLE_ERR(LOCATION, STATUS)
+C** +-------------------------------------------------------------------+
+ IMPLICIT NONE
+
+ INCLUDE 'libUN.inc'
+
+ character*(*) LOCATION
+ integer STATUS
+ IF (STATUS.NE.NF_NOERR) THEN
+ WRITE(*,*) 'IN ROUTINE ', LOCATION
+ WRITE(*,*) NF_STRERROR(STATUS)
+ STOP 'Stopped'
+ ENDIF
+ END
+
+C UN library: history of fixed bugs and updates.
+C ----------------------------------------------
+C
+C 961206 - UNgtime, trouble at end-of-file
+C 961218 - - all -, display 'artificial' errors
+C 970318 - again, display 'artificial' errors
+C 971028 - (3 sub),'syntax'error on Cray computer
+C 971105 - Allowed variable "imap(1)", =8 for Cray
+C 980705 - "single element" extension to UNwrite.
+C 980709 - bug fixes (start) in UNwrite & UNlwrite
+C ("DATA" statement incorrectly used).
+C 980825 - Changed default "stride" to 1 for v3.x
+C 981222 - bug fix: allow UNwrite for unlim dims.
+C note that this should be tested.
+C 990110 - Added "UNgindx" = general. of UNgtime
+C - Removed all "DATA" and all "//" in write
+C (the later should improve compatibility)
+C 990128 - UNwrite: added a "no warning" option.
+C 990323 - UNwrite: added 1D+time capability.
+C 990807 - UNwrite: added 3D-notime capability.
+C -----------------------------------------------------------------------
+C 000404 - Major upgrade: compatibility with
+C NetCDF v3.4
+C - NOTE: Types other than REAL may be
+C accepted in UNread, but not tested
+C -----------------------------------------------------------------------
+C 000614 - Bug fixes: uninitialised error count
+C in UNwcatt, bug in UNclose.
+C 000620 - Bug fix: UNropen (args. of get title fn)
+C 000713 - Bug fix: UNgtime (missing arg in a call)
+C (last tree caused by 000404 upgrade)
+C -----------------------------------------------------------------------
+C 000928 - UNlwrite: added 2D+time capability.
+C 001008 - All: CHARACTER*(*) declaration for units
+C and longer strings for intern. variables
+C 010417 - UNread: added var not found info
+C UNropen: added file not found info
+C 010715 - UNwrite + UNlwrite:
+C fixed bug / unlimited time dim
+C 0107xx - UNwrite:
+C missing values -> not in "range"
+C 020130 - All:
+C .removed obsolete warnings about
+C double precision in files.
+C .added a version (libUN_dbl) with
+C REAL*8 as arguments - but still
+C creates REAL*4 in files.
+C 020526 - Added UNparam function,
+C which provide optional features such
+C as missing variable behavior control
+C 020808 - Very simple fix for underflows while
+C reading some files; must use -fpe1
+C Fixed a bug -> out of range msg
+C 030121 - Enabled some non-standard NetCDF files
+C (missing units...) -> new warnings
+C rather then program stop.
+C 030215 - Added UNfindx for non-monotonic data
+C 030215 - Removed warning related to UNLIM dims
+C 030311 - Added VALID_RANGE attribute (option)
+C (if set, the range is accounted for
+C in the min/max set while writing vars)
+C 040902 - Improvements to "valid_range" attribute
+C - Added attribute "positive=down"
+C if units are sigma or sigma_level
+C 050331 - Added "user friendly" interfaces
+
diff --git a/MAR/code_nestor/src/libUN.inc b/MAR/code_nestor/src/libUN.inc
new file mode 100644
index 0000000000000000000000000000000000000000..6604fe75af99a292fe6f9b85c805347f847ede18
--- /dev/null
+++ b/MAR/code_nestor/src/libUN.inc
@@ -0,0 +1,58 @@
+C =========
+C libUN.inc
+C =========
+
+ INCLUDE 'NetCDF.inc'
+
+ CHARACTER*50 CF_institution
+ PARAMETER (CF_institution="ULg (Xavier Fettweis)")
+
+ CHARACTER*10 CF_libUN_version
+ PARAMETER (CF_libUN_version="2005.04.08")
+
+ INTEGER CF_dimmaxlen
+ PARAMETER (CF_dimmaxlen=99999) ! Maximum dim/axes length
+
+ INTEGER CF_dimmaxnbr
+ PARAMETER (CF_dimmaxnbr=20) ! Nbr Maximum of dim/axes
+
+
+ INTEGER CF_varmaxnbr
+ PARAMETER (CF_varmaxnbr=300) ! Nbr maximum of variables
+
+ INTEGER CF_attnbr
+ PARAMETER (CF_attnbr =1) ! nbr of attibutes
+
+ INTEGER CF_dim(0:CF_dimmaxnbr),CF_attnum(CF_attnbr)
+ INTEGER CF_varnbrtot,CF_dimnbrtot,CF_fileidopened
+
+ REAL CF_dimval(CF_dimmaxlen,0:CF_dimmaxnbr)
+
+ CHARACTER*13 CF_dimnam(0:CF_dimmaxnbr)
+ CHARACTER*13 CF_varnam(CF_varmaxnbr)
+ CHARACTER*13 CF_varnamdim(4,CF_varmaxnbr)
+ CHARACTER*13 CF_attnam(CF_attnbr)
+ CHARACTER*31 CF_dimnamuni(0:CF_dimmaxnbr)
+ CHARACTER*31 CF_varnamuni(CF_varmaxnbr)
+ CHARACTER*50 CF_vardes(CF_varmaxnbr)
+ CHARACTER*200 CF_filenam,CF_filetit,CF_filenamopened
+
+ COMMON/CF_FILE_CREATi/CF_dim,CF_attnum,CF_fileidopened,
+ . CF_varnbrtot,CF_dimnbrtot
+
+ COMMON/CF_FILE_CREATr/CF_dimval
+
+ COMMON/CF_FILE_CREATc/CF_dimnam,CF_varnam,CF_varnamdim,
+ . CF_attnam,CF_dimnamuni,CF_varnamuni,
+ . CF_vardes,CF_filenam,CF_filetit,
+ . CF_filenamopened
+
+C =================================================================
+
+ INTEGER iVarWarn,ireadchk
+ REAL VarRepl,vReadMin,vReadMax,
+ . vMissVal,ValRange(2)
+
+ COMMON/UNparams/VarRepl,iVarWarn,ireadchk,vReadMin,vReadMax,
+ . vMissVal,ValRange
+
diff --git a/MAR/code_nestor/src/z_orog.f b/MAR/code_nestor/src/z_orog.f
new file mode 100644
index 0000000000000000000000000000000000000000..a8595ec88e1e744246404e02bc890fd51f422a09
--- /dev/null
+++ b/MAR/code_nestor/src/z_orog.f
@@ -0,0 +1,295 @@
+ subroutine z_orog(imx,jmy,xi,yj,dx,hhxy,
+ . dx_res,hhav,soltyp,zoro)
+
+C +----------------------------------------------------------------------------+
+C | NESTOR 14 October 2004 |
+C | subroutine z_orog computes the orographic roughness |
+C | |
+C +----------------------------------------------------------------------------+
+
+ IMPLICIT NONE
+
+ LOGICAL FLott
+ INTEGER soltyp
+ INTEGER im ,jm
+ INTEGER imx ,jmy
+ INTEGER imxmx,jmymy
+ PARAMETER(imxmx=100,jmymy=100)
+ INTEGER ijmx (imxmx,jmymy)
+ REAL dx ,dx_res
+ REAL xi (imxmx,jmymy)
+ REAL yj (imxmx,jmymy)
+ REAL hhxy (imxmx,jmymy),hhav ,hhrg
+ REAL hhsg (imxmx,jmymy),hhx1 ,hhx2
+ REAL rSlopX ,rSlopY
+ REAL zx_zx_h(imxmx,jmymy),zx_zx
+ REAL zy_zy_h(imxmx,jmymy),zy_zy
+ REAL zx_zy_h(imxmx,jmymy),zx_zy
+ REAL max__hh
+ REAL grid_hh
+ REAL land_hh
+ REAL sum__hh
+ REAL sumsqhh
+ REAL zoro ,zstd ,zsig
+ REAL xk ,xl ,xm
+ REAL xp ,xq ,xw
+
+ REAL offset
+ REAL pSlope
+ REAL subghh
+ REAL Z0_log
+ REAL Z0_ANT
+
+ DATA FLott /.FALSE./ ! Parameterization Switch
+c # DATA offset/75.000 / ! d(Height) | significant MAX
+ DATA Z0_ANT/ 0.001 / ! Z0_ANT (Guess)
+
+
+ offset = 100.00
+ include 'USRant.offset'
+
+
+C +--F.Lott Model
+C + ============
+
+ IF (FLott) THEN
+
+
+C +--Resolved Slopes (Mesh average)
+C + ------------------------------
+
+ rSlopX = 0.
+ DO jm=2,jmy-1
+ rSlopX = rSlopX
+ . + hhxy(imx-1,jm )-hhxy(2 ,jm )
+ ENDDO
+ rSlopX = rSlopX
+ . / (dx *(imx-3) *(jmy-2))
+
+ rSlopY = 0.
+ DO im=2,imx-1
+ rSlopY = rSlopY
+ . + hhxy(im ,jmy-1)-hhxy(2 ,jm )
+ ENDDO
+ rSlopY = rSlopY
+ . / (dx *(jmy-3) *(imx-2))
+
+
+C +--Resolved Slopes
+C + ---------------
+
+ DO jm=2,jmy-1
+ DO im=2,imx-1
+c #SL rSlopX = (hhxy(imx-1,jm )-hhxy(2 ,jm ))
+c #SL. /(dx *(imx-3) )
+c #SL rSlopY = (hhxy(im ,jmy-1)-hhxy(2 ,jm ))
+c #SL. /(dx *(jmy-3) )
+
+
+C +--Slope Correlations
+C + ------------------
+
+ zx_zx_h(im,jm) = (hhxy(im +1,jm )-hhxy(im -1,jm ))
+ . /(2.*dx)
+ . - rSlopX
+ zy_zy_h(im,jm) = (hhxy(im ,jm +1)-hhxy(im ,jm -1))
+ . /(2.*dx)
+ . - rSlopY
+ ENDDO
+ ENDDO
+
+ land_hh = 0.
+ grid_hh = 0.
+ sum__hh = 0.
+ sumsqhh = 0.
+ zx_zx = 0.
+ zy_zy = 0.
+ zx_zy = 0.
+ DO jm=2,jmy-1
+ DO im=2,imx-1
+ zx_zy_h(im,jm) = zx_zx_h(im,jm) * zy_zy_h(im,jm)
+ zx_zx_h(im,jm) = zx_zx_h(im,jm) * zx_zx_h(im,jm)
+ zy_zy_h(im,jm) = zy_zy_h(im,jm) * zy_zy_h(im,jm)
+ IF ( hhxy(im,jm).GT.1. ) THEN
+ land_hh = land_hh + 1.
+ END IF
+ grid_hh = grid_hh + 1.
+ sum__hh = sum__hh + hhxy (im,jm)
+ sumsqhh = sumsqhh + hhxy (im,jm)
+ . *hhxy (im,jm)
+ zx_zx = zx_zx + zx_zx_h(im,jm)
+ zy_zy = zy_zy + zy_zy_h(im,jm)
+ zx_zy = zx_zy + zx_zy_h(im,jm)
+ ENDDO
+ ENDDO
+
+
+C +--Mean Orography:
+C + --------------
+
+ sum__hh = sum__hh / grid_hh
+ sumsqhh = sumsqhh / grid_hh
+ zx_zx = zx_zx / grid_hh
+ zy_zy = zy_zy / grid_hh
+ zx_zy = zx_zy / grid_hh
+
+
+C +--Standard deviation:
+C + ------------------
+
+ zstd = SQRT(MAX(0.,sumsqhh-sum__hh*sum__hh))
+
+
+C +--Coefficients K, L et M (FLott Model):
+C + ------------------------------------
+
+ xk=(zx_zx+zy_zy)*0.5
+ xl=(zx_zx-zy_zy)*0.5
+ xm= zx_zy
+ xp= xk-sqrt(xl**2+xm**2)
+ xq= xk+sqrt(xl**2+xm**2)
+ xw= 1.e-8
+ if (xp.le.xw) xp=0.
+ if (xq.le.xw) xq=xw
+ if (abs(xm).le.xw) xm=xw*sign(1.,xm)
+
+
+C +--Slope:
+C + -----
+
+ zsig=sqrt(xq)
+
+
+C +--Orographic Roughness
+C + --------------------
+
+ IF (soltyp.GT.2) THEN
+ zoro= MAX(1.e-6,zstd*zsig*0.5)
+ ELSE
+ zoro= 0.
+ ENDIF
+c #TEST zoro=sqrt(rSlopX*rSlopX+rSlopY*rSlopY) ! TEST
+c #TEST zoro= MAX(1.e-6,zstd*zsig*0.5) ! TEST
+
+
+C +--ECMWF Model
+C + ===========
+
+ ELSE
+
+
+C +--Slopes effects of the Resolved Topography are substracted
+C + ---------------------------------------------------------
+
+ DO jm=1,jmy
+ DO im=1,imx
+ hhxy(im,jm) =
+ . max(0.,hhxy(im ,jm ))
+ ENDDO
+ ENDDO
+
+ DO jm=2,jmy-1
+ DO im=2,imx-1
+ hhx1 = hhxy( 1, 1)
+ . +(hhxy( 1,jmy )-hhxy( 1, 1))
+ . * real( jm-1)/real( jmy-1)
+ hhx2 = hhxy(imx, 1)
+ . +(hhxy(imx,jmy )-hhxy(imx, 1))
+ . * real( jm-1)/real( jmy-1)
+ hhrg = hhx1
+ . +(hhx2 -hhx1 )
+ . * real( im-1)/real( imx-1)
+ hhsg(im,jm) = hhxy(im ,jm )
+ . -hhrg
+ . +hhav
+ ENDDO
+ ENDDO
+ DO im=1,imx
+ hhsg(im , 1)=hhav
+ hhsg(im ,jmy)=hhav
+ ENDDO
+ DO jm=1,jmy
+ hhsg( 1,jm )=hhav
+ hhsg(imx,jm )=hhav
+ ENDDO
+
+
+C +--Subgrid Topography Maxima
+C + -------------------------
+
+ sum__hh = 0.
+ sumsqhh = 0.
+ grid_hh = 0.
+ max__hh = -1.
+ DO jm=2,jmy-1
+ DO im=2,imx-1
+ sum__hh = sum__hh + hhsg(im,jm)
+ IF ( hhxy(im,jm).GT.0. ) THEN
+ sumsqhh = sumsqhh + hhsg(im,jm) *hhsg(im,jm)
+ END IF
+ grid_hh = grid_hh + 1.
+ IF ((hhsg(im,jm).GT.hhsg(im+1,jm )+offset).AND.
+ . (hhsg(im,jm).GT.hhsg(im-1,jm )+offset).AND.
+ . (hhsg(im,jm).GT.hhsg(im ,jm+1)+offset).AND.
+ . (hhsg(im,jm).GT.hhsg(im ,jm-1)+offset).AND.
+ . (hhsg(im,jm).GT.hhsg(im-1,jm-1)+offset).AND.
+ . (hhsg(im,jm).GT.hhsg(im-1,jm+1)+offset).AND.
+ . (hhsg(im,jm).GT.hhsg(im+1,jm-1)+offset).AND.
+ . (hhsg(im,jm).GT.hhsg(im+1,jm+1)+offset) ) THEN
+ max__hh = max__hh + 1.
+ ijmx(im,jm) = ijmx(im ,jm) +1
+ END IF
+ ENDDO
+ ENDDO
+ max__hh =
+ . max(0.,max__hh - 1.)
+
+
+C +--Mean Orography:
+C + --------------
+
+ sum__hh = sum__hh / max(grid_hh,1.e-6)
+ sumsqhh = sumsqhh / max(grid_hh,1.e-6)
+
+
+C +--Standard deviation:
+C + ------------------
+
+ zstd = SQRT(MAX(0.,sumsqhh-sum__hh*sum__hh))
+
+
+C +--Slope Parameter
+C + ---------------
+
+ pSlope = 4. * zstd * sqrt(max__hh) / dx_res
+
+
+C +--Roughness Length
+C + ----------------
+
+ subghh = 4.0*zstd ! subgrid mean orography
+ IF (subghh.GT. offset .AND.
+ . pSlope.GT. 0.01) THEN
+ Z0_log = 0.4/ log(1.0+subghh /(2.0 *Z0_ANT))
+ Z0_log = 0.4/sqrt(0.2*pSlope + Z0_log*Z0_log )
+ zoro = 0.5*subghh / (exp(Z0_log) - 1.0 )
+ zoro = min( subghh , zoro )
+ ELSE
+ zoro = 0.
+ END IF
+
+c #WR IF (max__hh.GT.0.)
+c #WR. write(6,6001) hhav,subghh,max__hh,dx_res,pSlope,Z0_log,zoro
+ 6001 format('sh=',f9.3,3x,'Subgrid=',f9.3
+ . ,3x,'Nb max =',f3.0,3x,'dx [m]=',f9.3,3x
+ . ,3x,'pSlope =',e9.3,3x,'Z0_log=',E9.3
+ . ,3x,'z0_oro =',e9.3)
+c #TEST hhav = max__hh
+c #TEST hhav = sum__hh - hhav
+c #TEST hhav = pSlope
+
+ END IF
+
+
+ return
+ end