[cdftools] 26/228: JMM add cdfnorth_unfold.f90 program. Not working at this revision
Alastair McKinstry
mckinstry at moszumanska.debian.org
Fri Jun 12 08:21:24 UTC 2015
This is an automated email from the git hooks/post-receive script.
mckinstry pushed a commit to branch master
in repository cdftools.
commit 5349e84d093e018f1dcf5da5358c112f8a3d8965
Author: molines <molines at 1055176f-818a-41d9-83e1-73fbe5b947c5>
Date: Mon Apr 26 11:32:37 2010 +0000
JMM add cdfnorth_unfold.f90 program. Not working at this revision
git-svn-id: http://servforge.legi.grenoble-inp.fr/svn/CDFTOOLS/trunk@302 1055176f-818a-41d9-83e1-73fbe5b947c5
---
Makefile | 3 +
cdfnorth_unfold.f90 | 310 ++++++++++++++++++++++++++++++++++++++++++++++++++++
2 files changed, 313 insertions(+)
diff --git a/Makefile b/Makefile
index c98bbb3..80357c5 100644
--- a/Makefile
+++ b/Makefile
@@ -450,6 +450,9 @@ cdfvar: cdfio.o cdfvar.f90
cdfcsp: cdfio.o cdfcsp.f90
$(F90) cdfcsp.f90 -o cdfcsp cdfio.o $(FFLAGS)
+cdfnorth_unfold: cdfio.o cdfnorth_unfold.f90
+ $(F90) cdfnorth_unfold.f90 -o cdfnorth_unfold cdfio.o $(FFLAGS)
+
cdfpolymask: cdfio.o modpoly.o cdfpolymask.f90
$(F90) cdfpolymask.f90 -o cdfpolymask cdfio.o modpoly.o $(FFLAGS)
diff --git a/cdfnorth_unfold.f90 b/cdfnorth_unfold.f90
new file mode 100644
index 0000000..16bdd87
--- /dev/null
+++ b/cdfnorth_unfold.f90
@@ -0,0 +1,310 @@
+PROGRAM cdfnorth_unfold
+ !!-----------------------------------------------------------------------
+ !! *** PROGRAM cdfnorth_unfold ***
+ !!
+ !! ** Purpose: Unfold the arctic ocean in an ORCA like configuration
+ !! for all the variables of the file given in the arguments
+ !!
+ !! ** Method: read the filename, the limit of the extracted zone, and
+ !! the type of pivot to use and the C-grid point of variables
+ !!
+ !! history :
+ !! Original code : J.M. Molines (Apr. 2010 )
+ !!-------------------------------------------------------------
+ !! $Rev$
+ !! $Date$
+ !! $Id$
+ !!--------------------------------------------------------------
+ !!
+ USE cdfio
+
+ IMPLICIT NONE
+ INTEGER :: jk,jt,jvar, jv , jtt,jkk !: dummy loop index
+ INTEGER :: ierr !: working integer
+ INTEGER :: narg, iargc !:
+ INTEGER :: npiglo,npjglo, npk ,nt !: size of the domain
+ INTEGER :: nvars !: Number of variables in a file
+ INTEGER :: ijatl, ijpacif, npiarctic, npjarctic, isig
+ INTEGER , DIMENSION(:), ALLOCATABLE :: id_var , & !: arrays of var id's
+ & ipk , & !: arrays of vertical level for each var
+ & id_varout
+ REAL(KIND=4) , DIMENSION (:,:), ALLOCATABLE :: tab !: Arrays for cumulated values
+ REAL(KIND=4) :: total_time
+ REAL(KIND=4) , DIMENSION (:,:), ALLOCATABLE :: v2d !: Array to read a layer of data
+ REAL(KIND=4),DIMENSION(1) :: timean
+ REAL(KIND=4),DIMENSION(365) :: tim
+
+ CHARACTER(LEN=256) :: cfile ,cfileout !: file name
+ CHARACTER(LEN=256) :: cdep, cdum, cpivot, ctype
+ CHARACTER(LEN=256) ,DIMENSION(:), ALLOCATABLE:: cvarname !: array of var name
+
+ TYPE (variable), DIMENSION(:), ALLOCATABLE :: typvar
+
+ INTEGER :: ncout, ncout2
+ INTEGER :: istatus
+ LOGICAL :: lcaltmean
+
+ !!
+
+ !! Read command line
+ narg= iargc()
+ IF ( narg /= 5 ) THEN
+ PRINT *,' Usage : cdfnorth_unfold filename jatl jpacif pivot Cgrid_point'
+ PRINT *, ' example: cdfnorth_unfold ORCA025-G70_y2000m10d02_gridT.nc 766 766 T T'
+ PRINT *, ' a file named unfold.nc will be created '
+ STOP
+ ENDIF
+ !!
+ !! Initialisation from 1st file (all file are assume to have the same geometry)
+ CALL getarg (1, cfile)
+ CALL getarg (2, cdum) ; READ(cdum,*) ijatl
+ CALL getarg (3, cdum) ; READ(cdum,*) ijpacif
+ CALL getarg (4, cpivot)
+ CALL getarg (4, ctype )
+
+ ! to be improved
+ SELECT CASE ( ctype )
+ CASE ( 'T','t')
+ isig=1
+ CASE ('U','u','V','v')
+ isig=-1
+ END SELECT
+
+ npiglo= getdim (cfile,'x')
+ npjglo= getdim (cfile,'y')
+ npk = getdim (cfile,'depth',cdtrue=cdep, kstatus=istatus)
+
+ IF (istatus /= 0 ) THEN
+ npk = getdim (cfile,'z',cdtrue=cdep,kstatus=istatus)
+ IF (istatus /= 0 ) THEN
+ npk = getdim (cfile,'sigma',cdtrue=cdep,kstatus=istatus)
+ IF ( istatus /= 0 ) THEN
+ npk = getdim (cfile,'nav_lev',cdtrue=cdep,kstatus=istatus)
+ IF ( istatus /= 0 ) THEN
+ PRINT *,' assume file with no depth'
+ npk=0
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+
+ ! to be improved
+ npiarctic=npiglo/2
+ npjarctic=npjglo-ijatl + npjglo -ijpacif
+
+
+ PRINT *, 'npiglo=', npiglo
+ PRINT *, 'npjglo=', npjglo
+ PRINT *, 'npk =', npk
+
+ ALLOCATE( tab(npiarctic, npjarctic), v2d(npiglo,npjglo) )
+
+ nvars = getnvar(cfile)
+ PRINT *,' nvars =', nvars
+
+ ALLOCATE (cvarname(nvars) )
+ ALLOCATE (typvar(nvars) )
+ ALLOCATE (id_var(nvars),ipk(nvars),id_varout(nvars) )
+
+ ! get list of variable names and collect attributes in typvar (optional)
+ cvarname(:)=getvarname(cfile,nvars,typvar)
+
+ id_var(:) = (/(jv, jv=1,nvars)/)
+ ! ipk gives the number of level or 0 if not a T[Z]YX variable
+ ipk(:) = getipk (cfile,nvars,cdep=cdep)
+ WHERE( ipk == 0 ) cvarname='none'
+ typvar(:)%name=cvarname
+
+ ! create output fileset
+ cfileout='unfold.nc'
+ ! create output file taking the sizes in cfile
+
+ ncout =create(cfileout, cfile,npiarctic,npjarctic,npk,cdep=cdep)
+ ierr= createvar(ncout , typvar, nvars, ipk, id_varout )
+
+! ierr= putheadervar(ncout , cfile, npiarctic,npjarctic, npk,cdep=cdep)
+ ierr=putvar1d(ncout,timean,1,'T')
+
+ DO jvar = 1,nvars
+ PRINT *,' Working with ', TRIM(cvarname(jvar)), ipk(jvar)
+ DO jk = 1, ipk(jvar)
+ PRINT *,'level ',jk
+ tab(:,:) = 0.
+ DO jtt=1,nt
+ jkk=jk
+ ! If forcing fields is without depth dimension
+ IF (npk==0) jkk=jtt
+ v2d(:,:)= getvar(cfile, cvarname(jvar), jkk ,npiglo, npjglo,ktime=jtt )
+ CALL unfold(v2d, tab, ijatl, ijpacif, cpivot, ctype, isig)
+ ierr = putvar(ncout, id_varout(jvar) ,tab, jkk, npiarctic, npjarctic, ktime=jtt)
+ ENDDO
+ END DO ! loop to next level
+ END DO ! loop to next var in file
+
+ istatus = closeout(ncout)
+
+CONTAINS
+ SUBROUTINE unfold( ptabin, ptabout, kjatl, kjpacif, cdpivot, cdtype, ksig)
+ !!------------------------------------------------------------------------
+ !! ** SUBROUTINE unfol **
+ !!
+ !! Purpose : unfold the north pole
+ !! -----------------------------------------------------------------------
+ REAL(KIND=4), DIMENSION(npiglo,npjglo) , INTENT(in) :: ptabin
+ REAL(KIND=4), DIMENSION(npiarctic,npjarctic), INTENT(out) :: ptabout
+ INTEGER, INTENT(in) :: kjatl
+ INTEGER, INTENT(in) :: kjpacif
+ INTEGER, INTENT(in) :: ksig
+ CHARACTER(LEN=*), INTENT(in) :: cdpivot
+ CHARACTER(LEN=*), INTENT(in) :: cdtype
+ !!
+ ! local variables :
+ INTEGER :: jj, jnorth, ipivot, ij
+ !
+ SELECT CASE ( cdpivot )
+ CASE ('T','t') ; jnorth=npjglo-3
+ CASE ('F','f') ; jnorth=npjglo-2
+ END SELECT
+
+ DO jj=kjatl,jnorth
+ ptabout(:,jj)=ptabin(npiglo/2:npiglo, jj)
+ ENDDO
+ DO jj=jnorth, kjpacif,-1
+ ij= 1
+ ptabout(:,ij)= ksig * ptabin(1:npiglo/2, jj)
+ ENDDO
+
+ END SUBROUTINE unfold
+
+ SUBROUTINE lbc_nfd_2d( pt2d, cd_type, psgn )
+ !!----------------------------------------------------------------------
+ !! *** routine lbc_nfd_2d ***
+ !!
+ !! ** Purpose : 2D lateral boundary condition : North fold treatment
+ !! without processor exchanges.
+ !!
+ !! ** Method :
+ !!
+ !! ** Action : pt2d with update value at its periphery
+ !!
+ !!----------------------------------------------------------------------
+ !! * Arguments
+ CHARACTER(len=1) , INTENT( in ) :: &
+ cd_type ! define the nature of ptab array grid-points
+ ! ! = T , U , V , F , W points
+ ! ! = S : T-point, north fold treatment ???
+ ! ! = G : F-point, north fold treatment ???
+ REAL(wp), INTENT( in ) :: &
+ psgn ! control of the sign change
+ ! ! = -1. , the sign is changed if north fold boundary
+ ! ! = 1. , the sign is kept if north fold boundary
+ REAL(wp), DIMENSION(:,:), INTENT( inout ) :: &
+ pt2d ! 3D array on which the boundary condition is applied
+
+ !! * Local declarations
+ INTEGER :: ji, jl, ipr2dj
+ INTEGER :: ijt, iju, ijpj, ijpjm1
+
+ SELECT CASE ( jpni )
+ CASE ( 1 ) ! only one proc along I
+ ijpj = nlcj
+ CASE DEFAULT
+ ijpj = 4
+ END SELECT
+
+
+ ipr2dj = 0
+
+ ijpjm1 = ijpj-1
+
+
+ SELECT CASE ( npolj )
+
+ CASE ( 3, 4 ) ! * North fold T-point pivot
+
+ SELECT CASE ( cd_type )
+
+ CASE ( 'T', 'S', 'W' )
+ DO ji = jpiglo/2+1, jpiglo
+ ijt=jpiglo-ji+2
+ pt2d(ji,ijpj-1) = psgn * pt2d(ijt,ijpj-1)
+ END DO
+ CASE ( 'U' ) ! U-point
+ DO ji = jpiglo/2, jpiglo-1
+ iju = jpiglo-ji+1
+ pt2d(ji,ijpjm1) = psgn * pt2d(iju,ijpjm1)
+ END DO
+ CASE ( 'V' ) ! V-point
+ DO jl =-1, ipr2dj
+ DO ji = 2, jpiglo
+ ijt = jpiglo-ji+2
+ pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-3-jl)
+ END DO
+ END DO
+ CASE ( 'F' , 'G' ) ! F-point
+ DO jl =-1, ipr2dj
+ DO ji = 1, jpiglo-1
+ iju = jpiglo-ji+1
+ pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-3-jl)
+ END DO
+ END DO
+ END SELECT
+
+ CASE ( 5, 6 ) ! * North fold F-point pivot
+
+ SELECT CASE ( cd_type )
+ CASE ( 'T' , 'W' ,'S' ) ! T-, W-point
+ DO jl = 0, ipr2dj
+ DO ji = 1, jpiglo
+ ijt = jpiglo-ji+1
+ pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-1-jl)
+ END DO
+ END DO
+ CASE ( 'U' ) ! U-point
+ DO jl = 0, ipr2dj
+ DO ji = 1, jpiglo-1
+ iju = jpiglo-ji
+ pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl)
+ END DO
+ END DO
+ CASE ( 'V' ) ! V-point
+ DO jl = 0, ipr2dj
+ DO ji = 1, jpiglo
+ ijt = jpiglo-ji+1
+ pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-2-jl)
+ END DO
+ END DO
+ DO ji = jpiglo/2+1, jpiglo
+ ijt = jpiglo-ji+1
+ pt2d(ji,ijpjm1) = psgn * pt2d(ijt,ijpjm1)
+ END DO
+ CASE ( 'F' , 'G' ) ! F-point
+ DO jl = 0, ipr2dj
+ DO ji = 1, jpiglo-1
+ iju = jpiglo-ji
+ pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-2-jl)
+ END DO
+ END DO
+ DO ji = jpiglo/2+1, jpiglo-1
+ iju = jpiglo-ji
+ pt2d(ji,ijpjm1) = psgn * pt2d(iju,ijpjm1)
+ END DO
+ CASE ( 'I' ) ! ice U-V point
+ pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0.e0
+ DO jl = 0, ipr2dj
+ DO ji = 2 , jpiglo-1
+ ijt = jpiglo - ji + 2
+ pt2d(ji,ijpj+jl)= 0.5 * ( pt2d(ji,ijpj-1-jl) + psgn * pt2d(ijt,ijpj-1-jl) )
+ END DO
+ END DO
+ END SELECT
+
+ CASE DEFAULT ! * closed : the code probably never go through
+ PRINT * ,' ERROR '
+
+ END SELECT
+
+ END SUBROUTINE lbc_nfd_2d
+
+
+END PROGRAM cdfnorth_unfold
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/debian-science/packages/cdftools.git
More information about the debian-science-commits
mailing list