Changeset 2594 for LMDZ5/branches/testing/libf/dynphy_lonlat/phylmd/limit_netcdf.F90

Timestamp:

Jul 18, 2016, 9:41:10 PM (8 years ago)

Author:

Laurent Fairhead

Message:

Merged trunk changes r2545:2589 into testing branch

Location:

LMDZ5/branches/testing

Files:

• . (modified) (1 prop)
• libf/dynphy_lonlat/phylmd/limit_netcdf.F90 (modified) (10 diffs)

LMDZ5/branches/testing/libf/dynphy_lonlat/phylmd/limit_netcdf.F90

@@ -117 +117 @@
     ALLOCATE(pctsrf(klon,nbsrf))
     CALL start_init_subsurf(.FALSE.)
+  !--- TO MATCH EXACTLY WHAT WOULD BE DONE IN etat0phys_netcdf
+    WHERE(   masque(:,:)<EPSFRA) masque(:,:)=0.
+    WHERE(1.-masque(:,:)<EPSFRA) masque(:,:)=1.
   END IF
 
@@ -336 +339 @@
   REAL, ALLOCATABLE :: champan(:,:,:)
 !--- input files
+  CHARACTER(LEN=20) :: fnam_m, fnam_p     ! previous/next files names
   CHARACTER(LEN=20) :: cal_in             ! calendar
   CHARACTER(LEN=20) :: unit_sic           ! attribute unit in sea-ice file
@@ -345 +349 @@
   LOGICAL           :: extrp              ! flag for extrapolation
   REAL              :: chmin, chmax
-  INTEGER ierr
+  INTEGER ierr, idx
   integer n_extrap ! number of extrapolated points
   logical skip
@@ -360 +364 @@
   END SELECT
   extrp=.FALSE.; IF(PRESENT(flag).AND.mode=='SST') extrp=flag
+  idx=INDEX(fnam,'.nc')-1
 
 !--- GETTING SOME DIMENSIONAL VARIABLES FROM FILE -----------------------------
@@ -393 +398 @@
 !--- Time (variable is not needed - it is rebuilt - but calendar is)
   CALL ncerr(NF90_INQUIRE_DIMENSION(ncid, dids(3), name=dnam, len=lmdep), fnam)
-  ALLOCATE(timeyear(MAX(lmdep,14)))
+  ALLOCATE(timeyear(lmdep+2))
   CALL ncerr(NF90_INQ_VARID(ncid, dnam, varid), fnam)
   cal_in=' '
@@ -412 +417 @@
   IF(lmdep==12) THEN
     timeyear=mid_month(anneeref, cal_in, ndays_in)
-    CALL msg(0,'Monthly periodic input file (perpetual run).')
-  ELSE IF(lmdep==14) THEN
-    timeyear=mid_month(anneeref, cal_in, ndays_in)
-    CALL msg(0,'Monthly 14-records input file (interannual run).')
+    CALL msg(0,'Monthly input file(s) for '//TRIM(title)//'.')
   ELSE IF(lmdep==ndays_in) THEN
-    timeyear=[(REAL(k)-0.5,k=1,ndays_in)]
+    timeyear=[(REAL(k)-0.5,k=0,ndays_in+1)]
     CALL msg(0,'Daily input file (no time interpolation).')
   ELSE
     WRITE(mess,'(a,i3,a,i3,a)')'Mismatching input file: found',lmdep,        &
-      ' records, 12/14/',ndays_in,' (periodic/interannual/daily) needed'
+      ' records, 12/',ndays_in,' (monthly/daily needed).'
     CALL abort_physic('mid_months',TRIM(mess),1)
   END IF
 
 !--- GETTING THE FIELD AND INTERPOLATING IT ----------------------------------
-  ALLOCATE(champ(imdep, jmdep), champtime(iim, jjp1, MAX(lmdep,14)))
+  ALLOCATE(champ(imdep, jmdep), champtime(iim, jjp1, lmdep+2))
   IF(extrp) ALLOCATE(work(imdep, jmdep))
   CALL msg(5,'')
@@ -446 +448 @@
       WHERE(NINT(mask)/=1) champint=0.001
     END IF
-    !--- Special case for periodic input file: index shifted
-    ll = l; IF(lmdep==12) ll = l + 1
-    champtime(:, :, ll)=champint
+    champtime(:, :, l+1)=champint
   END DO
-  IF(lmdep==12) THEN
-    champtime(:,:, 1)=champtime(:,:,13)
-    champtime(:,:,14)=champtime(:,:, 2)
-  END IF
   CALL ncerr(NF90_CLOSE(ncid), fnam)
 
+!--- FIRST RECORD: LAST ONE OF PREVIOUS YEAR (CURRENT YEAR IF UNAVAILABLE)
+  fnam_m=fnam(1:idx)//'_m.nc'
+  IF(NF90_OPEN(fnam_m,NF90_NOWRITE,ncid)==NF90_NOERR) THEN
+    CALL msg(0,'Reading previous year file ("'//TRIM(fnam_m)//'") last record for '//TRIM(title))
+    CALL ncerr(NF90_INQ_VARID(ncid, varname, varid),fnam_m)
+    CALL ncerr(NF90_INQUIRE_VARIABLE(ncid, varid, dimids=dids),fnam_m)
+    CALL ncerr(NF90_INQUIRE_DIMENSION(ncid, dids(3), len=l), fnam_m)
+    CALL ncerr(NF90_GET_VAR(ncid,varid,champ,[1,1,l],[imdep,jmdep,1]),fnam_m)
+    CALL ncerr(NF90_CLOSE(ncid), fnam_m)
+    CALL conf_dat2d(title, dlon_ini, dlat_ini, dlon, dlat, champ, .TRUE.)
+    IF(extrp) CALL extrapol(champ,imdep,jmdep,999999.,.TRUE.,.TRUE.,2,work)
+    IF(mode=='RUG') champ=LOG(champ)
+    CALL inter_barxy(dlon,dlat(:jmdep-1),champ,rlonu(:iim),rlatv,champint)
+    IF(mode=='RUG') THEN
+      champint=EXP(champint)
+      WHERE(NINT(mask)/=1) champint=0.001
+    END IF
+    champtime(:, :, 1)=champint
+  ELSE
+    CALL msg(0,'Using current year file ("'//TRIM(fnam)//'") last record for '//TRIM(title))
+    champtime(:, :, 1)=champtime(:, :, lmdep+1)
+  END IF
+
+!--- LAST RECORD: FIRST ONE OF NEXT YEAR (CURRENT YEAR IF UNAVAILABLE)
+  fnam_p=fnam(1:idx)//'_p.nc'
+  IF(NF90_OPEN(fnam_p,NF90_NOWRITE,ncid)==NF90_NOERR) THEN
+    CALL msg(0,'Reading previous year file ("'//TRIM(fnam_p)//'") first record for '//TRIM(title))
+    CALL ncerr(NF90_INQ_VARID(ncid, varname, varid),fnam_p)
+    CALL ncerr(NF90_GET_VAR(ncid,varid,champ,[1,1,1],[imdep,jmdep,1]),fnam_p)
+    CALL ncerr(NF90_CLOSE(ncid), fnam_p)
+    CALL conf_dat2d(title, dlon_ini, dlat_ini, dlon, dlat, champ, .TRUE.)
+    IF(extrp) CALL extrapol(champ,imdep,jmdep,999999.,.TRUE.,.TRUE.,2,work)
+    IF(mode=='RUG') champ=LOG(champ)
+    CALL inter_barxy(dlon,dlat(:jmdep-1),champ,rlonu(:iim),rlatv,champint)
+    IF(mode=='RUG') THEN
+      champint=EXP(champint)
+      WHERE(NINT(mask)/=1) champint=0.001
+    END IF
+    champtime(:, :, lmdep+2)=champint
+  ELSE
+    CALL msg(0,'Using current year file ("'//TRIM(fnam)//'") first record for '//TRIM(title))
+    champtime(:, :, lmdep+2)=champtime(:, :, 2)
+  END IF
   DEALLOCATE(dlon_ini, dlat_ini, dlon, dlat, champ)
   IF(extrp) DEALLOCATE(work)
@@ -477 +516 @@
      END IF
   END IF
-  ALLOCATE(yder(MAX(lmdep,14)), champan(iip1, jjp1, ndays))
+  ALLOCATE(yder(lmdep+2), champan(iip1, jjp1, ndays))
   IF(lmdep==ndays_in) THEN
      champan(1:iim,:,:)=champtime
@@ -546 +585 @@
 !
 !-------------------------------------------------------------------------------
+  USE grid_noro_m, ONLY: grid_noro0
   IMPLICIT NONE
 !===============================================================================
@@ -599 +639 @@
 
 END SUBROUTINE start_init_orog0
-!
-!-------------------------------------------------------------------------------
-
-
-!-------------------------------------------------------------------------------
-!
-SUBROUTINE grid_noro0(xd,yd,zd,x,y,zphi,mask)
-!
-!===============================================================================
-! Purpose: Extracted from grid_noro to provide geopotential height for dynamics
-!          without any call to physics subroutines.
-!===============================================================================
-  IMPLICIT NONE 
-!-------------------------------------------------------------------------------
-! Arguments:
-  REAL, INTENT(IN)   :: xd(:), yd(:) !--- INPUT  COORDINATES     (imdp) (jmdp)
-  REAL, INTENT(IN)   :: zd(:,:)      !--- INPUT  FIELD           (imdp,jmdp)
-  REAL, INTENT(IN)   :: x(:), y(:)   !--- OUTPUT COORDINATES     (imar+1) (jmar)
-  REAL, INTENT(OUT)  :: zphi(:,:)    !--- GEOPOTENTIAL           (imar+1,jmar)
-  REAL, INTENT(INOUT):: mask(:,:)    !--- MASK                   (imar+1,jmar)
-!-------------------------------------------------------------------------------
-! Local variables:
-  CHARACTER(LEN=256) :: modname="grid_noro0"
-  REAL, ALLOCATABLE :: xusn(:), yusn(:)           ! dim (imdp+2*iext) (jmdp+2)
-  REAL, ALLOCATABLE :: zusn(:,:)                  ! dim (imdp+2*iext,jmdp+2)
-  REAL, ALLOCATABLE :: weight(:,:)                ! dim (imar+1,jmar)
-  REAL, ALLOCATABLE :: mask_tmp(:,:), zmea(:,:)   ! dim (imar+1,jmar)
-  REAL, ALLOCATABLE :: num_tot(:,:), num_lan(:,:) ! dim (imax,jmax)
-  REAL, ALLOCATABLE :: a(:), b(:)                 ! dim (imax)
-  REAL, ALLOCATABLE :: c(:), d(:)                 ! dim (jmax)
-  LOGICAL :: masque_lu
-  INTEGER :: i, ii, imdp, imar, iext
-  INTEGER :: j, jj, jmdp, jmar, nn
-  REAL    :: xpi, zlenx, weighx, xincr,  zbordnor, zmeanor, zweinor, zbordest
-  REAL    :: rad, zleny, weighy, masque, zbordsud, zmeasud, zweisud, zbordoue
-!-------------------------------------------------------------------------------
-  imdp=assert_eq(SIZE(xd),SIZE(zd,1),TRIM(modname)//" imdp")
-  jmdp=assert_eq(SIZE(yd),SIZE(zd,2),TRIM(modname)//" jmdp")
-  imar=assert_eq(SIZE(x),SIZE(zphi,1),SIZE(mask,1),TRIM(modname)//" imar")-1
-  jmar=assert_eq(SIZE(y),SIZE(zphi,2),SIZE(mask,2),TRIM(modname)//" jmar")
-  IF(imar/=iim)   CALL abort_gcm(TRIM(modname),'imar/=iim'  ,1)
-  IF(jmar/=jjm+1) CALL abort_gcm(TRIM(modname),'jmar/=jjm+1',1)
-  iext=imdp/10
-  xpi = ACOS(-1.)
-  rad = 6371229.
-
-!--- ARE WE USING A READ MASK ?
-  masque_lu=ANY(mask/=-99999.); IF(.NOT.masque_lu) mask=0.0
-  WRITE(lunout,*)'Masque lu: ',masque_lu
-
-!--- EXTENSION OF THE INPUT DATABASE TO PROCEED COMPUTATIONS AT BOUNDARIES:
-  ALLOCATE(xusn(imdp+2*iext))
-  xusn(1     +iext:imdp  +iext)=xd(:)
-  xusn(1          :       iext)=xd(1+imdp-iext:imdp)-2.*xpi
-  xusn(1+imdp+iext:imdp+2*iext)=xd(1          :iext)+2.*xpi
-
-  ALLOCATE(yusn(jmdp+2))
-  yusn(1       )=yd(1)   +(yd(1)   -yd(2))
-  yusn(2:jmdp+1)=yd(:)
-  yusn(  jmdp+2)=yd(jmdp)+(yd(jmdp)-yd(jmdp-1))
-
-  ALLOCATE(zusn(imdp+2*iext,jmdp+2))
-  zusn(1       +iext:imdp  +iext,2:jmdp+1)=zd  (:                   ,     :)
-  zusn(1            :       iext,2:jmdp+1)=zd  (imdp-iext+1:imdp    ,     :)
-  zusn(1+imdp  +iext:imdp+2*iext,2:jmdp+1)=zd  (1:iext              ,     :)
-  zusn(1            :imdp/2+iext,       1)=zusn(1+imdp/2:imdp  +iext,     2)
-  zusn(1+imdp/2+iext:imdp+2*iext,       1)=zusn(1       :imdp/2+iext,     2)
-  zusn(1            :imdp/2+iext,  jmdp+2)=zusn(1+imdp/2:imdp  +iext,jmdp+1)
-  zusn(1+imdp/2+iext:imdp+2*iext,  jmdp+2)=zusn(1       :imdp/2+iext,jmdp+1)
-
-!--- COMPUTE LIMITS OF MODEL GRIDPOINT AREA (REGULAR GRID)
-  ALLOCATE(a(imar+1),b(imar+1))
-  b(1:imar)=(x(1:imar  )+ x(2:imar+1))/2.0
-  b(imar+1)= x(  imar+1)+(x(  imar+1)-x(imar))/2.0
-  a(1)=x(1)-(x(2)-x(1))/2.0
-  a(2:imar+1)= b(1:imar)
-
-  ALLOCATE(c(jmar),d(jmar))
-  d(1:jmar-1)=(y(1:jmar-1)+ y(2:jmar))/2.0
-  d(  jmar  )= y(  jmar  )+(y(  jmar)-y(jmar-1))/2.0
-  c(1)=y(1)-(y(2)-y(1))/2.0
-  c(2:jmar)=d(1:jmar-1)
-
-!--- INITIALIZATIONS:
-  ALLOCATE(weight(imar+1,jmar)); weight(:,:)= 0.0
-  ALLOCATE(zmea  (imar+1,jmar)); zmea  (:,:)= 0.0
-
-!--- SUMMATION OVER GRIDPOINT AREA
-  zleny=xpi/REAL(jmdp)*rad
-  xincr=xpi/REAL(jmdp)/2.
-  ALLOCATE(num_tot(imar+1,jmar)); num_tot(:,:)=0.
-  ALLOCATE(num_lan(imar+1,jmar)); num_lan(:,:)=0.
-  DO ii = 1, imar+1
-    DO jj = 1, jmar
-      DO j = 2,jmdp+1 
-        zlenx  =zleny  *COS(yusn(j))
-        zbordnor=(xincr+c(jj)-yusn(j))*rad
-        zbordsud=(xincr-d(jj)+yusn(j))*rad
-        weighy=AMAX1(0.,AMIN1(zbordnor,zbordsud,zleny))
-        IF(weighy/=0) THEN
-          DO i = 2, imdp+2*iext-1
-            zbordest=(xusn(i)-a(ii)+xincr)*rad*COS(yusn(j))
-            zbordoue=(b(ii)+xincr-xusn(i))*rad*COS(yusn(j))
-            weighx=AMAX1(0.,AMIN1(zbordest,zbordoue,zlenx))
-            IF(weighx/=0)THEN
-              num_tot(ii,jj)=num_tot(ii,jj)+1.0
-              IF(zusn(i,j)>=1.)num_lan(ii,jj)=num_lan(ii,jj)+1.0
-              weight(ii,jj)=weight(ii,jj)+weighx*weighy
-              zmea  (ii,jj)=zmea  (ii,jj)+zusn(i,j)*weighx*weighy !--- MEAN
-            END IF
-          END DO
-        END IF
-      END DO
-    END DO
-  END DO
-
-!--- COMPUTE PARAMETERS NEEDED BY LOTT & MILLER (1997) AND LOTT (1999) SSO SCHEME
-  IF(.NOT.masque_lu) THEN
-    WHERE(weight(:,1:jmar-1)/=0.0) mask=num_lan(:,:)/num_tot(:,:)
-  END IF
-  nn=COUNT(weight(:,1:jmar-1)==0.0)
-  IF(nn/=0) WRITE(lunout,*)'Problem with weight ; vanishing occurrences: ',nn
-  WHERE(weight/=0.0) zmea(:,:)=zmea(:,:)/weight(:,:)
-
-!--- MASK BASED ON GROUND MAXIMUM, 10% THRESHOLD (<10%: SURF PARAMS MEANINGLESS)
-  ALLOCATE(mask_tmp(imar+1,jmar)); mask_tmp(:,:)=0.0
-  WHERE(mask>=0.1) mask_tmp = 1.
-  WHERE(weight(:,:)/=0.0)
-    zphi(:,:)=mask_tmp(:,:)*zmea(:,:)
-    zmea(:,:)=mask_tmp(:,:)*zmea(:,:)
-  END WHERE
-  WRITE(lunout,*)'  MEAN ORO:' ,MAXVAL(zmea)
-
-!--- Values at poles
-  zphi(imar+1,:)=zphi(1,:)
-
-  zweinor=SUM(weight(1:imar,   1),DIM=1)
-  zweisud=SUM(weight(1:imar,jmar),DIM=1)
-  zmeanor=SUM(weight(1:imar,   1)*zmea(1:imar,   1),DIM=1)
-  zmeasud=SUM(weight(1:imar,jmar)*zmea(1:imar,jmar),DIM=1)
-  zphi(:,1)=zmeanor/zweinor; zphi(:,jmar)=zmeasud/zweisud
-
-END SUBROUTINE grid_noro0
 !
 !-------------------------------------------------------------------------------